;;;; files for more information.
(in-package "SB!ALIEN")
+
+(/show0 "host-alieneval.lisp 15")
\f
;;;; utility functions
(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))
(:constructor
,(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)))))
,(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 (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 (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
(def-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)
(declare (ignore type))
(def-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 (integer)
(signed t :type (member t nil)))
-(def-alien-type-translator signed (&optional (bits sb!vm:word-bits))
+(def-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))
+(def-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))
+(def-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)
(32 'sap-ref-32)
#!+alpha (64 'sap-ref-64)))))
(if ref-fun
- `(,ref-fun ,sap (/ ,offset sb!vm:byte-bits))
+ `(,ref-fun ,sap (/ ,offset sb!vm:n-byte-bits))
(error "cannot extract ~D bit integers"
(alien-integer-type-bits type)))))
\f
;;; 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))
+(def-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)
(def-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)))
(def-alien-type-method (double-float :extract-gen) (type sap offset)
(declare (ignore type))
- `(sap-ref-double ,sap (/ ,offset sb!vm:byte-bits)))
+ `(sap-ref-double ,sap (/ ,offset sb!vm:n-byte-bits)))
#!+long-float
(def-alien-type-class (long-float :include (float (:bits #!+x86 96
#!+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)))
+ `(sap-ref-long ,sap (/ ,offset sb!vm:n-byte-bits)))
\f
;;;; the POINTER type
(def-alien-type-class (pointer :include (alien-value (:bits
- #!-alpha sb!vm:word-bits
+ #!-alpha
+ sb!vm:n-word-bits
#!+alpha 64)))
(to nil :type (or alien-type null)))
(def-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)))
(dimensions (required-argument) :type list))
(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"
(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)
(record-fields-match (alien-record-type-fields type1)
(alien-record-type-fields type2) 0)))
\f
-;;;; the FUNCTION and VALUES types
+;;;; the FUNCTION and VALUES alien types
(defvar *values-type-okay* nil)
-(def-alien-type-class (function :include mem-block)
+(def-alien-type-class (fun :include mem-block)
(result-type (required-argument) :type alien-type)
(arg-types (required-argument) :type list)
(stub nil :type (or null function)))
(def-alien-type-translator function (result-type &rest arg-types
&environment env)
- (make-alien-function-type
+ (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))
+(def-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)))
+(def-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))
\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")
projects / sbcl.git / blobdiff