X-Git-Url: http://git.kpe.io/?a=blobdiff_plain;f=src%2Fstrings.lisp;h=684b0351ca108948b00ea5426a4f16407dc1a30b;hb=045b87e7fdcf1c5562fe170d96622e0a09759f64;hp=8d768e62f638311c27cf010a8c756f6bb2c1e96a;hpb=7257bec0054cabeb29c253942fac968efa0277c4;p=uffi.git diff --git a/src/strings.lisp b/src/strings.lisp index 8d768e6..684b035 100644 --- a/src/strings.lisp +++ b/src/strings.lisp @@ -2,12 +2,12 @@ ;;;; ************************************************************************* ;;;; FILE IDENTIFICATION ;;;; -;;;; Name: strings.cl +;;;; Name: strings.lisp ;;;; Purpose: UFFI source to handle strings, cstring and foreigns ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Feb 2002 ;;;; -;;;; $Id: strings.lisp,v 1.6 2003/03/12 21:13:18 kevin Exp $ +;;;; $Id$ ;;;; ;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg ;;;; @@ -16,8 +16,7 @@ ;;;; (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) +(in-package #:uffi) (defvar +null-cstring-pointer+ @@ -62,7 +61,7 @@ that LW/CMU automatically converts strings from c-calls." (defmacro free-cstring (obj) #+(or cmu sbcl scl lispworks) (declare (ignore obj)) #+allegro - `(unless (zerop obj) + `(unless (zerop ,obj) (ff:free-fobject ,obj)) #+mcl `(unless (ccl:%null-ptr-p ,obj) @@ -151,22 +150,28 @@ that LW/CMU automatically converts strings from c-calls." ;; Either length or null-terminated-p must be non-nil (defmacro convert-from-foreign-string (obj &key length + (locale :default) (null-terminated-p t)) #+allegro `(if (zerop ,obj) nil - (values (excl:native-to-string - ,obj - ,@(if length (list :length length) (values)) - :truncate (not ,null-terminated-p)))) + (if (eq ,locale :none) + (fast-native-to-string ,obj ,length) + (values + (excl:native-to-string + ,obj + ,@(when length (list :length length)) + :truncate (not ,null-terminated-p))))) #+lispworks `(if (fli:null-pointer-p ,obj) nil - (fli:convert-from-foreign-string - ,obj - ,@(if length (list :length length) (values)) - :null-terminated-p ,null-terminated-p - :external-format '(:latin-1 :eol-style :lf))) + (if (eq ,locale :none) + (fast-native-to-string ,obj ,length) + (fli:convert-from-foreign-string + ,obj + ,@(when length (list :length length)) + :null-terminated-p ,null-terminated-p + :external-format '(:latin-1 :eol-style :lf)))) #+(or cmu scl) `(if (null-pointer-p ,obj) nil @@ -184,26 +189,34 @@ that LW/CMU automatically converts strings from c-calls." #+mcl `(if (ccl:%null-ptr-p ,obj) nil - (ccl:%get-cstring ,obj 0 ,@(if length (list length) nil))) + #+(and mcl (not openmcl)) (ccl:%get-cstring ,obj 0 ,@(if length (list length) nil)) + #+openmcl ,@(if length + `((ccl:%str-from-ptr ,obj ,length)) + `((ccl:%get-cstring ,obj)))) ) - (defmacro allocate-foreign-string (size &key (unsigned t)) - #+(or cmu scl) + #+ignore (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))))))) + + #+(or cmu scl) + `(alien:make-alien ,(if unsigned + '(alien:unsigned 8) + '(alien:signed 8)) + ,size) + #+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))))))) + `(sb-alien:make-alien ,(if unsigned + '(sb-alien:unsigned 8) + '(sb-alien:signed 8)) + ,size) + #+lispworks `(fli:allocate-foreign-object :type ,(if unsigned @@ -220,6 +233,15 @@ that LW/CMU automatically converts strings from c-calls." `(new-ptr ,size) ) +(defun foreign-string-length (foreign-string) + #+allegro `(ff:foreign-strlen ,foreign-string) + #-allegro + `(loop with size = 0 + until (char= (deref-array ,foreign-string '(:array :unsigned-char) size) #\Null) + do (incf size) + finally return size)) + + (defmacro with-foreign-string ((foreign-string lisp-string) &body body) (let ((result (gensym))) `(let* ((,foreign-string (convert-to-foreign-string ,lisp-string)) @@ -277,25 +299,74 @@ that LW/CMU automatically converts strings from c-calls." (setf (char result i) (code-char (system:sap-ref-8 sap i)))) result))) -#+sbcl +#+(and sbcl (not sb-unicode)) (defun sbcl-naturalize-cstring (sap &key length (null-terminated-p t)) - (declare (type sb-sys:system-area-pointer sap)) + (declare (type sb-sys:system-area-pointer sap) + (type (or null fixnum) length)) (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))) + (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))) + (funcall *system-copy-fn* sap 0 result +system-copy-offset+ + (* length +system-copy-multiplier+)) + result))) + +#+(and sbcl sb-unicode) +(defun sbcl-naturalize-cstring (sap &key length (null-terminated-p t)) + (declare (type sb-sys:system-area-pointer sap) + (type (or null fixnum) length)) + (locally + (declare (optimize (speed 3) (safety 0))) + (cond + (null-terminated-p + (let ((casted (sb-alien:cast (sb-alien:sap-alien sap (* char)) + #+sb-unicode sb-alien:utf8-string + #-sb-unicode sb-alien:c-string))) + (if length + (copy-seq (subseq casted 0 length)) + (copy-seq casted)))) + (t + (let ((result (make-string length))) + ;; this will not work in sb-unicode + (funcall *system-copy-fn* sap 0 result +system-copy-offset+ + (* length +system-copy-multiplier+)) + result))))) + + +(eval-when (:compile-toplevel :load-toplevel :execute) + (def-function "strlen" + ((str (* :unsigned-char))) + :returning :unsigned-int)) + +(def-type char-ptr-def (* :unsigned-char)) + +#+(or lispworks (and allegro (not ics))) +(defun fast-native-to-string (s len) + (declare (optimize (speed 3) (space 0) (safety 0) (compilation-speed 0)) + (type char-ptr-def s)) + (let* ((len (or len (strlen s))) + (str (make-string len))) + (declare (fixnum len) + (type (simple-array (signed-byte 8) (*)) str)) + (dotimes (i len str) + (setf (aref str i) + (uffi:deref-array s '(:array :char) i))))) + +#+(and allegro ics) +(defun fast-native-to-string (s len) + (declare (optimize (speed 3) (space 0) (safety 0) (compilation-speed 0)) + (type char-ptr-def s)) + (let* ((len (or len (strlen s))) + (str (make-string len))) + (dotimes (i len str) + (setf (schar str i) (code-char (uffi:deref-array s '(:array :unsigned-byte) i))))))