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