From mmommer at common-lisp.net  Fri Dec  5 16:55:08 2003
From: mmommer at common-lisp.net (Mario Mommer)
Date: Fri, 05 Dec 2003 11:55:08 -0500
Subject: [lgtk-cvs] CVS update: lgtk/lgtk.asd 
Message-ID: <E1ASJES-0004ji-00@common-lisp.net>

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

Modified Files:
      Tag: sbcl-port
	lgtk.asd 
Log Message:
Applied patch by  Damien Diederen <diederen (at) swing (dot) be>.
It should run on sbcl.

Date: Fri Dec  5 11:55:07 2003
Author: mmommer

Index: lgtk/lgtk.asd
diff -u lgtk/lgtk.asd:1.7 lgtk/lgtk.asd:1.7.4.1
--- lgtk/lgtk.asd:1.7	Sun Nov  9 12:32:45 2003
+++ lgtk/lgtk.asd	Fri Dec  5 11:55:07 2003
@@ -6,7 +6,7 @@
 ;; advertising clause"). See the file COPYING for details.
 
 (defpackage #:lgtk-asd
-  (:use :cl :asdf))
+  (:use :cl :asdf #+cmu :ext #+sbcl :sb-ext #+sbcl :sb-alien))
 
 (in-package :lgtk-asd)
 
@@ -33,12 +33,13 @@
 
 ;; Get the list of libraries.
 (defun get-gtk-libs-list ()
-  (let ((prc (ext:run-program "pkg-config" '("--libs" "gtk+-2.0")
+  (let ((prc (run-program "pkg-config" '("--libs" "gtk+-2.0")
+			  :search t
 			  :output :stream)))
     (if (not prc)
 	(error "Could not run #\"pckg-config!")
-      (let ((str (ext:process-output prc))
-	    (ecode (ext:process-exit-code prc)))
+      (let ((str (process-output prc))
+	    (ecode (process-exit-code prc)))
 	(if (not (eql ecode 0))
 	    (error "Could not find gtk+-2.0")
 	  (remove-if ;; Remove options which do not specify a lib
@@ -48,12 +49,13 @@
 	   (splitatspc (read-line str))))))))
 
 (defun get-gtk-cflags-list ()
-  (let ((prc (ext:run-program "pkg-config" '("--cflags" "gtk+-2.0")
+  (let ((prc (run-program "pkg-config" '("--cflags" "gtk+-2.0")
+			  :search t
 			  :output :stream)))
     (if (not prc)
 	(error "Could not run #\"pckg-config!")
-      (let ((str (ext:process-output prc))
-	    (ecode (ext:process-exit-code prc)))
+      (let ((str (process-output prc))
+	    (ecode (process-exit-code prc)))
 	(if (not (eql ecode 0))
 	    (error "Could not find gtk+-2.0")
 	  (read-line str))))))
@@ -78,8 +80,8 @@
 
 (defmethod perform ((o load-op) (c gtk-libs-handle))
   (setf *source-dir* (pathname-directory (component-pathname c)))
-  (ext:load-foreign (namestring (car (output-files o c)))
-		    :libraries *gtklibs*))
+  (load-foreign (namestring (car (output-files o c)))
+		:libraries *gtklibs*))
 
 (defsystem lgtk
   :name "lgtk"




From mmommer at common-lisp.net  Fri Dec  5 16:55:09 2003
From: mmommer at common-lisp.net (Mario Mommer)
Date: Fri, 05 Dec 2003 11:55:09 -0500
Subject: [lgtk-cvs] CVS update: lgtk/src/dynaslot.lisp lgtk/src/gtklisp.lisp
	lgtk/src/gtknexus.lisp lgtk/src/port.lisp 
Message-ID: <E1ASJET-0004mg-00@common-lisp.net>

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

Modified Files:
      Tag: sbcl-port
	dynaslot.lisp gtklisp.lisp gtknexus.lisp port.lisp 
Log Message:
Applied patch by  Damien Diederen <diederen (at) swing (dot) be>.
It should run on sbcl.

Date: Fri Dec  5 11:55:08 2003
Author: mmommer

Index: lgtk/src/dynaslot.lisp
diff -u lgtk/src/dynaslot.lisp:1.3 lgtk/src/dynaslot.lisp:1.3.4.1
--- lgtk/src/dynaslot.lisp:1.3	Mon Nov 10 16:44:07 2003
+++ lgtk/src/dynaslot.lisp	Fri Dec  5 11:55:08 2003
@@ -117,6 +117,7 @@
 				    (car req) (caddr req) off))
 			       offsl reqs))))))))
 
+#+cmu
 (defmacro peek (base off type)
   `(alien:deref
      (alien:sap-alien
@@ -125,12 +126,31 @@
 	  (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 lgtk/src/gtklisp.lisp:1.4.4.1
--- lgtk/src/gtklisp.lisp:1.4	Mon Nov 10 15:44:47 2003
+++ lgtk/src/gtklisp.lisp	Fri Dec  5 11:55:08 2003
@@ -140,7 +140,9 @@
   (defun gtk-init ()
     (when (not *gtk-init*)
       (let ((i 0))
-	(gtk-aliens::|gtk_init| i (system:int-sap 0)))
+	(gtk-aliens::|gtk_init| i 
+		     #+cmu (system:int-sap 0)
+		     #+sbcl (sb-sys:int-sap 0)))
       (setf *gtk-init* t)))
 
   (gtk-init))
@@ -173,8 +175,9 @@
 			 (funcall *sigint-handler* a b c)))))
 
 	  (setf *sigint-handler*
-		(system:enable-interrupt unix:SIGINT #'my-handler))
-
+		#+cmu (system:enable-interrupt unix:SIGINT #'my-handler)
+		#+sbcl (sb-sys:enable-interrupt sb-unix:SIGINT #'my-handler))
+	  
 	  (let ((*in-main* t))
 	    (gtk-aliens::|gtk_main|))
 
@@ -186,7 +189,8 @@
 	    (throw 'common-lisp::top-level-catcher nil)))
 
       ;; When unwinding
-      (system:enable-interrupt unix:SIGINT *sigint-handler*)
+      #+cmu (system:enable-interrupt unix:SIGINT *sigint-handler*)
+      #+sbcl (sb-sys:enable-interrupt sb-unix:SIGINT *sigint-handler*)
       (setf *sigint-handler* nil))))
 
 ;; So far, so good.
@@ -205,12 +209,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.4.4.1
--- lgtk/src/gtknexus.lisp:1.4	Sun Nov  9 12:32:46 2003
+++ lgtk/src/gtknexus.lisp	Fri Dec  5 11:55:08 2003
@@ -197,15 +197,22 @@
 	r))))
 
 ;; Trampolines
-(defcallback gtk-standard-decoy (c-call:void (w (* t)) (cookie c-call:int))
+(defcallback gtk-standard-decoy
+    #+cmu (c-call:void (w (* t)) (cookie c-call:int))
+    #+sbcl (sb-alien:void (w (* t)) (cookie sb-alien:int))
   (%standard-handler w cookie))
 
-(defcallback gtk-destroy-decoy (c-call:void (w (* t)) (cookie c-call:int))
+(defcallback gtk-destroy-decoy 
+    #+cmu (c-call:void (w (* t)) (cookie c-call:int))
+    #+sbcl (sb-alien:void (w (* t)) (cookie sb-alien:int))
   (%destroy-handler w cookie))
 
-(defcallback gtk-evhandling-decoy (c-call:int
-				   (w (* t)) (ev (* t)) (cookie c-call:int))
+(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))
   (%event-handler w ev cookie))
 
-(defcallback %gtk-itc-handler (c-call:int (id c-call:int))
+(defcallback %gtk-itc-handler 
+    #+cmu (c-call:int (id c-call:int))
+    #+sbcl (sb-alien:int (id sb-alien:int))
   (%itc-handler id))


Index: lgtk/src/port.lisp
diff -u lgtk/src/port.lisp:1.3 lgtk/src/port.lisp:1.3.4.1
--- lgtk/src/port.lisp:1.3	Wed Oct 29 12:20:45 2003
+++ lgtk/src/port.lisp	Fri Dec  5 11:55:08 2003
@@ -44,6 +44,25 @@
     (* *)
     (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)))
+
 (defun port-alien-type (key)
   (let ((it (cond ((atom key) (cadr (assoc key *c-types*)))
 		  (t (mapcar #'port-alien-type key)))))
@@ -52,23 +71,30 @@
 
 ;; Get the actual pointer number
 (defun alien-address (it)
-  #+cmu (system:sap-int (alien:alien-sap it)))
+  #+cmu (system:sap-int (alien:alien-sap it))
+  #+sbcl (sb-sys:sap-int (sb-alien:alien-sap it)))
 
 (defmacro def-alien-routine (&rest stuff)
-  #+cmu `(alien:def-alien-routine , at stuff))
+  #+cmu `(alien:def-alien-routine , at stuff)
+  #+sbcl `(sb-alien:def-alien-routine , at stuff))
 
 ;;; GC magic
 
 #+cmu (defvar *weak-pointer-type* 'ext:weak-pointer)
+#+sbcl (defvar *weak-pointer-type* 'sb-ext: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
+  #+cmu (pushnew fun ext:*after-gc-hooks*)
+  #+sbcl (pushnew fun sb-ext:*after-gc-hooks*))




From mmommer at common-lisp.net  Fri Dec  5 17:23:26 2003
From: mmommer at common-lisp.net (Mario Mommer)
Date: Fri, 05 Dec 2003 12:23:26 -0500
Subject: [lgtk-cvs] CVS update: lgtk/INSTALL.txt 
Message-ID: <E1ASJfq-000841-00@common-lisp.net>

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

Modified Files:
      Tag: sbcl-port
	INSTALL.txt 
Log Message:
Added instructions for installing under SBCL.

Date: Fri Dec  5 12:23:26 2003
Author: mmommer

Index: lgtk/INSTALL.txt
diff -u lgtk/INSTALL.txt:1.2 lgtk/INSTALL.txt:1.2.4.1
--- lgtk/INSTALL.txt:1.2	Wed Oct 29 12:20:44 2003
+++ lgtk/INSTALL.txt	Fri Dec  5 12:23:26 2003
@@ -1,11 +1,17 @@
 	How to install lgtk, a gtk+ interface for Common Lisp
       ---------------------------------------------------------
 
-You need the following things:
+If you want to use lgtk with SBCL, read
+
+     http://www.caddr.com/macho/archives/clump/2003-12/360.html
+
+for instructons.
+
+Otherwise, you will need the following things:
 
     * The source code.
 
-    * Preferably, CMUCL 19a.
+    * Preferably, CMUCL 19a, or an SBCL with callback support.
 
       Alternatively, you need a CMUCL 18e core with callback
       support. You should grab a copy of Helmut Eller's callback.lisp




From mmommer at common-lisp.net  Fri Dec  5 17:24:58 2003
From: mmommer at common-lisp.net (Mario Mommer)
Date: Fri, 05 Dec 2003 12:24:58 -0500
Subject: [lgtk-cvs] CVS update: lgtk/README.txt 
Message-ID: <E1ASJhK-0008Mp-00@common-lisp.net>

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

Modified Files:
      Tag: sbcl-port
	README.txt 
Log Message:
Added a note on SBCL

Date: Fri Dec  5 12:24:58 2003
Author: mmommer

Index: lgtk/README.txt
diff -u lgtk/README.txt:1.1.1.1 lgtk/README.txt:1.1.1.1.4.1
--- lgtk/README.txt:1.1.1.1	Mon Oct 27 14:14:40 2003
+++ lgtk/README.txt	Fri Dec  5 12:24:58 2003
@@ -33,8 +33,8 @@
 
     * Multithreading support.
 
-    * Portablilty. For now it only runs on CMUCL. It should not be too
-      difficult to port to other implementations, though.
+    * Portablilty. For now it only runs on CMUCL and SBCL. It should
+      not be too difficult to port to other implementations, though.
 
     * Add missing functionality. That is quite a bit at the moment.
 




From mmommer at common-lisp.net  Fri Dec  5 17:55:51 2003
From: mmommer at common-lisp.net (Mario Mommer)
Date: Fri, 05 Dec 2003 12:55:51 -0500
Subject: [lgtk-cvs] CVS update: lgtk/lgtk.asd 
Message-ID: <E1ASKBD-0003Dw-00@common-lisp.net>

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

Modified Files:
      Tag: sbcl-port
	lgtk.asd 
Log Message:
Fixed a bug which prevented it from loading in cmucl.

Date: Fri Dec  5 12:55:51 2003
Author: mmommer

Index: lgtk/lgtk.asd
diff -u lgtk/lgtk.asd:1.7.4.1 lgtk/lgtk.asd:1.7.4.2
--- lgtk/lgtk.asd:1.7.4.1	Fri Dec  5 11:55:07 2003
+++ lgtk/lgtk.asd	Fri Dec  5 12:55:51 2003
@@ -31,13 +31,18 @@
 
       (cdr buf))))
 
