;;;; files for more information.
(in-package "SB!ALIEN")
+
+(/show0 "target-alieneval.lisp 15")
\f
;;;; alien variables
(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))))))
+
+(defmacro def-alien-variable (&rest rest)
+ (deprecation-warning 'def-alien-variable 'define-alien-variable)
+ `(define-alien-variable ,@rest))
-;;; Do the actual work of DEF-ALIEN-VARIABLE.
+;;; 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)
:EXTERN
No alien is allocated, but VAR is established as a local name for
the external alien given by EXTERNAL-NAME."
+ (/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))
binding
+ (/show symbol type opt1 opt2)
(let ((alien-type (parse-alien-type type env)))
+ (/show alien-type)
(multiple-value-bind (allocation initial-value)
(if opt2p
(values opt1 opt2)
(values opt1 nil))
(t
(values :local opt1))))
+ (/show allocation initial-value)
(setf body
(ecase allocation
#+nil
`((setq ,symbol ,initial-value)))
,@body)))))
(:extern
+ (/show ":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")
(let ((var (gensym))
(initval (if initial-value (gensym)))
(info (make-local-alien-info :type alien-type)))
+ (/show var initval info)
`((let ((,var (make-local-alien ',info))
,@(when initial-value
`((,initval ,initial-value))))
`((setq ,symbol ,initval)))
,@body)
(dispose-local-alien ',info ,var))))))))))))
+ (/show "revised" body)
(verify-local-auxiliaries-okay)
+ (/show "back from VERIFY-LOCAL-AUXILIARIES-OK, returning")
`(symbol-macrolet ((&auxiliary-type-definitions&
,(append *new-auxiliary-types*
(auxiliary-type-definitions env))))
\f
;;;; runtime C values that don't correspond directly to Lisp types
-;;; ALIEN-VALUE
-;;;
;;; Note: The DEFSTRUCT for ALIEN-VALUE lives in a separate file
;;; 'cause it has to be real early in the cold-load order.
#!-sb-fluid (declaim (freeze-type alien-value))
;;; system area pointer to it.
#!-sb-fluid (declaim (inline %make-alien))
(defun %make-alien (bits)
- (declare (type index bits) (optimize-interface (safety 2)))
- (alien-funcall (extern-alien "malloc" (function system-area-pointer unsigned))
+ (declare (type index bits))
+ (alien-funcall (extern-alien "malloc"
+ (function system-area-pointer unsigned))
(ash (the index (+ bits 7)) -3)))
#!-sb-fluid (declaim (inline free-alien))
(defun free-alien (alien)
#!+sb-doc
"Dispose of the storage pointed to by ALIEN. ALIEN must have been allocated
- by MAKE-ALIEN or ``malloc''."
+ by MAKE-ALIEN or malloc(3)."
(alien-funcall (extern-alien "free" (function (values) system-area-pointer))
(alien-sap alien))
nil)
(type symbol slot))
(or (find slot (alien-record-type-fields type)
:key #'alien-record-field-name)
- (error "There is no slot named ~S in ~S" slot type)))
+ (error "There is no slot named ~S in ~S." slot type)))
;;; Extract the value from the named slot from the record ALIEN. If
;;; ALIEN is actually a pointer, then DEREF it first.
(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
-;;; Does most of the work of the different DEREF methods. Returns two values:
-;;; the type and the offset (in bits) of the refered to alien.
+;;; This function does most of the work of the different DEREF
+;;; methods. It returns two values: the type and the offset (in bits)
+;;; of the referred-to alien.
(defun deref-guts (alien indices)
(declare (type alien-value alien)
(type list indices)
(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)
(values nil
nil
(list value)
- (if sb!c:*converting-for-interpreter*
- `(%set-local-alien ',info ,alien ,value)
- `(if (%local-alien-forced-to-memory-p ',info)
- (%set-local-alien ',info ,alien ,value)
- (setf ,alien
- (deport ,value ',(local-alien-info-type info)))))
+ `(if (%local-alien-forced-to-memory-p ',info)
+ (%set-local-alien ',info ,alien ,value)
+ (setf ,alien
+ (deport ,value ',(local-alien-info-type info))))
whole)))
(defun %local-alien-forced-to-memory-p (info)
(defun %cast (alien target-type)
(declare (type alien-value alien)
(type alien-type target-type)
- (optimize-interface (safety 2))
+ (optimize (safety 2))
(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 env)
+(defmacro define-alien-routine (name result-type
+ &rest args
+ &environment lexenv)
#!+sb-doc
- "Def-C-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.
+
+ NAME may be either a string, a symbol, or a list of the form (string symbol).
- Define a foreign interface function for the routine with the specified Name,
- which may be either a string, symbol or list of the form (string symbol).
- Return-Type is the Alien type for the function return value. VOID may be
- used to specify a function with no result.
+ RETURN-TYPE is the alien type for the function return value. VOID may be
+ used to specify a function with no result.
- The remaining forms specifiy individual arguments that are passed to the
- routine. Arg-Name is a symbol that names the argument, primarily for
- documentation. Arg-Type is the C-Type of the argument. Style specifies the
- say that the argument is passed.
+ The remaining forms specify individual arguments that are passed to the
+ routine. ARG-NAME is a symbol that names the argument, primarily for
+ documentation. ARG-TYPE is the C type of the argument. STYLE specifies the
+ way that the argument is passed.
:IN
- An :In argument is simply passed by value. The value to be passed is
+ 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.
to arrays, records or functions.
:COPY
- Similar to :IN, except that the argument values are stored in on
- the stack, and a pointer to the object is passed instead of
- the values themselves.
+ 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.
:IN-OUT
- 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."
+ 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)
(unless (eq style :out)
(lisp-args name))
(when (and (member style '(:out :in-out))
- (typep (parse-alien-type type env)
+ (typep (parse-alien-type type lexenv)
'alien-pointer-type))
(error "can't use :OUT or :IN-OUT on pointer-like type:~% ~S"
type))
(alien-args `(addr ,name))))
(when (or (eq style :out) (eq style :in-out))
(results 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)
- (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))))))))
+ `(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))
+
+ (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)
+ (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)))))))))
+
+(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
projects / sbcl.git / blobdiff