From: Kevin M. Rosenberg <kevin@rosenberg.net>
Date: Mon, 14 Oct 2002 01:51:15 +0000 (+0000)
Subject: r2997: *** empty log message ***
X-Git-Tag: v1.6.1~279
X-Git-Url: http://git.kpe.io/?a=commitdiff_plain;h=c6c305a69913c148753813cc057be7127017ae6a;p=uffi.git

r2997: *** empty log message ***
---

diff --git a/src/aggregates.lisp b/src/aggregates.lisp
index a1d8a67..bb183cf 100644
--- 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.1 2002/09/30 10:02:36 kevin Exp $
+;;;; $Id: aggregates.lisp,v 1.2 2002/10/14 01:51:15 kevin Exp $
 ;;;;
 ;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
 ;;;;
@@ -45,6 +45,7 @@ of the enum-name name, separator-string, and field-name"
 		       #+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))
+		       #+sbcl `((sb-alien:def-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))
 		       (nreverse constants)))
@@ -61,6 +62,9 @@ of the enum-name name, separator-string, and field-name"
   #+cmu
   `(alien:def-alien-type ,name-array 
     (* ,(convert-from-uffi-type type :array)))
+  #+sbcl
+  `(sb-alien:def-alien-type ,name-array 
+    (* ,(convert-from-uffi-type type :array)))
   #+(and mcl (not openmcl))
   `(def-mcl-type ,name-array '(:array ,type))
   #+openmcl
@@ -75,8 +79,9 @@ of the enum-name name, separator-string, and field-name"
 	     (def (append (list field-name)
 			  (if (eq type :pointer-self)
 			      #+cmu `((* (alien:struct ,name)))
+			      #+sbcl `((* (sb-alien:struct ,name)))
 			      #+mcl `((:* (:struct ,name)))
-			      #-(or cmu mcl) `((* ,name))
+			      #-(or cmu sbcl mcl) `((* ,name))
 			      `(,(convert-from-uffi-type type :struct))))))
 	(if variant
 	    (push (list def) processed)
@@ -87,6 +92,8 @@ of the enum-name name, separator-string, and field-name"
 (defmacro def-struct (name &rest fields)
   #+cmu
   `(alien:def-alien-type ,name (alien:struct ,name ,@(process-struct-fields name fields)))
+  #+sbcl
+  `(sb-alien:def-alien-type ,name (sb-alien:struct ,name ,@(process-struct-fields name fields)))
   #+allegro
   `(ff:def-foreign-type ,name (:struct ,@(process-struct-fields name fields)))
   #+lispworks
@@ -101,13 +108,15 @@ of the enum-name name, separator-string, and field-name"
 
 
 (defmacro get-slot-value (obj type slot)
-  #+(or lispworks cmu) (declare (ignore type))
+  #+(or lispworks cmu sbcl) (declare (ignore type))
   #+allegro
   `(ff:fslot-value-typed ,type :c ,obj ,slot)
   #+lispworks
   `(fli:foreign-slot-value ,obj ,slot)
   #+cmu
   `(alien:slot ,obj ,slot)
+  #+sbcl
+  `(sb-alien:slot ,obj ,slot)
   #+mcl
   `(ccl:pref ,obj ,(read-from-string (format nil ":~a.~a" (keyword type) (keyword slot))))
   )
@@ -121,13 +130,15 @@ of the enum-name name, separator-string, and field-name"
 
 
 (defmacro get-slot-pointer (obj type slot)
-  #+(or lispworks cmu) (declare (ignore type))
+  #+(or lispworks cmu sbcl) (declare (ignore type))
   #+allegro
   `(ff:fslot-value-typed ,type :c ,obj ,slot)
   #+lispworks
   `(fli:foreign-slot-pointer ,obj ,slot)
   #+cmu
   `(alien:slot ,obj ,slot)
+  #+sbcl
+  `(sb-alien:slot ,obj ,slot)
   #+(and mcl (not openmcl))
   `(ccl:%int-to-ptr (+ (ccl:%ptr-to-int ,obj) (the fixnum (ccl:field-info ,type ,slot))))
   #+openmcl
@@ -148,8 +159,9 @@ 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) (declare (ignore type))
+  #+(or lispworks cmu sbcl) (declare (ignore type))
   #+cmu  `(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)
   #+mcl
