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