src/strings.cl

   1 ;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
   2 ;;;; *************************************************************************
   3 ;;;; FILE IDENTIFICATION
   4 ;;;;
   5 ;;;; Name:          immediates.cl
   6 ;;;; Purpose:       UFFI source to handle immediate types
   7 ;;;; Programmer:    Kevin M. Rosenberg
   8 ;;;; Date Started:  Feb 2002
   9 ;;;;
  10 ;;;; Copyright (c) 2002 Kevin M. Rosenberg
  11 ;;;;
  12 ;;;; $Id: strings.cl,v 1.1 2002/03/09 19:55:33 kevin Exp $
  13 ;;;;
  14 ;;;; This file is part of the UFFI.
  15 ;;;;
  16 ;;;; UFFI is free software; you can redistribute it and/or modify
  17 ;;;; it under the terms of the GNU General Public License (version 2) as
  18 ;;;; published by the Free Software Foundation.
  19 ;;;;
  20 ;;;; UFFI is distributed in the hope that it will be useful,
  21 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  22 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  23 ;;;; GNU General Public License for more details.
  24 ;;;;
  25 ;;;; You should have received a copy of the GNU General Public License
  26 ;;;; along with UFFI; if not, write to the Free Software
  27 ;;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
  28 ;;;; *************************************************************************
  29
  30 (declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0)))
  31 (in-package :uffi)
  32
  33
  34 (defmacro convert-from-c-string (obj)
  35   "Converts a string from a c-call. Same as convert-from-foreign-string, except
  36 that CMU automatically converts strings from c-calls."
  37   #+cmu obj
  38   #+lispworks
  39   (let ((stored (gensym)))
  40     `(let ((,stored ,obj))
  41        (if (fli:null-pointer-p ,stored)
  42            nil
  43          (fli:convert-from-foreign-string ,stored))))
  44   #+allegro
  45   (let ((stored (gensym)))
  46     `(let ((,stored ,obj))
  47        (if (zerop ,stored)
  48            nil
  49          (values (excl:native-to-string ,stored)))))
  50   )
  51
  52 (defmacro convert-to-c-string (obj)
  53   #+lispworks
  54   `(if (null ,obj)
  55        +null-c-string-ptr+
  56      (fli:convert-to-foreign-string ,obj))
  57   #+allegro
  58   `(if (null ,obj)
  59        0
  60      (values (excl:string-to-native ,obj)))
  61   #+cmu
  62   (declare (ignore obj))
  63   )
  64
  65 (defmacro free-c-string (obj)
  66   #+lispworks
  67   `(unless (fli:null-pointer-p ,obj)
  68      (fli:free-foreign-object ,obj))
  69   #+allegro
  70   `(unless (zerop obj)
  71      (ff:free-fobject ,obj))
  72   #+cmu
  73   (declare (ignore obj))
  74   )
  75
  76 ;; Either length or null-terminated-p must be non-nil
  77 (defmacro convert-from-foreign-string (obj &key
  78                                            length
  79                                            (null-terminated-p t))
  80   #+allegro
  81   `(if (zerop ,obj)
  82        nil
  83      (values (excl:native-to-string
  84               ,obj
  85               ,@(if length (list :length length) (values))
  86               :truncate (not ,null-terminated-p))))
  87   #+lispworks
  88   `(if (fli:null-pointer-p ,obj)
  89        nil
  90      (fli:convert-from-foreign-string
  91       ,obj
  92       ,@(if length (list :length length) (values))
  93       :null-terminated-p ,null-terminated-p
  94       :external-format '(:latin-1 :eol-style :lf)))
  95   #+cmu
  96   `(cmucl-naturalize-c-string (alien:alien-sap ,obj)
  97                               :length ,length
  98                               :null-terminated-p ,null-terminated-p)
  99   )
 100
 101 (defmacro convert-to-foreign-string (obj)
 102   #+lispworks
 103   `(if (null ,obj)
 104        +null-c-string-ptr+
 105      (fli:convert-to-foreign-string ,obj))
 106   #+allegro
 107   `(if (null ,obj)
 108        0
 109      (values (excl:string-to-native ,obj)))
 110   #+cmu
 111   (let ((size (gensym))
 112         (storage (gensym))
 113         (i (gensym)))
 114     `(when (stringp ,obj)
 115        (let* ((,size (length ,obj))
 116               (,storage (alien:make-alien char (1+ ,size))))
 117          (setq ,storage (alien:cast ,storage (* char)))
 118          (dotimes (,i ,size)
 119            (declare (fixnum ,i)
 120                     (optimize (speed 3) (safety 0)))
 121            (setf (alien:deref ,storage ,i) (char-code (char ,obj ,i))))
 122          (setf (alien:deref ,storage ,size) 0)
 123          ,storage)))
 124   )
 125
 126
 127 (defmacro allocate-foreign-string (size)
 128   #+cmu
 129   (let ((array-def (gensym)))
 130     `(let ((,array-def (list 'alien:array 'c-call:char ,size)))
 131        (eval `(alien:cast (alien:make-alien ,,array-def) (* (alien:unsigned 8))))))
 132   #+lispworks
 133   `(fli:allocate-foreign-object :type '(:unsigned :char) :nelems ,size)
 134   #+allegro
 135   `(ff:allocate-fobject :char :c ,size)
 136   )
 137
 138 (defmacro with-c-string ((foreign-string lisp-string) &body body)
 139   #+cmu
 140   `(let ((,foreign-string ,lisp-string)) ,@body)
 141   #+allegro
 142   (let ((acl-native (gensym)))
 143     `(excl:with-native-string (,acl-native ,lisp-string)
 144        (let ((,foreign-string (if ,lisp-string ,acl-native 0)))
 145          ,@body)))
 146   #+lispworks
 147   (let ((result (gensym)))
 148     `(let* ((,foreign-string (convert-to-c-string ,lisp-string))
 149             (,result ,@body))
 150        (fli:free-foreign-object ,foreign-string)
 151        ,result))
 152   )
 153
 154 ;; Modified from CMUCL's source to handle non-null terminated strings
 155 #+cmu
 156 (defun cmucl-naturalize-c-string (sap &key
 157                                            length
 158                                            (null-terminated-p t))
 159   (declare (type system:system-area-pointer sap))
 160   (locally
 161       (declare (optimize (speed 3) (safety 0)))
 162     (let ((null-terminated-length
 163            (when null-terminated-p
 164              (loop
 165                  for offset of-type fixnum upfrom 0
 166                  until (zerop (system:sap-ref-8 sap offset))
 167                  finally (return offset)))))
 168       (if length
 169           (if (and null-terminated-length
 170                    (> (the fixnum length) (the fixnum null-terminated-length)))
 171               (setq length null-terminated-length))
 172         (setq length null-terminated-length)))
 173     (let ((result (make-string length)))
 174       (kernel:copy-from-system-area sap 0
 175                                     result (* vm:vector-data-offset
 176                                               vm:word-bits)
 177                                     (* length vm:byte-bits))
 178       result)))