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.4 2002/03/10 11:13:07 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 (def-constant +null-cstring-pointer+
  35     #+cmu nil
  36     #+allegro 0
  37     #+lispworks (fli:make-pointer :address 0 :type :char))
  38
  39 (defmacro convert-from-cstring (obj)
  40   "Converts a string from a c-call. Same as convert-from-foreign-string, except
  41 that CMU automatically converts strings from c-calls."
  42   #+cmu obj
  43   #+lispworks
  44   (let ((stored (gensym)))
  45     `(let ((,stored ,obj))
  46        (if (fli:null-pointer-p ,stored)
  47            nil
  48          (fli:convert-from-foreign-string ,stored))))
  49   #+allegro
  50   (let ((stored (gensym)))
  51     `(let ((,stored ,obj))
  52        (if (zerop ,stored)
  53            nil
  54          (values (excl:native-to-string ,stored)))))
  55   )
  56
  57 (defmacro convert-to-cstring (obj)
  58   #+lispworks
  59   `(if (null ,obj)
  60        +null-cstring-pointer+
  61      (fli:make-pointer
  62       :address (fli:pointer-address (fli:convert-to-foreign-string ,obj))
  63       :type :char))
  64   #+allegro
  65   `(if (null ,obj)
  66        0
  67      (values (excl:string-to-native ,obj)))
  68   #+cmu
  69   (declare (ignore obj))
  70   )
  71
  72 (defmacro free-cstring (obj)
  73   #+lispworks
  74   `(unless (fli:null-pointer-p ,obj)
  75      (fli:free-foreign-object ,obj))
  76   #+allegro
  77   `(unless (zerop obj)
  78      (ff:free-fobject ,obj))
  79   #+cmu
  80   (declare (ignore obj))
  81   )
  82
  83 ;; Either length or null-terminated-p must be non-nil
  84 (defmacro convert-from-foreign-string (obj &key
  85                                            length
  86                                            (null-terminated-p t))
  87   #+allegro
  88   `(if (zerop ,obj)
  89        nil
  90      (values (excl:native-to-string
  91               ,obj
  92               ,@(if length (list :length length) (values))
  93               :truncate (not ,null-terminated-p))))
  94   #+lispworks
  95   `(if (fli:null-pointer-p ,obj)
  96        nil
  97      (fli:convert-from-foreign-string
  98       ,obj
  99       ,@(if length (list :length length) (values))
 100       :null-terminated-p ,null-terminated-p
 101       :external-format '(:latin-1 :eol-style :lf)))
 102   #+cmu
 103   `(cmucl-naturalize-cstring (alien:alien-sap ,obj)
 104                               :length ,length
 105                               :null-terminated-p ,null-terminated-p)
 106   )
 107
 108 (defmacro convert-to-foreign-string (obj)
 109   #+lispworks
 110   `(if (null ,obj)
 111        +null-cstring-pointer+
 112      (fli:make-pointer
 113       :address (fli:pointer-address (fli:convert-to-foreign-string ,obj))
 114       :type :char))
 115   #+allegro
 116   `(if (null ,obj)
 117        0
 118      (values (excl:string-to-native ,obj)))
 119   #+cmu
 120   (let ((size (gensym))
 121         (storage (gensym))
 122         (i (gensym)))
 123     `(when (stringp ,obj)
 124        (let* ((,size (length ,obj))
 125               (,storage (alien:make-alien char (1+ ,size))))
 126          (setq ,storage (alien:cast ,storage (* char)))
 127          (dotimes (,i ,size)
 128            (declare (fixnum ,i)
 129                     (optimize (speed 3) (safety 0)))
 130            (setf (alien:deref ,storage ,i) (char-code (char ,obj ,i))))
 131          (setf (alien:deref ,storage ,size) 0)
 132          ,storage)))
 133   )
 134
 135
 136 (defmacro allocate-foreign-string (size &key (unsigned nil))
 137   #+cmu
 138   (let ((array-def (gensym)))
 139     `(let ((,array-def (list 'alien:array 'c-call:char ,size)))
 140        (eval `(alien:cast (alien:make-alien ,,array-def)
 141                           ,(if ,unsigned
 142                                '(* (alien:unsigned 8))
 143                              '(* (alien:signed 8)))))))
 144   #+lispworks
 145   `(fli:allocate-foreign-object :type
 146                                 ,(if unsigned
 147                                      ''(:unsigned :char)
 148                                    :char)
 149                                 :nelems ,size)
 150   #+allegro
 151   (declare (ignore unsigned))
 152   #+allegro
 153   `(ff:allocate-fobject :char :c ,size)
 154   )
 155
 156 (defmacro with-cstring ((foreign-string lisp-string) &body body)
 157   #+cmu
 158   `(let ((,foreign-string ,lisp-string)) ,@body)
 159   #+allegro
 160   (let ((acl-native (gensym)))
 161     `(excl:with-native-string (,acl-native ,lisp-string)
 162        (let ((,foreign-string (if ,lisp-string ,acl-native 0)))
 163          ,@body)))
 164   #+lispworks
 165   (let ((result (gensym)))
 166     `(let* ((,foreign-string (convert-to-cstring ,lisp-string))
 167             (,result ,@body))
 168        (fli:free-foreign-object ,foreign-string)
 169        ,result))
 170   )
 171
 172 ;; Modified from CMUCL's source to handle non-null terminated strings
 173 #+cmu
 174 (defun cmucl-naturalize-cstring (sap &key
 175                                            length
 176                                            (null-terminated-p t))
 177   (declare (type system:system-area-pointer sap))
 178   (locally
 179       (declare (optimize (speed 3) (safety 0)))
 180     (let ((null-terminated-length
 181            (when null-terminated-p
 182              (loop
 183                  for offset of-type fixnum upfrom 0
 184                  until (zerop (system:sap-ref-8 sap offset))
 185                  finally (return offset)))))
 186       (if length
 187           (if (and null-terminated-length
 188                    (> (the fixnum length) (the fixnum null-terminated-length)))
 189               (setq length null-terminated-length))
 190         (setq length null-terminated-length)))
 191     (let ((result (make-string length)))
 192       (kernel:copy-from-system-area sap 0
 193                                     result (* vm:vector-data-offset
 194                                               vm:word-bits)
 195                                     (* length vm:byte-bits))
 196       result)))