r3060: *** empty log message ***

diff --git a/NEWS b/NEWS
index 15937b30188396d96425d345bd1260b13704b3dc..3a8dccad7ff746ea8bc4b1cb3f0f66dc18af7ff2 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -1,3 +1,3 @@
-UFFI now passes all tests with SBCL & OpenMCL in Debian.
+UFFI now passes all tests with SCL, SBCL, & OpenMCL in Debian.
 
 UFFI now uses ASDF system definition files.

diff --git a/debian/changelog b/debian/changelog
index 17800a03e23a249b2433b7836d0f93f14b1a83a5..94951a205fbadf6d11c276f213e2e943c8f579d8 100644 (file)
--- a/debian/changelog
+++ b/debian/changelog
@@ -1,3 +1,9 @@
+cl-uffi (1.1.0-1) unstable; urgency=low
+
+  * Add SCL support.
+
+ -- Kevin M. Rosenberg <kmr@debian.org>  Tue, 15 Oct 2002 11:22:35 -0600
+
 cl-uffi (1.0.1-1) unstable; urgency=low
 
   * Add SBCL to documentation

diff --git a/doc/html.tar.gz b/doc/html.tar.gz
index 13d12938e30a5228a4a95bc077018962332a9255..1643e396fc3aa0261061ab765e817172cf228879 100644 (file)
Binary files a/doc/html.tar.gz and b/doc/html.tar.gz differ

diff --git a/examples/c-test-fns.lisp b/examples/c-test-fns.lisp
index c21b39c6e5717bcfca31da2a9ce52062fcb13b3b..435fdd69645db951457e3b99d5ac934f24400e23 100644 (file)
--- a/examples/c-test-fns.lisp
+++ b/examples/c-test-fns.lisp
@@ -7,7 +7,7 @@
 ;;;; Programmer:    Kevin M. Rosenberg
 ;;;; Date Started:  Mar 2002
 ;;;;
-;;;; $Id: c-test-fns.lisp,v 1.1 2002/09/30 10:02:36 kevin Exp $
+;;;; $Id: c-test-fns.lisp,v 1.2 2002/10/16 11:56:43 kevin Exp $
 ;;;;
 ;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
 ;;;;
@@ -68,7 +68,7 @@
     (half-double-vector +double-vec-length+ vec)
     vec))
 
