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