X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fhost-alieneval.lisp;h=4b75b315b4b3f62d6b0b43cdf14b06fc86be27c4;hb=3bd7a97d1b11a2b0aee086ef211cae807f3dfc35;hp=13c4223e46476cf427a77fabcc348803c8786e17;hpb=a530bbe337109d898d5b4a001fc8f1afa3b5dc39;p=sbcl.git diff --git a/src/code/host-alieneval.lisp b/src/code/host-alieneval.lisp index 13c4223..4b75b31 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) @@ -176,14 +167,14 @@ ;;; we no longer need to make a distinction between this and ;;; %PARSE-ALIEN-TYPE. (defun parse-alien-type (type env) - (declare (type sb!kernel:lexenv env)) + (declare (type (or sb!kernel:lexenv null) 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 @@ -202,7 +193,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 +210,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 +605,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 +763,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 @@ -863,10 +855,10 @@ (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)))) @@ -932,7 +924,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 +1148,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 +1177,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")