@@ -183,6 +195,8 @@ of the enum-name name, separator-string, and field-name"
   `(fli:define-c-union ,name ,@(process-struct-fields name fields))
   #+cmu
   `(alien:def-alien-type ,name (alien:union ,name ,@(process-struct-fields name fields)))
+  #+sbcl
+  `(sb-alien:def-alien-type ,name (sb-alien:union ,name ,@(process-struct-fields name fields)))
   #+(and mcl (not openmcl))
   `(ccl:defrecord ,name (:variant ,@(process-struct-fields name fields t)))
   #+openmcl
diff --git a/src/functions.lisp b/src/functions.lisp
index 927365d..5210f0a 100644
--- 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.2 2002/10/01 17:05:29 kevin Exp $
+;;;; $Id: functions.lisp,v 1.3 2002/10/14 01:51:15 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 cormanlisp (and mcl (not openmcl))) nil
+      #+(or lispworks cmu sbcl cormanlisp (and mcl (not openmcl))) nil
       #+allegro '(:void)
       #+mcl (values nil nil)
 
       ;; args not null
-      #+(or lispworks allegro cmu (and mcl (not openmcl)) cormanlisp)
+      #+(or lispworks allegro cmu sbcl (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)))
-    #+cmu
+    #+(or cmu sbcl)
     (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 allegro mcl cormanlisp) (declare (ignore module))
