projects
/
sbcl.git
/ blobdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
|
commitdiff
|
tree
raw
|
inline
| side by side
0.pre7.49:
[sbcl.git]
/
src
/
code
/
host-alieneval.lisp
diff --git
a/src/code/host-alieneval.lisp
b/src/code/host-alieneval.lisp
index
2c7bb5c
..
f2ac852
100644
(file)
--- a/
src/code/host-alieneval.lisp
+++ b/
src/code/host-alieneval.lisp
@@
-11,6
+11,8
@@
;;;; files for more information.
(in-package "SB!ALIEN")
;;;; files for more information.
(in-package "SB!ALIEN")
+
+(/show0 "host-alieneval.lisp 15")
\f
;;;; utility functions
\f
;;;; utility functions
@@
-30,7
+32,7
@@
(eval-when (:compile-toplevel :execute :load-toplevel)
(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))
(name nil :type symbol)
(include nil :type (or null alien-type-class))
(unparse nil :type (or null function))
@@
-84,8
+86,7
@@
;;; 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)
;;; 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
(multiple-value-bind (include include-defstruct overrides)
(etypecase include
(null
@@
-93,14
+94,12
@@
(symbol
(values
include
(symbol
(values
include
- (intern (concatenate 'string
- "ALIEN-" (symbol-name include) "-TYPE"))
+ (symbolicate "ALIEN-" include "-TYPE")
nil))
(list
(values
(car include)
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)
(cdr include))))
`(progn
(eval-when (:compile-toplevel :load-toplevel :execute)
@@
-110,21
+109,16
@@
(:class ',name)
,@overrides)
(:constructor
(:class ',name)
,@overrides)
(:constructor
- ,(intern (concatenate 'string "MAKE-"
- (string defstruct-name)))
+ ,(symbolicate "MAKE-" defstruct-name)
(&key class bits alignment
(&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)
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)
`(progn
(defun ,defun-name ,lambda-list
,@body)
@@
-169,24
+163,16
@@
,(let ((*new-auxiliary-types* nil))
,@body)))
,(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))
(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))
(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
(:primitive
(let ((translator (info :alien-type :translator type)))
(unless translator
@@
-860,6
+846,7
@@
(dimensions (required-argument) :type list))
(def-alien-type-translator array (ele-type &rest dims &environment env)
(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 dims
(unless (typep (first dims) '(or index null))
(error "The first dimension is not a non-negative fixnum or NIL: ~S"
@@
-869,15
+856,15
@@
(when loser
(error "A dimension is not a non-negative fixnum: ~S" loser))))
(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
(make-alien-array-type
- :element-type type
+ :element-type parsed-ele-type
:dimensions dims
: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))
(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)
(reduce #'* dims))))))
(def-alien-type-method (array :unparse) (type)
@@
-1154,7
+1141,7
@@
\f
;;;; the ADDR macro
\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."
#!+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."
@@
-1183,3
+1170,5
@@
(when (eq kind :alien)
`(%heap-alien-addr ',(info :variable :alien-info form))))))
(error "~S is not a valid L-value." form))))
(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")