From htaube at common-lisp.net Tue Dec 6 17:40:12 2005 From: htaube at common-lisp.net (Heinrich Konrad Taube) Date: Tue, 6 Dec 2005 18:40:12 +0100 (CET) Subject: [lambda-gtk-cvs] CVS update: lambda-gtk/lambda-gtk-cmusbcl.lisp Message-ID: <20051206174012.9F5FB88545@common-lisp.net> Update of /project/lambda-gtk/cvsroot/lambda-gtk In directory common-lisp.net:/tmp/cvs-serv11986 Modified Files: lambda-gtk-cmusbcl.lisp Log Message: implemented cstring->string, converted to SBCL native callbalcs (requires sbcl 0.9.7 or higher) Date: Tue Dec 6 18:40:11 2005 Author: htaube Index: lambda-gtk/lambda-gtk-cmusbcl.lisp diff -u lambda-gtk/lambda-gtk-cmusbcl.lisp:1.2 lambda-gtk/lambda-gtk-cmusbcl.lisp:1.3 --- lambda-gtk/lambda-gtk-cmusbcl.lisp:1.2 Fri Dec 31 22:18:03 2004 +++ lambda-gtk/lambda-gtk-cmusbcl.lisp Tue Dec 6 18:40:10 2005 @@ -550,6 +550,7 @@ (in-package :cl-user) (eval-when (:compile-toplevel :load-toplevel :execute) + #+sbcl (setq sb-alien::*values-type-okay* t) (export '(*gtk-libdir* *gtk-libfiles*) :cl-user) (defvar *gtk-libdir* #+:darwin \"/sw/lib/\" #-:darwin \"/usr/lib/\") (defvar *gtk-libfiles* @@ -634,7 +635,17 @@ (defgluecode (:export :gtk) (defun struct-free (x) (free-alien x))) (defgluecode (:export :gtk) - (defun cstring->string (str) (error "\"Fix me: not yet implemented.\""))) + (defun cstring->string (ptr) + (if ("g::nullptr?" ptr) + nil + (let ((p (if (typep ptr '(alien (* (unsigned 8)))) + ptr (cast ptr (* (unsigned 8)))))) + (declare (type (alien (* (unsigned 8))) p)) + (with-output-to-string (s) + (loop for i from 0 + for c = (deref p i) + until (zerop c) + do (write-char (code-char c) s))))))) (defgluecode (:export :gtk) (defun string->cstring (str) (if (= (length str) 0) @@ -681,13 +692,14 @@ `(,p (* t))))) (type (parse-alien-type return))) "#+:sbcl" - `(define-alien-function ,name , (cons type args) , at body) + `(defparameter ,name + (sb-alien::alien-sap + (sb-alien::alien-lambda ,type ,args , at body))) "#+:cmu" `(def-callback ,name ,(cons type args) , at body)))) (defgluecode (:export :g) (defmacro "g-callback" (x) - "#+:sbcl" - `(alien-function-sap ,x) + "#+:sbcl" x "#+:cmu `(alien::callback ,x)")) (defgluecode (:export :g) (defun "g-signal-connect" (instance detailed-signal c-handler data) From htaube at common-lisp.net Tue Dec 6 17:42:10 2005 From: htaube at common-lisp.net (Heinrich Konrad Taube) Date: Tue, 6 Dec 2005 18:42:10 +0100 (CET) Subject: [lambda-gtk-cvs] CVS update: lambda-gtk/lambda-gtk-openmcl.lisp Message-ID: <20051206174210.C797388545@common-lisp.net> Update of /project/lambda-gtk/cvsroot/lambda-gtk In directory common-lisp.net:/tmp/cvs-serv12006 Modified Files: lambda-gtk-openmcl.lisp Log Message: added trailing semicolon detect presence of ccl:darwin-headers;gtk2; directory Date: Tue Dec 6 18:42:10 2005 Author: htaube Index: lambda-gtk/lambda-gtk-openmcl.lisp diff -u lambda-gtk/lambda-gtk-openmcl.lisp:1.4 lambda-gtk/lambda-gtk-openmcl.lisp:1.5 --- lambda-gtk/lambda-gtk-openmcl.lisp:1.4 Fri Dec 31 22:18:04 2004 +++ lambda-gtk/lambda-gtk-openmcl.lisp Tue Dec 6 18:42:10 2005 @@ -338,7 +338,7 @@ (dolist (l *gtk-libfiles*) (open-shared-library (libpath l))))) (eval-when (:compile-toplevel :load-toplevel :execute) - (if (probe-file \"ccl:darwin-headers;gtk2\" ) + (if (probe-file \"ccl:darwin-headers;gtk2;\" ) (use-interface-dir :gtk2) (error \"Interface directory ccl:darwin-headers;gtk2; does not exist.\"))) ") From htaube at common-lisp.net Tue Dec 6 17:42:53 2005 From: htaube at common-lisp.net (Heinrich Konrad Taube) Date: Tue, 6 Dec 2005 18:42:53 +0100 (CET) Subject: [lambda-gtk-cvs] CVS update: lambda-gtk/lambda-gtk-common.lisp Message-ID: <20051206174253.8A4DD88545@common-lisp.net> Update of /project/lambda-gtk/cvsroot/lambda-gtk In directory common-lisp.net:/tmp/cvs-serv12088 Modified Files: lambda-gtk-common.lisp Log Message: put generated package exports inside eval-when Date: Tue Dec 6 18:42:53 2005 Author: htaube Index: lambda-gtk/lambda-gtk-common.lisp diff -u lambda-gtk/lambda-gtk-common.lisp:1.2 lambda-gtk/lambda-gtk-common.lisp:1.3 --- lambda-gtk/lambda-gtk-common.lisp:1.2 Mon Dec 13 03:51:23 2004 +++ lambda-gtk/lambda-gtk-common.lisp Tue Dec 6 18:42:52 2005 @@ -595,6 +595,7 @@ (let ((*print-case* ':downcase)) (terpri fil) (format fil postlude-string) + (format fil "~%(eval-when (:load-toplevel :execute)~%") (when g-exports (pprint `(export ',(reverse g-exports) :g) fil)) @@ -612,5 +613,5 @@ fil)) (terpri fil) (pprint '(pushnew ':gtk *features*) fil) - (format fil "~%~%;;; end generated output~%~%") + (format fil "~%)~%~%;;; end generated output~%~%") (values)))