;;;; files for more information.
(in-package "SB!ALIEN")
+
+(/show0 "host-alieneval.lisp 15")
\f
;;;; utility functions
(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
+(defstruct (alien-type-class (:copier nil))
(name nil :type symbol)
(include nil :type (or null alien-type-class))
(unparse nil :type (or null function))
;;; 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"))))
+(def!macro define-alien-type-class ((name &key include include-args)
+ &rest slots)
+ (let ((defstruct-name (symbolicate "ALIEN-" name "-TYPE")))
(multiple-value-bind (include include-defstruct overrides)
(etypecase include
(null
(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)
(create-alien-type-class-if-necessary ',name ',(or include 'root)))
(def!struct (,defstruct-name
(:include ,include-defstruct
- (:class ',name)
+ (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)))
+ ,@include-args
+ ;; KLUDGE
+ &aux (alignment (or alignment (guess-alignment bits))))))
,@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"))))
+(def!macro define-alien-type-method ((class method) lambda-list &rest body)
+ (let ((defun-name (symbolicate class "-" method "-METHOD")))
`(progn
(defun ,defun-name ,lambda-list
,@body)
;;; 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)
,(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
(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
(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*)
\f
;;;; alien type defining stuff
-(def!macro def-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
- 'def-alien-type-translator
- :environment env)
- `(eval-when (:compile-toplevel :load-toplevel :execute)
- (defun ,defun-name (,whole ,env)
- (declare (ignorable ,env))
- ,@decls
- (block ,name
- ,body))
- (%def-alien-type-translator ',name #',defun-name ,docs)))))
-
-(eval-when (:compile-toplevel :load-toplevel :execute)
- (defun %def-alien-type-translator (name translator docs)
+(def!macro define-alien-type-translator (name lambda-list &body body)
+ (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)
(setf (info :alien-type :translator name) translator)
(setf (fdocumentation name 'alien-type) docs)
name))
-(def!macro def-alien-type (name type &environment env)
+(def!macro define-alien-type (name type &environment env)
#!+sb-doc
"Define the alien type NAME to be equivalent to TYPE. Name may be NIL for
STRUCT and UNION types, in which case the name is taken from the type
,@(when *new-auxiliary-types*
`((%def-auxiliary-alien-types ',*new-auxiliary-types*)))
,@(when name
- `((%def-alien-type ',name ',alien-type)))))))
+ `((%define-alien-type ',name ',alien-type)))))))
+(def!macro def-alien-type (&rest rest)
+ (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)))
(:struct (frob :struct))
(:union (frob :union))
(:enum (frob :enum)))))))
- (defun %def-alien-type (name new)
+ (defun %define-alien-type (name new)
(ecase (info :alien-type :kind name)
(:primitive
(error "~S is a built-in alien type." name))
(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)))
\f
;;;; the SAP type
-(def-alien-type-class (system-area-pointer))
+(define-alien-type-class (system-area-pointer))
-(def-alien-type-translator system-area-pointer ()
+(define-alien-type-translator system-area-pointer ()
(make-alien-system-area-pointer-type
- :bits #!-alpha sb!vm:word-bits #!+alpha 64))
+ :bits #!-alpha sb!vm:n-word-bits #!+alpha 64))
-(def-alien-type-method (system-area-pointer :unparse) (type)
+(define-alien-type-method (system-area-pointer :unparse) (type)
(declare (ignore type))
'system-area-pointer)
-(def-alien-type-method (system-area-pointer :lisp-rep) (type)
+(define-alien-type-method (system-area-pointer :lisp-rep) (type)
(declare (ignore type))
'system-area-pointer)
-(def-alien-type-method (system-area-pointer :alien-rep) (type)
+(define-alien-type-method (system-area-pointer :alien-rep) (type)
(declare (ignore type))
'system-area-pointer)
-(def-alien-type-method (system-area-pointer :naturalize-gen) (type alien)
+(define-alien-type-method (system-area-pointer :naturalize-gen) (type alien)
(declare (ignore type))
alien)
-(def-alien-type-method (system-area-pointer :deport-gen) (type object)
+(define-alien-type-method (system-area-pointer :deport-gen) (type object)
(declare (ignore type))
(/noshow "doing alien type method SYSTEM-AREA-POINTER :DEPORT-GEN" object)
object)
-(def-alien-type-method (system-area-pointer :extract-gen) (type sap offset)
+(define-alien-type-method (system-area-pointer :extract-gen) (type sap offset)
(declare (ignore type))
- `(sap-ref-sap ,sap (/ ,offset sb!vm:byte-bits)))
+ `(sap-ref-sap ,sap (/ ,offset sb!vm:n-byte-bits)))
\f
;;;; the ALIEN-VALUE type
-(def-alien-type-class (alien-value :include system-area-pointer))
+(define-alien-type-class (alien-value :include system-area-pointer))
-(def-alien-type-method (alien-value :lisp-rep) (type)
+(define-alien-type-method (alien-value :lisp-rep) (type)
(declare (ignore type))
nil)
-(def-alien-type-method (alien-value :naturalize-gen) (type alien)
+(define-alien-type-method (alien-value :naturalize-gen) (type alien)
`(%sap-alien ,alien ',type))
-(def-alien-type-method (alien-value :deport-gen) (type value)
+(define-alien-type-method (alien-value :deport-gen) (type value)
(declare (ignore type))
(/noshow "doing alien type method ALIEN-VALUE :DEPORT-GEN" value)
`(alien-sap ,value))
(def!struct (heap-alien-info
(:make-load-form-fun sb!kernel:just-dump-it-normally))
;; The type of this alien.
- (type (required-argument) :type alien-type)
+ (type (missing-arg) :type alien-type)
;; The form to evaluate to produce the SAP pointing to where in the heap
;; it is.
- (sap-form (required-argument)))
+ (sap-form (missing-arg)))
(def!method print-object ((info heap-alien-info) stream)
(print-unreadable-object (info stream :type t)
(funcall (formatter "~S ~S")
\f
;;;; default methods
-(def-alien-type-method (root :unparse) (type)
+(define-alien-type-method (root :unparse) (type)
`(<unknown-alien-type> ,(type-of type)))
-(def-alien-type-method (root :type=) (type1 type2)
+(define-alien-type-method (root :type=) (type1 type2)
(declare (ignore type1 type2))
t)
-(def-alien-type-method (root :subtypep) (type1 type2)
+(define-alien-type-method (root :subtypep) (type1 type2)
(alien-type-= type1 type2))
-(def-alien-type-method (root :lisp-rep) (type)
+(define-alien-type-method (root :lisp-rep) (type)
(declare (ignore type))
nil)
-(def-alien-type-method (root :alien-rep) (type)
+(define-alien-type-method (root :alien-rep) (type)
(declare (ignore type))
'*)
-(def-alien-type-method (root :naturalize-gen) (type alien)
+(define-alien-type-method (root :naturalize-gen) (type alien)
(declare (ignore alien))
(error "cannot represent ~S typed aliens" type))
-(def-alien-type-method (root :deport-gen) (type object)
+(define-alien-type-method (root :deport-gen) (type object)
(declare (ignore object))
(error "cannot represent ~S typed aliens" type))
-(def-alien-type-method (root :extract-gen) (type sap offset)
+(define-alien-type-method (root :extract-gen) (type sap offset)
(declare (ignore sap offset))
(error "cannot represent ~S typed aliens" type))
-(def-alien-type-method (root :deposit-gen) (type sap offset value)
+(define-alien-type-method (root :deposit-gen) (type sap offset value)
`(setf ,(invoke-alien-type-method :extract-gen type sap offset) ,value))
-(def-alien-type-method (root :arg-tn) (type state)
+(define-alien-type-method (root :arg-tn) (type state)
(declare (ignore state))
(error "Aliens of type ~S cannot be passed as arguments to CALL-OUT."
(unparse-alien-type type)))
-(def-alien-type-method (root :result-tn) (type state)
+(define-alien-type-method (root :result-tn) (type state)
(declare (ignore state))
(error "Aliens of type ~S cannot be returned from CALL-OUT."
(unparse-alien-type type)))
\f
;;;; the INTEGER type
-(def-alien-type-class (integer)
+(define-alien-type-class (integer)
(signed t :type (member t nil)))
-(def-alien-type-translator signed (&optional (bits sb!vm:word-bits))
+(define-alien-type-translator signed (&optional (bits sb!vm:n-word-bits))
(make-alien-integer-type :bits bits))
-(def-alien-type-translator integer (&optional (bits sb!vm:word-bits))
+(define-alien-type-translator integer (&optional (bits sb!vm:n-word-bits))
(make-alien-integer-type :bits bits))
-(def-alien-type-translator unsigned (&optional (bits sb!vm:word-bits))
+(define-alien-type-translator unsigned (&optional (bits sb!vm:n-word-bits))
(make-alien-integer-type :bits bits :signed nil))
-(def-alien-type-method (integer :unparse) (type)
+(define-alien-type-method (integer :unparse) (type)
(list (if (alien-integer-type-signed type) 'signed 'unsigned)
(alien-integer-type-bits type)))
-(def-alien-type-method (integer :type=) (type1 type2)
+(define-alien-type-method (integer :type=) (type1 type2)
(and (eq (alien-integer-type-signed type1)
(alien-integer-type-signed type2))
(= (alien-integer-type-bits type1)
(alien-integer-type-bits type2))))
-(def-alien-type-method (integer :lisp-rep) (type)
+(define-alien-type-method (integer :lisp-rep) (type)
(list (if (alien-integer-type-signed type) 'signed-byte 'unsigned-byte)
(alien-integer-type-bits type)))
-(def-alien-type-method (integer :alien-rep) (type)
+(define-alien-type-method (integer :alien-rep) (type)
(list (if (alien-integer-type-signed type) 'signed-byte 'unsigned-byte)
(alien-integer-type-bits type)))
-(def-alien-type-method (integer :naturalize-gen) (type alien)
+(define-alien-type-method (integer :naturalize-gen) (type alien)
(declare (ignore type))
alien)
-(def-alien-type-method (integer :deport-gen) (type value)
+(define-alien-type-method (integer :deport-gen) (type value)
(declare (ignore type))
value)
-(def-alien-type-method (integer :extract-gen) (type sap offset)
+(define-alien-type-method (integer :extract-gen) (type sap offset)
(declare (type alien-integer-type type))
(let ((ref-fun
(if (alien-integer-type-signed type)
(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:byte-bits))
- (error "cannot extract ~D bit integers"
+ `(,ref-fun ,sap (/ ,offset sb!vm:n-byte-bits))
+ (error "cannot extract ~W-bit integers"
(alien-integer-type-bits type)))))
\f
;;;; the BOOLEAN type
-(def-alien-type-class (boolean :include integer :include-args (signed)))
+(define-alien-type-class (boolean :include integer :include-args (signed)))
;;; FIXME: Check to make sure that we aren't attaching user-readable
;;; stuff to CL:BOOLEAN in any way which impairs ANSI compliance.
-(def-alien-type-translator boolean (&optional (bits sb!vm:word-bits))
+(define-alien-type-translator boolean (&optional (bits sb!vm:n-word-bits))
(make-alien-boolean-type :bits bits :signed nil))
-(def-alien-type-method (boolean :unparse) (type)
+(define-alien-type-method (boolean :unparse) (type)
`(boolean ,(alien-boolean-type-bits type)))
-(def-alien-type-method (boolean :lisp-rep) (type)
+(define-alien-type-method (boolean :lisp-rep) (type)
(declare (ignore type))
`(member t nil))
-(def-alien-type-method (boolean :naturalize-gen) (type alien)
+(define-alien-type-method (boolean :naturalize-gen) (type alien)
(declare (ignore type))
`(not (zerop ,alien)))
-(def-alien-type-method (boolean :deport-gen) (type value)
+(define-alien-type-method (boolean :deport-gen) (type value)
(declare (ignore type))
`(if ,value 1 0))
\f
;;;; the ENUM type
-(def-alien-type-class (enum :include (integer (:bits 32))
- :include-args (signed))
+(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 symbols to integers
+ to ; alist or vector from integers to symbols
+ kind ; kind of from mapping, :VECTOR or :ALIST
+ offset) ; offset to add to value for :VECTOR from mapping
-(def-alien-type-translator enum (&whole
+(define-alien-type-translator enum (&whole
type name
&rest mappings
&environment env)
(values (first el) (second el))
(values el (1+ prev)))
(setf prev val)
- (unless (keywordp sym)
- (error "The enumeration element ~S is not a keyword." sym))
+ (unless (symbolp sym)
+ (error "The enumeration element ~S is not a symbol." sym))
(unless (integerp val)
(error "The element value ~S is not an integer." val))
(unless (and max (> max val)) (setq max val))
;; If range is at least 20% dense, use vector mapping. Crossover
;; point solely on basis of space would be 25%. Vector mapping
;; is always faster, so give the benefit of the doubt.
- ((< 0.2 (/ (float (length from-alist)) (float (- max min))))
+ ((< 0.2 (/ (float (length from-alist)) (float (1+ (- max min)))))
;; If offset is small and ignorable, ignore it to save time.
(when (< 0 min 10) (setq min 0))
(let ((to (make-array (1+ (- max min)))))
(t
(make-alien-enum-type :name name :signed signed
:from from-alist
- :to (mapcar #'(lambda (x) (cons (cdr x) (car x)))
+ :to (mapcar (lambda (x) (cons (cdr x) (car x)))
from-alist)
:kind :alist))))))
-(def-alien-type-method (enum :unparse) (type)
+(define-alien-type-method (enum :unparse) (type)
`(enum ,(alien-enum-type-name type)
,@(let ((prev -1))
- (mapcar #'(lambda (mapping)
- (let ((sym (car mapping))
- (value (cdr mapping)))
- (prog1
- (if (= (1+ prev) value)
- sym
- `(,sym ,value))
- (setf prev value))))
+ (mapcar (lambda (mapping)
+ (let ((sym (car mapping))
+ (value (cdr mapping)))
+ (prog1
+ (if (= (1+ prev) value)
+ sym
+ `(,sym ,value))
+ (setf prev value))))
(alien-enum-type-from type)))))
-(def-alien-type-method (enum :type=) (type1 type2)
+(define-alien-type-method (enum :type=) (type1 type2)
(and (eq (alien-enum-type-name type1)
(alien-enum-type-name type2))
(equal (alien-enum-type-from type1)
(alien-enum-type-from type2))))
-(def-alien-type-method (enum :lisp-rep) (type)
+(define-alien-type-method (enum :lisp-rep) (type)
`(member ,@(mapcar #'car (alien-enum-type-from type))))
-(def-alien-type-method (enum :naturalize-gen) (type alien)
+(define-alien-type-method (enum :naturalize-gen) (type alien)
(ecase (alien-enum-type-kind type)
(:vector
`(svref ',(alien-enum-type-to type)
(+ ,alien ,(alien-enum-type-offset type))))
(:alist
`(ecase ,alien
- ,@(mapcar #'(lambda (mapping)
- `(,(car mapping) ,(cdr mapping)))
+ ,@(mapcar (lambda (mapping)
+ `(,(car mapping) ',(cdr mapping)))
(alien-enum-type-to type))))))
-(def-alien-type-method (enum :deport-gen) (type value)
+(define-alien-type-method (enum :deport-gen) (type value)
`(ecase ,value
- ,@(mapcar #'(lambda (mapping)
- `(,(car mapping) ,(cdr mapping)))
+ ,@(mapcar (lambda (mapping)
+ `(,(car mapping) ,(cdr mapping)))
(alien-enum-type-from type))))
\f
;;;; the FLOAT types
-(def-alien-type-class (float)
- (type (required-argument) :type symbol))
+(define-alien-type-class (float)
+ (type (missing-arg) :type symbol))
-(def-alien-type-method (float :unparse) (type)
+(define-alien-type-method (float :unparse) (type)
(alien-float-type-type type))
-(def-alien-type-method (float :lisp-rep) (type)
+(define-alien-type-method (float :lisp-rep) (type)
(alien-float-type-type type))
-(def-alien-type-method (float :alien-rep) (type)
+(define-alien-type-method (float :alien-rep) (type)
(alien-float-type-type type))
-(def-alien-type-method (float :naturalize-gen) (type alien)
+(define-alien-type-method (float :naturalize-gen) (type alien)
(declare (ignore type))
alien)
-(def-alien-type-method (float :deport-gen) (type value)
+(define-alien-type-method (float :deport-gen) (type value)
(declare (ignore type))
value)
-(def-alien-type-class (single-float :include (float (:bits 32))
- :include-args (type)))
+(define-alien-type-class (single-float :include (float (bits 32))
+ :include-args (type)))
-(def-alien-type-translator single-float ()
+(define-alien-type-translator single-float ()
(make-alien-single-float-type :type 'single-float))
-(def-alien-type-method (single-float :extract-gen) (type sap offset)
+(define-alien-type-method (single-float :extract-gen) (type sap offset)
(declare (ignore type))
- `(sap-ref-single ,sap (/ ,offset sb!vm:byte-bits)))
+ `(sap-ref-single ,sap (/ ,offset sb!vm:n-byte-bits)))
-(def-alien-type-class (double-float :include (float (:bits 64))
- :include-args (type)))
+(define-alien-type-class (double-float :include (float (bits 64))
+ :include-args (type)))
-(def-alien-type-translator double-float ()
+(define-alien-type-translator double-float ()
(make-alien-double-float-type :type 'double-float))
-(def-alien-type-method (double-float :extract-gen) (type sap offset)
+(define-alien-type-method (double-float :extract-gen) (type sap offset)
(declare (ignore type))
- `(sap-ref-double ,sap (/ ,offset sb!vm:byte-bits)))
-
-#!+long-float
-(def-alien-type-class (long-float :include (float (:bits #!+x86 96
- #!+sparc 128))
- :include-args (type)))
+ `(sap-ref-double ,sap (/ ,offset sb!vm:n-byte-bits)))
-#!+long-float
-(def-alien-type-translator long-float ()
- (make-alien-long-float-type :type 'long-float))
-
-#!+long-float
-(def-alien-type-method (long-float :extract-gen) (type sap offset)
- (declare (ignore type))
- `(sap-ref-long ,sap (/ ,offset sb!vm:byte-bits)))
\f
;;;; the POINTER type
-(def-alien-type-class (pointer :include (alien-value (:bits
- #!-alpha sb!vm:word-bits
- #!+alpha 64)))
+(define-alien-type-class (pointer :include (alien-value (bits
+ #!-alpha
+ sb!vm:n-word-bits
+ #!+alpha 64)))
(to nil :type (or alien-type null)))
-(def-alien-type-translator * (to &environment env)
+(define-alien-type-translator * (to &environment env)
(make-alien-pointer-type :to (if (eq to t) nil (parse-alien-type to env))))
-(def-alien-type-method (pointer :unparse) (type)
+(define-alien-type-method (pointer :unparse) (type)
(let ((to (alien-pointer-type-to type)))
`(* ,(if to
(%unparse-alien-type to)
t))))
-(def-alien-type-method (pointer :type=) (type1 type2)
+(define-alien-type-method (pointer :type=) (type1 type2)
(let ((to1 (alien-pointer-type-to type1))
(to2 (alien-pointer-type-to type2)))
(if to1
nil)
(null to2))))
-(def-alien-type-method (pointer :subtypep) (type1 type2)
+(define-alien-type-method (pointer :subtypep) (type1 type2)
(and (alien-pointer-type-p type2)
(let ((to1 (alien-pointer-type-to type1))
(to2 (alien-pointer-type-to type2)))
t)
(null to2)))))
-(def-alien-type-method (pointer :deport-gen) (type value)
+(define-alien-type-method (pointer :deport-gen) (type value)
(/noshow "doing alien type method POINTER :DEPORT-GEN" type value)
(values
;; FIXME: old version, highlighted a bug in xc optimization
\f
;;;; the MEM-BLOCK type
-(def-alien-type-class (mem-block :include alien-value))
+(define-alien-type-class (mem-block :include alien-value))
-(def-alien-type-method (mem-block :extract-gen) (type sap offset)
+(define-alien-type-method (mem-block :extract-gen) (type sap offset)
(declare (ignore type))
- `(sap+ ,sap (/ ,offset sb!vm:byte-bits)))
+ `(sap+ ,sap (/ ,offset sb!vm:n-byte-bits)))
-(def-alien-type-method (mem-block :deposit-gen) (type sap offset value)
- (let ((bits (alien-mem-block-type-bits type)))
- (unless bits
+(define-alien-type-method (mem-block :deposit-gen) (type sap offset value)
+ (let ((bytes (truncate (alien-mem-block-type-bits type) sb!vm:n-byte-bits)))
+ (unless bytes
(error "can't deposit aliens of type ~S (unknown size)" type))
- `(sb!kernel:system-area-copy ,value 0 ,sap ,offset ',bits)))
+ `(sb!kernel:system-area-ub8-copy ,value 0 ,sap ,offset ',bytes)))
\f
;;;; the ARRAY type
-(def-alien-type-class (array :include mem-block)
- (element-type (required-argument) :type alien-type)
- (dimensions (required-argument) :type list))
+(define-alien-type-class (array :include mem-block)
+ (element-type (missing-arg) :type alien-type)
+ (dimensions (missing-arg) :type list))
+
+(define-alien-type-translator array (ele-type &rest dims &environment env)
-(def-alien-type-translator array (ele-type &rest dims &environment env)
(when dims
(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 '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)
+(define-alien-type-method (array :unparse) (type)
`(array ,(%unparse-alien-type (alien-array-type-element-type type))
,@(alien-array-type-dimensions type)))
-(def-alien-type-method (array :type=) (type1 type2)
+(define-alien-type-method (array :type=) (type1 type2)
(and (equal (alien-array-type-dimensions type1)
(alien-array-type-dimensions type2))
(alien-type-= (alien-array-type-element-type type1)
(alien-array-type-element-type type2))))
-(def-alien-type-method (array :subtypep) (type1 type2)
+(define-alien-type-method (array :subtypep) (type1 type2)
(and (alien-array-type-p type2)
(let ((dim1 (alien-array-type-dimensions type1))
(dim2 (alien-array-type-dimensions type2)))
(def!struct (alien-record-field
(:make-load-form-fun sb!kernel:just-dump-it-normally))
- (name (required-argument) :type symbol)
- (type (required-argument) :type alien-type)
+ (name (missing-arg) :type symbol)
+ (type (missing-arg) :type alien-type)
(bits nil :type (or unsigned-byte null))
(offset 0 :type unsigned-byte))
(def!method print-object ((field alien-record-field) stream)
(alien-record-field-name field)
(alien-record-field-bits field))))
-(def-alien-type-class (record :include mem-block)
+(define-alien-type-class (record :include mem-block)
(kind :struct :type (member :struct :union))
(name nil :type (or symbol null))
(fields nil :type list))
-(def-alien-type-translator struct (name &rest fields &environment env)
+(define-alien-type-translator struct (name &rest fields &environment env)
(parse-alien-record-type :struct name fields env))
-(def-alien-type-translator union (name &rest fields &environment env)
+(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 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))))
- (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)
(setf (alien-record-type-bits result)
(align-offset total-bits overall-alignment))))
-(def-alien-type-method (record :unparse) (type)
+(define-alien-type-method (record :unparse) (type)
`(,(case (alien-record-type-kind type)
(:struct 'struct)
(:union 'union)
,(alien-record-type-name type)
,@(unless (member type *record-types-already-unparsed* :test #'eq)
(push type *record-types-already-unparsed*)
- (mapcar #'(lambda (field)
- `(,(alien-record-field-name field)
- ,(%unparse-alien-type (alien-record-field-type field))
- ,@(if (alien-record-field-bits field)
- (list (alien-record-field-bits field)))))
+ (mapcar (lambda (field)
+ `(,(alien-record-field-name field)
+ ,(%unparse-alien-type (alien-record-field-type field))
+ ,@(if (alien-record-field-bits field)
+ (list (alien-record-field-bits field)))))
(alien-record-type-fields type)))))
-;;; Test the record fields. The depth is limiting in case of cyclic
-;;; pointers.
-(defun record-fields-match (fields1 fields2 depth)
- (declare (type list fields1 fields2)
- (type (mod 64) depth))
- (labels ((record-type-= (type1 type2 depth)
- (and (eq (alien-record-type-name type1)
- (alien-record-type-name type2))
- (eq (alien-record-type-kind type1)
- (alien-record-type-kind type2))
- (= (length (alien-record-type-fields type1))
- (length (alien-record-type-fields type2)))
- (record-fields-match (alien-record-type-fields type1)
- (alien-record-type-fields type2)
- (1+ depth))))
- (pointer-type-= (type1 type2 depth)
- (let ((to1 (alien-pointer-type-to type1))
- (to2 (alien-pointer-type-to type2)))
- (if to1
- (if to2
- (type-= to1 to2 (1+ depth))
- nil)
- (null to2))))
- (type-= (type1 type2 depth)
- (cond ((and (alien-pointer-type-p type1)
- (alien-pointer-type-p type2))
- (or (> depth 10)
- (pointer-type-= type1 type2 depth)))
- ((and (alien-record-type-p type1)
- (alien-record-type-p type2))
- (record-type-= type1 type2 depth))
- (t
- (alien-type-= type1 type2)))))
- (do ((fields1-rem fields1 (rest fields1-rem))
- (fields2-rem fields2 (rest fields2-rem)))
- ((or (eq fields1-rem fields2-rem)
- (endp fields1-rem) (endp fields2-rem))
- (eq fields1-rem fields2-rem))
- (let ((field1 (first fields1-rem))
- (field2 (first fields2-rem)))
- (declare (type alien-record-field field1 field2))
- (unless (and (eq (alien-record-field-name field1)
- (alien-record-field-name field2))
- (eql (alien-record-field-bits field1)
- (alien-record-field-bits field2))
- (eql (alien-record-field-offset field1)
- (alien-record-field-offset field2))
- (let ((field1 (alien-record-field-type field1))
- (field2 (alien-record-field-type field2)))
- (type-= field1 field2 (1+ depth))))
- (return nil))))))
-
-(def-alien-type-method (record :type=) (type1 type2)
+;;; Test the record fields. Keep a hashtable table of already compared
+;;; types to detect cycles.
+(defun record-fields-match-p (field1 field2)
+ (and (eq (alien-record-field-name field1)
+ (alien-record-field-name field2))
+ (eql (alien-record-field-bits field1)
+ (alien-record-field-bits field2))
+ (eql (alien-record-field-offset field1)
+ (alien-record-field-offset field2))
+ (alien-type-= (alien-record-field-type field1)
+ (alien-record-field-type field2))))
+
+(defvar *alien-type-matches* nil
+ "A hashtable used to detect cycles while comparing record types.")
+
+(define-alien-type-method (record :type=) (type1 type2)
(and (eq (alien-record-type-name type1)
(alien-record-type-name type2))
(eq (alien-record-type-kind type1)
(alien-record-type-kind type2))
- (= (length (alien-record-type-fields type1))
- (length (alien-record-type-fields type2)))
- (record-fields-match (alien-record-type-fields type1)
- (alien-record-type-fields type2) 0)))
+ (eql (alien-type-bits type1)
+ (alien-type-bits type2))
+ (eql (alien-type-alignment type1)
+ (alien-type-alignment type2))
+ (flet ((match-fields (&optional old)
+ (setf (gethash type1 *alien-type-matches*) (cons type2 old))
+ (every #'record-fields-match-p
+ (alien-record-type-fields type1)
+ (alien-record-type-fields type2))))
+ (if *alien-type-matches*
+ (let ((types (gethash type1 *alien-type-matches*)))
+ (or (memq type2 types) (match-fields types)))
+ (let ((*alien-type-matches* (make-hash-table :test #'eq)))
+ (match-fields))))))
\f
-;;;; the FUNCTION and VALUES types
+;;;; the FUNCTION and VALUES alien types
+;;; not documented in CMU CL:-(
+;;;
+;;; reverse engineering observations:
+;;; * seems to be set when translating return values
+;;; * seems to enable the translation of (VALUES), which is the
+;;; Lisp idiom for C's return type "void" (which is likely
+;;; why it's set when when translating return values)
(defvar *values-type-okay* nil)
-(def-alien-type-class (function :include mem-block)
- (result-type (required-argument) :type alien-type)
- (arg-types (required-argument) :type list)
+(define-alien-type-class (fun :include mem-block)
+ (result-type (missing-arg) :type alien-type)
+ (arg-types (missing-arg) :type list)
(stub nil :type (or null function)))
-(def-alien-type-translator function (result-type &rest arg-types
- &environment env)
- (make-alien-function-type
+(define-alien-type-translator function (result-type &rest arg-types
+ &environment env)
+ (make-alien-fun-type
:result-type (let ((*values-type-okay* t))
(parse-alien-type result-type env))
:arg-types (mapcar (lambda (arg-type) (parse-alien-type arg-type env))
arg-types)))
-(def-alien-type-method (function :unparse) (type)
- `(function ,(%unparse-alien-type (alien-function-type-result-type type))
+(define-alien-type-method (fun :unparse) (type)
+ `(function ,(%unparse-alien-type (alien-fun-type-result-type type))
,@(mapcar #'%unparse-alien-type
- (alien-function-type-arg-types type))))
+ (alien-fun-type-arg-types type))))
-(def-alien-type-method (function :type=) (type1 type2)
- (and (alien-type-= (alien-function-type-result-type type1)
- (alien-function-type-result-type type2))
- (= (length (alien-function-type-arg-types type1))
- (length (alien-function-type-arg-types type2)))
+(define-alien-type-method (fun :type=) (type1 type2)
+ (and (alien-type-= (alien-fun-type-result-type type1)
+ (alien-fun-type-result-type type2))
+ (= (length (alien-fun-type-arg-types type1))
+ (length (alien-fun-type-arg-types type2)))
(every #'alien-type-=
- (alien-function-type-arg-types type1)
- (alien-function-type-arg-types type2))))
+ (alien-fun-type-arg-types type1)
+ (alien-fun-type-arg-types type2))))
-(def-alien-type-class (values)
- (values (required-argument) :type list))
+(define-alien-type-class (values)
+ (values (missing-arg) :type list))
-(def-alien-type-translator values (&rest values &environment env)
+(define-alien-type-translator values (&rest values &environment env)
(unless *values-type-okay*
(error "cannot use values types here"))
(let ((*values-type-okay* nil))
:values (mapcar (lambda (alien-type) (parse-alien-type alien-type env))
values))))
-(def-alien-type-method (values :unparse) (type)
+(define-alien-type-method (values :unparse) (type)
`(values ,@(mapcar #'%unparse-alien-type
(alien-values-type-values type))))
-(def-alien-type-method (values :type=) (type1 type2)
+(define-alien-type-method (values :type=) (type1 type2)
(and (= (length (alien-values-type-values type1))
(length (alien-values-type-values type2)))
(every #'alien-type-=
(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 (required-argument) :type alien-type)
- ;; T if this local alien must be forced into memory. Using the ADDR macro
+ (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
\f
;;;; 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."
(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")