(error "badly formed alien name"))
(values (cadr name) (car name))))))
-(defmacro def-alien-variable (name type &environment env)
+(defmacro define-alien-variable (name type &environment env)
#!+sb-doc
"Define NAME as an external alien variable of type TYPE. NAME should be
a list of a string holding the alien name and a symbol to use as the Lisp
`(eval-when (:compile-toplevel :load-toplevel :execute)
,@(when *new-auxiliary-types*
`((%def-auxiliary-alien-types ',*new-auxiliary-types*)))
- (%def-alien-variable ',lisp-name
- ',alien-name
- ',alien-type))))))
+ (%define-alien-variable ',lisp-name
+ ',alien-name
+ ',alien-type))))))
-;;; Do the actual work of DEF-ALIEN-VARIABLE.
+(defmacro def-alien-variable (&rest rest)
+ (deprecation-warning 'def-alien-variable 'define-alien-variable)
+ `(define-alien-variable ,@rest))
+
+;;; Do the actual work of DEFINE-ALIEN-VARIABLE.
(eval-when (:compile-toplevel :load-toplevel :execute)
- (defun %def-alien-variable (lisp-name alien-name type)
+ (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)
`((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
((,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)
(let ((alien-type (parse-alien-type type env)))
(if (eq (compute-alien-rep-type alien-type) 'system-area-pointer)
`(%sap-alien ,sap ',alien-type)
- (error "cannot make aliens of type ~S out of SAPs" type))))
+ (error "cannot make an alien of type ~S out of a SAP" type))))
(defun %sap-alien (sap type)
(declare (type system-area-pointer sap)
(let* ((field (slot-or-lose type slot))
(offset (alien-record-field-offset field))
(field-type (alien-record-field-type field)))
- (%sap-alien (sap+ (alien-sap alien) (/ offset sb!vm:byte-bits))
+ (%sap-alien (sap+ (alien-sap alien) (/ offset sb!vm:n-byte-bits))
(make-alien-pointer-type :to field-type)))))))
\f
;;;; the DEREF operator
(etypecase type
(alien-pointer-type
(when (cdr indices)
- (error "too many indices when derefing ~S: ~D"
+ (error "too many indices when DEREF'ing ~S: ~W"
type
(length indices)))
(let ((element-type (alien-pointer-type-to type)))
0))))
(alien-array-type
(unless (= (length indices) (length (alien-array-type-dimensions type)))
- (error "incorrect number of indices when derefing ~S: ~D"
+ (error "incorrect number of indices when DEREF'ing ~S: ~W"
type (length indices)))
(labels ((frob (dims indices offset)
(if (null dims)
(type list indices)
(optimize (inhibit-warnings 3)))
(multiple-value-bind (target-type offset) (deref-guts alien indices)
- (%sap-alien (sap+ (alien-value-sap alien) (/ offset sb!vm:byte-bits))
+ (%sap-alien (sap+ (alien-value-sap alien) (/ offset sb!vm:n-byte-bits))
(make-alien-pointer-type :to target-type))))
\f
;;;; accessing heap alien variables
(alien-sap (alien-sap alien)))
(finalize
alien
- #'(lambda ()
- (alien-funcall
- (extern-alien "free" (function (values) system-area-pointer))
- alien-sap)))
+ (lambda ()
+ (alien-funcall
+ (extern-alien "free" (function (values) system-area-pointer))
+ alien-sap)))
alien))
(defun note-local-alien-type (info alien)
(optimize (inhibit-warnings 3)))
(if (or (alien-pointer-type-p target-type)
(alien-array-type-p target-type)
- (alien-function-type-p target-type))
+ (alien-fun-type-p target-type))
(let ((alien-type (alien-value-type alien)))
(if (or (alien-pointer-type-p alien-type)
(alien-array-type-p alien-type)
- (alien-function-type-p alien-type))
+ (alien-fun-type-p alien-type))
(naturalize (alien-value-sap alien) target-type)
(error "~S cannot be casted." alien)))
(error "cannot cast to alien type ~S" (unparse-alien-type target-type))))
(values (ceiling bits
(ecase units
(:bits 1)
- (:bytes sb!vm:byte-bits)
- (:words sb!vm:word-bits))))
+ (:bytes sb!vm:n-byte-bits)
+ (:words sb!vm:n-word-bits))))
(error "unknown size for alien type ~S"
(unparse-alien-type alien-type)))))
\f
(funcall (coerce (compute-deposit-lambda type) 'function)
sap offset type value))
\f
-;;;; ALIEN-FUNCALL, DEF-ALIEN-ROUTINE
+;;;; ALIEN-FUNCALL, DEFINE-ALIEN-ROUTINE
(defun alien-funcall (alien &rest args)
#!+sb-doc
(typecase type
(alien-pointer-type
(apply #'alien-funcall (deref alien) args))
- (alien-function-type
- (unless (= (length (alien-function-type-arg-types type))
+ (alien-fun-type
+ (unless (= (length (alien-fun-type-arg-types type))
(length args))
- (error "wrong number of arguments for ~S~%expected ~D, got ~D"
+ (error "wrong number of arguments for ~S~%expected ~W, got ~W"
type
- (length (alien-function-type-arg-types type))
+ (length (alien-fun-type-arg-types type))
(length args)))
- (let ((stub (alien-function-type-stub type)))
+ (let ((stub (alien-fun-type-stub type)))
(unless stub
(setf stub
(let ((fun (gensym))
`(lambda (,fun ,@parms)
(declare (type (alien ,type) ,fun))
(alien-funcall ,fun ,@parms)))))
- (setf (alien-function-type-stub type) stub))
+ (setf (alien-fun-type-stub type) stub))
(apply stub alien args)))
(t
(error "~S is not an alien function." alien)))))
-(defmacro def-alien-routine (name result-type &rest args &environment lexenv)
+(defmacro define-alien-routine (name result-type
+ &rest args
+ &environment lexenv)
#!+sb-doc
- "DEF-ALIEN-ROUTINE Name Result-Type {(Arg-Name Arg-Type [Style])}*
+ "DEFINE-ALIEN-ROUTINE Name Result-Type {(Arg-Name Arg-Type [Style])}*
Define a foreign interface function for the routine with the specified NAME.
Also automatically DECLAIM the FTYPE of the defined function.
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.
- (declaim (ftype (function (mapcar (constantly t) ',args)
- (alien ,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)
+ `(define-alien-routine ,@rest))
\f
(defun alien-typep (object type)
#!+sb-doc