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

diff --git a/CREDITS b/CREDITS
index 1f707f8..6394064 100644 (file)
--- a/CREDITS
+++ b/CREDITS
@@ -606,6 +606,11 @@ Teemu Kalvas:
   character database, restoring the FAST-READ-CHAR optimization and
   developing external format support.
 
   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.
 
 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).
 
   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.
 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.
 
 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
 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 (file)
--- a/INSTALL
+++ b/INSTALL
@@ -154,7 +154,8 @@ INSTALLING SBCL
                (pushnew x features))
              (disable (x)
                (setf features (remove x features))))
                (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
         (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
     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
 
     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
 
     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 (file)
--- 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:
 ;;;; -*- 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*,
   * 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)
     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.
   * 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
     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
 
 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 (file)
--- 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)
 ;;; 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.
   ;; 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)
 ;;; 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
   (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 (file)
--- 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
 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
 
 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 (file)
--- 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"
                "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
                "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"
       :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"
                "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 (file)
--- 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)
 
 (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)
   (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 (file)
--- 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)
 ;;;     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 (file)
--- a/src/code/error.lisp
+++ b/src/code/error.lisp
@@ -124,6 +124,24 @@
                stream ':external-format (stream-external-format stream)
                octets)))))
 
                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 ~S): ~2I~_~
+                  the character with code ~D cannot be encoded.~@:>"
+               (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 ~S): ~2I~_~
+                  the octet sequence ~S cannot be decoded.~@:>"
+             (c-string-decoding-error-external-format c)
+             (character-decoding-error-octets c)))))
+

 (define-condition control-stack-exhausted (storage-condition)
   ()
   (:report
 (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 (file)
--- 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)
     (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)
     (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
 
 (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)
     (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)
     (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
 
 (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)
     (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)
     (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 (file)
--- 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)
     (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)
     (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
 
 (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)
     (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)
     (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
 
 (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)
     (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)
     (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
 
 (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)
     (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)
     (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
 
 (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)
     (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)
     (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
 
 (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)
     (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)
     (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
 
 (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)
     (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)
     (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
 
 (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)
     (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)
     (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
 
 (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)
     (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)
     (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
 
 (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)
     (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)
     (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
 
 (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)
     (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)
     (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
 
 (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)
     (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)
     (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)
 
 (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)
     (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)
     (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
 
 (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)
     (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)
     (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 (file)
--- 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)
     (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)
     (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
 
 (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)
     (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)
     (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
 
 (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)
     (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)
     (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
 
 (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)
     (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)
     (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)
 
 (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)
     (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)
     (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
 
 (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)
     (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)
     (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)
 
 (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)
     (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)
     (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
 
 (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)
     (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)
     (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
 
 (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)
     (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)
     (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
 
 (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)
     (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)
     (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
 
 (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)
     (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)
     (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
 
 (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)
     (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)
     (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 (file)
--- 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)
     (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)
     (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
 
 (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)
     (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)
     (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
 
 (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)
     (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)
     (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
 
 (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)
     (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)
     (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
 
 (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)
     (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)
     (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
 
 (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)
     (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)
     (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
 
 (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)
     (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)
     (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
 
 (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)
     (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)
     (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
 
 (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)
     (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)
     (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 (file)
--- 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)
         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)
         (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 (file)
--- 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: 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)
   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)))
 
   2
   (code-char (sap-ref-16le sap head)))
 

@@ -48,7 +48,7 @@
   2
   (if (< bits #x10000)
       (setf (sap-ref-16be sap tail) bits)
   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)))
 
   2
   (code-char (sap-ref-16be sap head)))
 

@@ -209,7 +209,7 @@
 
 (instantiate-octets-definition define-ucs-2->string)
 
 
 (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*)
 
            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 (file)
--- a/src/code/fd-stream.lisp
+++ b/src/code/fd-stream.lisp
@@ -140,6 +140,16 @@
          :stream stream
          :code code))
 
          :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)
 ;;; 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 "~@<Skip output of this character.~@:>"))
       (throw 'output-nothing nil))))
 
                 (format stream "~@<Skip output of this character.~@:>"))
       (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
 ;;; 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.")
 
   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)
 ;;; 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)
         (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))
          (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))
     `(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))
       (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
       (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
         *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))
          (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))
     `(progn
       (defun ,size-function (byte)
         (declare (ignorable byte))

@@ -1293,13 +1371,90 @@
                             ,in-expr))
                         nil)
                 (return))))
                             ,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
       (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
         *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)
 (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))
 
       (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)
                          :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))
 
       (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)
   (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)))
 
         (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
           (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))
               (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
     (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)
 ;;; 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.
 
 ;;; 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 (file)
--- 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."
   #!+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))
            (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)))
          (dst 0)
          (quoted nil))
     (do ((src start (1+ src)))

@@ -85,7 +85,7 @@
 (/show0 "filesys.lisp 86")
 
 (defun maybe-make-pattern (namestr start end)
 (/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)
            (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)
 (/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)))
            (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)))
                             (: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)
       (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 ((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
                (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
                                (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)
              (%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))
                  (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))
                                           (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))
                          (%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))
                    (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))
                                 (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))))))))
                          (%enumerate-directories subdir (rest tail) pathname
                                                  verify-existence follow-links
                                                  nodes function))))))))

