(clear-info :variable :constant-value lisp-name)
(setf (info :variable :alien-info lisp-name)
(make-heap-alien-info :type type
- :sap-form `(foreign-symbol-address
- ',alien-name)))))
+ :sap-form `(foreign-symbol-address ',alien-name t)))))
(defmacro extern-alien (name type &environment env)
#!+sb-doc
"Access the alien variable named NAME, assuming it is of type TYPE. This
is SETFable."
- (let ((alien-name (etypecase name
- (symbol (guess-alien-name-from-lisp-name name))
- (string name))))
+ (let* ((alien-name (etypecase name
+ (symbol (guess-alien-name-from-lisp-name name))
+ (string name)))
+ (alien-type (parse-alien-type type env))
+ (datap (not (alien-fun-type-p alien-type))))
`(%heap-alien ',(make-heap-alien-info
- :type (parse-alien-type type env)
- :sap-form `(foreign-symbol-address ',alien-name)))))
+ :type alien-type
+ :sap-form `(foreign-symbol-address ',alien-name ,datap)))))
(defmacro with-alien (bindings &body body &environment env)
#!+sb-doc
(symbol type &optional (opt1 nil opt1p) (opt2 nil opt2p))
binding
(/show symbol type opt1 opt2)
- (let ((alien-type (parse-alien-type type env)))
+ (let* ((alien-type (parse-alien-type type env))
+ (datap (not (alien-fun-type-p alien-type))))
(/show alien-type)
(multiple-value-bind (allocation initial-value)
(if opt2p
`((setq ,symbol ,initial-value)))
,@body)))))
(:extern
- (/show ":EXTERN case")
+ (/show0 ":EXTERN case")
(let ((info (make-heap-alien-info
:type alien-type
:sap-form `(foreign-symbol-address
- ',initial-value))))
+ ',initial-value
+ ,datap))))
`((symbol-macrolet
((,symbol (%heap-alien ',info)))
,@body))))
(:local
- (/show ":LOCAL case")
+ (/show0 ":LOCAL case")
(let ((var (gensym))
(initval (if initial-value (gensym)))
(info (make-local-alien-info :type alien-type)))
(dispose-local-alien ',info ,var))))))))))))
(/show "revised" body)
(verify-local-auxiliaries-okay)
- (/show "back from VERIFY-LOCAL-AUXILIARIES-OK, returning")
+ (/show0 "back from VERIFY-LOCAL-AUXILIARIES-OK, returning")
`(symbol-macrolet ((&auxiliary-type-definitions&
,(append *new-auxiliary-types*
(auxiliary-type-definitions env))))
(def!method print-object ((value alien-value) stream)
(print-unreadable-object (value stream)
(format stream
- "~S :SAP #X~8,'0X"
+ "~S ~S #X~8,'0X ~S ~S"
'alien-value
- (sap-int (alien-value-sap value)))))
+ :sap (sap-int (alien-value-sap value))
+ :type (unparse-alien-type (alien-value-type value)))))
#!-sb-fluid (declaim (inline null-alien))
(defun null-alien (x)
way that the argument is passed.
:IN
- An :IN argument is simply passed by value. The value to be passed is
- obtained from argument(s) to the interface function. No values are
- returned for :In arguments. This is the default mode.
+ An :IN argument is simply passed by value. The value to be passed is
+ obtained from argument(s) to the interface function. No values are
+ returned for :In arguments. This is the default mode.
:OUT
- The specified argument type must be a pointer to a fixed sized object.
- A pointer to a preallocated object is passed to the routine, and the
- the object is accessed on return, with the value being returned from
- the interface function. :OUT and :IN-OUT cannot be used with pointers
- to arrays, records or functions.
+ The specified argument type must be a pointer to a fixed sized object.
+ A pointer to a preallocated object is passed to the routine, and the
+ the object is accessed on return, with the value being returned from
+ the interface function. :OUT and :IN-OUT cannot be used with pointers
+ to arrays, records or functions.
:COPY
- This is similar to :IN, except that the argument values are stored
+ This is similar to :IN, except that the argument values are stored
on the stack, and a pointer to the object is passed instead of
- the value itself.
+ the value itself.
:IN-OUT
- This is a combination of :OUT and :COPY. A pointer to the argument is
- passed, with the object being initialized from the supplied argument
+ This is a combination of :OUT and :COPY. A pointer to the argument is
+ passed, with the object being initialized from the supplied argument
and the return value being determined by accessing the object on
return."
(multiple-value-bind (lisp-name alien-name)
(pick-lisp-and-alien-names name)
- (collect ((docs) (lisp-args) (arg-types) (alien-vars)
+ (collect ((docs) (lisp-args) (lisp-arg-types)
+ (lisp-result-types
+ (cond ((eql result-type 'void)
+ ;; What values does a function return, if it
+ ;; returns no values? Exactly one - NIL. -- APD,
+ ;; 2003-03-02
+ (list 'null))
+ (t
+ ;; FIXME: Check for VALUES.
+ (list `(alien ,result-type)))))
+ (arg-types) (alien-vars)
(alien-args) (results))
(dolist (arg args)
(if (stringp arg)
(destructuring-bind (name type &optional (style :in)) arg
(unless (member style '(:in :copy :out :in-out))
(error "bogus argument style ~S in ~S" style arg))
- (unless (eq style :out)
- (lisp-args name))
(when (and (member style '(:out :in-out))
(typep (parse-alien-type type lexenv)
'alien-pointer-type))
(error "can't use :OUT or :IN-OUT on pointer-like type:~% ~S"
type))
- (cond ((eq style :in)
- (arg-types type)
- (alien-args name))
- (t
- (arg-types `(* ,type))
- (if (eq style :out)
- (alien-vars `(,name ,type))
- (alien-vars `(,name ,type ,name)))
- (alien-args `(addr ,name))))
+ (let (arg-type)
+ (cond ((eq style :in)
+ (setq arg-type type)
+ (alien-args name))
+ (t
+ (setq arg-type `(* ,type))
+ (if (eq style :out)
+ (alien-vars `(,name ,type))
+ (alien-vars `(,name ,type ,name)))
+ (alien-args `(addr ,name))))
+ (arg-types arg-type)
+ (unless (eq style :out)
+ (lisp-args name)
+ (lisp-arg-types t
+ ;; FIXME: It should be something
+ ;; like `(ALIEN ,ARG-TYPE), except
+ ;; for we also accept SAPs where
+ ;; pointers are required.
+ )))
(when (or (eq style :out) (eq style :in-out))
- (results name)))))
+ (results name)
+ (lisp-result-types `(alien ,type))))))
`(progn
-
;; The theory behind this automatic DECLAIM is that (1) if
;; you're calling C, static typing is what you're doing
;; anyway, and (2) such a declamation can be (especially for
;; alien values) both messy to do by hand and very important
;; for performance of later code which uses the return value.
- ,(let (;; FIXME: Ideally, we'd actually declare useful types
- ;; here, so e.g. an alien function of "int" and "char"
- ;; arguments would get Lisp arg types WORD and CHARACTER
- ;; or something. Meanwhile, for now we just punt.
- (lisp-arg-types (mapcar (constantly t) args))
- ;; KLUDGE: This is a quick hack to solve bug 133,
- ;; where PROCLAIM trying to translate alien void result
- ;; types would signal an error here ("cannot use values
- ;; types here"), and the kludgy SB!ALIEN::*VALUE-TYPE-OKAY*
- ;; flag to enable values types didn't fit into PROCLAIM
- ;; in any reasonable way. But there's likely a better
- ;; way to do this. (If there isn't a suitable utility
- ;; to systematically translate C return types into
- ;; Lisp return types, there should be.) -- WHN 2002-01-22
- (lisp-result-type (if (eql result-type 'void)
- '(values)
- `(alien ,result-type))))
- `(declaim (ftype (function ,lisp-arg-types ,lisp-result-type)
- ,lisp-name)))
-
+ (declaim (ftype (function ,(lisp-arg-types)
+ (values ,@(lisp-result-types) &optional))
+ ,lisp-name))
(defun ,lisp-name ,(lisp-args)
,@(docs)
(with-alien
((,lisp-name (function ,result-type ,@(arg-types))
:extern ,alien-name)
,@(alien-vars))
- ,(if (alien-values-type-p result-type)
+ #-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)))))))))
+ (values (alien-funcall ,lisp-name ,@(alien-args))
+ ,@(results)))))))))
(defmacro def-alien-routine (&rest rest)
(deprecation-warning 'def-alien-routine 'define-alien-routine)
projects / sbcl.git / blobdiff