src/mcl/strings.cl

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