X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=sidebyside;f=src%2Fcode%2Fhost-alieneval.lisp;h=be87e0f28d9b3e2f3142e6a8db900515dccc8281;hb=a10eba73462a7203914114f3a4bdac98c741ec08;hp=72a65e05d8d3ee319669b87ff89424c67347ffd9;hpb=6f408b4ce6a2f411618fe1bebf63ee08093a7d03;p=sbcl.git diff --git a/src/code/host-alieneval.lisp b/src/code/host-alieneval.lisp index 72a65e0..be87e0f 100644 --- a/src/code/host-alieneval.lisp +++ b/src/code/host-alieneval.lisp @@ -12,8 +12,7 @@ (in-package "SB!ALIEN") -(file-comment - "$Header$") +(/show0 "host-alieneval.lisp 15") ;;;; utility functions @@ -33,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)) @@ -64,7 +63,7 @@ (setf (gethash name *alien-type-classes*) (make-alien-type-class :name name :include include))))) -(defconstant method-slot-alist +(defparameter *method-slot-alist* '((:unparse . alien-type-class-unparse) (:type= . alien-type-class-type=) (:subtypep . alien-type-class-subtypep) @@ -79,16 +78,15 @@ (:result-tn . alien-type-class-result-tn))) (defun method-slot (method) - (cdr (or (assoc method method-slot-alist) + (cdr (or (assoc method *method-slot-alist*) (error "no method ~S" method)))) ) ; EVAL-WHEN -;;; We define a keyword "BOA" constructor so that we can reference the slot -;;; names in init forms. +;;; 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")))) + (let ((defstruct-name (symbolicate "ALIEN-" name "-TYPE"))) (multiple-value-bind (include include-defstruct overrides) (etypecase include (null @@ -96,14 +94,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) @@ -113,21 +109,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")))) + (let ((defun-name (symbolicate class "-" method "-METHOD"))) `(progn (defun ,defun-name ,lambda-list ,@body) @@ -172,24 +163,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 @@ -202,7 +185,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 @@ -219,7 +202,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*) @@ -349,7 +332,7 @@ (def-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) (declare (ignore type)) @@ -374,7 +357,7 @@ (def-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 @@ -398,10 +381,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") @@ -526,13 +509,13 @@ (def-alien-type-class (integer) (signed t :type (member t nil))) -(def-alien-type-translator signed (&optional (bits sb!vm:word-bits)) +(def-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)) +(def-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)) +(def-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) @@ -576,7 +559,7 @@ (32 'sap-ref-32) #!+alpha (64 'sap-ref-64))))) (if ref-fun - `(,ref-fun ,sap (/ ,offset sb!vm:byte-bits)) + `(,ref-fun ,sap (/ ,offset sb!vm:n-byte-bits)) (error "cannot extract ~D bit integers" (alien-integer-type-bits type))))) @@ -586,7 +569,7 @@ ;;; 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)) +(def-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) @@ -614,8 +597,8 @@ 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 +(def-alien-type-translator enum (&whole + type name &rest mappings &environment env) (cond (mappings @@ -732,7 +715,7 @@ ;;;; the FLOAT types (def-alien-type-class (float) - (type (required-argument) :type symbol)) + (type (missing-arg) :type symbol)) (def-alien-type-method (float :unparse) (type) (alien-float-type-type type)) @@ -759,7 +742,7 @@ (def-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))) @@ -769,10 +752,11 @@ (def-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)) +(def-alien-type-class (long-float :include (float (:bits #!+x86 96 + #!+sparc 128)) :include-args (type))) #!+long-float @@ -782,12 +766,13 @@ #!+long-float (def-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 + sb!vm:n-word-bits #!+alpha 64))) (to nil :type (or alien-type null))) @@ -847,7 +832,7 @@ (def-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) (let ((bits (alien-mem-block-type-bits type))) @@ -858,10 +843,11 @@ ;;;; the ARRAY type (def-alien-type-class (array :include mem-block) - (element-type (required-argument) :type alien-type) - (dimensions (required-argument) :type list)) + (element-type (missing-arg) :type alien-type) + (dimensions (missing-arg) :type list)) (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" @@ -871,15 +857,15 @@ (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) @@ -908,8 +894,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) @@ -932,7 +918,7 @@ (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)))) @@ -1078,39 +1064,39 @@ (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) +(def-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 &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)) +(def-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))) +(def-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)) + (values (missing-arg) :type list)) (def-alien-type-translator values (&rest values &environment env) (unless *values-type-okay* @@ -1142,10 +1128,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) @@ -1156,7 +1143,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." @@ -1185,3 +1172,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")