X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=inline;f=src%2Fcode%2Fhost-alieneval.lisp;h=f2ac852547a0036f4c07ffd894f4b81791c9db4e;hb=dec94b039e8ec90baf21463df839a6181de606f6;hp=13c4223e46476cf427a77fabcc348803c8786e17;hpb=a530bbe337109d898d5b4a001fc8f1afa3b5dc39;p=sbcl.git diff --git a/src/code/host-alieneval.lisp b/src/code/host-alieneval.lisp index 13c4223..f2ac852 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,24 +846,25 @@ (dimensions (required-argument) :type list)) (def-alien-type-translator array (ele-type &rest dims &environment env) + (when dims - (unless (typep (first dims) '(or sb!kernel:index null)) + (unless (typep (first dims) '(or index null)) (error "The first dimension is not a non-negative fixnum or NIL: ~S" (first dims))) - (let ((loser (find-if-not #'(lambda (x) (typep x 'sb!kernel:index)) + (let ((loser (find-if-not #'(lambda (x) (typep x 'index)) (rest dims)))) (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 +917,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 +1141,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 +1170,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")