src-mcl/strings.cl

   1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: UFFI -*-
   2 ;;;; *************************************************************************
   3 ;;;; FILE IDENTIFICATION
   4 ;;;;
   5 ;;;; Name:          strings.cl
   6 ;;;; Purpose:       UFFI source to handle strings, cstring and foreigns
   7 ;;;; Programmers:   Kevin M. Rosenberg and John DeSoi
   8 ;;;; Date Started:  Feb 2002
   9 ;;;;
  10 ;;;; $Id: strings.cl,v 1.2 2002/09/20 04:51:14 kevin Exp $
  11 ;;;;
  12 ;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
  13 ;;;; and John DeSoi
  14 ;;;;
  15 ;;;; UFFI users are granted the rights to distribute and use this software
  16 ;;;; as governed by the terms of the Lisp Lesser GNU Public License
  17 ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
  18 ;;;; *************************************************************************
  19
  20 (declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0)))
  21 (in-package :uffi)
  22
  23
  24 (defvar +null-cstring-pointer+ (ccl:%null-ptr))
  25
  26 (defmacro convert-from-cstring (obj)
  27   "Converts a string from a c-call. Same as convert-from-foreign-string, except
  28 that CMU automatically converts strings from c-calls."
  29   #+cmu obj
  30   #+lispworks
  31   (let ((stored (gensym)))
  32     `(let ((,stored ,obj))
  33        (if (fli:null-pointer-p ,stored)
  34            nil
  35          (fli:convert-from-foreign-string ,stored))))
  36   #+allegro
  37   (let ((stored (gensym)))
  38     `(let ((,stored ,obj))
  39        (if (zerop ,stored)
  40            nil
  41          (values (excl:native-to-string ,stored)))))
  42   #+mcl
  43   (let ((stored (gensym)))
  44     `(let ((,stored ,obj))
  45        (if (ccl:%null-ptr-p ,stored)
  46            nil
  47          (values (ccl:%get-cstring ,stored)))))
  48
  49
  50   )
  51
  52 (defmacro convert-to-cstring (obj)
  53   #+lispworks
  54   `(if (null ,obj)
  55     +null-cstring-pointer+
  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   #+mcl
  64   `(if (null ,obj)
  65     +null-cstring-pointer+
  66     (let ((ptr (new-ptr (1+ (length ,obj)))))
  67       (ccl:%put-cstring ptr ,obj)
  68       ptr))
  69   )
  70
  71 (defmacro free-cstring (obj)
  72   #+lispworks
  73   `(unless (fli:null-pointer-p ,obj)
  74      (fli:free-foreign-object ,obj))
  75   #+allegro
  76   `(unless (zerop obj)
  77      (ff:free-fobject ,obj))
  78   #+cmu
  79   (declare (ignore obj))
  80   #+mcl
  81   `(unless (ccl:%null-ptr-p ,obj)
  82      (dispose-ptr ,obj))
  83
  84   )
  85
  86 ;; Either length or null-terminated-p must be non-nil
  87 (defmacro convert-from-foreign-string (obj &key
  88                                            length
  89                                            (null-terminated-p t))
  90   #+allegro
  91   `(if (zerop ,obj)
  92        nil
  93      (values (excl:native-to-string
  94               ,obj
  95               ,@(if length (list :length length) (values))
  96               :truncate (not ,null-terminated-p))))
  97   #+lispworks
  98   `(if (fli:null-pointer-p ,obj)
  99        nil
 100      (fli:convert-from-foreign-string
 101       ,obj
 102       ,@(if length (list :length length) (values))
 103       :null-terminated-p ,null-terminated-p
 104       :external-format '(:latin-1 :eol-style :lf)))
 105   #+cmu
 106   `(cmucl-naturalize-cstring (alien:alien-sap ,obj)
 107                               :length ,length
 108                               :null-terminated-p ,null-terminated-p)
 109   #+mcl
 110   (declare (ignore null-terminated-p))
 111   #+mcl
 112   `(if (ccl:%null-ptr-p ,obj)
 113      nil
 114      (ccl:%get-cstring ,obj 0 ,@(if length (list length) nil)))
 115   )
 116
 117 (defmacro convert-to-foreign-string (obj)
 118   #+lispworks
 119   `(if (null ,obj)
 120        +null-cstring-pointer+
 121     (fli:convert-to-foreign-string ,obj))
 122   #+allegro
 123   `(if (null ,obj)
 124        0
 125      (values (excl:string-to-native ,obj)))
 126   #+cmu
 127   (let ((size (gensym))
 128         (storage (gensym))
 129         (i (gensym)))
 130     `(when (stringp ,obj)
 131        (let* ((,size (length ,obj))
 132               (,storage (alien:make-alien char (1+ ,size))))
 133          (setq ,storage (alien:cast ,storage (* char)))
 134          (dotimes (,i ,size)
 135            (declare (fixnum ,i)
 136                     (optimize (speed 3) (safety 0)))
 137            (setf (alien:deref ,storage ,i) (char-code (char ,obj ,i))))
 138          (setf (alien:deref ,storage ,size) 0)
 139          ,storage)))
 140   #+mcl
 141   `(if (null ,obj)
 142     +null-cstring-pointer+
 143     (let ((ptr (new-ptr (1+ (length ,obj)))))
 144       (ccl:%put-cstring ptr ,obj)
 145       ptr))
 146   )
 147
 148
 149 (defmacro allocate-foreign-string (size &key (unsigned t))
 150   #+cmu
 151   (let ((array-def (gensym)))
 152     `(let ((,array-def (list 'alien:array 'c-call:char ,size)))
 153        (eval `(alien:cast (alien:make-alien ,,array-def)
 154                           ,(if ,unsigned
 155                                '(* (alien:unsigned 8))
 156                              '(* (alien:signed 8)))))))
 157   #+lispworks
 158   `(fli:allocate-foreign-object :type
 159                                 ,(if unsigned
 160                                      ''(:unsigned :char)
 161                                    :char)
 162                                 :nelems ,size)
 163   #+allegro
 164   (declare (ignore unsigned))
 165   #+allegro
 166   `(ff:allocate-fobject :char :c ,size)
 167   #+mcl
 168   (declare (ignore unsigned))
 169   #+mcl
 170   `(new-ptr ,size)
 171
 172   )
 173
 174
 175 ; I'm sure there must be a better way to write this...
 176 (defmacro with-cstring ((foreign-string lisp-string) &body body)
 177   `(if (stringp ,lisp-string)
 178      (ccl:with-cstrs ((,foreign-string ,lisp-string))
 179        ,@body)
 180      (let ((,foreign-string +null-cstring-pointer+))
 181        ,@body)))
 182
 183
 184 #| Works but, supposedly the built in method is better
 185 (defmacro with-cstring ((foreign-string lisp-string) &body body)
 186   (let ((result (gensym)))
 187     `(let* ((,foreign-string (convert-to-cstring ,lisp-string))
 188             (,result ,@body))
 189        (dispose-ptr ,foreign-string)
 190        ,result))
 191   )
 192
 193 |#
 194
 195
 196
 197
 198 (defmacro with-foreign-string ((foreign-string lisp-string) &body body)
 199   (let ((result (gensym)))
 200     `(let* ((,foreign-string (convert-to-foreign-string ,lisp-string))
 201             (,result (progn ,@body)))
 202       (declare (dynamic-extent ,foreign-string))
 203       (free-foreign-object ,foreign-string)
 204       ,result)))
 205
 206
 207
 208
 209