;;;; Programmer: Kevin M. Rosenberg
;;;; Date Started: Feb 2002
;;;;
-;;;; $Id: strings.lisp,v 1.9 2003/06/12 18:32:30 kevin Exp $
+;;;; $Id$
;;;;
;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
;;;;
`(if (zerop ,obj)
nil
(if (eq ,locale :none)
- (fast-native-to-string ,obj)
+ (fast-native-to-string ,obj ,length)
(excl:native-to-string
,obj
,@(when length (list :length length))
`(if (fli:null-pointer-p ,obj)
nil
(if (eq ,locale :none)
- (fast-native-to-string ,obj)
+ (fast-native-to-string ,obj ,length)
(fli:convert-from-foreign-string
,obj
,@(when length (list :length length))
(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
`(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))
(def-type char-ptr-def (* :unsigned-char))
-;;#+(or lispworks (and allegro ics))
-#+(or lispworks allegro)
-(defun fast-native-to-string (s)
+#+(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 (strlen s))
- (str (make-string len)))
+ (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)))))
+ (setf (aref str i)
+ (uffi:deref-array s '(:array :char) i)))))
-;;#+(and allegro (not ics))
-#+ignore
-(defun fast-native-to-string (s)
- (declare (optimize (speed 3) (space 0) (safety 0) (compilation-speed 0) (debug 0))
+#+(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 (strlen s))
- (len4 (the fixnum (ash (the fixnum len) -2)))
- (end4 (the fixnum (ash (the fixnum len4) 2)))
- (remainder (the fixnum (- len end4)))
- (str (make-string len))
- (str4 str))
- (declare (type fixnum len len4 end4 remainder)
- (type (simple-array (signed-byte 32) (*)) str4)
- (type (simple-array (signed-byte 8) (*)) str))
- (dotimes (i len4)
- (declare (fixnum i))
- (setf (aref str4 i) (uffi:deref-array s '(:array :int) i)))
- (dotimes (i remainder)
- (declare (fixnum i))
- (setf (aref str end4) (uffi:deref-array s '(:array :char) end4))
- (incf end4))
- str))
+ (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 :byte) i))))))