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) ,@body) + `(defparameter ,name + (sb-alien::alien-sap + (sb-alien::alien-lambda ,type ,args ,@body))) "#+:cmu" `(def-callback ,name ,(cons type args) ,@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)