27 Apr
2006
27 Apr
'06
7:59 p.m.
[ CC:d to cffi-devel, in case the FFI experts have any opinions on external-format handling. ]
Yaroslav Kavenchuk kavenchuk@jenty.by writes:
I have impudence to offer dear community patch for non-ascii encoding of alien c-string once again.
(Maybe me have forgotten? :)
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.
* 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'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:
(define-alien-routine strdup (c-string :external-format :latin-1) (str (c-string :external-format :utf-8)))
(Hmm... maybe using a keyword parameter for this is excessive, and an optional would do).
James, Luis, would something like this be useful for CFFI? Would the proposed interface work for you? Any opinions on the c-string issue mentioned above?
A patch implementing this functionality (including Yaroslav's work): http://jsnell.iki.fi/tmp/alien-again.diff
--
Juho Snellman
27 Apr
27 Apr
8:27 p.m.
New subject: [cffi-devel] Re: [Sbcl-devel] encoding of alien c-string once again
Juho Snellman jsnell@iki.fi writes:
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:
(define-alien-routine strdup (c-string :external-format :latin-1) (str (c-string :external-format :utf-8)))
I agree; this is what the half-finished patch I have adding support for string encodings to CFFI looks like as well:
(defcfun "strdup" (:string :encoding :latin-1) (str (:string :encoding :utf-8)))
James, Luis, would something like this be useful for CFFI? Would the proposed interface work for you? Any opinions on the c-string issue mentioned above?
CFFI wants to operate at a lower level than this. The sort of interface that would be really useful for us would be versions of STRING-TO-OCTETS and OCTETS-TO-STRING that operate on SAPs instead of octet vectors. IIRC, there are unexported functions in SBCL for doing this for the various encodings, but nothing exported.
James
28 Apr
28 Apr
7:01 a.m.
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 ".")
22 May
22 May
9:52 p.m.
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.
Fixed (see alien-c-string.patch)
- 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?
Partially fixed (see non-ascii-pathnames.patch). Need help on non-windows platforms.
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:
(define-alien-routine strdup (c-string :external-format :latin-1) (str (c-string :external-format :utf-8)))
Fixed (see alien-c-string.patch). (Maybe now redefine utf8-string as (c-string :external-format :utf8)?)
Well, what now?
--
WBR, Yaroslav Kavenchuk.
Index: src/code/early-alieneval.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/early-alieneval.lisp,v
retrieving revision 1.3
diff -u -r1.3 early-alieneval.lisp
--- src/code/early-alieneval.lisp 15 Oct 2005 13:32:32 -0000 1.3
+++ src/code/early-alieneval.lisp 22 May 2006 21:25:05 -0000
@@ -26,3 +26,6 @@
;;; Lisp idiom for C's return type "void" (which is likely
;;; why it's set when when translating return values)
(defvar *values-type-okay* nil)
+
+#!+sb-unicode
+(defvar *alien-external-format* nil)
Index: src/code/host-c-call.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/host-c-call.lisp,v
retrieving revision 1.8
diff -u -r1.8 host-c-call.lisp
--- src/code/host-c-call.lisp 13 Jan 2006 11:32:46 -0000 1.8
+++ src/code/host-c-call.lisp 22 May 2006 21:25:25 -0000
@@ -11,28 +11,36 @@
(/show0 "host-c-call.lisp 12")
-(define-alien-type-class (c-string :include pointer :include-args (to)))
+(define-alien-type-class (c-string :include pointer :include-args (to))
+ #!+sb-unicode
+ (external-format (alien-external-format) :type keyword))
-(define-alien-type-translator c-string ()
+(define-alien-type-translator c-string #!-sb-unicode ()
+ #!+sb-unicode (&key (external-format (alien-external-format)))
(make-alien-c-string-type
- :to (parse-alien-type 'char (sb!kernel:make-null-lexenv))))
+ :to (parse-alien-type 'char (sb!kernel:make-null-lexenv))
+ #!+sb-unicode :external-format #!+sb-unicode external-format))
+
(define-alien-type-method (c-string :unparse) (type)
- (declare (ignore type))
- 'c-string)
+ #!-sb-unicode (declare (ignore type))
+ #!-sb-unicode 'c-string
+ #!+sb-unicode
+ (list 'c-string :external-format (alien-c-string-type-external-format type)))
(define-alien-type-method (c-string :lisp-rep) (type)
(declare (ignore type))
'(or simple-string null (alien (* char))))
(define-alien-type-method (c-string :naturalize-gen) (type alien)
- (declare (ignore type))
+ #!-sb-unicode (declare (ignore type))
`(if (zerop (sap-int ,alien))
nil
- (%naturalize-c-string ,alien)))
+ (%naturalize-c-string ,alien
+ #!+sb-unicode (alien-c-string-type-external-format ,type))))
(define-alien-type-method (c-string :deport-gen) (type value)
- (declare (ignore type))
+ #!-sb-unicode (declare (ignore type))
`(etypecase ,value
(null (int-sap 0))
((alien (* char)) (alien-sap ,value))
@@ -62,9 +70,12 @@
;; we're taking the SAP of a immediately discarded temporary -> the
;; conservativeness doesn't protect us.
;; -- JES, 2006-01-13
- (simple-string (vector-sap (coerce ,value 'simple-base-string)))))
+ (simple-string (vector-sap #!-sb-unicode (coerce ,value 'simple-base-string)
+ #!+sb-unicode (%deport-c-string ,value
+ (alien-c-string-type-external-format ,type))))))
+
-(/show0 "host-c-call.lisp 42")
+(/show0 "host-c-call.lisp 78")
(define-alien-type-class (utf8-string :include pointer :include-args (to)))
Index: src/code/octets.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/octets.lisp,v
retrieving revision 1.13
diff -u -r1.13 octets.lisp
--- src/code/octets.lisp 22 Mar 2006 11:39:27 -0000 1.13
+++ src/code/octets.lisp 22 May 2006 21:25:28 -0000
@@ -641,16 +641,18 @@
(defun default-external-format ()
(or *default-external-format*
- (let ((external-format #!-win32 (intern (or (sb!alien:alien-funcall
- (extern-alien
- "nl_langinfo"
- (function c-string int))
- sb!unix:codeset)
- "LATIN-1")
- "KEYWORD")
- #!+win32
- #!+sb-unicode (sb!win32::ansi-codepage)
- #!-sb-unicode :LATIN-1))
+ (let ((external-format
+ #!-win32
+ (let ((*default-external-format* :LATIN-1))
+ (intern (or (sb!alien:alien-funcall
+ (extern-alien "nl_langinfo"
+ (function c-string int))
+ sb!unix:codeset)
+ "LATIN-1")
+ "KEYWORD"))
+ #!+win32
+ #!+sb-unicode (sb!win32::ansi-codepage)
+ #!-sb-unicode :LATIN-1))
(/show0 "cold-printing defaulted external-format:")
#!+sb-show
(cold-print external-format)
@@ -673,14 +675,14 @@
;;; FIXME: OAOOM here vrt. DEFINE-EXTERNAL-FORMAT in fd-stream.lisp
(defparameter *external-format-functions*
'(((:ascii :us-ascii :ansi_x3.4-1968 :iso-646 :iso-646-us :|646|)
- ascii->string-aref string->ascii)
+ ascii->string-aref string->ascii ascii->string-sap-ref-8)
((:latin1 :latin-1 :iso-8859-1 :iso8859-1)
- latin1->string-aref string->latin1)
+ latin1->string-aref string->latin1 latin1->string-sap-ref-8)
#!+sb-unicode
((:latin9 :latin-9 :iso-8859-15 :iso8859-15)
- latin9->string-aref string->latin9)
+ latin9->string-aref string->latin9 latin9->string-sap-ref-8)
((:utf8 :utf-8)
- utf8->string-aref string->utf8)))
+ utf8->string-aref string->utf8 utf8->string-sap-ref-8)))
(defun external-formats-funs (external-format)
(when (eql external-format :default)
Index: src/code/target-c-call.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/target-c-call.lisp,v
retrieving revision 1.16
diff -u -r1.16 target-c-call.lisp
--- src/code/target-c-call.lisp 13 Jan 2006 11:32:46 -0000 1.16
+++ src/code/target-c-call.lisp 22 May 2006 21:25:29 -0000
@@ -46,17 +46,38 @@
;;; so the string can't move by virtue of pointers to it from
;;; outside the heap. Other platforms will access the lisp string
;;; through the GC-safe interior pointer. -- JES, 2006-01-13
-(defun %naturalize-c-string (sap)
+(eval-when (#+sb-xc :compile-toplevel)
+
+(defun alien-external-format () :LATIN-1))
+
+(eval-when (#-sb-xc :compile-toplevel :execute :load-toplevel)
+
+(defun alien-external-format ()
+ (or *alien-external-format*
+ (setf *alien-external-format* (sb!impl::default-external-format)))))
+
+(defun %naturalize-c-string (sap #!+sb-unicode external-format)
(declare (type system-area-pointer sap))
(locally
(declare (optimize (speed 3) (safety 0)))
(let ((length (loop for offset of-type fixnum upfrom 0
until (zerop (sap-ref-8 sap offset))
finally (return offset))))
+ #!+sb-unicode
+ (funcall (symbol-function (third (sb!impl::external-formats-funs external-format)))
+ sap 0 length)
+ #!-sb-unicode
(let ((result (make-string length :element-type 'base-char)))
(sb!kernel:copy-ub8-from-system-area sap 0 result 0 length)
result))))
+#!+sb-unicode
+(defun %deport-c-string (string external-format)
+ (declare (type simple-string string))
+ (sb!impl::string-to-octets string
+ :external-format external-format
+ :null-terminate t))
+
(defun %naturalize-utf8-string (sap)
(declare (type system-area-pointer sap))
(locally
Index: src/code/external-formats/enc-cyr.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/external-formats/enc-cyr.lisp,v
retrieving revision 1.3
diff -u -r1.3 enc-cyr.lisp
--- src/code/external-formats/enc-cyr.lisp 28 Jan 2006 08:52:35 -0000 1.3
+++ src/code/external-formats/enc-cyr.lisp 22 May 2006 21:25:47 -0000
@@ -161,7 +161,7 @@
(instantiate-octets-definition define-koi8-r->string)
(push '((:koi8-r :|koi8-r|)
- koi8-r->string-aref string->koi8-r)
+ koi8-r->string-aref string->koi8-r koi8-r->string-sap-ref-8)
*external-format-functions*)
(define-external-format (:koi8-r :|koi8-r|)
@@ -336,7 +336,7 @@
(instantiate-octets-definition define-koi8-u->string)
(push '((:koi8-u :|koi8-u|)
- koi8-u->string-aref string->koi8-u)
+ koi8-u->string-aref string->koi8-u koi8-u->string-sap-ref-8)
*external-format-functions*)
(define-external-format (:koi8-u :|koi8-u|)
@@ -506,7 +506,7 @@
(instantiate-octets-definition define-x-mac-cyrillic->string)
(push '((:x-mac-cyrillic :|x-mac-cyrillic|)
- x-mac-cyrillic->string-aref string->x-mac-cyrillic)
+ x-mac-cyrillic->string-aref string->x-mac-cyrillic x-mac-cyrillic->string-sap-ref-8)
*external-format-functions*)
(define-external-format (:x-mac-cyrillic :|x-mac-cyrillic|)
Index: src/code/external-formats/enc-dos.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/external-formats/enc-dos.lisp,v
retrieving revision 1.3
diff -u -r1.3 enc-dos.lisp
--- src/code/external-formats/enc-dos.lisp 28 Jan 2006 08:52:35 -0000 1.3
+++ src/code/external-formats/enc-dos.lisp 22 May 2006 21:25:57 -0000
@@ -161,7 +161,7 @@
(instantiate-octets-definition define-cp437->string)
(push '((:cp437 :|cp437|)
- cp437->string-aref string->cp437)
+ cp437->string-aref string->cp437 cp437->string-sap-ref-8)
*external-format-functions*)
(define-external-format (:cp437 :|cp437|)
@@ -336,7 +336,7 @@
(instantiate-octets-definition define-cp850->string)
(push '((:cp850 :|cp850|)
- cp850->string-aref string->cp850)
+ cp850->string-aref string->cp850 cp850->string-sap-ref-8)
*external-format-functions*)
(define-external-format (:cp850 :|cp850|)
@@ -511,7 +511,7 @@
(instantiate-octets-definition define-cp852->string)
(push '((:cp852 :|cp852|)
- cp852->string-aref string->cp852)
+ cp852->string-aref string->cp852 cp852->string-sap-ref-8)
*external-format-functions*)
(define-external-format (:cp852 :|cp852|)
@@ -686,7 +686,7 @@
(instantiate-octets-definition define-cp855->string)
(push '((:cp855 :|cp855|)
- cp855->string-aref string->cp855)
+ cp855->string-aref string->cp855 cp855->string-sap-ref-8)
*external-format-functions*)
(define-external-format (:cp855 :|cp855|)
@@ -860,7 +860,7 @@
(instantiate-octets-definition define-cp857->string)
(push '((:cp857 :|cp857|)
- cp857->string-aref string->cp857)
+ cp857->string-aref string->cp857 cp857->string-sap-ref-8)
*external-format-functions*)
(define-external-format (:cp857 :|cp857|)
@@ -1035,7 +1035,7 @@
(instantiate-octets-definition define-cp860->string)
(push '((:cp860 :|cp860|)
- cp860->string-aref string->cp860)
+ cp860->string-aref string->cp860 cp860->string-sap-ref-8)
*external-format-functions*)
(define-external-format (:cp860 :|cp860|)
@@ -1210,7 +1210,7 @@
(instantiate-octets-definition define-cp861->string)
(push '((:cp861 :|cp861|)
- cp861->string-aref string->cp861)
+ cp861->string-aref string->cp861 cp861->string-sap-ref-8)
*external-format-functions*)
(define-external-format (:cp861 :|cp861|)
@@ -1385,7 +1385,7 @@
(instantiate-octets-definition define-cp862->string)
(push '((:cp862 :|cp862|)
- cp862->string-aref string->cp862)
+ cp862->string-aref string->cp862 cp862->string-sap-ref-8)
*external-format-functions*)
(define-external-format (:cp862 :|cp862|)
@@ -1560,7 +1560,7 @@
(instantiate-octets-definition define-cp863->string)
(push '((:cp863 :|cp863|)
- cp863->string-aref string->cp863)
+ cp863->string-aref string->cp863 cp863->string-sap-ref-8)
*external-format-functions*)
(define-external-format (:cp863 :|cp863|)
@@ -1732,7 +1732,7 @@
(instantiate-octets-definition define-cp864->string)
(push '((:cp864 :|cp864|)
- cp864->string-aref string->cp864)
+ cp864->string-aref string->cp864 cp864->string-sap-ref-8)
*external-format-functions*)
(define-external-format (:cp864 :|cp864|)
@@ -1907,7 +1907,7 @@
(instantiate-octets-definition define-cp865->string)
(push '((:cp865 :|cp865|)
- cp865->string-aref string->cp865)
+ cp865->string-aref string->cp865 cp865->string-sap-ref-8)
*external-format-functions*)
(define-external-format (:cp865 :|cp865|)
@@ -2082,7 +2082,7 @@
(instantiate-octets-definition define-cp866->string)
(push '((:cp866 :|cp866|)
- cp866->string-aref string->cp866)
+ cp866->string-aref string->cp866 cp866->string-sap-ref-8)
*external-format-functions*)
(define-external-format (:cp866 :|cp866|)
@@ -2257,7 +2257,7 @@
(instantiate-octets-definition define-cp869->string)
(push '((:cp869 :|cp869|)
- cp869->string-aref string->cp869)
+ cp869->string-aref string->cp869 cp869->string-sap-ref-8)
*external-format-functions*)
(define-external-format (:cp869 :|cp869|)
@@ -2431,7 +2431,7 @@
(instantiate-octets-definition define-cp874->string)
(push '((:cp874 :|cp874|)
- cp874->string-aref string->cp874)
+ cp874->string-aref string->cp874 cp874->string-sap-ref-8)
*external-format-functions*)
(define-external-format (:cp874 :|cp874|)
Index: src/code/external-formats/enc-iso.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/external-formats/enc-iso.lisp,v
retrieving revision 1.4
diff -u -r1.4 enc-iso.lisp
--- src/code/external-formats/enc-iso.lisp 28 Jan 2006 08:52:35 -0000 1.4
+++ src/code/external-formats/enc-iso.lisp 22 May 2006 21:26:01 -0000
@@ -90,7 +90,7 @@
(instantiate-octets-definition define-iso-8859-2->string)
(push '((:iso-8859-2 :|iso-8859-2| :latin-2 :|latin-2|)
- iso-8859-2->string-aref string->iso-8859-2)
+ iso-8859-2->string-aref string->iso-8859-2 iso-8859-2->string-sap-ref-8)
*external-format-functions*)
(define-external-format (:iso-8859-2 :|iso-8859-2| :latin-2 :|latin-2|)
@@ -172,7 +172,7 @@
(instantiate-octets-definition define-iso-8859-3->string)
(push '((:iso-8859-3 :|iso-8859-3| :latin-3 :|latin-3|)
- iso-8859-3->string-aref string->iso-8859-3)
+ iso-8859-3->string-aref string->iso-8859-3 iso-8859-3->string-sap-ref-8)
*external-format-functions*)
(define-external-format (:iso-8859-3 :|iso-8859-3| :latin-3 :|latin-3|)
@@ -269,7 +269,7 @@
(instantiate-octets-definition define-iso-8859-4->string)
(push '((:iso-8859-4 :|iso-8859-4| :latin-4 :|latin-4|)
- iso-8859-4->string-aref string->iso-8859-4)
+ iso-8859-4->string-aref string->iso-8859-4 iso-8859-4->string-sap-ref-8)
*external-format-functions*)
(define-external-format (:iso-8859-4 :|iso-8859-4| :latin-4 :|latin-4|)
@@ -410,7 +410,7 @@
(instantiate-octets-definition define-iso-8859-5->string)
(push '((:iso-8859-5 :|iso-8859-5|)
- iso-8859-5->string-aref string->iso-8859-5)
+ iso-8859-5->string-aref string->iso-8859-5 iso-8859-5->string-sap-ref-8)
*external-format-functions*)
(define-external-format (:iso-8859-5 :|iso-8859-5|)
@@ -550,7 +550,7 @@
(instantiate-octets-definition define-iso-8859-6->string)
(push '((:iso-8859-6 :|iso-8859-6|)
- iso-8859-6->string-aref string->iso-8859-6)
+ iso-8859-6->string-aref string->iso-8859-6 iso-8859-6->string-sap-ref-8)
*external-format-functions*)
(define-external-format (:iso-8859-6 :|iso-8859-6|)
@@ -677,7 +677,7 @@
(instantiate-octets-definition define-iso-8859-7->string)
(push '((:iso-8859-7 :|iso-8859-7|)
- iso-8859-7->string-aref string->iso-8859-7)
+ iso-8859-7->string-aref string->iso-8859-7 iso-8859-7->string-sap-ref-8)
*external-format-functions*)
(define-external-format (:iso-8859-7 :|iso-8859-7|)
@@ -793,7 +793,7 @@
(instantiate-octets-definition define-iso-8859-8->string)
(push '((:iso-8859-8 :|iso-8859-8|)
- iso-8859-8->string-aref string->iso-8859-8)
+ iso-8859-8->string-aref string->iso-8859-8 iso-8859-8->string-sap-ref-8)
*external-format-functions*)
(define-external-format (:iso-8859-8 :|iso-8859-8|)
@@ -846,7 +846,7 @@
(instantiate-octets-definition define-iso-8859-9->string)
(push '((:iso-8859-9 :|iso-8859-9| :latin-5 :|latin-5|)
- iso-8859-9->string-aref string->iso-8859-9)
+ iso-8859-9->string-aref string->iso-8859-9 iso-8859-9->string-sap-ref-8)
*external-format-functions*)
(define-external-format (:iso-8859-9 :|iso-8859-9| :latin-5 :|latin-5|)
@@ -939,7 +939,7 @@
(instantiate-octets-definition define-iso-8859-10->string)
(push '((:iso-8859-10 :|iso-8859-10| :latin-6 :|latin-6|)
- iso-8859-10->string-aref string->iso-8859-10)
+ iso-8859-10->string-aref string->iso-8859-10 iso-8859-10->string-sap-ref-8)
*external-format-functions*)
(define-external-format (:iso-8859-10 :|iso-8859-10| :latin-6 :|latin-6|)
@@ -1081,7 +1081,7 @@
(instantiate-octets-definition define-iso-8859-11->string)
(push '((:iso-8859-11 :|iso-8859-11|)
- iso-8859-11->string-aref string->iso-8859-11)
+ iso-8859-11->string-aref string->iso-8859-11 iso-8859-11->string-sap-ref-8)
*external-format-functions*)
(define-external-format (:iso-8859-11 :|iso-8859-11|)
@@ -1184,7 +1184,7 @@
(instantiate-octets-definition define-iso-8859-13->string)
(push '((:iso-8859-13 :|iso-8859-13| :latin-7 :|latin-7|)
- iso-8859-13->string-aref string->iso-8859-13)
+ iso-8859-13->string-aref string->iso-8859-13 iso-8859-13->string-sap-ref-8)
*external-format-functions*)
(define-external-format (:iso-8859-13 :|iso-8859-13| :latin-7 :|latin-7|)
@@ -1262,7 +1262,7 @@
(instantiate-octets-definition define-iso-8859-14->string)
(push '((:iso-8859-14 :|iso-8859-14| :latin-8 :|latin-8|)
- iso-8859-14->string-aref string->iso-8859-14)
+ iso-8859-14->string-aref string->iso-8859-14 iso-8859-14->string-sap-ref-8)
*external-format-functions*)
(define-external-format (:iso-8859-14 :|iso-8859-14| :latin-8 :|latin-8|)
Index: src/code/external-formats/enc-win.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/external-formats/enc-win.lisp,v
retrieving revision 1.3
diff -u -r1.3 enc-win.lisp
--- src/code/external-formats/enc-win.lisp 28 Jan 2006 08:52:35 -0000 1.3
+++ src/code/external-formats/enc-win.lisp 22 May 2006 21:26:08 -0000
@@ -112,7 +112,7 @@
(instantiate-octets-definition define-cp1250->string)
(push '((:cp1250 :|cp1250| :windows-1250 :|windows-1250|)
- cp1250->string-aref string->cp1250)
+ cp1250->string-aref string->cp1250 cp1250->string-sap-ref-8)
*external-format-functions*)
(define-external-format (:cp1250 :|cp1250| :windows-1250 :|windows-1250|)
@@ -272,7 +272,7 @@
(instantiate-octets-definition define-cp1251->string)
(push '((:cp1251 :|cp1251| :windows-1251 :|windows-1251|)
- cp1251->string-aref string->cp1251)
+ cp1251->string-aref string->cp1251 cp1251->string-sap-ref-8)
*external-format-functions*)
(define-external-format (:cp1251 :|cp1251| :windows-1251 :|windows-1251|)
@@ -351,7 +351,7 @@
(instantiate-octets-definition define-cp1252->string)
(push '((:cp1252 :|cp1252| :windows-1252 :|windows-1252|)
- cp1252->string-aref string->cp1252)
+ cp1252->string-aref string->cp1252 cp1252->string-sap-ref-8)
*external-format-functions*)
(define-external-format (:cp1252 :|cp1252| :windows-1252 :|windows-1252|)
@@ -505,7 +505,7 @@
(instantiate-octets-definition define-cp1253->string)
(push '((:cp1253 :|cp1253| :windows-1253 :|windows-1253|)
- cp1253->string-aref string->cp1253)
+ cp1253->string-aref string->cp1253 cp1253->string-sap-ref-8)
*external-format-functions*)
(define-external-format (:cp1253 :|cp1253| :windows-1253 :|windows-1253|)
@@ -590,7 +590,7 @@
(instantiate-octets-definition define-cp1254->string)
(push '((:cp1254 :|cp1254| :windows-1254 :|windows-1254|)
- cp1254->string-aref string->cp1254)
+ cp1254->string-aref string->cp1254 cp1254->string-sap-ref-8)
*external-format-functions*)
(define-external-format (:cp1254 :|cp1254|)
@@ -736,7 +736,7 @@
(instantiate-octets-definition define-cp1255->string)
(push '((:cp1255 :|cp1255| :windows-1255 :|windows-1255|)
- cp1255->string-aref string->cp1255)
+ cp1255->string-aref string->cp1255 cp1255->string-sap-ref-8)
*external-format-functions*)
(define-external-format (:cp1255 :|cp1255| :windows-1255 :|windows-1255|)
@@ -868,7 +868,7 @@
(instantiate-octets-definition define-cp1256->string)
(push '((:cp1256 :|cp1256| :windows-1256 :|windows-1256|)
- cp1256->string-aref string->cp1256)
+ cp1256->string-aref string->cp1256 cp1256->string-sap-ref-8)
*external-format-functions*)
(define-external-format (:cp1256 :|cp1256|)
@@ -1002,7 +1002,7 @@
(instantiate-octets-definition define-cp1257->string)
(push '((:cp1257 :|cp1257| :windows-1257 :|windows-1257|)
- cp1257->string-aref string->cp1257)
+ cp1257->string-aref string->cp1257 cp1257->string-sap-ref-8)
*external-format-functions*)
(define-external-format (:cp1257 :|cp1257| :windows-1257 :|windows-1257|)
@@ -1095,7 +1095,7 @@
(instantiate-octets-definition define-cp1258->string)
(push '((:cp1258 :|cp1258| :windows-1258 :|windows-1258|)
- cp1258->string-aref string->cp1258)
+ cp1258->string-aref string->cp1258 cp1258->string-sap-ref-8)
*external-format-functions*)
(define-external-format (:cp1258 :|cp1258| :windows-1258 :|windows-1258|)
Index: src/code/external-formats/eucjp.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/external-formats/eucjp.lisp,v
retrieving revision 1.2
diff -u -r1.2 eucjp.lisp
--- src/code/external-formats/eucjp.lisp 4 Nov 2005 12:51:17 -0000 1.2
+++ src/code/external-formats/eucjp.lisp 22 May 2006 21:26:37 -0000
@@ -13289,5 +13289,5 @@
(instantiate-octets-definition define-eucjp->string)
(push '((:euc-jp :eucjp :|eucJP|)
- eucjp->string-aref string->eucjp)
+ eucjp->string-aref string->eucjp eucjp->string-sap-ref-8)
*external-format-functions*)
Index: src/code/fd-stream.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/fd-stream.lisp,v
retrieving revision 1.100
diff -u -r1.100 fd-stream.lisp
--- src/code/fd-stream.lisp 5 Apr 2006 06:24:11 -0000 1.100
+++ src/code/fd-stream.lisp 22 May 2006 21:25:20 -0000
@@ -1890,8 +1890,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: src/code/filesys.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/filesys.lisp,v
retrieving revision 1.57
diff -u -r1.57 filesys.lisp
--- src/code/filesys.lisp 6 Apr 2006 10:39:34 -0000 1.57
+++ src/code/filesys.lisp 22 May 2006 21:25:24 -0000
@@ -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,6 +586,7 @@
;;; (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))
#!-win32
@@ -807,8 +837,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 +861,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: src/code/unix.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/unix.lisp,v
retrieving revision 1.66
diff -u -r1.66 unix.lisp
--- src/code/unix.lisp 6 Apr 2006 10:39:34 -0000 1.66
+++ src/code/unix.lisp 22 May 2006 21:25:41 -0000
@@ -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: src/code/win32-pathname.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/win32-pathname.lisp,v
retrieving revision 1.2
diff -u -r1.2 win32-pathname.lisp
--- src/code/win32-pathname.lisp 13 Apr 2006 22:52:56 -0000 1.2
+++ src/code/win32-pathname.lisp 22 May 2006 21:25:43 -0000
@@ -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)))
@@ -291,7 +291,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)
@@ -339,7 +339,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 ".")
9:57 p.m.
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.
Fixed (see alien-c-string.patch)
- 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?
Partially fixed (see non-ascii-pathnames.patch). Need help on non-windows platforms.
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:
(define-alien-routine strdup (c-string :external-format :latin-1) (str (c-string :external-format :utf-8)))
Fixed (see alien-c-string.patch). (Maybe now redefine utf8-string as (c-string :external-format :utf8)?)
Well, what now?
--
WBR, Yaroslav Kavenchuk.
6789
Age (days ago)
6814
Last active (days ago)
4 comments
4 participants
participants (4)
-
James Bielman -
Juho Snellman -
Yaroslav Kavenchuk -
Yaroslav Kavenchuk