X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fhost-alieneval.lisp;h=7bab89b392cc83dc677e35763a3f2fbea5198560;hb=4281f3b99891120fea5cabbc3a9d091b19f45995;hp=0a263e11fa5a7f5eb9621609dc839ff3b1c2b67b;hpb=78a057624fecd10d0fb2ead4ef02ffc361b1ee22;p=sbcl.git diff --git a/src/code/host-alieneval.lisp b/src/code/host-alieneval.lisp index 0a263e1..7bab89b 100644 --- a/src/code/host-alieneval.lisp +++ b/src/code/host-alieneval.lisp @@ -22,7 +22,7 @@ (defun guess-alignment (bits) (cond ((null bits) nil) - #!-x86 ((> bits 32) 64) + #!-(or x86 (and ppc darwin)) ((> bits 32) 64) ((> bits 16) 32) ((> bits 8) 16) ((> bits 1) 8) @@ -30,7 +30,7 @@ ;;;; ALIEN-TYPE-INFO stuff -(eval-when (:compile-toplevel :execute :load-toplevel) +(eval-when (#-sb-xc :compile-toplevel :execute :load-toplevel) (defstruct (alien-type-class (:copier nil)) (name nil :type symbol) @@ -115,7 +115,9 @@ ,@(mapcar (lambda (x) (if (atom x) x (car x))) slots) - ,@include-args))) + ,@include-args + ;; KLUDGE + &aux (alignment (or alignment (guess-alignment bits)))))) ,@slots))))) (def!macro define-alien-type-method ((class method) lambda-list &rest body) @@ -145,7 +147,7 @@ ;;; COMPILER-LET is no longer supported by ANSI or SBCL. Instead, we ;;; follow the suggestion in CLTL2 of using SYMBOL-MACROLET to achieve ;;; a similar effect. -(eval-when (:compile-toplevel :load-toplevel :execute) +(eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute) (defun auxiliary-type-definitions (env) (multiple-value-bind (result expanded-p) (sb!xc:macroexpand '&auxiliary-type-definitions& env) @@ -243,22 +245,21 @@ ;;;; alien type defining stuff (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 - 'define-alien-type-translator - :environment env) - `(eval-when (:compile-toplevel :load-toplevel :execute) - (defun ,defun-name (,whole ,env) - (declare (ignorable ,env)) - ,@decls - (block ,name - ,body)) - (%define-alien-type-translator ',name #',defun-name ,docs))))) - -(eval-when (:compile-toplevel :load-toplevel :execute) + (with-unique-names (whole env) + (let ((defun-name (symbolicate "ALIEN-" name "-TYPE-TRANSLATOR"))) + (multiple-value-bind (body decls docs) + (sb!kernel:parse-defmacro lambda-list whole body name + 'define-alien-type-translator + :environment env) + `(eval-when (:compile-toplevel :load-toplevel :execute) + (defun ,defun-name (,whole ,env) + (declare (ignorable ,env)) + ,@decls + (block ,name + ,body)) + (%define-alien-type-translator ',name #',defun-name ,docs)))))) + +(eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute) (defun %define-alien-type-translator (name translator docs) (declare (ignore docs)) (setf (info :alien-type :kind name) :primitive) @@ -284,9 +285,18 @@ (deprecation-warning 'def-alien-type 'define-alien-type) `(define-alien-type ,@rest)) -(eval-when (:compile-toplevel :load-toplevel :execute) +(eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute) (defun %def-auxiliary-alien-types (types) (dolist (info types) + ;; Clear up the type we're about to define from the toplevel + ;; *new-auxiliary-types* (local scopes take care of themselves). + ;; Unless this is done we never actually get back the full type + ;; from INFO, since the *new-auxiliary-types* have precendence. + (setf *new-auxiliary-types* + (remove info *new-auxiliary-types* + :test (lambda (a b) + (and (eq (first a) (first b)) + (eq (second a) (second b)))))) (destructuring-bind (kind name defn) info (macrolet ((frob (kind) `(let ((old (info :alien-type ,kind name))) @@ -322,10 +332,11 @@ (def!struct (alien-type (:make-load-form-fun sb!kernel:just-dump-it-normally) - (:constructor make-alien-type (&key class bits alignment))) + (:constructor make-alien-type (&key class bits alignment + &aux (alignment (or alignment (guess-alignment bits)))))) (class 'root :type symbol) (bits nil :type (or null unsigned-byte)) - (alignment (guess-alignment bits) :type (or null unsigned-byte))) + (alignment nil :type (or null unsigned-byte))) (def!method print-object ((type alien-type) stream) (print-unreadable-object (type stream :type t) (prin1 (unparse-alien-type type) stream))) @@ -556,12 +567,12 @@ (8 'signed-sap-ref-8) (16 'signed-sap-ref-16) (32 'signed-sap-ref-32) - #!+alpha (64 'signed-sap-ref-64)) + (64 'signed-sap-ref-64)) (case (alien-integer-type-bits type) (8 'sap-ref-8) (16 'sap-ref-16) (32 'sap-ref-32) - #!+alpha (64 'sap-ref-64))))) + (64 'sap-ref-64))))) (if ref-fun `(,ref-fun ,sap (/ ,offset sb!vm:n-byte-bits)) (error "cannot extract ~W-bit integers" @@ -596,10 +607,10 @@ (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. + 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 (define-alien-type-translator enum (&whole type name @@ -758,19 +769,6 @@ (declare (ignore type)) `(sap-ref-double ,sap (/ ,offset sb!vm:n-byte-bits))) -#!+long-float -(define-alien-type-class (long-float :include (float (bits #!+x86 96 - #!+sparc 128)) - :include-args (type))) - -#!+long-float -(define-alien-type-translator long-float () - (make-alien-long-float-type :type 'long-float)) - -#!+long-float -(define-alien-type-method (long-float :extract-gen) (type sap offset) - (declare (ignore type)) - `(sap-ref-long ,sap (/ ,offset sb!vm:n-byte-bits))) ;;;; the POINTER type @@ -921,32 +919,36 @@ (define-alien-type-translator union (name &rest fields &environment env) (parse-alien-record-type :union name fields env)) +;;; FIXME: This is really pretty horrible: we avoid creating new +;;; ALIEN-RECORD-TYPE objects when a live one is flitting around the +;;; system already. This way forwrd-references sans fields get get +;;; "updated" for free to contain the field info. Maybe rename +;;; MAKE-ALIEN-RECORD-TYPE to %MAKE-ALIEN-RECORD-TYPE and use +;;; ENSURE-ALIEN-RECORD-TYPE instead. --NS 20040729 (defun parse-alien-record-type (kind name fields 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)))) - (cond (old-fields - ;; KLUDGE: We can't easily compare the new fields - ;; against the old fields, since the old fields have - ;; already been parsed into an internal - ;; representation, so we just punt, assuming that - ;; they're consistent. -- WHN 200000505 - #| - (unless (equal fields old-fields) - ;; FIXME: Perhaps this should be a warning, and we - ;; should overwrite the old definition and proceed? - (error "mismatch in fields for ~S~% old ~S~% new ~S" - name old-fields fields)) - |# - old) - (t - (let ((new (make-alien-record-type :name name - :kind kind))) - (when name - (setf (auxiliary-alien-type kind name env) new)) - (parse-alien-record-fields new fields env) - new))))) + ;; KLUDGE: We can't easily compare the new fields + ;; against the old fields, since the old fields have + ;; already been parsed into an internal + ;; representation, so we just punt, assuming that + ;; they're consistent. -- WHN 200000505 + #| + (unless (equal fields old-fields) + ;; FIXME: Perhaps this should be a warning, and we + ;; should overwrite the old definition and proceed? + (error "mismatch in fields for ~S~% old ~S~% new ~S" + name old-fields fields)) + |# + (if old-fields + old + (let ((type (or old (make-alien-record-type :name name :kind kind)))) + (when (and name (not old)) + (setf (auxiliary-alien-type kind name env) type)) + (parse-alien-record-fields type fields env) + type)))) (name (or (auxiliary-alien-type kind name env) (setf (auxiliary-alien-type kind name env) @@ -1137,14 +1139,15 @@ (def!struct (local-alien-info (:make-load-form-fun sb!kernel:just-dump-it-normally) (:constructor make-local-alien-info - (&key type force-to-memory-p))) + (&key type force-to-memory-p + &aux (force-to-memory-p (or force-to-memory-p + (alien-array-type-p type) + (alien-record-type-p type)))))) ;; the type of the local alien (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)) - :type (member t nil))) + (force-to-memory-p nil :type (member t nil))) (def!method print-object ((info local-alien-info) stream) (print-unreadable-object (info stream :type t) (format stream