[lgtk-cvs] CVS update: lgtk/src/dynaslot.lisp lgtk/src/gtklisp.lisp lgtk/src/gtknexus.lisp lgtk/src/port.lisp
Mario Mommer
mmommer at common-lisp.net
Thu Dec 11 08:47:21 UTC 2003
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))
- , at 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))
+ , at body))
+
+(defmacro c-fun-ptr (it)
+ `(callback ,it))
More information about the Lgtk-cvs
mailing list