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)