[lgtk-cvs] CVS update: lgtk/src/gtknexus.lisp lgtk/src/gtkpackage.lisp lgtk/src/port.lisp

[Mario Mommer]

Update of /project/lgtk/cvsroot/lgtk/src
In directory common-lisp.net:/tmp/cvs-serv2899

Modified Files:
      Tag: sbcl-port
	gtknexus.lisp gtkpackage.lisp port.lisp 
Log Message:
Applied a patch by Damien Diederen. #+... magic reduced / moved mostly to 
port.lisp.


Date: Wed Dec 10 12:10:21 2003
Author: mmommer

Index: lgtk/src/gtknexus.lisp
diff -u lgtk/src/gtknexus.lisp:1.4.4.1 lgtk/src/gtknexus.lisp:1.4.4.2
--- lgtk/src/gtknexus.lisp:1.4.4.1	Fri Dec  5 11:55:08 2003
+++ lgtk/src/gtknexus.lisp	Wed Dec 10 12:10:21 2003
@@ -197,22 +197,26 @@
 	r))))
 
 ;; Trampolines
-(defcallback gtk-standard-decoy
-    #+cmu (c-call:void (w (* t)) (cookie c-call:int))
-    #+sbcl (sb-alien:void (w (* t)) (cookie sb-alien:int))
+(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))
   (%standard-handler w cookie))
 
-(defcallback gtk-destroy-decoy 
-    #+cmu (c-call:void (w (* t)) (cookie c-call:int))
-    #+sbcl (sb-alien:void (w (* t)) (cookie sb-alien:int))
+(%defcallback gtk-destroy-decoy (:void (w (* t)) (cookie :int))
   (%destroy-handler w cookie))
 
-(defcallback gtk-evhandling-decoy 
-    #+cmu (c-call:int (w (* t)) (ev (* t)) (cookie c-call:int))
-    #+sbcl (sb-alien:int (w (* t)) (ev (* t)) (cookie sb-alien:int))
+(%defcallback gtk-evhandling-decoy (:int (w (* t)) (ev (* t)) (cookie :int))
   (%event-handler w ev cookie))
 
-(defcallback %gtk-itc-handler 
-    #+cmu (c-call:int (id c-call:int))
-    #+sbcl (sb-alien:int (id sb-alien:int))
+(%defcallback %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.2.4.1
--- lgtk/src/gtkpackage.lisp:1.2	Wed Nov  5 16:20:41 2003
+++ lgtk/src/gtkpackage.lisp	Wed Dec 10 12:10:21 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.4.1 lgtk/src/port.lisp:1.3.4.2
--- lgtk/src/port.lisp:1.3.4.1	Fri Dec  5 11:55:08 2003
+++ lgtk/src/port.lisp	Wed Dec 10 12:10:21 2003
@@ -7,11 +7,12 @@
 
 ;; 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 #:defcallback #:callback)
+  #+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,43 +26,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)))
-
-#+sbcl
-(defparameter *c-types*
-  '((:char sb-alien:char)
-    (:short sb-alien:short)
-    (:ushort sb-alien:unsigned-short)
-    (:int sb-alien:int)
-    (:uint sb-alien:unsigned-int)
-    (:long sb-alien:long)
-    (:ulong sb-alien:unsigned-long)
-    (:double sb-alien:double)
-    (:float sb-alien:float)
-
-    (:c-string sb-alien:c-string)
-
-    (:void sb-alien: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*)))
@@ -71,17 +54,15 @@
 
 ;; Get the actual pointer number
 (defun alien-address (it)
-  #+cmu (system:sap-int (alien:alien-sap it))
-  #+sbcl (sb-sys:sap-int (sb-alien:alien-sap it)))
+  (sap-int (alien-sap it)))
 
 (defmacro def-alien-routine (&rest stuff)
   #+cmu `(alien:def-alien-routine , at stuff)
-  #+sbcl `(sb-alien:def-alien-routine , at stuff))
+  #+sbcl `(define-alien-routine , at stuff))
 
 ;;; GC magic
 
-#+cmu (defvar *weak-pointer-type* 'ext:weak-pointer)
-#+sbcl (defvar *weak-pointer-type* 'sb-ext:weak-pointer)
+(defvar *weak-pointer-type* 'weak-pointer)
 
 (defun finalize (fun obj)
   #+cmu (ext:finalize fun obj)
@@ -96,5 +77,4 @@
   #+sbcl (sb-ext:weak-pointer-value obj))
 
 (defun run-after-gc (fun)
-  #+cmu (pushnew fun ext:*after-gc-hooks*)
-  #+sbcl (pushnew fun sb-ext:*after-gc-hooks*))
+  (pushnew fun *after-gc-hooks*))