+(defun pkg-config-lib-string ()
+  #+sbcl (run-program "pkg-config" '("--libs" "gtk+-2.0")
+		      :search t
+		      :output :stream)
+  #+cmu (ext:run-program "pkg-config" '("--libs" "gtk+-2.0")
+			  :output :stream))
+
 ;; Get the list of libraries.
 (defun get-gtk-libs-list ()
-  (let ((prc (run-program "pkg-config" '("--libs" "gtk+-2.0")
-			  :search t
-			  :output :stream)))
+  (let ((prc (pkg-config-lib-string)))
     (if (not prc)
-	(error "Could not run #\"pckg-config!")
+	(error "Could not run #\"pkg-config!")
       (let ((str (process-output prc))
 	    (ecode (process-exit-code prc)))
 	(if (not (eql ecode 0))
@@ -48,10 +53,16 @@
 						   ;; insenitive.
 	   (splitatspc (read-line str))))))))
 
+
+(defun pkg-config-cflags-string ()
+  #+sbcl (run-program "pkg-config" '("--cflags" "gtk+-2.0")
+		      :search t
+		      :output :stream)
+  #+cmu (ext:run-program "pkg-config" '("--cflags" "gtk+-2.0")
+			  :output :stream))
+
 (defun get-gtk-cflags-list ()
-  (let ((prc (run-program "pkg-config" '("--cflags" "gtk+-2.0")
-			  :search t
-			  :output :stream)))
+  (let ((prc (pkg-config-cflags-string)))
     (if (not prc)
 	(error "Could not run #\"pckg-config!")
       (let ((str (process-output prc))




From mmommer at common-lisp.net  Wed Dec 10 17:10:22 2003
From: mmommer at common-lisp.net (Mario Mommer)
Date: Wed, 10 Dec 2003 12:10:22 -0500
Subject: [lgtk-cvs] CVS update: lgtk/src/gtknexus.lisp
	lgtk/src/gtkpackage.lisp lgtk/src/port.lisp 
Message-ID: <E1AU7qw-0001Bz-00@common-lisp.net>

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*))




From mmommer at common-lisp.net  Thu Dec 11 08:47:21 2003
From: mmommer at common-lisp.net (Mario Mommer)
Date: Thu, 11 Dec 2003 03:47:21 -0500
Subject: [lgtk-cvs] CVS update: lgtk/src/dynaslot.lisp lgtk/src/gtklisp.lisp
	lgtk/src/gtknexus.lisp lgtk/src/port.lisp 
Message-ID: <E1AUMTh-0004sy-00@common-lisp.net>

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))




From mmommer at common-lisp.net  Thu Dec 11 08:47:21 2003
From: mmommer at common-lisp.net (Mario Mommer)
Date: Thu, 11 Dec 2003 03:47:21 -0500
Subject: [lgtk-cvs] CVS update: lgtk/lgtk.asd 
Message-ID: <E1AUMTh-0004sj-00@common-lisp.net>

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

Modified Files:
      Tag: sbcl-port
	lgtk.asd 
Log Message:
Further cleanup.

Date: Thu Dec 11 03:47:21 2003
Author: mmommer

Index: lgtk/lgtk.asd
diff -u lgtk/lgtk.asd:1.7.4.2 lgtk/lgtk.asd:1.7.4.3
--- lgtk/lgtk.asd:1.7.4.2	Fri Dec  5 12:55:51 2003
+++ lgtk/lgtk.asd	Thu Dec 11 03:47:20 2003
@@ -108,7 +108,7 @@
 	    ((:file "port")
 	     (:file "nexus" :depends-on ("port"))
 	     (:file "widgets" :depends-on ("nexus"))
-	     (:file "dynaslot" :depends-on ("bindings" "nexus"))
+	     (:file "dynaslot" :depends-on ("bindings" "nexus" "port"))
 	     (:file "enums" :depends-on ("bindings"))
 	     (:file "bindings" :depends-on ("port"))
 
@@ -127,3 +127,9 @@
 					       "libhandle"))
 	     (:file "gtknexus" :depends-on ("gtkbindings"))
 	     (:file "gtklisp" :depends-on ("gtknexus"))))))
