[lambda-gtk-cvs] CVS update: lambda-gtk/lambda-gtk-cmusbcl.lisp

[Heinrich Konrad Taube]

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)