-#+cmu
+#+(or cmu scl)
 (defun t3 ()
   (let ((vec (make-array +double-vec-length+ :element-type 'double-float)))
     (dotimes (i +double-vec-length+)

diff --git a/src/aggregates.lisp b/src/aggregates.lisp
index a233d1d4462d44bc30c9366e67ea10258c4dfb9b..848b735cb60968414f7d5bebaffe890a835cce01 100644 (file)
--- a/src/aggregates.lisp
+++ b/src/aggregates.lisp
@@ -7,7 +7,7 @@
 ;;;; Programmer:    Kevin M. Rosenberg
 ;;;; Date Started:  Feb 2002
 ;;;;
-;;;; $Id: aggregates.lisp,v 1.3 2002/10/14 04:15:02 kevin Exp $
+;;;; $Id: aggregates.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
 ;;;;
@@ -44,7 +44,7 @@ of the enum-name name, separator-string, and field-name"
     (setf cmds (append '(progn)
                       #+allegro `((ff:def-foreign-type ,enum-name :int))
                       #+lispworks `((fli:define-c-typedef ,enum-name :int))
-                      #+cmu `((alien:def-alien-type ,enum-name alien:signed))
+                      #+(or cmu scl) `((alien:def-alien-type ,enum-name alien:signed))
                       #+sbcl `((sb-alien:define-alien-type ,enum-name sb-alien:signed))
                        #+(and mcl (not openmcl)) `((def-mcl-type ,enum-name :integer))
                        #+openmcl `((ccl::def-foreign-type ,enum-name :int))
@@ -59,7 +59,7 @@ of the enum-name name, separator-string, and field-name"
   #+lispworks
   `(fli:define-c-typedef ,name-array
     (:c-array ,(convert-from-uffi-type type :array)))
-  #+cmu
+  #+(or cmu scl)
   `(alien:def-alien-type ,name-array 
     (* ,(convert-from-uffi-type type :array)))
   #+sbcl
@@ -78,10 +78,10 @@ of the enum-name name, separator-string, and field-name"
             (type (cadr field))
             (def (append (list field-name)
                          (if (eq type :pointer-self)
-                             #+cmu `((* (alien:struct ,name)))
+                             #+(or cmu scl) `((* (alien:struct ,name)))
                              #+sbcl `((* (sb-alien:struct ,name)))
                              #+mcl `((:* (:struct ,name)))
-                             #-(or cmu sbcl mcl) `((* ,name))
+                             #-(or cmu sbcl scl mcl) `((* ,name))
                              `(,(convert-from-uffi-type type :struct))))))
        (if variant
            (push (list def) processed)
@@ -90,7 +90,7 @@ of the enum-name name, separator-string, and field-name"
        
            
 (defmacro def-struct (name &rest fields)
-  #+cmu
+  #+(or cmu scl)
   `(alien:def-alien-type ,name (alien:struct ,name ,@(process-struct-fields name fields)))
   #+sbcl
   `(sb-alien:define-alien-type ,name (sb-alien:struct ,name ,@(process-struct-fields name fields)))
@@ -108,12 +108,12 @@ of the enum-name name, separator-string, and field-name"
 
 
 (defmacro get-slot-value (obj type slot)
-  #+(or lispworks cmu sbcl) (declare (ignore type))
+  #+(or lispworks cmu sbcl scl) (declare (ignore type))
   #+allegro
   `(ff:fslot-value-typed ,type :c ,obj ,slot)
   #+lispworks
   `(fli:foreign-slot-value ,obj ,slot)
-  #+cmu
+  #+(or cmu scl)
   `(alien:slot ,obj ,slot)
   #+sbcl
   `(sb-alien:slot ,obj ,slot)
@@ -130,12 +130,12 @@ of the enum-name name, separator-string, and field-name"
 
 
 (defmacro get-slot-pointer (obj type slot)
-  #+(or lispworks cmu sbcl) (declare (ignore type))
+  #+(or lispworks cmu sbcl scl) (declare (ignore type))
   #+allegro
   `(ff:fslot-value-typed ,type :c ,obj ,slot)
   #+lispworks
   `(fli:foreign-slot-pointer ,obj ,slot)
-  #+cmu
+  #+(or cmu scl)
   `(alien:slot ,obj ,slot)
   #+sbcl
   `(sb-alien:slot ,obj ,slot)
@@ -159,8 +159,8 @@ of the enum-name name, separator-string, and field-name"
 
 (defmacro deref-array (obj type i)
   "Returns a field from a row"
-  #+(or lispworks cmu sbcl) (declare (ignore type))
-  #+cmu  `(alien:deref ,obj ,i)
+  #+(or lispworks cmu sbcl scl) (declare (ignore type))
+  #+(or cmu scl)  `(alien:deref ,obj ,i)
   #+sbcl  `(sb-alien:deref ,obj ,i)
   #+lispworks `(fli:dereference ,obj :index ,i)
   #+allegro `(ff:fslot-value-typed (quote ,(convert-from-uffi-type type :type)) :c ,obj ,i)
@@ -193,7 +193,7 @@ of the enum-name name, separator-string, and field-name"
   `(ff:def-foreign-type ,name (:union ,@(process-struct-fields name fields)))
   #+lispworks
   `(fli:define-c-union ,name ,@(process-struct-fields name fields))
-  #+cmu
+  #+(or cmu scl)
   `(alien:def-alien-type ,name (alien:union ,name ,@(process-struct-fields name fields)))
   #+sbcl
   `(sb-alien:define-alien-type ,name (sb-alien:union ,name ,@(process-struct-fields name fields)))

diff --git a/src/functions.lisp b/src/functions.lisp
index ad8aca4382a2ff8b7091b9606b63a83bc931789f..f23ec8f6163de4f38f06083c5233ca952105a90b 100644 (file)
--- a/src/functions.lisp
+++ b/src/functions.lisp
@@ -7,7 +7,7 @@
 ;;;; Programmer:    Kevin M. Rosenberg
 ;;;; Date Started:  Feb 2002
 ;;;;
-;;;; $Id: functions.lisp,v 1.4 2002/10/14 03:07:41 kevin Exp $
+;;;; $Id: functions.lisp,v 1.5 2002/10/16 11:56:43 kevin Exp $
 ;;;;
 ;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
 ;;;;
@@ -21,12 +21,12 @@
 
 (defun process-function-args (args)
   (if (null args)
-      #+(or lispworks cmu sbcl cormanlisp (and mcl (not openmcl))) nil
+      #+(or lispworks cmu sbcl scl cormanlisp (and mcl (not openmcl))) nil
       #+allegro '(:void)
       #+mcl (values nil nil)
 
       ;; args not null
-      #+(or lispworks allegro cmu sbcl (and mcl (not openmcl)) cormanlisp)
+      #+(or lispworks allegro cmu sbcl scl (and mcl (not openmcl)) cormanlisp)
       (let (processed)
        (dolist (arg args)
          (push (process-one-function-arg arg) processed))
@@ -49,7 +49,7 @@
 (defun process-one-function-arg (arg)
   (let ((name (car arg))
        (type (convert-from-uffi-type (cadr arg) :routine)))
-    #+(or cmu sbcl)
+    #+(or cmu sbcl scl)
     (list name type :in)
     #+(or allegro lispworks (and mcl (not openmcl)))
     (if (and (listp type) (listp (car type)))
@@ -66,7 +66,7 @@
 ;; name is either a string representing foreign name, or a list
 ;; of foreign-name as a string and lisp name as a symbol
 (defmacro def-function (names args &key module returning)
-  #+(or cmu sbcl allegro mcl cormanlisp) (declare (ignore module))
+  #+(or cmu sbcl scl allegro mcl cormanlisp) (declare (ignore module))
   
   (let* ((result-type (convert-from-uffi-type returning :return))
         (function-args (process-function-args args))
@@ -80,7 +80,7 @@
        :returning ,(allegro-convert-return-type result-type)
        :call-direct t
        :strings-convert nil)
-    #+cmu
+    #+(or cmu scl)
     `(alien:def-alien-routine (,foreign-name ,lisp-name)
         ,result-type
        ,@function-args)

diff --git a/src/libraries.lisp b/src/libraries.lisp
index 65b64b34e434b1d9523377c24d1590cdd56c3b1c..c259dc8d08b69ba206e0c71bd0d25ded426c71a8 100644 (file)
--- a/src/libraries.lisp
+++ b/src/libraries.lisp
@@ -7,7 +7,7 @@
 ;;;; Programmer:    Kevin M. Rosenberg
 ;;;; Date Started:  Feb 2002
 ;;;;
-;;;; $Id: libraries.lisp,v 1.3 2002/10/14 03:07:41 kevin Exp $
+;;;; $Id: libraries.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
 ;;;;
@@ -74,7 +74,7 @@ library type if type is not specified."
 (defun load-foreign-library (filename &key module supporting-libraries
                                           force-load)
   #+(or allegro lispworks openmcl) (declare (ignore module supporting-libraries))
-  #+(or cmu sbcl) (declare (ignore module))
+  #+(or cmu scl sbcl) (declare (ignore module))
   
   (when (and filename (probe-file filename))
     (if (pathnamep filename)    ;; ensure filename is a string to check if
@@ -92,6 +92,12 @@ library type if type is not specified."
                                :libraries
                                (convert-supporting-libraries-to-string
                                 supporting-libraries))))
+       #+scl
+       (let ((type (pathname-type (parse-namestring filename))))
+         (alien:load-foreign filename 
+                             :libraries
+                             (convert-supporting-libraries-to-string
+                              supporting-libraries)))
        #+sbcl
        (sb-alien:load-foreign filename 
                               :libraries

diff --git a/src/objects.lisp b/src/objects.lisp
index 19cb002d94ea50f698bbfa5db24ce9bc9504dab8..c7fa563a2dcc717f15c622b1edfcefcdef900621 100644 (file)
--- a/src/objects.lisp
+++ b/src/objects.lisp
@@ -7,7 +7,7 @@
 ;;;; Programmer:    Kevin M. Rosenberg
 ;;;; Date Started:  Feb 2002
 ;;;;
-;;;; $Id: objects.lisp,v 1.3 2002/10/14 07:08:49 kevin Exp $
+;;;; $Id: objects.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
 ;;;;
@@ -22,7 +22,7 @@
 (defun size-of-foreign-type (type)
   #+lispworks (fli:size-of type)
   #+allegro (ff:sizeof-fobject type)
-  #+cmu  (ash (eval `(alien:alien-size ,type)) -3) ;; convert from bits to bytes
+  #+(or cmu scl)  (ash (eval `(alien:alien-size ,type)) -3) ;; convert from bits to bytes
   #+sbcl  (ash (eval `(sb-alien:alien-size ,type)) -3) ;; convert from bits to bytes
   #+clisp (values (ffi:size-of type))
   #+(and mcl (not openmcl))
@@ -39,7 +39,7 @@
 an array of TYPE with size SIZE. The TYPE parameter is evaluated."
   (if (eq size :unspecified)
       (progn
-       #+cmu
+       #+(or cmu scl)
        `(alien:make-alien ,(convert-from-uffi-type (eval type) :allocation))
        #+sbcl
        `(sb-alien:make-alien ,(convert-from-uffi-type (eval type) :allocation))
@@ -51,7 +51,7 @@ an array of TYPE with size SIZE. The TYPE parameter is evaluated."
        `(new-ptr ,(size-of-foreign-type (convert-from-uffi-type type :allocation)))
        )
       (progn
-       #+cmu
+       #+(or cmu scl)
        `(alien:make-alien ,(convert-from-uffi-type (eval type) :allocation) ,size)
        #+sbcl
        `(sb-alien:make-alien ,(convert-from-uffi-type (eval type) :allocation) ,size)
@@ -64,7 +64,7 @@ an array of TYPE with size SIZE. The TYPE parameter is evaluated."
        )))
 
 (defmacro free-foreign-object (obj)
-  #+cmu
+  #+(or cmu scl)
   `(alien:free-alien ,obj)
   #+sbcl
   `(sb-alien:free-alien ,obj)
@@ -79,14 +79,14 @@ an array of TYPE with size SIZE. The TYPE parameter is evaluated."
 (defmacro null-pointer-p (obj)
   #+lispworks `(fli:null-pointer-p ,obj)
   #+allegro `(zerop ,obj)
-  #+cmu   `(alien:null-alien ,obj)
+  #+(or cmu scl)   `(alien:null-alien ,obj)
   #+sbcl   `(sb-alien:null-alien ,obj)
   #+mcl   `(ccl:%null-ptr-p ,obj)
   )
 
 (defmacro make-null-pointer (type)
   #+(or allegro mcl) (declare (ignore type))
-  #+cmu `(alien:sap-alien (system:int-sap 0) (* ,(convert-from-uffi-type (eval type) :type)))
+  #+(or cmu scl) `(alien:sap-alien (system:int-sap 0) (* ,(convert-from-uffi-type (eval type) :type)))
   #+sbcl `(sb-alien:sap-alien (sb-sys:int-sap 0) (* ,(convert-from-uffi-type (eval type) :type)))
   #+lispworks `(fli:make-pointer :address 0 :type (quote ,(convert-from-uffi-type (eval type) :type)))
   #+allegro 0
@@ -94,7 +94,7 @@ an array of TYPE with size SIZE. The TYPE parameter is evaluated."
   )
 
 (defmacro char-array-to-pointer (obj)
-  #+cmu `(alien:cast ,obj (* (alien:unsigned 8)))
+  #+(or cmu scl) `(alien:cast ,obj (* (alien:unsigned 8)))
   #+sbcl `(sb-alien:cast ,obj (* (sb-alien:unsigned 8)))
   #+lispworks `(fli:make-pointer :type '(:unsigned :char)
                                :address (fli:pointer-address ,obj))
@@ -104,8 +104,8 @@ an array of TYPE with size SIZE. The TYPE parameter is evaluated."
 
 (defmacro deref-pointer (ptr type)
   "Returns a object pointed"
-  #+(or cmu sbcl lispworks) (declare (ignore type))
-  #+cmu  `(alien:deref ,ptr)
+  #+(or cmu sbcl lispworks scl) (declare (ignore type))
+  #+(or cmu scl)  `(alien:deref ,ptr)
   #+sbcl  `(sb-alien:deref ,ptr)
   #+lispworks `(fli:dereference ,ptr)
   #+allegro `(ff:fslot-value-typed ,(convert-from-uffi-type type :deref) :c ,ptr)
@@ -123,7 +123,7 @@ an array of TYPE with size SIZE. The TYPE parameter is evaluated."
 (defmacro ensure-char-character (obj)
   obj)
 
-#+(or allegro cmu sbcl openmcl)
+#+(or allegro cmu sbcl scl openmcl)
 (defmacro ensure-char-character (obj)
   `(code-char ,obj))
   
@@ -131,12 +131,12 @@ an array of TYPE with size SIZE. The TYPE parameter is evaluated."
 (defmacro ensure-char-integer (obj)
  `(char-code ,obj))
 
-#+(or allegro cmu sbcl openmcl)
+#+(or allegro cmu sbcl scl openmcl)
 (defmacro ensure-char-integer (obj)
   obj)
 
 (defmacro pointer-address (obj)
-  #+cmu
+  #+(or cmu scl)
   `(system:sap-int (alien:alien-sap ,obj))
   #+sbcl
   `(sb-sys:sap-int (sb-alien:alien-sap ,obj))
@@ -151,12 +151,12 @@ an array of TYPE with size SIZE. The TYPE parameter is evaluated."
 ;; TYPE is evaluated.
 #-mcl
 (defmacro with-foreign-object ((var type) &rest body)
-  #-(or cmu sbcl lispworks) ; default version
+  #-(or cmu sbcl lispworks scl) ; default version
   `(let ((,var (allocate-foreign-object ,type)))
     (unwind-protect
         (progn ,@body)
       (free-foreign-object ,var)))
-  #+cmu
+  #+(or cmu scl)
   (let ((obj (gensym)))
     `(alien:with-alien ((,obj ,(convert-from-uffi-type (eval type) :allocate)))
        (let ((,var (alien:addr ,obj)))

diff --git a/src/primitives.lisp b/src/primitives.lisp
index 1b210fd86e553eaf4073128fa0f1980de868a2ae..dc91044d8cead83512ae03def4157a43fa98f23c 100644 (file)
--- a/src/primitives.lisp
+++ b/src/primitives.lisp
@@ -7,7 +7,7 @@
 ;;;; Programmer:    Kevin M. Rosenberg
 ;;;; Date Started:  Feb 2002
 ;;;;
-;;;; $Id: primitives.lisp,v 1.4 2002/10/14 04:15:02 kevin Exp $
+;;;; $Id: primitives.lisp,v 1.5 2002/10/16 11:56:43 kevin Exp $
 ;;;;
 ;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
 ;;;;
@@ -56,7 +56,7 @@
 supports takes advantage of this optimization."
   #+(or lispworks allegro mcl cormanlisp)  (declare (ignore type))
   #+(or lispworks allegro mcl cormanlisp) `(deftype ,name () t)
-  #+cmu
+  #+(or cmu scl)
   `(deftype ,name () '(alien:alien ,(convert-from-uffi-type type :declare)))
   #+sbcl
   `(deftype ,name () '(sb-alien:alien ,(convert-from-uffi-type type :declare)))
@@ -69,7 +69,7 @@ supports takes advantage of this optimization."
 (defmacro def-foreign-type (name type)
   #+lispworks `(fli:define-c-typedef ,name ,(convert-from-uffi-type type :type))
   #+allegro `(ff:def-foreign-type ,name ,(convert-from-uffi-type type :type))
-  #+cmu `(alien:def-alien-type ,name ,(convert-from-uffi-type type :type))
+  #+(or cmu scl) `(alien:def-alien-type ,name ,(convert-from-uffi-type type :type))
   #+sbcl `(sb-alien:define-alien-type ,name ,(convert-from-uffi-type type :type))
   #+cormanlisp `(ct:defctype ,name ,(convert-from-uffi-type type :type))
   #+mcl
@@ -84,13 +84,13 @@ supports takes advantage of this optimization."
 
 (eval-when (:compile-toplevel :load-toplevel :execute)
   (defvar +type-conversion-hash+ (make-hash-table :size 20))
-  #+(or cmu sbcl) (defvar *cmu-def-type-hash* (make-hash-table :size 20))
+  #+(or cmu sbcl scl) (defvar *cmu-def-type-hash* (make-hash-table :size 20))
   )
 
-#+(or cmu sbcl)
+#+(or cmu sbcl scl)
 (defparameter *cmu-sbcl-def-type-list* nil)
 
-#+cmu
+#+(or cmu scl)
 (defparameter *cmu-sbcl-def-type-list*
     '((:char . (alien:signed 8))
       (:unsigned-char . (alien:unsigned 8))
@@ -125,7 +125,7 @@ supports takes advantage of this optimization."
 
 (defparameter *type-conversion-list* nil)
 
-#+cmu
+#+(or cmu scl)
 (setq *type-conversion-list*
     '((* . *) (:void . c-call:void) 
       (:short . c-call:short)
@@ -223,7 +223,7 @@ supports takes advantage of this optimization."
 (dolist (type *type-conversion-list*)
   (setf (gethash (car type) +type-conversion-hash+) (cdr type)))
 
-#+(or cmu sbcl)
+#+(or cmu sbcl scl)
 (dolist (type *cmu-sbcl-def-type-list*)
   (setf (gethash (car type) *cmu-def-type-hash*) (cdr type)))
 
@@ -242,7 +242,7 @@ supports takes advantage of this optimization."
        ((and (or (eq context :routine) (eq context :return))
             (eq type :cstring))
        (setq type '((* :char) integer)))
-       #+(or cmu sbcl)
+       #+(or cmu sbcl scl)
        ((eq context :type)
        (let ((cmu-type (gethash type *cmu-def-type-hash*)))
          (if cmu-type

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))

diff --git a/tests/c-test-fns.lisp b/tests/c-test-fns.lisp
index c21b39c6e5717bcfca31da2a9ce52062fcb13b3b..435fdd69645db951457e3b99d5ac934f24400e23 100644 (file)
--- a/tests/c-test-fns.lisp
+++ b/tests/c-test-fns.lisp
@@ -7,7 +7,7 @@
 ;;;; Programmer:    Kevin M. Rosenberg
 ;;;; Date Started:  Mar 2002
 ;;;;
-;;;; $Id: c-test-fns.lisp,v 1.1 2002/09/30 10:02:36 kevin Exp $
+;;;; $Id: c-test-fns.lisp,v 1.2 2002/10/16 11:56:43 kevin Exp $
 ;;;;
 ;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
 ;;;;
@@ -68,7 +68,7 @@
     (half-double-vector +double-vec-length+ vec)
     vec))
 
-#+cmu
+#+(or cmu scl)
 (defun t3 ()
   (let ((vec (make-array +double-vec-length+ :element-type 'double-float)))
     (dotimes (i +double-vec-length+)

diff --git a/uffi.asd b/uffi.asd
index 1076b827897557e0e86de44f6ec1d6e8d156f8dc..c31fafb882cf34d40ccb12e1d18d6edf51a4ee57 100644 (file)
--- a/uffi.asd
+++ b/uffi.asd
@@ -7,7 +7,7 @@
 ;;;; Programmer:    Kevin M. Rosenberg
 ;;;; Date Started:  Aug 2002
 ;;;;
-;;;; $Id: uffi.asd,v 1.19 2002/10/14 03:07:41 kevin Exp $
+;;;; $Id: uffi.asd,v 1.20 2002/10/16 11:56:43 kevin Exp $
 ;;;;
 ;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
 ;;;;
@@ -19,7 +19,7 @@
 (declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0)))
 (in-package :asdf)
 
-#+(or allegro lispworks cmu mcl cormanlisp sbcl)
+#+(or allegro lispworks cmu mcl cormanlisp sbcl scl)
 (defsystem uffi
   :name "cl-uffi"
   :author "Kevin M. Rosenberg <kmr@debian.org>"
@@ -50,7 +50,7 @@
              ((:file "uffi-corman")))
      ))
 
-#+(or allegro lispworks cmu mcl cormanlisp sbcl)
+#+(or allegro lispworks cmu mcl cormanlisp sbcl scl)
 (when (ignore-errors (find-class 'load-compiled-op))
   (defmethod perform :after ((op load-compiled-op) (c (eql (find-system :uffi))))
     (pushnew :uffi cl:*features*)))