- lgtk-cvs@common-lisp.net - mailman3.common-lisp.net

[lgtk-cvs] CVS update: lgtk/src/gtkbindings.lisp lgtk/src/gtkenums.lisp
by Mario Mommer 01 Mar '04

01 Mar '04

Update of /project/lgtk/cvsroot/lgtk/src In directory common-lisp.net:/tmp/cvs-serv14368/src Modified Files: gtkbindings.lisp gtkenums.lisp Log Message: Added a few more bindings. Different flavors of buttons. This was a patch by Sverker Wiberg. Date: Mon Mar 1 12:41:41 2004 Author: mmommer Index: lgtk/src/gtkbindings.lisp diff -u lgtk/src/gtkbindings.lisp:1.5 lgtk/src/gtkbindings.lisp:1.6 --- lgtk/src/gtkbindings.lisp:1.5 Tue Nov 11 16:41:54 2003 +++ lgtk/src/gtkbindings.lisp Mon Mar 1 12:41:41 2004 @@ -132,6 +132,24 @@ (def-binding "gtk_button_new_with_mnemonic" (gtkbutton (c-string text))) + +(def-binding "gtk_button_new_from_stock" + (gtkbutton (c-string text))) + +(def-binding "gtk_button_set_relief" + (void (gtkbutton button) + (gtkreliefstyle style))) + +(def-binding "gtk_button_get_relief" + (gtkreliefstyle (gtkbutton button))) + +(def-binding "gtk_button_get_label" + (c-string (gtkbutton button))) + +(def-binding "gtk_button_set_label" + (void (gtkbutton button) + (c-string label))) + (def-binding "gtk_toggle_button_new" (gtktogglebutton)) Index: lgtk/src/gtkenums.lisp diff -u lgtk/src/gtkenums.lisp:1.2 lgtk/src/gtkenums.lisp:1.3 --- lgtk/src/gtkenums.lisp:1.2 Wed Nov 5 12:49:56 2003 +++ lgtk/src/gtkenums.lisp Mon Mar 1 12:41:41 2004 @@ -7,11 +7,15 @@ (in-package #:gtk) +(defenum gtkreliefstyle + (:gtk-relief-normal + :gtk-relief-half + :gtk-relief-none)) + (defenum gtkwindowtype (:gtk-window-toplevel :gtk-window-popup)) - (defenum gsignalflags ((:g-signal-none . 0) (:g-signal-run-first . 1) @@ -63,3 +67,4 @@ :gtk-shadow-out :gtk-shadow-etched-in :gtk-shadow-etched-out)) +

1 0

[lgtk-cvs] CVS update: lgtk/lgtk-examples.asd
by Mario Mommer 01 Mar '04

01 Mar '04

Update of /project/lgtk/cvsroot/lgtk In directory common-lisp.net:/tmp/cvs-serv14368 Modified Files: lgtk-examples.asd Log Message: Added a few more bindings. Different flavors of buttons. This was a patch by Sverker Wiberg. Date: Mon Mar 1 12:41:41 2004 Author: mmommer Index: lgtk/lgtk-examples.asd diff -u lgtk/lgtk-examples.asd:1.4 lgtk/lgtk-examples.asd:1.5 --- lgtk/lgtk-examples.asd:1.4 Tue Nov 11 16:41:51 2003 +++ lgtk/lgtk-examples.asd Mon Mar 1 12:41:41 2004 @@ -24,6 +24,7 @@ (:file "check-button") (:file "radio-buttons") (:file "toggle-button") + (:file "button-flavors") (:file "tables-hw") (:file "dialog") (:file "entry"))))

1 0

[lgtk-cvs] CVS update: lgtk/src/gtklisp.lisp
by Mario Mommer 13 Dec '03

13 Dec '03

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

1 0

[lgtk-cvs] CVS update: lgtk/src/dynaslot.lisp lgtk/src/gtklisp.lisp lgtk/src/gtknexus.lisp lgtk/src/gtkpackage.lisp lgtk/src/port.lisp
by Mario Mommer 11 Dec '03

11 Dec '03

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 ,@stuff)) + #+cmu `(alien:def-alien-routine ,@stuff) + #+sbcl `(define-alien-routine ,@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)) + ,@body)) + +(defmacro c-fun-ptr (it) + `(callback ,it))

1 0

[lgtk-cvs] CVS update: lgtk/INSTALL.txt lgtk/README.txt lgtk/lgtk.asd
by Mario Mommer 11 Dec '03

11 Dec '03

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"

1 0

[lgtk-cvs] CVS update: lgtk/src/dynaslot.lisp lgtk/src/gtklisp.lisp lgtk/src/gtknexus.lisp lgtk/src/port.lisp
by Mario Mommer 11 Dec '03

11 Dec '03

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

1 0

[lgtk-cvs] CVS update: lgtk/lgtk.asd
by Mario Mommer 11 Dec '03

11 Dec '03

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"

1 0

[lgtk-cvs] CVS update: lgtk/src/gtknexus.lisp lgtk/src/gtkpackage.lisp lgtk/src/port.lisp
by Mario Mommer 10 Dec '03

10 Dec '03

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)) + ,@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 ,@stuff) - #+sbcl `(sb-alien:def-alien-routine ,@stuff)) + #+sbcl `(define-alien-routine ,@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*))

1 0

[lgtk-cvs] CVS update: lgtk/lgtk.asd
by Mario Mommer 05 Dec '03

05 Dec '03

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

1 0

[lgtk-cvs] CVS update: lgtk/README.txt
by Mario Mommer 05 Dec '03

05 Dec '03

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.

1 0