src/strings.lisp

   1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: UFFI -*-
   2 ;;;; *************************************************************************
   3 ;;;; FILE IDENTIFICATION
   4 ;;;;
   5 ;;;; Name:          strings.lisp
   6 ;;;; Purpose:       UFFI source to handle strings, cstring and foreigns
   7 ;;;; Programmer:    Kevin M. Rosenberg
   8 ;;;; Date Started:  Feb 2002
   9 ;;;;
  10 ;;;; This file, part of UFFI, is Copyright (c) 2002-2010 by Kevin M. Rosenberg
  11 ;;;; *************************************************************************
  12
  13 (in-package #:uffi)
  14
  15
  16 (def-pointer-var +null-cstring-pointer+
  17     #+(or cmu sbcl scl) nil
  18     #+allegro 0
  19     #+lispworks (fli:make-pointer :address 0 :type '(:unsigned :char))
  20     #+(or openmcl digitool) (ccl:%null-ptr)
  21 )
  22
  23 (defmacro convert-from-cstring (obj)
  24   "Converts a string from a c-call. Same as convert-from-foreign-string, except
  25 that LW/CMU automatically converts strings from c-calls."
  26   #+(or cmu sbcl lispworks scl) obj
  27   #+allegro
  28   (let ((stored (gensym)))
  29     `(let ((,stored ,obj))
  30        (if (zerop ,stored)
  31            nil
  32            (values (excl:native-to-string ,stored)))))
  33   #+(or openmcl digitool)
  34   (let ((stored (gensym)))
  35     `(let ((,stored ,obj))
  36        (if (ccl:%null-ptr-p ,stored)
  37            nil
  38          (values (ccl:%get-cstring ,stored)))))
  39   )
  40
  41 (defmacro convert-to-cstring (obj)
  42   #+(or cmu sbcl scl lispworks) obj
  43   #+allegro
  44   (let ((stored (gensym)))
  45     `(let ((,stored ,obj))
  46        (if (null ,stored)
  47            0
  48            (values (excl:string-to-native ,stored)))))
  49   #+(or openmcl digitool)
  50   (let ((stored (gensym)))
  51     `(let ((,stored ,obj))
  52        (if (null ,stored)
  53            +null-cstring-pointer+
  54            (let ((ptr (new-ptr (1+ (length ,stored)))))
  55              (ccl::%put-cstring ptr ,stored)
  56              ptr))))
  57   )
  58
  59 (defmacro free-cstring (obj)
  60   #+(or cmu sbcl scl lispworks) (declare (ignore obj))
  61   #+allegro
  62   (let ((stored (gensym)))
  63     `(let ((,stored ,obj))
  64        (unless (zerop ,stored)
  65          (ff:free-fobject ,stored))))
  66   #+(or openmcl digitool)
  67   (let ((stored (gensym)))
  68     `(let ((,stored ,obj))
  69        (unless (ccl:%null-ptr-p ,stored)
  70          (dispose-ptr ,stored))))
  71   )
  72
  73 (defmacro with-cstring ((cstring lisp-string) &body body)
  74   #+(or cmu sbcl scl lispworks)
  75   `(let ((,cstring ,lisp-string)) ,@body)
  76   #+allegro
  77   (let ((acl-native (gensym))
  78         (stored-lisp-string (gensym)))
  79     `(let ((,stored-lisp-string ,lisp-string))
  80        (excl:with-native-string (,acl-native ,stored-lisp-string)
  81          (let ((,cstring (if ,stored-lisp-string ,acl-native 0)))
  82            ,@body))))
  83   #+(or openmcl digitool)
  84   (let ((stored-lisp-string (gensym)))
  85     `(let ((,stored-lisp-string ,lisp-string))
  86        (if (stringp ,stored-lisp-string)
  87            (ccl:with-cstrs ((,cstring ,stored-lisp-string))
  88              ,@body)
  89            (let ((,cstring +null-cstring-pointer+))
  90              ,@body))))
  91   )
  92
  93 (defmacro with-cstrings (bindings &rest body)
  94   (if bindings
  95       `(with-cstring ,(car bindings)
  96         (with-cstrings ,(cdr bindings)
  97           ,@body))
  98       `(progn ,@body)))
  99
 100 ;;; Foreign string functions
 101
 102 (defmacro convert-to-foreign-string (obj)
 103   #+lispworks
 104   (let ((stored (gensym)))
 105     `(let ((,stored ,obj))
 106        (if (null ,stored)
 107            +null-cstring-pointer+
 108            (fli:convert-to-foreign-string
 109             ,stored
 110             :external-format '(:latin-1 :eol-style :lf)))))
 111   #+allegro
 112   (let ((stored (gensym)))
 113     `(let ((,stored ,obj))
 114        (if (null ,stored)
 115            0
 116            (values (excl:string-to-native ,stored)))))
 117   #+(or cmu scl)
 118   (let ((size (gensym))
 119         (storage (gensym))
 120         (stored-obj (gensym))
 121         (i (gensym)))
 122     `(let ((,stored-obj ,obj))
 123        (etypecase ,stored-obj
 124          (null
 125           (alien:sap-alien (system:int-sap 0) (* (alien:unsigned 8))))
 126          (string
 127           (let* ((,size (length ,stored-obj))
 128                  (,storage (alien:make-alien (alien:unsigned 8) (1+ ,size))))
 129             (setq ,storage (alien:cast ,storage (* (alien:unsigned 8))))
 130             (locally
 131                 (declare (optimize (speed 3) (safety 0)))
 132               (dotimes (,i ,size)
 133                 (declare (fixnum ,i))
 134                 (setf (alien:deref ,storage ,i)
 135                       (char-code (char ,stored-obj ,i))))
 136            (setf (alien:deref ,storage ,size) 0))
 137          ,storage)))))
 138   #+sbcl
 139   (let ((size (gensym))
 140         (storage (gensym))
 141         (stored-obj (gensym))
 142         (i (gensym)))
 143     `(let ((,stored-obj ,obj))
 144        (etypecase ,stored-obj
 145          (null
 146           (sb-alien:sap-alien (sb-sys:int-sap 0) (* (sb-alien:unsigned 8))))
 147          (string
 148           (let* ((,size (length ,stored-obj))
 149                  (,storage (sb-alien:make-alien (sb-alien:unsigned 8) (1+ ,size))))
 150             (setq ,storage (sb-alien:cast ,storage (* (sb-alien:unsigned 8))))
 151             (locally
 152                 (declare (optimize (speed 3) (safety 0)))
 153               (dotimes (,i ,size)
 154                 (declare (fixnum ,i))
 155                 (setf (sb-alien:deref ,storage ,i)
 156                       (char-code (char ,stored-obj ,i))))
 157               (setf (sb-alien:deref ,storage ,size) 0))
 158             ,storage)))))
 159   #+(or openmcl digitool)
 160   (let ((stored-obj (gensym)))
 161     `(let ((,stored-obj ,obj))
 162        (if (null ,stored-obj)
 163            +null-cstring-pointer+
 164            (let ((ptr (new-ptr (1+ (length ,stored-obj)))))
 165              (ccl::%put-cstring ptr ,stored-obj)
 166              ptr))))
 167   )
 168
 169 ;; Either length or null-terminated-p must be non-nil
 170 (defmacro convert-from-foreign-string (obj &key
 171                                            length
 172                                            (locale :default)
 173                                            (null-terminated-p t))
 174   #+allegro
 175   (let ((stored-obj (gensym)))
 176     `(let ((,stored-obj ,obj))
 177        (if (zerop ,stored-obj)
 178            nil
 179            (if (eq ,locale :none)
 180                (fast-native-to-string ,stored-obj ,length)
 181                (values
 182                 (excl:native-to-string
 183                  ,stored-obj
 184                  ,@(when length (list :length length))
 185                  :truncate (not ,null-terminated-p)))))))
 186   #+lispworks
 187   (let ((stored-obj (gensym)))
 188     `(let ((,stored-obj ,obj))
 189        (if (fli:null-pointer-p ,stored-obj)
 190            nil
 191            (if (eq ,locale :none)
 192                (fast-native-to-string ,stored-obj ,length)
 193                (fli:convert-from-foreign-string
 194                 ,stored-obj
 195                 ,@(when length (list :length length))
 196                 :null-terminated-p ,null-terminated-p
 197                 :external-format '(:latin-1 :eol-style :lf))))))
 198   #+(or cmu scl)
 199   (let ((stored-obj (gensym)))
 200     `(let ((,stored-obj ,obj))
 201        (if (null-pointer-p ,stored-obj)
 202            nil
 203            (cmucl-naturalize-cstring (alien:alien-sap ,stored-obj)
 204                                      :length ,length
 205                                      :null-terminated-p ,null-terminated-p))))
 206
 207   #+sbcl
 208   (let ((stored-obj (gensym)))
 209     `(let ((,stored-obj ,obj))
 210        (if (null-pointer-p ,stored-obj)
 211             nil
 212             (sbcl-naturalize-cstring (sb-alien:alien-sap ,stored-obj)
 213                                      :length ,length
 214                                      :null-terminated-p ,null-terminated-p))))
 215   #+(or openmcl digitool)
 216   (declare (ignore null-terminated-p))
 217   #+(or openmcl digitool)
 218   (let ((stored-obj (gensym)))
 219     `(let ((,stored-obj ,obj))
 220        (if (ccl:%null-ptr-p ,stored-obj)
 221            nil
 222            #+digitool (ccl:%get-cstring
 223                                       ,stored-obj 0
 224                                       ,@(if length (list length) nil))
 225            #+openmcl ,@(if length
 226                            `((ccl:%str-from-ptr ,stored-obj ,length))
 227                            `((ccl:%get-cstring ,stored-obj))))))
 228   )
 229
 230
 231 (defmacro allocate-foreign-string (size &key (unsigned t))
 232   #+ignore
 233   (let ((array-def (gensym)))
 234     `(let ((,array-def (list 'alien:array 'c-call:char ,size)))
 235        (eval `(alien:cast (alien:make-alien ,,array-def)
 236                           ,(if ,unsigned
 237                                '(* (alien:unsigned 8))
 238                              '(* (alien:signed 8)))))))
 239
 240   #+(or cmu scl)
 241   `(alien:make-alien ,(if unsigned
 242                              '(alien:unsigned 8)
 243                              '(alien:signed 8))
 244     ,size)
 245
 246   #+sbcl
 247   `(sb-alien:make-alien ,(if unsigned
 248                              '(sb-alien:unsigned 8)
 249                              '(sb-alien:signed 8))
 250     ,size)
 251
 252   #+lispworks
 253   `(fli:allocate-foreign-object :type
 254                                 ,(if unsigned
 255                                      ''(:unsigned :char)
 256                                    :char)
 257                                 :nelems ,size)
 258   #+allegro
 259   (declare (ignore unsigned))
 260   #+allegro
 261   `(ff:allocate-fobject :char :c ,size)
 262   #+(or openmcl digitool)
 263   (declare (ignore unsigned))
 264   #+(or openmcl digitool)
 265   `(new-ptr ,size)
 266   )
 267
 268 (defun foreign-string-length (foreign-string)
 269   #+allegro `(ff:foreign-strlen ,foreign-string)
 270   #-allegro
 271   `(loop with size = 0
 272     until (char= (deref-array ,foreign-string '(:array :unsigned-char) size) #\Null)
 273     do (incf size)
 274     finally return size))
 275
 276
 277 (defmacro with-foreign-string ((foreign-string lisp-string) &body body)
 278   (let ((result (gensym)))
 279     `(let* ((,foreign-string (convert-to-foreign-string ,lisp-string))
 280             (,result (progn ,@body)))
 281       (declare (dynamic-extent ,foreign-string))
 282       (free-foreign-object ,foreign-string)
 283       ,result)))
 284
 285 (defmacro with-foreign-strings (bindings &body body)
 286   `(with-foreign-string ,(car bindings)
 287     ,@(if (cdr bindings)
 288           `((with-foreign-strings ,(cdr bindings) ,@body))
 289           body)))
 290
 291 ;; Modified from CMUCL's source to handle non-null terminated strings
 292 #+cmu
 293 (defun cmucl-naturalize-cstring (sap &key length (null-terminated-p t))
 294   (declare (type system:system-area-pointer sap))
 295   (locally
 296       (declare (optimize (speed 3) (safety 0)))
 297     (let ((null-terminated-length
 298            (when null-terminated-p
 299              (loop
 300                  for offset of-type fixnum upfrom 0
 301                  until (zerop (system:sap-ref-8 sap offset))
 302                  finally (return offset)))))
 303       (if length
 304           (if (and null-terminated-length
 305                    (> (the fixnum length) (the fixnum null-terminated-length)))
 306               (setq length null-terminated-length))
 307         (setq length null-terminated-length)))
 308     (let ((result (make-string length)))
 309       (kernel:copy-from-system-area sap 0
 310                                     result (* vm:vector-data-offset
 311                                               vm:word-bits)
 312                                     (* length vm:byte-bits))
 313       result)))
 314
 315 #+scl
 316 ;; kernel:copy-from-system-area doesn't work like it does on CMUCL or SBCL,
 317 ;; so have to iteratively copy from sap
 318 (defun cmucl-naturalize-cstring (sap &key length (null-terminated-p t))
 319   (declare (type system:system-area-pointer sap))
 320   (locally
 321       (declare (optimize (speed 3) (safety 0)))
 322     (let ((null-terminated-length
 323            (when null-terminated-p
 324              (loop
 325                  for offset of-type fixnum upfrom 0
 326                  until (zerop (system:sap-ref-8 sap offset))
 327                  finally (return offset)))))
 328       (if length
 329           (if (and null-terminated-length
 330                    (> (the fixnum length) (the fixnum null-terminated-length)))
 331               (setq length null-terminated-length))
 332         (setq length null-terminated-length)))
 333     (let ((result (make-string length)))
 334       (dotimes (i length)
 335         (declare (type fixnum i))
 336         (setf (char result i) (code-char (system:sap-ref-8 sap i))))
 337       result)))
 338
 339 #+(and sbcl (not sb-unicode))
 340 (defun sbcl-naturalize-cstring (sap &key length (null-terminated-p t))
 341   (declare (type sb-sys:system-area-pointer sap)
 342            (type (or null fixnum) length))
 343   (locally
 344    (declare (optimize (speed 3) (safety 0)))
 345    (let ((null-terminated-length
 346           (when null-terminated-p
 347             (loop
 348              for offset of-type fixnum upfrom 0
 349              until (zerop (sb-sys:sap-ref-8 sap offset))
 350              finally (return offset)))))
 351      (if length
 352          (if (and null-terminated-length
 353                   (> (the fixnum length) (the fixnum null-terminated-length)))
 354              (setq length null-terminated-length))
 355        (setq length null-terminated-length)))
 356    (let ((result (make-string length)))
 357        (funcall *system-copy-fn* sap 0 result +system-copy-offset+
 358                 (* length +system-copy-multiplier+))
 359        result)))
 360
 361 #+(and sbcl sb-unicode)
 362 (defun sbcl-naturalize-cstring (sap &key length (null-terminated-p t))
 363   (declare (type sb-sys:system-area-pointer sap)
 364            (type (or null fixnum) length))
 365   (locally
 366    (declare (optimize (speed 3) (safety 0)))
 367    (cond
 368     (null-terminated-p
 369      (let ((casted (sb-alien:cast (sb-alien:sap-alien sap (* char))
 370                                   #+sb-unicode sb-alien:utf8-string
 371                                   #-sb-unicode sb-alien:c-string)))
 372        (if length
 373            (copy-seq (subseq casted 0 length))
 374          (copy-seq casted))))
 375     (t
 376      (let ((result (make-string length)))
 377        ;; this will not work in sb-unicode
 378        (funcall *system-copy-fn* sap 0 result +system-copy-offset+
 379                 (* length +system-copy-multiplier+))
 380        result)))))
 381
 382
 383 (eval-when (:compile-toplevel :load-toplevel :execute)
 384    (def-function "strlen"
 385      ((str (* :unsigned-char)))
 386      :returning :unsigned-int))
 387
 388 (def-type char-ptr-def (* :unsigned-char))
 389
 390 #+(or (and allegro (not ics)) (and lispworks (not lispworks5) (not lispworks6)))
 391 (defun fast-native-to-string (s len)
 392   (declare (optimize (speed 3) (space 0) (safety 0) (compilation-speed 0))
 393            (type char-ptr-def s))
 394   (let* ((len (or len (strlen s)))
 395          (str (make-string len)))
 396     (declare (fixnum len)
 397              (type (simple-array #+lispworks base-char
 398                                  #-lispworks (signed-byte 8) (*)) str))
 399     (dotimes (i len str)
 400       (setf (aref str i)
 401         (uffi:deref-array s '(:array :char) i)))))
 402
 403 #+(or (and allegro ics) lispworks5 lispworks6)
 404 (defun fast-native-to-string (s len)
 405   (declare (optimize (speed 3) (space 0) (safety 0) (compilation-speed 0))
 406            (type char-ptr-def s))
 407   (let* ((len (or len (strlen s)))
 408          (str (make-string len)))
 409       (dotimes (i len str)
 410         (setf (schar str i) (code-char (uffi:deref-array s '(:array :unsigned-byte) i))))))