[cffi-devel] Re: [Sbcl-devel] encoding of alien c-string once again

28 Apr 2006

Wow, I'm nappy! :)
Juho Snellman wrote:
...
Thanks. There are some issues with this patch.

On non-windows platforms we need to naturalize a string to find
out the default external format, and after this change we need to
know the default external format to naturalize a string. But
that's easy to fix.

Excuse me, I do not have *nix.
May be use :latin-1 to naturalize string with external format?
...

Also, the patch can't be used stand-alone, since other SBCL
internals (e.g. pathname handling) assume that a c-string alien
type will be naturalized to a simple-base-string. What's the right
thing to do here? Add a new alien-type that does the conversion,
and leave c-string as-is, or change to change the behaviour of
c-string?

I suggest to replace [simple-]base-string to [simple-]string for all 
pathnames and alien functions calls with c-string.
Patch for win32 is attached.
...

I'm not sure that the interface is quite right. It seems probable
that at one point or another somebody will need to use multiple
external formats at once (ebcdic for pathnames and latin-1 for a
database connection, or something). So we might need to be able to
parametrize the external format to be used when defining the
types. As a silly example:

I do not think, that various encodings are necessary for a call of one 
alien function. But even in this case it is possible to use later 
transformation from (* (unsigned 8)) to c-string.
...
(define-alien-routine strdup (c-string :external-format :latin-1)
   (str (c-string :external-format :utf-8)))

Nice (for future)
...
(Hmm... maybe using a keyword parameter for this is excessive, and
an optional would do).

With keyword parameter more readably (IMHO)
Thanks!
-- 
WBR, Yaroslav Kavenchuk.

Index: sbcl/src/code/fd-stream.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/fd-stream.lisp,v
retrieving revision 1.99
diff -u -r1.99 fd-stream.lisp

