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