+
+;; On 2003.12.10, load-foreign was put in deathrow by the sbcl
+;; developers. The following comment was made by Krystof_ and is
+;; probably going to help minimize the impact: "cmucl's load-foreign
+;; on linux runs ld -G -o /tmp/RANDOM --whole-archive file1.a file2.o
+;; file3.so --no-whole-archive -lfoo -lbar"




From mmommer at common-lisp.net  Thu Dec 11 10:48:00 2003
From: mmommer at common-lisp.net (Mario Mommer)
Date: Thu, 11 Dec 2003 05:48:00 -0500
Subject: [lgtk-cvs] CVS update: lgtk/INSTALL.txt lgtk/README.txt
	lgtk/lgtk.asd 
Message-ID: <E1AUOMS-0008A3-00@common-lisp.net>

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

Modified Files:
	INSTALL.txt README.txt lgtk.asd 
Log Message:
Merged back the sbcl-port branch

Date: Thu Dec 11 05:48:00 2003
Author: mmommer

Index: lgtk/INSTALL.txt
diff -u lgtk/INSTALL.txt:1.2 lgtk/INSTALL.txt:1.3
--- lgtk/INSTALL.txt:1.2	Wed Oct 29 12:20:44 2003
+++ lgtk/INSTALL.txt	Thu Dec 11 05:47:59 2003
@@ -1,11 +1,17 @@
 	How to install lgtk, a gtk+ interface for Common Lisp
       ---------------------------------------------------------
 