+  #+(or cmu sbcl allegro mcl cormanlisp) (declare (ignore module))
   
   (let* ((result-type (convert-from-uffi-type returning :return))
 	 (function-args (process-function-args args))
@@ -84,6 +84,10 @@
     `(alien:def-alien-routine (,foreign-name ,lisp-name)
 	 ,result-type
        ,@function-args)
+    #+sbcl
+    `(sb-alien:def-alien-routine (,foreign-name ,lisp-name)
+	 ,result-type
+       ,@function-args)
     #+lispworks
     `(fli:define-foreign-function (,lisp-name ,foreign-name :source)
 	 ,function-args
diff --git a/src/libraries.lisp b/src/libraries.lisp
index 72dbc09..eec9045 100644
--- 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.1 2002/09/30 10:02:36 kevin Exp $
+;;;; $Id: libraries.lisp,v 1.2 2002/10/14 01:51:15 kevin Exp $
 ;;;;
 ;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
 ;;;;
@@ -73,10 +73,8 @@ library type if type is not specified."
 
 (defun load-foreign-library (filename &key module supporting-libraries
 					   force-load)
-  #+allegro (declare (ignore module supporting-libraries))
-  #+lispworks  (declare (ignore supporting-libraries))
-  #+cmu (declare (ignore module))
-  #+openmcl (declare (ignore module supporting-libraries))
+  #+(or allegro lispworks openmcl) (declare (ignore module supporting-libraries))
+  #+(or cmu sbcl) (declare (ignore module))
   
   (when (and filename (probe-file filename))
     (if (pathnamep filename)    ;; ensure filename is a string to check if
@@ -95,6 +93,11 @@ library type if type is not specified."
 				  :libraries
 				  (convert-supporting-libraries-to-string
 				   supporting-libraries))))
+	  #+sbcl
+	  (sb-alien:load-foreign filename 
+				 :libraries
+				 (convert-supporting-libraries-to-string
+				  supporting-libraries))
 	  #+lispworks (fli:register-module module :real-name filename)
 	  #+allegro (load filename)
 	  #+openmcl (ccl:open-shared-library filename)
diff --git a/src/objects-mcl.lisp b/src/objects-mcl.lisp
deleted file mode 100644
index 6e12650..0000000
--- a/src/objects-mcl.lisp
+++ /dev/null
@@ -1,42 +0,0 @@
-;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: UFFI -*-
-;;;; *************************************************************************
-;;;; FILE IDENTIFICATION
-;;;;
-;;;; Name:          readmacros-mcl.cl
-;;;; Purpose:       UFFI source to handle objects and pointers
-;;;; Programmer:    Kevin M. Rosenberg
-;;;; Date Started:  Feb 2002
-;;;;
-;;;; $Id: objects-mcl.lisp,v 1.1 2002/09/30 10:02:36 kevin Exp $
-;;;;
-;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
-;;;;
-;;;; UFFI users are granted the rights to distribute and use this software
-;;;; as governed by the terms of the Lisp Lesser GNU Public License
-;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
-;;;; *************************************************************************
-
-(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0)))
-(in-package :uffi)
-
-;; trap macros don't work right directly in the macros
-(eval-when (:compile-toplevel :load-toplevel :execute)
-
-  #+(and mcl (not openmcl))
-  (defun new-ptr (size)
-    (#_NewPtr size))
-	 
-  #+(and mcl (not openmcl))
-  (defun dispose-ptr (ptr)
-    (#_DisposePtr ptr))
-  
-  #+openmcl
-  (defmacro new-ptr (size)
-    `(ccl::malloc ,size))
-	 
-  #+openmcl
-  (defmacro dispose-ptr (ptr)
-    `(ccl::free ,ptr))
-  )
-  
-  
diff --git a/src/objects.lisp b/src/objects.lisp
index 5a9d21a..7826f56 100644
--- 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.1 2002/09/30 10:02:36 kevin Exp $
+;;;; $Id: objects.lisp,v 1.2 2002/10/14 01:51:15 kevin Exp $
 ;;;;
 ;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
 ;;;;
@@ -23,6 +23,7 @@
   #+lispworks (fli:size-of type)
   #+allegro (ff:sizeof-fobject type)
   #+cmu  (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))
   (let ((mcl-type (ccl:find-mactype type nil t)))
@@ -40,6 +41,8 @@ an array of TYPE with size SIZE. The TYPE parameter is evaluated."
       (progn
 	#+cmu
 	`(alien:make-alien ,(convert-from-uffi-type (eval type) :allocation))
+	#+sbcl
+	`(sb-alien:make-alien ,(convert-from-uffi-type (eval type) :allocation))
 	#+lispworks
 	`(fli:allocate-foreign-object :type ',(convert-from-uffi-type type :allocate))
 	#+allegro
@@ -50,6 +53,8 @@ an array of TYPE with size SIZE. The TYPE parameter is evaluated."
       (progn
 	#+cmu
 	`(alien:make-alien ,(convert-from-uffi-type (eval type) :allocation) ,size)
+	#+sbcl
+	`(sb-alien:make-alien ,(convert-from-uffi-type (eval type) :allocation) ,size)
 	#+lispworks
 	`(fli:allocate-foreign-object :type ',(convert-from-uffi-type type :allocate) :nelems ,size)
 	#+allegro
@@ -61,6 +66,8 @@ an array of TYPE with size SIZE. The TYPE parameter is evaluated."
 (defmacro free-foreign-object (obj)
   #+cmu
   `(alien:free-alien ,obj)
+  #+sbcl
+  `(sb-alien:free-alien ,obj)
   #+lispworks
   `(fli:free-foreign-object ,obj)
   #+allegro
@@ -73,13 +80,14 @@ an array of TYPE with size SIZE. The TYPE parameter is evaluated."
   #+lispworks `(fli:null-pointer-p ,obj)
   #+allegro `(zerop ,obj)
   #+cmu   `(alien:null-alien ,obj)
+  #+sbcl   `(sb-alien:null-alien ,obj)
   #+mcl   `(ccl:%null-ptr-p ,obj)
   )
 
 (defmacro make-null-pointer (type)
-  #+(or allegro cmu mcl) (declare (ignore type))
-  
+  #+(or allegro cmu sbcl mcl) (declare (ignore type))
   #+cmu `(system:int-sap 0)
+  #+sbcl `(sb-sys:int-sap 0)
   #+allegro 0
   #+lispworks `(fli:make-pointer :address 0 :type ,type)
   #+mcl `(ccl:%null-ptr)
@@ -87,6 +95,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)))
+  #+sbcl `(sb-alien:cast ,obj (* (sb-alien:unsigned 8)))
   #+lispworks `(fli:make-pointer :type '(:unsigned :char)
 				:address (fli:pointer-address ,obj))
   #+allegro obj
