r3060: *** empty log message ***

[uffi.git] / src / strings.lisp

diff --git a/src/strings.lisp b/src/strings.lisp
index 63847cc3885fa0bcd61c6157a1c946ed604d2e58..02ae84bfa1758412f690918d6290633bba04ae1b 100644 (file)
--- a/src/strings.lisp
+++ b/src/strings.lisp
@@ -7,7 +7,7 @@
 ;;;; Programmer:    Kevin M. Rosenberg
 ;;;; Date Started:  Feb 2002
 ;;;;
-;;;; $Id: strings.lisp,v 1.3 2002/10/14 03:07:41 kevin Exp $
+;;;; $Id: strings.lisp,v 1.4 2002/10/16 11:56:43 kevin Exp $
 ;;;;
 ;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
 ;;;;
@@ -21,20 +21,16 @@
 
 
 (defvar +null-cstring-pointer+
-    #+cmu nil
-    #+sbcl nil
+    #+(or cmu sbcl scl) nil
     #+allegro 0
     #+lispworks (fli:make-pointer :address 0 :type '(:unsigned :char))
     #+mcl (ccl:%null-ptr)
-    #-(or cmu allegro lispworks mcl) nil
 )
 
 (defmacro convert-from-cstring (obj)
   "Converts a string from a c-call. Same as convert-from-foreign-string, except
 that LW/CMU automatically converts strings from c-calls."
-  #+cmu obj
-  #+sbcl obj
-  #+lispworks obj
+  #+(or cmu sbcl lispworks scl) obj
   #+allegro 
   (let ((stored (gensym)))
     `(let ((,stored ,obj))
@@ -50,9 +46,7 @@ that LW/CMU automatically converts strings from c-calls."
   )
 
 (defmacro convert-to-cstring (obj)
-  #+cmu obj
-  #+sbcl obj
-  #+lispworks obj
+  #+(or cmu sbcl scl lispworks) obj
   #+allegro
   `(if (null ,obj)
     0
@@ -66,7 +60,7 @@ that LW/CMU automatically converts strings from c-calls."
   )
 
 (defmacro free-cstring (obj)
-  #+(or cmu sbcl lispworks) (declare (ignore obj))
+  #+(or cmu sbcl scl lispworks) (declare (ignore obj))
   #+allegro
   `(unless (zerop obj)
      (ff:free-fobject ,obj))
@@ -76,7 +70,7 @@ that LW/CMU automatically converts strings from c-calls."
   )
 
 (defmacro with-cstring ((cstring lisp-string) &body body)
-  #+(or cmu sbcl lispworks)
+  #+(or cmu sbcl scl lispworks)
   `(let ((,cstring ,lisp-string)) ,@body) 
   #+allegro
   (let ((acl-native (gensym)))
@@ -109,7 +103,7 @@ that LW/CMU automatically converts strings from c-calls."
   `(if (null ,obj)
        0
      (values (excl:string-to-native ,obj)))
-  #+cmu
+  #+(or cmu scl)
   (let ((size (gensym))
        (storage (gensym))
        (i (gensym)))
@@ -173,7 +167,7 @@ that LW/CMU automatically converts strings from c-calls."
       ,@(if length (list :length length) (values))
       :null-terminated-p ,null-terminated-p
       :external-format '(:latin-1 :eol-style :lf)))      
-  #+cmu
+  #+(or cmu scl)
   `(if (null-pointer-p ,obj)
     nil
     (cmucl-naturalize-cstring (alien:alien-sap ,obj)
@@ -196,7 +190,7 @@ that LW/CMU automatically converts strings from c-calls."
 
 
 (defmacro allocate-foreign-string (size &key (unsigned t))
-  #+cmu
+  #+(or cmu scl)
   (let ((array-def (gensym)))
     `(let ((,array-def (list 'alien:array 'c-call:char ,size)))
        (eval `(alien:cast (alien:make-alien ,,array-def) 
@@ -259,6 +253,30 @@ that LW/CMU automatically converts strings from c-calls."
                                    (* length vm:byte-bits))
       result)))
 
+#+scl
+;; kernel:copy-from-system-area doesn't work like it does on CMUCL or SBCL,
+;; so have to iteratively copy from sap
+(defun cmucl-naturalize-cstring (sap &key length (null-terminated-p t))
+  (declare (type system:system-area-pointer sap))
+  (locally
+      (declare (optimize (speed 3) (safety 0)))
+    (let ((null-terminated-length
+          (when null-terminated-p
+            (loop
+                for offset of-type fixnum upfrom 0
+                until (zerop (system:sap-ref-8 sap offset))
+                finally (return offset)))))
+      (if length
+         (if (and null-terminated-length
+                  (> (the fixnum length) (the fixnum null-terminated-length)))
+             (setq length null-terminated-length))
+       (setq length null-terminated-length)))
+    (let ((result (make-string length)))
+      (dotimes (i length)
+       (declare (type fixnum i))
+       (setf (char result i) (code-char (system:sap-ref-8 sap i))))
+      result)))
+
 #+sbcl
 (defun sbcl-naturalize-cstring (sap &key length (null-terminated-p t))
   (declare (type sb-sys:system-area-pointer sap))