-You need the following things:
+If you want to use lgtk with SBCL, read
+
+     http://www.caddr.com/macho/archives/clump/2003-12/360.html
+
+for instructons.
+
+Otherwise, you will need the following things:
 
     * The source code.
 
-    * Preferably, CMUCL 19a.
+    * Preferably, CMUCL 19a, or an SBCL with callback support.
 
       Alternatively, you need a CMUCL 18e core with callback
       support. You should grab a copy of Helmut Eller's callback.lisp


Index: lgtk/README.txt
diff -u lgtk/README.txt:1.1.1.1 lgtk/README.txt:1.2
--- lgtk/README.txt:1.1.1.1	Mon Oct 27 14:14:40 2003
+++ lgtk/README.txt	Thu Dec 11 05:47:59 2003
@@ -33,8 +33,8 @@
 
     * Multithreading support.
 
-    * Portablilty. For now it only runs on CMUCL. It should not be too
-      difficult to port to other implementations, though.
+    * Portablilty. For now it only runs on CMUCL and SBCL. It should
+      not be too difficult to port to other implementations, though.
 
     * Add missing functionality. That is quite a bit at the moment.
 


Index: lgtk/lgtk.asd
diff -u lgtk/lgtk.asd:1.7 lgtk/lgtk.asd:1.8
--- lgtk/lgtk.asd:1.7	Sun Nov  9 12:32:45 2003
+++ lgtk/lgtk.asd	Thu Dec 11 05:47:59 2003
@@ -6,7 +6,7 @@
 ;; advertising clause"). See the file COPYING for details.
 
 (defpackage #:lgtk-asd
-  (:use :cl :asdf))
+  (:use :cl :asdf #+cmu :ext #+sbcl :sb-ext #+sbcl :sb-alien))
 
 (in-package :lgtk-asd)
 
@@ -31,14 +31,20 @@
 
       (cdr buf))))
 
