X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fhost-alieneval.lisp;h=7d525877a084bb7865c1a6199eab49164b1f8e94;hb=e33fb894f991b2926d8f3bace9058e4c0b2c3a37;hp=70582096b924cc9ad4ed553eb66baf8657dcda88;hpb=95a6db7329b91dd90d165dd4057b9b5098d34aa2;p=sbcl.git diff --git a/src/code/host-alieneval.lisp b/src/code/host-alieneval.lisp index 7058209..7d52587 100644 --- a/src/code/host-alieneval.lisp +++ b/src/code/host-alieneval.lisp @@ -11,6 +11,8 @@ ;;;; files for more information. (in-package "SB!ALIEN") + +(/show0 "host-alieneval.lisp 15") ;;;; utility functions @@ -30,7 +32,7 @@ (eval-when (:compile-toplevel :execute :load-toplevel) -(defstruct alien-type-class +(defstruct (alien-type-class (:copier nil)) (name nil :type symbol) (include nil :type (or null alien-type-class)) (unparse nil :type (or null function)) @@ -83,9 +85,9 @@ ;;; We define a keyword "BOA" constructor so that we can reference the ;;; slot names in init forms. -(def!macro def-alien-type-class ((name &key include include-args) &rest slots) - (let ((defstruct-name - (intern (concatenate 'string "ALIEN-" (symbol-name name) "-TYPE")))) +(def!macro define-alien-type-class ((name &key include include-args) + &rest slots) + (let ((defstruct-name (symbolicate "ALIEN-" name "-TYPE"))) (multiple-value-bind (include include-defstruct overrides) (etypecase include (null @@ -93,14 +95,12 @@ (symbol (values include - (intern (concatenate 'string - "ALIEN-" (symbol-name include) "-TYPE")) + (symbolicate "ALIEN-" include "-TYPE") nil)) (list (values (car include) - (intern (concatenate 'string - "ALIEN-" (symbol-name (car include)) "-TYPE")) + (symbolicate "ALIEN-" (car include) "-TYPE") (cdr include)))) `(progn (eval-when (:compile-toplevel :load-toplevel :execute) @@ -110,21 +110,16 @@ (:class ',name) ,@overrides) (:constructor - ,(intern (concatenate 'string "MAKE-" - (string defstruct-name))) + ,(symbolicate "MAKE-" defstruct-name) (&key class bits alignment - ,@(mapcar #'(lambda (x) - (if (atom x) x (car x))) + ,@(mapcar (lambda (x) + (if (atom x) x (car x))) slots) ,@include-args))) ,@slots))))) -(def!macro def-alien-type-method ((class method) lambda-list &rest body) - (let ((defun-name (intern (concatenate 'string - (symbol-name class) - "-" - (symbol-name method) - "-METHOD")))) +(def!macro define-alien-type-method ((class method) lambda-list &rest body) + (let ((defun-name (symbolicate class "-" method "-METHOD"))) `(progn (defun ,defun-name ,lambda-list ,@body) @@ -169,24 +164,16 @@ ,(let ((*new-auxiliary-types* nil)) ,@body))) -;;; FIXME: Now that *NEW-AUXILIARY-TYPES* is born initialized to NIL, -;;; we no longer need to make a distinction between this and -;;; %PARSE-ALIEN-TYPE. +;;; Parse TYPE as an alien type specifier and return the resultant +;;; ALIEN-TYPE structure. (defun parse-alien-type (type env) - (declare (type sb!kernel:lexenv env)) - #!+sb-doc - "Parse the list structure TYPE as an alien type specifier and return - the resultant ALIEN-TYPE structure." - (%parse-alien-type type env)) - -(defun %parse-alien-type (type env) - (declare (type sb!kernel:lexenv env)) + (declare (type (or sb!kernel:lexenv null) env)) (if (consp type) (let ((translator (info :alien-type :translator (car type)))) (unless translator (error "unknown alien type: ~S" type)) (funcall translator type env)) - (case (info :alien-type :kind type) + (ecase (info :alien-type :kind type) (:primitive (let ((translator (info :alien-type :translator type))) (unless translator @@ -199,7 +186,7 @@ (error "unknown alien type: ~S" type))))) (defun auxiliary-alien-type (kind name env) - (declare (type sb!kernel:lexenv env)) + (declare (type (or sb!kernel:lexenv null) env)) (flet ((aux-defn-matches (x) (and (eq (first x) kind) (eq (second x) name)))) (let ((in-auxiliaries @@ -216,7 +203,7 @@ (info :alien-type :enum name))))))) (defun (setf auxiliary-alien-type) (new-value kind name env) - (declare (type sb!kernel:lexenv env)) + (declare (type (or sb!kernel:lexenv null) env)) (flet ((aux-defn-matches (x) (and (eq (first x) kind) (eq (second x) name)))) (when (find-if #'aux-defn-matches *new-auxiliary-types*) @@ -255,13 +242,13 @@ ;;;; alien type defining stuff -(def!macro def-alien-type-translator (name lambda-list &body body) +(def!macro define-alien-type-translator (name lambda-list &body body) (let ((whole (gensym "WHOLE")) (env (gensym "ENV")) (defun-name (symbolicate "ALIEN-" name "-TYPE-TRANSLATOR"))) (multiple-value-bind (body decls docs) (sb!kernel:parse-defmacro lambda-list whole body name - 'def-alien-type-translator + 'define-alien-type-translator :environment env) `(eval-when (:compile-toplevel :load-toplevel :execute) (defun ,defun-name (,whole ,env) @@ -269,10 +256,10 @@ ,@decls (block ,name ,body)) - (%def-alien-type-translator ',name #',defun-name ,docs))))) + (%define-alien-type-translator ',name #',defun-name ,docs))))) (eval-when (:compile-toplevel :load-toplevel :execute) - (defun %def-alien-type-translator (name translator docs) + (defun %define-alien-type-translator (name translator docs) (declare (ignore docs)) (setf (info :alien-type :kind name) :primitive) (setf (info :alien-type :translator name) translator) @@ -281,7 +268,7 @@ (setf (fdocumentation name 'alien-type) docs) name)) -(def!macro def-alien-type (name type &environment env) +(def!macro define-alien-type (name type &environment env) #!+sb-doc "Define the alien type NAME to be equivalent to TYPE. Name may be NIL for STRUCT and UNION types, in which case the name is taken from the type @@ -292,7 +279,10 @@ ,@(when *new-auxiliary-types* `((%def-auxiliary-alien-types ',*new-auxiliary-types*))) ,@(when name - `((%def-alien-type ',name ',alien-type))))))) + `((%define-alien-type ',name ',alien-type))))))) +(def!macro def-alien-type (&rest rest) + (deprecation-warning 'def-alien-type 'define-alien-type) + `(define-alien-type ,@rest)) (eval-when (:compile-toplevel :load-toplevel :execute) (defun %def-auxiliary-alien-types (types) @@ -309,7 +299,7 @@ (:struct (frob :struct)) (:union (frob :union)) (:enum (frob :enum))))))) - (defun %def-alien-type (name new) + (defun %define-alien-type (name new) (ecase (info :alien-type :kind name) (:primitive (error "~S is a built-in alien type." name)) @@ -342,49 +332,49 @@ ;;;; the SAP type -(def-alien-type-class (system-area-pointer)) +(define-alien-type-class (system-area-pointer)) -(def-alien-type-translator system-area-pointer () +(define-alien-type-translator system-area-pointer () (make-alien-system-area-pointer-type - :bits #!-alpha sb!vm:word-bits #!+alpha 64)) + :bits #!-alpha sb!vm:n-word-bits #!+alpha 64)) -(def-alien-type-method (system-area-pointer :unparse) (type) +(define-alien-type-method (system-area-pointer :unparse) (type) (declare (ignore type)) 'system-area-pointer) -(def-alien-type-method (system-area-pointer :lisp-rep) (type) +(define-alien-type-method (system-area-pointer :lisp-rep) (type) (declare (ignore type)) 'system-area-pointer) -(def-alien-type-method (system-area-pointer :alien-rep) (type) +(define-alien-type-method (system-area-pointer :alien-rep) (type) (declare (ignore type)) 'system-area-pointer) -(def-alien-type-method (system-area-pointer :naturalize-gen) (type alien) +(define-alien-type-method (system-area-pointer :naturalize-gen) (type alien) (declare (ignore type)) alien) -(def-alien-type-method (system-area-pointer :deport-gen) (type object) +(define-alien-type-method (system-area-pointer :deport-gen) (type object) (declare (ignore type)) (/noshow "doing alien type method SYSTEM-AREA-POINTER :DEPORT-GEN" object) object) -(def-alien-type-method (system-area-pointer :extract-gen) (type sap offset) +(define-alien-type-method (system-area-pointer :extract-gen) (type sap offset) (declare (ignore type)) - `(sap-ref-sap ,sap (/ ,offset sb!vm:byte-bits))) + `(sap-ref-sap ,sap (/ ,offset sb!vm:n-byte-bits))) ;;;; the ALIEN-VALUE type -(def-alien-type-class (alien-value :include system-area-pointer)) +(define-alien-type-class (alien-value :include system-area-pointer)) -(def-alien-type-method (alien-value :lisp-rep) (type) +(define-alien-type-method (alien-value :lisp-rep) (type) (declare (ignore type)) nil) -(def-alien-type-method (alien-value :naturalize-gen) (type alien) +(define-alien-type-method (alien-value :naturalize-gen) (type alien) `(%sap-alien ,alien ',type)) -(def-alien-type-method (alien-value :deport-gen) (type value) +(define-alien-type-method (alien-value :deport-gen) (type value) (declare (ignore type)) (/noshow "doing alien type method ALIEN-VALUE :DEPORT-GEN" value) `(alien-sap ,value)) @@ -395,10 +385,10 @@ (def!struct (heap-alien-info (:make-load-form-fun sb!kernel:just-dump-it-normally)) ;; The type of this alien. - (type (required-argument) :type alien-type) + (type (missing-arg) :type alien-type) ;; The form to evaluate to produce the SAP pointing to where in the heap ;; it is. - (sap-form (required-argument))) + (sap-form (missing-arg))) (def!method print-object ((info heap-alien-info) stream) (print-unreadable-object (info stream :type t) (funcall (formatter "~S ~S") @@ -475,90 +465,90 @@ ;;;; default methods -(def-alien-type-method (root :unparse) (type) +(define-alien-type-method (root :unparse) (type) `( ,(type-of type))) -(def-alien-type-method (root :type=) (type1 type2) +(define-alien-type-method (root :type=) (type1 type2) (declare (ignore type1 type2)) t) -(def-alien-type-method (root :subtypep) (type1 type2) +(define-alien-type-method (root :subtypep) (type1 type2) (alien-type-= type1 type2)) -(def-alien-type-method (root :lisp-rep) (type) +(define-alien-type-method (root :lisp-rep) (type) (declare (ignore type)) nil) -(def-alien-type-method (root :alien-rep) (type) +(define-alien-type-method (root :alien-rep) (type) (declare (ignore type)) '*) -(def-alien-type-method (root :naturalize-gen) (type alien) +(define-alien-type-method (root :naturalize-gen) (type alien) (declare (ignore alien)) (error "cannot represent ~S typed aliens" type)) -(def-alien-type-method (root :deport-gen) (type object) +(define-alien-type-method (root :deport-gen) (type object) (declare (ignore object)) (error "cannot represent ~S typed aliens" type)) -(def-alien-type-method (root :extract-gen) (type sap offset) +(define-alien-type-method (root :extract-gen) (type sap offset) (declare (ignore sap offset)) (error "cannot represent ~S typed aliens" type)) -(def-alien-type-method (root :deposit-gen) (type sap offset value) +(define-alien-type-method (root :deposit-gen) (type sap offset value) `(setf ,(invoke-alien-type-method :extract-gen type sap offset) ,value)) -(def-alien-type-method (root :arg-tn) (type state) +(define-alien-type-method (root :arg-tn) (type state) (declare (ignore state)) (error "Aliens of type ~S cannot be passed as arguments to CALL-OUT." (unparse-alien-type type))) -(def-alien-type-method (root :result-tn) (type state) +(define-alien-type-method (root :result-tn) (type state) (declare (ignore state)) (error "Aliens of type ~S cannot be returned from CALL-OUT." (unparse-alien-type type))) ;;;; the INTEGER type -(def-alien-type-class (integer) +(define-alien-type-class (integer) (signed t :type (member t nil))) -(def-alien-type-translator signed (&optional (bits sb!vm:word-bits)) +(define-alien-type-translator signed (&optional (bits sb!vm:n-word-bits)) (make-alien-integer-type :bits bits)) -(def-alien-type-translator integer (&optional (bits sb!vm:word-bits)) +(define-alien-type-translator integer (&optional (bits sb!vm:n-word-bits)) (make-alien-integer-type :bits bits)) -(def-alien-type-translator unsigned (&optional (bits sb!vm:word-bits)) +(define-alien-type-translator unsigned (&optional (bits sb!vm:n-word-bits)) (make-alien-integer-type :bits bits :signed nil)) -(def-alien-type-method (integer :unparse) (type) +(define-alien-type-method (integer :unparse) (type) (list (if (alien-integer-type-signed type) 'signed 'unsigned) (alien-integer-type-bits type))) -(def-alien-type-method (integer :type=) (type1 type2) +(define-alien-type-method (integer :type=) (type1 type2) (and (eq (alien-integer-type-signed type1) (alien-integer-type-signed type2)) (= (alien-integer-type-bits type1) (alien-integer-type-bits type2)))) -(def-alien-type-method (integer :lisp-rep) (type) +(define-alien-type-method (integer :lisp-rep) (type) (list (if (alien-integer-type-signed type) 'signed-byte 'unsigned-byte) (alien-integer-type-bits type))) -(def-alien-type-method (integer :alien-rep) (type) +(define-alien-type-method (integer :alien-rep) (type) (list (if (alien-integer-type-signed type) 'signed-byte 'unsigned-byte) (alien-integer-type-bits type))) -(def-alien-type-method (integer :naturalize-gen) (type alien) +(define-alien-type-method (integer :naturalize-gen) (type alien) (declare (ignore type)) alien) -(def-alien-type-method (integer :deport-gen) (type value) +(define-alien-type-method (integer :deport-gen) (type value) (declare (ignore type)) value) -(def-alien-type-method (integer :extract-gen) (type sap offset) +(define-alien-type-method (integer :extract-gen) (type sap offset) (declare (type alien-integer-type type)) (let ((ref-fun (if (alien-integer-type-signed type) @@ -573,46 +563,46 @@ (32 'sap-ref-32) #!+alpha (64 'sap-ref-64))))) (if ref-fun - `(,ref-fun ,sap (/ ,offset sb!vm:byte-bits)) - (error "cannot extract ~D bit integers" + `(,ref-fun ,sap (/ ,offset sb!vm:n-byte-bits)) + (error "cannot extract ~W-bit integers" (alien-integer-type-bits type))))) ;;;; the BOOLEAN type -(def-alien-type-class (boolean :include integer :include-args (signed))) +(define-alien-type-class (boolean :include integer :include-args (signed))) ;;; FIXME: Check to make sure that we aren't attaching user-readable ;;; stuff to CL:BOOLEAN in any way which impairs ANSI compliance. -(def-alien-type-translator boolean (&optional (bits sb!vm:word-bits)) +(define-alien-type-translator boolean (&optional (bits sb!vm:n-word-bits)) (make-alien-boolean-type :bits bits :signed nil)) -(def-alien-type-method (boolean :unparse) (type) +(define-alien-type-method (boolean :unparse) (type) `(boolean ,(alien-boolean-type-bits type))) -(def-alien-type-method (boolean :lisp-rep) (type) +(define-alien-type-method (boolean :lisp-rep) (type) (declare (ignore type)) `(member t nil)) -(def-alien-type-method (boolean :naturalize-gen) (type alien) +(define-alien-type-method (boolean :naturalize-gen) (type alien) (declare (ignore type)) `(not (zerop ,alien))) -(def-alien-type-method (boolean :deport-gen) (type value) +(define-alien-type-method (boolean :deport-gen) (type value) (declare (ignore type)) `(if ,value 1 0)) ;;;; the ENUM type -(def-alien-type-class (enum :include (integer (:bits 32)) - :include-args (signed)) +(define-alien-type-class (enum :include (integer (:bits 32)) + :include-args (signed)) name ; name of this enum (if any) from ; alist from keywords to integers. to ; alist or vector from integers to keywords. kind ; Kind of from mapping, :vector or :alist. offset) ; Offset to add to value for :vector from mapping. -(def-alien-type-translator enum (&whole type - name +(define-alien-type-translator enum (&whole + type name &rest mappings &environment env) (cond (mappings @@ -687,7 +677,7 @@ from-alist) :kind :alist)))))) -(def-alien-type-method (enum :unparse) (type) +(define-alien-type-method (enum :unparse) (type) `(enum ,(alien-enum-type-name type) ,@(let ((prev -1)) (mapcar #'(lambda (mapping) @@ -700,16 +690,16 @@ (setf prev value)))) (alien-enum-type-from type))))) -(def-alien-type-method (enum :type=) (type1 type2) +(define-alien-type-method (enum :type=) (type1 type2) (and (eq (alien-enum-type-name type1) (alien-enum-type-name type2)) (equal (alien-enum-type-from type1) (alien-enum-type-from type2)))) -(def-alien-type-method (enum :lisp-rep) (type) +(define-alien-type-method (enum :lisp-rep) (type) `(member ,@(mapcar #'car (alien-enum-type-from type)))) -(def-alien-type-method (enum :naturalize-gen) (type alien) +(define-alien-type-method (enum :naturalize-gen) (type alien) (ecase (alien-enum-type-kind type) (:vector `(svref ',(alien-enum-type-to type) @@ -720,7 +710,7 @@ `(,(car mapping) ,(cdr mapping))) (alien-enum-type-to type)))))) -(def-alien-type-method (enum :deport-gen) (type value) +(define-alien-type-method (enum :deport-gen) (type value) `(ecase ,value ,@(mapcar #'(lambda (mapping) `(,(car mapping) ,(cdr mapping))) @@ -728,76 +718,78 @@ ;;;; the FLOAT types -(def-alien-type-class (float) - (type (required-argument) :type symbol)) +(define-alien-type-class (float) + (type (missing-arg) :type symbol)) -(def-alien-type-method (float :unparse) (type) +(define-alien-type-method (float :unparse) (type) (alien-float-type-type type)) -(def-alien-type-method (float :lisp-rep) (type) +(define-alien-type-method (float :lisp-rep) (type) (alien-float-type-type type)) -(def-alien-type-method (float :alien-rep) (type) +(define-alien-type-method (float :alien-rep) (type) (alien-float-type-type type)) -(def-alien-type-method (float :naturalize-gen) (type alien) +(define-alien-type-method (float :naturalize-gen) (type alien) (declare (ignore type)) alien) -(def-alien-type-method (float :deport-gen) (type value) +(define-alien-type-method (float :deport-gen) (type value) (declare (ignore type)) value) -(def-alien-type-class (single-float :include (float (:bits 32)) - :include-args (type))) +(define-alien-type-class (single-float :include (float (:bits 32)) + :include-args (type))) -(def-alien-type-translator single-float () +(define-alien-type-translator single-float () (make-alien-single-float-type :type 'single-float)) -(def-alien-type-method (single-float :extract-gen) (type sap offset) +(define-alien-type-method (single-float :extract-gen) (type sap offset) (declare (ignore type)) - `(sap-ref-single ,sap (/ ,offset sb!vm:byte-bits))) + `(sap-ref-single ,sap (/ ,offset sb!vm:n-byte-bits))) -(def-alien-type-class (double-float :include (float (:bits 64)) - :include-args (type))) +(define-alien-type-class (double-float :include (float (:bits 64)) + :include-args (type))) -(def-alien-type-translator double-float () +(define-alien-type-translator double-float () (make-alien-double-float-type :type 'double-float)) -(def-alien-type-method (double-float :extract-gen) (type sap offset) +(define-alien-type-method (double-float :extract-gen) (type sap offset) (declare (ignore type)) - `(sap-ref-double ,sap (/ ,offset sb!vm:byte-bits))) + `(sap-ref-double ,sap (/ ,offset sb!vm:n-byte-bits))) #!+long-float -(def-alien-type-class (long-float :include (float (:bits #!+x86 96 #!+sparc 128)) - :include-args (type))) +(define-alien-type-class (long-float :include (float (:bits #!+x86 96 + #!+sparc 128)) + :include-args (type))) #!+long-float -(def-alien-type-translator long-float () +(define-alien-type-translator long-float () (make-alien-long-float-type :type 'long-float)) #!+long-float -(def-alien-type-method (long-float :extract-gen) (type sap offset) +(define-alien-type-method (long-float :extract-gen) (type sap offset) (declare (ignore type)) - `(sap-ref-long ,sap (/ ,offset sb!vm:byte-bits))) + `(sap-ref-long ,sap (/ ,offset sb!vm:n-byte-bits))) ;;;; the POINTER type -(def-alien-type-class (pointer :include (alien-value (:bits - #!-alpha sb!vm:word-bits - #!+alpha 64))) +(define-alien-type-class (pointer :include (alien-value (:bits + #!-alpha + sb!vm:n-word-bits + #!+alpha 64))) (to nil :type (or alien-type null))) -(def-alien-type-translator * (to &environment env) +(define-alien-type-translator * (to &environment env) (make-alien-pointer-type :to (if (eq to t) nil (parse-alien-type to env)))) -(def-alien-type-method (pointer :unparse) (type) +(define-alien-type-method (pointer :unparse) (type) (let ((to (alien-pointer-type-to type))) `(* ,(if to (%unparse-alien-type to) t)))) -(def-alien-type-method (pointer :type=) (type1 type2) +(define-alien-type-method (pointer :type=) (type1 type2) (let ((to1 (alien-pointer-type-to type1)) (to2 (alien-pointer-type-to type2))) (if to1 @@ -806,7 +798,7 @@ nil) (null to2)))) -(def-alien-type-method (pointer :subtypep) (type1 type2) +(define-alien-type-method (pointer :subtypep) (type1 type2) (and (alien-pointer-type-p type2) (let ((to1 (alien-pointer-type-to type1)) (to2 (alien-pointer-type-to type2))) @@ -816,7 +808,7 @@ t) (null to2))))) -(def-alien-type-method (pointer :deport-gen) (type value) +(define-alien-type-method (pointer :deport-gen) (type value) (/noshow "doing alien type method POINTER :DEPORT-GEN" type value) (values ;; FIXME: old version, highlighted a bug in xc optimization @@ -840,13 +832,13 @@ ;;;; the MEM-BLOCK type -(def-alien-type-class (mem-block :include alien-value)) +(define-alien-type-class (mem-block :include alien-value)) -(def-alien-type-method (mem-block :extract-gen) (type sap offset) +(define-alien-type-method (mem-block :extract-gen) (type sap offset) (declare (ignore type)) - `(sap+ ,sap (/ ,offset sb!vm:byte-bits))) + `(sap+ ,sap (/ ,offset sb!vm:n-byte-bits))) -(def-alien-type-method (mem-block :deposit-gen) (type sap offset value) +(define-alien-type-method (mem-block :deposit-gen) (type sap offset value) (let ((bits (alien-mem-block-type-bits type))) (unless bits (error "can't deposit aliens of type ~S (unknown size)" type)) @@ -854,11 +846,12 @@ ;;;; the ARRAY type -(def-alien-type-class (array :include mem-block) - (element-type (required-argument) :type alien-type) - (dimensions (required-argument) :type list)) +(define-alien-type-class (array :include mem-block) + (element-type (missing-arg) :type alien-type) + (dimensions (missing-arg) :type list)) + +(define-alien-type-translator array (ele-type &rest dims &environment env) -(def-alien-type-translator array (ele-type &rest dims &environment env) (when dims (unless (typep (first dims) '(or index null)) (error "The first dimension is not a non-negative fixnum or NIL: ~S" @@ -868,28 +861,28 @@ (when loser (error "A dimension is not a non-negative fixnum: ~S" loser)))) - (let ((type (parse-alien-type ele-type env))) + (let ((parsed-ele-type (parse-alien-type ele-type env))) (make-alien-array-type - :element-type type + :element-type parsed-ele-type :dimensions dims - :alignment (alien-type-alignment type) - :bits (if (and (alien-type-bits type) + :alignment (alien-type-alignment parsed-ele-type) + :bits (if (and (alien-type-bits parsed-ele-type) (every #'integerp dims)) - (* (align-offset (alien-type-bits type) - (alien-type-alignment type)) + (* (align-offset (alien-type-bits parsed-ele-type) + (alien-type-alignment parsed-ele-type)) (reduce #'* dims)))))) -(def-alien-type-method (array :unparse) (type) +(define-alien-type-method (array :unparse) (type) `(array ,(%unparse-alien-type (alien-array-type-element-type type)) ,@(alien-array-type-dimensions type))) -(def-alien-type-method (array :type=) (type1 type2) +(define-alien-type-method (array :type=) (type1 type2) (and (equal (alien-array-type-dimensions type1) (alien-array-type-dimensions type2)) (alien-type-= (alien-array-type-element-type type1) (alien-array-type-element-type type2)))) -(def-alien-type-method (array :subtypep) (type1 type2) +(define-alien-type-method (array :subtypep) (type1 type2) (and (alien-array-type-p type2) (let ((dim1 (alien-array-type-dimensions type1)) (dim2 (alien-array-type-dimensions type2))) @@ -905,8 +898,8 @@ (def!struct (alien-record-field (:make-load-form-fun sb!kernel:just-dump-it-normally)) - (name (required-argument) :type symbol) - (type (required-argument) :type alien-type) + (name (missing-arg) :type symbol) + (type (missing-arg) :type alien-type) (bits nil :type (or unsigned-byte null)) (offset 0 :type unsigned-byte)) (def!method print-object ((field alien-record-field) stream) @@ -917,19 +910,19 @@ (alien-record-field-name field) (alien-record-field-bits field)))) -(def-alien-type-class (record :include mem-block) +(define-alien-type-class (record :include mem-block) (kind :struct :type (member :struct :union)) (name nil :type (or symbol null)) (fields nil :type list)) -(def-alien-type-translator struct (name &rest fields &environment env) +(define-alien-type-translator struct (name &rest fields &environment env) (parse-alien-record-type :struct name fields env)) -(def-alien-type-translator union (name &rest fields &environment env) +(define-alien-type-translator union (name &rest fields &environment env) (parse-alien-record-type :union name fields env)) (defun parse-alien-record-type (kind name fields env) - (declare (type sb!kernel:lexenv env)) + (declare (type (or sb!kernel:lexenv null) env)) (cond (fields (let* ((old (and name (auxiliary-alien-type kind name env))) (old-fields (and old (alien-record-type-fields old)))) @@ -998,7 +991,7 @@ (setf (alien-record-type-bits result) (align-offset total-bits overall-alignment)))) -(def-alien-type-method (record :unparse) (type) +(define-alien-type-method (record :unparse) (type) `(,(case (alien-record-type-kind type) (:struct 'struct) (:union 'union) @@ -1065,7 +1058,7 @@ (type-= field1 field2 (1+ depth)))) (return nil)))))) -(def-alien-type-method (record :type=) (type1 type2) +(define-alien-type-method (record :type=) (type1 type2) (and (eq (alien-record-type-name type1) (alien-record-type-name type2)) (eq (alien-record-type-kind type1) @@ -1075,41 +1068,41 @@ (record-fields-match (alien-record-type-fields type1) (alien-record-type-fields type2) 0))) -;;;; the FUNCTION and VALUES types +;;;; the FUNCTION and VALUES alien types (defvar *values-type-okay* nil) -(def-alien-type-class (function :include mem-block) - (result-type (required-argument) :type alien-type) - (arg-types (required-argument) :type list) +(define-alien-type-class (fun :include mem-block) + (result-type (missing-arg) :type alien-type) + (arg-types (missing-arg) :type list) (stub nil :type (or null function))) -(def-alien-type-translator function (result-type &rest arg-types +(define-alien-type-translator function (result-type &rest arg-types &environment env) - (make-alien-function-type + (make-alien-fun-type :result-type (let ((*values-type-okay* t)) (parse-alien-type result-type env)) :arg-types (mapcar (lambda (arg-type) (parse-alien-type arg-type env)) arg-types))) -(def-alien-type-method (function :unparse) (type) - `(function ,(%unparse-alien-type (alien-function-type-result-type type)) +(define-alien-type-method (fun :unparse) (type) + `(function ,(%unparse-alien-type (alien-fun-type-result-type type)) ,@(mapcar #'%unparse-alien-type - (alien-function-type-arg-types type)))) + (alien-fun-type-arg-types type)))) -(def-alien-type-method (function :type=) (type1 type2) - (and (alien-type-= (alien-function-type-result-type type1) - (alien-function-type-result-type type2)) - (= (length (alien-function-type-arg-types type1)) - (length (alien-function-type-arg-types type2))) +(define-alien-type-method (fun :type=) (type1 type2) + (and (alien-type-= (alien-fun-type-result-type type1) + (alien-fun-type-result-type type2)) + (= (length (alien-fun-type-arg-types type1)) + (length (alien-fun-type-arg-types type2))) (every #'alien-type-= - (alien-function-type-arg-types type1) - (alien-function-type-arg-types type2)))) + (alien-fun-type-arg-types type1) + (alien-fun-type-arg-types type2)))) -(def-alien-type-class (values) - (values (required-argument) :type list)) +(define-alien-type-class (values) + (values (missing-arg) :type list)) -(def-alien-type-translator values (&rest values &environment env) +(define-alien-type-translator values (&rest values &environment env) (unless *values-type-okay* (error "cannot use values types here")) (let ((*values-type-okay* nil)) @@ -1117,11 +1110,11 @@ :values (mapcar (lambda (alien-type) (parse-alien-type alien-type env)) values)))) -(def-alien-type-method (values :unparse) (type) +(define-alien-type-method (values :unparse) (type) `(values ,@(mapcar #'%unparse-alien-type (alien-values-type-values type)))) -(def-alien-type-method (values :type=) (type1 type2) +(define-alien-type-method (values :type=) (type1 type2) (and (= (length (alien-values-type-values type1)) (length (alien-values-type-values type2))) (every #'alien-type-= @@ -1139,10 +1132,11 @@ (:constructor make-local-alien-info (&key type force-to-memory-p))) ;; the type of the local alien - (type (required-argument) :type alien-type) - ;; T if this local alien must be forced into memory. Using the ADDR macro + (type (missing-arg) :type alien-type) + ;; Must this local alien be forced into memory? Using the ADDR macro ;; on a local alien will set this. - (force-to-memory-p (or (alien-array-type-p type) (alien-record-type-p type)) + (force-to-memory-p (or (alien-array-type-p type) + (alien-record-type-p type)) :type (member t nil))) (def!method print-object ((info local-alien-info) stream) (print-unreadable-object (info stream :type t) @@ -1153,7 +1147,7 @@ ;;;; the ADDR macro -(sb!kernel:defmacro-mundanely addr (expr &environment env) +(defmacro-mundanely addr (expr &environment env) #!+sb-doc "Return an Alien pointer to the data addressed by Expr, which must be a call to SLOT or DEREF, or a reference to an Alien variable." @@ -1182,3 +1176,5 @@ (when (eq kind :alien) `(%heap-alien-addr ',(info :variable :alien-info form)))))) (error "~S is not a valid L-value." form)))) + +(/show0 "host-alieneval.lisp end of file")