X-Git-Url: http://git.kpe.io/?a=blobdiff_plain;f=src%2Fstrings.cl;h=8bd95bd243e54bd1143cc8e4cef3a559a537f5ad;hb=a624b86f5dd46f9fc682440e5c7b0b131dc28084;hp=6eeea2c60ff7d7bc7778940450c367cc4abd8227;hpb=192193db6e4fbda90a840474d4aa2e8762597927;p=uffi.git diff --git a/src/strings.cl b/src/strings.cl index 6eeea2c..8bd95bd 100644 --- a/src/strings.cl +++ b/src/strings.cl @@ -1,46 +1,35 @@ -;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: UFFI -*- ;;;; ************************************************************************* ;;;; FILE IDENTIFICATION ;;;; -;;;; Name: immediates.cl -;;;; Purpose: UFFI source to handle immediate types +;;;; Name: strings.cl +;;;; Purpose: UFFI source to handle strings, cstring and foreigns ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Feb 2002 ;;;; -;;;; Copyright (c) 2002 Kevin M. Rosenberg +;;;; $Id: strings.cl,v 1.17 2002/04/06 19:53:08 kevin Exp $ ;;;; -;;;; $Id: strings.cl,v 1.1 2002/03/09 19:55:33 kevin Exp $ +;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg ;;;; -;;;; This file is part of the UFFI. -;;;; -;;;; UFFI is free software; you can redistribute it and/or modify -;;;; it under the terms of the GNU General Public License (version 2) as -;;;; published by the Free Software Foundation. -;;;; -;;;; UFFI is distributed in the hope that it will be useful, -;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;;; GNU General Public License for more details. -;;;; -;;;; You should have received a copy of the GNU General Public License -;;;; along with UFFI; if not, write to the Free Software -;;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +;;;; UFFI users are granted the rights to distribute and use this software +;;;; as governed by the terms of the Lisp Lesser GNU Public License +;;;; (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) -(defmacro convert-from-c-string (obj) +(def-constant +null-cstring-pointer+ + #+cmu nil + #+allegro 0 + #+lispworks (fli:make-pointer :address 0 :type '(:unsigned :char))) + +(defmacro convert-from-cstring (obj) "Converts a string from a c-call. Same as convert-from-foreign-string, except -that CMU automatically converts strings from c-calls." +that LW/CMU automatically converts strings from c-calls." #+cmu obj - #+lispworks - (let ((stored (gensym))) - `(let ((,stored ,obj)) - (if (fli:null-pointer-p ,stored) - nil - (fli:convert-from-foreign-string ,stored)))) + #+lispworks obj #+allegro (let ((stored (gensym))) `(let ((,stored ,obj)) @@ -49,30 +38,74 @@ that CMU automatically converts strings from c-calls." (values (excl:native-to-string ,stored))))) ) -(defmacro convert-to-c-string (obj) - #+lispworks - `(if (null ,obj) - +null-c-string-ptr+ - (fli:convert-to-foreign-string ,obj)) +(defmacro convert-to-cstring (obj) + #+cmu obj + #+lispworks obj #+allegro `(if (null ,obj) - 0 - (values (excl:string-to-native ,obj))) - #+cmu - (declare (ignore obj)) + 0 + (values (excl:string-to-native ,obj))) ) -(defmacro free-c-string (obj) - #+lispworks - `(unless (fli:null-pointer-p ,obj) - (fli:free-foreign-object ,obj)) +(defmacro free-cstring (obj) + #+cmu (declare (ignore obj)) + #+lispworks (declare (ignore obj)) #+allegro `(unless (zerop obj) (ff:free-fobject ,obj)) + ) + +(defmacro with-cstring ((cstring lisp-string) &body body) #+cmu - (declare (ignore obj)) + `(let ((,cstring ,lisp-string)) ,@body) + #+lispworks + `(let ((,cstring ,lisp-string)) ,@body) + #+allegro + (let ((acl-native (gensym))) + `(excl:with-native-string (,acl-native ,lisp-string) + (let ((,cstring (if ,lisp-string ,acl-native 0))) + ,@body))) ) +(defmacro with-cstrings (bindings &rest body) + (if bindings + `(with-cstring ,(car bindings) + (with-cstrings ,(cdr bindings) + ,@body)) + `(progn ,@body))) + +;;; Foreign string functions + +(defmacro convert-to-foreign-string (obj) + #+lispworks + `(if (null ,obj) + +null-cstring-pointer+ + (fli:convert-to-foreign-string ,obj)) + #+allegro + `(if (null ,obj) + 0 + (values (excl:string-to-native ,obj))) + #+cmu + (let ((size (gensym)) + (storage (gensym)) + (i (gensym))) + `(etypecase ,obj + (null + (alien:sap-alien (system:int-sap 0) (* (alien:unsigned 8)))) + (string + (let* ((,size (length ,obj)) + (,storage (alien:make-alien (alien:unsigned 8) (1+ ,size)))) + (setq ,storage (alien:cast ,storage (* (alien:unsigned 8)))) + (locally + (declare (optimize (speed 3) (safety 0))) + (dotimes (,i ,size) + (declare (fixnum ,i)) + (setf (alien:deref ,storage ,i) (char-code (char ,obj ,i)))) + (setf (alien:deref ,storage ,size) 0)) + ,storage)))) + ) + + ;; Either length or null-terminated-p must be non-nil (defmacro convert-from-foreign-string (obj &key length @@ -93,67 +126,47 @@ that CMU automatically converts strings from c-calls." :null-terminated-p ,null-terminated-p :external-format '(:latin-1 :eol-style :lf))) #+cmu - `(cmucl-naturalize-c-string (alien:alien-sap ,obj) - :length ,length - :null-terminated-p ,null-terminated-p) + `(if (null-pointer-p ,obj) + nil + (cmucl-naturalize-cstring (alien:alien-sap ,obj) + :length ,length + :null-terminated-p ,null-terminated-p)) ) -(defmacro convert-to-foreign-string (obj) - #+lispworks - `(if (null ,obj) - +null-c-string-ptr+ - (fli:convert-to-foreign-string ,obj)) - #+allegro - `(if (null ,obj) - 0 - (values (excl:string-to-native ,obj))) - #+cmu - (let ((size (gensym)) - (storage (gensym)) - (i (gensym))) - `(when (stringp ,obj) - (let* ((,size (length ,obj)) - (,storage (alien:make-alien char (1+ ,size)))) - (setq ,storage (alien:cast ,storage (* char))) - (dotimes (,i ,size) - (declare (fixnum ,i) - (optimize (speed 3) (safety 0))) - (setf (alien:deref ,storage ,i) (char-code (char ,obj ,i)))) - (setf (alien:deref ,storage ,size) 0) - ,storage))) - ) -(defmacro allocate-foreign-string (size) +(defmacro allocate-foreign-string (size &key (unsigned t)) #+cmu (let ((array-def (gensym))) `(let ((,array-def (list 'alien:array 'c-call:char ,size))) - (eval `(alien:cast (alien:make-alien ,,array-def) (* (alien:unsigned 8)))))) + (eval `(alien:cast (alien:make-alien ,,array-def) + ,(if ,unsigned + '(* (alien:unsigned 8)) + '(* (alien:signed 8))))))) #+lispworks - `(fli:allocate-foreign-object :type '(:unsigned :char) :nelems ,size) + `(fli:allocate-foreign-object :type + ,(if unsigned + ''(:unsigned :char) + :char) + :nelems ,size) + #+allegro + (declare (ignore unsigned)) #+allegro `(ff:allocate-fobject :char :c ,size) ) -(defmacro with-c-string ((foreign-string lisp-string) &body body) - #+cmu - `(let ((,foreign-string ,lisp-string)) ,@body) - #+allegro - (let ((acl-native (gensym))) - `(excl:with-native-string (,acl-native ,lisp-string) - (let ((,foreign-string (if ,lisp-string ,acl-native 0))) - ,@body))) - #+lispworks +(defmacro with-foreign-string ((foreign-string lisp-string) &body body) (let ((result (gensym))) - `(let* ((,foreign-string (convert-to-c-string ,lisp-string)) - (,result ,@body)) - (fli:free-foreign-object ,foreign-string) - ,result)) - ) + `(let* ((,foreign-string (convert-to-foreign-string ,lisp-string)) + (,result (progn ,@body))) + (declare (dynamic-extent ,foreign-string)) + (free-foreign-object ,foreign-string) + ,result))) + ;; Modified from CMUCL's source to handle non-null terminated strings #+cmu -(defun cmucl-naturalize-c-string (sap &key +(defun cmucl-naturalize-cstring (sap &key length (null-terminated-p t)) (declare (type system:system-area-pointer sap))