(defun %define-alien-variable (lisp-name alien-name type)
(setf (info :variable :kind lisp-name) :alien)
(setf (info :variable :where-from lisp-name) :defined)
- (clear-info :variable :constant-value lisp-name)
(setf (info :variable :alien-info lisp-name)
(make-heap-alien-info :type type
:sap-form `(foreign-symbol-sap ',alien-name t)))))
ALLOCATION should be one of:
:LOCAL (the default)
The alien is allocated on the stack, and has dynamic extent.
- :STATIC
- The alien is allocated on the heap, and has infinite extent. The alien
- is allocated at load time, so the same piece of memory is used each time
- this form executes.
:EXTERN
No alien is allocated, but VAR is established as a local name for
the external alien given by EXTERNAL-NAME."
+ ;; FIXME:
+ ;; :STATIC
+ ;; The alien is allocated on the heap, and has infinite extent. The alien
+ ;; is allocated at load time, so the same piece of memory is used each time
+ ;; this form executes.
(/show "entering WITH-ALIEN" bindings)
(with-auxiliary-alien-types env
(dolist (binding (reverse bindings))
(/show binding)
(destructuring-bind
- (symbol type &optional (opt1 nil opt1p) (opt2 nil opt2p))
+ (symbol type &optional (opt1 nil opt1p) (opt2 nil opt2p))
binding
(/show symbol type opt1 opt2)
(let* ((alien-type (parse-alien-type type env))
`((let ((,sap (load-time-value (%make-alien ...))))
(declare (type system-area-pointer ,sap))
(symbol-macrolet
- ((,symbol (sap-alien ,sap ,type)))
- ,@(when initial-value
- `((setq ,symbol ,initial-value)))
- ,@body)))))
+ ((,symbol (sap-alien ,sap ,type)))
+ ,@(when initial-value
+ `((setq ,symbol ,initial-value)))
+ ,@body)))))
(:extern
(/show0 ":EXTERN case")
(let ((info (make-heap-alien-info
:sap-form `(foreign-symbol-sap ',initial-value
,datap))))
`((symbol-macrolet
- ((,symbol (%heap-alien ',info)))
- ,@body))))
+ ((,symbol (%heap-alien ',info)))
+ ,@body))))
(:local
(/show0 ":LOCAL case")
- (let ((var (gensym))
- (initval (if initial-value (gensym)))
- (info (make-local-alien-info :type alien-type)))
+ (let* ((var (sb!xc:gensym "VAR"))
+ (initval (if initial-value (sb!xc:gensym "INITVAL")))
+ (info (make-local-alien-info :type alien-type))
+ (inner-body
+ `((note-local-alien-type ',info ,var)
+ (symbol-macrolet ((,symbol (local-alien ',info ,var)))
+ ,@(when initial-value
+ `((setq ,symbol ,initval)))
+ ,@body)))
+ (body-forms
+ (if initial-value
+ `((let ((,initval ,initial-value))
+ ,@inner-body))
+ inner-body)))
(/show var initval info)
- `((let ((,var (make-local-alien ',info))
- ,@(when initial-value
- `((,initval ,initial-value))))
- (note-local-alien-type ',info ,var)
- (multiple-value-prog1
- (symbol-macrolet
- ((,symbol (local-alien ',info ,var)))
- ,@(when initial-value
- `((setq ,symbol ,initval)))
- ,@body)
- (dispose-local-alien ',info ,var))))))))))))
+ #!+(or x86 x86-64)
+ `((let ((,var (make-local-alien ',info)))
+ ,@body-forms))
+ ;; FIXME: This version is less efficient then it needs to be, since
+ ;; it could just save and restore the number-stack pointer once,
+ ;; instead of doing multiple decrements if there are multiple bindings.
+ #!-(or x86 x86-64)
+ `((let (,var)
+ (unwind-protect
+ (progn
+ (setf ,var (make-local-alien ',info))
+ (let ((,var ,var))
+ ,@body-forms))
+ (dispose-local-alien ',info ,var))))))))))))
(/show "revised" body)
(verify-local-auxiliaries-okay)
(/show0 "back from VERIFY-LOCAL-AUXILIARIES-OK, returning")
`(symbol-macrolet ((&auxiliary-type-definitions&
,(append *new-auxiliary-types*
(auxiliary-type-definitions env))))
+ #!+(or x86 x86-64)
+ (let ((sb!vm::*alien-stack* sb!vm::*alien-stack*))
+ ,@body)
+ #!-(or x86 x86-64)
,@body)))
\f
;;;; runtime C values that don't correspond directly to Lisp types
(let ((stub (alien-fun-type-stub type)))
(unless stub
(setf stub
- (let ((fun (gensym))
+ (let ((fun (sb!xc:gensym "FUN"))
(parms (make-gensym-list (length args))))
(compile nil
`(lambda (,fun ,@parms)
((,lisp-name (function ,result-type ,@(arg-types))
:extern ,alien-name)
,@(alien-vars))
- #-nil
- (values (alien-funcall ,lisp-name ,@(alien-args))
- ,@(results))
- #+nil
- (if (alien-values-type-p result-type)
- ;; FIXME: RESULT-TYPE is a type specifier, so it
- ;; cannot be of type ALIEN-VALUES-TYPE. Also note,
- ;; that if RESULT-TYPE is VOID, then this code
- ;; disagrees with the computation of the return type
- ;; and with all usages of this macro. -- APD,
- ;; 2002-03-02
- (let ((temps (make-gensym-list
- (length
- (alien-values-type-values result-type)))))
- `(multiple-value-bind ,temps
- (alien-funcall ,lisp-name ,@(alien-args))
- (values ,@temps ,@(results))))
- (values (alien-funcall ,lisp-name ,@(alien-args))
- ,@(results)))))))))
+ ,@(if (eq 'void result-type)
+ `((alien-funcall ,lisp-name ,@(alien-args))
+ (values nil ,@(results)))
+ `((values (alien-funcall ,lisp-name ,@(alien-args))
+ ,@(results))))))))))
\f
(defun alien-typep (object type)
#!+sb-doc
projects / sbcl.git / blobdiff