;;;; 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))
(setf (gethash name *alien-type-classes*)
(make-alien-type-class :name name :include include)))))
-(defconstant method-slot-alist
+(defparameter *method-slot-alist*
'((:unparse . alien-type-class-unparse)
(:type= . alien-type-class-type=)
(:subtypep . alien-type-class-subtypep)
(:result-tn . alien-type-class-result-tn)))
(defun method-slot (method)
- (cdr (or (assoc method method-slot-alist)
+ (cdr (or (assoc method *method-slot-alist*)
(error "no method ~S" method))))
) ; EVAL-WHEN
-;;; We define a keyword "BOA" constructor so that we can reference the slot
-;;; names in init forms.
+;;; 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"))))
+ (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)
(: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)))
,@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"))))
+ (let ((defun-name (symbolicate class "-" method "-METHOD")))
`(progn
(defun ,defun-name ,lambda-list
,@body)
;;; we no longer need to make a distinction between this and
;;; %PARSE-ALIEN-TYPE.
(defun parse-alien-type (type env)
- (declare (type sb!kernel:lexenv 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 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)))))
(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*)
kind ; Kind of from mapping, :vector or :alist.
offset) ; Offset to add to value for :vector from mapping.
-(def-alien-type-translator enum (&whole type
- name
+(def-alien-type-translator enum (&whole
+ type name
&rest mappings
&environment env)
(cond (mappings
`(sap-ref-double ,sap (/ ,offset sb!vm:byte-bits)))
#!+long-float
-(def-alien-type-class (long-float :include (float (:bits #!+x86 96 #!+sparc 128))
+(def-alien-type-class (long-float :include (float (:bits #!+x86 96
+ #!+sparc 128))
:include-args (type)))
#!+long-float
(parse-alien-record-type :union name fields env))
(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))))
\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")