;; 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: gboxed.lisp,v 1.1 2001-04-29 20:19:25 espen Exp $
+;; $Id: gboxed.lisp,v 1.2 2001-04-30 11:25:25 espen Exp $
(in-package "GLIB")
(eval-when (:compile-toplevel :load-toplevel :execute)
- (defclass boxed (alien-structure)
+ (defclass boxed (proxy)
()
(:metaclass proxy-class)))
"Specify either :type-init or :alien-name for class ~A"
class-name))
(alien-name (type-number-from-alien-name (first alien-name)))
- (type-init
- (funcall (alien-function (first type-init) '(unsigned 32))))
+ (type-init (funcall (mkbinding (first type-init) 'type-number)))
(t
(or
(type-number-from-alien-name
(default-alien-type-name class-name) nil)
(funcall
- (alien-function
+ (mkbinding
(default-alien-fname (format nil "~A_get_type" class-name))
- '(unsigned 32))))))))
+ 'type-number)))))))
(setf (find-type-number class) type-number)))
;; 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.7 2001-04-30 11:25:25 espen Exp $
(in-package "GLIB")
,@(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
(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)))
;; 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: glib-package.lisp,v 1.4 2001-04-29 20:33:53 espen Exp $
+;; $Id: glib-package.lisp,v 1.5 2001-04-30 11:25:25 espen Exp $
(export 'kernel::type-expand-1 "KERNEL")
(:export "DEFTYPE-METHOD" "TRANSLATE-TYPE-SPEC" "TRANSLATE-TO-ALIEN"
"TRANSLATE-FROM-ALIEN" "CLEANUP-ALIEN" "UNREFERENCE-ALIEN"
"SIZE-OF")
- (:export "DEFBINDING" "DEFINE-FOREIGN" "USE-PREFIX" "PACKAGE-PREFIX")
+ (:export "DEFBINDING" "DEFINE-FOREIGN" "MKBINDING" "USE-PREFIX"
+ "PACKAGE-PREFIX")
(:export "LONG" "UNSIGNED-LONG" "INT" "UNSIGNED-INT" "SHORT" "UNSIGNED-SHORT"
- "SIGNED" "UNSIGNED" "CHAR" "POINTER" "ENUM" "FLAGS")
+ "SIGNED" "UNSIGNED" "CHAR" "POINTER")
(:export "INTERN-ARGUMENT-TRANSLATOR" "INTERN-RETURN-VALUE-TRANSLATOR"
"INTERN-CLEANUP-FUNCTION" "INTERN-WRITER-FUNCTION"
"INTERN-READER-FUNCTION" "INTERN-DESTROY-FUNCTION"))
;; 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: gtype.lisp,v 1.8 2001-04-29 20:17:07 espen Exp $
+;; $Id: gtype.lisp,v 1.9 2001-04-30 11:25:25 espen Exp $
(in-package "GLIB")
(defun type-number-of (object)
(find-type-number (type-of object)))
-(defun alien-function (name return-type &rest arg-types)
- (let ((alien
- (alien::%heap-alien
- (alien::make-heap-alien-info
- :type (alien::parse-alien-type
- `(function ,@(cons return-type arg-types)))
- :sap-form (system:foreign-symbol-address name)))))
- #'(lambda (&rest args)
- (apply #'alien:alien-funcall alien args))))
-
-
(defun type-init (name &optional init-fname)
(funcall
- (alien-function
- (or
- init-fname
- (default-alien-fname (format nil "~A_get_type" name)))
- '(unsigned 32))))
+ (mkbinding
+ (or init-fname (default-alien-fname (format nil "~A_get_type" name)))
+ 'type-number)))
;;;; Superclass for wrapping types in the glib type system
(when ref
(setf
(slot-value class 'ref)
- (alien-function (first ref) 'system-area-pointer 'system-area-pointer)))
+ (mkbinding (first ref) 'pointer 'pointer)))
(when unref
(setf
(slot-value class 'unref)
- (alien-function (first unref) 'void 'system-area-pointer)))))
+ (mkbinding (first unref) 'nil 'pointer)))))
(defmethod shared-initialize :after ((class ginstance-class) names
&rest initargs)
;; 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: proxy.lisp,v 1.1 2001-04-29 20:19:25 espen Exp $
+;; $Id: proxy.lisp,v 1.2 2001-04-30 11:25:25 espen Exp $
(in-package "GLIB")
((class proxy-class)
(slotd effective-virtual-alien-slot-definition)
direct-slotds)
- (let ((location (call-next-method)))
+ (let ((location (call-next-method))
+ (class-name (class-name class)))
(if (or (stringp location) (consp location))
(destructuring-bind (reader &optional writer) (mklist location)
(with-slots (type) slotd
(list
(if (stringp reader)
- (let* ((alien-type (translate-type-spec type))
- (alien
- (alien::%heap-alien
- (alien::make-heap-alien-info
- :type (alien::parse-alien-type
- `(function ,alien-type system-area-pointer))
- :sap-form (system:foreign-symbol-address reader))))
- (translate-return-value
- (intern-return-value-translator type)))
- #'(lambda (object)
- (funcall
- translate-return-value
- (alien-funcall
- alien (proxy-location object)))))
+ (mkbinding reader type class-name)
reader)
(if (stringp writer)
- (let* ((alien-type (translate-type-spec type))
- (alien
- (alien::%heap-alien
- (alien::make-heap-alien-info
- :type (alien::parse-alien-type
- `(function
- void system-area-pointer ,alien-type))
- :sap-form (system:foreign-symbol-address writer))))
- (translate-argument (intern-argument-translator type))
- (cleanup (intern-cleanup-function type)))
+ (let ((writer (mkbinding writer 'nil class-name type)))
#'(lambda (value object)
- (let ((tmp (funcall translate-argument value))
- (location (proxy-location object)))
- (alien-funcall alien location tmp)
- (funcall cleanup tmp))))
+ (funcall writer object value)))
writer))))
location)))
~mdw / clg / commitdiff