Update of /project/lgtk/cvsroot/lgtk/src In directory common-lisp.net:/tmp/cvs-serv18598/src Modified Files: Tag: sbcl-port dynaslot.lisp gtklisp.lisp gtknexus.lisp port.lisp Log Message: Further cleanup. Date: Thu Dec 11 03:47:21 2003 Author: mmommer Index: lgtk/src/dynaslot.lisp diff -u lgtk/src/dynaslot.lisp:1.3.4.1 lgtk/src/dynaslot.lisp:1.3.4.2 --- lgtk/src/dynaslot.lisp:1.3.4.1 Fri Dec 5 11:55:08 2003 +++ lgtk/src/dynaslot.lisp Thu Dec 11 03:47:21 2003 @@ -8,7 +8,7 @@ (defpackage #:dynaslot (:export #:begin-slot-declarations #:generate-alien-accessors #:add-alien-slots #:peek #:poke) - (:use :defbinding :nexus :common-lisp)) + (:use :defbinding :nexus :common-lisp :clnexus-port)) (in-package :dynaslot) @@ -116,42 +116,6 @@ (generate-them-accessors (car req) (caddr req) off)) offsl reqs)))))))) - -#+cmu -(defmacro peek (base off type) - `(alien:deref - (alien:sap-alien - (system:int-sap - (+ ,off - (system:sap-int (alien:alien-sap ,base)))) - (* ,type)))) - -#+sbcl -(defmacro peek (base off type) - `(sb-alien:deref - (sb-alien:sap-alien - (sb-sys:int-sap - (+ ,off - (sb-sys:sap-int (sb-alien:alien-sap ,base)))) - (* ,type)))) - -#+cmu -(defmacro poke (base off type value) - `(setf (alien:deref - (alien:sap-alien - (system:int-sap - (+ ,off - (system:sap-int (alien:alien-sap ,base)))) - (* ,type))) ,value)) - -#+sbcl -(defmacro poke (base off type value) - `(setf (sb-alien:deref - (sb-alien:sap-alien - (sb-sys:int-sap - (+ ,off - (sb-sys:sap-int (sb-alien:alien-sap ,base)))) - (* ,type))) ,value)) ;; This is how this should be used. #|| Index: lgtk/src/gtklisp.lisp diff -u lgtk/src/gtklisp.lisp:1.4.4.1 lgtk/src/gtklisp.lisp:1.4.4.2 --- lgtk/src/gtklisp.lisp:1.4.4.1 Fri Dec 5 11:55:08 2003 +++ lgtk/src/gtklisp.lisp Thu Dec 11 03:47:21 2003 @@ -141,8 +141,7 @@ (when (not *gtk-init*) (let ((i 0)) (gtk-aliens::|gtk_init| i - #+cmu (system:int-sap 0) - #+sbcl (sb-sys:int-sap 0))) + (voidptr 0))) (setf *gtk-init* t))) (gtk-init)) @@ -175,8 +174,7 @@ (funcall *sigint-handler* a b c))))) (setf *sigint-handler* - #+cmu (system:enable-interrupt unix:SIGINT #'my-handler) - #+sbcl (sb-sys:enable-interrupt sb-unix:SIGINT #'my-handler)) + (swap-unix-sigint-handler #'my-handler)) (let ((*in-main* t)) (gtk-aliens::|gtk_main|)) @@ -189,8 +187,7 @@ (throw 'common-lisp::top-level-catcher nil))) ;; When unwinding - #+cmu (system:enable-interrupt unix:SIGINT *sigint-handler*) - #+sbcl (sb-sys:enable-interrupt sb-unix:SIGINT *sigint-handler*) + (swap-unix-sigint-handler *sigint-handler*) (setf *sigint-handler* nil)))) ;; So far, so good. Index: lgtk/src/gtknexus.lisp diff -u lgtk/src/gtknexus.lisp:1.4.4.2 lgtk/src/gtknexus.lisp:1.4.4.3 --- lgtk/src/gtknexus.lisp:1.4.4.2 Wed Dec 10 12:10:21 2003 +++ lgtk/src/gtknexus.lisp Thu Dec 11 03:47:21 2003 @@ -72,7 +72,7 @@ (defmacro def-callback-type (name marker decoy) `(defresource ,name (callback-resource :marker ,marker - :trampoline (callback ,decoy)))) + :trampoline (c-fun-ptr ,decoy)))) (defun getanumber () (format t "Enter a number to be returned to the toolkit, e.g 42~%") @@ -197,26 +197,14 @@ r)))) ;; Trampolines -(defmacro %defcallback (name (return-type &rest arg-specs) &rest body) - "Defines a callback using the `port' C type specifiers. Uses -PORT-ALIEN-TYPE to convert the syntax to the implementation-dependant -alien type specifiers." - `(defcallback ,name - ,(list* (port-alien-type return-type) - (mapcar (lambda (arg-spec) - (destructuring-bind (name type) arg-spec - (list name (port-alien-type type)))) - arg-specs)) - ,@body)) - -(%defcallback gtk-standard-decoy (:void (w (* t)) (cookie :int)) +(def-c-callable gtk-standard-decoy (:void (w (* t)) (cookie :int)) (%standard-handler w cookie)) -(%defcallback gtk-destroy-decoy (:void (w (* t)) (cookie :int)) +(def-c-callable gtk-destroy-decoy (:void (w (* t)) (cookie :int)) (%destroy-handler w cookie)) -(%defcallback gtk-evhandling-decoy (:int (w (* t)) (ev (* t)) (cookie :int)) +(def-c-callable gtk-evhandling-decoy (:int (w (* t)) (ev (* t)) (cookie :int)) (%event-handler w ev cookie)) -(%defcallback %gtk-itc-handler (:int (id :int)) +(def-c-callable %gtk-itc-handler (:int (id :int)) (%itc-handler id)) Index: lgtk/src/port.lisp diff -u lgtk/src/port.lisp:1.3.4.2 lgtk/src/port.lisp:1.3.4.3 --- lgtk/src/port.lisp:1.3.4.2 Wed Dec 10 12:10:21 2003 +++ lgtk/src/port.lisp Thu Dec 11 03:47:21 2003 @@ -9,7 +9,8 @@ (defpackage #:clnexus-port (:export #:alien-address #:finalize #:make-weak-pointer #:weak-pointer-value #:*weak-pointer-type* #:run-after-gc - #:def-alien-routine #:port-alien-type #:defcallback #:callback) + #:def-alien-routine #:port-alien-type #:def-c-callable #:c-fun-ptr + #:swap-unix-sigint-handler #:voidptr #:peek #:poke) #+cmu (:use common-lisp ext system alien c-call callback) #+sbcl (:use common-lisp sb-ext sb-sys sb-alien callback) (:shadow def-alien-routine finalize make-weak-pointer weak-pointer-value)) @@ -78,3 +79,63 @@ (defun run-after-gc (fun) (pushnew fun *after-gc-hooks*)) + +(defun voidptr (int) + (int-sap int)) + +(defun swap-unix-sigint-handler (new-one) + #+cmu (system:enable-interrupt unix:SIGINT new-one) + #+sbcl (sb-sys:enable-interrupt sb-unix:SIGINT new-one)) + +;;; Aaaah BASIC! Those where the days..... +#+cmu +(defmacro peek (base off type) + `(alien:deref + (alien:sap-alien + (system:int-sap + (+ ,off + (system:sap-int (alien:alien-sap ,base)))) + (* ,type)))) + +#+sbcl +(defmacro peek (base off type) + `(sb-alien:deref + (sb-alien:sap-alien + (sb-sys:int-sap + (+ ,off + (sb-sys:sap-int (sb-alien:alien-sap ,base)))) + (* ,type)))) + +#+cmu +(defmacro poke (base off type value) + `(setf (alien:deref + (alien:sap-alien + (system:int-sap + (+ ,off + (system:sap-int (alien:alien-sap ,base)))) + (* ,type))) ,value)) + +#+sbcl +(defmacro poke (base off type value) + `(setf (sb-alien:deref + (sb-alien:sap-alien + (sb-sys:int-sap + (+ ,off + (sb-sys:sap-int (sb-alien:alien-sap ,base)))) + (* ,type))) ,value)) + +;; The callback interface will get non-portable among sbcl and cmucl. +(defmacro def-c-callable (name (return-type &rest arg-specs) &rest body) + "Defines a callback using the `port' C type specifiers. Uses +PORT-ALIEN-TYPE to convert the syntax to the implementation-dependant +alien type specifiers." + `(defcallback ,name + ,(list* (port-alien-type return-type) + (mapcar (lambda (arg-spec) + (destructuring-bind (name type) arg-spec + (list name (port-alien-type type)))) + arg-specs)) + ,@body)) + +(defmacro c-fun-ptr (it) + `(callback ,it))