(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)
\f
;;;; 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)
;;; 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)
;;;; 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)
(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)))
(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"
(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
(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)))
\f
;;;; the POINTER type
(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)