From 54b330585ed41edeb93a289f0e59aec67fa9ded9 Mon Sep 17 00:00:00 2001 From: Juho Snellman Date: Wed, 6 Sep 2006 20:27:09 +0000 Subject: [PATCH] 0.9.16.17: Support for external formats in SB-ALIEN. The C-STRING alien-type specifier now accepts :EXTERNAL-FORMAT and :ELEMENT-TYPE parameters. This is a slightly incompatible change: to get the behaviour of the old C-STRING alien-type, use (C-STRING :EXTERNAL-FORMAT :ASCII :ELEMENT-TYPE BASE-CHAR). Thanks to Yaroslav Kavenchuk for doing most of the work on this. * Also add support for non-ascii pathnames * Add some recent CONTRIBUTORS * Update INSTALL * Add argument quote/space escaping to RUN-PROGRAM on win32 --- CREDITS | 11 ++ INSTALL | 10 +- NEWS | 12 +++ contrib/sb-simple-streams/file.lisp | 8 +- doc/manual/ffi.texinfo | 40 +++++-- package-data-list.lisp-expr | 3 + src/code/cold-init.lisp | 1 + src/code/early-alieneval.lisp | 2 + src/code/error.lisp | 18 ++++ src/code/external-formats/enc-cyr.lisp | 12 +-- src/code/external-formats/enc-dos.lisp | 56 +++++----- src/code/external-formats/enc-iso.lisp | 48 ++++----- src/code/external-formats/enc-win.lisp | 36 +++---- src/code/external-formats/eucjp.lisp | 2 +- src/code/external-formats/ucs-2.lisp | 8 +- src/code/fd-stream.lisp | 181 +++++++++++++++++++++++++++++--- src/code/filesys.lisp | 43 ++++---- src/code/host-c-call.lisp | 113 ++++++++++++-------- src/code/octets.lisp | 3 +- src/code/pathname.lisp | 2 +- src/code/run-program.lisp | 17 ++- src/code/target-c-call.lisp | 36 +++++-- src/code/target-pathname.lisp | 2 +- src/code/unix-pathname.lisp | 18 ++-- src/code/unix.lisp | 14 +-- src/code/win32-pathname.lisp | 20 ++-- tests/external-format.impure.lisp | 41 ++++++++ version.lisp-expr | 2 +- 28 files changed, 540 insertions(+), 219 deletions(-) diff --git a/CREDITS b/CREDITS index 1f707f8..6394064 100644 --- a/CREDITS +++ b/CREDITS @@ -606,6 +606,11 @@ Teemu Kalvas: character database, restoring the FAST-READ-CHAR optimization and developing external format support. +Yaroslav Kavenchuk: + He implemented several missing features and fixed many bugs in + the win32 port. He also worked on external-format support for + SB-ALIEN. + Frederik Kuivinen: He showed how to implement the DEBUG-RETURN functionality. @@ -673,6 +678,9 @@ William ("Bill") Newman: updating documentation, and even, for better or worse, getting rid of various functionality (e.g. the byte interpreter). +NIIMI Satoshi: + He contributed a number of fixes to the FreeBSD port. + Patrik Nordebo: He contributed to the port of SBCL to MacOS X, finding solutions for ABI and assembly syntax differences between Darwin and Linux. @@ -684,6 +692,9 @@ Luís Oliveira: Scott Parish: He ported SBCL to OpenBSD-with-ELF. +Timothy Ritchey: + He implemented SB-BSD-SOCKETS support for the win32 port. + Kevin M. Rosenberg: He provided the ACL-style toplevel (sb-aclrepl contrib module), and a number of MOP-related bug reports. He also creates the official diff --git a/INSTALL b/INSTALL index 2eec8f1..050e67f 100644 --- a/INSTALL +++ b/INSTALL @@ -154,7 +154,8 @@ INSTALLING SBCL (pushnew x features)) (disable (x) (setf features (remove x features)))) - ;; Threading support, available on x86/x86-64 Linux only. + ;; Threading support, available only on x86/x86-64 Linux, x86 Solaris + ;; and x86 Mac OS X (experimental). (enable :sb-thread))) This is the preferred way because it lets local changes interact @@ -241,11 +242,12 @@ INSTALLING SBCL NetBSD X Solaris X X Tru64 X - Darwin (Mac OS X) X + Darwin (Mac OS X) X X + Windows X Some operating systems are more equal than others: most of the - development and testing is done on x86 Linux and *BSD, PPC Linux - and Mac OS X. + development and testing is done on x86/x86-64 Linux and x86/PPC + Mac OS X. If an underprivileged platform is important to you, you can help by e.g. testing during the monthly freeze periods, and most diff --git a/NEWS b/NEWS index 52e46fd..6c8c521 100644 --- a/NEWS +++ b/NEWS @@ -1,5 +1,13 @@ ;;;; -*- coding: utf-8; -*- changes in sbcl-0.9.17 (0.9.99?) relative to sbcl-0.9.16: + * incompatible change: External-format support for FFI calls. The + SB-ALIEN:C-STRING no longer implies an ASCII + external-format. Instead the string is subject to external-format + conversion. Additionally return values of type SB-ALIEN:C-STRING + are by default of type (SIMPLE-ARRAY CHARACTER), not + SIMPLE-BASE-STRING. For an alien type that behaves like the old + SB-ALIEN:C-STRING type, use (SB-ALIEN:C-STRING :EXTERNAL-FORMAT + :ASCII :ELEMENT-TYPE BASE-CHAR). (thanks to Yaroslav Kavenchuk) * incompatible change: SB-EXT package no longer contains the following unused symbols: *GC-NOTIFY-AFTER*, *GC-NOTIFY-BEFORE*, *GC-NOTIFY-STREAM*, *ERROR-PRINT-LENGTH*, *ERROR-PRINT-LEVEL*, @@ -16,6 +24,8 @@ changes in sbcl-0.9.17 (0.9.99?) relative to sbcl-0.9.16: Slobodov) * bug fix: better detection of circularities in the file-compiler. (reported by Marco Monteiro) + * bug fix: the CL pathname functions now work with files that have + non-ASCII characters in their names (thanks to Yaroslav Kavenchuk) * bug fix: The :PTY argument for RUN-PROGRAM will now work on systems with Unix98 pty semantics. * bug fix: ASDF-INSTALL will now work with bsd tar. @@ -192,6 +202,8 @@ changes in sbcl-0.9.13 relative to sbcl-0.9.12: faster * optimization: added a limited bytecode compiler for simple toplevel forms, speeding up compilation and FASL loading + * bug fix: the statistical profiler now properly distinguishes anonymous + functions changes in sbcl-0.9.12 relative to sbcl-0.9.11: * minor incompatible change: in sbcl-0.9.11 (but not earlier diff --git a/contrib/sb-simple-streams/file.lisp b/contrib/sb-simple-streams/file.lisp index 7b71b9d..9dbe8f8 100644 --- a/contrib/sb-simple-streams/file.lisp +++ b/contrib/sb-simple-streams/file.lisp @@ -115,8 +115,8 @@ ;;; TODO: use this in src/code/fd-stream.lisp:fd-stream-misc-routine ;;; as well, snarf error reporting from there. (defun revert-file (filename original) - (declare (type simple-base-string filename) - (type (or simple-base-string null) original)) + (declare (type simple-string filename) + (type (or simple-string null) original)) ;; We can't do anything unless we know what file were ;; dealing with, and we don't want to do anything ;; strange unless we were writing to the file. @@ -140,8 +140,8 @@ ;;; TODO: use this in src/code/fd-stream.lisp:fd-stream-misc-routine ;;; as well, snarf error reporting from there. (defun delete-original (filename original) - (declare (type simple-base-string filename) - (type (or simple-base-string null) original)) + (declare (type simple-string filename) + (type (or simple-string null) original)) (when original (multiple-value-bind (okay err) (sb-unix:unix-unlink original) (unless okay diff --git a/doc/manual/ffi.texinfo b/doc/manual/ffi.texinfo index f8ffb73..cfdd1d2 100644 --- a/doc/manual/ffi.texinfo +++ b/doc/manual/ffi.texinfo @@ -283,15 +283,37 @@ types to declare that no useful value is returned. Using return zero values. @item -The foreign type specifier @code{sb-alien:c-string} is similar to -@code{(* char)}, but is interpreted as a null-terminated string, and is -automatically converted into a Lisp string when accessed; or if the -pointer is C @code{NULL} or @code{0}, then accessing it gives Lisp -@code{nil}. Lisp strings of type @code{base-string} are stored with a -trailing NUL termination, so no copying (either by the user or the -implementation) is necessary when passing them to foreign code; strings -of type @code{(simple-array character (*))} are copied by the -implementation as required. +The foreign type specifier @code{(sb-alien:c-string &key external-format +element-type)} is similar to @code{(* char)}, but is interpreted as a +null-terminated string, and is automatically converted into a Lisp +string when accessed; or if the pointer is C @code{NULL} or @code{0}, +then accessing it gives Lisp @code{nil}. + +External format conversion is automatically done when Lisp strings are +passed to foreign code, or when foreign strings are passed to Lisp code. +If the type specifier has an explicit @code{external-format}, that +external format will be used. Otherwise a default external format that +has been determined at SBCL startup time based on the current locale +settings will be used. For example, when the following alien routine is +called, the Lisp string given as argument is converted to an +@code{ebcdic} octet representation. + +@lisp +(define-alien-routine test int (str (c-string :external-format :ebcdic-us))) +@end lisp + +Lisp strings of type @code{base-string} are stored with a trailing NUL +termination, so no copying (either by the user or the implementation) is +necessary when passing them to foreign code, assuming that the +@code{external-format} and @code{element-type} of the @code{c-string} +type are compatible with the internal representation of the string. For +an SBCL built with Unicode support that means an @code{external-format} +of @code{:ascii} and an @code{element-type} of @code{base-char}. Without +Unicode support the @code{external-format} can also be +@code{:iso-8859-1}, and the @code{element-type} can also be +@code{character}. If the @code{external-format} or @code{element-type} +is not compatible, or the string is a @code{(simple-array character +(*))}, this data is copied by the implementation as required. Assigning a Lisp string to a @code{c-string} structure field or variable stores the contents of the string to the memory already diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index 833033a..eca3957 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -831,6 +831,8 @@ retained, possibly temporariliy, because it might be used internally." "CHARACTER-DECODING-ERROR" "CHARACTER-DECODING-ERROR-OCTETS" "CHARACTER-ENCODING-ERROR" "CHARACTER-ENCODING-ERROR-CODE" "STREAM-DECODING-ERROR" "STREAM-ENCODING-ERROR" + "C-STRING-ENCODING-ERROR" "C-STRING-ENCODING-ERROR-EXTERNAL-FORMAT" + "C-STRING-DECODING-ERROR" "C-STRING-DECODING-ERROR-EXTERNAL-FORMAT" "ATTEMPT-RESYNC" "FORCE-END-OF-FILE" ;; bootstrapping magic, to make things happen both in @@ -2090,6 +2092,7 @@ structure representations" :export ("*ASSEMBLY-UNIT-LENGTH*" "*PRIMITIVE-OBJECTS*" "AFTER-BREAKPOINT-TRAP" + "*ALLOC-SIGNAL*" "ANY-REG-SC-NUMBER" "ARRAY-DATA-SLOT" "ARRAY-DIMENSIONS-OFFSET" "ARRAY-DISPLACED-P-SLOT" "ARRAY-DISPLACEMENT-SLOT" "ARRAY-ELEMENTS-SLOT" "ARRAY-FILL-POINTER-P-SLOT" diff --git a/src/code/cold-init.lisp b/src/code/cold-init.lisp index 034e5bf..3ab05a9 100644 --- a/src/code/cold-init.lisp +++ b/src/code/cold-init.lisp @@ -287,6 +287,7 @@ UNIX-like systems, UNIX-STATUS is used as the status code." (defun reinit () (setf *default-external-format* nil) + (setf sb!alien::*default-c-string-external-format* nil) (without-interrupts (without-gcing (os-cold-init-or-reinit) diff --git a/src/code/early-alieneval.lisp b/src/code/early-alieneval.lisp index 5da7b50..8043bbd 100644 --- a/src/code/early-alieneval.lisp +++ b/src/code/early-alieneval.lisp @@ -26,3 +26,5 @@ ;;; 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) + +(defvar *default-c-string-external-format* nil) diff --git a/src/code/error.lisp b/src/code/error.lisp index 8666181..6827435 100644 --- a/src/code/error.lisp +++ b/src/code/error.lisp @@ -124,6 +124,24 @@ stream ':external-format (stream-external-format stream) octets))))) +(define-condition c-string-encoding-error (character-encoding-error) + ((external-format :initarg :external-format :reader c-string-encoding-error-external-format)) + (:report + (lambda (c s) + (format s "~@" + (c-string-encoding-error-external-format c) + (character-encoding-error-code c))))) + +(define-condition c-string-decoding-error (character-decoding-error) + ((external-format :initarg :external-format :reader c-string-decoding-error-external-format)) + (:report + (lambda (c s) + (format s "~@" + (c-string-decoding-error-external-format c) + (character-decoding-error-octets c))))) + (define-condition control-stack-exhausted (storage-condition) () (:report diff --git a/src/code/external-formats/enc-cyr.lisp b/src/code/external-formats/enc-cyr.lisp index 660e38d..9d0061d 100644 --- a/src/code/external-formats/enc-cyr.lisp +++ b/src/code/external-formats/enc-cyr.lisp @@ -169,11 +169,11 @@ (let ((koi8-r-byte (code->koi8-r-mapper bits))) (if koi8-r-byte (setf (sap-ref-8 sap tail) koi8-r-byte) - (stream-encoding-error-and-handle stream bits))) + (external-format-encoding-error stream bits))) (let ((code (koi8-r->code-mapper byte))) (if code (code-char code) - (stream-decoding-error stream byte)))) ;; TODO -- error check + (external-format-decoding-error stream byte)))) ;; TODO -- error check (define-unibyte-mapper koi8-u->code-mapper code->koi8-u-mapper (#x80 #x2500) ; BOX DRAWINGS LIGHT HORIZONTAL @@ -344,11 +344,11 @@ (let ((koi8-u-byte (code->koi8-u-mapper bits))) (if koi8-u-byte (setf (sap-ref-8 sap tail) koi8-u-byte) - (stream-encoding-error-and-handle stream bits))) + (external-format-encoding-error stream bits))) (let ((code (koi8-u->code-mapper byte))) (if code (code-char code) - (stream-decoding-error stream byte)))) ;; TODO -- error check + (external-format-decoding-error stream byte)))) ;; TODO -- error check (define-unibyte-mapper x-mac-cyrillic->code-mapper code->x-mac-cyrillic-mapper (#x80 #x0410) ; CYRILLIC CAPITAL LETTER A @@ -514,8 +514,8 @@ (let ((x-mac-cyrillic-byte (code->x-mac-cyrillic-mapper bits))) (if x-mac-cyrillic-byte (setf (sap-ref-8 sap tail) x-mac-cyrillic-byte) - (stream-encoding-error-and-handle stream bits))) + (external-format-encoding-error stream bits))) (let ((code (x-mac-cyrillic->code-mapper byte))) (if code (code-char code) - (stream-decoding-error stream byte)))) ;; TODO -- error check + (external-format-decoding-error stream byte)))) ;; TODO -- error check diff --git a/src/code/external-formats/enc-dos.lisp b/src/code/external-formats/enc-dos.lisp index 74d8761..edb9457 100644 --- a/src/code/external-formats/enc-dos.lisp +++ b/src/code/external-formats/enc-dos.lisp @@ -169,11 +169,11 @@ (let ((cp437-byte (code->cp437-mapper bits))) (if cp437-byte (setf (sap-ref-8 sap tail) cp437-byte) - (stream-encoding-error-and-handle stream bits))) + (external-format-encoding-error stream bits))) (let ((code (cp437->code-mapper byte))) (if code (code-char code) - (stream-decoding-error stream byte)))) ;; TODO -- error check + (external-format-decoding-error stream byte)))) ;; TODO -- error check (define-unibyte-mapper cp850->code-mapper code->cp850-mapper (#x80 #x00C7) ; LATIN CAPITAL LETTER C WITH CEDILLA @@ -344,11 +344,11 @@ (let ((cp850-byte (code->cp850-mapper bits))) (if cp850-byte (setf (sap-ref-8 sap tail) cp850-byte) - (stream-encoding-error-and-handle stream bits))) + (external-format-encoding-error stream bits))) (let ((code (cp850->code-mapper byte))) (if code (code-char code) - (stream-decoding-error stream byte)))) ;; TODO -- error check + (external-format-decoding-error stream byte)))) ;; TODO -- error check (define-unibyte-mapper cp852->code-mapper code->cp852-mapper (#x80 #x00C7) ; LATIN CAPITAL LETTER C WITH CEDILLA @@ -519,11 +519,11 @@ (let ((cp852-byte (code->cp852-mapper bits))) (if cp852-byte (setf (sap-ref-8 sap tail) cp852-byte) - (stream-encoding-error-and-handle stream bits))) + (external-format-encoding-error stream bits))) (let ((code (cp852->code-mapper byte))) (if code (code-char code) - (stream-decoding-error stream byte)))) ;; TODO -- error check + (external-format-decoding-error stream byte)))) ;; TODO -- error check (define-unibyte-mapper cp855->code-mapper code->cp855-mapper (#x80 #x0452) ; CYRILLIC SMALL LETTER DJE @@ -694,11 +694,11 @@ (let ((cp855-byte (code->cp855-mapper bits))) (if cp855-byte (setf (sap-ref-8 sap tail) cp855-byte) - (stream-encoding-error-and-handle stream bits))) + (external-format-encoding-error stream bits))) (let ((code (cp855->code-mapper byte))) (if code (code-char code) - (stream-decoding-error stream byte)))) ;; TODO -- error check + (external-format-decoding-error stream byte)))) ;; TODO -- error check (define-unibyte-mapper cp857->code-mapper code->cp857-mapper (#x80 #x00C7) ; LATIN CAPITAL LETTER C WITH CEDILLA @@ -868,11 +868,11 @@ (let ((cp857-byte (code->cp857-mapper bits))) (if cp857-byte (setf (sap-ref-8 sap tail) cp857-byte) - (stream-encoding-error-and-handle stream bits))) + (external-format-encoding-error stream bits))) (let ((code (cp857->code-mapper byte))) (if code (code-char code) - (stream-decoding-error stream byte)))) ;; TODO -- error check + (external-format-decoding-error stream byte)))) ;; TODO -- error check (define-unibyte-mapper cp860->code-mapper code->cp860-mapper (#x80 #x00C7) ; LATIN CAPITAL LETTER C WITH CEDILLA @@ -1043,11 +1043,11 @@ (let ((cp860-byte (code->cp860-mapper bits))) (if cp860-byte (setf (sap-ref-8 sap tail) cp860-byte) - (stream-encoding-error-and-handle stream bits))) + (external-format-encoding-error stream bits))) (let ((code (cp860->code-mapper byte))) (if code (code-char code) - (stream-decoding-error stream byte)))) ;; TODO -- error check + (external-format-decoding-error stream byte)))) ;; TODO -- error check (define-unibyte-mapper cp861->code-mapper code->cp861-mapper (#x80 #x00C7) ; LATIN CAPITAL LETTER C WITH CEDILLA @@ -1218,11 +1218,11 @@ (let ((cp861-byte (code->cp861-mapper bits))) (if cp861-byte (setf (sap-ref-8 sap tail) cp861-byte) - (stream-encoding-error-and-handle stream bits))) + (external-format-encoding-error stream bits))) (let ((code (cp861->code-mapper byte))) (if code (code-char code) - (stream-decoding-error stream byte)))) ;; TODO -- error check + (external-format-decoding-error stream byte)))) ;; TODO -- error check (define-unibyte-mapper cp862->code-mapper code->cp862-mapper (#x80 #x05D0) ; HEBREW LETTER ALEF @@ -1393,11 +1393,11 @@ (let ((cp862-byte (code->cp862-mapper bits))) (if cp862-byte (setf (sap-ref-8 sap tail) cp862-byte) - (stream-encoding-error-and-handle stream bits))) + (external-format-encoding-error stream bits))) (let ((code (cp862->code-mapper byte))) (if code (code-char code) - (stream-decoding-error stream byte)))) ;; TODO -- error check + (external-format-decoding-error stream byte)))) ;; TODO -- error check (define-unibyte-mapper cp863->code-mapper code->cp863-mapper (#x80 #x00C7) ; LATIN CAPITAL LETTER C WITH CEDILLA @@ -1568,11 +1568,11 @@ (let ((cp863-byte (code->cp863-mapper bits))) (if cp863-byte (setf (sap-ref-8 sap tail) cp863-byte) - (stream-encoding-error-and-handle stream bits))) + (external-format-encoding-error stream bits))) (let ((code (cp863->code-mapper byte))) (if code (code-char code) - (stream-decoding-error stream byte)))) ;; TODO -- error check + (external-format-decoding-error stream byte)))) ;; TODO -- error check (define-unibyte-mapper cp864->code-mapper code->cp864-mapper (#x80 #x00B0) ; DEGREE SIGN @@ -1740,11 +1740,11 @@ (let ((cp864-byte (code->cp864-mapper bits))) (if cp864-byte (setf (sap-ref-8 sap tail) cp864-byte) - (stream-encoding-error-and-handle stream bits))) + (external-format-encoding-error stream bits))) (let ((code (cp864->code-mapper byte))) (if code (code-char code) - (stream-decoding-error stream byte)))) ;; TODO -- error check + (external-format-decoding-error stream byte)))) ;; TODO -- error check (define-unibyte-mapper cp865->code-mapper code->cp865-mapper (#x80 #x00C7) ; LATIN CAPITAL LETTER C WITH CEDILLA @@ -1915,11 +1915,11 @@ (let ((cp865-byte (code->cp865-mapper bits))) (if cp865-byte (setf (sap-ref-8 sap tail) cp865-byte) - (stream-encoding-error-and-handle stream bits))) + (external-format-encoding-error stream bits))) (let ((code (cp865->code-mapper byte))) (if code (code-char code) - (stream-decoding-error stream byte)))) ;; TODO -- error check + (external-format-decoding-error stream byte)))) ;; TODO -- error check (define-unibyte-mapper cp866->code-mapper code->cp866-mapper (#x80 #x0410) ; CYRILLIC CAPITAL LETTER A @@ -2090,11 +2090,11 @@ (let ((cp866-byte (code->cp866-mapper bits))) (if cp866-byte (setf (sap-ref-8 sap tail) cp866-byte) - (stream-encoding-error-and-handle stream bits))) + (external-format-encoding-error stream bits))) (let ((code (cp866->code-mapper byte))) (if code (code-char code) - (stream-decoding-error stream byte)))) ;; TODO -- error check + (external-format-decoding-error stream byte)))) ;; TODO -- error check (define-unibyte-mapper cp869->code-mapper code->cp869-mapper (#x80 nil) @@ -2265,11 +2265,11 @@ (let ((cp869-byte (code->cp869-mapper bits))) (if cp869-byte (setf (sap-ref-8 sap tail) cp869-byte) - (stream-encoding-error-and-handle stream bits))) + (external-format-encoding-error stream bits))) (let ((code (cp869->code-mapper byte))) (if code (code-char code) - (stream-decoding-error stream byte)))) ;; TODO -- error check + (external-format-decoding-error stream byte)))) ;; TODO -- error check (define-unibyte-mapper cp874->code-mapper code->cp874-mapper (#x80 #x20AC) ; EURO SIGN @@ -2439,8 +2439,8 @@ (let ((cp874-byte (code->cp874-mapper bits))) (if cp874-byte (setf (sap-ref-8 sap tail) cp874-byte) - (stream-encoding-error-and-handle stream bits))) + (external-format-encoding-error stream bits))) (let ((code (cp874->code-mapper byte))) (if code (code-char code) - (stream-decoding-error stream byte)))) ;; TODO -- error check + (external-format-decoding-error stream byte)))) ;; TODO -- error check diff --git a/src/code/external-formats/enc-iso.lisp b/src/code/external-formats/enc-iso.lisp index dba365b..f8a1119 100644 --- a/src/code/external-formats/enc-iso.lisp +++ b/src/code/external-formats/enc-iso.lisp @@ -98,11 +98,11 @@ (let ((iso-8859-2-byte (code->iso-8859-2-mapper bits))) (if iso-8859-2-byte (setf (sap-ref-8 sap tail) iso-8859-2-byte) - (stream-encoding-error-and-handle stream bits))) + (external-format-encoding-error stream bits))) (let ((code (iso-8859-2->code-mapper byte))) (if code (code-char code) - (stream-decoding-error stream byte)))) ;; TODO -- error check + (external-format-decoding-error stream byte)))) ;; TODO -- error check (define-unibyte-mapper iso-8859-3->code-mapper code->iso-8859-3-mapper (#xA1 #x0126) ; LATIN CAPITAL LETTER H WITH STROKE @@ -180,11 +180,11 @@ (let ((iso-8859-3-byte (code->iso-8859-3-mapper bits))) (if iso-8859-3-byte (setf (sap-ref-8 sap tail) iso-8859-3-byte) - (stream-encoding-error-and-handle stream bits))) + (external-format-encoding-error stream bits))) (let ((code (iso-8859-3->code-mapper byte))) (if code (code-char code) - (stream-decoding-error stream byte)))) ;; TODO -- error check + (external-format-decoding-error stream byte)))) ;; TODO -- error check (define-unibyte-mapper iso-8859-4->code-mapper code->iso-8859-4-mapper (#xA1 #x0104) ; LATIN CAPITAL LETTER A WITH OGONEK @@ -277,11 +277,11 @@ (let ((iso-8859-4-byte (code->iso-8859-4-mapper bits))) (if iso-8859-4-byte (setf (sap-ref-8 sap tail) iso-8859-4-byte) - (stream-encoding-error-and-handle stream bits))) + (external-format-encoding-error stream bits))) (let ((code (iso-8859-4->code-mapper byte))) (if code (code-char code) - (stream-decoding-error stream byte)))) ;; TODO -- error check + (external-format-decoding-error stream byte)))) ;; TODO -- error check (define-unibyte-mapper iso-8859-5->code-mapper code->iso-8859-5-mapper (#xA1 #x0401) ; CYRILLIC CAPITAL LETTER IO @@ -418,11 +418,11 @@ (let ((iso-8859-5-byte (code->iso-8859-5-mapper bits))) (if iso-8859-5-byte (setf (sap-ref-8 sap tail) iso-8859-5-byte) - (stream-encoding-error-and-handle stream bits))) + (external-format-encoding-error stream bits))) (let ((code (iso-8859-5->code-mapper byte))) (if code (code-char code) - (stream-decoding-error stream byte)))) ;; TODO -- error check + (external-format-decoding-error stream byte)))) ;; TODO -- error check (define-unibyte-mapper iso-8859-6->code-mapper code->iso-8859-6-mapper (#xA1 nil) @@ -558,11 +558,11 @@ (let ((iso-8859-6-byte (code->iso-8859-6-mapper bits))) (if iso-8859-6-byte (setf (sap-ref-8 sap tail) iso-8859-6-byte) - (stream-encoding-error-and-handle stream bits))) + (external-format-encoding-error stream bits))) (let ((code (iso-8859-6->code-mapper byte))) (if code (code-char code) - (stream-decoding-error stream byte)))) ;; TODO -- error check + (external-format-decoding-error stream byte)))) ;; TODO -- error check (define-unibyte-mapper iso-8859-7->code-mapper code->iso-8859-7-mapper (#xA1 #x02BD) ; MODIFIER LETTER REVERSED COMMA @@ -685,11 +685,11 @@ (let ((iso-8859-7-byte (code->iso-8859-7-mapper bits))) (if iso-8859-7-byte (setf (sap-ref-8 sap tail) iso-8859-7-byte) - (stream-encoding-error-and-handle stream bits))) + (external-format-encoding-error stream bits))) (let ((code (iso-8859-7->code-mapper byte))) (if code (code-char code) - (stream-decoding-error stream byte)))) ;; TODO -- error check + (external-format-decoding-error stream byte)))) ;; TODO -- error check (define-unibyte-mapper iso-8859-8->code-mapper code->iso-8859-8-mapper (#xA1 nil) @@ -801,11 +801,11 @@ (let ((iso-8859-8-byte (code->iso-8859-8-mapper bits))) (if iso-8859-8-byte (setf (sap-ref-8 sap tail) iso-8859-8-byte) - (stream-encoding-error-and-handle stream bits))) + (external-format-encoding-error stream bits))) (let ((code (iso-8859-8->code-mapper byte))) (if code (code-char code) - (stream-decoding-error stream byte)))) ;; TODO -- error check + (external-format-decoding-error stream byte)))) ;; TODO -- error check (define-unibyte-mapper iso-8859-9->code-mapper code->iso-8859-9-mapper (#xD0 #x011E) ; LATIN CAPITAL LETTER G WITH BREVE @@ -854,11 +854,11 @@ (let ((iso-8859-9-byte (code->iso-8859-9-mapper bits))) (if iso-8859-9-byte (setf (sap-ref-8 sap tail) iso-8859-9-byte) - (stream-encoding-error-and-handle stream bits))) + (external-format-encoding-error stream bits))) (let ((code (iso-8859-9->code-mapper byte))) (if code (code-char code) - (stream-decoding-error stream byte)))) ;; TODO -- error check + (external-format-decoding-error stream byte)))) ;; TODO -- error check (define-unibyte-mapper iso-8859-10->code-mapper code->iso-8859-10-mapper (#xA1 #x0104) ; LATIN CAPITAL LETTER A WITH OGONEK @@ -947,11 +947,11 @@ (let ((iso-8859-10-byte (code->iso-8859-10-mapper bits))) (if iso-8859-10-byte (setf (sap-ref-8 sap tail) iso-8859-10-byte) - (stream-encoding-error-and-handle stream bits))) + (external-format-encoding-error stream bits))) (let ((code (iso-8859-10->code-mapper byte))) (if code (code-char code) - (stream-decoding-error stream byte)))) ;; TODO -- error check + (external-format-decoding-error stream byte)))) ;; TODO -- error check (define-unibyte-mapper iso-8859-11->code-mapper code->iso-8859-11-mapper (#xA1 #x0E01) ; THAI CHARACTER KO KAI @@ -1089,11 +1089,11 @@ (let ((iso-8859-11-byte (code->iso-8859-11-mapper bits))) (if iso-8859-11-byte (setf (sap-ref-8 sap tail) iso-8859-11-byte) - (stream-encoding-error-and-handle stream bits))) + (external-format-encoding-error stream bits))) (let ((code (iso-8859-11->code-mapper byte))) (if code (code-char code) - (stream-decoding-error stream byte)))) ;; TODO -- error check + (external-format-decoding-error stream byte)))) ;; TODO -- error check (define-unibyte-mapper iso-8859-13->code-mapper code->iso-8859-13-mapper (#xA1 #x201D) ; RIGHT DOUBLE QUOTATION MARK @@ -1192,11 +1192,11 @@ (let ((iso-8859-13-byte (code->iso-8859-13-mapper bits))) (if iso-8859-13-byte (setf (sap-ref-8 sap tail) iso-8859-13-byte) - (stream-encoding-error-and-handle stream bits))) + (external-format-encoding-error stream bits))) (let ((code (iso-8859-13->code-mapper byte))) (if code (code-char code) - (stream-decoding-error stream byte)))) ;; TODO -- error check + (external-format-decoding-error stream byte)))) ;; TODO -- error check (define-unibyte-mapper iso-8859-14->code-mapper code->iso-8859-14-mapper (#xA1 #x1E02) ; LATIN CAPITAL LETTER B WITH DOT ABOVE @@ -1270,8 +1270,8 @@ (let ((iso-8859-14-byte (code->iso-8859-14-mapper bits))) (if iso-8859-14-byte (setf (sap-ref-8 sap tail) iso-8859-14-byte) - (stream-encoding-error-and-handle stream bits))) + (external-format-encoding-error stream bits))) (let ((code (iso-8859-14->code-mapper byte))) (if code (code-char code) - (stream-decoding-error stream byte)))) ;; TODO -- error check + (external-format-decoding-error stream byte)))) ;; TODO -- error check diff --git a/src/code/external-formats/enc-win.lisp b/src/code/external-formats/enc-win.lisp index 3053734..a8bcc3c 100644 --- a/src/code/external-formats/enc-win.lisp +++ b/src/code/external-formats/enc-win.lisp @@ -120,11 +120,11 @@ (let ((cp1250-byte (code->cp1250-mapper bits))) (if cp1250-byte (setf (sap-ref-8 sap tail) cp1250-byte) - (stream-encoding-error-and-handle stream bits))) + (external-format-encoding-error stream bits))) (let ((code (cp1250->code-mapper byte))) (if code (code-char code) - (stream-decoding-error stream byte)))) ;; TODO -- error check + (external-format-decoding-error stream byte)))) ;; TODO -- error check (define-unibyte-mapper cp1251->code-mapper code->cp1251-mapper (#x80 #x0402) ; CYRILLIC CAPITAL LETTER DJE @@ -280,11 +280,11 @@ (let ((cp1251-byte (code->cp1251-mapper bits))) (if cp1251-byte (setf (sap-ref-8 sap tail) cp1251-byte) - (stream-encoding-error-and-handle stream bits))) + (external-format-encoding-error stream bits))) (let ((code (cp1251->code-mapper byte))) (if code (code-char code) - (stream-decoding-error stream byte)))) ;; TODO -- error check + (external-format-decoding-error stream byte)))) ;; TODO -- error check (define-unibyte-mapper cp1252->code-mapper code->cp1252-mapper (#x80 #x20AC) ; EURO SIGN @@ -359,11 +359,11 @@ (let ((cp1252-byte (code->cp1252-mapper bits))) (if cp1252-byte (setf (sap-ref-8 sap tail) cp1252-byte) - (stream-encoding-error-and-handle stream bits))) + (external-format-encoding-error stream bits))) (let ((code (cp1252->code-mapper byte))) (if code (code-char code) - (stream-decoding-error stream byte)))) ;; TODO -- error check + (external-format-decoding-error stream byte)))) ;; TODO -- error check (define-unibyte-mapper cp1253->code-mapper code->cp1253-mapper (#x80 #x20AC) ; EURO SIGN @@ -513,11 +513,11 @@ (let ((cp1253-byte (code->cp1253-mapper bits))) (if cp1253-byte (setf (sap-ref-8 sap tail) cp1253-byte) - (stream-encoding-error-and-handle stream bits))) + (external-format-encoding-error stream bits))) (let ((code (cp1253->code-mapper byte))) (if code (code-char code) - (stream-decoding-error stream byte)))) ;; TODO -- error check + (external-format-decoding-error stream byte)))) ;; TODO -- error check (define-unibyte-mapper cp1254->code-mapper code->cp1254-mapper (#x80 #x20AC) ; EURO SIGN @@ -598,11 +598,11 @@ (let ((cp1254-byte (code->cp1254-mapper bits))) (if cp1254-byte (setf (sap-ref-8 sap tail) cp1254-byte) - (stream-encoding-error-and-handle stream bits))) + (external-format-encoding-error stream bits))) (let ((code (cp1254->code-mapper byte))) (if code (code-char code) - (stream-decoding-error stream byte)))) ;; TODO -- error check + (external-format-decoding-error stream byte)))) ;; TODO -- error check (define-unibyte-mapper cp1255->code-mapper code->cp1255-mapper (#x80 #x20AC) ; EURO SIGN @@ -744,11 +744,11 @@ (let ((cp1255-byte (code->cp1255-mapper bits))) (if cp1255-byte (setf (sap-ref-8 sap tail) cp1255-byte) - (stream-encoding-error-and-handle stream bits))) + (external-format-encoding-error stream bits))) (let ((code (cp1255->code-mapper byte))) (if code (code-char code) - (stream-decoding-error stream byte)))) ;; TODO -- error check + (external-format-decoding-error stream byte)))) ;; TODO -- error check (define-unibyte-mapper cp1256->code-mapper code->cp1256-mapper (#x80 #x20AC) ; EURO SIGN @@ -876,11 +876,11 @@ (let ((cp1256-byte (code->cp1256-mapper bits))) (if cp1256-byte (setf (sap-ref-8 sap tail) cp1256-byte) - (stream-encoding-error-and-handle stream bits))) + (external-format-encoding-error stream bits))) (let ((code (cp1256->code-mapper byte))) (if code (code-char code) - (stream-decoding-error stream byte)))) ;; TODO -- error check + (external-format-decoding-error stream byte)))) ;; TODO -- error check (define-unibyte-mapper cp1257->code-mapper code->cp1257-mapper (#x80 #x20AC) ; EURO SIGN @@ -1010,11 +1010,11 @@ (let ((cp1257-byte (code->cp1257-mapper bits))) (if cp1257-byte (setf (sap-ref-8 sap tail) cp1257-byte) - (stream-encoding-error-and-handle stream bits))) + (external-format-encoding-error stream bits))) (let ((code (cp1257->code-mapper byte))) (if code (code-char code) - (stream-decoding-error stream byte)))) ;; TODO -- error check + (external-format-decoding-error stream byte)))) ;; TODO -- error check (define-unibyte-mapper cp1258->code-mapper code->cp1258-mapper (#x80 #x20AC) ; EURO SIGN @@ -1103,8 +1103,8 @@ (let ((cp1258-byte (code->cp1258-mapper bits))) (if cp1258-byte (setf (sap-ref-8 sap tail) cp1258-byte) - (stream-encoding-error-and-handle stream bits))) + (external-format-encoding-error stream bits))) (let ((code (cp1258->code-mapper byte))) (if code (code-char code) - (stream-decoding-error stream byte)))) ;; TODO -- error check + (external-format-decoding-error stream byte)))) ;; TODO -- error check diff --git a/src/code/external-formats/eucjp.lisp b/src/code/external-formats/eucjp.lisp index 584fa7f..cc1f7a7 100644 --- a/src/code/external-formats/eucjp.lisp +++ b/src/code/external-formats/eucjp.lisp @@ -13088,7 +13088,7 @@ 1)) (let ((euc (ucs-to-eucjp bits))) (if (null euc) - (stream-encoding-error-and-handle stream byte) + (external-format-encoding-error stream byte) (ecase size (1 (setf (sap-ref-8 sap tail) euc)) (2 (setf (sap-ref-8 sap tail) (ldb (byte 8 8) euc) diff --git a/src/code/external-formats/ucs-2.lisp b/src/code/external-formats/ucs-2.lisp index 4375114..2aea2df 100644 --- a/src/code/external-formats/ucs-2.lisp +++ b/src/code/external-formats/ucs-2.lisp @@ -36,11 +36,11 @@ ;;; ;;; Define external format: fd-stream ;;; -(define-external-format/variable-width (:ucs-2le :ucs2le) nil +(define-external-format/variable-width (:ucs-2le :ucs2le #!+win32 :ucs2 #!+win32 :ucs-2) nil 2 (if (< bits #x10000) (setf (sap-ref-16le sap tail) bits) - (stream-encoding-error-and-handle stream bits)) + (external-format-encoding-error stream bits)) 2 (code-char (sap-ref-16le sap head))) @@ -48,7 +48,7 @@ 2 (if (< bits #x10000) (setf (sap-ref-16be sap tail) bits) - (stream-encoding-error-and-handle stream bits)) + (external-format-encoding-error stream bits)) 2 (code-char (sap-ref-16be sap head))) @@ -209,7 +209,7 @@ (instantiate-octets-definition define-ucs-2->string) -(pushnew '((:ucs-2le :ucs2le) +(pushnew '((:ucs-2le :ucs2le #!+win32 :ucs2 #!+win32 :ucs-2) ucs-2le->string-aref string->ucs-2le) *external-format-functions*) diff --git a/src/code/fd-stream.lisp b/src/code/fd-stream.lisp index ef0c2c4..9bfe050 100644 --- a/src/code/fd-stream.lisp +++ b/src/code/fd-stream.lisp @@ -140,6 +140,16 @@ :stream stream :code code)) +(defun c-string-encoding-error (external-format code) + (error 'c-string-encoding-error + :external-format external-format + :code code)) + +(defun c-string-decoding-error (external-format octets) + (error 'c-string-decoding-error + :external-format external-format + :octets octets)) + ;;; Returning true goes into end of file handling, false will enter another ;;; round of input buffer filling followed by re-entering character decode. (defun stream-decoding-error-and-handle (stream octet-count) @@ -169,6 +179,16 @@ (format stream "~@")) (throw 'output-nothing nil)))) +(defun external-format-encoding-error (stream code) + (if (streamp stream) + (stream-encoding-error-and-handle stream code) + (c-string-encoding-error stream code))) + +(defun external-format-decoding-error (stream octet-count) + (if (streamp stream) + (stream-decoding-error stream octet-count) + (c-string-decoding-error stream octet-count))) + ;;; This is called by the server when we can write to the given file ;;; descriptor. Attempt to write the data again. If it worked, remove ;;; the data from the OUTPUT-LATER list. If it didn't work, something @@ -552,13 +572,22 @@ element-type, string input function name, character input function name, and string output function name.") +(defun get-external-format (external-format) + (dolist (entry *external-formats*) + (when (member external-format (first entry)) + (return entry)))) + +(defun get-external-format-function (external-format index) + (let ((entry (get-external-format external-format))) + (when entry (nth index entry)))) + ;;; Find an output routine to use given the type and buffering. Return ;;; as multiple values the routine, the real type transfered, and the ;;; number of bytes per element. (defun pick-output-routine (type buffering &optional external-format) (when (subtypep type 'character) - (dolist (entry *external-formats*) - (when (member external-format (first entry)) + (let ((entry (get-external-format external-format))) + (when entry (return-from pick-output-routine (values (symbol-function (nth (ecase buffering (:none 4) @@ -1021,7 +1050,9 @@ (format (format nil "OUTPUT-CHAR-~A-~~A-BUFFERED" (string name))) (in-function (symbolicate "FD-STREAM-READ-N-CHARACTERS/" name)) (in-char-function (symbolicate "INPUT-CHAR/" name)) - (size-function (symbolicate "BYTES-FOR-CHAR/" name))) + (size-function (symbolicate "BYTES-FOR-CHAR/" name)) + (read-c-string-function (symbolicate "READ-FROM-C-STRING/" name)) + (output-c-string-function (symbolicate "OUTPUT-TO-C-STRING/" name))) `(progn (defun ,size-function (byte) (declare (ignore byte)) @@ -1125,13 +1156,58 @@ (def-input-routine ,in-char-function (character ,size sap head) (let ((byte (sap-ref-8 sap head))) ,in-expr)) + (defun ,read-c-string-function (sap element-type) + (declare (type system-area-pointer sap) + (type (member character base-char) element-type)) + (locally + (declare (optimize (speed 3) (safety 0))) + (let* ((stream ,name) + (length (loop for head of-type index upfrom 0 by ,size + for count of-type index upto (1- ARRAY-DIMENSION-LIMIT) + for byte = (sap-ref-8 sap head) + for char of-type character = ,in-expr + until (zerop (char-code char)) + finally (return count))) + (string (make-string length :element-type element-type))) + (declare (ignorable stream) + (type index length) + (type string string)) + (/show0 before-copy-loop) + (loop for head of-type index upfrom 0 by ,size + for index of-type index below length + for byte = (sap-ref-8 sap head) + for char of-type character = ,in-expr + do (setf (aref string index) char)) + string))) ;; last loop rewrite to dotimes? + (defun ,output-c-string-function (string) + (declare (type simple-string string)) + (locally + (declare (optimize (speed 3) (safety 0))) + (let* ((length (length string)) + (buffer (make-array (* (1+ length) ,size) :element-type '(unsigned-byte 8))) + (sap (sb!sys:vector-sap buffer)) + (tail 0) + (stream ,name)) + (declare (type index length tail) + (type system-area-pointer sap)) + (dotimes (i length) + (let* ((byte (aref string i)) + (bits (char-code byte))) + (declare (ignorable byte bits)) + ,out-expr) + (incf tail ,size)) + (let* ((bits 0) + (byte (code-char bits))) + (declare (ignorable bits byte)) + ,out-expr) + buffer))) (setf *external-formats* (cons '(,external-format ,in-function ,in-char-function ,out-function ,@(mapcar #'(lambda (buffering) (intern (format nil format (string buffering)))) '(:none :line :full)) nil ; no resync-function - ,size-function) + ,size-function ,read-c-string-function ,output-c-string-function) *external-formats*))))) (defmacro define-external-format/variable-width @@ -1143,7 +1219,9 @@ (in-function (symbolicate "FD-STREAM-READ-N-CHARACTERS/" name)) (in-char-function (symbolicate "INPUT-CHAR/" name)) (resync-function (symbolicate "RESYNC/" name)) - (size-function (symbolicate "BYTES-FOR-CHAR/" name))) + (size-function (symbolicate "BYTES-FOR-CHAR/" name)) + (read-c-string-function (symbolicate "READ-FROM-C-STRING/" name)) + (output-c-string-function (symbolicate "OUTPUT-TO-C-STRING/" name))) `(progn (defun ,size-function (byte) (declare (ignorable byte)) @@ -1293,13 +1371,90 @@ ,in-expr)) nil) (return)))) + (defun ,read-c-string-function (sap element-type) + (declare (type system-area-pointer sap)) + (locally + (declare (optimize (speed 3) (safety 0))) + (let* ((stream ,name) + (size 0) (head 0) (byte 0) (char nil) + (decode-break-reason nil) + (length (dotimes (count (1- ARRAY-DIMENSION-LIMIT) count) + (setf decode-break-reason + (block decode-break-reason + (setf byte (sap-ref-8 sap head) + size ,in-size-expr + char ,in-expr) + (incf head size) + nil)) + (when decode-break-reason + (c-string-decoding-error ,name decode-break-reason)) + (when (zerop (char-code char)) + (return count)))) + (string (make-string length :element-type element-type))) + (declare (ignorable stream) + (type index head length) ;; size + (type (unsigned-byte 8) byte) + (type (or null character) char) + (type string string)) + (setf head 0) + (dotimes (index length string) + (setf decode-break-reason + (block decode-break-reason + (setf byte (sap-ref-8 sap head) + size ,in-size-expr + char ,in-expr) + (incf head size) + nil)) + (when decode-break-reason + (c-string-decoding-error ,name decode-break-reason)) + (setf (aref string index) char))))) + + (defun ,output-c-string-function (string) + (declare (type simple-string string)) + (locally + (declare (optimize (speed 3) (safety 0))) + (let* ((length (length string)) + (char-length (make-array (1+ length) :element-type 'index)) + (buffer-length + (+ (loop for i of-type index below length + for byte of-type character = (aref string i) + for bits = (char-code byte) + sum (setf (aref char-length i) + (the index ,out-size-expr))) + (let* ((byte (code-char 0)) + (bits (char-code byte))) + (declare (ignorable byte bits)) + (setf (aref char-length length) + (the index ,out-size-expr))))) + (tail 0) + (buffer (make-array buffer-length :element-type '(unsigned-byte 8))) + (sap (sb!sys:vector-sap buffer)) + stream) + (declare (type index length buffer-length tail) + (type system-area-pointer sap) + (type null stream) + (ignorable stream)) + (loop for i of-type index below length + for byte of-type character = (aref string i) + for bits = (char-code byte) + for size of-type index = (aref char-length i) + do (prog1 + ,out-expr + (incf tail size))) + (let* ((bits 0) + (byte (code-char bits)) + (size (aref char-length length))) + (declare (ignorable bits byte size)) + ,out-expr) + buffer))) + (setf *external-formats* (cons '(,external-format ,in-function ,in-char-function ,out-function ,@(mapcar #'(lambda (buffering) (intern (format nil format (string buffering)))) '(:none :line :full)) ,resync-function - ,size-function) + ,size-function ,read-c-string-function ,output-c-string-function) *external-formats*))))) ;;; Multiple names for the :ISO{,-}8859-* families are needed because on @@ -1308,7 +1463,7 @@ (define-external-format (:latin-1 :latin1 :iso-8859-1 :iso8859-1) 1 t (if (>= bits 256) - (stream-encoding-error-and-handle stream bits) + (external-format-encoding-error stream bits) (setf (sap-ref-8 sap tail) bits)) (code-char byte)) @@ -1316,7 +1471,7 @@ :iso-646 :iso-646-us :|646|) 1 t (if (>= bits 128) - (stream-encoding-error-and-handle stream bits) + (external-format-encoding-error stream bits) (setf (sap-ref-8 sap tail) bits)) (code-char byte)) @@ -1347,7 +1502,7 @@ (define-external-format (:ebcdic-us :ibm-037 :ibm037) 1 t (if (>= bits 256) - (stream-encoding-error-and-handle stream bits) + (external-format-encoding-error stream bits) (setf (sap-ref-8 sap tail) (aref reverse-table bits))) (aref table byte))) @@ -1378,10 +1533,10 @@ (if (< bits 256) (if (= bits (char-code (aref latin-9-table bits))) bits - (stream-encoding-error-and-handle stream byte)) + (external-format-encoding-error stream byte)) (if (= (aref latin-9-reverse-1 (logand bits 15)) bits) (aref latin-9-reverse-2 (logand bits 15)) - (stream-encoding-error-and-handle stream byte)))) + (external-format-encoding-error stream byte)))) (aref latin-9-table byte))) (define-external-format/variable-width (:utf-8 :utf8) nil @@ -1906,8 +2061,8 @@ ;;; 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 simple-string name)) + (concatenate '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. diff --git a/src/code/filesys.lisp b/src/code/filesys.lisp index d1de6be..f323df9 100644 --- a/src/code/filesys.lisp +++ b/src/code/filesys.lisp @@ -55,9 +55,9 @@ #!+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 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 'character)) (dst 0) (quoted nil)) (do ((src start (1+ src))) @@ -85,7 +85,7 @@ (/show0 "filesys.lisp 86") (defun maybe-make-pattern (namestr start end) - (declare (type simple-base-string namestr) + (declare (type simple-string namestr) (type index start end)) (if *ignore-wildcards* (subseq namestr start end) @@ -158,7 +158,7 @@ (/show0 "filesys.lisp 160") (defun extract-name-type-and-version (namestr start end) - (declare (type simple-base-string namestr) + (declare (type simple-string namestr) (type index start end)) (let* ((last-dot (position #\. namestr :start (1+ start) :end end :from-end t))) @@ -239,9 +239,9 @@ (:relative "")) "")) (devstring (if (and device (not (eq device :unspecific))) - (concatenate 'simple-base-string (string device) (string #\:)) + (concatenate 'simple-string (string device) (string #\:)) "")) - (headstring (concatenate 'simple-base-string devstring dirstring))) + (headstring (concatenate 'simple-string devstring dirstring))) (if directory (%enumerate-directories headstring (rest directory) pathname verify-existence follow-links nil function) @@ -274,10 +274,10 @@ (let ((piece (car tail))) (etypecase piece (simple-string - (let ((head (concatenate 'base-string head piece))) + (let ((head (concatenate 'string head piece))) (with-directory-node-noted (head) (%enumerate-directories - (concatenate 'base-string head + (concatenate 'string head (host-unparse-directory-separator host)) (cdr tail) pathname verify-existence follow-links @@ -293,8 +293,8 @@ (%enumerate-directories head (rest tail) pathname verify-existence follow-links nodes function) - (dolist (name (ignore-errors (directory-lispy-filenames head))) - (let ((subdir (concatenate 'base-string head name))) + (dolist (name (directory-lispy-filenames head)) + (let ((subdir (concatenate 'string head name))) (multiple-value-bind (res dev ino mode) (unix-xstat subdir) (declare (type (or fixnum null) mode)) @@ -305,14 +305,14 @@ (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 '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 'string head name))) (multiple-value-bind (res dev ino mode) (unix-xstat subdir) (declare (type (or fixnum null) mode)) @@ -320,7 +320,7 @@ (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 'string subdir (host-unparse-directory-separator host)))) (%enumerate-directories subdir (rest tail) pathname verify-existence follow-links nodes function)))))))) @@ -330,9 +330,9 @@ :pathname pathname :format-control "~@")) (with-directory-node-removed (head) - (let ((head (concatenate 'base-string head ".."))) + (let ((head (concatenate 'string head ".."))) (with-directory-node-noted (head) - (%enumerate-directories (concatenate 'base-string head (host-unparse-directory-separator host)) + (%enumerate-directories (concatenate 'string head (host-unparse-directory-separator host)) (rest tail) pathname verify-existence follow-links nodes function))))) @@ -355,7 +355,7 @@ (/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 'string))) (when (or (not verify-existence) (sb!unix:unix-file-kind directory)) (funcall function directory)))) @@ -382,19 +382,19 @@ (components-match file-type type) (components-match file-version version)) (funcall function - (concatenate 'base-string + (concatenate 'string directory complete-filename)))))) (t (/noshow0 "default case") - (let ((file (concatenate 'base-string directory name))) + (let ((file (concatenate '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 '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 'string file "." (quick-integer-to-string version)))) (/noshow0 "finished possibly tweaking FILE") (when (or (not verify-existence) @@ -572,6 +572,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. If the HOME environment variable has been specified, the directory it designates is returned; otherwise obtains the home directory from the operating @@ -848,7 +849,7 @@ system." :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) 'string))) (when verbose (format *standard-output* "~&creating directory: ~A~%" diff --git a/src/code/host-c-call.lisp b/src/code/host-c-call.lisp index 8050231..1976a2f 100644 --- a/src/code/host-c-call.lisp +++ b/src/code/host-c-call.lisp @@ -11,28 +11,72 @@ (/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)) + (external-format :default :type keyword) + (element-type 'character :type (member character base-char))) -(define-alien-type-translator c-string () +(define-alien-type-translator c-string + (&key (external-format :default) + (element-type 'character)) (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)) + :element-type element-type + :external-format external-format)) + +(defun c-string-external-format (type) + (let ((external-format (alien-c-string-type-external-format type))) + (if (eq external-format :default) + (default-c-string-external-format) + external-format))) (define-alien-type-method (c-string :unparse) (type) - (declare (ignore type)) - 'c-string) + (list 'c-string + :external-format (alien-c-string-type-external-format type) + :element-type (alien-c-string-type-element-type type))) (define-alien-type-method (c-string :lisp-rep) (type) (declare (ignore type)) '(or simple-string null (alien (* char)))) +(defun c-string-needs-conversion-p (type) + #+sb-xc-host + t + #-sb-xc-host + (let ((external-format (sb!impl::get-external-format + ;; Can't use C-STRING-EXTERNAL-FORMAT here, + ;; since the meaning of :DEFAULT can change + ;; when *DEFAULT-C-STRING-EXTERNAL-FORMAT* + ;; changes. + (alien-c-string-type-external-format type)))) + (not (and external-format + (or (eq (caar external-format) :ascii) + ;; On non-SB-UNICODE all latin-1 codepoints will fit + ;; into a base-char, on SB-UNICODE they won't. + #!-sb-unicode + (eq (caar external-format) :latin-1)))))) + (define-alien-type-method (c-string :naturalize-gen) (type alien) - (declare (ignore type)) `(if (zerop (sap-int ,alien)) nil - (%naturalize-c-string ,alien))) + ;; Check whether we need to do a full external-format + ;; conversion, or whether we can just do a cheap byte-by-byte + ;; copy of the c-string data. + ;; + ;; On SB-UNICODE we can never do the cheap copy, even if the + ;; external format and element-type are suitable, since + ;; simple-base-strings may not contain ISO-8859-1 characters. + ;; If we need to check for non-ascii data in the input, we + ;; might as well go through the usual external-format machinery + ;; instead of rewriting another version of it. + ,(if #!+sb-unicode t + #!-sb-unicode (c-string-needs-conversion-p type) + `(sb!alien::c-string-to-string ,alien + (c-string-external-format ,type) + (alien-c-string-type-element-type + ,type)) + `(%naturalize-c-string ,alien)))) (define-alien-type-method (c-string :deport-gen) (type value) - (declare (ignore type)) `(etypecase ,value (null (int-sap 0)) ((alien (* char)) (alien-sap ,value)) @@ -53,46 +97,25 @@ ;; #define in gencgc.c or modifying the example so that a major ;; GC will occasionally be triggered would unmask the bug). ;; - ;; The SIMPLE-BASE-STRING case will generally be very hard to - ;; trigger on GENCGC (even when threaded) thanks to GC - ;; conservativeness. It's mostly a problem on cheneygc. - ;; -- JES, 2006-01-13 - (simple-base-string (vector-sap ,value)) + ;; The pure VECTOR-SAP branch for the SIMPLE-BASE-STRING case + ;; will generally be very hard to trigger on GENCGC (even when + ;; threaded) thanks to GC conservativeness. It's mostly a problem + ;; on cheneygc. -- JES, 2006-01-13 + (simple-base-string + ,(if (c-string-needs-conversion-p type) + ;; If the alien type is not ascii-compatible (+SB-UNICODE) + ;; or latin-1-compatible (-SB-UNICODE), we need to do + ;; external format conversion. + `(vector-sap (string-to-c-string ,value + (c-string-external-format ,type))) + ;; Otherwise we can just pass it uncopied. + `(vector-sap ,value))) ;; This case, on the other hand, will cause trouble on GENCGC, since ;; 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))))) - -(/show0 "host-c-call.lisp 42") - -(define-alien-type-class (utf8-string :include pointer :include-args (to))) - -(define-alien-type-translator utf8-string () - (make-alien-utf8-string-type - :to (parse-alien-type 'char (sb!kernel:make-null-lexenv)))) - -(define-alien-type-method (utf8-string :unparse) (type) - (declare (ignore type)) - 'utf8-string) - -(define-alien-type-method (utf8-string :lisp-rep) (type) - (declare (ignore type)) - '(or simple-string null (alien (* char)))) - -(define-alien-type-method (utf8-string :naturalize-gen) (type alien) - (declare (ignore type)) - `(if (zerop (sap-int ,alien)) - nil - (%naturalize-utf8-string ,alien))) - -(define-alien-type-method (utf8-string :deport-gen) (type value) - (declare (ignore type)) - `(etypecase ,value - (null (int-sap 0)) - ((alien (* char)) (alien-sap ,value)) - ;; See the C-STRING :DEPORT-GEN comments for GC safety issues. - (simple-base-string (vector-sap ,value)) - (simple-string (vector-sap (%deport-utf8-string ,value))))) + (simple-string + (vector-sap (string-to-c-string ,value + (c-string-external-format ,type)))))) (/show0 "host-c-call.lisp end of file") diff --git a/src/code/octets.lisp b/src/code/octets.lisp index b86a1be..5aca4f8 100644 --- a/src/code/octets.lisp +++ b/src/code/octets.lisp @@ -644,7 +644,8 @@ one-past-the-end" (let ((external-format #!-win32 (intern (or (sb!alien:alien-funcall (extern-alien "nl_langinfo" - (function c-string int)) + (function (c-string :external-format :latin-1) + int)) sb!unix:codeset) "LATIN-1") "KEYWORD") diff --git a/src/code/pathname.lisp b/src/code/pathname.lisp index 2fa8fa0..cea8b13 100644 --- a/src/code/pathname.lisp +++ b/src/code/pathname.lisp @@ -52,7 +52,7 @@ (unparse-enough #'unparse-enough-namestring) (unparse-directory-separator ";") (customary-case :upper))) - (name "" :type simple-base-string) + (name "" :type simple-string) (translations nil :type list) (canon-transls nil :type list)) diff --git a/src/code/run-program.lisp b/src/code/run-program.lisp index 805a92a..cafb1de 100644 --- a/src/code/run-program.lisp +++ b/src/code/run-program.lisp @@ -531,7 +531,7 @@ status slot." ;;; Is UNIX-FILENAME the name of a file that we can execute? (defun unix-filename-is-executable-p (unix-filename) - (let ((filename (coerce unix-filename 'base-string))) + (let ((filename (coerce unix-filename 'string))) (values (and (eq (sb-unix:unix-file-kind filename) :file) #-win32 (sb-unix:unix-access filename sb-unix:x_ok))))) @@ -839,7 +839,20 @@ Common Lisp Users Manual for details about the PROCESS structure. proc ;; It's friendly to allow the caller to pass any string ;; designator, but internally we'd like SIMPLE-STRINGs. - (simple-args (mapcar (lambda (x) (coerce x 'simple-string)) args))) + (simple-args + (mapcar + (lambda (x) + (coerce + ;; Apparently any spaces or double quotes in the arguments + ;; need to be escaped on win32. + #+win32 + (if (position-if (lambda (c) (find c '(#\" #\Space))) x) + (write-to-string x) + x) + #-win32 + x + 'simple-string)) + args))) (unwind-protect (let ((pfile (if search diff --git a/src/code/target-c-call.lisp b/src/code/target-c-call.lisp index df7fa8c..a3ff56a 100644 --- a/src/code/target-c-call.lisp +++ b/src/code/target-c-call.lisp @@ -34,9 +34,20 @@ (define-alien-type float single-float) (define-alien-type double double-float) +(define-alien-type utf8-string (c-string :external-format :utf8)) + (define-alien-type-translator void () (parse-alien-type '(values) (sb!kernel:make-null-lexenv))) + +(defun default-c-string-external-format () + #!+sb-xc + :latin-1 + #!-sb-xc + (or *default-c-string-external-format* + (setf *default-c-string-external-format* + (sb!impl::default-external-format)))) + ;;; FIXME: %NATURALIZE-C-STRING (and the UTF8 siblings below) would ;;; appear to be vulnerable to the lisp string moving from underneath ;;; them if the world undergoes a GC, possibly triggered by another @@ -57,16 +68,21 @@ (sb!kernel:copy-ub8-from-system-area sap 0 result 0 length) result)))) -(defun %naturalize-utf8-string (sap) +(defun string-to-c-string (string external-format) + (declare (type simple-string string)) + (locally + (declare (optimize (speed 3) (safety 0))) + (let ((func (sb!impl::get-external-format-function external-format 10))) + (unless func + (error "Undefined external-format ~A.~%" external-format)) + (funcall (symbol-function func) string)))) + +(defun c-string-to-string (sap external-format element-type) (declare (type system-area-pointer sap)) (locally - (declare (optimize (speed 3) (safety 0))) - (let ((byte-length (do* ((offset 0 (1+ offset)) - (byte #1=(sap-ref-8 sap offset) #1#)) - ((zerop byte) offset)))) - (handler-bind ((sb!impl::octet-decoding-error #'sb!impl::use-unicode-replacement-char)) - (sb!impl::utf8->string-sap-ref-8 sap 0 byte-length))))) + (declare (optimize (speed 3) (safety 0))) + (let ((func (sb!impl::get-external-format-function external-format 9))) + (unless func + (error "Undefined external-format ~A.~%" external-format)) + (funcall (symbol-function func) sap element-type)))) -(defun %deport-utf8-string (string) - (declare (type simple-string string)) - (sb!impl::string->utf8 string 0 (length string) 1)) diff --git a/src/code/target-pathname.lisp b/src/code/target-pathname.lisp index bff90db..f57d5b3 100644 --- a/src/code/target-pathname.lisp +++ b/src/code/target-pathname.lisp @@ -1302,7 +1302,7 @@ PARSE-NAMESTRING." is not alphanumeric or hyphen:~% ~S" :args (list ch) :namestring word :offset i)))) - (coerce word 'base-string))) + (coerce word 'string))) ; why not simple-string? ;;; Given a logical host or string, return a logical host. If ERROR-P ;;; is NIL, then return NIL when no such host exists. diff --git a/src/code/unix-pathname.lisp b/src/code/unix-pathname.lisp index e0ceb42..b376da8 100644 --- a/src/code/unix-pathname.lisp +++ b/src/code/unix-pathname.lisp @@ -15,7 +15,7 @@ ;;; separated subseq. The first value is true if absolute directories ;;; location. (defun split-at-slashes (namestr start end) - (declare (type simple-base-string namestr) + (declare (type simple-string namestr) (type index start end)) (let ((absolute (and (/= start end) (char= (schar namestr start) #\/)))) @@ -34,7 +34,7 @@ (defun parse-unix-namestring (namestring start end) (declare (type simple-string namestring) (type index start end)) - (setf namestring (coerce namestring 'simple-base-string)) + (setf namestring (coerce namestring 'simple-string)) (multiple-value-bind (absolute pieces) (split-at-slashes namestring start end) (multiple-value-bind (name type version) @@ -88,7 +88,7 @@ (defun parse-native-unix-namestring (namestring start end) (declare (type simple-string namestring) (type index start end)) - (setf namestring (coerce namestring 'simple-base-string)) + (setf namestring (coerce namestring 'simple-string)) (multiple-value-bind (absolute ranges) (split-at-slashes namestring start end) (let* ((components (loop for ((start . end) . rest) on ranges @@ -169,7 +169,7 @@ (t (error "invalid pattern piece: ~S" piece)))))) (apply #'concatenate - 'simple-base-string + 'simple-string (strings)))))) (defun unparse-unix-directory-list (directory) @@ -195,7 +195,7 @@ (pieces "/")) (t (error "invalid directory component: ~S" dir))))) - (apply #'concatenate 'simple-base-string (pieces)))) + (apply #'concatenate 'simple-string (pieces)))) (defun unparse-unix-directory (pathname) (declare (type pathname pathname)) @@ -228,13 +228,13 @@ (error "type component can't have a #\. inside: ~S" pathname))) (strings ".") (strings (unparse-unix-piece type)))) - (apply #'concatenate 'simple-base-string (strings)))) + (apply #'concatenate 'simple-string (strings)))) (/show0 "filesys.lisp 406") (defun unparse-unix-namestring (pathname) (declare (type pathname pathname)) - (concatenate 'simple-base-string + (concatenate 'simple-string (unparse-unix-directory pathname) (unparse-unix-file pathname))) @@ -264,7 +264,7 @@ (error "non-STRING type in NATIVE-NAMESTRING: ~S" name)) (write-char #\. s) (write-string type s)))) - 'simple-base-string))) + 'simple-string))) (defun unparse-unix-enough (pathname defaults) (declare (type pathname pathname defaults)) @@ -312,7 +312,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 'simple-string) (when (position #\. pathname-type) (error "type component can't have a #\. inside: ~S" pathname))) (strings ".") diff --git a/src/code/unix.lisp b/src/code/unix.lisp index b9c1d80..25336bf 100644 --- a/src/code/unix.lisp +++ b/src/code/unix.lisp @@ -47,7 +47,7 @@ ;;;; Lisp types used by syscalls -(deftype unix-pathname () #!-win32 'simple-base-string #!+win32 'simple-string) +(deftype unix-pathname () 'simple-string) (deftype unix-fd () `(integer 0 ,most-positive-fixnum)) (deftype unix-file-mode () '(unsigned-byte 32)) @@ -848,7 +848,7 @@ SYSCALL-FORM. Repeat evaluation of SYSCALL-FORM if it is interrupted." (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 (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) @@ -874,7 +874,7 @@ SYSCALL-FORM. Repeat evaluation of SYSCALL-FORM if it is interrupted." ;;; 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 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...) @@ -914,7 +914,7 @@ SYSCALL-FORM. Repeat evaluation of SYSCALL-FORM if it is interrupted." :from-end t))) (dir (subseq pathname 0 dir-len))) (/noshow dir) - (concatenate 'base-string dir link)) + (concatenate 'string dir link)) link)))) (if (unix-file-kind new-pathname) (setf pathname new-pathname) @@ -930,9 +930,9 @@ SYSCALL-FORM. Repeat evaluation of SYSCALL-FORM if it is interrupted." (push pathname previous-pathnames)))) (defun unix-simplify-pathname (src) - (declare (type simple-base-string src)) + (declare (type simple-string src)) (let* ((src-len (length src)) - (dst (make-string src-len :element-type 'base-char)) + (dst (make-string src-len :element-type 'character)) (dst-len 0) (dots 0) (last-slash nil)) @@ -1007,7 +1007,7 @@ SYSCALL-FORM. Repeat evaluation of SYSCALL-FORM if it is interrupted." (if prev-prev-slash (setf dst-len (1+ prev-prev-slash)) (return-from unix-simplify-pathname - (coerce "./" 'simple-base-string)))))))) + (coerce "./" 'simple-string)))))))) (cond ((zerop dst-len) "./") ((= dst-len src-len) diff --git a/src/code/win32-pathname.lisp b/src/code/win32-pathname.lisp index 14c5b2f..f39891a 100644 --- a/src/code/win32-pathname.lisp +++ b/src/code/win32-pathname.lisp @@ -12,7 +12,7 @@ (in-package "SB!IMPL") (defun extract-device (namestr start end) - (declare (type simple-base-string namestr) + (declare (type 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 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 '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 '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 + '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 '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 'simple-string (strings)))) (defun unparse-win32-namestring (pathname) (declare (type pathname pathname)) - (concatenate 'simple-base-string + (concatenate '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))) + 'simple-string))) ;;; FIXME. (defun unparse-win32-enough (pathname defaults) @@ -340,7 +340,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 'simple-string) (when (position #\. pathname-type) (error "type component can't have a #\. inside: ~S" pathname))) (strings ".") diff --git a/tests/external-format.impure.lisp b/tests/external-format.impure.lisp index 1373538..430078b 100644 --- a/tests/external-format.impure.lisp +++ b/tests/external-format.impure.lisp @@ -280,4 +280,45 @@ (assert (char= char new-char))))) (values))) +;;; External format support in SB-ALIEN + +(with-test (:name (:sb-alien :vanilla)) + (define-alien-routine strdup c-string (str c-string)) + (assert (equal "foo" (strdup "foo")))) + +(with-test (:name (:sb-alien :utf-8 :utf-8)) + (define-alien-routine strdup (c-string :external-format :utf-8) + (str (c-string :external-format :utf-8))) + (assert (equal "foo" (strdup "foo")))) + +(with-test (:name (:sb-alien :latin-1 :utf-8)) + (define-alien-routine strdup (c-string :external-format :latin-1) + (str (c-string :external-format :utf-8))) + (assert (= (length (strdup (string (code-char 246)))) + 2))) + +(with-test (:name (:sb-alien :utf-8 :latin-1)) + (define-alien-routine strdup (c-string :external-format :utf-8) + (str (c-string :external-format :latin-1))) + (assert (equal (string (code-char 228)) + (strdup (concatenate 'string + (list (code-char 195)) + (list (code-char 164))))))) + +(with-test (:name (:sb-alien :ebcdic :ebcdic)) + (define-alien-routine strdup (c-string :external-format :ebcdic-us) + (str (c-string :external-format :ebcdic-us))) + (assert (equal "foo" (strdup "foo")))) + +(with-test (:name (:sb-alien :latin-1 :ebcdic)) + (define-alien-routine strdup (c-string :external-format :latin-1) + (str (c-string :external-format :ebcdic-us))) + (assert (not (equal "foo" (strdup "foo"))))) + +(with-test (:name (:sb-alien :simple-base-string)) + (define-alien-routine strdup (c-string :external-format :ebcdic-us + :element-type base-char) + (str (c-string :external-format :ebcdic-us))) + (assert (typep (strdup "foo") 'simple-base-string))) + ;;;; success diff --git a/version.lisp-expr b/version.lisp-expr index 3e55064..820c3b5 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"0.9.16.16" +"0.9.16.17" -- 1.7.10.4