[PATCH] lgtk CVS on SBCL
Damien Diederen <[email protected]> Thu, 4 Dec 2003 23:02:58 +0100
| Newsgroups | gmane.lisp.clump |
|---|---|
| Message-ID | <[email protected]> |
--wxDdMuZNg1r63Hyj
Content-Type: text/plain; charset=us-ascii
Content-Disposition: inline
Hi All,
This is a first effort to get Mario Mommer's Gtk+ bindings running on
SBCL:
* callback-sbcl.{lisp, patch}: a straightforward,
`query-replace-regexp'-based port of Helmut Heller's callbacks (from
http://article.gmane.org/gmane.lisp.cmucl.devel/2472). A comment at
the top of the file explains the way they work; the main thing is an
unmovable CALL-CALLBACK lisp function. The file can be loaded as-is
in SBCL, but a PURIFY or SAVE-LISP-AND-DIE should be issued before
creating callbacks if you want to avoid nasty random crashes.
* lgtk.patch: a *FEATURES*-based conditionalization of the current CVS
lgtk. `port.lisp' and `lgtk.asd' are the most affected files, but
various implementation-specific package references have been patched
at other places. Those should clearly be moved to 'port.lisp', or be
collected in a "private" package.
Mini-HOWTO (for ASDF-enabled SBCLs):
(load "callback-sbcl")
(purify)
(require :lgtk)
;; Let the fun begin
(require :lgtk-examples)
WorksForMe, but LameConditionalizationAllOverThePlace and ScaryThingsInside.
Comments are of course welcome...
Cu,
Dash.
--
Do not condemn the judgement of another because it differs from your own.
You may both be wrong.
-- Dandemis
--
http://users.swing.be/diederen/
--wxDdMuZNg1r63Hyj
Content-Type: text/plain; charset=us-ascii
Content-Disposition: attachment; filename="callback-sbcl.lisp"
;;; callback.lisp -- callback support for CMUCL/x86
;;; This is a SBCL port of Helmut Heller's code from:
;;; http://article.gmane.org/gmane.lisp.cmucl.devel/2472
;;;
;;; Note that this is a straightforward `query-replace-regexp'-based
;;; port as I do not know the SBCL internals at all.
;;;
;;; Damien Diederen <[email protected]>
;;; This package provides a mechanism for defining callbacks: lisp
;;; functions which can be called from foreign code. The user
;;; interface consists of the macros DEFCALLBACK and CALLBACK. (See
;;; the doc-strings for details.)
;;;
;;; Below are two examples. The first example defines a callback FOO
;;; and calls it with alien-funcall. The second illustrates the use
;;; of the libc qsort function.
;;;
;;; The implementation generates a piece machine code -- a
;;; "trampoline" -- for each callback function. A pointer to this
;;; trampoline can then be passed to foreign code. The trampoline is
;;; allocated with malloc and is not moved by the GC.
;;;
;;; When called, the trampoline passes a pointer to the arguments
;;; (essentially the stack pointer) together with an index to
;;; CALL-CALLACK. CALL-CALLBACK uses the index to find the
;;; corresponding lisp function and calls this function with the
;;; argument pointer. The lisp function uses the pointer to copy the
;;; arguments form the stack to local variables. On return, the lisp
;;; function stores the result into the location given by the argument
;;; pointer, and the trampoline code copies the return value from
;;; there into the right return register.
;;;
;;; The address of CALL-CALLBACK is used in every trampoline and must
;;; not be moved by the gc. It is therefore necessary to either
;;; include this package into the image (core) or to purify before
;;; creating any trampolines (or to invent some other trick).
;;;
;;; Examples:
#||
;;; Example 1:
(defcallback foo (int (arg1 int) (arg2 int))
(format t "~&foo: ~S, ~S~%" arg1 arg2)
(+ arg1 arg2))
(alien-funcall (sap-alien (callback foo) (function int int int))
555 444444)
;;; Example 2:
(def-alien-routine qsort void
(base (* t))
(nmemb int)
(size int)
(compar (* (function int (* t) (* t)))))
(defcallback my< (int (arg1 (* double))
(arg2 (* double)))
(let ((a1 (deref arg1))
(a2 (deref arg2)))
(cond ((= a1 a2) 0)
((< a1 a2) -1)
(t +1))))
(let ((a (make-array 10 :element-type 'double-float
:initial-contents '(0.1d0 0.5d0 0.2d0 1.2d0 1.5d0
2.5d0 0.0d0 0.1d0 0.2d0 0.3d0))))
(print a)
(qsort (sb-sys:vector-sap a)
(length a)
(alien-size double :bytes)
(callback my<))
(print a))
||#
(defpackage :callback
(:use :cl :sb-ext :sb-alien :sb-assem)
(:export :defcallback
:callback))
(in-package :callback)
(defstruct (callback
(:constructor make-callback (trampoline lisp-fn return-type)))
"A callback consists of a piece assembly code -- the trampoline --
and a lisp function. We store the return-type, so we can detect
incompatible redefinitions."
(trampoline (required-argument) :type system-area-pointer)
(lisp-fn (required-argument) :type (function (fixnum) (values)))
(return-type (required-argument) :type sb-alien::alien-type))
(declaim (type (vector callback) *callbacks*))
(defvar *callbacks* (make-array 10 :element-type 'callback
:fill-pointer 0 :adjustable t)
"Vector of all callbacks.")
(defun call-callback (index sp-fixnum)
(declare (type fixnum index sp-fixnum)
(optimize speed))
(funcall (callback-lisp-fn (aref *callbacks* index))
sp-fixnum))
(defun create-callback (lisp-fn return-type)
(let* ((index (fill-pointer *callbacks*))
(tramp (make-callback-trampoline index return-type))
(cb (make-callback tramp lisp-fn return-type)))
(vector-push-extend cb *callbacks*)
cb))
(defun address-of-call-into-lisp ()
(sb-sys:sap-int (alien-sap (extern-alien "call_into_lisp" (function (* t))))))
(defun address-of-call-callback ()
(sb-kernel:get-lisp-obj-address #'call-callback))
;;; Some abbreviations for alien-type classes. The $ suffix is there
;;; to prevent name clashes.
(deftype void$ () '(satisfies alien-void-type-p))
(deftype integer$ () 'sb-alien::alien-integer-type)
(deftype integer-64$ () '(satisfies alien-integer-64-type-p))
(deftype signed-integer$ () '(satisfies alien-signed-integer-type-p))
(deftype pointer$ () 'sb-alien::alien-pointer-type)
(deftype single$ () 'sb-alien::alien-single-float-type)
(deftype double$ () 'sb-alien::alien-double-float-type)
(deftype sap$ () '(satisfies alien-sap-type=))
(defun alien-sap-type= (type)
(sb-alien::alien-type-= type
(sb-alien::parse-alien-type 'system-area-pointer nil)))
(defun alien-void-type-p (type)
(and (sb-alien::alien-values-type-p type)
(null (sb-alien::alien-values-type-values type))))
(defun alien-integer-64-type-p (type)
(and (sb-alien::alien-integer-type-p type)
(= (sb-alien::alien-type-bits type) 64)))
(defun alien-signed-integer-type-p (type)
(and (sb-alien::alien-integer-type-p type)
(sb-alien::alien-integer-type-signed type)))
(defun segment-to-trampoline (segment length)
(let* ((code (alien-funcall
(extern-alien "malloc" (function system-area-pointer unsigned))
length))
(fill-pointer code))
(on-segment-contents-vectorly segment
(lambda (subseg)
(sb-kernel:copy-byte-vector-to-system-area subseg fill-pointer)
(setf fill-pointer (sb-sys:sap+ fill-pointer (length subseg)))))
code))
(defun make-callback-trampoline (index return-type)
"Cons up a piece of code which calls call-callback with INDEX and a
pointer to the arguments."
(let* ((segment (make-segment))
(eax sb-vm::eax-tn)
(edx sb-vm::edx-tn)
(ebp sb-vm::ebp-tn)
(esp sb-vm::esp-tn)
([ebp-8] (sb-vm::make-ea :dword :base ebp :disp -8))
([ebp-4] (sb-vm::make-ea :dword :base ebp :disp -4)))
;; The generated assembly roughly corresponds to this C code:
;;
;; int32 args[2];
;; args[0] = <index>;
;; args[1] = <untagged pointer to arguments (in the caller frame)>;
;; call_into_lisp (call-callback, args, 2)
;; // The Lisp side stores the result into args,
;; // assuming &args == args[1] - 16 bytes.
;; return *args;
;;
(assemble (segment)
(inst push ebp) ; save old frame pointer
(inst mov ebp esp) ; establish new frame
(inst mov eax esp) ; pointer to first arg for
(inst add eax 8) ; this function
(inst push eax) ; arg1
(inst push (ash index 2)) ; arg0
(inst mov eax esp) ; save argsp
(inst push 2) ; n-args
(inst push eax) ; argsp
(inst push (address-of-call-callback)); function
;; The stack looks now like this:
;; in-args
;; ret-addr
;; old-fp
;; arg1 (= &in-args)
;; arg0 (= index)
;; 2
;; argsp (= &arg0)
;; call-callback
(inst mov eax (address-of-call-into-lisp))
(inst call eax)
;; now put the result into the right register
(etypecase return-type
(integer-64$ (inst mov eax [ebp-8])
(inst mov edx [ebp-4]))
((or integer$ pointer$ sap$) (inst mov eax [ebp-8]))
(single$ (inst fld [ebp-8]))
(double$ (inst fldd [ebp-8]))
(void$ ))
(inst mov esp ebp) ; discard frame
(inst pop ebp) ; restore frame pointer
(inst ret))
(let ((length (finalize-segment segment)))
(prog1 (segment-to-trampoline segment length)
;; FIXME: What is the SBCL equivalent of CMUCL's
;; RELEASE-SEGMENT? Is there any, or does it just get GCed? -dd
#+(or) (release-segment segment)))))
(defun symbol-trampoline (symbol)
(callback-trampoline (symbol-value symbol)))
(defmacro callback (name)
"Return the trampoline pointer for the callback NAME."
`(symbol-trampoline ',name))
(defun compatible-return-types-p (type1 type2)
(flet ((machine-rep (type)
(etypecase type
(integer-64$ :dword)
((or integer$ pointer$ sap$) :word)
(single$ :single)
(double$ :double)
(void$ :void))))
(eq (machine-rep type1) (machine-rep type2))))
(defun define-callback-function (name lisp-fn return-type)
(declare (type symbol name)
(type function lisp-fn))
(flet ((register-new-callback ()
(setf (symbol-value name)
(create-callback lisp-fn return-type))))
(if (and (boundp name)
(callback-p (symbol-value name)))
;; try do redefine the existing callback
(let ((callback (find (symbol-trampoline name) *callbacks*
:key #'callback-trampoline :test #'sb-sys:sap=)))
(cond (callback
(let ((old-type (callback-return-type callback)))
(cond ((compatible-return-types-p old-type return-type)
;; (format t "~&; Redefining callback ~A~%" name)
(setf (callback-lisp-fn callback) lisp-fn)
(setf (callback-return-type callback) return-type)
callback)
(t
(let ((e (format nil "~
Attempt to redefine callback with incompatible return type.
Old type was: ~A
New type is: ~A" old-type return-type))
(c (format nil "~
Create new trampoline (old trampoline calls old lisp function).")))
(cerror c e)
(register-new-callback))))))
(t (register-new-callback))))
(register-new-callback))))
(defun word-aligned-bits (type)
(sb-alien::align-offset (sb-alien::alien-type-bits type) sb-vm:n-word-bits))
(defun argument-size (spec)
(let ((type (sb-alien::parse-alien-type spec nil)))
(typecase type
((or integer$ single$ double$ pointer$ sap$)
(ceiling (word-aligned-bits type) sb-vm:n-byte-bits))
(t (error "Unsupported argument type: ~A" spec)))))
(defun parse-return-type (spec)
(let ((sb-alien::*values-type-okay* t))
(sb-alien::parse-alien-type spec nil)))
(defun return-exp (spec sap body)
(flet ((store (spec) `(setf (deref (sap-alien ,sap (* ,spec))) ,body)))
(let ((type (parse-return-type spec)))
(typecase type
(void$ body)
(signed-integer$
(store `(signed ,(word-aligned-bits type))))
(integer$
(store `(unsigned ,(word-aligned-bits type))))
((or single$ double$ pointer$ sap$)
(store spec))
(t (error "Unsupported return type: ~A" spec))))))
(defmacro defcallback (name (return-type &rest arg-specs) &body body)
"(defcallback NAME (RETURN-TYPE {(ARG-NAME ARG-TYPE)}*) {FORM}*)
Define a function which can be called by foreign code. The pointer
returned by (callback NAME), when called by foreign code, invokes the
lisp function. The lisp function expects alien arguments of the
specified ARG-TYPEs and returns an alien of type RETURN-TYPE.
If (callback NAME) is already a callback function pointer, its value
is not changed (though it's arranged that an updated version of the
lisp callback function will be called). This feature allows for
incremental redefinition of callback functions."
(let ((sp-fixnum (gensym (string :sp-fixnum)))
(sp (gensym (string :sp))))
`(progn
(defun ,name (,sp-fixnum)
(declare (type fixnum ,sp-fixnum))
;; We assume sp-fixnum is word aligned and pass it untagged to
;; this function. The shift compensates this.
(let ((,sp (sb-sys:int-sap (ash ,sp-fixnum 2))))
(declare (ignorable ,sp))
;; Copy all arguments to local variables.
(with-alien ,(loop for offset = 0 then (+ offset
(argument-size type))
for (name type) in arg-specs
collect `(,name ,type
:local (deref (sap-alien
(sb-sys:sap+ ,sp ,offset)
(* ,type)))))
,(return-exp return-type `(sb-sys:sap+ ,sp -16) `(progn ,@body))
(values))))
(define-callback-function
',name #',name ',(parse-return-type return-type)))))
;;; dumping support
(defun restore-callbacks ()
;; Create new trampolines on reload.
(loop for cb across *callbacks*
for i from 0
do (setf (callback-trampoline cb)
(make-callback-trampoline i (callback-return-type cb)))))
;; *after-save-initializations* contains
;; new-assem::forget-output-blocks, and the assembler may not work
;; before forget-output-blocks was called. We add 'restore-callback at
;; the end of *after-save-initializations* to sidestep this problem.
(setf sb-int:*after-save-initializations*
(append sb-int:*after-save-initializations* (list 'restore-callbacks)))
;;; callback.lisp ends here
--wxDdMuZNg1r63Hyj
Content-Type: text/plain; charset=us-ascii
Content-Disposition: attachment; filename="callback-sbcl.patch"
--- /home/dash/download/callback.lisp Wed Oct 29 20:44:15 2003
+++ callback-sbcl.lisp Thu Dec 4 21:13:28 2003
@@ -1,5 +1,13 @@
;;; callback.lisp -- callback support for CMUCL/x86
+;;; This is a SBCL port of Helmut Heller's code from:
+;;; http://article.gmane.org/gmane.lisp.cmucl.devel/2472
+;;;
+;;; Note that this is a straightforward `query-replace-regexp'-based
+;;; port as I do not know the SBCL internals at all.
+;;;
+;;; Damien Diederen <[email protected]>
+
;;; This package provides a mechanism for defining callbacks: lisp
;;; functions which can be called from foreign code. The user
;;; interface consists of the macros DEFCALLBACK and CALLBACK. (See
@@ -31,7 +39,7 @@
;;;
;;; Examples:
-#|
+#||
;;; Example 1:
(defcallback foo (int (arg1 int) (arg2 int))
@@ -61,16 +69,16 @@
:initial-contents '(0.1d0 0.5d0 0.2d0 1.2d0 1.5d0
2.5d0 0.0d0 0.1d0 0.2d0 0.3d0))))
(print a)
- (qsort (sys:vector-sap a)
+ (qsort (sb-sys:vector-sap a)
(length a)
(alien-size double :bytes)
(callback my<))
(print a))
-|#
+||#
(defpackage :callback
- (:use :cl :ext :alien :c-call :new-assem)
+ (:use :cl :sb-ext :sb-alien :sb-assem)
(:export :defcallback
:callback))
@@ -83,7 +91,7 @@
incompatible redefinitions."
(trampoline (required-argument) :type system-area-pointer)
(lisp-fn (required-argument) :type (function (fixnum) (values)))
- (return-type (required-argument) :type alien::alien-type))
+ (return-type (required-argument) :type sb-alien::alien-type))
(declaim (type (vector callback) *callbacks*))
(defvar *callbacks* (make-array 10 :element-type 'callback
@@ -104,61 +112,60 @@
cb))
(defun address-of-call-into-lisp ()
- (sys:sap-int (alien-sap (extern-alien "call_into_lisp" (function (* t))))))
+ (sb-sys:sap-int (alien-sap (extern-alien "call_into_lisp" (function (* t))))))
(defun address-of-call-callback ()
- (kernel:get-lisp-obj-address #'call-callback))
+ (sb-kernel:get-lisp-obj-address #'call-callback))
;;; Some abbreviations for alien-type classes. The $ suffix is there
;;; to prevent name clashes.
(deftype void$ () '(satisfies alien-void-type-p))
-(deftype integer$ () 'alien::alien-integer-type)
+(deftype integer$ () 'sb-alien::alien-integer-type)
(deftype integer-64$ () '(satisfies alien-integer-64-type-p))
(deftype signed-integer$ () '(satisfies alien-signed-integer-type-p))
-(deftype pointer$ () 'alien::alien-pointer-type)
-(deftype single$ () 'alien::alien-single-float-type)
-(deftype double$ () 'alien::alien-double-float-type)
+(deftype pointer$ () 'sb-alien::alien-pointer-type)
+(deftype single$ () 'sb-alien::alien-single-float-type)
+(deftype double$ () 'sb-alien::alien-double-float-type)
(deftype sap$ () '(satisfies alien-sap-type=))
(defun alien-sap-type= (type)
- (alien::alien-type-= type
- (alien::parse-alien-type 'system-area-pointer)))
+ (sb-alien::alien-type-= type
+ (sb-alien::parse-alien-type 'system-area-pointer nil)))
(defun alien-void-type-p (type)
- (and (alien::alien-values-type-p type)
- (null (alien::alien-values-type-values type))))
+ (and (sb-alien::alien-values-type-p type)
+ (null (sb-alien::alien-values-type-values type))))
(defun alien-integer-64-type-p (type)
- (and (alien::alien-integer-type-p type)
- (= (alien::alien-type-bits type) 64)))
+ (and (sb-alien::alien-integer-type-p type)
+ (= (sb-alien::alien-type-bits type) 64)))
(defun alien-signed-integer-type-p (type)
- (and (alien::alien-integer-type-p type)
- (alien::alien-integer-type-signed type)))
+ (and (sb-alien::alien-integer-type-p type)
+ (sb-alien::alien-integer-type-signed type)))
(defun segment-to-trampoline (segment length)
(let* ((code (alien-funcall
(extern-alien "malloc" (function system-area-pointer unsigned))
length))
(fill-pointer code))
- (segment-map-output segment
- (lambda (sap length)
- (kernel:system-area-copy sap 0 fill-pointer 0
- (* length vm:byte-bits))
- (setf fill-pointer (sys:sap+ fill-pointer length))))
+ (on-segment-contents-vectorly segment
+ (lambda (subseg)
+ (sb-kernel:copy-byte-vector-to-system-area subseg fill-pointer)
+ (setf fill-pointer (sb-sys:sap+ fill-pointer (length subseg)))))
code))
(defun make-callback-trampoline (index return-type)
"Cons up a piece of code which calls call-callback with INDEX and a
pointer to the arguments."
(let* ((segment (make-segment))
- (eax x86::eax-tn)
- (edx x86::edx-tn)
- (ebp x86::ebp-tn)
- (esp x86::esp-tn)
- ([ebp-8] (x86::make-ea :dword :base ebp :disp -8))
- ([ebp-4] (x86::make-ea :dword :base ebp :disp -4)))
+ (eax sb-vm::eax-tn)
+ (edx sb-vm::edx-tn)
+ (ebp sb-vm::ebp-tn)
+ (esp sb-vm::esp-tn)
+ ([ebp-8] (sb-vm::make-ea :dword :base ebp :disp -8))
+ ([ebp-4] (sb-vm::make-ea :dword :base ebp :disp -4)))
;; The generated assembly roughly corresponds to this C code:
;;
;; int32 args[2];
@@ -204,7 +211,9 @@
(inst ret))
(let ((length (finalize-segment segment)))
(prog1 (segment-to-trampoline segment length)
- (release-segment segment)))))
+ ;; FIXME: What is the SBCL equivalent of CMUCL's
+ ;; RELEASE-SEGMENT? Is there any, or does it just get GCed? -dd
+ #+(or) (release-segment segment)))))
(defun symbol-trampoline (symbol)
(callback-trampoline (symbol-value symbol)))
@@ -233,7 +242,7 @@
(callback-p (symbol-value name)))
;; try do redefine the existing callback
(let ((callback (find (symbol-trampoline name) *callbacks*
- :key #'callback-trampoline :test #'sys:sap=)))
+ :key #'callback-trampoline :test #'sb-sys:sap=)))
(cond (callback
(let ((old-type (callback-return-type callback)))
(cond ((compatible-return-types-p old-type return-type)
@@ -254,18 +263,18 @@
(register-new-callback))))
(defun word-aligned-bits (type)
- (alien::align-offset (alien::alien-type-bits type) vm:word-bits))
+ (sb-alien::align-offset (sb-alien::alien-type-bits type) sb-vm:n-word-bits))
(defun argument-size (spec)
- (let ((type (alien::parse-alien-type spec)))
+ (let ((type (sb-alien::parse-alien-type spec nil)))
(typecase type
((or integer$ single$ double$ pointer$ sap$)
- (ceiling (word-aligned-bits type) vm:byte-bits))
+ (ceiling (word-aligned-bits type) sb-vm:n-byte-bits))
(t (error "Unsupported argument type: ~A" spec)))))
(defun parse-return-type (spec)
- (let ((alien::*values-type-okay* t))
- (alien::parse-alien-type spec)))
+ (let ((sb-alien::*values-type-okay* t))
+ (sb-alien::parse-alien-type spec nil)))
(defun return-exp (spec sap body)
(flet ((store (spec) `(setf (deref (sap-alien ,sap (* ,spec))) ,body)))
@@ -299,7 +308,7 @@
(declare (type fixnum ,sp-fixnum))
;; We assume sp-fixnum is word aligned and pass it untagged to
;; this function. The shift compensates this.
- (let ((,sp (sys:int-sap (ash ,sp-fixnum 2))))
+ (let ((,sp (sb-sys:int-sap (ash ,sp-fixnum 2))))
(declare (ignorable ,sp))
;; Copy all arguments to local variables.
(with-alien ,(loop for offset = 0 then (+ offset
@@ -307,9 +316,9 @@
for (name type) in arg-specs
collect `(,name ,type
:local (deref (sap-alien
- (sys:sap+ ,sp ,offset)
+ (sb-sys:sap+ ,sp ,offset)
(* ,type)))))
- ,(return-exp return-type `(sys:sap+ ,sp -16) `(progn ,@body))
+ ,(return-exp return-type `(sb-sys:sap+ ,sp -16) `(progn ,@body))
(values))))
(define-callback-function
',name #',name ',(parse-return-type return-type)))))
@@ -327,7 +336,7 @@
;; new-assem::forget-output-blocks, and the assembler may not work
;; before forget-output-blocks was called. We add 'restore-callback at
;; the end of *after-save-initializations* to sidestep this problem.
-(setf *after-save-initializations*
- (append *after-save-initializations* (list 'restore-callbacks)))
+(setf sb-int:*after-save-initializations*
+ (append sb-int:*after-save-initializations* (list 'restore-callbacks)))
;;; callback.lisp ends here
--wxDdMuZNg1r63Hyj
Content-Type: text/plain; charset=us-ascii
Content-Disposition: attachment; filename="lgtk.patch"
Index: lgtk.asd
===================================================================
RCS file: /project/lgtk/cvsroot/lgtk/lgtk.asd,v
retrieving revision 1.7
diff -u -r1.7 lgtk.asd
--- lgtk.asd 9 Nov 2003 17:32:45 -0000 1.7
+++ lgtk.asd 4 Dec 2003 20:10:25 -0000
@@ -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"
Index: src/dynaslot.lisp
===================================================================
RCS file: /project/lgtk/cvsroot/lgtk/src/dynaslot.lisp,v
retrieving revision 1.3
diff -u -r1.3 dynaslot.lisp
--- src/dynaslot.lisp 10 Nov 2003 21:44:07 -0000 1.3
+++ src/dynaslot.lisp 4 Dec 2003 20:10:26 -0000
@@ -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: src/gtklisp.lisp
===================================================================
RCS file: /project/lgtk/cvsroot/lgtk/src/gtklisp.lisp,v
retrieving revision 1.4
diff -u -r1.4 gtklisp.lisp
--- src/gtklisp.lisp 10 Nov 2003 20:44:47 -0000 1.4
+++ src/gtklisp.lisp 4 Dec 2003 20:10:26 -0000
@@ -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: src/gtknexus.lisp
===================================================================
RCS file: /project/lgtk/cvsroot/lgtk/src/gtknexus.lisp,v
retrieving revision 1.4
diff -u -r1.4 gtknexus.lisp
--- src/gtknexus.lisp 9 Nov 2003 17:32:46 -0000 1.4
+++ src/gtknexus.lisp 4 Dec 2003 20:10:27 -0000
@@ -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: src/port.lisp
===================================================================
RCS file: /project/lgtk/cvsroot/lgtk/src/port.lisp,v
retrieving revision 1.3
diff -u -r1.3 port.lisp
--- src/port.lisp 29 Oct 2003 17:20:45 -0000 1.3
+++ src/port.lisp 4 Dec 2003 20:10:27 -0000
@@ -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*))
--wxDdMuZNg1r63Hyj
Content-Type: text/plain; charset="us-ascii"
MIME-Version: 1.0
Content-Transfer-Encoding: 7bit
Content-Disposition: inline
_______________________________________________
Clump mailing list
[email protected]
http://manly.caddr.com/mailman/listinfo/clump
--wxDdMuZNg1r63Hyj--