\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)
(create-alien-type-class-if-necessary ',name ',(or include 'root)))
(def!struct (,defstruct-name
(:include ,include-defstruct
- (:class ',name)
+ (class ',name)
,@overrides)
(:constructor
,(symbolicate "MAKE-" defstruct-name)
,@(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)
;;; 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)
(destructuring-bind (kind name defn) info
(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 ENUM type
-(define-alien-type-class (enum :include (integer (:bits 32))
+(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
(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))))))
(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)))))
(define-alien-type-method (enum :type=) (type1 type2)
(+ ,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))))))
(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
(declare (ignore type))
value)
-(define-alien-type-class (single-float :include (float (:bits 32))
+(define-alien-type-class (single-float :include (float (bits 32))
:include-args (type)))
(define-alien-type-translator single-float ()
(declare (ignore type))
`(sap-ref-single ,sap (/ ,offset sb!vm:n-byte-bits)))
-(define-alien-type-class (double-float :include (float (:bits 64))
+(define-alien-type-class (double-float :include (float (bits 64))
:include-args (type)))
(define-alien-type-translator double-float ()
`(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))
+(define-alien-type-class (long-float :include (float (bits #!+x86 96
+ #!+sparc 128))
:include-args (type)))
#!+long-float
\f
;;;; the POINTER type
-(define-alien-type-class (pointer :include (alien-value (:bits
+(define-alien-type-class (pointer :include (alien-value (bits
#!-alpha
sb!vm:n-word-bits
#!+alpha 64)))
(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))))
,(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
\f
;;;; 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)
(define-alien-type-class (fun :include mem-block)
(stub nil :type (or null function)))
(define-alien-type-translator function (result-type &rest arg-types
- &environment env)
+ &environment env)
(make-alien-fun-type
:result-type (let ((*values-type-okay* t))
(parse-alien-type result-type env))
(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
projects / sbcl.git / blobdiff