X-Git-Url: http://git.kpe.io/?a=blobdiff_plain;f=src%2Fstrings.lisp;h=c63d943e2c8e3496fb89056de87df03bb722bab1;hb=2164fc8537ae2b53fdca3f5b401242299bd53c56;hp=2712a7355ce3ec389880367aa26d6910119f3759;hpb=eb03e5da9d2a2918aff4004597205b36a32f7f6e;p=uffi.git diff --git a/src/strings.lisp b/src/strings.lisp index 2712a73..c63d943 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.5 2002/12/13 22:49:09 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+ @@ -55,14 +54,14 @@ that LW/CMU automatically converts strings from c-calls." `(if (null ,obj) +null-cstring-pointer+ (let ((ptr (new-ptr (1+ (length ,obj))))) - (ccl:%put-cstring ptr ,obj) + (ccl::%put-cstring ptr ,obj) ptr)) ) (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) @@ -143,7 +142,7 @@ that LW/CMU automatically converts strings from c-calls." `(if (null ,obj) +null-cstring-pointer+ (let ((ptr (new-ptr (1+ (length ,obj))))) - (ccl:%put-cstring ptr ,obj) + (ccl::%put-cstring ptr ,obj) ptr)) ) @@ -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)) @@ -299,3 +321,31 @@ that LW/CMU automatically converts strings from c-calls." sb-vm:n-word-bits) (* length sb-vm:n-byte-bits)) 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))))))