[lgtk-cvs] CVS update: lgtk/src/dynaslot.lisp lgtk/src/gtklisp.lisp lgtk/src/gtknexus.lisp lgtk/src/port.lisp
Mario Mommer
mmommer at common-lisp.net
Fri Dec 5 16:55:09 UTC 2003
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*))
More information about the Lgtk-cvs
mailing list