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