X-Git-Url: http://git.kpe.io/?a=blobdiff_plain;f=src%2Fstrings.lisp;h=2712a7355ce3ec389880367aa26d6910119f3759;hb=02b663aaba3227e4541572337b3d4105a30c1768;hp=c2aa4b7cc7347dce3df6f1e08347a528bac958a9;hpb=a95b9a217335917d96b8c0cced4f49c3e4846115;p=uffi.git diff --git a/src/strings.lisp b/src/strings.lisp index c2aa4b7..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.1 2002/09/30 10:02:36 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,18 +21,16 @@ (defvar +null-cstring-pointer+ - #+cmu 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 - #+lispworks obj + #+(or cmu sbcl lispworks scl) obj #+allegro (let ((stored (gensym))) `(let ((,stored ,obj)) @@ -48,8 +46,7 @@ that LW/CMU automatically converts strings from c-calls." ) (defmacro convert-to-cstring (obj) - #+cmu obj - #+lispworks obj + #+(or cmu sbcl scl lispworks) obj #+allegro `(if (null ,obj) 0 @@ -63,8 +60,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 scl lispworks) (declare (ignore obj)) #+allegro `(unless (zerop obj) (ff:free-fobject ,obj)) @@ -74,9 +70,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 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))) @@ -127,6 +121,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+ @@ -155,12 +167,18 @@ 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) :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 @@ -172,13 +190,20 @@ 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) ,(if ,unsigned '(* (alien:unsigned 8)) '(* (alien:signed 8))))))) + #+sbcl + (let ((array-def (gensym))) + `(let ((,array-def (list 'sb-alien:array 'char ,size))) + (eval `(sb-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 @@ -206,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))) @@ -229,3 +252,50 @@ that LW/CMU automatically converts strings from c-calls." vm:word-bits) (* 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)) + (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 (sb-sys: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:n-word-bits) + (* length sb-vm:n-byte-bits)) + result)))