@@ -95,8 +104,9 @@ an array of TYPE with size SIZE. The TYPE parameter is evaluated."
 
 (defmacro deref-pointer (ptr type)
   "Returns a object pointed"
-  #+(or cmu lispworks) (declare (ignore type))
+  #+(or cmu sbcl lispworks) (declare (ignore type))
   #+cmu  `(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)
   #+mcl `(ccl:pref ,ptr ,(convert-from-uffi-type type :deref))
@@ -113,7 +123,7 @@ an array of TYPE with size SIZE. The TYPE parameter is evaluated."
 (defmacro ensure-char-character (obj)
   obj)
 
-#+(or allegro cmu openmcl)
+#+(or allegro cmu sbcl openmcl)
 (defmacro ensure-char-character (obj)
   `(code-char ,obj))
   
@@ -121,13 +131,15 @@ an array of TYPE with size SIZE. The TYPE parameter is evaluated."
 (defmacro ensure-char-integer (obj)
  `(char-code ,obj))
 
-#+(or allegro cmu openmcl)
+#+(or allegro cmu sbcl openmcl)
 (defmacro ensure-char-integer (obj)
   obj)
 
 (defmacro pointer-address (obj)
   #+cmu
   `(system:sap-int (alien:alien-sap ,obj))
+  #+sbcl
+  `(sb-sys:sap-int (sb-alien:alien-sap ,obj))
   #+lispworks
   `(fli:pointer-address ,obj)
   #+allegro
@@ -139,7 +151,7 @@ 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 lispworks) ; default version
+  #-(or cmu sbcl lispworks) ; default version
   `(let ((,var (allocate-foreign-object ,type)))
     (unwind-protect
 	 (progn ,@body)
@@ -149,6 +161,11 @@ an array of TYPE with size SIZE. The TYPE parameter is evaluated."
     `(alien:with-alien ((,obj ,(convert-from-uffi-type (eval type) :allocate)))
        (let ((,var (alien:addr ,obj)))
 	 ,@body)))
+  #+sbcl
+  (let ((obj (gensym)))
+    `(sb-alien:with-alien ((,obj ,(convert-from-uffi-type (eval type) :allocate)))
+       (let ((,var (sb-alien:addr ,obj)))
+	 ,@body)))
   #+lispworks
   `(fli:with-dynamic-foreign-objects ((,var ,(convert-from-uffi-type
 					      (eval type) :allocate)))
diff --git a/src/os.lisp b/src/os.lisp
new file mode 100644
index 0000000..f9cc31f
--- /dev/null
+++ b/src/os.lisp
@@ -0,0 +1,68 @@
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: UFFI -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name:          os.cl
+;;;; Purpose:       Operating system interface for UFFI
+;;;; Programmer:    Kevin M. Rosenberg
+;;;; Date Started:  Sep 2002 
+;;;;
+;;;; $Id: os.lisp,v 1.1 2002/10/14 01:51:15 kevin Exp $
+;;;;
+;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg.
+;;;; Much of this code was taken from other open source project and copyright
+;;;; for that code is noted below where appropriate.
+;;;;
+;;;; UFFI users are granted the rights to distribute and use this software
+;;;; as governed by the terms of the Lisp Lesser GNU Public License
+;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
+;;;; *************************************************************************
+
+(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0)))
+(in-package :uffi)
+
+
+;; Take from ASDF -- Copyright Dan Barlow and Contributors
+
+(defun run-shell-command (control-string &rest args)
+  "Interpolate ARGS into CONTROL-STRING as if by FORMAT, and
+synchronously execute the result using a Bourne-compatible shell, with
+output to *trace-output*.  Returns the shell's exit code."
+  (let ((command (apply #'format nil control-string args)))
+    (format *trace-output* "; $ ~A~%" command)
+    #+sbcl
+    (sb-impl::process-exit-code
+     (sb-ext:run-program  
+      "/bin/sh"
+      (list  "-c" command)
+      :input nil :output *trace-output*))
+    
+    #+(or cmu scl)
+    (ext:process-exit-code
+     (ext:run-program  
+      "/bin/sh"
+      (list  "-c" command)
+      :input nil :output *trace-output*))
+
+    #+allegro
+    (excl:run-shell-command command :input nil :output *trace-output*)
+    
+    #+lispworks
+    (system:call-system-showing-output
+     command
+     :shell-type "/bin/sh"
+     :output-stream *trace-output*)
+    
+    #+clisp				;XXX not exactly *trace-output*, I know
+    (ext:run-shell-command  command :output :terminal :wait t)
+
+    #+openmcl
+    (nth-value 1
+	       (ccl:external-process-status
+		(ccl:run-program "/bin/sh" (list "-c" command)
+				 :input nil :output *trace-output*
+				 :wait t)))
+
+    #-(or openmcl clisp lispworks allegro scl cmu sbcl)
+    (error "RUN-SHELL-PROGRAM not implemented for this Lisp")
+    ))
diff --git a/src/package.lisp b/src/package.lisp
index abacbc8..dbd851b 100644
--- a/src/package.lisp
+++ b/src/package.lisp
@@ -69,4 +69,7 @@
    #:find-foreign-library
    #:load-foreign-library
    #:default-foreign-library-type
+
+   ;; OS
+   #:run-shell-command
    ))
diff --git a/src/primitives.lisp b/src/primitives.lisp
index 6147753..0133de3 100644
--- 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.2 2002/10/01 17:05:29 kevin Exp $
+;;;; $Id: primitives.lisp,v 1.3 2002/10/14 01:51:15 kevin Exp $
 ;;;;
 ;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
 ;;;;
@@ -84,11 +84,14 @@ 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) (defvar *cmu-def-type-hash* (make-hash-table :size 20))
   )
 
+#+(or cmu sbcl)
+(defparameter *cmu-sbcl-def-type-list* nil)
+
 #+cmu
-(defconstant +cmu-def-type-list+
+(defparameter *cmu-sbcl-def-type-list*
     '((:char . (alien:signed 8))
       (:unsigned-char . (alien:unsigned 8))
       (:byte . (alien:signed 8))
@@ -104,7 +107,7 @@ supports takes advantage of this optimization."
       )
   "Conversions in CMUCL for def-foreign-type are different than in def-function")
 #+sbcl
-(defconstant +cmu-def-type-list+
+(defparameter *cmu-sbcl-def-type-list*
     '((:char . (sb-alien:signed 8))
       (:unsigned-char . (sb-alien:unsigned 8))
       (:byte . (sb-alien:signed 8))
@@ -120,10 +123,10 @@ supports takes advantage of this optimization."
       )
   "Conversions in SBCL for def-foreign-type are different than in def-function")
 
-(defparameter +type-conversion-list+ nil)
+(defparameter *type-conversion-list* nil)
 
 #+cmu
-(setq +type-conversion-list+
+(setq *type-conversion-list*
     '((* . *) (:void . c-call:void) 
       (:short . c-call:short)
       (:pointer-void . (* t))
@@ -140,24 +143,24 @@ supports takes advantage of this optimization."
       (:array . alien:array)))
 
 #+sbcl
-(setq +type-conversion-list+
-    '((* . *) (:void . void) 
-      (:short . short)
+(setq *type-conversion-list*
+    '((* . *) (:void . sb-alien:void) 
+      (:short . sb-alien:short)
       (:pointer-void . (* t))
-      (:cstring . c-string)
-      (:char . char) 
+      (:cstring . sb-alien:c-string)
+      (:char . sb-alien:char) 
       (:unsigned-char . (sb-alien:unsigned 8))
       (:byte . (sb-alien:signed 8))
       (:unsigned-byte . (sb-alien:unsigned 8))
-      (:short . unsigned-short) 
-      (:unsigned-short . unsigned-short)
-      (:int . integer) (:unsigned-int . unsigned-int) 
-      (:long . long) (:unsigned-long . unsigned-long)
-      (:float . float) (:double . double)
-      (:array . array)))
+      (:short . sb-alien:unsigned-short) 
+      (:unsigned-short . sb-alien:unsigned-short)
+      (:int . sb-alien:integer) (:unsigned-int . sb-alien:unsigned-int) 
+      (:long . sb-alien:long) (:unsigned-long . sb-alien:unsigned-long)
+      (:float . sb-alien:float) (:double . sb-alien:double)
+      (:array . sb-alien:array)))
 
 #+(or allegro cormanlisp)
-(setq +type-conversion-list+
+(setq *type-conversion-list*
     '((* . *) (:void . :void)
       (:short . :short)
       (:pointer-void . (* :void))
@@ -172,7 +175,7 @@ supports takes advantage of this optimization."
       (:array . :array)))
 
 #+lispworks
-(setq +type-conversion-list+
+(setq *type-conversion-list*
     '((* . :pointer) (:void . :void) 
       (:short . :short)
       (:pointer-void . (:pointer :void))
@@ -189,7 +192,7 @@ supports takes advantage of this optimization."
       (:array . :c-array)))
 
 #+(and mcl (not openmcl))
-(setq +type-conversion-list+
+(setq *type-conversion-list*
      '((* . :pointer) (:void . :void)
        (:short . :short) (:unsigned-short . :unsigned-short)
        (:pointer-void . :pointer)
@@ -203,7 +206,7 @@ supports takes advantage of this optimization."
        (:array . :array)))
 
 #+openmcl
-(setq +type-conversion-list+
+(setq *type-conversion-list*
      '((* . :address) (:void . :void)
        (:short . :short) (:unsigned-short . :unsigned-short)
        (:pointer-void . :address)
@@ -217,12 +220,12 @@ supports takes advantage of this optimization."
        (:float . :single-float) (:double . :double-float)
        (:array . :array)))
 
-(dolist (type +type-conversion-list+)
+(dolist (type *type-conversion-list*)
   (setf (gethash (car type) +type-conversion-hash+) (cdr type)))
 
 #+(or cmu sbcl)
-(dolist (type +cmu-def-type-list+)
-  (setf (gethash (car type) +cmu-def-type-hash+) (cdr type)))
+(dolist (type *cmu-sbcl-def-type-list*)
+  (setf (gethash (car type) *cmu-def-type-hash*) (cdr type)))
 
 (defun basic-convert-from-uffi-type (type)
   (let ((found-type (gethash type +type-conversion-hash+)))
@@ -241,7 +244,7 @@ supports takes advantage of this optimization."
 	(setq type '((* :char) integer)))
        #+(or cmu sbcl)
        ((eq context :type)
-	(let ((cmu-type (gethash type +cmu-def-type-hash+)))
+	(let ((cmu-type (gethash type *cmu-def-type-hash*)))
 	  (if cmu-type
 	      cmu-type
 	      (basic-convert-from-uffi-type type))))
diff --git a/src/strings.lisp b/src/strings.lisp
index c2aa4b7..5d8094e 100644
--- 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.1 2002/09/30 10:02:36 kevin Exp $
+;;;; $Id: strings.lisp,v 1.2 2002/10/14 01:51:15 kevin Exp $
 ;;;;
 ;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
 ;;;;
@@ -22,6 +22,7 @@
 
 (defvar +null-cstring-pointer+
     #+cmu nil
+    #+sbcl nil
     #+allegro 0
     #+lispworks (fli:make-pointer :address 0 :type '(:unsigned :char))
     #+mcl (ccl:%null-ptr)
@@ -32,6 +33,7 @@
   "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
   #+allegro 
   (let ((stored (gensym)))
@@ -49,6 +51,7 @@ that LW/CMU automatically converts strings from c-calls."
 
 (defmacro convert-to-cstring (obj)
   #+cmu obj
+  #+sbcl obj
   #+lispworks obj
   #+allegro
   `(if (null ,obj)
@@ -63,8 +66,7 @@ that LW/CMU automatically converts strings from c-calls."
   )
 
 (defmacro free-cstring (obj)
-  #+cmu (declare (ignore obj))
-  #+lispworks (declare (ignore obj))
+  #+(or cmu sbcl lispworks) (declare (ignore obj))
   #+allegro
   `(unless (zerop obj)
      (ff:free-fobject ,obj))
@@ -74,9 +76,7 @@ that LW/CMU automatically converts strings from c-calls."
   )
 
 (defmacro with-cstring ((cstring lisp-string) &body body)
-  #+cmu
-  `(let ((,cstring ,lisp-string)) ,@body) 
-  #+lispworks
+  #+(or cmu sbcl lispworks)
   `(let ((,cstring ,lisp-string)) ,@body) 
   #+allegro
   (let ((acl-native (gensym)))
@@ -127,6 +127,24 @@ that LW/CMU automatically converts strings from c-calls."
 	     (setf (alien:deref ,storage ,i) (char-code (char ,obj ,i))))
 	   (setf (alien:deref ,storage ,size) 0))
 	 ,storage))))
+  #+sbcl
+  (let ((size (gensym))
+	(storage (gensym))
+	(i (gensym)))
+    `(etypecase ,obj
+      (null 
+       (sb-alien:sap-alien (sb-sys:int-sap 0) (* (sb-alien:unsigned 8))))
+      (string
+       (let* ((,size (length ,obj))
+	      (,storage (sb-alien:make-alien (sb-alien:unsigned 8) (1+ ,size))))
+	 (setq ,storage (sb-alien:cast ,storage (* (sb-alien:unsigned 8))))
+	 (locally
+	     (declare (optimize (speed 3) (safety 0)))
+	   (dotimes (,i ,size)
+	     (declare (fixnum ,i))
+	     (setf (sb-alien:deref ,storage ,i) (char-code (char ,obj ,i))))
+	   (setf (sb-alien:deref ,storage ,size) 0))
+	 ,storage))))
   #+mcl
   `(if (null ,obj)
        +null-cstring-pointer+
@@ -161,6 +179,12 @@ that LW/CMU automatically converts strings from c-calls."
     (cmucl-naturalize-cstring (alien:alien-sap ,obj)
      :length ,length
      :null-terminated-p ,null-terminated-p))
+  #+sbcl
+  `(if (null-pointer-p ,obj)
+    nil
+    (sbcl-naturalize-cstring (sb-alien:alien-sap ,obj)
+     :length ,length
+     :null-terminated-p ,null-terminated-p))
   #+mcl
   (declare (ignore null-terminated-p))
   #+mcl
@@ -179,6 +203,13 @@ that LW/CMU automatically converts strings from c-calls."
 			  ,(if ,unsigned 
 			       '(* (alien:unsigned 8))
 			     '(* (alien:signed 8)))))))
+  #+sbcl
+  (let ((array-def (gensym)))
+    `(let ((,array-def (list 'sb-alien:array 'char ,size)))
+       (eval `(alien:cast (sb-alien:make-alien ,,array-def) 
+			  ,(if ,unsigned 
+			       '(* (sb-alien:unsigned 8))
+			     '(* (sb-alien:signed 8)))))))
   #+lispworks
   `(fli:allocate-foreign-object :type 
 				,(if unsigned 
@@ -229,3 +260,28 @@ that LW/CMU automatically converts strings from c-calls."
 					      vm:word-bits)
 				    (* length vm:byte-bits))
       result)))
+
+#+sbcl
+(defun sbcl-naturalize-cstring (sap &key 
+					   length
+					   (null-terminated-p t))
+  (declare (type sb-sys: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)))
+      (sb-kernel:copy-from-system-area sap 0
+				    result (* sb-vm:vector-data-offset
+					      sb-vm:word-bits)
+				    (* length sb-vm:byte-bits))
+      result)))