;; License along with this library; if not, write to the Free Software
;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
-;; $Id: gforeign.lisp,v 1.1 2000/08/14 16:44:38 espen Exp $
+;; $Id: gforeign.lisp,v 1.5 2000/10/01 17:19:11 espen Exp $
(in-package "GLIB")
;; To make the compiler shut up
(eval-when (:compile-toplevel :load-toplevel :execute)
(define-type-method-fun translate-type-spec (type-spec))
+ (define-type-method-fun size-of (type-spec))
(define-type-method-fun translate-to-alien (type-spec expr &optional copy))
(define-type-method-fun translate-from-alien (type-spec expr &optional alloc))
- (define-type-method-fun cleanup-alien (type-spec expr &optional copied)))
+ (define-type-method-fun cleanup-alien (type-spec alien &optional copied)))
;;;;
`(lambda (sap offset)
(declare (ignorable sap offset))
,(translate-from-alien
- type-spec `(,(sap-ref-fname type-spec) sap offset) :copy))))))
+ type-spec `(,(sap-ref-fname type-spec) sap offset) :reference))))))
(defun get-destroy-function (type-spec)
;;;;
+(defconstant +bits-per-unit+ 8
+ "Number of bits in an addressable unit (byte)")
+
+;; Sizes of fundamental C types in addressable units
+(defconstant +size-of-short+ 2)
(defconstant +size-of-int+ 4)
+(defconstant +size-of-long+ 4)
(defconstant +size-of-sap+ 4)
(defconstant +size-of-float+ 4)
(defconstant +size-of-double+ 8)
(double-float 'sap-ref-double))))
-(defun signed (size)
- (if (eq size '*)
- `(signed ,(* 8 +size-of-int+))
- `(signed ,size)))
-
-(defun unsigned (size)
- (if (eq size '*)
- `(unsigned ,(* 8 +size-of-int+))
- `(unsigned ,size)))
-
-(defun size-of (type-spec)
- (let ((alien-type-spec (translate-type-spec type-spec)))
- (ecase (first (mklist alien-type-spec))
- ((signed unsigned) (/ (second alien-type-spec) 8))
- ((system-area-pointer single-float) +size-of-sap+)
- (single-float +size-of-float+)
- (double-float +size-of-double+))))
-
-
;;;; Foreign function call interface
(defvar *package-prefix* nil)
(push doc/arg docs)
(progn
(destructuring-bind (expr type &optional (style :in)) doc/arg
- (unless (member style '(:in :out))
+ (unless (member style '(:in :out :in-out))
(error "Bogus argument style ~S in ~S." style doc/arg))
- (when (and (not supplied-lambda-list) (namep expr) (eq style :in))
+ (when (and
+ (not supplied-lambda-list)
+ (namep expr) (member style '(:in :in-out)))
(push expr lambda-list))
(push
(list (if (namep expr) expr (gensym)) expr type style) args)))))
(defun %define-foreign (foreign-name lisp-name lambda-list
return-type-spec docs args)
(ext:collect ((alien-types) (alien-bindings) (alien-parameters)
- (alien-values) (alien-deallocatiors))
+ (alien-values) (alien-deallocators))
(dolist (arg args)
(destructuring-bind (var expr type-spec style) arg
(let ((declaration (translate-type-spec type-spec))
(deallocation (cleanup-alien type-spec expr)))
(cond
- ((eq style :out)
+ ((member style '(:out :in-out))
(alien-types `(* ,declaration))
(alien-parameters `(addr ,var))
- (alien-bindings `(,var ,declaration))
+ (alien-bindings
+ `(,var ,declaration
+ ,@(when (eq style :in-out)
+ (list (translate-to-alien type-spec expr)))))
(alien-values (translate-from-alien type-spec var)))
(deallocation
(alien-types declaration)
(alien-bindings
`(,var ,declaration ,(translate-to-alien type-spec expr)))
(alien-parameters var)
- (alien-deallocatiors deallocation))
+ (alien-deallocators deallocation))
(t
(alien-types declaration)
(alien-parameters (translate-to-alien type-spec expr)))))))
,(if return-type-spec
`(let ((result
,(translate-from-alien return-type-spec alien-funcall)))
- ,@(alien-deallocatiors)
+ ,@(alien-deallocators)
(values result ,@(alien-values)))
`(progn
,alien-funcall
- ,@(alien-deallocatiors)
+ ,@(alien-deallocators)
(values ,@(alien-values)))))))))
-;;;; Translations for fundamental types
+;;;; Definitons and translations of fundamental types
(lisp:deftype long (&optional (min '*) (max '*)) `(integer ,min ,max))
(lisp:deftype unsigned-long (&optional (min '*) (max '*)) `(integer ,min ,max))
(lisp:deftype invalid () nil)
+
(deftype-method cleanup-alien t (type-spec alien &optional copied)
(declare (ignore type-spec alien copied))
nil)
(deftype-method translate-type-spec fixnum (type-spec)
(declare (ignore type-spec))
- (signed '*))
+ (translate-type-spec 'signed))
+
+(deftype-method size-of fixnum (type-spec)
+ (declare (ignore type-spec))
+ (size-of 'signed))
(deftype-method translate-to-alien fixnum (type-spec number &optional copy)
(declare (ignore type-spec copy))
(deftype-method translate-type-spec long (type-spec)
(declare (ignore type-spec))
- (signed '*))
+ `(signed ,(* +bits-per-unit+ +size-of-long+)))
+
+(deftype-method size-of long (type-spec)
+ (declare (ignore type-spec))
+ +size-of-long+)
(deftype-method translate-type-spec unsigned-long (type-spec)
(declare (ignore type-spec))
- (unsigned '*))
+ `(unsigned ,(* +bits-per-unit+ +size-of-long+)))
+
+(deftype-method size-of unsigned-long (type-spec)
+ (declare (ignore type-spec))
+ +size-of-long+)
+
+
+(deftype-method translate-type-spec int (type-spec)
+ (declare (ignore type-spec))
+ `(signed ,(* +bits-per-unit+ +size-of-int+)))
+
+(deftype-method size-of int (type-spec)
+ (declare (ignore type-spec))
+ +size-of-int+)
+
+
+(deftype-method translate-type-spec unsigned-int (type-spec)
+ (declare (ignore type-spec))
+ `(signed ,(* +bits-per-unit+ +size-of-int+)))
+
+(deftype-method size-of unsigned-int (type-spec)
+ (declare (ignore type-spec))
+ +size-of-int+)
(deftype-method translate-type-spec short (type-spec)
(declare (ignore type-spec))
- '(signed 16))
+ `(signed ,(* +bits-per-unit+ +size-of-short+)))
+
+(deftype-method size-of short (type-spec)
+ (declare (ignore type-spec))
+ +size-of-short+)
(deftype-method translate-type-spec unsigned-short (type-spec)
(declare (ignore type-spec))
- '(unsigned 16))
+ `(unsigned ,(* +bits-per-unit+ +size-of-short+)))
+
+(deftype-method size-of unsigned-short (type-spec)
+ (declare (ignore type-spec))
+ +size-of-short+)
(deftype-method translate-type-spec signed-byte (type-spec)
- (destructuring-bind (name &optional (size '*))
- (type-expand-to 'signed-byte type-spec)
- (declare (ignore name))
- (signed size)))
+ (let ((size (second (mklist (type-expand-to 'signed-byte type-spec)))))
+ `(signed
+ ,(cond
+ ((member size '(nil *)) (* +bits-per-unit+ +size-of-int+))
+ (t size)))))
+
+(deftype-method size-of signed-byte (type-spec)
+ (let ((size (second (mklist (type-expand-to 'signed-byte type-spec)))))
+ (cond
+ ((member size '(nil *)) +size-of-int+)
+ (t (/ size +bits-per-unit+)))))
(deftype-method translate-to-alien signed-byte (type-spec number &optional copy)
(declare (ignore type-spec copy))
number)
-(deftype-method
- translate-from-alien signed-byte (type-spec number &optional alloc)
+(deftype-method translate-from-alien signed-byte
+ (type-spec number &optional alloc)
(declare (ignore type-spec alloc))
number)
(deftype-method translate-type-spec unsigned-byte (type-spec)
- (destructuring-bind (name &optional (size '*))
- (type-expand-to 'unsigned-byte type-spec)
- (declare (ignore name))
- (unsigned size)))
-
-(deftype-method
- translate-to-alien unsigned-byte (type-spec number &optional copy)
+ (let ((size (second (mklist (type-expand-to 'unsigned-byte type-spec)))))
+ `(signed
+ ,(cond
+ ((member size '(nil *)) (* +bits-per-unit+ +size-of-int+))
+ (t size)))))
+
+(deftype-method size-of unsigned-byte (type-spec)
+ (let ((size (second (mklist (type-expand-to 'unsigned-byte type-spec)))))
+ (cond
+ ((member size '(nil *)) +size-of-int+)
+ (t (/ size +bits-per-unit+)))))
+
+(deftype-method translate-to-alien unsigned-byte
+ (type-spec number &optional copy)
(declare (ignore type-spec copy))
number)
-(deftype-method
- translate-from-alien unsigned-byte (type-spec number &optional alloc)
+(deftype-method translate-from-alien unsigned-byte
+ (type-spec number &optional alloc)
(declare (ignore type-spec alloc))
number)
(declare (ignore type-spec))
'single-float)
-(deftype-method
- translate-to-alien single-float (type-spec number &optional copy)
+(deftype-method size-of single-float (type-spec)
+ (declare (ignore type-spec))
+ +size-of-float+)
+
+(deftype-method translate-to-alien single-float
+ (type-spec number &optional copy)
(declare (ignore type-spec copy))
number)
-(deftype-method
- translate-from-alien single-float (type-spec number &optional alloc)
+(deftype-method translate-from-alien single-float
+ (type-spec number &optional alloc)
(declare (ignore type-spec alloc))
number)
(declare (ignore type-spec))
'double-float)
-(deftype-method
- translate-to-alien double-float (type-spec number &optional copy)
+(deftype-method size-of double-float (type-spec)
+ (declare (ignore type-spec))
+ +size-of-double+)
+
+(deftype-method translate-to-alien double-float
+ (type-spec number &optional copy)
(declare (ignore type-spec copy))
number)
-(deftype-method
- translate-from-alien double-float (type-spec number &optional alloc)
+(deftype-method translate-from-alien double-float
+ (type-spec number &optional alloc)
(declare (ignore type-spec alloc))
number)
(deftype-method translate-type-spec base-char (type-spec)
(declare (ignore type-spec))
- '(unsigned 8))
+ '(unsigned +bits-per-unit+))
+
+(deftype-method size-of base-char (type-spec)
+ (declare (ignore type-spec))
+ 1)
(deftype-method translate-to-alien base-char (type-spec char &optional copy)
(declare (ignore type-spec copy))
(declare (ignore type-spec))
'system-area-pointer)
+(deftype-method size-of string (type-spec)
+ (declare (ignore type-spec))
+ +size-of-sap+)
+
(deftype-method translate-to-alien string (type-spec string &optional copy)
(declare (ignore type-spec))
(if copy
(1+ (length string))))
`(make-pointer (1+ (kernel:get-lisp-obj-address ,string)))))
-(deftype-method
- translate-from-alien string (type-spec sap &optional (alloc :dynamic))
+(deftype-method translate-from-alien string
+ (type-spec sap &optional (alloc :copy))
(declare (ignore type-spec))
`(let ((sap ,sap))
(unless (null-pointer-p sap)
(prog1
(c-call::%naturalize-c-string sap)
- ,(when (eq alloc :dynamic) `(deallocate-memory ,sap))))))
+ ;,(when (eq alloc :copy) `(deallocate-memory ,sap))
+ ))))
(deftype-method cleanup-alien string (type-spec sap &optional copied)
(declare (ignore type-spec))
(deftype-method translate-type-spec boolean (type-spec)
- (if (atom type-spec)
- (unsigned '*)
- (destructuring-bind (name &optional (size '*))
- (type-expand-to 'boolean type-spec)
- (declare (ignore name))
- (unsigned size))))
+ (translate-type-spec
+ (cons 'unsigned (cdr (mklist (type-expand-to 'boolean type-spec))))))
+
+(deftype-method size-of boolean (type-spec)
+ (size-of
+ (cons 'unsigned (cdr (mklist (type-expand-to 'boolean type-spec))))))
(deftype-method translate-to-alien boolean (type-spec boolean &optional copy)
(declare (ignore type-spec copy))
`(not (zerop ,int)))
-(deftype-method translate-type-spec or (union-type-spec)
- (destructuring-bind (name &rest type-specs)
- (type-expand-to 'or union-type-spec)
- (declare (ignore name))
- (let ((type-spec-translations
- (map 'list #'translate-type-spec type-specs)))
- (unless (apply #'all-equal type-spec-translations)
- (error
- "No common alien type specifier for union type: ~A" union-type-spec))
- (first type-spec-translations))))
+(deftype-method translate-type-spec or (union-type)
+ (let* ((member-types (cdr (type-expand-to 'or union-type)))
+ (alien-type (translate-type-spec (first member-types))))
+ (dolist (type (cdr member-types))
+ (unless (eq alien-type (translate-type-spec type))
+ (error "No common alien type specifier for union type: ~A" union-type)))
+ alien-type))
+
+(deftype-method size-of or (union-type)
+ (size-of (first (cdr (type-expand-to 'or union-type)))))
(deftype-method translate-to-alien or (union-type-spec expr &optional copy)
(destructuring-bind (name &rest type-specs)
(etypecase value
,@(map
'list
- #'(lambda (type-spec)
- (list type-spec (translate-to-alien type-spec 'value copy)))
- type-specs)))))
-
+ #'(lambda (type-spec)
+ (list type-spec (translate-to-alien type-spec 'value copy)))
+ type-specs)))))
(deftype-method translate-type-spec system-area-pointer (type-spec)
(declare (ignore type-spec))
'system-area-pointer)
-(deftype-method
- translate-to-alien system-area-pointer (type-spec sap &optional copy)
+(deftype-method size-of system-area-pointer (type-spec)
+ (declare (ignore type-spec))
+ +size-of-sap+)
+
+(deftype-method translate-to-alien system-area-pointer
+ (type-spec sap &optional copy)
(declare (ignore type-spec copy))
sap)
-(deftype-method
- translate-from-alien system-area-pointer (type-spec sap &optional alloc)
+(deftype-method translate-from-alien system-area-pointer
+ (type-spec sap &optional alloc)
(declare (ignore type-spec alloc))
sap)
'system-area-pointer)
(deftype-method translate-to-alien null (type-spec expr &optional copy)
- (declare (ignore type-spec copy))
+ (declare (ignore type-spec expr copy))
`(make-pointer 0))
(deftype-method transalte-type-spec static (type-spec)
(translate-type-spec (second type-spec)))
+(deftype-method size-of static (type-spec)
+ (size-of type-spec))
+
(deftype-method translate-to-alien static (type-spec expr &optional copy)
(declare (ignore copy))
(translate-to-alien (second type-spec) expr nil))
(rest args)
args))))
+
(lisp:deftype enum (&rest args)
`(member ,@(map-mappings args :symbols)))
(deftype-method translate-type-spec enum (type-spec)
- (destructuring-bind (name &rest args) (type-expand-to 'enum type-spec)
- (declare (ignore name))
+ (let ((args (cdr (type-expand-to 'enum type-spec))))
+ (if (integerp (first args))
+ (translate-type-spec `(signed ,(first args)))
+ (translate-type-spec 'signed))))
+
+(deftype-method size-of enum (type-spec)
+ (let ((args (cdr (type-expand-to 'enum type-spec))))
(if (integerp (first args))
- `(signed ,(first args))
- '(signed 32))))
+ (size-of `(signed ,(first args)))
+ (size-of 'signed))))
(deftype-method translate-to-alien enum (type-spec expr &optional copy)
(declare (ignore copy))
- (destructuring-bind (name &rest args) (type-expand-to 'enum type-spec)
- (declare (ignore name))
+ (let ((args (cdr (type-expand-to 'enum type-spec))))
`(ecase ,expr
,@(map-mappings args :enum-int))))
list)))
(deftype-method translate-type-spec flags (type-spec)
- (destructuring-bind (name &rest args) (type-expand-to 'flags type-spec)
- (declare (ignore name))
+ (let ((args (cdr (type-expand-to 'flags type-spec))))
+ (if (integerp (first args))
+ (translate-type-spec `(signed ,(first args)))
+ (translate-type-spec 'signed))))
+
+(deftype-method size-of flags (type-spec)
+ (let ((args (cdr (type-expand-to 'flags type-spec))))
(if (integerp (first args))
- `(signed ,(first args))
- '(signed 32))))
+ (size-of `(signed ,(first args)))
+ (size-of 'signed))))
(deftype-method translate-to-alien flags (type-spec expr &optional copy)
(declare (ignore copy))
(destructuring-bind (name &rest args) (type-expand-to 'flags type-spec)
(declare (ignore name))
- (let ((mappings (map-mappings args :flags-int)))
- `(let ((value 0))
- (dolist (flag ,expr value)
- (setq value (logior value (second (assoc flag ',mappings)))))))))
+ (let ((mappings (map-mappings args :flags-int))
+ (value (make-symbol "VALUE")))
+ `(let ((,value 0))
+ (dolist (flag ,expr ,value)
+ (setq ,value (logior ,value (second (assoc flag ',mappings)))))))))
(deftype-method translate-from-alien flags (type-spec expr &optional alloc)
(declare (ignore alloc))
(destructuring-bind (name &rest args) (type-expand-to 'flags type-spec)
(declare (ignore name))
- (let ((mappings (map-mappings args :int-flags)))
- `(let ((result nil))
- (dolist (mapping ',mappings result)
+ (let ((mappings (map-mappings args :int-flags))
+ (result (make-symbol "RESULT")))
+ `(let ((,result nil))
+ (dolist (mapping ',mappings ,result)
(unless (zerop (logand ,expr (first mapping)))
- (push (second mapping) result)))))))
+ (push (second mapping) ,result)))))))