From 9adccb27da69b60d058aa37867d55ea20ecf97ca Mon Sep 17 00:00:00 2001 Message-Id: <9adccb27da69b60d058aa37867d55ea20ecf97ca.1714419823.git.mdw@distorted.org.uk> From: Mark Wooding Date: Sat, 6 Nov 2004 21:39:57 +0000 Subject: [PATCH] Major cleanup of ffi abstraction layer Organization: Straylight/Edgeware From: espen --- atk/atk.lisp | 6 +- gdk/gdk.lisp | 29 +- gdk/gdkevents.lisp | 47 +- gdk/gdktypes.lisp | 21 +- glib/defpackage.lisp | 12 +- glib/ffi.lisp | 1019 +++++++++++++++++++----------------------- glib/gboxed.lisp | 116 ++--- glib/gcallback.lisp | 22 +- glib/genums.lisp | 228 ++++++---- glib/ginterface.lisp | 49 +- glib/glib.asd | 6 +- glib/glib.lisp | 410 +++++++++-------- glib/gobject.lisp | 175 ++++---- glib/gparam.lisp | 151 ++++--- glib/proxy.lisp | 320 ++++++------- gtk/gtk.lisp | 29 +- gtk/gtkobject.lisp | 81 +--- gtk/gtktypes.lisp | 6 +- gtk/gtkwidget.lisp | 4 +- pango/pango.lisp | 7 +- 20 files changed, 1379 insertions(+), 1359 deletions(-) diff --git a/atk/atk.lisp b/atk/atk.lisp index 1f9a731..8a2cd7c 100644 --- a/atk/atk.lisp +++ b/atk/atk.lisp @@ -15,12 +15,14 @@ ;; 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: atk.lisp,v 1.3 2004-10-31 11:44:45 espen Exp $ +;; $Id: atk.lisp,v 1.4 2004-11-06 21:39:57 espen Exp $ (in-package "ATK") (eval-when (:compile-toplevel :load-toplevel :execute) - (init-types-in-library "libatk-1.0.so")) + (init-types-in-library + #.(concatenate 'string (pkg-config:pkg-variable "atk" "libdir") + "/libatk-1.0.so") :prefix "atk_")) (define-types-by-introspection "Atk") diff --git a/gdk/gdk.lisp b/gdk/gdk.lisp index c258377..497b985 100644 --- a/gdk/gdk.lisp +++ b/gdk/gdk.lisp @@ -15,7 +15,7 @@ ;; 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: gdk.lisp,v 1.10 2004-10-31 11:51:08 espen Exp $ +;; $Id: gdk.lisp,v 1.11 2004-11-06 21:39:58 espen Exp $ (in-package "GDK") @@ -30,11 +30,12 @@ (defbinding (gdk-init "gdk_parse_args") () nil ;;; Display -(defbinding %display-manager-get () display-manager) +(defbinding (display-manager "gdk_display_manager_get") () display-manager) + (defbinding (display-set-default "gdk_display_manager_set_default_display") (display) nil - ((%display-manager-get) display-manager) + ((display-manager) display-manager) (display display)) (defbinding display-get-default () display) @@ -318,15 +319,6 @@ (defbinding rgb-init () nil) ;;; Cursor -(deftype-method alien-ref cursor (type-spec) - (declare (ignore type-spec)) - '%cursor-ref) - -(deftype-method alien-unref cursor (type-spec) - (declare (ignore type-spec)) - '%cursor-unref) - - (defbinding cursor-new () cursor (cursor-type cursor-type)) @@ -338,10 +330,19 @@ (defbinding cursor-new-from-pixmap () cursor (x int) (y int)) (defbinding %cursor-ref () pointer - (cursor (or cursor pointer))) + (location pointer)) (defbinding %cursor-unref () nil - (cursor (or cursor pointer))) + (location pointer)) + +(defmethod reference-foreign ((class (eql (find-class 'cursor))) location) + (declare (ignore class)) + (%cursor-ref location)) + +(defmethod unreference-foreign ((class (eql (find-class 'cursor))) location) + (declare (ignore class)) + (%cursor-unref location)) + diff --git a/gdk/gdkevents.lisp b/gdk/gdkevents.lisp index fe7e357..7b0b698 100644 --- a/gdk/gdkevents.lisp +++ b/gdk/gdkevents.lisp @@ -15,19 +15,13 @@ ;; 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: gdkevents.lisp,v 1.4 2004-10-31 11:53:30 espen Exp $ +;; $Id: gdkevents.lisp,v 1.5 2004-11-06 21:39:58 espen Exp $ (in-package "GDK") (defvar *event-classes* (make-hash-table)) -(defun %type-of-event (location) - (class-name - (gethash - (funcall (intern-reader-function 'event-type) location 0) - *event-classes*))) - (eval-when (:compile-toplevel :load-toplevel :execute) (defclass event (boxed) ((%type @@ -52,32 +46,32 @@ (defmethod initialize-instance ((event event) &rest initargs) (call-next-method) (setf (slot-value event '%type) (event-class-type (class-of event)))) -(deftype-method translate-from-alien - event (type-spec location &optional weak-ref) - (declare (ignore type-spec)) - `(let ((location ,location)) - (unless (null-pointer-p location) - (ensure-proxy-instance (%type-of-event location) location ,weak-ref)))) - ;;;; Metaclass for event classes (eval-when (:compile-toplevel :load-toplevel :execute) - (defclass event-class (proxy-class) + (defclass event-class (boxed-class) ((event-type :reader event-class-type))) + (defmethod validate-superclass ((class event-class) (super standard-class)) + (subtypep (class-name super) 'event))) + + +(defmethod shared-initialize ((class event-class) names &key name type) + (call-next-method) + (setf (slot-value class 'event-type) (first type)) + (setf (gethash (first type) *event-classes*) class) + (let ((class-name (or name (class-name class)))) + (register-type class-name 'event))) - (defmethod shared-initialize ((class event-class) names &key name type) - (call-next-method) - (setf (slot-value class 'event-type) (first type)) - (setf (gethash (first type) *event-classes*) class) - (let ((class-name (or name (class-name class)))) - (register-type class-name 'event))) - +(let ((reader (reader-function 'event-type))) + (defun %event-class (location) + (gethash (funcall reader location 0) *event-classes*))) - (defmethod validate-superclass - ((class event-class) (super pcl::standard-class)) - (subtypep (class-name super) 'event))) +(defmethod ensure-proxy-instance ((class event-class) location) + (declare (ignore class)) + (let ((class (%event-class location))) + (make-instance class :location location))) ;;;; @@ -88,13 +82,14 @@ (defclass timed-event (event) :accessor event-time :initarg :time :type (unsigned 32))) - (:metaclass proxy-class)) + (:metaclass event-class)) (defclass delete-event (event) () (:metaclass event-class) (:type :delete)) + (defclass destroy-event (event) () (:metaclass event-class) diff --git a/gdk/gdktypes.lisp b/gdk/gdktypes.lisp index a08da2e..bbc2f96 100644 --- a/gdk/gdktypes.lisp +++ b/gdk/gdktypes.lisp @@ -15,13 +15,21 @@ ;; 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: gdktypes.lisp,v 1.7 2002-03-19 19:06:22 espen Exp $ +;; $Id: gdktypes.lisp,v 1.8 2004-11-06 21:39:58 espen Exp $ (in-package "GDK") (eval-when (:compile-toplevel :load-toplevel :execute) - (init-types-in-library "libgdk-x11-2.0.so") - (init-types-in-library "libgdk_pixbuf-2.0.so")) + (init-types-in-library #.(concatenate 'string + (pkg-config:pkg-variable "gtk+-2.0" "libdir") + "/libgdk-x11-2.0.so") :prefix "gdk_") + (init-types-in-library #.(concatenate 'string + (pkg-config:pkg-variable "gtk+-2.0" "libdir") + "/libgdk-x11-2.0.so") :prefix "_gdk_") + (init-types-in-library #.(concatenate 'string + (pkg-config:pkg-variable "gtk+-2.0" "libdir") + "/libgdk_pixbuf-2.0.so") :prefix "gdk_")) + (defclass color (boxed) ((pixel @@ -63,11 +71,8 @@ (defclass cursor (struct) :accessor cursor-type :initarg :type :type cursor-type)) - (:metaclass proxy-class) - (:copy %cursor-copy) - (:free %cursor-free)) + (:metaclass struct-class)) (defclass device (struct) () - (:metaclass proxy-class)) - + (:metaclass struct-class)) diff --git a/glib/defpackage.lisp b/glib/defpackage.lisp index 7d3ecde..6fb1e46 100644 --- a/glib/defpackage.lisp +++ b/glib/defpackage.lisp @@ -15,22 +15,18 @@ ;; 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: defpackage.lisp,v 1.1 2004-10-27 14:48:00 espen Exp $ +;; $Id: defpackage.lisp,v 1.2 2004-11-06 21:39:58 espen Exp $ ;(export 'kernel::type-expand-1 "KERNEL") (defpackage "GLIB" - (:use "ALIEN" "C-CALL" "SYSTEM" "COMMON-LISP" "PCL" "AUTOEXPORT" - "GLIB-SYSTEM") - (;:shadowing- - :import-from "PCL" + (:use "ALIEN" "SYSTEM" "COMMON-LISP" "PCL" "AUTOEXPORT") + (:import-from "PCL" "LOCATION" "ALLOCATION" "DIRECT-SLOTS" "READER-FUNCTION" "WRITER-FUNCTION" "BOUNDP-FUNCTION" "INITIALIZE-INTERNAL-SLOT-FUNCTIONS" "COMPUTE-SLOT-ACCESSOR-INFO" "COMPUTE-EFFECTIVE-SLOT-DEFINITION-INITARGS" - #:initialize-internal-slot-gfs) - ; (:import-from "KERNEL" "TYPE-EXPAND-1") - (:export #:load-shared-library) + "INITIALIZE-INTERNAL-SLOT-GFS") (:export "DEFTYPE-METHOD" "TRANSLATE-TYPE-SPEC" "TRANSLATE-TO-ALIEN" "TRANSLATE-FROM-ALIEN" "CLEANUP-ALIEN" "UNREFERENCE-ALIEN" "SIZE-OF") diff --git a/glib/ffi.lisp b/glib/ffi.lisp index 6fe93a5..0391858 100644 --- a/glib/ffi.lisp +++ b/glib/ffi.lisp @@ -15,221 +15,27 @@ ;; 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: ffi.lisp,v 1.1 2004-10-27 14:46:01 espen Exp $ +;; $Id: ffi.lisp,v 1.2 2004-11-06 21:39:58 espen Exp $ (in-package "GLIB") -;;;; Type methods - -(defvar *type-methods* (make-hash-table)) - -(defun ensure-type-method-fun (fname) - (unless (fboundp fname) - (setf - (symbol-function fname) - #'(lambda (type-spec &rest args) - (apply - (find-applicable-type-method type-spec fname) type-spec args))))) - -(defmacro define-type-method-fun (fname lambda-list) - (declare (ignore lambda-list)) - `(defun ,fname (type-spec &rest args) - (apply - (find-applicable-type-method type-spec ',fname) type-spec args))) - - -(defun ensure-type-name (type) - (etypecase type - (symbol type) - (pcl::class (class-name type)))) - -(defun add-type-method (type fname function) - (push - (cons fname function) - (gethash (ensure-type-name type) *type-methods*))) - -(defun find-type-method (type fname) - (cdr (assoc fname (gethash (ensure-type-name type) *type-methods*)))) - -(defun find-applicable-type-method (type-spec fname &optional (error t)) - (flet ((find-superclass-method (class) - (when (and class (class-finalized-p class)) -; (unless (class-finalized-p class) -; (finalize-inheritance class)) - (dolist (super (cdr (pcl::class-precedence-list class))) - (return-if (find-type-method super fname))))) - (find-expanded-type-method (type-spec) - (multiple-value-bind (expanded-type-spec expanded-p) - (type-expand-1 type-spec) - (cond - (expanded-p - (find-applicable-type-method expanded-type-spec fname nil)) - ((neq type-spec t) - (find-applicable-type-method t fname nil)))))) - - (or - (typecase type-spec - (pcl::class - (or - (find-type-method type-spec fname) - (find-superclass-method type-spec))) - (symbol - (or - (find-type-method type-spec fname) - (find-expanded-type-method type-spec) - (find-superclass-method (find-class type-spec nil)))) - (cons - (or - (find-type-method (first type-spec) fname) - (find-expanded-type-method type-spec))) - (t - (error "Invalid type specifier ~A" type-spec))) - (and - error - (error - "No applicable method for ~A when called with type specifier ~A" - fname type-spec))))) - -(defmacro deftype-method (fname type lambda-list &body body) - `(progn - (ensure-type-method-fun ',fname) - (add-type-method ',type ',fname #'(lambda ,lambda-list ,@body)) - ',fname)) - -;; To make the compiler happy -(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 weak-ref)) - (define-type-method-fun translate-from-alien (type-spec expr &optional weak-ref)) - (define-type-method-fun cleanup-alien (type-spec sap &otional weak-ref)) - (define-type-method-fun unreference-alien (type-spec sap))) - - -;;;; - -(defvar *type-function-cache* (make-hash-table :test #'equal)) - -(defun get-cached-function (type-spec fname) - (cdr (assoc fname (gethash type-spec *type-function-cache*)))) - -(defun set-cached-function (type-spec fname function) - (push (cons fname function) (gethash type-spec *type-function-cache*)) - function) - - -(defun intern-argument-translator (type-spec) - (or - (get-cached-function type-spec 'argument-translator) - (set-cached-function type-spec 'argument-translator - (compile - nil - `(lambda (object) - (declare (ignorable object)) - ,(translate-to-alien type-spec 'object t)))))) - -(defun intern-return-value-translator (type-spec) - (or - (get-cached-function type-spec 'return-value-translator) - (set-cached-function type-spec 'return-value-translator - (compile - nil - `(lambda (alien) - (declare (ignorable alien)) - ,(translate-from-alien type-spec 'alien nil)))))) - -(defun intern-cleanup-function (type-spec) - (or - (get-cached-function type-spec 'cleanup-function) - (set-cached-function type-spec 'cleanup-function - (compile - nil - `(lambda (alien) - (declare (ignorable alien)) - ,(cleanup-alien type-spec 'alien t)))))) - - - -;; Returns a function to write an object of the specified type -;; to a memory location -(defun intern-writer-function (type-spec) - (or - (get-cached-function type-spec 'writer-function) - (set-cached-function type-spec 'writer-function - (compile - nil - `(lambda (value sap offset) - (declare (ignorable value sap offset)) - (setf - (,(sap-ref-fname type-spec) sap offset) - ,(translate-to-alien type-spec 'value nil))))))) - -;; Returns a function to read an object of the specified type -;; from a memory location -(defun intern-reader-function (type-spec) - (or - (get-cached-function type-spec 'reader-function) - (set-cached-function type-spec 'reader-function - (compile - nil - `(lambda (sap offset) - (declare (ignorable sap offset)) - ,(translate-from-alien - type-spec `(,(sap-ref-fname type-spec) sap offset) t)))))) - -(defun intern-destroy-function (type-spec) - (if (atomic-type-p type-spec) - #'(lambda (sap offset) - (declare (ignore sap offset))) - (or - (get-cached-function type-spec 'destroy-function) - (set-cached-function type-spec 'destroy-function - (compile - nil - `(lambda (sap offset) - (declare (ignorable sap offset)) - ,(unreference-alien - type-spec `(,(sap-ref-fname type-spec) sap offset)))))))) - - - ;;;; -(defconstant +bits-per-unit+ 8 - "Number of bits in an addressable unit (byte)") - -;; Sizes of fundamental C types in addressable units +;; Sizes of fundamental C types in bytes (8 bits) (defconstant +size-of-short+ 2) (defconstant +size-of-int+ 4) (defconstant +size-of-long+ 4) -(defconstant +size-of-sap+ 4) +(defconstant +size-of-pointer+ 4) (defconstant +size-of-float+ 4) (defconstant +size-of-double+ 8) -(defun sap-ref-unsigned (sap offset) - (sap-ref-32 sap offset)) - -(defun sap-ref-signed (sap offset) - (signed-sap-ref-32 sap offset)) - -(defun sap-ref-fname (type-spec) - (let ((alien-type-spec (mklist (translate-type-spec type-spec)))) - (ecase (first alien-type-spec) - (unsigned - (ecase (second alien-type-spec) - (8 'sap-ref-8) - (16 'sap-ref-16) - (32 'sap-ref-32) - (64 'sap-ref-64))) - (signed - (ecase (second alien-type-spec) - (8 'signed-sap-ref-8) - (16 'signed-sap-ref-16) - (32 'signed-sap-ref-32) - (64 'signed-sap-ref-64))) - (system-area-pointer 'sap-ref-sap) - (single-float 'sap-ref-single) - (double-float 'sap-ref-double)))) +;; Sizes of fundamental C types in bits +(defconstant +bits-of-byte+ 8) +(defconstant +bits-of-short+ 16) +(defconstant +bits-of-int+ 32) +(defconstant +bits-of-long+ 32) + + ;;;; Foreign function call interface @@ -288,7 +94,7 @@ (defun default-type-name (alien-name) (rest parts) #\-) (find-prefix-package (first parts))))) -(defmacro defbinding (name lambda-list return-type-spec &rest docs/args) +(defmacro defbinding (name lambda-list return-type &rest docs/args) (multiple-value-bind (lisp-name c-name) (if (atom name) (values name (default-alien-fname name)) @@ -309,21 +115,24 @@ (defmacro defbinding (name lambda-list return-type-spec &rest docs/args) (namep expr) (member style '(:in :in-out))) (push expr lambda-list)) (push - (list (if (namep expr) (make-symbol (string expr)) (gensym)) expr type style) args))))) + (list (if (namep expr) + (make-symbol (string expr)) + (gensym)) + expr (mklist type) style) args))))) (%defbinding c-name lisp-name (or supplied-lambda-list (nreverse lambda-list)) - return-type-spec (reverse docs) (reverse args))))) + return-type (reverse docs) (reverse args))))) #+cmu -(defun %defbinding (foreign-name lisp-name lambda-list - return-type-spec docs args) - (ext:collect ((alien-types) (alien-bindings) (alien-parameters) - (alien-values) (alien-deallocators)) +(defun %defbinding (foreign-name lisp-name lambda-list return-type docs args) + (ext:collect ((alien-types) (alien-bindings) (alien-parameters) + (alien-values) (cleanup-forms)) (dolist (arg args) - (destructuring-bind (var expr type-spec style) arg - (let ((declaration (translate-type-spec type-spec)) - (deallocation (cleanup-alien type-spec var t))) + (destructuring-bind (var expr type style) arg + (let ((declaration (alien-type type)) + (cleanup (cleanup-form var type))) + (cond ((member style '(:out :in-out)) (alien-types `(* ,declaration)) @@ -331,17 +140,17 @@ (defun %defbinding (foreign-name lisp-name lambda-list (alien-bindings `(,var ,declaration ,@(when (eq style :in-out) - (list (translate-to-alien type-spec expr t))))) - (alien-values (translate-from-alien type-spec var nil))) - (deallocation + (list (to-alien-form expr type))))) + (alien-values (from-alien-form var type))) + (cleanup (alien-types declaration) (alien-bindings - `(,var ,declaration ,(translate-to-alien type-spec expr t))) + `(,var ,declaration ,(to-alien-form expr type))) (alien-parameters var) - (alien-deallocators deallocation)) + (cleanup-forms cleanup)) (t (alien-types declaration) - (alien-parameters (translate-to-alien type-spec expr t))))))) + (alien-parameters (to-alien-form expr type))))))) (let* ((alien-name (make-symbol (string lisp-name))) (alien-funcall `(alien-funcall ,alien-name ,@(alien-parameters)))) @@ -350,413 +159,525 @@ (defun %defbinding (foreign-name lisp-name lambda-list (declare (optimize (ext:inhibit-warnings 3))) (with-alien ((,alien-name (function - ,(translate-type-spec return-type-spec) + ,(alien-type return-type) ,@(alien-types)) :extern ,foreign-name) ,@(alien-bindings)) - ,(if return-type-spec - `(let ((result - ,(translate-from-alien return-type-spec alien-funcall nil))) - ,@(alien-deallocators) - (values result ,@(alien-values))) + ,(if return-type + `(values + (unwind-protect + ,(from-alien-form alien-funcall return-type) + ,@(cleanup-forms)) + ,@(alien-values)) `(progn - ,alien-funcall - ,@(alien-deallocators) - (values ,@(alien-values))))))))) + (unwind-protect + ,alien-funcall + ,@(cleanup-forms)) + (values ,@(alien-values))))))))) +;;; Creates bindings at runtime (defun mkbinding (name return-type &rest arg-types) - (declare (optimize (ext:inhibit-warnings 3))) - (let* ((ftype - `(function - ,@(mapcar #'translate-type-spec (cons return-type arg-types)))) + (declare (optimize (ext:inhibit-warnings 3))) + (let* ((ftype + `(function ,@(mapcar #'alien-type (cons return-type arg-types)))) (alien (alien::%heap-alien (alien::make-heap-alien-info :type (alien::parse-alien-type ftype) :sap-form (system:foreign-symbol-address name :flavor :code)))) - (translate-arguments - (mapcar #'intern-argument-translator arg-types)) - (translate-return-value (intern-return-value-translator return-type)) - (cleanup-arguments (mapcar #'intern-cleanup-function arg-types))) - + (translate-arguments (mapcar #'to-alien-function arg-types)) + (translate-return-value (from-alien-function return-type)) + (cleanup-arguments (mapcar #'cleanup-function arg-types))) + #'(lambda (&rest args) (map-into args #'funcall translate-arguments args) (prog1 - (funcall - translate-return-value (apply #'alien:alien-funcall alien args)) + (funcall translate-return-value + (apply #'alien:alien-funcall alien args)) (mapc #'funcall cleanup-arguments args))))) - -(defun type-translateable-p (type-spec) - (find-applicable-type-method type-spec 'translate-type-spec nil)) - -(defun every-type-translateable-p (type-specs) - (every #'type-translateable-p type-specs)) - -(defun mkbinding-late (name return-type &rest arg-types) - (if (every-type-translateable-p (cons return-type arg-types)) - (apply #'mkbinding name return-type arg-types) - (let ((binding nil)) - #'(lambda (&rest args) - (cond - (binding (apply binding args)) - ((every-type-translateable-p (cons return-type arg-types)) - (setq binding (apply #'mkbinding name return-type arg-types)) - (apply binding args)) - (t - (dolist (type-spec (cons return-type arg-types)) - (unless (type-translateable-p type-spec) - (error "Can't translate type ~A" type-spec))))))))) - ;;;; Definitons and translations of fundamental types -(deftype long (&optional (min '*) (max '*)) `(integer ,min ,max)) -(deftype unsigned-long (&optional (min '*) (max '*)) `(integer ,min ,max)) -(deftype int (&optional (min '*) (max '*)) `(long ,min ,max)) -(deftype unsigned-int (&optional (min '*) (max '*)) `(unsigned-long ,min ,max)) -(deftype short (&optional (min '*) (max '*)) `(int ,min ,max)) -(deftype unsigned-short (&optional (min '*) (max '*)) `(unsigned-int ,min ,max)) -(deftype signed (&optional (size '*)) `(signed-byte ,size)) -(deftype unsigned (&optional (size '*)) `(signed-byte ,size)) -(deftype char () 'base-char) -(deftype pointer () 'system-area-pointer) -(deftype boolean (&optional (size '*)) - (declare (ignore size)) - `(member t nil)) -(deftype invalid () nil) - -(defun atomic-type-p (type-spec) - (or - (eq type-spec 'pointer) - (not (eq (translate-type-spec type-spec) 'system-area-pointer)))) - - -(deftype-method cleanup-alien t (type-spec sap &optional weak-ref) - (declare (ignore type-spec sap weak-ref)) - nil) - - -(deftype-method translate-to-alien integer (type-spec number &optional weak-ref) - (declare (ignore type-spec weak-ref)) - number) - -(deftype-method translate-from-alien integer (type-spec number &optional weak-ref) - (declare (ignore type-spec weak-ref)) - number) - - -(deftype-method translate-type-spec fixnum (type-spec) - (declare (ignore type-spec)) - (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 weak-ref) - (declare (ignore type-spec weak-ref)) - number) - -(deftype-method translate-from-alien fixnum (type-spec number &optional weak-ref) - (declare (ignore type-spec weak-ref)) - number) - - -(deftype-method translate-type-spec long (type-spec) - (declare (ignore type-spec)) - `(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 ,(* +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)) - `(unsigned ,(* +bits-per-unit+ +size-of-int+))) - -(deftype-method size-of unsigned-int (type-spec) - (declare (ignore type-spec)) - +size-of-int+) - +(defmacro def-type-method (name args &optional documentation) + `(progn + (defgeneric ,name (,@args type &rest args) + ,@(when documentation `((:documentation ,documentation)))) + (defmethod ,name (,@args (type symbol) &rest args) + (let ((class (find-class type nil))) + (if class + (apply #',name ,@args class args) + (multiple-value-bind (super-type expanded-p) + (type-expand-1 (cons type args)) + (if expanded-p + (,name ,@args super-type) + (call-next-method)))))) + (defmethod ,name (,@args (type cons) &rest args) + (declare (ignore args)) + (apply #',name ,@args (first type) (rest type))))) + -(deftype-method translate-type-spec short (type-spec) - (declare (ignore type-spec)) - `(signed ,(* +bits-per-unit+ +size-of-short+))) +(def-type-method alien-type ()) +(def-type-method size-of ()) +(def-type-method to-alien-form (form)) +(def-type-method from-alien-form (form)) +(def-type-method cleanup-form (form) + "Creates a form to clean up after the alien call has finished.") -(deftype-method size-of short (type-spec) - (declare (ignore type-spec)) - +size-of-short+) +(def-type-method to-alien-function ()) +(def-type-method from-alien-function ()) +(def-type-method cleanup-function ()) +(def-type-method writer-function ()) +(def-type-method reader-function ()) +(def-type-method destroy-function ()) -(deftype-method translate-type-spec unsigned-short (type-spec) - (declare (ignore type-spec)) - `(unsigned ,(* +bits-per-unit+ +size-of-short+))) -(deftype-method size-of unsigned-short (type-spec) - (declare (ignore type-spec)) - +size-of-short+) +(deftype int () '(signed-byte #.+bits-of-int+)) +(deftype unsigned-int () '(unsigned-byte #.+bits-of-int+)) +(deftype long () '(signed-byte #.+bits-of-long+)) +(deftype unsigned-long () '(unsigned-byte #.+bits-of-long+)) +(deftype short () '(signed-byte #.+bits-of-short+)) +(deftype unsigned-short () '(unsigned-byte #.+bits-of-short+)) +(deftype signed (&optional (size '*)) `(signed-byte ,size)) +(deftype unsigned (&optional (size '*)) `(unsigned-byte ,size)) +(deftype char () 'base-char) +(deftype pointer () 'system-area-pointer) +(deftype boolean (&optional (size '*)) (declare (ignore size)) `(member t nil)) +;(deftype invalid () nil) -(deftype-method translate-type-spec signed-byte (type-spec) - (let ((size (second (mklist (type-expand-to 'signed-byte type-spec))))) - `(signed - ,(cond - ((member size '(nil *)) (* +bits-per-unit+ +size-of-int+)) - (t size))))) +(defmethod to-alien-form (form (type t) &rest args) + (declare (ignore type args)) + form) -(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+))))) +(defmethod to-alien-function ((type t) &rest args) + (declare (ignore type args)) + #'identity) -(deftype-method translate-to-alien signed-byte (type-spec number &optional weak-ref) - (declare (ignore type-spec weak-ref)) - number) +(defmethod from-alien-form (form (type t) &rest args) + (declare (ignore type args)) + form) -(deftype-method translate-from-alien signed-byte - (type-spec number &optional weak-ref) - (declare (ignore type-spec weak-ref)) - number) +(defmethod from-alien-function ((type t) &rest args) + (declare (ignore type args)) + #'identity) + +(defmethod cleanup-form (form (type t) &rest args) + (declare (ignore form type args)) + nil) +(defmethod cleanup-function ((type t) &rest args) + (declare (ignore type args)) + #'identity) + +(defmethod destroy-function ((type t) &rest args) + (declare (ignore type args)) + #'(lambda (location offset) + (declare (ignore location offset)))) + + +(defmethod alien-type ((type (eql 'signed-byte)) &rest args) + (declare (ignore type)) + (destructuring-bind (&optional (size '*)) args + (ecase size + (#.+bits-of-byte+ '(signed-byte 8)) + (#.+bits-of-short+ 'c-call:short) + ((* #.+bits-of-int+) 'c-call:int) + (#.+bits-of-long+ 'c-call:long)))) + +(defmethod size-of ((type (eql 'signed-byte)) &rest args) + (declare (ignore type)) + (destructuring-bind (&optional (size '*)) args + (ecase size + (#.+bits-of-byte+ 1) + (#.+bits-of-short+ +size-of-short+) + ((* #.+bits-of-int+) +size-of-int+) + (#.+bits-of-long+ +size-of-long+)))) + +(defmethod writer-function ((type (eql 'signed-byte)) &rest args) + (declare (ignore type)) + (destructuring-bind (&optional (size '*)) args + (let ((size (if (eq size '*) +bits-of-int+ size))) + (ecase size + (8 #'(lambda (value location &optional (offset 0)) + (setf (signed-sap-ref-8 location offset) value))) + (16 #'(lambda (value location &optional (offset 0)) + (setf (signed-sap-ref-16 location offset) value))) + (32 #'(lambda (value location &optional (offset 0)) + (setf (signed-sap-ref-32 location offset) value))) + (64 #'(lambda (value location &optional (offset 0)) + (setf (signed-sap-ref-64 location offset) value))))))) + +(defmethod reader-function ((type (eql 'signed-byte)) &rest args) + (declare (ignore type)) + (destructuring-bind (&optional (size '*)) args + (let ((size (if (eq size '*) +bits-of-int+ size))) + (ecase size + (8 #'(lambda (sap &optional (offset 0)) + (signed-sap-ref-8 sap offset))) + (16 #'(lambda (sap &optional (offset 0)) + (signed-sap-ref-16 sap offset))) + (32 #'(lambda (sap &optional (offset 0)) + (signed-sap-ref-32 sap offset))) + (64 #'(lambda (sap &optional (offset 0)) + (signed-sap-ref-64 sap offset))))))) + +(defmethod alien-type ((type (eql 'unsigned-byte)) &rest args) + (destructuring-bind (&optional (size '*)) args + (ecase size + (#.+bits-of-byte+ '(unsigned-byte 8)) + (#.+bits-of-short+ 'c-call:unsigned-short) + ((* #.+bits-of-int+) 'c-call:unsigned-int) + (#.+bits-of-long+ 'c-call:unsigned-long)))) + +(defmethod size-of ((type (eql 'unsigned-byte)) &rest args) + (apply #'size-of 'signed args)) + +(defmethod writer-function ((type (eql 'unsigned-byte)) &rest args) + (declare (ignore type)) + (destructuring-bind (&optional (size '*)) args + (let ((size (if (eq size '*) +bits-of-int+ size))) + (ecase size + (8 #'(lambda (value location &optional (offset 0)) + (setf (sap-ref-8 location offset) value))) + (16 #'(lambda (value location &optional (offset 0)) + (setf (sap-ref-16 location offset) value))) + (32 #'(lambda (value location &optional (offset 0)) + (setf (sap-ref-32 location offset) value))) + (64 #'(lambda (value location &optional (offset 0)) + (setf (sap-ref-64 location offset) value))))))) + +(defmethod reader-function ((type (eql 'unsigned-byte)) &rest args) + (declare (ignore type)) + (destructuring-bind (&optional (size '*)) args + (let ((size (if (eq size '*) +bits-of-int+ size))) + (ecase size + (8 #'(lambda (sap &optional (offset 0)) + (sap-ref-8 sap offset))) + (16 #'(lambda (sap &optional (offset 0)) + (sap-ref-16 sap offset))) + (32 #'(lambda (sap &optional (offset 0)) + (sap-ref-32 sap offset))) + (64 #'(lambda (sap &optional (offset 0)) + (sap-ref-64 sap offset))))))) + + +(defmethod alien-type ((type (eql 'integer)) &rest args) + (declare (ignore type args)) + (alien-type 'signed-byte)) -(deftype-method translate-type-spec unsigned-byte (type-spec) - (let ((size (second (mklist (type-expand-to 'unsigned-byte type-spec))))) - `(signed - ,(cond - ((member size '(nil *)) (* +bits-per-unit+ +size-of-int+)) - (t size))))) +(defmethod size-of ((type (eql 'integer)) &rest args) + (declare (ignore type args)) + (size-of 'signed-byte)) -(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 weak-ref) - (declare (ignore type-spec weak-ref)) - number) +(defmethod alien-type ((type (eql 'fixnum)) &rest args) + (declare (ignore type args)) + (alien-type 'signed-byte)) -(deftype-method translate-from-alien unsigned-byte - (type-spec number &optional weak-ref) - (declare (ignore type-spec weak-ref)) - number) +(defmethod size-of ((type (eql 'fixnum)) &rest args) + (declare (ignore type args)) + (size-of 'signed-byte)) -(deftype-method translate-type-spec single-float (type-spec) - (declare (ignore type-spec)) - 'single-float) +(defmethod alien-type ((type (eql 'single-float)) &rest args) + (declare (ignore type args)) + 'alien:single-float) -(deftype-method size-of single-float (type-spec) - (declare (ignore type-spec)) +(defmethod size-of ((type (eql 'single-float)) &rest args) + (declare (ignore type args)) +size-of-float+) -(deftype-method translate-to-alien single-float (type-spec number &optional weak-ref) - (declare (ignore type-spec weak-ref)) - number) +(defmethod writer-function ((type (eql 'single-float)) &rest args) + (declare (ignore type args)) + #'(lambda (value location &optional (offset 0)) + (setf (sap-ref-single location offset) (coerce value 'single-float))))) -(deftype-method translate-from-alien single-float - (type-spec number &optional weak-ref) - (declare (ignore type-spec weak-ref)) - number) +(defmethod reader-function ((type (eql 'single-float)) &rest args) + (declare (ignore type args)) + #'(lambda (sap &optional (offset 0)) + (sap-ref-single sap offset))) -(deftype-method translate-type-spec double-float (type-spec) - (declare (ignore type-spec)) - 'double-float) +(defmethod alien-type ((type (eql 'double-float)) &rest args) + (declare (ignore type args)) + 'alien:double-float) -(deftype-method size-of double-float (type-spec) - (declare (ignore type-spec)) - +size-of-double+) +(defmethod size-of ((type (eql 'double-float)) &rest args) + (declare (ignore type args)) + +size-of-float+) -(deftype-method translate-to-alien double-float (type-spec number &optional weak-ref) - (declare (ignore type-spec weak-ref)) - `(coerce ,number 'double-float)) +(defmethod writer-function ((type (eql 'double-float)) &rest args) + (declare (ignore type args)) + #'(lambda (value location &optional (offset 0)) + (setf (sap-ref-double location offset) (coerce value 'double-float)))) -(deftype-method translate-from-alien double-float - (type-spec number &optional weak-ref) - (declare (ignore type-spec weak-ref)) - number) +(defmethod reader-function ((type (eql 'double-float)) &rest args) + (declare (ignore type args)) + #'(lambda (sap &optional (offset 0)) + (sap-ref-double sap offset))) -(deftype-method translate-type-spec base-char (type-spec) - (declare (ignore type-spec)) - `(unsigned ,+bits-per-unit+)) +(defmethod alien-type ((type (eql 'base-char)) &rest args) + (declare (ignore type args)) + 'c-call:char) -(deftype-method size-of base-char (type-spec) - (declare (ignore type-spec)) +(defmethod size-of ((type (eql 'base-char)) &rest args) + (declare (ignore type args)) 1) -(deftype-method translate-to-alien base-char (type-spec char &optional weak-ref) - (declare (ignore type-spec weak-ref)) - `(char-code ,char)) +(defmethod writer-function ((type (eql 'base-char)) &rest args) + (declare (ignore type args)) + #'(lambda (char location &optional (offset 0)) + (setf (sap-ref-8 location offset) (char-code char)))) -(deftype-method translate-from-alien base-char (type-spec code &optional weak-ref) - (declare (ignore type-spec weak-ref)) - `(code-char ,code)) +(defmethod reader-function ((type (eql 'base-char)) &rest args) + (declare (ignore type args)) + #'(lambda (location &optional (offset 0)) + (code-char (sap-ref-8 location offset)))) -(deftype-method translate-type-spec string (type-spec) - (declare (ignore type-spec)) - 'system-area-pointer) +(defmethod alien-type ((type (eql 'string)) &rest args) + (declare (ignore type args)) + (alien-type 'pointer)) -(deftype-method size-of string (type-spec) - (declare (ignore type-spec)) - +size-of-sap+) +(defmethod size-of ((type (eql 'string)) &rest args) + (declare (ignore type args)) + (size-of 'pointer)) -(deftype-method translate-to-alien string (type-spec string &optional weak-ref) - (declare (ignore type-spec weak-ref)) +(defmethod to-alien-form (string (type (eql 'string)) &rest args) + (declare (ignore type args)) `(let ((string ,string)) ;; Always copy strings to prevent seg fault due to GC (copy-memory (make-pointer (1+ (kernel:get-lisp-obj-address string))) (1+ (length string))))) - -(deftype-method translate-from-alien string - (type-spec c-string &optional weak-ref) - (declare (ignore type-spec)) - `(let ((c-string ,c-string)) - (unless (null-pointer-p c-string) - (prog1 - (c-call::%naturalize-c-string c-string) - ;,(unless weak-ref `(deallocate-memory c-string)) - )))) - -(deftype-method cleanup-alien string (type-spec c-string &optional weak-ref) - (when weak-ref - (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)))) - - -;;; Pathname - -(deftype-method translate-type-spec pathname (type-spec) - (declare (ignore type-spec)) - (translate-type-spec 'string)) - -(deftype-method size-of pathname (type-spec) - (declare (ignore type-spec)) - (size-of 'string)) - -(deftype-method translate-to-alien pathname (type-spec path &optional weak-ref) - (declare (ignore type-spec)) - (translate-to-alien 'string - `(namestring (translate-logical-pathname ,path)) weak-ref)) - -(deftype-method translate-from-alien pathname (type-spec c-string &optional weak-ref) - (declare (ignore type-spec)) - `(parse-namestring ,(translate-from-alien 'string c-string weak-ref))) - -(deftype-method cleanup-alien pathname (type-spec c-string &optional weak-ref) - (declare (ignore type-spec)) - (cleanup-alien 'string c-string weak-ref)) - -(deftype-method unreference-alien pathname (type-spec c-string) - (declare (ignore type-spec)) - (unreference-alien 'string c-string)) +(defmethod to-alien-function ((type (eql 'string)) &rest args) + (declare (ignore type args)) + #'(lambda (string) + (copy-memory + (make-pointer (1+ (kernel:get-lisp-obj-address string))) + (1+ (length string))))) + +(defmethod from-alien-form (string (type (eql 'string)) &rest args) + (declare (ignore type args)) + `(let ((string ,string)) + (unless (null-pointer-p string) + (c-call::%naturalize-c-string string)))) -(deftype-method translate-type-spec boolean (type-spec) - (translate-type-spec - (cons 'unsigned (cdr (mklist (type-expand-to 'boolean type-spec)))))) +(defmethod from-alien-function ((type (eql 'string)) &rest args) + (declare (ignore type args)) + #'(lambda (string) + (unless (null-pointer-p string) + (c-call::%naturalize-c-string string)))) -(deftype-method size-of boolean (type-spec) - (size-of - (cons 'unsigned (cdr (mklist (type-expand-to 'boolean type-spec)))))) +(defmethod cleanup-form (string (type (eql 'string)) &rest args) + (declare (ignore type args)) + `(let ((string ,string)) + (unless (null-pointer-p string) + (deallocate-memory string)))) + +(defmethod cleanup-function ((type (eql 'string)) &rest args) + #'(lambda (string) + (unless (null-pointer-p string) + (deallocate-memory string)))) + +(defmethod writer-function ((type (eql 'string)) &rest args) + (declare (ignore type args)) + #'(lambda (string location &optional (offset 0)) + (assert (null-pointer-p (sap-ref-sap location offset))) + (setf (sap-ref-sap location offset) + (copy-memory + (make-pointer (1+ (kernel:get-lisp-obj-address string))) + (1+ (length string)))))) + +(defmethod reader-function ((type (eql 'string)) &rest args) + (declare (ignore type args)) + #'(lambda (location &optional (offset 0)) + (unless (null-pointer-p (sap-ref-sap location offset)) + (c-call::%naturalize-c-string (sap-ref-sap location offset))))) + +(defmethod destroy-function ((type (eql 'string)) &rest args) + (declare (ignore type args)) + #'(lambda (location &optional (offset 0)) + (unless (null-pointer-p (sap-ref-sap location offset)) + (deallocate-memory (sap-ref-sap location offset)) + (setf (sap-ref-sap location offset) (make-pointer 0))))) + + +(defmethod alien-type ((type (eql 'pathname)) &rest args) + (declare (ignore type args)) + (alien-type 'string)) + +(defmethod size-of ((type (eql 'pathname)) &rest args) + (declare (ignore type args)) + (size-of 'string)) -(deftype-method translate-to-alien boolean (type-spec boolean &optional weak-ref) - (declare (ignore type-spec weak-ref)) +(defmethod to-alien-form (path (type (eql 'pathname)) &rest args) + (declare (ignore type args)) + (to-alien-form `(namestring (translate-logical-pathname ,path)) 'string)) + +(defmethod to-alien-function ((type (eql 'pathname)) &rest args) + (declare (ignore type args)) + (let ((string-function (to-alien-function 'string))) + #'(lambda (path) + (funcall string-function (namestring path))))) + +(defmethod from-alien-form (string (type (eql 'pathname)) &rest args) + (declare (ignore type args)) + `(parse-namestring ,(from-alien-form string 'string))) + +(defmethod from-alien-function ((type (eql 'pathname)) &rest args) + (declare (ignore type args)) + (let ((string-function (from-alien-function 'string))) + #'(lambda (string) + (parse-namestring (funcall string-function string))))) + +(defmethod cleanup-form (string (type (eql 'pathnanme)) &rest args) + (declare (ignore type args)) + (cleanup-form string 'string)) + +(defmethod cleanup-function ((type (eql 'pathnanme)) &rest args) + (declare (ignore type args)) + (cleanup-function 'string)) + +(defmethod writer-function ((type (eql 'pathname)) &rest args) + (declare (ignore type args)) + (let ((string-writer (writer-function 'string))) + #'(lambda (path location &optional (offset 0)) + (funcall string-writer (namestring path) location offset)))) + +(defmethod reader-function ((type (eql 'pathname)) &rest args) + (declare (ignore type args)) + (let ((string-reader (reader-function 'string))) + #'(lambda (location &optional (offset 0)) + (let ((string (funcall string-reader location offset))) + (when string + (parse-namestring string)))))) + +(defmethod destroy-function ((type (eql 'pathname)) &rest args) + (declare (ignore type args)) + (destroy-function 'string)) + + +(defmethod alien-type ((type (eql 'boolean)) &rest args) + (apply #'alien-type 'signed-byte args)) + +(defmethod size-of ((type (eql 'boolean)) &rest args) + (apply #'size-of 'signed-byte args)) + +(defmethod to-alien-form (boolean (type (eql 'boolean)) &rest args) + (declare (ignore type args)) `(if ,boolean 1 0)) -(deftype-method translate-from-alien boolean (type-spec int &optional weak-ref) - (declare (ignore type-spec weak-ref)) - `(not (zerop ,int))) - - -(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))) +(defmethod to-alien-function ((type (eql 'boolean)) &rest args) + (declare (ignore type args)) + #'(lambda (boolean) + (if boolean 1 0))) + +(defmethod from-alien-form (boolean (type (eql 'boolean)) &rest args) + (declare (ignore type args)) + `(not (zerop ,boolean))) + +(defmethod from-alien-function ((type (eql 'boolean)) &rest args) + (declare (ignore type args)) + #'(lambda (boolean) + (not (zerop boolean)))) + +(defmethod writer-function ((type (eql 'boolean)) &rest args) + (declare (ignore type)) + (let ((writer (apply #'writer-function 'signed-byte args))) + #'(lambda (boolean location &optional (offset 0)) + (funcall writer (if boolean 1 0) location offset)))) + +(defmethod reader-function ((type (eql 'boolean)) &rest args) + (declare (ignore type)) + (let ((reader (apply #'reader-function 'signed-byte args))) + #'(lambda (location &optional (offset 0)) + (not (zerop (funcall reader location offset)))))) + + +(defmethod alien-type ((type (eql 'or)) &rest args) + (let ((alien-type (alien-type (first args)))) + (unless (every #'(lambda (type) + (eq alien-type (alien-type type))) + (rest args)) + (error "No common alien type specifier for union type: ~A" + (cons type args))) 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 weak-ref) - (destructuring-bind (name &rest type-specs) - (type-expand-to 'or union-type-spec) - (declare (ignore name)) - `(let ((value ,expr)) - (etypecase value - ,@(map - 'list - #'(lambda (type-spec) - (list type-spec (translate-to-alien type-spec 'value weak-ref))) - type-specs))))) - - -(deftype-method translate-type-spec system-area-pointer (type-spec) - (declare (ignore type-spec)) +(defmethod size-of ((type (eql 'or)) &rest args) + (declare (ignore type)) + (size-of (first args))) + +(defmethod to-alien-form (form (type (eql 'or)) &rest args) + (declare (ignore type)) + `(let ((value ,form)) + (etypecase value + ,@(mapcar + #'(lambda (type) + `(,type ,(to-alien-form 'value type))) + args)))) + +(defmethod to-alien-function ((type (eql 'or)) &rest types) + (declare (ignore type)) + (let ((functions (mapcar #'to-alien-function types))) + #'(lambda (value) + (loop + for function in functions + for type in types + when (typep value type) + do (return (funcall function value)) + finally (error "~S is not of type ~A" value `(or ,@types)))))) + +(defmethod alien-type ((type (eql 'system-area-pointer)) &rest args) + (declare (ignore type args)) 'system-area-pointer) -(deftype-method size-of system-area-pointer (type-spec) - (declare (ignore type-spec)) - +size-of-sap+) +(defmethod size-of ((type (eql 'system-area-pointer)) &rest args) + (declare (ignore type args)) + +size-of-pointer+) -(deftype-method translate-to-alien system-area-pointer (type-spec sap &optional weak-ref) - (declare (ignore type-spec weak-ref)) - sap) +(defmethod writer-function ((type (eql 'system-area-pointer)) &rest args) + (declare (ignore type args)) + #'(lambda (sap location &optional (offset 0)) + (setf (sap-ref-sap location offset) sap))) -(deftype-method translate-from-alien system-area-pointer - (type-spec sap &optional weak-ref) - (declare (ignore type-spec weak-ref)) - sap) +(defmethod reader-function ((type (eql 'system-area-pointer)) &rest args) + (declare (ignore type args)) + #'(lambda (location &optional (offset 0)) + (sap-ref-sap location offset))) -(deftype-method translate-type-spec null (type-spec) - (declare (ignore type-spec)) - 'system-area-pointer) +(defmethod alien-type ((type (eql 'null)) &rest args) + (declare (ignore type args)) + (alien-type 'pointer)) -(deftype-method translate-to-alien null (type-spec expr &optional weak-ref) - (declare (ignore type-spec expr weak-ref)) +(defmethod size-of ((type (eql 'null)) &rest args) + (declare (ignore type args)) + (size-of 'pointer)) + +(defmethod to-alien-form (null (type (eql 'null)) &rest args) + (declare (ignore null type args)) `(make-pointer 0)) +(defmethod to-alien-function ((type (eql 'null)) &rest args) + (declare (ignore type args)) + #'(lambda (null) + (declare (ignore null)) + (make-pointer 0))) -(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))) +(defmethod alien-type ((type (eql 'nil)) &rest args) + (declare (ignore type args)) + 'c-call:void) + +(defmethod from-alien-function ((type (eql 'nil)) &rest args) + (declare (ignore type args)) + #'(lambda (value) + (declare (ignore value)) + (values))) diff --git a/glib/gboxed.lisp b/glib/gboxed.lisp index f3a6270..caf5fb4 100644 --- a/glib/gboxed.lisp +++ b/glib/gboxed.lisp @@ -15,50 +15,56 @@ ;; 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.10 2004-10-27 14:58:59 espen Exp $ +;; $Id: gboxed.lisp,v 1.11 2004-11-06 21:39:58 espen Exp $ (in-package "GLIB") (eval-when (:compile-toplevel :load-toplevel :execute) - (init-types-in-library "libgobject-2.0.so") - (defclass boxed (proxy) - () - (:metaclass proxy-class) - (:copy %boxed-copy) - (:free %boxed-free))) + (init-types-in-library #.(concatenate 'string + (pkg-config:pkg-variable "glib-2.0" "libdir") + "/libgobject-2.0.so"))) -(defbinding %boxed-copy (type location) pointer - ((find-type-number type) type-number) - (location pointer)) - -(defbinding %boxed-free (type location) nil - ((find-type-number type) type-number) - (location pointer)) +(defclass boxed (proxy) + () + (:metaclass struct-class)) ;;;; Metaclass for boxed classes (eval-when (:compile-toplevel :load-toplevel :execute) - (defclass boxed-class (proxy-class) + (defclass boxed-class (struct-class) ()) + (defmethod validate-superclass ((class boxed-class) (super standard-class)) + (subtypep (class-name super) 'boxed))) - (defmethod shared-initialize ((class boxed-class) names - &rest initargs &key name alien-name) - (declare (ignore initargs names)) - (call-next-method) - - (let* ((class-name (or name (class-name class))) - (type-number - (find-type-number - (or (first alien-name) (default-alien-type-name class-name))))) - (register-type class-name type-number))) +(defmethod shared-initialize ((class boxed-class) names + &rest initargs &key name alien-name) + (declare (ignore initargs names)) + (call-next-method) + + (let* ((class-name (or name (class-name class))) + (type-number + (find-type-number + (or (first alien-name) (default-alien-type-name class-name))))) + (register-type class-name type-number))) - (defmethod validate-superclass - ((class boxed-class) (super pcl::standard-class)) - (subtypep (class-name super) 'boxed))) + +(defbinding %boxed-copy (type location) pointer + ((find-type-number type) type-number) + (location pointer)) + +(defbinding %boxed-free (type location) nil + ((find-type-number type) type-number) + (location pointer)) + +(defmethod reference-foreign ((class boxed-class) location) + (%boxed-copy (class-name class) location)) + +(defmethod unreference-foreign ((class boxed-class) location) + (%boxed-free (class-name class) location)) ;;;; @@ -73,31 +79,31 @@ (register-derivable-type 'boxed "GBoxed" 'expand-boxed-type) ;;;; Special boxed types -(defclass gstring (boxed) - () - (:metaclass boxed-class) - (:alien-name "GString")) - -(deftype-method translate-from-alien - gstring (type-spec location &optional weak-ref) - `(let ((location ,location)) - (unless (null-pointer-p location) - (prog1 - (c-call::%naturalize-c-string location) - ,(unless weak-ref - (unreference-alien type-spec location)))))) - -(deftype-method translate-to-alien - gstring (type-spec string &optional weak-ref) - (declare (ignore weak-ref)) - `(let ((string ,string)) - ;; Always copy strings to prevent seg fault due to GC - (funcall - ',(proxy-class-copy (find-class type-spec)) - ',type-spec - (make-pointer (1+ (kernel:get-lisp-obj-address string)))))) - -(deftype-method cleanup-alien gstring (type-spec c-string &optional weak-ref) - (when weak-ref - (unreference-alien type-spec c-string))) +;; (defclass gstring (boxed) +;; () +;; (:metaclass boxed-class) +;; (:alien-name "GString")) + +;; (deftype-method translate-from-alien +;; gstring (type-spec location &optional weak-ref) +;; `(let ((location ,location)) +;; (unless (null-pointer-p location) +;; (prog1 +;; (c-call::%naturalize-c-string location) +;; ,(unless weak-ref +;; (unreference-alien type-spec location)))))) + +;; (deftype-method translate-to-alien +;; gstring (type-spec string &optional weak-ref) +;; (declare (ignore weak-ref)) +;; `(let ((string ,string)) +;; ;; Always copy strings to prevent seg fault due to GC +;; (funcall +;; ',(proxy-class-copy (find-class type-spec)) +;; ',type-spec +;; (make-pointer (1+ (kernel:get-lisp-obj-address string)))))) + +;; (deftype-method cleanup-alien gstring (type-spec c-string &optional weak-ref) +;; (when weak-ref +;; (unreference-alien type-spec c-string))) diff --git a/glib/gcallback.lisp b/glib/gcallback.lisp index ee11387..520d7a8 100644 --- a/glib/gcallback.lisp +++ b/glib/gcallback.lisp @@ -15,7 +15,7 @@ ;; 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: gcallback.lisp,v 1.11 2004-11-01 00:08:49 espen Exp $ +;; $Id: gcallback.lisp,v 1.12 2004-11-06 21:39:58 espen Exp $ (in-package "GLIB") @@ -35,13 +35,16 @@ (defun register-callback-function (function) (check-type function (or null symbol function)) (register-user-data function)) -(def-callback closure-callback-marshal - (void (gclosure system-area-pointer) (return-value system-area-pointer) - (n-params unsigned-int) (param-values system-area-pointer) - (invocation-hint system-area-pointer) (callback-id unsigned-int)) +(def-callback closure-callback-marshal (c-call:void + (gclosure system-area-pointer) + (return-value system-area-pointer) + (n-params c-call:unsigned-int) + (param-values system-area-pointer) + (invocation-hint system-area-pointer) + (callback-id c-call:unsigned-int)) (callback-trampoline callback-id n-params param-values return-value)) -(def-callback %destroy-user-data (void (id unsigned-int)) +(def-callback %destroy-user-data (c-call:void (id c-call:unsigned-int)) (destroy-user-data id)) (defun make-callback-closure (function) @@ -75,7 +78,7 @@ (defun invoke-callback (callback-id type &rest args) ;;;; Timeouts and idle functions -(def-callback source-callback-marshal (void (callback-id unsigned-int)) +(def-callback source-callback-marshal (c-call:void (callback-id c-call:unsigned-int)) (callback-trampoline callback-id 0 nil (make-pointer 0))) (defbinding (timeout-add "g_timeout_add_full") @@ -172,8 +175,9 @@ (defmethod signal-connect ((gobject gobject) signal function &key after object) ;; TODO: define and signal conditions based on log-level ;(defun log-handler (domain log-level message) -(def-callback log-handler (void (domain c-string) (log-level int) - (message c-string)) +(def-callback log-handler (c-call:void (domain c-call:c-string) + (log-level c-call:int) + (message c-call:c-string)) (error "~A: ~A" domain message)) (setf (extern-alien "log_handler" system-area-pointer) (callback log-handler)) diff --git a/glib/genums.lisp b/glib/genums.lisp index 8200826..4fb3c10 100644 --- a/glib/genums.lisp +++ b/glib/genums.lisp @@ -15,35 +15,32 @@ ;; 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: genums.lisp,v 1.3 2001-10-21 22:02:01 espen Exp $ +;; $Id: genums.lisp,v 1.4 2004-11-06 21:39:58 espen Exp $ (in-package "GLIB") -(defun %map-mappings (args op) +(defun %map-enum (args op) (let ((current-value 0)) - (map - 'list + (mapcar #'(lambda (mapping) (destructuring-bind (symbol &optional (value current-value)) (mklist mapping) (setf current-value (1+ value)) (case op (:enum-int (list symbol value)) - (:flags-int (list symbol value #|(ash 1 value)|#)) + (:flags-int (list symbol value)) (:int-enum (list value symbol)) - (:int-flags (list value #|(ash 1 value)|# symbol)) + (:int-flags (list value symbol)) (:symbols symbol)))) - (if (integerp (first args)) - (rest args) - args)))) + args))) (defun %query-enum-or-flags-values (query-function class type) (multiple-value-bind (sap length) (funcall query-function (type-class-ref type)) (let ((values nil) - (size (proxy-class-size (find-class class))) - (proxy (make-proxy-instance class sap nil))) + (size (proxy-instance-size (find-class class))) + (proxy (make-instance class :location sap))) (dotimes (i length) (with-slots (location nickname value) proxy (setf location sap) @@ -56,42 +53,63 @@ (defun %query-enum-or-flags-values (query-function class type) values))) -;;;; Enum type +;;;; Generic enum type (deftype enum (&rest args) - `(member ,@(%map-mappings args :symbols))) - -(deftype-method translate-type-spec enum (type-spec) - (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)) - (size-of `(signed ,(first args))) - (size-of 'signed)))) - -(deftype-method translate-to-alien enum (type-spec expr &optional weak-ref) - (declare (ignore weak-ref)) - (let ((args (cdr (type-expand-to 'enum type-spec)))) - `(ecase ,expr - ,@(%map-mappings args :enum-int)))) - -(deftype-method translate-from-alien enum (type-spec expr &optional weak-ref) - (declare (ignore weak-ref)) - (destructuring-bind (name &rest args) (type-expand-to 'enum type-spec) - (declare (ignore name)) - `(ecase ,expr - ,@(%map-mappings args :int-enum)))) - -(eval-when (:compile-toplevel :load-toplevel :execute) - (defclass %enum-value (static) - ((value :allocation :alien :type int) - (name :allocation :alien :type string) - (nickname :allocation :alien :type string)) - (:metaclass proxy-class))) + `(member ,@(%map-enum args :symbols))) + +(defmethod alien-type ((type (eql 'enum)) &rest args) + (declare (ignore type args)) + (alien-type 'signed)) + +(defmethod size-of ((type (eql 'enum)) &rest args) + (declare (ignore type args)) + (size-of 'signed)) + +(defmethod to-alien-form (form (type (eql 'enum)) &rest args) + (declare (ignore type)) + `(ecase ,form + ,@(%map-enum args :enum-int))) + +(defmethod from-alien-form (form (type (eql 'enum)) &rest args) + (declare (ignore type)) + `(ecase ,form + ,@(%map-enum args :int-enum))) + +(defmethod to-alien-function ((type (eql 'enum)) &rest args) + (let ((mappings (%map-enum args :enum-int))) + #'(lambda (enum) + (or + (second (assoc enum mappings)) + (error "~S is not of type ~S" enum (cons type args)))))) + +(defmethod from-alien-function ((type (eql 'enum)) &rest args) + (declare (ignore type)) + (let ((mappings (%map-enum args :int-enum))) + #'(lambda (int) + (second (assoc int mappings))))) + +(defmethod writer-function ((type (eql 'enum)) &rest args) + (declare (ignore type)) + (let ((writer (writer-function 'signed)) + (function (apply #'to-alien-function 'enum args))) + #'(lambda (enum location &optional (offset 0)) + (funcall writer (funcall function enum) location offset)))) + +(defmethod reader-function ((type (eql 'enum)) &rest args) + (declare (ignore type)) + (let ((reader (reader-function 'signed)) + (function (apply #'from-alien-function 'enum args))) + #'(lambda (location &optional (offset 0)) + (funcall function (funcall reader location offset))))) + + + +(defclass %enum-value (struct) + ((value :allocation :alien :type int) + (name :allocation :alien :type string) + (nickname :allocation :alien :type string)) + (:metaclass static-struct-class)) (defbinding %enum-class-values () pointer (class pointer) @@ -102,56 +120,80 @@ (defun query-enum-values (type) -;;;; Flags type +;;;; Generic flags type (deftype flags (&rest args) - `(or - null - (cons - (member ,@(%map-mappings args :symbols)) - list))) - -(deftype-method translate-type-spec flags (type-spec) - (let ((args (cdr (type-expand-to 'flags type-spec)))) - (if (integerp (first args)) - (translate-type-spec `(unsigned ,(first args))) - (translate-type-spec 'unsigned)))) - -(deftype-method size-of flags (type-spec) - (let ((args (cdr (type-expand-to 'flags type-spec)))) - (if (integerp (first args)) - (size-of `(unsigned ,(first args))) - (size-of 'unsigned)))) - -(deftype-method translate-to-alien flags (type-spec expr &optional weak-ref) - (declare (ignore weak-ref)) - (destructuring-bind (name &rest args) (type-expand-to 'flags type-spec) - (declare (ignore name)) - (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 weak-ref) - (declare (ignore weak-ref)) - (destructuring-bind (name &rest args) (type-expand-to 'flags type-spec) - (declare (ignore name)) - (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))))))) - - - -;(eval-when (:compile-toplevel :load-toplevel :execute) - (defclass %flags-value (static) - ((value :allocation :alien :type unsigned-int) - (name :allocation :alien :type string) - (nickname :allocation :alien :type string)) - (:metaclass proxy-class));) + `(or null (cons (member ,@(%map-enum args :symbols)) list))) + +(defmethod alien-type ((type (eql 'flags)) &rest args) + (declare (ignore type args)) + (alien-type 'unsigned)) + +(defmethod size-of ((type (eql 'flags)) &rest args) + (declare (ignore type args)) + (size-of 'unsigned)) + +(defmethod to-alien-form (flags (type (eql 'flags)) &rest args) + `(loop + with value = 0 + with flags = ,flags + for flag in (mklist flags) + do (let ((flagval + (or + (second (assoc flag ',(%map-enum args :flags-int))) + (error "~S is not of type ~S" flags '(,type ,@args))))) + (setq value (logior value flagval))) + finally (return value))) + +(defmethod from-alien-form (int (type (eql 'flags)) &rest args) + (declare (ignore type)) + `(loop + for mapping in ',(%map-enum args :int-flags) + unless (zerop (logand int (first mapping))) + collect (second mapping))) + +(defmethod to-alien-function ((type (eql 'flags)) &rest args) + (let ((mappings (%map-enum args :flags-int))) + #'(lambda (flags) + (loop + with value = 0 + for flag in (mklist flags) + do (let ((flagval (or + (second (assoc flag mappings)) + (error "~S is not of type ~S" flags (cons type args))))) + (setq value (logior value flagval))) + finally (return value))))) + +(defmethod from-alien-function ((type (eql 'flags)) &rest args) + (declare (ignore type)) + (let ((mappings (%map-enum args :int-flags))) + #'(lambda (int) + (loop + for mapping in mappings + unless (zerop (logand int (first mapping))) + collect (second mapping))))) + +(defmethod writer-function ((type (eql 'flags)) &rest args) + (declare (ignore type)) + (let ((writer (writer-function 'unsigned)) + (function (apply #'to-alien-function 'flags args))) + #'(lambda (flags location &optional (offset 0)) + (funcall writer (funcall function flags) location offset)))) + +(defmethod reader-function ((type (eql 'flags)) &rest args) + (declare (ignore type)) + (let ((reader (reader-function 'unsigned)) + (function (apply #'from-alien-function 'flags args))) + #'(lambda (location &optional (offset 0)) + (funcall function (funcall reader location offset))))) + + + +(defclass %flags-value (struct) + ((value :allocation :alien :type unsigned-int) + (name :allocation :alien :type string) + (nickname :allocation :alien :type string)) + (:metaclass static-struct-class)) (defbinding %flags-class-values () pointer (class pointer) diff --git a/glib/ginterface.lisp b/glib/ginterface.lisp index 47fc9a3..f0d3dcc 100644 --- a/glib/ginterface.lisp +++ b/glib/ginterface.lisp @@ -15,7 +15,7 @@ ;; 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: ginterface.lisp,v 1.3 2004-10-31 00:56:29 espen Exp $ +;; $Id: ginterface.lisp,v 1.4 2004-11-06 21:39:58 espen Exp $ (in-package "GLIB") @@ -26,30 +26,10 @@ (use-prefix "g") (defclass ginterface () ()) -(deftype-method translate-type-spec ginterface (type-spec) - (declare (ignore type-spec)) - (translate-type-spec 'gobject)) - -(deftype-method size-of ginterface (type-spec) - (declare (ignore type-spec)) - (size-of 'gobject)) - -(deftype-method translate-from-alien - ginterface (type-spec location &optional weak-ref) - (declare (ignore type-spec)) - (translate-from-alien 'gobject location weak-ref)) - -(deftype-method translate-to-alien - ginterface (type-spec instance &optional weak-ref) - (declare (ignore type-spec)) - (translate-to-alien 'gobject instance weak-ref)) - - - ;;;; Metaclass for interfaces (eval-when (:compile-toplevel :load-toplevel :execute) - (defclass ginterface-class (virtual-slot-class) + (defclass ginterface-class (virtual-slots-class) ())) (defmethod direct-slot-definition-class ((class ginterface-class) &rest initargs) @@ -90,6 +70,31 @@ (defmethod validate-superclass (subtypep (class-name super) 'ginterface)) +(defmethod alien-type ((class ginterface-class) &rest args) + (declare (ignore class args)) + (alien-type 'gobject)) + +(defmethod size-of ((class ginterface-class) &rest args) + (declare (ignore class args)) + (size-of 'gobject)) + +(defmethod from-alien-form (location (class ginterface-class) &rest args) + (declare (ignore class args)) + (from-alien-form location 'gobject)) + +(defmethod from-alien-function ((class ginterface-class) &rest args) + (declare (ignore class args)) + (from-alien-function 'gobject)) + +(defmethod to-alien-form (instance (class ginterface-class) &rest args) + (declare (ignore class args)) + (to-alien-form instance 'gobject)) + +(defmethod to-alien-function ((class ginterface-class) &rest args) + (declare (ignore class args)) + (to-alien-function 'gobject)) + + ;;;; diff --git a/glib/glib.asd b/glib/glib.asd index bc1d30e..c779bec 100644 --- a/glib/glib.asd +++ b/glib/glib.asd @@ -3,8 +3,7 @@ (asdf:oos 'asdf:load-op :clg-tools) (defpackage "GLIB-SYSTEM" - (:use "COMMON-LISP" "ASDF" "PKG-CONFIG") - (:export "*GTK-LIBRARY-PATH*")) + (:use "COMMON-LISP" "ASDF" "PKG-CONFIG")) (ext:unlock-all-packages) @@ -19,9 +18,6 @@ (defvar *cmucl-include-path* "/usr/lib/cmucl/include") -;; TODO: remove this -(defvar *gtk-library-path* (pkg-variable "gtk+-2.0" "libdir")) - (defsystem glib :depends-on (clg-tools) diff --git a/glib/glib.lisp b/glib/glib.lisp index f949d17..149d392 100644 --- a/glib/glib.lisp +++ b/glib/glib.lisp @@ -15,7 +15,7 @@ ;; 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.lisp,v 1.15 2004-11-01 00:08:49 espen Exp $ +;; $Id: glib.lisp,v 1.16 2004-11-06 21:39:58 espen Exp $ (in-package "GLIB") @@ -34,8 +34,8 @@ (defbinding (reallocate-memory "g_realloc") () pointer (defbinding (deallocate-memory "g_free") () nil (address pointer)) -;(defun deallocate-memory (address) -; (declare (ignore address))) +;; (defun deallocate-memory (address) +;; (declare (ignore address))) (defun copy-memory (from length &optional (to (allocate-memory length))) (kernel:system-area-copy from 0 to 0 (* 8 length)) @@ -122,7 +122,9 @@ (defun remove-quark (quark) ;;;; Linked list (GList) -(deftype glist (type) `(or (null (cons ,type list)))) +(deftype glist (type &key copy) + (declare (ignore copy)) + `(or (null (cons ,type list)))) (defbinding (%glist-append-unsigned "g_list_append") () pointer (glist pointer) @@ -136,70 +138,94 @@ (defbinding (%glist-append-sap "g_list_append") () pointer (glist pointer) (data pointer)) -(defmacro glist-append (glist value type-spec) - (ecase (first (mklist (translate-type-spec type-spec))) - (unsigned `(%glist-append-unsigned ,glist ,value)) - (signed `(%glist-append-signed ,glist ,value)) - (system-area-pointer `(%glist-append-sap ,glist ,value)))) - -(defmacro glist-data (glist type-spec) - (ecase (first (mklist (translate-type-spec type-spec))) - (unsigned `(sap-ref-unsigned ,glist 0)) - (signed `(sap-ref-signed ,glist 0)) - (system-area-pointer `(sap-ref-sap ,glist 0)))) +(defun make-glist (type list) + (let ((new-element (ecase (alien-type type) + (system-area-pointer #'%glist-append-sap) + ((signed-byte c-call:short c-call:int c-call:long) + #'%glist-append-signed) + ((unsigned-byte c-call:unsigned-short + c-call:unsigned-int c-call:unsigned-long) + #'%glist-append-unsigned))) + (to-alien (to-alien-function type))) + (loop + for element in list + as glist = (funcall new-element (or glist (make-pointer 0)) + (funcall to-alien element)) + finally (return glist)))) (defun glist-next (glist) (unless (null-pointer-p glist) - (sap-ref-sap glist +size-of-sap+))) + (sap-ref-sap glist +size-of-pointer+))) +;; Also used for gslists +(defun map-glist (seqtype function glist element-type) + (let ((reader (reader-function element-type))) + (case seqtype + ((nil) + (loop + as tmp = glist then (glist-next tmp) + until (null-pointer-p tmp) + do (funcall function (funcall reader tmp)))) + (list + (loop + as tmp = glist then (glist-next tmp) + until (null-pointer-p tmp) + collect (funcall function (funcall reader tmp)))) + (t + (coerce + (loop + as tmp = glist then (glist-next tmp) + until (null-pointer-p tmp) + collect (funcall function (funcall reader tmp))) + seqtype))))) + (defbinding (glist-free "g_list_free") () nil (glist pointer)) -(deftype-method translate-type-spec glist (type-spec) - (declare (ignore type-spec)) - (translate-type-spec 'pointer)) -(deftype-method size-of glist (type-spec) - (declare (ignore type-spec)) +(defmethod alien-type ((type (eql 'glist)) &rest args) + (declare (ignore type args)) + (alien-type 'pointer)) + +(defmethod size-of ((type (eql 'glist)) &rest args) + (declare (ignore type args)) (size-of 'pointer)) -(deftype-method translate-to-alien glist (type-spec list &optional weak-ref) - (declare (ignore weak-ref)) - (let* ((element-type (second (type-expand-to 'glist type-spec))) - (element (translate-to-alien element-type 'element))) - `(let ((glist (make-pointer 0))) - (dolist (element ,list glist) - (setq glist (glist-append glist ,element ,element-type)))))) - -(deftype-method translate-from-alien - glist (type-spec glist &optional weak-ref) - (let ((element-type (second (type-expand-to 'glist type-spec)))) - `(let ((glist ,glist) - (list nil)) - (do ((tmp glist (glist-next tmp))) - ((null-pointer-p tmp)) - (push - ,(translate-from-alien - element-type `(glist-data tmp ,element-type) weak-ref) - list)) - ,(unless weak-ref - '(glist-free glist)) - (nreverse list)))) - -(deftype-method cleanup-alien glist (type-spec glist &optional weak-ref) - (when weak-ref - (unreference-alien type-spec glist))) - -(deftype-method unreference-alien glist (type-spec glist) - (let ((element-type (second (type-expand-to 'glist type-spec)))) +(defmethod to-alien-form (list (type (eql 'glist)) &rest args) + (declare (ignore type)) + (destructuring-bind (element-type) args + `(make-glist ',element-type ,list))) + +(defmethod to-alien-function ((type (eql 'glist)) &rest args) + (declare (ignore type args)) + (destructuring-bind (element-type) args + #'(lambda (list) + (make-glist element-type list)))) + +(defmethod from-alien-form (glist (type (eql 'glist)) &rest args) + (declare (ignore type)) + (destructuring-bind (element-type) args `(let ((glist ,glist)) - (unless (null-pointer-p glist) - ,(unless (atomic-type-p element-type) - `(do ((tmp glist (glist-next tmp))) - ((null-pointer-p tmp)) - ,(unreference-alien - element-type `(glist-data tmp ,element-type)))) - (glist-free glist))))) + (unwind-protect + (map-glist 'list #'identity glist ',element-type) + (glist-free glist))))) + +(defmethod from-alien-function ((type (eql 'glist)) &rest args) + (declare (ignore type)) + (destructuring-bind (element-type) args + #'(lambda (glist) + (unwind-protect + (map-glist 'list #'identity glist element-type) + (glist-free glist))))) + +(defmethod cleanup-form (glist (type (eql 'glist)) &rest args) + (declare (ignore type args)) + `(glist-free ,glist)) + +(defmethod cleanup-function ((type (eql 'glist)) &rest args) + (declare (ignore type args)) + #'glist-free) + ;;;; Single linked list (GSList) @@ -218,163 +244,151 @@ (defbinding (%gslist-prepend-sap "g_slist_prepend") () pointer (gslist pointer) (data pointer)) -(defmacro gslist-prepend (gslist value type-spec) - (ecase (first (mklist (translate-type-spec type-spec))) - (unsigned `(%gslist-prepend-unsigned ,gslist ,value)) - (signed `(%gslist-prepend-signed ,gslist ,value)) - (system-area-pointer `(%gslist-prepend-sap ,gslist ,value)))) - +(defun make-gslist (type list) + (let ((new-element (ecase (alien-type type) + (system-area-pointer #'%gslist-prepend-sap) + ((signed-byte c-call:short c-call:int c-call:long) + #'%gslist-prepend-signed) + ((unsigned-byte c-call:unsigned-short + c-call:unsigned-int c-call:unsigned-long) + #'%gslist-prepend-unsigned))) + (to-alien (to-alien-function type))) + (loop + for element in (reverse list) + as gslist = (funcall new-element (or gslist (make-pointer 0)) + (funcall to-alien element)) + finally (return gslist)))) + (defbinding (gslist-free "g_slist_free") () nil (gslist pointer)) -(deftype-method translate-type-spec gslist (type-spec) - (declare (ignore type-spec)) - (translate-type-spec 'pointer)) -(deftype-method size-of gslist (type-spec) - (declare (ignore type-spec)) +(defmethod alien-type ((type (eql 'gslist)) &rest args) + (declare (ignore type args)) + (alien-type 'pointer)) + +(defmethod size-of ((type (eql 'gslist)) &rest args) + (declare (ignore type args)) (size-of 'pointer)) -(deftype-method translate-to-alien gslist (type-spec list &optional weak-ref) - (declare (ignore weak-ref)) - (let* ((element-type (second (type-expand-to 'gslist type-spec))) - (element (translate-to-alien element-type 'element))) - `(let ((gslist (make-pointer 0))) - (dolist (element (reverse ,list) gslist) - (setq gslist (gslist-prepend gslist ,element ,element-type)))))) - -(deftype-method translate-from-alien - gslist (type-spec gslist &optional weak-ref) - (let ((element-type (second (type-expand-to 'gslist type-spec)))) - `(let ((gslist ,gslist) - (list nil)) - (do ((tmp gslist (glist-next tmp))) - ((null-pointer-p tmp)) - (push - ,(translate-from-alien - element-type `(glist-data tmp ,element-type) weak-ref) - list)) - ,(unless weak-ref - '(gslist-free gslist)) - (nreverse list)))) - -(deftype-method cleanup-alien gslist (type-spec gslist &optional weak-ref) - (when weak-ref - (unreference-alien type-spec gslist))) - -(deftype-method unreference-alien gslist (type-spec gslist) - (let ((element-type (second (type-expand-to 'gslist type-spec)))) +(defmethod to-alien-form (list (type (eql 'gslist)) &rest args) + (declare (ignore type)) + (destructuring-bind (element-type) args + `(make-sglist ',element-type ,list))) + +(defmethod to-alien-function ((type (eql 'gslist)) &rest args) + (declare (ignore type args)) + (destructuring-bind (element-type) args + #'(lambda (list) + (make-gslist element-type list)))) + +(defmethod from-alien-form (gslist (type (eql 'gslist)) &rest args) + (declare (ignore type)) + (destructuring-bind (element-type) args `(let ((gslist ,gslist)) - (unless (null-pointer-p gslist) - ,(unless (atomic-type-p element-type) - `(do ((tmp gslist (glist-next tmp))) - ((null-pointer-p tmp)) - ,(unreference-alien - element-type `(glist-data tmp ,element-type)))) - (gslist-free gslist))))) + (unwind-protect + (map-glist 'list #'identity gslist ',element-type) + (gslist-free gslist))))) +(defmethod from-alien-function ((type (eql 'gslist)) &rest args) + (declare (ignore type)) + (destructuring-bind (element-type) args + #'(lambda (gslist) + (unwind-protect + (map-glist 'list #'identity gslist element-type) + (gslist-free gslist))))) +(defmethod cleanup-form (list (type (eql 'gslist)) &rest args) + (declare (ignore type args)) + `(gslist-free ,list)) -;;; Vector +(defmethod cleanup-function ((type (eql 'gslist)) &rest args) + (declare (ignore type args)) + #'gslist-free) -(defvar *magic-end-of-array* (allocate-memory 1)) -(deftype-method translate-type-spec vector (type-spec) - (declare (ignore type-spec)) - (translate-type-spec 'pointer)) -(deftype-method size-of vector (type-spec) - (declare (ignore type-spec)) - (size-of 'pointer)) +;;; Vector -(deftype-method translate-to-alien vector (type-spec vector &optional weak-ref) - (declare (ignore weak-ref)) - (destructuring-bind (element-type &optional (length '*)) - (cdr (type-expand-to 'vector type-spec)) - (let* ((element-size (size-of element-type)) - (size (cond - ((not (eq length '*)) - (* element-size length)) - ((not (atomic-type-p element-type)) - `(* ,element-size (1+ (length vector)))) - (t - `(* ,element-size (length vector)))))) - - `(let ((vector ,vector)) - (let ((c-vector (allocate-memory ,size))) - (dotimes (i ,(if (eq length '*) '(length vector) length)) - (setf - (,(sap-ref-fname element-type) c-vector (* i ,element-size)) - ,(translate-to-alien element-type '(aref vector i)))) - ,(when (and - (eq length '*) - (not (atomic-type-p element-type))) - `(setf - (sap-ref-sap c-vector (* (length vector) ,element-size)) - *magic-end-of-array*)) - c-vector))))) - -(deftype-method translate-from-alien - vector (type-spec c-array &optional weak-ref) - (destructuring-bind (element-type &optional (length '*)) - (cdr (type-expand-to 'vector type-spec)) - (when (eq length '*) - (error "Can't use vectors of variable length as return type")) - (let ((element-size (size-of element-type))) - `(let ((c-array ,c-array) - (vector (make-array ,length :element-type ',element-type))) - (dotimes (i ,length) - (setf - (aref vector i) - ,(translate-from-alien - element-type - `(,(sap-ref-fname element-type) c-array (* i ,element-size)) - weak-ref))) - ,(unless weak-ref - '(deallocate-memory c-vector)) - vector)))) - - -(deftype-method cleanup-alien vector (type-spec c-vector &optional weak-ref) - (when weak-ref - (unreference-alien type-spec c-vector))) - -(deftype-method unreference-alien vector (type-spec c-vector) - (destructuring-bind (element-type &optional (length '*)) - (cdr (type-expand-to 'vector type-spec)) - `(let ((c-vector ,c-vector)) - (unless (null-pointer-p c-vector) - ,(unless (atomic-type-p element-type) - (let ((element-size (size-of element-type))) - (if (not (eq length '*)) - `(dotimes (i ,length) - (unreference-alien - element-type (sap-ref-sap c-vector (* i ,element-size)))) - `(do ((offset 0 (+ offset ,element-size))) - ((sap= - (sap-ref-sap c-vector offset) - *magic-end-of-array*)) - ,(unreference-alien - element-type '(sap-ref-sap c-vector offset)))))) - (deallocate-memory c-vector))))) - - -(defun map-c-array (seqtype function location element-type length) - (let ((reader (intern-reader-function element-type)) - (size (size-of element-type))) +(defun make-c-vector (type length &optional content location) + (let* ((size-of-type (size-of type)) + (location (or location (allocate-memory (* size-of-type length)))) + (writer (writer-function type))) + (loop + for element across content + for i from 0 below length + as offset = 0 then (+ offset size-of-type) + do (funcall writer element location offset)) + location)) + + +(defun map-c-vector (seqtype function location element-type length) + (let ((reader (reader-function element-type)) + (size-of-element (size-of element-type))) (case seqtype ((nil) - (dotimes (i length) - (funcall function (funcall reader location (* i size))))) + (loop + for i from 0 below length + as offset = 0 then (+ offset size-of-element) + do (funcall function (funcall reader location offset)))) (list - (let ((list nil)) - (dotimes (i length) - (push (funcall function (funcall reader location (* i size))) list)) - (nreverse list))) + (loop + for i from 0 below length + as offset = 0 then (+ offset size-of-element) + collect (funcall function (funcall reader location offset)))) (t - (let ((sequence (make-sequence seqtype length))) - (dotimes (i length) - (setf + (loop + with sequence = (make-sequence seqtype length) + for i from 0 below length + as offset = 0 then (+ offset size-of-element) + do (setf (elt sequence i) - (funcall function (funcall reader location (* i size))))) - sequence))))) + (funcall function (funcall reader location offset))) + finally (return sequence)))))) + + +(defmethod alien-type ((type (eql 'vector)) &rest args) + (declare (ignore type args)) + (alien-type 'pointer)) + +(defmethod size-of ((type (eql 'vector)) &rest args) + (declare (ignore type args)) + (size-of 'pointer)) + +(defmethod to-alien-form (vector (type (eql 'vector)) &rest args) + (declare (ignore type)) + (destructuring-bind (element-type &optional (length '*)) args + (if (eq length '*) + `(let* ((vector ,vector) + (location (sap+ + (allocate-memory (+ ,+size-of-int+ + (* ,(size-of element-type) + (length vector)))) + ,+size-of-int+))) + (make-c-vector ',element-type (length vector) vector location) + (setf (sap-ref-32 location ,(- +size-of-int+)) (length vector)) + location) + `(make-c-vector ',element-type ,length ,vector)))) + +(defmethod from-alien-form (location (type (eql 'vector)) &rest args) + (declare (ignore type)) + (destructuring-bind (element-type &optional (length '*)) args + (if (eq length '*) + (error "Can't use vector of variable size as return type") + `(map-c-vector 'vector #'identity ',element-type ',length ,location)))) + +(defmethod cleanup-form (location (type (eql 'vector)) &rest args) + (declare (ignore type)) + (destructuring-bind (element-type &optional (length '*)) args + `(let* ((location ,location) + (length ,(if (eq length '*) + `(sap-ref-32 location ,(- +size-of-int+)) + length))) + (loop + with destroy = (destroy-function ',element-type) + for i from 0 below length + as offset = 0 then (+ offset ,(size-of element-type)) + do (funcall destroy location offset)) + (deallocate-memory ,(if (eq length '*) + `(sap+ location ,(- +size-of-int+)) + 'location))))) diff --git a/glib/gobject.lisp b/glib/gobject.lisp index 1ecc1b4..620b7ba 100644 --- a/glib/gobject.lisp +++ b/glib/gobject.lisp @@ -15,7 +15,7 @@ ;; 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: gobject.lisp,v 1.16 2004-11-03 16:18:16 espen Exp $ +;; $Id: gobject.lisp,v 1.17 2004-11-06 21:39:58 espen Exp $ (in-package "GLIB") @@ -24,84 +24,90 @@ (eval-when (:compile-toplevel :load-toplevel :execute) (defclass gobject (ginstance) () (:metaclass ginstance-class) - (:alien-name "GObject") - (:copy %object-ref) - (:free %object-unref))) + (:alien-name "GObject"))) + +(defmethod print-object ((instance gobject) stream) + (print-unreadable-object (instance stream :type t :identity nil) + (if (slot-boundp instance 'location) + (format stream "at 0x~X" (sap-int (proxy-location instance))) + (write-string "(destroyed)" stream)))) (defmethod initialize-instance ((object gobject) &rest initargs) - (let ((slotds (class-slots (class-of object))) - (names (make-array 0 :adjustable t :fill-pointer t)) - (values (make-array 0 :adjustable t :fill-pointer t))) - - (loop - as tmp = initargs then (cddr tmp) while tmp - as key = (first tmp) - as value = (second tmp) - as slotd = (find-if - #'(lambda (slotd) - (member key (slot-definition-initargs slotd))) - slotds) - when (and (typep slotd 'effective-property-slot-definition) - (slot-value slotd 'construct)) - do (let ((type (find-type-number (slot-definition-type slotd)))) - (vector-push-extend (slot-definition-pname slotd) names) - (vector-push-extend (gvalue-new type value) values) - (remf initargs key))) - - (setf - (slot-value object 'location) - (if (zerop (length names)) - (%gobject-new (type-number-of object)) - (%gobject-newvv (type-number-of object) (length names) names values))) - -; (map 'nil #'gvalue-free values) - ) + ;; Extract initargs which we should pass directly to the GObeject + ;; constructor + (let* ((slotds (class-slots (class-of object))) + (args (loop + as tmp = initargs then (cddr tmp) while tmp + as key = (first tmp) + as value = (second tmp) + as slotd = (find-if + #'(lambda (slotd) + (member key (slot-definition-initargs slotd))) + slotds) + when (and (typep slotd 'effective-property-slot-definition) + (slot-value slotd 'construct)) + collect (progn + (remf initargs key) + (list + (slot-definition-pname slotd) + (slot-definition-type slotd) + value))))) + (if args + (let* ((string-size (size-of 'string)) + (string-writer (writer-function 'string)) + (string-destroy (destroy-function 'string)) + (params (allocate-memory + (* (length args) (+ string-size +gvalue-size+))))) + (loop + for (pname type value) in args + as tmp = params then (sap+ tmp (+ string-size +gvalue-size+)) + do (funcall string-writer pname tmp) + (gvalue-init (sap+ tmp string-size) type value)) + (unwind-protect + (setf + (slot-value object 'location) + (%gobject-newv (type-number-of object) (length args) params)) + (loop + repeat (length args) + as tmp = params then (sap+ tmp (+ string-size +gvalue-size+)) + do (funcall string-destroy tmp) + (gvalue-unset (sap+ tmp string-size))) + (deallocate-memory params))) + (setf + (slot-value object 'location) + (%gobject-new (type-number-of object))))) (%object-weak-ref object) (apply #'call-next-method object initargs)) -(defmethod initialize-proxy ((object gobject) &rest initargs &key weak-ref) +(defmethod initialize-instance :around ((object gobject) &rest initargs) (declare (ignore initargs)) (call-next-method) - (%object-weak-ref object) - (unless weak-ref - (object-ref object))) + (%object-weak-ref object)) -(def-callback weak-notify (void (data int) (location system-area-pointer)) - (when (instance-cached-p location) - (warn "~A being finalized by the GObject system while still in existence in lisp" (find-cached-instance location)) - (remove-cached-instance location))) + +(def-callback weak-notify (c-call:void (data c-call:int) (location system-area-pointer)) + (let ((object (find-cached-instance location))) + (when object +;; (warn "~A being finalized by the GObject system while still in existence in lisp" object) + (slot-makunbound object 'location) + (remove-cached-instance location)))) (defbinding %object-weak-ref (object) nil (object gobject) ((callback weak-notify) pointer) (0 unsigned-int)) - (defbinding (%gobject-new "g_object_new") () pointer (type type-number) (nil null)) -(defbinding (%gobject-newvv "g_object_newvv") () pointer +(defbinding (%gobject-newv "g_object_newv") () pointer (type type-number) (n-parameters unsigned-int) - (names (vector string)) - (values (vector gvalue))) - - -(defbinding %object-ref (type location) pointer - (location pointer)) - - (defbinding %object-unref (type location) nil - (location pointer)) - -(defun object-ref (object) - (%object-ref nil (proxy-location object))) - -(defun object-unref (object) - (%object-unref nil (proxy-location object))) + (params pointer)) @@ -154,7 +160,7 @@ (defun object-data (object key &key (test #'eq)) ;;;; Metaclass used for subclasses of gobject -(eval-when (:compile-toplevel :load-toplevel :execute) +;(eval-when (:compile-toplevel :load-toplevel :execute) (defclass gobject-class (ginstance-class) ()) @@ -168,8 +174,21 @@ (defclass effective-property-slot-definition (effective-virtual-slot-definitio ((pname :reader slot-definition-pname :initarg :pname) (readable :reader slot-readable-p :initarg :readable) (writable :reader slot-writable-p :initarg :writable) - (construct :initarg :construct)))) + (construct :initarg :construct)));) +(defbinding %object-ref () pointer + (location pointer)) + +(defbinding %object-unref () nil + (location pointer)) + +(defmethod reference-foreign ((class gobject-class) location) + (declare (ignore class)) + (%object-ref location)) + +(defmethod unreference-foreign ((class gobject-class) location) + (declare (ignore class)) + (%object-unref location)) ; (defbinding object-class-install-param () nil @@ -215,14 +234,13 @@ (defmethod initialize-internal-slot-functions ((slotd effective-property-slot-de (setf (slot-value slotd 'reader-function) (if (slot-readable-p slotd) - #'(lambda (object) - (with-gc-disabled - (let ((gvalue (gvalue-new type-number))) - (%object-get-property object pname gvalue) - (unwind-protect - (funcall - (intern-reader-function (type-from-number type-number)) gvalue +gvalue-value-offset+) ; temporary workaround for wrong topological sorting of types - (gvalue-free gvalue t))))) + (let () ;(reader (reader-function (type-from-number type-number)))) + #'(lambda (object) + (let ((gvalue (gvalue-new type-number))) + (%object-get-property object pname gvalue) + (unwind-protect + (funcall #|reader|# (reader-function (type-from-number type-number)) gvalue +gvalue-value-offset+) + (gvalue-free gvalue t))))) #'(lambda (value object) (error "Slot is not readable: ~A" (slot-definition-name slotd)))))) @@ -230,18 +248,15 @@ (defmethod initialize-internal-slot-functions ((slotd effective-property-slot-de (setf (slot-value slotd 'writer-function) (if (slot-writable-p slotd) - #'(lambda (value object) - (with-gc-disabled - (let ((gvalue (gvalue-new type-number))) - (funcall - (intern-writer-function (type-from-number type-number)) ; temporary - value gvalue +gvalue-value-offset+) - (%object-set-property object pname gvalue) - (funcall - (intern-destroy-function (type-from-number type-number)) ; temporary - gvalue +gvalue-value-offset+) - (gvalue-free gvalue nil) - value))) + (let ();; (writer (writer-function (type-from-number type-number))) +;; (destroy (destroy-function (type-from-number type-number)))) + #'(lambda (value object) + (let ((gvalue (gvalue-new type-number))) + (funcall #|writer|# (writer-function (type-from-number type-number)) value gvalue +gvalue-value-offset+) + (%object-set-property object pname gvalue) +; (funcall #|destroy|#(destroy-function (type-from-number type-number)) gvalue +gvalue-value-offset+) + (gvalue-free gvalue t) + value))) #'(lambda (value object) (error "Slot is not writable: ~A" (slot-definition-name slotd)))))) @@ -270,9 +285,9 @@ (defbinding %object-class-list-properties () pointer (defun %map-params (params length type inherited-p) (if inherited-p - (map-c-array 'list #'identity params 'param length) + (map-c-vector 'list #'identity params 'param length) (let ((properties ())) - (map-c-array 'list + (map-c-vector 'list #'(lambda (param) (when (eql (param-owner-type param) type) (push param properties))) diff --git a/glib/gparam.lisp b/glib/gparam.lisp index 10bdc7e..1d90291 100644 --- a/glib/gparam.lisp +++ b/glib/gparam.lisp @@ -15,7 +15,7 @@ ;; 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: gparam.lisp,v 1.8 2004-10-28 09:33:56 espen Exp $ +;; $Id: gparam.lisp,v 1.9 2004-11-06 21:39:58 espen Exp $ (in-package "GLIB") @@ -24,27 +24,31 @@ (deftype gvalue () 'pointer) (eval-when (:compile-toplevel :load-toplevel :execute) (defbinding (size-of-gvalue "size_of_gvalue") () unsigned-int)) -(defconstant +gvalue-size+ (+ (size-of 'type-number) (* 2 (size-of 'double-float)))) +;(defconstant +gvalue-size+ (+ (size-of 'type-number) (* 2 (size-of 'double-float)))) (defconstant +gvalue-size+ #.(size-of-gvalue)) (defconstant +gvalue-value-offset+ (size-of 'type-number)) -(defbinding (gvalue-init "g_value_init") () nil +(defbinding (%gvalue-init "g_value_init") () nil (value gvalue) (type type-number)) (defbinding (gvalue-unset "g_value_unset") () nil (value gvalue)) +(defun gvalue-init (gvalue type &optional (value nil value-p)) + (%gvalue-init gvalue (find-type-number type)) + (when value-p + (funcall (writer-function type) value gvalue +gvalue-value-offset+))) (defun gvalue-new (type &optional (value nil value-p)) (let ((gvalue (allocate-memory +gvalue-size+))) - (gvalue-init gvalue (find-type-number type)) - (when value-p - (gvalue-set gvalue value)) + (if value-p + (gvalue-init gvalue type value) + (gvalue-init gvalue type)) gvalue)) -(defun gvalue-free (gvalue &optional unset-p) +(defun gvalue-free (gvalue &optional (unset-p t)) (unless (null-pointer-p gvalue) (when unset-p (gvalue-unset gvalue)) @@ -54,21 +58,15 @@ (defun gvalue-type (gvalue) (type-from-number (system:sap-ref-32 gvalue 0))) (defun gvalue-get (gvalue) - (funcall - (intern-reader-function (gvalue-type gvalue)) + (funcall (reader-function (gvalue-type gvalue)) gvalue +gvalue-value-offset+)) (defun gvalue-set (gvalue value) - (funcall - (intern-writer-function (gvalue-type gvalue)) + (funcall (writer-function (gvalue-type gvalue)) value gvalue +gvalue-value-offset+) value) -(deftype-method unreference-alien gvalue (type-spec location) - `(gvalue-free ,location nil)) - - (deftype param-flag-type () '(flags @@ -79,38 +77,61 @@ (deftype param-flag-type () (:lax-validation 16) (:private 32))) -;(eval-when (:compile-toplevel :load-toplevel :execute) +(eval-when (:compile-toplevel :load-toplevel :execute) + (defclass param-spec-class (ginstance-class) + ()) + + (defmethod validate-superclass + ((class param-spec-class) (super pcl::standard-class)) + t ;(subtypep (class-name super) 'param) +)) + + +(defbinding %param-spec-ref () pointer + (location pointer)) + +(defbinding %param-spec-unref () nil + (location pointer)) + +(defmethod reference-foreign ((class param-spec-class) location) + (declare (ignore class)) + (%param-spec-ref location)) + +(defmethod unreference-foreign ((class param-spec-class) location) + (declare (ignore class)) + (%param-spec-unref location)) + + + ;; TODO: rename to param-spec - (defclass param (ginstance) - ((name - :allocation :alien - :reader param-name - :type string) - (flags - :allocation :alien - :reader param-flags - :type param-flag-type) - (value-type - :allocation :alien - :reader param-value-type - :type type-number) - (owner-type - :allocation :alien - :reader param-owner-type - :type type-number) - (nickname - :allocation :virtual - :getter "g_param_spec_get_nick" - :reader param-nickname - :type string) - (documentation - :allocation :virtual - :getter "g_param_spec_get_blurb" - :reader param-documentation - :type string)) - (:metaclass ginstance-class) - (:ref "g_param_spec_ref") - (:unref "g_param_spec_unref"));) +(defclass param (ginstance) + ((name + :allocation :alien + :reader param-name + :type string) + (flags + :allocation :alien + :reader param-flags + :type param-flag-type) + (value-type + :allocation :alien + :reader param-value-type + :type type-number) + (owner-type + :allocation :alien + :reader param-owner-type + :type type-number) + (nickname + :allocation :virtual + :getter "g_param_spec_get_nick" + :reader param-nickname + :type string) + (documentation + :allocation :virtual + :getter "g_param_spec_get_blurb" + :reader param-documentation + :type string)) + (:metaclass param-spec-class)) (defclass param-char (param) @@ -126,7 +147,7 @@ (default-value :allocation :alien :reader param-char-default-value :type char)) - (:metaclass ginstance-class)) + (:metaclass param-spec-class)) (defclass param-unsigned-char (param) ( @@ -143,7 +164,7 @@ (defclass param-unsigned-char (param) ; :reader param-unsigned-char-default-value ; :type unsigned-char) ) - (:metaclass ginstance-class) + (:metaclass param-spec-class) (:alien-name "GParamUChar")) (defclass param-boolean (param) @@ -151,7 +172,7 @@ (defclass param-boolean (param) :allocation :alien :reader param-boolean-default-value :type boolean)) - (:metaclass ginstance-class)) + (:metaclass param-spec-class)) (defclass param-int (param) ((minimum @@ -166,7 +187,7 @@ (default-value :allocation :alien :reader param-int-default-value :type int)) - (:metaclass ginstance-class)) + (:metaclass param-spec-class)) (defclass param-unsigned-int (param) ((minimum @@ -181,7 +202,7 @@ (default-value :allocation :alien :reader param-unsigned-int-default-value :type unsigned-int)) - (:metaclass ginstance-class) + (:metaclass param-spec-class) (:alien-name "GParamUInt")) (defclass param-long (param) @@ -197,7 +218,7 @@ (default-value :allocation :alien :reader param-long-default-value :type long)) - (:metaclass ginstance-class)) + (:metaclass param-spec-class)) (defclass param-unsigned-long (param) ((minimum @@ -212,12 +233,12 @@ (default-value :allocation :alien :reader param-unsigned-long-default-value :type unsigned-long)) - (:metaclass ginstance-class) + (:metaclass param-spec-class) (:alien-name "GParamULong")) (defclass param-unichar (param) () - (:metaclass ginstance-class)) + (:metaclass param-spec-class)) (defclass param-enum (param) ((class @@ -228,7 +249,7 @@ (default-value :allocation :alien :reader param-enum-default-value :type long)) - (:metaclass ginstance-class)) + (:metaclass param-spec-class)) (defclass param-flags (param) ((class @@ -239,7 +260,7 @@ (default-value :allocation :alien :reader param-flags-default-value :type long)) - (:metaclass ginstance-class)) + (:metaclass param-spec-class)) (defclass param-single-float (param) ((minimum @@ -258,7 +279,7 @@ (default-value :allocation :alien :reader param-single-float-epsilon :type single-float)) - (:metaclass ginstance-class) + (:metaclass param-spec-class) (:alien-name "GParamFloat")) (defclass param-double-float (param) @@ -278,7 +299,7 @@ (default-value :allocation :alien :reader param-double-float-epsilon :type double-float)) - (:metaclass ginstance-class) + (:metaclass param-spec-class) (:alien-name "GParamDouble")) (defclass param-string (param) @@ -286,19 +307,19 @@ (defclass param-string (param) :allocation :alien :reader param-string-default-value :type string)) - (:metaclass ginstance-class)) + (:metaclass param-spec-class)) (defclass param-param (param) () - (:metaclass ginstance-class)) + (:metaclass param-spec-class)) (defclass param-boxed (param) () - (:metaclass ginstance-class)) + (:metaclass param-spec-class)) (defclass param-pointer (param) () - (:metaclass ginstance-class)) + (:metaclass param-spec-class)) (defclass param-value-array (param) ((element-spec @@ -309,12 +330,12 @@ (defclass param-value-array (param) :allocation :alien :reader param-value-array-length :type unsigned-int)) - (:metaclass ginstance-class)) + (:metaclass param-spec-class)) ;; (defclass param-closure (param) ;; () -;; (:metaclass ginstance-class)) +;; (:metaclass param-spec-class)) (defclass param-object (param) () - (:metaclass ginstance-class)) + (:metaclass param-spec-class)) diff --git a/glib/proxy.lisp b/glib/proxy.lisp index e9a0f13..eeecae1 100644 --- a/glib/proxy.lisp +++ b/glib/proxy.lisp @@ -15,20 +15,14 @@ ;; 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.10 2004-11-03 16:18:16 espen Exp $ +;; $Id: proxy.lisp,v 1.11 2004-11-06 21:39:58 espen Exp $ (in-package "GLIB") -(import -'(pcl::initialize-internal-slot-functions - pcl::compute-effective-slot-definition-initargs - pcl::compute-slot-accessor-info - pcl::reader-function pcl::writer-function pcl::boundp-function)) - ;;;; Superclass for all metaclasses implementing some sort of virtual slots (eval-when (:compile-toplevel :load-toplevel :execute) - (defclass virtual-slot-class (standard-class) + (defclass virtual-slots-class (standard-class) ()) (defclass direct-virtual-slot-definition (standard-direct-slot-definition) @@ -48,17 +42,16 @@ (defun most-specific-slot-value (instances slot &optional default) instances))) (if object (slot-value object slot) - default))) -) + default)))) -(defmethod direct-slot-definition-class ((class virtual-slot-class) &rest initargs) +(defmethod direct-slot-definition-class ((class virtual-slots-class) &rest initargs) (if (eq (getf initargs :allocation) :virtual) (find-class 'direct-virtual-slot-definition) (call-next-method))) -(defmethod effective-slot-definition-class ((class virtual-slot-class) &rest initargs) +(defmethod effective-slot-definition-class ((class virtual-slots-class) &rest initargs) (if (eq (getf initargs :allocation) :virtual) (find-class 'effective-virtual-slot-definition) (call-next-method))) @@ -76,10 +69,13 @@ (defmethod initialize-internal-slot-functions ((slotd effective-virtual-slot-def (error "Can't read slot: ~A" (slot-definition-name slotd)))) (symbol #'(lambda (object) (funcall getter object))) - (string (let ((reader (mkbinding-late getter - (slot-definition-type slotd) 'pointer))) + (string ;(let ()(reader (mkbinding getter +;; (slot-definition-type slotd) 'pointer))) (setf (slot-value slotd 'reader-function) #'(lambda (object) + (let ((reader + (mkbinding getter + (slot-definition-type slotd) 'pointer))) (funcall reader (proxy-location object))))))))) (unless (slot-boundp slotd 'writer-function) @@ -93,10 +89,14 @@ (defmethod initialize-internal-slot-functions ((slotd effective-virtual-slot-def ((or symbol cons) #'(lambda (value object) (funcall (fdefinition setter) value object))) (string - (let ((writer (mkbinding-late setter 'nil 'pointer - (slot-definition-type slotd)))) + (let ((writer ()));; (mkbinding setter 'nil 'pointer +;; (slot-definition-type slotd)))) (setf (slot-value slotd 'writer-function) #'(lambda (value object) + (unless writer + (setq writer + (mkbinding setter 'nil 'pointer + (slot-definition-type slotd)))) (funcall writer (proxy-location object) value)))))))) (unless (slot-boundp slotd 'boundp-function) @@ -117,7 +117,7 @@ (defmethod compute-slot-accessor-info ((slotd effective-virtual-slot-definition) type gf) nil) -(defmethod compute-effective-slot-definition-initargs ((class virtual-slot-class) direct-slotds) +(defmethod compute-effective-slot-definition-initargs ((class virtual-slots-class) direct-slotds) (if (eq (most-specific-slot-value direct-slotds 'allocation) :virtual) (nconc (list :getter (most-specific-slot-value direct-slotds 'getter) @@ -128,25 +128,25 @@ (defmethod compute-effective-slot-definition-initargs ((class virtual-slot-class (defmethod slot-value-using-class - ((class virtual-slot-class) (object standard-object) + ((class virtual-slots-class) (object standard-object) (slotd effective-virtual-slot-definition)) (if (funcall (slot-value slotd 'boundp-function) object) (funcall (slot-value slotd 'reader-function) object) (slot-unbound class object (slot-definition-name slotd)))) (defmethod slot-boundp-using-class - ((class virtual-slot-class) (object standard-object) + ((class virtual-slots-class) (object standard-object) (slotd effective-virtual-slot-definition)) (funcall (slot-value slotd 'boundp-function) object)) (defmethod (setf slot-value-using-class) - (value (class virtual-slot-class) (object standard-object) + (value (class virtual-slots-class) (object standard-object) (slotd effective-virtual-slot-definition)) (funcall (slot-value slotd 'writer-function) value object)) (defmethod validate-superclass - ((class virtual-slot-class) (super standard-class)) + ((class virtual-slots-class) (super standard-class)) t) @@ -171,90 +171,69 @@ (defun instance-cached-p (location) (defun remove-cached-instance (location) (remhash (system:sap-int location) *instance-cache*)) +;; For debuging +(defun cached-instances () + (let ((instances ())) + (maphash #'(lambda (location ref) + (declare (ignore location)) + (push (ext:weak-pointer-value ref) instances)) + *instance-cache*) + instances)) + ;;;; Proxy for alien instances -(eval-when (:compile-toplevel :load-toplevel :execute) - (defclass proxy () - ((location :reader proxy-location :type system-area-pointer))) +(defclass proxy () + ((location :reader proxy-location :type system-area-pointer))) - (defgeneric initialize-proxy (object &rest initargs)) - (defgeneric instance-finalizer (object))) +(defgeneric initialize-proxy (object &rest initargs)) +(defgeneric instance-finalizer (object)) +(defgeneric reference-foreign (class location)) +(defgeneric unreference-foreign (class location)) + +(defmethod unreference-foreign :around ((class class) location) + (unless (null-pointer-p location) +;; (format t "Unreferencing ~A at ~A" (class-name class) location) +;; (finish-output *standard-output*) + (call-next-method) +;; (write-line " done") +;; (finish-output *standard-output*) + )) (defmethod print-object ((instance proxy) stream) (print-unreadable-object (instance stream :type t :identity nil) (format stream "at 0x~X" (sap-int (proxy-location instance))))) +(defmethod print-object ((instance proxy) stream) + (print-unreadable-object (instance stream :type t :identity nil) + (format stream "at 0x~X" (sap-int (proxy-location instance))))) -(defmethod initialize-instance :after ((instance proxy) - &rest initargs &key) - (declare (ignore initargs)) - (cache-instance instance) - (ext:finalize instance (instance-finalizer instance))) -(defmethod initialize-proxy ((instance proxy) - &rest initargs &key location weak-ref) - (declare (ignore initargs)) - (setf - (slot-value instance 'location) - (if weak-ref - (funcall - (proxy-class-copy (class-of instance)) - (type-of instance) location) - location)) +(defmethod initialize-instance :around ((instance proxy) &key location) + (if location + (setf (slot-value instance 'location) location) + (call-next-method)) (cache-instance instance) - (ext:finalize instance (instance-finalizer instance))) + (ext:finalize instance (instance-finalizer instance)) + instance) (defmethod instance-finalizer ((instance proxy)) - (let ((class (class-of instance)) - (type (type-of instance)) - (location (proxy-location instance))) - (declare (type symbol type) (type system-area-pointer location)) - (let ((free (proxy-class-free class))) - #'(lambda () - (when (instance-cached-p location) - (remove-cached-instance location) - (funcall free type location)))))) - - -(deftype-method translate-type-spec proxy (type-spec) - (declare (ignore type-spec)) - (translate-type-spec 'pointer)) - -(deftype-method size-of proxy (type-spec) - (declare (ignore type-spec)) - (size-of 'pointer)) - -(deftype-method translate-from-alien - proxy (type-spec location &optional weak-ref) - `(let ((location ,location)) - (unless (null-pointer-p location) - (ensure-proxy-instance ',type-spec location ,weak-ref)))) - -(deftype-method translate-to-alien - proxy (type-spec instance &optional weak-ref) - (if weak-ref - `(proxy-location ,instance) - (let ((copy (proxy-class-copy (find-class type-spec)))) - (if (symbolp copy) - `(,copy ',type-spec (proxy-location ,instance)) - `(funcall ',copy ',type-spec (proxy-location ,instance)))))) - -(deftype-method unreference-alien proxy (type-spec location) - (let ((free (proxy-class-free (find-class type-spec)))) - (if (symbolp free) - `(,free ',type-spec ,location) - `(funcall ',free ',type-spec ,location)))) + (let ((location (proxy-location instance)) + (class (class-of instance))) +;; (unless (find-method #'unreference-foreign nil (list (class-of class) t) nil) +;; (error "No matching method for UNREFERENCE-INSTANCE when called with class ~A" class)) + #'(lambda () + (when (instance-cached-p location) + (remove-cached-instance location)) + (unreference-foreign class location)))) ;;;; Metaclass used for subclasses of proxy (eval-when (:compile-toplevel :load-toplevel :execute) - (defclass proxy-class (virtual-slot-class) - ((size :reader proxy-class-size) - (copy :reader proxy-class-copy) - (free :reader proxy-class-free))) + (defclass proxy-class (virtual-slots-class) + ((size :reader proxy-instance-size))) (defclass direct-alien-slot-definition (direct-virtual-slot-definition) ((allocation :initform :alien) @@ -277,26 +256,12 @@ (defmethod direct-proxy-superclass ((class proxy-class)) (class-direct-superclasses class))) (defmethod shared-initialize ((class proxy-class) names - &rest initargs &key size copy free) + &rest initargs &key size) (declare (ignore initargs)) (call-next-method) (cond (size (setf (slot-value class 'size) (first size))) - ((slot-boundp class 'size) (slot-makunbound class 'size))) - (cond - (copy (setf (slot-value class 'copy) (first copy))) - ((slot-boundp class 'copy) (slot-makunbound class 'copy))) - (cond - (free (setf (slot-value class 'free) (first free))) - ((slot-boundp class 'free) (slot-makunbound class 'free)))) - - (defmethod shared-initialize :after ((class proxy-class) names &rest initargs) - (let ((super (most-specific-proxy-superclass class))) - (unless (or (not super) (eq super (find-class 'proxy))) - (unless (or (slot-boundp class 'copy) (not (slot-boundp super 'copy))) - (setf (slot-value class 'copy) (proxy-class-copy super))) - (unless (or (slot-boundp class 'free) (not (slot-boundp super 'free))) - (setf (slot-value class 'free) (proxy-class-free super)))))) + ((slot-boundp class 'size) (slot-makunbound class 'size)))) (defmethod direct-slot-definition-class ((class proxy-class) &rest initargs) (case (getf initargs :allocation) @@ -319,23 +284,23 @@ (defmethod compute-effective-slot-definition-initargs ((class proxy-class) dir (defmethod initialize-internal-slot-functions ((slotd effective-alien-slot-definition)) (with-slots (offset) slotd - (let* ((type (slot-definition-type slotd)) - (reader (intern-reader-function type)) - (writer (intern-writer-function type)) - (destroy (intern-destroy-function type))) + (let ((type (slot-definition-type slotd))) (unless (slot-boundp slotd 'reader-function) - (setf - (slot-value slotd 'reader-function) - #'(lambda (object) - (funcall reader (proxy-location object) offset)))) + (let ((reader (reader-function type))) + (setf + (slot-value slotd 'reader-function) + #'(lambda (object) + (funcall reader (proxy-location object) offset))))) (unless (slot-boundp slotd 'writer-function) - (setf - (slot-value slotd 'writer-function) - #'(lambda (value object) - (let ((location (proxy-location object))) - (funcall destroy location offset) - (funcall writer value location offset))))) + (let ((writer (writer-function type)) + (destroy (destroy-function type))) + (setf + (slot-value slotd 'writer-function) + #'(lambda (value object) + (let ((location (proxy-location object))) + (funcall destroy location offset) ; destroy old value + (funcall writer value location offset)))))) (unless (slot-boundp slotd 'boundp-function) (setf @@ -350,9 +315,8 @@ (defmethod initialize-internal-slot-functions ((slotd effective-alien-slot-def (defconstant +struct-alignmen+ 4) (defmethod compute-slots ((class proxy-class)) - ;; This stuff should really go somewhere else (loop - with offset = (proxy-class-size (most-specific-proxy-superclass class)) + with offset = (proxy-instance-size (most-specific-proxy-superclass class)) with size = offset for slotd in (class-direct-slots class) when (eq (slot-definition-allocation slotd) :alien) @@ -372,69 +336,111 @@ (defmethod compute-slots ((class proxy-class)) (defmethod validate-superclass ((class proxy-class) (super standard-class)) (subtypep (class-name super) 'proxy)) - (defmethod proxy-class-size (class) + (defmethod proxy-instance-size (class) (declare (ignore class)) 0) ) -(defgeneric make-proxy-instance (class location weak-ref - &rest initargs &key));) +(defmethod alien-type ((class proxy-class) &rest args) + (declare (ignore class args)) + (alien-type 'pointer)) + +(defmethod size-of ((class proxy-class) &rest args) + (declare (ignore class args)) + (size-of 'pointer)) + +(defmethod from-alien-form (location (class proxy-class) &rest args) + (declare (ignore args)) + `(ensure-proxy-instance ',(class-name class) ,location)) + +(defmethod from-alien-function ((class proxy-class) &rest args) + (declare (ignore args)) + #'(lambda (location) + (ensure-proxy-instance class location))) -(defmethod make-proxy-instance ((class symbol) location weak-ref - &rest initargs &key) - (apply #'make-proxy-instance (find-class class) location weak-ref initargs)) +(defmethod to-alien-form (instance (class proxy-class) &rest args) + (declare (ignore class args)) + `(proxy-location ,instance)) -(defmethod make-proxy-instance ((class proxy-class) location weak-ref - &rest initargs &key) - (let ((instance (allocate-instance class))) - (apply - #'initialize-proxy - instance :location location :weak-ref weak-ref initargs) - instance)) +(defmethod to-alien-function ((class proxy-class) &rest args) + (declare (ignore class args)) + #'proxy-location) + +(defmethod writer-function ((class proxy-class) &rest args) + (declare (ignore args)) + #'(lambda (instance location &optional (offset 0)) + (assert (null-pointer-p (sap-ref-sap location offset))) + (setf + (sap-ref-sap location offset) + (reference-foreign class (proxy-location instance))))) -(defun ensure-proxy-instance (class location weak-ref &rest initargs) - (or - (find-cached-instance location) - (apply #'make-proxy-instance class location weak-ref initargs))) +(defmethod reader-function ((class proxy-class) &rest args) + (declare (ignore args)) + #'(lambda (location &optional (offset 0)) + (ensure-proxy-instance class (sap-ref-sap location offset)))) +(defmethod destroy-function ((class proxy-class) &rest args) + (declare (ignore args)) + #'(lambda (location &optional (offset 0)) + (unreference-foreign class (sap-ref-sap location offset)))) + + +(defgeneric ensure-proxy-instance (class location) + (:documentation "Returns a proxy object representing the foreign object at the give location.")) + +(defmethod ensure-proxy-instance :around (class location) + (unless (null-pointer-p location) + (or + (find-cached-instance location) + (call-next-method)))) + +(defmethod ensure-proxy-instance ((class symbol) location) + (ensure-proxy-instance (find-class class) location)) + +(defmethod ensure-proxy-instance ((class proxy-class) location) + (make-instance class :location location)) ;;;; Superclasses for wrapping of C structures -(eval-when (:compile-toplevel :load-toplevel :execute) - (defclass struct (proxy) - () - (:metaclass proxy-class) - (:copy %copy-struct) - (:free %free-struct))) +(defclass struct (proxy) + () + (:metaclass proxy-class)) -(defmethod initialize-instance ((structure struct) &rest initargs) +(defmethod initialize-instance ((struct struct) &rest initargs) (declare (ignore initargs)) (setf - (slot-value structure 'location) - (allocate-memory (proxy-class-size (class-of structure)))) + (slot-value struct 'location) + (allocate-memory (proxy-instance-size (class-of struct)))) (call-next-method)) -(defun %copy-struct (type location) - (copy-memory location (proxy-class-size (find-class type)))) +;;;; Metaclasses used for subclasses of struct + +(defclass struct-class (proxy-class) + ()) -(defun %free-struct (type location) - (declare (ignore type)) +(defmethod reference-foreign ((class struct-class) location) + (copy-memory location (proxy-instance-size class))) + +(defmethod unreference-foreign ((class struct-class) location) (deallocate-memory location)) +(defmethod reader-function ((class struct-class) &rest args) + (declare (ignore args)) + #'(lambda (location &optional (offset 0)) + (let ((instance (sap-ref-sap location offset))) + (unless (null-pointer-p instance) + (ensure-proxy-instance class (reference-foreign class instance)))))) + -;(eval-when (:compile-toplevel :load-toplevel :execute) - (defclass static (struct) - () - (:metaclass proxy-class) - (:copy %copy-static) - (:free %free-static));) +(defclass static-struct-class (struct-class) + ()) -(defun %copy-static (type location) - (declare (ignore type)) +(defmethod reference-foreign ((class static-struct-class) location) + (declare (ignore class)) location) -(defun %free-static (type location) - (declare (ignore type location)) +(defmethod unreference-foreign ((class static-struct-class) location) + (declare (ignore class location)) nil) diff --git a/gtk/gtk.lisp b/gtk/gtk.lisp index d71b327..845fdd8 100644 --- a/gtk/gtk.lisp +++ b/gtk/gtk.lisp @@ -15,7 +15,7 @@ ;; 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: gtk.lisp,v 1.14 2004-11-03 10:41:23 espen Exp $ +;; $Id: gtk.lisp,v 1.15 2004-11-06 21:39:58 espen Exp $ (in-package "GTK") @@ -42,6 +42,27 @@ (defun gtk-version () (defbinding get-default-language () string) +;;;; Initalization + +(defbinding (gtk-init "gtk_parse_args") () nil + "Initializes the library without opening the display." + (nil null) + (nil null)) + +(defun clg-init (&optional display) + "Initializes the system and starts the event handling" + (unless (gdk:display-get-default) + (gdk:gdk-init) + (gtk-init) + (prog1 + (gdk:display-open display) + (system:add-fd-handler + (gdk:display-connection-number) :input #'main-iterate-all) + (setq lisp::*periodic-polling-function* #'main-iterate-all) + (setq lisp::*max-event-to-sec* 0) + (setq lisp::*max-event-to-usec* 1000)))) + + ;;; Acccel group @@ -248,6 +269,7 @@ (defbinding (color-selection-is-adjusting-p (defmethod shared-initialize ((combo combo) names &rest initargs &key popdown-strings) + (declare (ignore initargs)) (call-next-method) (when popdown-strings (combo-set-popdown-strings combo popdown-strings))) @@ -264,6 +286,7 @@ (defbinding combo-disable-activate () nil ;;;; Dialog (defmethod shared-initialize ((dialog dialog) names &rest initargs &key button) + (declare (ignore button)) (call-next-method) (dolist (button-definition (get-all initargs :button)) (apply #'dialog-add-button dialog (mklist button-definition)))) @@ -677,14 +700,14 @@ (defbinding window-begin-resize-drag () nil (edge gdk:window-edge) (button int) (root-x int) (root-y int) - (timestamp (unsigned-int 32))) + (timestamp unsigned-int)) (defbinding window-begin-move-drag () nil (window window) (edge gdk:window-edge) (button int) (root-x int) (root-y int) - (timestamp (unsigned-int 32))) + (timestamp unsigned-int)) (defbinding window-set-frame-dimensions () nil (window window) diff --git a/gtk/gtkobject.lisp b/gtk/gtkobject.lisp index 0173ba6..3d1c67c 100644 --- a/gtk/gtkobject.lisp +++ b/gtk/gtkobject.lisp @@ -15,7 +15,7 @@ ;; 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: gtkobject.lisp,v 1.18 2004-11-03 16:54:24 espen Exp $ +;; $Id: gtkobject.lisp,v 1.19 2004-11-06 21:39:58 espen Exp $ (in-package "GTK") @@ -34,7 +34,9 @@ (in-package "GTK") ;;;; Superclass for the gtk class hierarchy (eval-when (:compile-toplevel :load-toplevel :execute) - (init-types-in-library "libgtk-x11-2.0.so" + (init-types-in-library + #.(concatenate 'string (pkg-config:pkg-variable "gtk+-2.0" "libdir") + "/libgtk-x11-2.0.so") :ignore ("gtk_window_get_type_hint")) (defclass %object (gobject) @@ -43,15 +45,14 @@ (defclass %object (gobject) (:alien-name "GtkObject"))) -(defmethod shared-initialize ((object %object) names &rest initargs &key signal) - (declare (ignore names signal)) +(defmethod initialize-instance ((object %object) &rest initargs &key signal) + (declare (ignore signal)) (call-next-method) - (object-ref object) ; inc ref count before sinking - (%object-sink object) + (reference-foreign (class-of object) (proxy-location object)) (dolist (signal-definition (get-all initargs :signal)) (apply #'signal-connect object signal-definition))) -(defmethod initialize-proxy ((object %object) &rest initargs) +(defmethod initialize-instance :around ((object %object) &rest initargs) (declare (ignore initargs)) (call-next-method) (%object-sink object)) @@ -85,34 +86,13 @@ (defun main-iterate-all (&rest args) (main-iteration-do nil) (main-iterate-all))) -;;;; Initalization - -(defbinding (gtk-init "gtk_parse_args") () nil - "Initializes the library without opening the display." - (nil null) - (nil null)) - -(defun clg-init (&optional display) - "Initializes the system and starts the event handling" - (unless (gdk:display-get-default) - (gdk:gdk-init) - (gtk-init) - (prog1 - (gdk:display-open display) - (system:add-fd-handler - (gdk:display-connection-number) :input #'main-iterate-all) - (setq lisp::*periodic-polling-function* #'main-iterate-all) - (setq lisp::*max-event-to-sec* 0) - (setq lisp::*max-event-to-usec* 1000)))) - - ;;;; Metaclass for child classes (defvar *container-to-child-class-mappings* (make-hash-table)) (eval-when (:compile-toplevel :load-toplevel :execute) - (defclass child-class (virtual-slot-class) + (defclass child-class (virtual-slots-class) ()) (defclass direct-child-slot-definition (direct-virtual-slot-definition) @@ -128,15 +108,6 @@ (defmethod shared-initialize ((class child-class) names &key container) (gethash (find-class (first container)) *container-to-child-class-mappings*) class)) -;; (defmethod initialize-instance ((slotd direct-child-slot-definition) -;; &rest initargs &key pname) -;; (declare (ignore initargs)) -;; (call-next-method) -;; (if pname -;; (setf (slot-value slotd 'pname) pname) -;; ; ??? -;; (error "Need pname for slot with allocation :property"))) - (defmethod direct-slot-definition-class ((class child-class) &rest initargs) (case (getf initargs :allocation) (:property (find-class 'direct-child-slot-definition)) @@ -169,31 +140,25 @@ (defmethod initialize-internal-slot-functions ((slotd effective-child-slot-defin (slot-value slotd 'reader-function) #'(lambda (object) (with-slots (parent child) object - (with-gc-disabled - (let ((gvalue (gvalue-new type-number))) - (%container-child-get-property parent child pname gvalue) - (unwind-protect - (funcall - (intern-reader-function type) - gvalue +gvalue-value-offset+) - (gvalue-free gvalue t)))))))) + (let ((gvalue (gvalue-new type-number))) + (%container-child-get-property parent child pname gvalue) + (unwind-protect + (funcall (reader-function type) gvalue +gvalue-value-offset+) + (gvalue-free gvalue t))))))) (unless (slot-boundp slotd 'writer-function) (setf (slot-value slotd 'writer-function) #'(lambda (value object) (with-slots (parent child) object - (with-gc-disabled - (let ((gvalue (gvalue-new type-number))) - (funcall - (intern-writer-function type) - value gvalue +gvalue-value-offset+) - (%container-child-set-property parent child pname gvalue) - (funcall - (intern-destroy-function type) - gvalue +gvalue-value-offset+) - (gvalue-free gvalue nil) - value)))))) + (let ((gvalue (gvalue-new type-number))) + (funcall (writer-function type) value gvalue +gvalue-value-offset+) + (%container-child-set-property parent child pname gvalue) +;; (funcall +;; (destroy-function type) +;; gvalue +gvalue-value-offset+) + (gvalue-free gvalue t) + value))))) (unless (slot-boundp slotd 'boundp-function) (setf @@ -250,7 +215,7 @@ (defun query-container-class-child-properties (type-number) (multiple-value-bind (array length) (%container-class-list-child-properties class) (unwind-protect - (map-c-array 'list #'identity array 'param length) + (map-c-vector 'list #'identity array 'param length) (deallocate-memory array))))) (defun default-container-child-name (container-class) diff --git a/gtk/gtktypes.lisp b/gtk/gtktypes.lisp index 4b09c9a..00dd6f7 100644 --- a/gtk/gtktypes.lisp +++ b/gtk/gtktypes.lisp @@ -15,7 +15,7 @@ ;; 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: gtktypes.lisp,v 1.16 2004-10-31 12:05:52 espen Exp $ +;; $Id: gtktypes.lisp,v 1.17 2004-11-06 21:39:58 espen Exp $ (in-package "GTK") @@ -55,7 +55,7 @@ (defclass allocation (struct) :accessor allocation-height :initarg :height :type int)) - (:metaclass proxy-class)) + (:metaclass struct-class)) (defclass border (boxed) ((left @@ -106,7 +106,7 @@ (defclass stock-item (struct) :accessor stock-item-translation-domain :initarg :translation-domain :type string)) - (:metaclass proxy-class)) + (:metaclass static-struct-class)) (define-types-by-introspection "Gtk" diff --git a/gtk/gtkwidget.lisp b/gtk/gtkwidget.lisp index e04d7f7..bd62906 100644 --- a/gtk/gtkwidget.lisp +++ b/gtk/gtkwidget.lisp @@ -15,7 +15,7 @@ ;; 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: gtkwidget.lisp,v 1.9 2004-10-31 12:05:52 espen Exp $ +;; $Id: gtkwidget.lisp,v 1.10 2004-11-06 21:39:58 espen Exp $ (in-package "GTK") @@ -361,7 +361,7 @@ (defbinding %widget-get-size-request () nil (defun widget-get-size-request (widget) (multiple-value-bind (width height) (%widget-get-size-request widget) - (values (unless (= width -1) width) (unless (= height -1) height)))) + (values (unless (= width -1) width) (unless (= height -1) height)))) (defbinding widget-set-size-request (widget width height) nil (widget widget) diff --git a/pango/pango.lisp b/pango/pango.lisp index 09a2265..32db14d 100644 --- a/pango/pango.lisp +++ b/pango/pango.lisp @@ -15,11 +15,14 @@ ;; 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: pango.lisp,v 1.5 2004-10-31 11:45:39 espen Exp $ +;; $Id: pango.lisp,v 1.6 2004-11-06 21:39:58 espen Exp $ (in-package "PANGO") (eval-when (:compile-toplevel :load-toplevel :execute) - (init-types-in-library "libpango-1.0.so" :ignore ("_pango_fribidi_get_type"))) + (init-types-in-library + #.(concatenate 'string (pkg-config:pkg-variable "atk" "libdir") + "/libpango-1.0.so") + :prefix "pango_" :ignore ("_pango_fribidi_get_type"))) (define-types-by-introspection "Pango") -- [mdw]