[lgtk-cvs] CVS update: lgtk/src/dynaslot.lisp lgtk/src/gtklisp.lisp lgtk/src/gtknexus.lisp lgtk/src/gtkpackage.lisp lgtk/src/port.lisp
Mario Mommer
mmommer at common-lisp.net
Thu Dec 11 10:48:00 UTC 2003
Update of /project/lgtk/cvsroot/lgtk/src
In directory common-lisp.net:/tmp/cvs-serv31311/lgtk/src
Modified Files:
dynaslot.lisp gtklisp.lisp gtknexus.lisp gtkpackage.lisp
port.lisp
Log Message:
Merged back the sbcl-port branch
Date: Thu Dec 11 05:48:00 2003
Author: mmommer
Index: lgtk/src/dynaslot.lisp
diff -u lgtk/src/dynaslot.lisp:1.3 lgtk/src/dynaslot.lisp:1.4
--- lgtk/src/dynaslot.lisp:1.3 Mon Nov 10 16:44:07 2003
+++ lgtk/src/dynaslot.lisp Thu Dec 11 05:48:00 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,22 +116,6 @@
(generate-them-accessors
(car req) (caddr req) off))
offsl reqs))))))))
-
-(defmacro peek (base off type)
- `(alien:deref
- (alien:sap-alien
- (system:int-sap
- (+ ,off
- (system:sap-int (alien:alien-sap ,base))))
- (* ,type))))
-
-(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))
;; This is how this should be used.
#||
Index: lgtk/src/gtklisp.lisp
diff -u lgtk/src/gtklisp.lisp:1.4 lgtk/src/gtklisp.lisp:1.5
--- lgtk/src/gtklisp.lisp:1.4 Mon Nov 10 15:44:47 2003
+++ lgtk/src/gtklisp.lisp Thu Dec 11 05:48:00 2003
@@ -140,7 +140,8 @@
(defun gtk-init ()
(when (not *gtk-init*)
(let ((i 0))
- (gtk-aliens::|gtk_init| i (system:int-sap 0)))
+ (gtk-aliens::|gtk_init| i
+ (voidptr 0)))
(setf *gtk-init* t)))
(gtk-init))
@@ -173,8 +174,8 @@
(funcall *sigint-handler* a b c)))))
(setf *sigint-handler*
- (system:enable-interrupt unix:SIGINT #'my-handler))
-
+ (swap-unix-sigint-handler #'my-handler))
+
(let ((*in-main* t))
(gtk-aliens::|gtk_main|))
@@ -186,7 +187,7 @@
(throw 'common-lisp::top-level-catcher nil)))
;; When unwinding
- (system:enable-interrupt unix:SIGINT *sigint-handler*)
+ (swap-unix-sigint-handler *sigint-handler*)
(setf *sigint-handler* nil))))
;; So far, so good.
@@ -205,12 +206,16 @@
(defun schedule-visual-gc ()
(when (not (or *visual-gc-scheduled* *main-active*))
(setf *visual-gc-scheduled* t)
+ #+cmu
(mp:make-process
#'(lambda ()
(sleep 1)
(unless *main-active*
(live-for-1msec))
- (setf *visual-gc-scheduled* nil)))))
+ (setf *visual-gc-scheduled* nil)))
+ ;; Need to provide SBCL alternative here. -dd
+ #+sbcl
+ t))
(eval-when (:load-toplevel)
(run-after-gc #'schedule-visual-gc))
Index: lgtk/src/gtknexus.lisp
diff -u lgtk/src/gtknexus.lisp:1.4 lgtk/src/gtknexus.lisp:1.5
--- lgtk/src/gtknexus.lisp:1.4 Sun Nov 9 12:32:46 2003
+++ lgtk/src/gtknexus.lisp Thu Dec 11 05:48:00 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,15 +197,14 @@
r))))
;; Trampolines
-(defcallback gtk-standard-decoy (c-call:void (w (* t)) (cookie c-call:int))
+(def-c-callable gtk-standard-decoy (:void (w (* t)) (cookie :int))
(%standard-handler w cookie))
-(defcallback gtk-destroy-decoy (c-call:void (w (* t)) (cookie c-call:int))
+(def-c-callable gtk-destroy-decoy (:void (w (* t)) (cookie :int))
(%destroy-handler w cookie))
-(defcallback gtk-evhandling-decoy (c-call:int
- (w (* t)) (ev (* t)) (cookie c-call:int))
+(def-c-callable gtk-evhandling-decoy (:int (w (* t)) (ev (* t)) (cookie :int))
(%event-handler w ev cookie))
-(defcallback %gtk-itc-handler (c-call:int (id c-call:int))
+(def-c-callable %gtk-itc-handler (:int (id :int))
(%itc-handler id))
Index: lgtk/src/gtkpackage.lisp
diff -u lgtk/src/gtkpackage.lisp:1.2 lgtk/src/gtkpackage.lisp:1.3
--- lgtk/src/gtkpackage.lisp:1.2 Wed Nov 5 16:20:41 2003
+++ lgtk/src/gtkpackage.lisp Thu Dec 11 05:48:00 2003
@@ -49,5 +49,5 @@
;; enums. Only export those which can be combined via | in
;; C. See file enums.lisp for details.
:gtkattachoptions)
- (:use common-lisp nexus widget-nexus callback enums defbinding clnexus-port
+ (:use common-lisp nexus widget-nexus enums defbinding clnexus-port
dynaslot))
Index: lgtk/src/port.lisp
diff -u lgtk/src/port.lisp:1.3 lgtk/src/port.lisp:1.4
--- lgtk/src/port.lisp:1.3 Wed Oct 29 12:20:45 2003
+++ lgtk/src/port.lisp Thu Dec 11 05:48:00 2003
@@ -7,11 +7,13 @@
;; Portablility package.
(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)
- (:use common-lisp))
+ (:export #:alien-address #:finalize #:make-weak-pointer
+ #:weak-pointer-value #:*weak-pointer-type* #:run-after-gc
+ #: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))
(in-package #:clnexus-port)
@@ -25,24 +27,25 @@
;;; Alien magic
;; basic C types
-#+cmu
(defparameter *c-types*
- '((:char c-call:char)
- (:short c-call:short)
- (:ushort c-call:unsigned-short)
- (:int c-call:int)
- (:uint c-call:unsigned-int)
- (:long c-call:long)
- (:ulong c-call:unsigned-long)
- (:double c-call:double)
- (:float c-call:float)
+ '((:char char)
+ (:short short)
+ (:ushort unsigned-short)
+ (:int int)
+ (:uint unsigned-int)
+ (:long long)
+ (:ulong unsigned-long)
+ (:double double)
+ (:float float)
- (:c-string c-call:c-string)
+ (:c-string c-string)
- (:void c-call:void)
+ (:void void)
(:voidptr (* t))
(* *)
- (t t)))
+ (t t))
+ "Maps `port' C type specifiers from the :KEYWORDS package to symbols
+from the the C-CALL (CMUCL) or SB-ALIEN (SBCL) packages.")
(defun port-alien-type (key)
(let ((it (cond ((atom key) (cadr (assoc key *c-types*)))
@@ -52,23 +55,87 @@
;; Get the actual pointer number
(defun alien-address (it)
- #+cmu (system:sap-int (alien:alien-sap it)))
+ (sap-int (alien-sap it)))
(defmacro def-alien-routine (&rest stuff)
- #+cmu `(alien:def-alien-routine , at stuff))
+ #+cmu `(alien:def-alien-routine , at stuff)
+ #+sbcl `(define-alien-routine , at stuff))
;;; GC magic
-#+cmu (defvar *weak-pointer-type* 'ext:weak-pointer)
+(defvar *weak-pointer-type* 'weak-pointer)
(defun finalize (fun obj)
- #+cmu (ext:finalize fun obj))
+ #+cmu (ext:finalize fun obj)
+ #+sbcl (sb-ext:finalize fun obj))
(defun make-weak-pointer (obj)
- #+cmu (ext:make-weak-pointer obj))
+ #+cmu (ext:make-weak-pointer obj)
+ #+sbcl (sb-ext:make-weak-pointer obj))
(defun weak-pointer-value (obj)
- #+cmu (ext:weak-pointer-value obj))
+ #+cmu (ext:weak-pointer-value obj)
+ #+sbcl (sb-ext:weak-pointer-value obj))
(defun run-after-gc (fun)
- (pushnew fun ext:*after-gc-hooks*))
\ No newline at end of file
+ (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