+(defun pkg-config-lib-string ()
+  #+sbcl (run-program "pkg-config" '("--libs" "gtk+-2.0")
+		      :search t
+		      :output :stream)
+  #+cmu (ext:run-program "pkg-config" '("--libs" "gtk+-2.0")
+			  :output :stream))
+
 ;; Get the list of libraries.
 (defun get-gtk-libs-list ()
-  (let ((prc (ext:run-program "pkg-config" '("--libs" "gtk+-2.0")
-			  :output :stream)))
+  (let ((prc (pkg-config-lib-string)))
     (if (not prc)
-	(error "Could not run #\"pckg-config!")
-      (let ((str (ext:process-output prc))
-	    (ecode (ext:process-exit-code prc)))
+	(error "Could not run #\"pkg-config!")
+      (let ((str (process-output prc))
+	    (ecode (process-exit-code prc)))
 	(if (not (eql ecode 0))
 	    (error "Could not find gtk+-2.0")
 	  (remove-if ;; Remove options which do not specify a lib
@@ -47,13 +53,20 @@
 						   ;; insenitive.
 	   (splitatspc (read-line str))))))))
 
+
+(defun pkg-config-cflags-string ()
+  #+sbcl (run-program "pkg-config" '("--cflags" "gtk+-2.0")
+		      :search t
+		      :output :stream)
+  #+cmu (ext:run-program "pkg-config" '("--cflags" "gtk+-2.0")
+			  :output :stream))
+
 (defun get-gtk-cflags-list ()
-  (let ((prc (ext:run-program "pkg-config" '("--cflags" "gtk+-2.0")
-			  :output :stream)))
+  (let ((prc (pkg-config-cflags-string)))
     (if (not prc)
 	(error "Could not run #\"pckg-config!")
-      (let ((str (ext:process-output prc))
-	    (ecode (ext:process-exit-code prc)))
+      (let ((str (process-output prc))
+	    (ecode (process-exit-code prc)))
 	(if (not (eql ecode 0))
 	    (error "Could not find gtk+-2.0")
 	  (read-line str))))))
@@ -78,8 +91,8 @@
 
 (defmethod perform ((o load-op) (c gtk-libs-handle))
   (setf *source-dir* (pathname-directory (component-pathname c)))
-  (ext:load-foreign (namestring (car (output-files o c)))
-		    :libraries *gtklibs*))
+  (load-foreign (namestring (car (output-files o c)))
+		:libraries *gtklibs*))
 
 (defsystem lgtk
   :name "lgtk"
@@ -95,7 +108,7 @@
 	    ((:file "port")
 	     (:file "nexus" :depends-on ("port"))
 	     (:file "widgets" :depends-on ("nexus"))
-	     (:file "dynaslot" :depends-on ("bindings" "nexus"))
+	     (:file "dynaslot" :depends-on ("bindings" "nexus" "port"))
 	     (:file "enums" :depends-on ("bindings"))
 	     (:file "bindings" :depends-on ("port"))
 
@@ -114,3 +127,9 @@
 					       "libhandle"))
 	     (:file "gtknexus" :depends-on ("gtkbindings"))
 	     (:file "gtklisp" :depends-on ("gtknexus"))))))
