X-Git-Url: http://git.kpe.io/?a=blobdiff_plain;f=src%2Fstrings.lisp;h=2712a7355ce3ec389880367aa26d6910119f3759;hb=3dc00d0c4f7d59f610746a053f72fbe9d1a80fab;hp=5d8094e35c799f47ed2be54099bb7e17e215b789;hpb=c6c305a69913c148753813cc057be7127017ae6a;p=uffi.git diff --git a/src/strings.lisp b/src/strings.lisp index 5d8094e..2712a73 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.2 2002/10/14 01:51:15 kevin Exp $ +;;;; $Id: strings.lisp,v 1.5 2002/12/13 22:49:09 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))) @@ -103,13 +97,13 @@ that LW/CMU automatically converts strings from c-calls." (defmacro convert-to-foreign-string (obj) #+lispworks `(if (null ,obj) - +null-cstring-pointer+ - (fli:convert-to-foreign-string ,obj)) + +null-cstring-pointer+ + (fli:convert-to-foreign-string ,obj :external-format '(:latin-1 :eol-style :lf))) #+allegro `(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) @@ -206,7 +200,7 @@ that LW/CMU automatically converts strings from c-calls." #+sbcl (let ((array-def (gensym))) `(let ((,array-def (list 'sb-alien:array 'char ,size))) - (eval `(alien:cast (sb-alien:make-alien ,,array-def) + (eval `(sb-alien:cast (sb-alien:make-alien ,,array-def) ,(if ,unsigned '(* (sb-alien:unsigned 8)) '(* (sb-alien:signed 8))))))) @@ -237,9 +231,7 @@ that LW/CMU automatically converts strings from c-calls." ;; Modified from CMUCL's source to handle non-null terminated strings #+cmu -(defun cmucl-naturalize-cstring (sap &key - length - (null-terminated-p t)) +(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))) @@ -261,10 +253,32 @@ 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)) +(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))) @@ -272,7 +286,7 @@ that LW/CMU automatically converts strings from c-calls." (when null-terminated-p (loop for offset of-type fixnum upfrom 0 - until (zerop (system:sap-ref-8 sap offset)) + until (zerop (sb-sys:sap-ref-8 sap offset)) finally (return offset))))) (if length (if (and null-terminated-length @@ -282,6 +296,6 @@ that LW/CMU automatically converts strings from c-calls." (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)) + sb-vm:n-word-bits) + (* length sb-vm:n-byte-bits)) result)))