--- sbcl/src/code/fd-stream.lisp	2006/03/22 11:39:27	1.99
+++ sbcl/src/code/fd-stream.lisp	2006/03/30 07:12:48
@@ -1887,8 +1887,12 @@
 ;;; Pick a name to use for the backup file for the :IF-EXISTS
 ;;; :RENAME-AND-DELETE and :RENAME options.
 (defun pick-backup-name (name)
-  (declare (type simple-base-string name))
-  (concatenate 'simple-base-string name ".bak"))
+  (declare (type #!-sb-unicode simple-base-string
+                 #!+sb-unicode simple-string
+                 name))
+  (concatenate #!-sb-unicode 'simple-base-string
+               #!+sb-unicode 'simple-string name
+               ".bak"))

 ;;; Ensure that the given arg is one of the given list of valid
 ;;; things. Allow the user to fix any problems.
Index: sbcl/src/code/filesys.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/filesys.lisp,v
retrieving revision 1.55
diff -u -r1.55 filesys.lisp
--- sbcl/src/code/filesys.lisp	2006/01/06 16:44:59	1.55
+++ sbcl/src/code/filesys.lisp	2006/03/30 07:12:48
@@ -55,9 +55,11 @@
   #!+sb-doc
   "Remove any occurrences of #\ from the string because we've already
    checked for whatever they may have protected."
-  (declare (type simple-base-string namestr)
+  (declare (type #!-sb-unicode simple-base-string
+                 #!+sb-unicode simple-string namestr)
            (type index start end))
-  (let* ((result (make-string (- end start) :element-type 'base-char))
+  (let* ((result (make-string (- end start) :element-type #!-sb-unicode 'base-char
+                                                          #!+sb-unicode 'character))
          (dst 0)
          (quoted nil))
     (do ((src start (1+ src)))
@@ -85,7 +87,8 @@
 (/show0 "filesys.lisp 86")

 (defun maybe-make-pattern (namestr start end)
-  (declare (type simple-base-string namestr)
+  (declare (type #!-sb-unicode simple-base-string
+                 #!+sb-unicode simple-string namestr)
            (type index start end))
   (if *ignore-wildcards*
       (subseq namestr start end)
@@ -149,7 +152,7 @@
                (let ((piece (first (pattern))))
                  (typecase piece
                    ((member :multi-char-wild) :wild)
-                   (simple-string piece)
+                   (#!-sb-unicode simple-string #!+sb-unicode string piece)
                    (t
                     (make-pattern (pattern))))))
               (t
@@ -158,7 +161,8 @@
 (/show0 "filesys.lisp 160")

 (defun extract-name-type-and-version (namestr start end)
-  (declare (type simple-base-string namestr)
+  (declare (type #!-sb-unicode simple-base-string
+                 #!+sb-unicode simple-string namestr)
            (type index start end))
   (let* ((last-dot (position #. namestr :start (1+ start) :end end
                              :from-end t)))
@@ -239,9 +243,11 @@
                             (:relative ""))
                           ""))
            (devstring (if (and device (not (eq device :unspecific)))
-                          (concatenate 'simple-base-string (string device) (string #:))
+                          (concatenate #!-sb-unicode 'simple-base-string
+                                       #!+sb-unicode 'simple-string (string device) (string #:))
                           ""))
-           (headstring (concatenate 'simple-base-string devstring dirstring)))
+           (headstring (concatenate #!-sb-unicode 'simple-base-string
+                                    #!+sb-unicode 'simple-string devstring dirstring)))
       (if directory
           (%enumerate-directories headstring (rest directory) pathname
                                   verify-existence follow-links nil function)
@@ -251,7 +257,7 @@
 (defun %enumerate-directories (head tail pathname verify-existence
                                follow-links nodes function
                                &aux (host (pathname-host pathname)))
-  (declare (simple-string head))
+  (declare (#!-sb-unicode simple-string #!+sb-unicode string head))
   (macrolet ((unix-xstat (name)
                `(if follow-links
                     (sb!unix:unix-stat ,name)
@@ -273,11 +279,14 @@
     (if tail
         (let ((piece (car tail)))
           (etypecase piece
-            (simple-string
-             (let ((head (concatenate 'base-string head piece)))
+            (#!-sb-unicode simple-string #!+sb-unicode string 
+             (let ((head (concatenate #!-sb-unicode 'base-string
+                                      #!+sb-unicode 'string head piece)))
                (with-directory-node-noted (head)
                  (%enumerate-directories
-                  (concatenate 'base-string head
+                  (concatenate #!-sb-unicode 'base-string
+                               #!+sb-unicode 'string
+                               head
                                (host-unparse-directory-separator host))
                   (cdr tail) pathname
                   verify-existence follow-links
@@ -294,7 +303,9 @@
                                      verify-existence follow-links
                                      nodes function)
              (dolist (name (ignore-errors (directory-lispy-filenames head)))
-               (let ((subdir (concatenate 'base-string head name)))
+               (let ((subdir (concatenate #!-sb-unicode 'base-string
+                                          #!+sb-unicode 'string
+                                          head name)))
                  (multiple-value-bind (res dev ino mode)
                      (unix-xstat subdir)
                    (declare (type (or fixnum null) mode))
@@ -305,14 +316,18 @@
                                           (eql (cdr dir) ino))
                                  (return t)))
                        (let ((nodes (cons (cons dev ino) nodes))
-                             (subdir (concatenate 'base-string subdir (host-unparse-directory-separator host))))
+                             (subdir (concatenate #!-sb-unicode 'base-string
+                                                  #!+sb-unicode 'string
+                                                  subdir (host-unparse-directory-separator host))))
                          (%enumerate-directories subdir tail pathname
                                                  verify-existence follow-links
                                                  nodes function))))))))
             ((or pattern (member :wild))
              (dolist (name (directory-lispy-filenames head))
                (when (or (eq piece :wild) (pattern-matches piece name))
-                 (let ((subdir (concatenate 'base-string head name)))
+                 (let ((subdir (concatenate #!-sb-unicode 'base-string
+                                            #!+sb-unicode 'string
+                                            head name)))
                    (multiple-value-bind (res dev ino mode)
                        (unix-xstat subdir)
                      (declare (type (or fixnum null) mode))
@@ -320,7 +335,9 @@
                                 (eql (logand mode sb!unix:s-ifmt)
                                      sb!unix:s-ifdir))
                        (let ((nodes (cons (cons dev ino) nodes))
-                             (subdir (concatenate 'base-string subdir (host-unparse-directory-separator host))))
+                             (subdir (concatenate #!-sb-unicode 'base-string
+                                                  #!+sb-unicode 'string
+                                                  subdir (host-unparse-directory-separator host))))
                          (%enumerate-directories subdir (rest tail) pathname
                                                  verify-existence follow-links
                                                  nodes function))))))))
@@ -330,9 +347,13 @@
                     :pathname pathname
                     :format-control "~@<invalid use of :UP after :ABSOLUTE.~@:>"))
            (with-directory-node-removed (head)
-             (let ((head (concatenate 'base-string head "..")))
+             (let ((head (concatenate #!-sb-unicode 'base-string
+                                      #!+sb-unicode 'string
+                                      head "..")))
                (with-directory-node-noted (head)
-                 (%enumerate-directories (concatenate 'base-string head (host-unparse-directory-separator host))
+                 (%enumerate-directories (concatenate #!-sb-unicode 'base-string
+                                                      #!+sb-unicode 'string
+                                                      head (host-unparse-directory-separator host))
                                          (rest tail) pathname
                                          verify-existence follow-links
                                          nodes function)))))
@@ -347,7 +368,7 @@

 ;;; Call FUNCTION on files.
 (defun %enumerate-files (directory pathname verify-existence function)
-  (declare (simple-string directory))
+  (declare (#!-sb-unicode simple-string #!+sb-unicode string directory))
   (/noshow0 "entering %ENUMERATE-FILES")
   (let ((name (%pathname-name pathname))
         (type (%pathname-type pathname))
@@ -355,7 +376,8 @@
     (/noshow0 "computed NAME, TYPE, and VERSION")
     (cond ((member name '(nil :unspecific))
            (/noshow0 "UNSPECIFIC, more or less")
-           (let ((directory (coerce directory 'base-string)))
+           (let ((directory (coerce directory #!-sb-unicode 'base-string
+                                              #!+sb-unicode 'string)))
              (when (or (not verify-existence)
                        (sb!unix:unix-file-kind directory))
                (funcall function directory))))
@@ -382,19 +404,26 @@
                           (components-match file-type type)
                           (components-match file-version version))
                  (funcall function
-                          (concatenate 'base-string
+                          (concatenate #!-sb-unicode 'base-string
+                                       #!+sb-unicode 'string
                                        directory
                                        complete-filename))))))
           (t
            (/noshow0 "default case")
-           (let ((file (concatenate 'base-string directory name)))
+           (let ((file (concatenate #!-sb-unicode 'base-string
+                                    #!+sb-unicode 'string
+                                    directory name)))
              (/noshow "computed basic FILE")
              (unless (or (null type) (eq type :unspecific))
                (/noshow0 "tweaking FILE for more-or-less-:UNSPECIFIC case")
-               (setf file (concatenate 'base-string file "." type)))
+               (setf file (concatenate #!-sb-unicode 'base-string
+                                       #!+sb-unicode 'string
+                                       file "." type)))
              (unless (member version '(nil :newest :wild :unspecific))
                (/noshow0 "tweaking FILE for more-or-less-:WILD case")
-               (setf file (concatenate 'base-string file "."
+               (setf file (concatenate #!-sb-unicode 'base-string
+                                       #!+sb-unicode 'string
+                                       file "."
                                        (quick-integer-to-string version))))
              (/noshow0 "finished possibly tweaking FILE")
              (when (or (not verify-existence)
@@ -557,5 +586,6 @@
 
 ;;; (This is an ANSI Common Lisp function.)
 (defun user-homedir-pathname (&optional host)
+  #!+sb-doc
   "Return the home directory of the user as a pathname."
   (declare (ignore host))
@@ -807,8 +826,8 @@
     (if (and xn yn)
         (let ((res (string-lessp xn yn)))
           (cond ((not res) nil)
-                ((= res (length (the simple-string xn))) t)
-                ((= res (length (the simple-string yn))) nil)
+                ((= res (length (the #!-sb-unicode simple-string #!+sb-unicode string xn))) t)
+                ((= res (length (the #!-sb-unicode simple-string #!+sb-unicode string yn))) nil)
                 (t t)))
         xn)))
 
@@ -831,7 +850,8 @@
                                :device (pathname-device pathname)
                                :directory (subseq dir 0 i))))
                  (unless (probe-file newpath)
-                   (let ((namestring (coerce (namestring newpath) 'base-string)))
+                   (let ((namestring (coerce (namestring newpath) #!-sb-unicode 'base-string
+                                                                  #!+sb-unicode 'string)))
                      (when verbose
                        (format *standard-output*
                                "~&creating directory: ~A~%"
Index: sbcl/src/code/unix.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/unix.lisp,v
retrieving revision 1.64
diff -u -r1.64 unix.lisp
--- sbcl/src/code/unix.lisp	2006/01/18 12:57:48	1.64
+++ sbcl/src/code/unix.lisp	2006/03/30 11:00:53
@@ -47,7 +47,7 @@
 
 ;;;; Lisp types used by syscalls

-(deftype unix-pathname () #!-win32 'simple-base-string #!+win32 'simple-string)
+(deftype unix-pathname () #!-sb-unicode 'simple-base-string #!+sb-unicode 'simple-string)
 (deftype unix-fd () `(integer 0 ,most-positive-fixnum))

 (deftype unix-file-mode () '(unsigned-byte 32))
@@ -864,7 +864,7 @@
 (defun unix-file-kind (name &optional check-for-links)
   #!+sb-doc
   "Return either :FILE, :DIRECTORY, :LINK, :SPECIAL, or NIL."
-  (declare (simple-base-string name))
+  (declare (#!-sb-unicode simple-base-string #!+sb-unicode simple-string name))
   (multiple-value-bind (res dev ino mode)
       (if check-for-links (unix-lstat name) (unix-stat name))
     (declare (type (or fixnum null) mode)
@@ -890,7 +890,7 @@
 ;;; paths have been converted to absolute paths, so we don't need to
 ;;; try to handle any more generality than that.
 (defun unix-resolve-links (pathname)
-  (declare (type simple-base-string pathname))
+  (declare (type #!-sb-unicode simple-base-string #!+sb-unicode simple-string pathname))
   ;; KLUDGE: The Win32 platform doesn't have symbolic links, so
   ;; short-cut this computation (and the check for being an absolute
   ;; unix pathname...)
@@ -930,7 +930,9 @@
                                                         :from-end t)))
                                  (dir (subseq pathname 0 dir-len)))
                             (/noshow dir)
-                            (concatenate 'base-string dir link))
+                            (concatenate #!-sb-unicode 'base-string
+                                         #!+sb-unicode 'string
+                                         dir link))
                           link))))
                 (if (unix-file-kind new-pathname)
                     (setf pathname new-pathname)
@@ -946,9 +948,12 @@
             (push pathname previous-pathnames))))

 (defun unix-simplify-pathname (src)
-  (declare (type simple-base-string src))
+  (declare (type #!-sb-unicode simple-base-string
+                 #!+sb-unicode simple-string
+                 src))
   (let* ((src-len (length src))
-         (dst (make-string src-len :element-type 'base-char))
+         (dst (make-string src-len :element-type #!-sb-unicode 'base-char
+                                                 #!+sb-unicode 'character))
          (dst-len 0)
          (dots 0)
          (last-slash nil))
@@ -1023,7 +1028,8 @@
              (if prev-prev-slash
                  (setf dst-len (1+ prev-prev-slash))
                  (return-from unix-simplify-pathname
-                   (coerce "./" 'simple-base-string))))))))
+                   (coerce "./" #!-sb-unicode 'simple-base-string
+                                #!+sb-unicode 'simple-string))))))))
     (cond ((zerop dst-len)
            "./")
           ((= dst-len src-len)
Index: sbcl/src/code/win32-pathname.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/win32-pathname.lisp,v
retrieving revision 1.1
diff -u -r1.1 win32-pathname.lisp
--- sbcl/src/code/win32-pathname.lisp	2006/01/06 16:44:59	1.1
+++ sbcl/src/code/win32-pathname.lisp	2006/03/30 07:12:48
@@ -12,7 +12,7 @@
 (in-package "SB!IMPL")

 (defun extract-device (namestr start end)
-  (declare (type simple-base-string namestr)
+  (declare (type #!-sb-unicode simple-base-string #!+sb-unicode simple-string namestr)
            (type index start end))
   (if (and (>= end (+ start 2))
            (alpha-char-p (char namestr start))
@@ -21,7 +21,7 @@
       (values nil start)))

 (defun split-at-slashes-and-backslashes (namestr start end)
-  (declare (type simple-base-string namestr)
+  (declare (type #!-sb-unicode simple-base-string #!+sb-unicode simple-string namestr)
            (type index start end))
   (let ((absolute (and (/= start end)
                        (or (char= (schar namestr start) #/)
@@ -44,7 +44,7 @@
 (defun parse-win32-namestring (namestring start end)
   (declare (type simple-string namestring)
            (type index start end))
-  (setf namestring (coerce namestring 'simple-base-string))
+  (setf namestring (coerce namestring #!-sb-unicode 'simple-base-string #!+sb-unicode 'simple-string))
   (multiple-value-bind (device new-start)
       (extract-device namestring start end)
     (multiple-value-bind (absolute pieces)
@@ -100,7 +100,7 @@
 (defun parse-native-win32-namestring (namestring start end)
   (declare (type simple-string namestring)
            (type index start end))
-  (setf namestring (coerce namestring 'simple-base-string))
+  (setf namestring (coerce namestring #!-sb-unicode 'simple-base-string #!+sb-unicode 'simple-string))
   (multiple-value-bind (device new-start)
       (extract-device namestring start end)
     (multiple-value-bind (absolute ranges)
@@ -187,7 +187,7 @@
               (t
                (error "invalid pattern piece: ~S" piece))))))
        (apply #'concatenate
-              'simple-base-string
+              #!-sb-unicode 'simple-base-string #!+sb-unicode 'simple-string
               (strings))))))

 (defun unparse-win32-directory-list (directory)
@@ -213,7 +213,7 @@
            (pieces "\"))
           (t
            (error "invalid directory component: ~S" dir)))))
-    (apply #'concatenate 'simple-base-string (pieces))))
+    (apply #'concatenate #!-sb-unicode 'simple-base-string #!+sb-unicode 'simple-string (pieces))))

 (defun unparse-win32-directory (pathname)
   (declare (type pathname pathname))
@@ -246,11 +246,11 @@
             (error "type component can't have a #. inside: ~S" pathname)))
         (strings ".")
         (strings (unparse-unix-piece type))))
-    (apply #'concatenate 'simple-base-string (strings))))
+    (apply #'concatenate #!-sb-unicode 'simple-base-string #!+sb-unicode 'simple-string (strings))))

 (defun unparse-win32-namestring (pathname)
   (declare (type pathname pathname))
-  (concatenate 'simple-base-string
+  (concatenate #!-sb-unicode 'simple-base-string #!+sb-unicode 'simple-string
                (unparse-win32-device pathname)
                (unparse-win32-directory pathname)
                (unparse-win32-file pathname)))
@@ -284,7 +284,7 @@
              (error "non-STRING type in NATIVE-NAMESTRING: ~S" name))
            (write-char #. s)
            (write-string type s))))
-     'simple-base-string)))
+     #!-sb-unicode 'simple-base-string #!+sb-unicode 'simple-string)))

 ;;; FIXME.
 (defun unparse-win32-enough (pathname defaults)
@@ -332,7 +332,7 @@
         (when type-needed
           (when (or (null pathname-type) (eq pathname-type :unspecific))
             (lose))
-          (when (typep pathname-type 'simple-base-string)
+          (when (typep pathname-type #!-sb-unicode 'simple-base-string #!+sb-unicode 'simple-string)
             (when (position #. pathname-type)
               (error "type component can't have a #. inside: ~S" pathname)))
           (strings ".")

    

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

[cffi-devel] Re: [Sbcl-devel] encoding of alien c-string once again