From: Kevin M. Rosenberg 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)))