@@ -330,9 +330,9 @@
                     :pathname pathname
                     :format-control "~@<invalid use of :UP after :ABSOLUTE.~@:>"))
            (with-directory-node-removed (head)
                     :pathname pathname
                     :format-control "~@<invalid use of :UP after :ABSOLUTE.~@:>"))
            (with-directory-node-removed (head)

-             (let ((head (concatenate 'base-string head "..")))
+             (let ((head (concatenate 'string head "..")))

                (with-directory-node-noted (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)))))
                                          (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")
     (/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))))
              (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
                           (components-match file-type type)
                           (components-match file-version version))
                  (funcall function

-                          (concatenate 'base-string
+                          (concatenate 'string

                                        directory
                                        complete-filename))))))
           (t
            (/noshow0 "default case")
                                        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")
              (/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")
              (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)
                                        (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)
 
 ;;; (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
   "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)
                                :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~%"
                      (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 (file)
--- a/src/code/host-c-call.lisp
+++ b/src/code/host-c-call.lisp
@@ -11,28 +11,72 @@
 
 (/show0 "host-c-call.lisp 12")
 
 
 (/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
   (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)
 
 (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))))
 
 
 (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)
 (define-alien-type-method (c-string :naturalize-gen) (type alien)

-  (declare (ignore type))

   `(if (zerop (sap-int ,alien))
        nil
   `(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)
 
 (define-alien-type-method (c-string :deport-gen) (type value)

-  (declare (ignore type))

   `(etypecase ,value
      (null (int-sap 0))
      ((alien (* char)) (alien-sap ,value))
   `(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).
      ;;
      ;;  #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
      ;; 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")
 
 (/show0 "host-c-call.lisp end of file")

diff --git a/src/code/octets.lisp b/src/code/octets.lisp
index b86a1be..5aca4f8 100644 (file)
--- 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"
       (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")
                                                     sb!unix:codeset)
                                                   "LATIN-1")
                                               "KEYWORD")

diff --git a/src/code/pathname.lisp b/src/code/pathname.lisp
index 2fa8fa0..cea8b13 100644 (file)
--- 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)))
                        (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))
 
   (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 (file)
--- 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)
 
 ;;; 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)))))
     (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.
         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
     (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 (file)
--- 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 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)))
 \f
 (define-alien-type-translator void ()
   (parse-alien-type '(values) (sb!kernel:make-null-lexenv)))
 \f

+
+(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
 ;;; 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))))
 
         (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 (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 (file)
--- 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))))
                              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.
 
 ;;; 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 (file)
--- 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)
 ;;; 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) #\/))))
            (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))
 (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)
   (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))
 (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
   (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
               (t
                (error "invalid pattern piece: ~S" piece))))))
        (apply #'concatenate

-              'simple-base-string
+              'simple-string

               (strings))))))
 
 (defun unparse-unix-directory-list (directory)
               (strings))))))
 
 (defun unparse-unix-directory-list (directory)

@@ -195,7 +195,7 @@
            (pieces "/"))
           (t
            (error "invalid directory component: ~S" dir)))))
            (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))
 
 (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))))
             (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))
 
 (/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)))
 
                (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))))
              (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))
 
 (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 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 ".")
             (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 (file)
--- a/src/code/unix.lisp
+++ b/src/code/unix.lisp
@@ -47,7 +47,7 @@
 \f
 ;;;; Lisp types used by syscalls
 
 \f
 ;;;; 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))
 (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."
 (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)
   (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)
 ;;; 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...)
   ;; 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)
                                                         :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)
                           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)
             (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))
   (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))
          (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
              (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)
     (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 (file)
--- 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)
 (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))
            (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)
       (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) #\/)
            (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))
 (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)
   (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))
 (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)
   (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
               (t
                (error "invalid pattern piece: ~S" piece))))))
        (apply #'concatenate

-              'simple-base-string
+              'simple-string

               (strings))))))
 
 (defun unparse-win32-directory-list (directory)
               (strings))))))
 
 (defun unparse-win32-directory-list (directory)

@@ -213,7 +213,7 @@
            (pieces "\\"))
           (t
            (error "invalid directory component: ~S" dir)))))
            (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))
 
 (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))))
             (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))
 
 (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)))
                (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))))
              (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)
 
 ;;; 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 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 ".")
             (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 (file)
--- a/tests/external-format.impure.lisp
+++ b/tests/external-format.impure.lisp
@@ -280,4 +280,45 @@
           (assert (char= char new-char)))))
     (values)))
 
           (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
 ;;;; success

diff --git a/version.lisp-expr b/version.lisp-expr
index 3e55064..820c3b5 100644 (file)
--- 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".)
 ;;; 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"