;; 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.6 2001-04-29 20:05:22 espen Exp $
+;; $Id: gforeign.lisp,v 1.9 2001-05-11 15:57:57 espen Exp $
(in-package "GLIB")
(defmacro defbinding (name lambda-list return-type-spec &rest docs/args)
- (multiple-value-bind (c-name lisp-name)
+ (multiple-value-bind (lisp-name c-name)
(if (atom name)
- (values (default-alien-fname name) name)
- (values-list name))
+ (values name (default-alien-fname name))
+ (values-list name))
+
(let ((supplied-lambda-list lambda-list)
(docs nil)
(args nil))
c-name lisp-name (or supplied-lambda-list (nreverse lambda-list))
return-type-spec (reverse docs) (reverse args)))))
-;; For backward compatibility
-(defmacro define-foreign (&rest args)
- `(defbinding ,@args))
-
-
#+cmu
(defun %defbinding (foreign-name lisp-name lambda-list
return-type-spec docs args)
,@(alien-deallocators)
(values ,@(alien-values)))))))))
-
+
+(defun mkbinding (name rettype &rest types)
+ (declare (optimize (ext:inhibit-warnings 3)))
+ (let* ((ftype
+ `(function ,@(mapcar #'translate-type-spec (cons rettype types))))
+ (alien
+ (alien::%heap-alien
+ (alien::make-heap-alien-info
+ :type (alien::parse-alien-type ftype)
+ :sap-form (system:foreign-symbol-address name))))
+ (translate-arguments (mapcar #'intern-return-value-translator types))
+ (translate-return-value (intern-return-value-translator rettype))
+ (cleanup-arguments (mapcar #'intern-cleanup-function types)))
+
+ #'(lambda (&rest args)
+ (map-into args #'funcall translate-arguments args)
+ (prog1
+ (funcall
+ translate-return-value (apply #'alien:alien-funcall alien args))
+ (mapc #'funcall cleanup-arguments args)))))
;;;; Definitons and translations of fundamental types
(deftype boolean (&optional (size '*))
(declare (ignore size))
`(member t nil))
-(deftype static (type) type)
(deftype invalid () nil)
(defun atomic-type-p (type-spec)
(unreference-alien type-spec c-string)))
(deftype-method unreference-alien string (type-spec c-string)
+ (declare (ignore type-spec))
`(let ((c-string ,c-string))
(unless (null-pointer-p c-string)
(deallocate-memory c-string))))
(deftype-method translate-type-spec nil (type-spec)
(declare (ignore type-spec))
'void)
+
+(deftype-method translate-from-alien nil (type-spec expr &optional weak-ref)
+ (declare (ignore type-spec weak-ref))
+ `(progn
+ ,expr
+ (values)))