X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fhost-alieneval.lisp;h=e2f17572290c4acbe3a75a693fac055689d8afcf;hb=bee53328c93be3433477821131ab805557476c8b;hp=72a65e05d8d3ee319669b87ff89424c67347ffd9;hpb=6f408b4ce6a2f411618fe1bebf63ee08093a7d03;p=sbcl.git diff --git a/src/code/host-alieneval.lisp b/src/code/host-alieneval.lisp index 72a65e0..e2f1757 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*) @@ -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 @@ -772,7 +755,8 @@ `(sap-ref-double ,sap (/ ,offset sb!vm: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 @@ -862,6 +846,19 @@ (dimensions (required-argument) :type list)) (def-alien-type-translator array (ele-type &rest dims &environment env) + + ;; This declaration is a workaround for bug 119, which causes the + ;; EVERY #'INTEGERP expression below to be compiled incorrectly + ;; by the byte compiler. Since as of sbcl-0.pre7.x we are using + ;; the byte compiler to do all the tricky stuff for the 'interpreter', + ;; and since we use 'interpreted' definitions of these type translators + ;; at cross-compilation time, this means that cross-compilation + ;; doesn't work properly unless we force this function to be + ;; native compiled instead of byte-compiled. + ;; + ;; FIXME: So, when bug 119 is fixed, this declaration can go away. + (declare (optimize (speed 2))) ; i.e. not byte-compiled + (when dims (unless (typep (first dims) '(or index null)) (error "The first dimension is not a non-negative fixnum or NIL: ~S" @@ -871,15 +868,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) @@ -932,7 +929,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)))) @@ -1156,7 +1153,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 +1182,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")