+
+;; On 2003.12.10, load-foreign was put in deathrow by the sbcl
+;; developers. The following comment was made by Krystof_ and is
+;; probably going to help minimize the impact: "cmucl's load-foreign
+;; on linux runs ld -G -o /tmp/RANDOM --whole-archive file1.a file2.o
+;; file3.so --no-whole-archive -lfoo -lbar"




From mmommer at common-lisp.net  Thu Dec 11 10:48:00 2003
From: mmommer at common-lisp.net (Mario Mommer)
Date: Thu, 11 Dec 2003 05:48:00 -0500
Subject: [lgtk-cvs] CVS update: lgtk/src/dynaslot.lisp lgtk/src/gtklisp.lisp
	lgtk/src/gtknexus.lisp lgtk/src/gtkpackage.lisp lgtk/src/port.lisp 
Message-ID: <E1AUOMS-0008AP-00@common-lisp.net>

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))




From mmommer at common-lisp.net  Sat Dec 13 11:10:17 2003
From: mmommer at common-lisp.net (Mario Mommer)
Date: Sat, 13 Dec 2003 06:10:17 -0500
Subject: [lgtk-cvs] CVS update: lgtk/src/gtklisp.lisp 
Message-ID: <E1AV7f7-0003L5-00@common-lisp.net>

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

Modified Files:
	gtklisp.lisp 
Log Message:
Added correct selector for callback address.

Date: Sat Dec 13 06:10:17 2003
Author: mmommer

Index: lgtk/src/gtklisp.lisp
diff -u lgtk/src/gtklisp.lisp:1.5 lgtk/src/gtklisp.lisp:1.6
--- lgtk/src/gtklisp.lisp:1.5	Thu Dec 11 05:48:00 2003
+++ lgtk/src/gtklisp.lisp	Sat Dec 13 06:10:17 2003
@@ -67,7 +67,7 @@
 			   :func func)))
     (setf (contents it)
 	  (gtk-aliens::|gtk_timeout_add| msecs
-				 (callback %gtk-itc-handler)
+				 (c-fun-ptr %gtk-itc-handler)
 				(id it)))
 
     it))
@@ -81,7 +81,7 @@
 			   :data data
 			   :func func)))
     (setf (contents it)
-	  (gtk-aliens::|gtk_idle_add| (callback %gtk-itc-handler)
+	  (gtk-aliens::|gtk_idle_add| (c-fun-ptr %gtk-itc-handler)
 			      (id it)))
 
     it))