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.
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.
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
(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
NetBSD X
Solaris X X
Tru64 X
- Darwin (Mac OS X) X
+ Darwin (Mac OS X) X X
+ Windows X
Some operating systems are more equal than others: most of the
- development and testing is done on x86 Linux and *BSD, PPC Linux
- and Mac OS X.
+ development and testing is done on x86/x86-64 Linux and x86/PPC
+ Mac OS X.
If an underprivileged platform is important to you, you can help
by e.g. testing during the monthly freeze periods, and most
;;;; -*- 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*,
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.
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
;;; 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.
;;; 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
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
"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
: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"
(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)
;;; 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)
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
(let ((koi8-r-byte (code->koi8-r-mapper bits)))
(if koi8-r-byte
(setf (sap-ref-8 sap tail) koi8-r-byte)
- (stream-encoding-error-and-handle stream bits)))
+ (external-format-encoding-error stream bits)))
(let ((code (koi8-r->code-mapper byte)))
(if code
(code-char code)
- (stream-decoding-error stream byte)))) ;; TODO -- error check
+ (external-format-decoding-error stream byte)))) ;; TODO -- error check
(define-unibyte-mapper koi8-u->code-mapper code->koi8-u-mapper
(#x80 #x2500) ; BOX DRAWINGS LIGHT HORIZONTAL
(let ((koi8-u-byte (code->koi8-u-mapper bits)))
(if koi8-u-byte
(setf (sap-ref-8 sap tail) koi8-u-byte)
- (stream-encoding-error-and-handle stream bits)))
+ (external-format-encoding-error stream bits)))
(let ((code (koi8-u->code-mapper byte)))
(if code
(code-char code)
- (stream-decoding-error stream byte)))) ;; TODO -- error check
+ (external-format-decoding-error stream byte)))) ;; TODO -- error check
(define-unibyte-mapper x-mac-cyrillic->code-mapper code->x-mac-cyrillic-mapper
(#x80 #x0410) ; CYRILLIC CAPITAL LETTER A
(let ((x-mac-cyrillic-byte (code->x-mac-cyrillic-mapper bits)))
(if x-mac-cyrillic-byte
(setf (sap-ref-8 sap tail) x-mac-cyrillic-byte)
- (stream-encoding-error-and-handle stream bits)))
+ (external-format-encoding-error stream bits)))
(let ((code (x-mac-cyrillic->code-mapper byte)))
(if code
(code-char code)
- (stream-decoding-error stream byte)))) ;; TODO -- error check
+ (external-format-decoding-error stream byte)))) ;; TODO -- error check
(let ((cp437-byte (code->cp437-mapper bits)))
(if cp437-byte
(setf (sap-ref-8 sap tail) cp437-byte)
- (stream-encoding-error-and-handle stream bits)))
+ (external-format-encoding-error stream bits)))
(let ((code (cp437->code-mapper byte)))
(if code
(code-char code)
- (stream-decoding-error stream byte)))) ;; TODO -- error check
+ (external-format-decoding-error stream byte)))) ;; TODO -- error check
(define-unibyte-mapper cp850->code-mapper code->cp850-mapper
(#x80 #x00C7) ; LATIN CAPITAL LETTER C WITH CEDILLA
(let ((cp850-byte (code->cp850-mapper bits)))
(if cp850-byte
(setf (sap-ref-8 sap tail) cp850-byte)
- (stream-encoding-error-and-handle stream bits)))
+ (external-format-encoding-error stream bits)))
(let ((code (cp850->code-mapper byte)))
(if code
(code-char code)
- (stream-decoding-error stream byte)))) ;; TODO -- error check
+ (external-format-decoding-error stream byte)))) ;; TODO -- error check
(define-unibyte-mapper cp852->code-mapper code->cp852-mapper
(#x80 #x00C7) ; LATIN CAPITAL LETTER C WITH CEDILLA
(let ((cp852-byte (code->cp852-mapper bits)))
(if cp852-byte
(setf (sap-ref-8 sap tail) cp852-byte)
- (stream-encoding-error-and-handle stream bits)))
+ (external-format-encoding-error stream bits)))
(let ((code (cp852->code-mapper byte)))
(if code
(code-char code)
- (stream-decoding-error stream byte)))) ;; TODO -- error check
+ (external-format-decoding-error stream byte)))) ;; TODO -- error check
(define-unibyte-mapper cp855->code-mapper code->cp855-mapper
(#x80 #x0452) ; CYRILLIC SMALL LETTER DJE
(let ((cp855-byte (code->cp855-mapper bits)))
(if cp855-byte
(setf (sap-ref-8 sap tail) cp855-byte)
- (stream-encoding-error-and-handle stream bits)))
+ (external-format-encoding-error stream bits)))
(let ((code (cp855->code-mapper byte)))
(if code
(code-char code)
- (stream-decoding-error stream byte)))) ;; TODO -- error check
+ (external-format-decoding-error stream byte)))) ;; TODO -- error check
(define-unibyte-mapper cp857->code-mapper code->cp857-mapper
(#x80 #x00C7) ; LATIN CAPITAL LETTER C WITH CEDILLA
(let ((cp857-byte (code->cp857-mapper bits)))
(if cp857-byte
(setf (sap-ref-8 sap tail) cp857-byte)
- (stream-encoding-error-and-handle stream bits)))
+ (external-format-encoding-error stream bits)))
(let ((code (cp857->code-mapper byte)))
(if code
(code-char code)
- (stream-decoding-error stream byte)))) ;; TODO -- error check
+ (external-format-decoding-error stream byte)))) ;; TODO -- error check
(define-unibyte-mapper cp860->code-mapper code->cp860-mapper
(#x80 #x00C7) ; LATIN CAPITAL LETTER C WITH CEDILLA
(let ((cp860-byte (code->cp860-mapper bits)))
(if cp860-byte
(setf (sap-ref-8 sap tail) cp860-byte)
- (stream-encoding-error-and-handle stream bits)))
+ (external-format-encoding-error stream bits)))
(let ((code (cp860->code-mapper byte)))
(if code
(code-char code)
- (stream-decoding-error stream byte)))) ;; TODO -- error check
+ (external-format-decoding-error stream byte)))) ;; TODO -- error check
(define-unibyte-mapper cp861->code-mapper code->cp861-mapper
(#x80 #x00C7) ; LATIN CAPITAL LETTER C WITH CEDILLA
(let ((cp861-byte (code->cp861-mapper bits)))
(if cp861-byte
(setf (sap-ref-8 sap tail) cp861-byte)
- (stream-encoding-error-and-handle stream bits)))
+ (external-format-encoding-error stream bits)))
(let ((code (cp861->code-mapper byte)))
(if code
(code-char code)
- (stream-decoding-error stream byte)))) ;; TODO -- error check
+ (external-format-decoding-error stream byte)))) ;; TODO -- error check
(define-unibyte-mapper cp862->code-mapper code->cp862-mapper
(#x80 #x05D0) ; HEBREW LETTER ALEF
(let ((cp862-byte (code->cp862-mapper bits)))
(if cp862-byte
(setf (sap-ref-8 sap tail) cp862-byte)
- (stream-encoding-error-and-handle stream bits)))
+ (external-format-encoding-error stream bits)))
(let ((code (cp862->code-mapper byte)))
(if code
(code-char code)
- (stream-decoding-error stream byte)))) ;; TODO -- error check
+ (external-format-decoding-error stream byte)))) ;; TODO -- error check
(define-unibyte-mapper cp863->code-mapper code->cp863-mapper
(#x80 #x00C7) ; LATIN CAPITAL LETTER C WITH CEDILLA
(let ((cp863-byte (code->cp863-mapper bits)))
(if cp863-byte
(setf (sap-ref-8 sap tail) cp863-byte)
- (stream-encoding-error-and-handle stream bits)))
+ (external-format-encoding-error stream bits)))
(let ((code (cp863->code-mapper byte)))
(if code
(code-char code)
- (stream-decoding-error stream byte)))) ;; TODO -- error check
+ (external-format-decoding-error stream byte)))) ;; TODO -- error check
(define-unibyte-mapper cp864->code-mapper code->cp864-mapper
(#x80 #x00B0) ; DEGREE SIGN
(let ((cp864-byte (code->cp864-mapper bits)))
(if cp864-byte
(setf (sap-ref-8 sap tail) cp864-byte)
- (stream-encoding-error-and-handle stream bits)))
+ (external-format-encoding-error stream bits)))
(let ((code (cp864->code-mapper byte)))
(if code
(code-char code)
- (stream-decoding-error stream byte)))) ;; TODO -- error check
+ (external-format-decoding-error stream byte)))) ;; TODO -- error check
(define-unibyte-mapper cp865->code-mapper code->cp865-mapper
(#x80 #x00C7) ; LATIN CAPITAL LETTER C WITH CEDILLA
(let ((cp865-byte (code->cp865-mapper bits)))
(if cp865-byte
(setf (sap-ref-8 sap tail) cp865-byte)
- (stream-encoding-error-and-handle stream bits)))
+ (external-format-encoding-error stream bits)))
(let ((code (cp865->code-mapper byte)))
(if code
(code-char code)
- (stream-decoding-error stream byte)))) ;; TODO -- error check
+ (external-format-decoding-error stream byte)))) ;; TODO -- error check
(define-unibyte-mapper cp866->code-mapper code->cp866-mapper
(#x80 #x0410) ; CYRILLIC CAPITAL LETTER A
(let ((cp866-byte (code->cp866-mapper bits)))
(if cp866-byte
(setf (sap-ref-8 sap tail) cp866-byte)
- (stream-encoding-error-and-handle stream bits)))
+ (external-format-encoding-error stream bits)))
(let ((code (cp866->code-mapper byte)))
(if code
(code-char code)
- (stream-decoding-error stream byte)))) ;; TODO -- error check
+ (external-format-decoding-error stream byte)))) ;; TODO -- error check
(define-unibyte-mapper cp869->code-mapper code->cp869-mapper
(#x80 nil)
(let ((cp869-byte (code->cp869-mapper bits)))
(if cp869-byte
(setf (sap-ref-8 sap tail) cp869-byte)
- (stream-encoding-error-and-handle stream bits)))
+ (external-format-encoding-error stream bits)))
(let ((code (cp869->code-mapper byte)))
(if code
(code-char code)
- (stream-decoding-error stream byte)))) ;; TODO -- error check
+ (external-format-decoding-error stream byte)))) ;; TODO -- error check
(define-unibyte-mapper cp874->code-mapper code->cp874-mapper
(#x80 #x20AC) ; EURO SIGN
(let ((cp874-byte (code->cp874-mapper bits)))
(if cp874-byte
(setf (sap-ref-8 sap tail) cp874-byte)
- (stream-encoding-error-and-handle stream bits)))
+ (external-format-encoding-error stream bits)))
(let ((code (cp874->code-mapper byte)))
(if code
(code-char code)
- (stream-decoding-error stream byte)))) ;; TODO -- error check
+ (external-format-decoding-error stream byte)))) ;; TODO -- error check
(let ((iso-8859-2-byte (code->iso-8859-2-mapper bits)))
(if iso-8859-2-byte
(setf (sap-ref-8 sap tail) iso-8859-2-byte)
- (stream-encoding-error-and-handle stream bits)))
+ (external-format-encoding-error stream bits)))
(let ((code (iso-8859-2->code-mapper byte)))
(if code
(code-char code)
- (stream-decoding-error stream byte)))) ;; TODO -- error check
+ (external-format-decoding-error stream byte)))) ;; TODO -- error check
(define-unibyte-mapper iso-8859-3->code-mapper code->iso-8859-3-mapper
(#xA1 #x0126) ; LATIN CAPITAL LETTER H WITH STROKE
(let ((iso-8859-3-byte (code->iso-8859-3-mapper bits)))
(if iso-8859-3-byte
(setf (sap-ref-8 sap tail) iso-8859-3-byte)
- (stream-encoding-error-and-handle stream bits)))
+ (external-format-encoding-error stream bits)))
(let ((code (iso-8859-3->code-mapper byte)))
(if code
(code-char code)
- (stream-decoding-error stream byte)))) ;; TODO -- error check
+ (external-format-decoding-error stream byte)))) ;; TODO -- error check
(define-unibyte-mapper iso-8859-4->code-mapper code->iso-8859-4-mapper
(#xA1 #x0104) ; LATIN CAPITAL LETTER A WITH OGONEK
(let ((iso-8859-4-byte (code->iso-8859-4-mapper bits)))
(if iso-8859-4-byte
(setf (sap-ref-8 sap tail) iso-8859-4-byte)
- (stream-encoding-error-and-handle stream bits)))
+ (external-format-encoding-error stream bits)))
(let ((code (iso-8859-4->code-mapper byte)))
(if code
(code-char code)
- (stream-decoding-error stream byte)))) ;; TODO -- error check
+ (external-format-decoding-error stream byte)))) ;; TODO -- error check
(define-unibyte-mapper iso-8859-5->code-mapper code->iso-8859-5-mapper
(#xA1 #x0401) ; CYRILLIC CAPITAL LETTER IO
(let ((iso-8859-5-byte (code->iso-8859-5-mapper bits)))
(if iso-8859-5-byte
(setf (sap-ref-8 sap tail) iso-8859-5-byte)
- (stream-encoding-error-and-handle stream bits)))
+ (external-format-encoding-error stream bits)))
(let ((code (iso-8859-5->code-mapper byte)))
(if code
(code-char code)
- (stream-decoding-error stream byte)))) ;; TODO -- error check
+ (external-format-decoding-error stream byte)))) ;; TODO -- error check
(define-unibyte-mapper iso-8859-6->code-mapper code->iso-8859-6-mapper
(#xA1 nil)
(let ((iso-8859-6-byte (code->iso-8859-6-mapper bits)))
(if iso-8859-6-byte
(setf (sap-ref-8 sap tail) iso-8859-6-byte)
- (stream-encoding-error-and-handle stream bits)))
+ (external-format-encoding-error stream bits)))
(let ((code (iso-8859-6->code-mapper byte)))
(if code
(code-char code)
- (stream-decoding-error stream byte)))) ;; TODO -- error check
+ (external-format-decoding-error stream byte)))) ;; TODO -- error check
(define-unibyte-mapper iso-8859-7->code-mapper code->iso-8859-7-mapper
(#xA1 #x02BD) ; MODIFIER LETTER REVERSED COMMA
(let ((iso-8859-7-byte (code->iso-8859-7-mapper bits)))
(if iso-8859-7-byte
(setf (sap-ref-8 sap tail) iso-8859-7-byte)
- (stream-encoding-error-and-handle stream bits)))
+ (external-format-encoding-error stream bits)))
(let ((code (iso-8859-7->code-mapper byte)))
(if code
(code-char code)
- (stream-decoding-error stream byte)))) ;; TODO -- error check
+ (external-format-decoding-error stream byte)))) ;; TODO -- error check
(define-unibyte-mapper iso-8859-8->code-mapper code->iso-8859-8-mapper
(#xA1 nil)
(let ((iso-8859-8-byte (code->iso-8859-8-mapper bits)))
(if iso-8859-8-byte
(setf (sap-ref-8 sap tail) iso-8859-8-byte)
- (stream-encoding-error-and-handle stream bits)))
+ (external-format-encoding-error stream bits)))
(let ((code (iso-8859-8->code-mapper byte)))
(if code
(code-char code)
- (stream-decoding-error stream byte)))) ;; TODO -- error check
+ (external-format-decoding-error stream byte)))) ;; TODO -- error check
(define-unibyte-mapper iso-8859-9->code-mapper code->iso-8859-9-mapper
(#xD0 #x011E) ; LATIN CAPITAL LETTER G WITH BREVE
(let ((iso-8859-9-byte (code->iso-8859-9-mapper bits)))
(if iso-8859-9-byte
(setf (sap-ref-8 sap tail) iso-8859-9-byte)
- (stream-encoding-error-and-handle stream bits)))
+ (external-format-encoding-error stream bits)))
(let ((code (iso-8859-9->code-mapper byte)))
(if code
(code-char code)
- (stream-decoding-error stream byte)))) ;; TODO -- error check
+ (external-format-decoding-error stream byte)))) ;; TODO -- error check
(define-unibyte-mapper iso-8859-10->code-mapper code->iso-8859-10-mapper
(#xA1 #x0104) ; LATIN CAPITAL LETTER A WITH OGONEK
(let ((iso-8859-10-byte (code->iso-8859-10-mapper bits)))
(if iso-8859-10-byte
(setf (sap-ref-8 sap tail) iso-8859-10-byte)
- (stream-encoding-error-and-handle stream bits)))
+ (external-format-encoding-error stream bits)))
(let ((code (iso-8859-10->code-mapper byte)))
(if code
(code-char code)
- (stream-decoding-error stream byte)))) ;; TODO -- error check
+ (external-format-decoding-error stream byte)))) ;; TODO -- error check
(define-unibyte-mapper iso-8859-11->code-mapper code->iso-8859-11-mapper
(#xA1 #x0E01) ; THAI CHARACTER KO KAI
(let ((iso-8859-11-byte (code->iso-8859-11-mapper bits)))
(if iso-8859-11-byte
(setf (sap-ref-8 sap tail) iso-8859-11-byte)
- (stream-encoding-error-and-handle stream bits)))
+ (external-format-encoding-error stream bits)))
(let ((code (iso-8859-11->code-mapper byte)))
(if code
(code-char code)
- (stream-decoding-error stream byte)))) ;; TODO -- error check
+ (external-format-decoding-error stream byte)))) ;; TODO -- error check
(define-unibyte-mapper iso-8859-13->code-mapper code->iso-8859-13-mapper
(#xA1 #x201D) ; RIGHT DOUBLE QUOTATION MARK
(let ((iso-8859-13-byte (code->iso-8859-13-mapper bits)))
(if iso-8859-13-byte
(setf (sap-ref-8 sap tail) iso-8859-13-byte)
- (stream-encoding-error-and-handle stream bits)))
+ (external-format-encoding-error stream bits)))
(let ((code (iso-8859-13->code-mapper byte)))
(if code
(code-char code)
- (stream-decoding-error stream byte)))) ;; TODO -- error check
+ (external-format-decoding-error stream byte)))) ;; TODO -- error check
(define-unibyte-mapper iso-8859-14->code-mapper code->iso-8859-14-mapper
(#xA1 #x1E02) ; LATIN CAPITAL LETTER B WITH DOT ABOVE
(let ((iso-8859-14-byte (code->iso-8859-14-mapper bits)))
(if iso-8859-14-byte
(setf (sap-ref-8 sap tail) iso-8859-14-byte)
- (stream-encoding-error-and-handle stream bits)))
+ (external-format-encoding-error stream bits)))
(let ((code (iso-8859-14->code-mapper byte)))
(if code
(code-char code)
- (stream-decoding-error stream byte)))) ;; TODO -- error check
+ (external-format-decoding-error stream byte)))) ;; TODO -- error check
(let ((cp1250-byte (code->cp1250-mapper bits)))
(if cp1250-byte
(setf (sap-ref-8 sap tail) cp1250-byte)
- (stream-encoding-error-and-handle stream bits)))
+ (external-format-encoding-error stream bits)))
(let ((code (cp1250->code-mapper byte)))
(if code
(code-char code)
- (stream-decoding-error stream byte)))) ;; TODO -- error check
+ (external-format-decoding-error stream byte)))) ;; TODO -- error check
(define-unibyte-mapper cp1251->code-mapper code->cp1251-mapper
(#x80 #x0402) ; CYRILLIC CAPITAL LETTER DJE
(let ((cp1251-byte (code->cp1251-mapper bits)))
(if cp1251-byte
(setf (sap-ref-8 sap tail) cp1251-byte)
- (stream-encoding-error-and-handle stream bits)))
+ (external-format-encoding-error stream bits)))
(let ((code (cp1251->code-mapper byte)))
(if code
(code-char code)
- (stream-decoding-error stream byte)))) ;; TODO -- error check
+ (external-format-decoding-error stream byte)))) ;; TODO -- error check
(define-unibyte-mapper cp1252->code-mapper code->cp1252-mapper
(#x80 #x20AC) ; EURO SIGN
(let ((cp1252-byte (code->cp1252-mapper bits)))
(if cp1252-byte
(setf (sap-ref-8 sap tail) cp1252-byte)
- (stream-encoding-error-and-handle stream bits)))
+ (external-format-encoding-error stream bits)))
(let ((code (cp1252->code-mapper byte)))
(if code
(code-char code)
- (stream-decoding-error stream byte)))) ;; TODO -- error check
+ (external-format-decoding-error stream byte)))) ;; TODO -- error check
(define-unibyte-mapper cp1253->code-mapper code->cp1253-mapper
(#x80 #x20AC) ; EURO SIGN
(let ((cp1253-byte (code->cp1253-mapper bits)))
(if cp1253-byte
(setf (sap-ref-8 sap tail) cp1253-byte)
- (stream-encoding-error-and-handle stream bits)))
+ (external-format-encoding-error stream bits)))
(let ((code (cp1253->code-mapper byte)))
(if code
(code-char code)
- (stream-decoding-error stream byte)))) ;; TODO -- error check
+ (external-format-decoding-error stream byte)))) ;; TODO -- error check
(define-unibyte-mapper cp1254->code-mapper code->cp1254-mapper
(#x80 #x20AC) ; EURO SIGN
(let ((cp1254-byte (code->cp1254-mapper bits)))
(if cp1254-byte
(setf (sap-ref-8 sap tail) cp1254-byte)
- (stream-encoding-error-and-handle stream bits)))
+ (external-format-encoding-error stream bits)))
(let ((code (cp1254->code-mapper byte)))
(if code
(code-char code)
- (stream-decoding-error stream byte)))) ;; TODO -- error check
+ (external-format-decoding-error stream byte)))) ;; TODO -- error check
(define-unibyte-mapper cp1255->code-mapper code->cp1255-mapper
(#x80 #x20AC) ; EURO SIGN
(let ((cp1255-byte (code->cp1255-mapper bits)))
(if cp1255-byte
(setf (sap-ref-8 sap tail) cp1255-byte)
- (stream-encoding-error-and-handle stream bits)))
+ (external-format-encoding-error stream bits)))
(let ((code (cp1255->code-mapper byte)))
(if code
(code-char code)
- (stream-decoding-error stream byte)))) ;; TODO -- error check
+ (external-format-decoding-error stream byte)))) ;; TODO -- error check
(define-unibyte-mapper cp1256->code-mapper code->cp1256-mapper
(#x80 #x20AC) ; EURO SIGN
(let ((cp1256-byte (code->cp1256-mapper bits)))
(if cp1256-byte
(setf (sap-ref-8 sap tail) cp1256-byte)
- (stream-encoding-error-and-handle stream bits)))
+ (external-format-encoding-error stream bits)))
(let ((code (cp1256->code-mapper byte)))
(if code
(code-char code)
- (stream-decoding-error stream byte)))) ;; TODO -- error check
+ (external-format-decoding-error stream byte)))) ;; TODO -- error check
(define-unibyte-mapper cp1257->code-mapper code->cp1257-mapper
(#x80 #x20AC) ; EURO SIGN
(let ((cp1257-byte (code->cp1257-mapper bits)))
(if cp1257-byte
(setf (sap-ref-8 sap tail) cp1257-byte)
- (stream-encoding-error-and-handle stream bits)))
+ (external-format-encoding-error stream bits)))
(let ((code (cp1257->code-mapper byte)))
(if code
(code-char code)
- (stream-decoding-error stream byte)))) ;; TODO -- error check
+ (external-format-decoding-error stream byte)))) ;; TODO -- error check
(define-unibyte-mapper cp1258->code-mapper code->cp1258-mapper
(#x80 #x20AC) ; EURO SIGN
(let ((cp1258-byte (code->cp1258-mapper bits)))
(if cp1258-byte
(setf (sap-ref-8 sap tail) cp1258-byte)
- (stream-encoding-error-and-handle stream bits)))
+ (external-format-encoding-error stream bits)))
(let ((code (cp1258->code-mapper byte)))
(if code
(code-char code)
- (stream-decoding-error stream byte)))) ;; TODO -- error check
+ (external-format-decoding-error stream byte)))) ;; TODO -- error check
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)
;;;
;;; Define external format: fd-stream
;;;
-(define-external-format/variable-width (:ucs-2le :ucs2le) nil
+(define-external-format/variable-width (:ucs-2le :ucs2le #!+win32 :ucs2 #!+win32 :ucs-2) nil
2
(if (< bits #x10000)
(setf (sap-ref-16le sap tail) bits)
- (stream-encoding-error-and-handle stream bits))
+ (external-format-encoding-error stream bits))
2
(code-char (sap-ref-16le sap head)))
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)))
(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*)
: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)
(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
element-type, string input function name, character input function name,
and string output function name.")
+(defun get-external-format (external-format)
+ (dolist (entry *external-formats*)
+ (when (member external-format (first entry))
+ (return entry))))
+
+(defun get-external-format-function (external-format index)
+ (let ((entry (get-external-format external-format)))
+ (when entry (nth index entry))))
+
;;; Find an output routine to use given the type and buffering. Return
;;; as multiple values the routine, the real type transfered, and the
;;; number of bytes per element.
(defun pick-output-routine (type buffering &optional external-format)
(when (subtypep type 'character)
- (dolist (entry *external-formats*)
- (when (member external-format (first entry))
+ (let ((entry (get-external-format external-format)))
+ (when entry
(return-from pick-output-routine
(values (symbol-function (nth (ecase buffering
(:none 4)
(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))
(def-input-routine ,in-char-function (character ,size sap head)
(let ((byte (sap-ref-8 sap head)))
,in-expr))
+ (defun ,read-c-string-function (sap element-type)
+ (declare (type system-area-pointer sap)
+ (type (member character base-char) element-type))
+ (locally
+ (declare (optimize (speed 3) (safety 0)))
+ (let* ((stream ,name)
+ (length (loop for head of-type index upfrom 0 by ,size
+ for count of-type index upto (1- ARRAY-DIMENSION-LIMIT)
+ for byte = (sap-ref-8 sap head)
+ for char of-type character = ,in-expr
+ until (zerop (char-code char))
+ finally (return count)))
+ (string (make-string length :element-type element-type)))
+ (declare (ignorable stream)
+ (type index length)
+ (type string string))
+ (/show0 before-copy-loop)
+ (loop for head of-type index upfrom 0 by ,size
+ for index of-type index below length
+ for byte = (sap-ref-8 sap head)
+ for char of-type character = ,in-expr
+ do (setf (aref string index) char))
+ string))) ;; last loop rewrite to dotimes?
+ (defun ,output-c-string-function (string)
+ (declare (type simple-string string))
+ (locally
+ (declare (optimize (speed 3) (safety 0)))
+ (let* ((length (length string))
+ (buffer (make-array (* (1+ length) ,size) :element-type '(unsigned-byte 8)))
+ (sap (sb!sys:vector-sap buffer))
+ (tail 0)
+ (stream ,name))
+ (declare (type index length tail)
+ (type system-area-pointer sap))
+ (dotimes (i length)
+ (let* ((byte (aref string i))
+ (bits (char-code byte)))
+ (declare (ignorable byte bits))
+ ,out-expr)
+ (incf tail ,size))
+ (let* ((bits 0)
+ (byte (code-char bits)))
+ (declare (ignorable bits byte))
+ ,out-expr)
+ buffer)))
(setf *external-formats*
(cons '(,external-format ,in-function ,in-char-function ,out-function
,@(mapcar #'(lambda (buffering)
(intern (format nil format (string buffering))))
'(:none :line :full))
nil ; no resync-function
- ,size-function)
+ ,size-function ,read-c-string-function ,output-c-string-function)
*external-formats*)))))
(defmacro define-external-format/variable-width
(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))
,in-expr))
nil)
(return))))
+ (defun ,read-c-string-function (sap element-type)
+ (declare (type system-area-pointer sap))
+ (locally
+ (declare (optimize (speed 3) (safety 0)))
+ (let* ((stream ,name)
+ (size 0) (head 0) (byte 0) (char nil)
+ (decode-break-reason nil)
+ (length (dotimes (count (1- ARRAY-DIMENSION-LIMIT) count)
+ (setf decode-break-reason
+ (block decode-break-reason
+ (setf byte (sap-ref-8 sap head)
+ size ,in-size-expr
+ char ,in-expr)
+ (incf head size)
+ nil))
+ (when decode-break-reason
+ (c-string-decoding-error ,name decode-break-reason))
+ (when (zerop (char-code char))
+ (return count))))
+ (string (make-string length :element-type element-type)))
+ (declare (ignorable stream)
+ (type index head length) ;; size
+ (type (unsigned-byte 8) byte)
+ (type (or null character) char)
+ (type string string))
+ (setf head 0)
+ (dotimes (index length string)
+ (setf decode-break-reason
+ (block decode-break-reason
+ (setf byte (sap-ref-8 sap head)
+ size ,in-size-expr
+ char ,in-expr)
+ (incf head size)
+ nil))
+ (when decode-break-reason
+ (c-string-decoding-error ,name decode-break-reason))
+ (setf (aref string index) char)))))
+
+ (defun ,output-c-string-function (string)
+ (declare (type simple-string string))
+ (locally
+ (declare (optimize (speed 3) (safety 0)))
+ (let* ((length (length string))
+ (char-length (make-array (1+ length) :element-type 'index))
+ (buffer-length
+ (+ (loop for i of-type index below length
+ for byte of-type character = (aref string i)
+ for bits = (char-code byte)
+ sum (setf (aref char-length i)
+ (the index ,out-size-expr)))
+ (let* ((byte (code-char 0))
+ (bits (char-code byte)))
+ (declare (ignorable byte bits))
+ (setf (aref char-length length)
+ (the index ,out-size-expr)))))
+ (tail 0)
+ (buffer (make-array buffer-length :element-type '(unsigned-byte 8)))
+ (sap (sb!sys:vector-sap buffer))
+ stream)
+ (declare (type index length buffer-length tail)
+ (type system-area-pointer sap)
+ (type null stream)
+ (ignorable stream))
+ (loop for i of-type index below length
+ for byte of-type character = (aref string i)
+ for bits = (char-code byte)
+ for size of-type index = (aref char-length i)
+ do (prog1
+ ,out-expr
+ (incf tail size)))
+ (let* ((bits 0)
+ (byte (code-char bits))
+ (size (aref char-length length)))
+ (declare (ignorable bits byte size))
+ ,out-expr)
+ buffer)))
+
(setf *external-formats*
(cons '(,external-format ,in-function ,in-char-function ,out-function
,@(mapcar #'(lambda (buffering)
(intern (format nil format (string buffering))))
'(:none :line :full))
,resync-function
- ,size-function)
+ ,size-function ,read-c-string-function ,output-c-string-function)
*external-formats*)))))
;;; Multiple names for the :ISO{,-}8859-* families are needed because on
(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))
: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))
(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)))
(if (< bits 256)
(if (= bits (char-code (aref latin-9-table bits)))
bits
- (stream-encoding-error-and-handle stream byte))
+ (external-format-encoding-error stream byte))
(if (= (aref latin-9-reverse-1 (logand bits 15)) bits)
(aref latin-9-reverse-2 (logand bits 15))
- (stream-encoding-error-and-handle stream byte))))
+ (external-format-encoding-error stream byte))))
(aref latin-9-table byte)))
(define-external-format/variable-width (:utf-8 :utf8) nil
;;; 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.
#!+sb-doc
"Remove any occurrences of #\\ from the string because we've already
checked for whatever they may have protected."
- (declare (type simple-base-string namestr)
+ (declare (type simple-string namestr)
(type index start end))
- (let* ((result (make-string (- end start) :element-type 'base-char))
+ (let* ((result (make-string (- end start) :element-type 'character))
(dst 0)
(quoted nil))
(do ((src start (1+ src)))
(/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)
(/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)))
(: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)
(let ((piece (car tail)))
(etypecase piece
(simple-string
- (let ((head (concatenate 'base-string head piece)))
+ (let ((head (concatenate 'string head piece)))
(with-directory-node-noted (head)
(%enumerate-directories
- (concatenate 'base-string head
+ (concatenate 'string head
(host-unparse-directory-separator host))
(cdr tail) pathname
verify-existence follow-links
(%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))
(eql (cdr dir) ino))
(return t)))
(let ((nodes (cons (cons dev ino) nodes))
- (subdir (concatenate 'base-string subdir (host-unparse-directory-separator host))))
+ (subdir (concatenate 'string subdir (host-unparse-directory-separator host))))
(%enumerate-directories subdir tail pathname
verify-existence follow-links
nodes function))))))))
((or pattern (member :wild))
(dolist (name (directory-lispy-filenames head))
(when (or (eq piece :wild) (pattern-matches piece name))
- (let ((subdir (concatenate 'base-string head name)))
+ (let ((subdir (concatenate 'string head name)))
(multiple-value-bind (res dev ino mode)
(unix-xstat subdir)
(declare (type (or fixnum null) mode))
(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))))))))
: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)
- (%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)))))
(/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))))
(components-match file-type type)
(components-match file-version version))
(funcall function
- (concatenate 'base-string
+ (concatenate 'string
directory
complete-filename))))))
(t
(/noshow0 "default case")
- (let ((file (concatenate 'base-string directory name)))
+ (let ((file (concatenate 'string directory name)))
(/noshow "computed basic FILE")
(unless (or (null type) (eq type :unspecific))
(/noshow0 "tweaking FILE for more-or-less-:UNSPECIFIC case")
- (setf file (concatenate 'base-string file "." type)))
+ (setf file (concatenate 'string file "." type)))
(unless (member version '(nil :newest :wild :unspecific))
(/noshow0 "tweaking FILE for more-or-less-:WILD case")
- (setf file (concatenate 'base-string file "."
+ (setf file (concatenate 'string file "."
(quick-integer-to-string version))))
(/noshow0 "finished possibly tweaking FILE")
(when (or (not verify-existence)
;;; (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
: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~%"
(/show0 "host-c-call.lisp 12")
-(define-alien-type-class (c-string :include pointer :include-args (to)))
+(define-alien-type-class (c-string :include pointer :include-args (to))
+ (external-format :default :type keyword)
+ (element-type 'character :type (member character base-char)))
-(define-alien-type-translator c-string ()
+(define-alien-type-translator c-string
+ (&key (external-format :default)
+ (element-type 'character))
(make-alien-c-string-type
- :to (parse-alien-type 'char (sb!kernel:make-null-lexenv))))
+ :to (parse-alien-type 'char (sb!kernel:make-null-lexenv))
+ :element-type element-type
+ :external-format external-format))
+
+(defun c-string-external-format (type)
+ (let ((external-format (alien-c-string-type-external-format type)))
+ (if (eq external-format :default)
+ (default-c-string-external-format)
+ external-format)))
(define-alien-type-method (c-string :unparse) (type)
- (declare (ignore type))
- 'c-string)
+ (list 'c-string
+ :external-format (alien-c-string-type-external-format type)
+ :element-type (alien-c-string-type-element-type type)))
(define-alien-type-method (c-string :lisp-rep) (type)
(declare (ignore type))
'(or simple-string null (alien (* char))))
+(defun c-string-needs-conversion-p (type)
+ #+sb-xc-host
+ t
+ #-sb-xc-host
+ (let ((external-format (sb!impl::get-external-format
+ ;; Can't use C-STRING-EXTERNAL-FORMAT here,
+ ;; since the meaning of :DEFAULT can change
+ ;; when *DEFAULT-C-STRING-EXTERNAL-FORMAT*
+ ;; changes.
+ (alien-c-string-type-external-format type))))
+ (not (and external-format
+ (or (eq (caar external-format) :ascii)
+ ;; On non-SB-UNICODE all latin-1 codepoints will fit
+ ;; into a base-char, on SB-UNICODE they won't.
+ #!-sb-unicode
+ (eq (caar external-format) :latin-1))))))
+
(define-alien-type-method (c-string :naturalize-gen) (type alien)
- (declare (ignore type))
`(if (zerop (sap-int ,alien))
nil
- (%naturalize-c-string ,alien)))
+ ;; Check whether we need to do a full external-format
+ ;; conversion, or whether we can just do a cheap byte-by-byte
+ ;; copy of the c-string data.
+ ;;
+ ;; On SB-UNICODE we can never do the cheap copy, even if the
+ ;; external format and element-type are suitable, since
+ ;; simple-base-strings may not contain ISO-8859-1 characters.
+ ;; If we need to check for non-ascii data in the input, we
+ ;; might as well go through the usual external-format machinery
+ ;; instead of rewriting another version of it.
+ ,(if #!+sb-unicode t
+ #!-sb-unicode (c-string-needs-conversion-p type)
+ `(sb!alien::c-string-to-string ,alien
+ (c-string-external-format ,type)
+ (alien-c-string-type-element-type
+ ,type))
+ `(%naturalize-c-string ,alien))))
(define-alien-type-method (c-string :deport-gen) (type value)
- (declare (ignore type))
`(etypecase ,value
(null (int-sap 0))
((alien (* char)) (alien-sap ,value))
;; #define in gencgc.c or modifying the example so that a major
;; GC will occasionally be triggered would unmask the bug).
;;
- ;; The SIMPLE-BASE-STRING case will generally be very hard to
- ;; trigger on GENCGC (even when threaded) thanks to GC
- ;; conservativeness. It's mostly a problem on cheneygc.
- ;; -- JES, 2006-01-13
- (simple-base-string (vector-sap ,value))
+ ;; The pure VECTOR-SAP branch for the SIMPLE-BASE-STRING case
+ ;; will generally be very hard to trigger on GENCGC (even when
+ ;; threaded) thanks to GC conservativeness. It's mostly a problem
+ ;; on cheneygc. -- JES, 2006-01-13
+ (simple-base-string
+ ,(if (c-string-needs-conversion-p type)
+ ;; If the alien type is not ascii-compatible (+SB-UNICODE)
+ ;; or latin-1-compatible (-SB-UNICODE), we need to do
+ ;; external format conversion.
+ `(vector-sap (string-to-c-string ,value
+ (c-string-external-format ,type)))
+ ;; Otherwise we can just pass it uncopied.
+ `(vector-sap ,value)))
;; This case, on the other hand, will cause trouble on GENCGC, since
;; we're taking the SAP of a immediately discarded temporary -> the
;; conservativeness doesn't protect us.
;; -- JES, 2006-01-13
- (simple-string (vector-sap (coerce ,value 'simple-base-string)))))
-
-(/show0 "host-c-call.lisp 42")
-
-(define-alien-type-class (utf8-string :include pointer :include-args (to)))
-
-(define-alien-type-translator utf8-string ()
- (make-alien-utf8-string-type
- :to (parse-alien-type 'char (sb!kernel:make-null-lexenv))))
-
-(define-alien-type-method (utf8-string :unparse) (type)
- (declare (ignore type))
- 'utf8-string)
-
-(define-alien-type-method (utf8-string :lisp-rep) (type)
- (declare (ignore type))
- '(or simple-string null (alien (* char))))
-
-(define-alien-type-method (utf8-string :naturalize-gen) (type alien)
- (declare (ignore type))
- `(if (zerop (sap-int ,alien))
- nil
- (%naturalize-utf8-string ,alien)))
-
-(define-alien-type-method (utf8-string :deport-gen) (type value)
- (declare (ignore type))
- `(etypecase ,value
- (null (int-sap 0))
- ((alien (* char)) (alien-sap ,value))
- ;; See the C-STRING :DEPORT-GEN comments for GC safety issues.
- (simple-base-string (vector-sap ,value))
- (simple-string (vector-sap (%deport-utf8-string ,value)))))
+ (simple-string
+ (vector-sap (string-to-c-string ,value
+ (c-string-external-format ,type))))))
(/show0 "host-c-call.lisp end of file")
(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")
(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))
;;; 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)))))
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
(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
+
+(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
(sb!kernel:copy-ub8-from-system-area sap 0 result 0 length)
result))))
-(defun %naturalize-utf8-string (sap)
+(defun string-to-c-string (string external-format)
+ (declare (type simple-string string))
+ (locally
+ (declare (optimize (speed 3) (safety 0)))
+ (let ((func (sb!impl::get-external-format-function external-format 10)))
+ (unless func
+ (error "Undefined external-format ~A.~%" external-format))
+ (funcall (symbol-function func) string))))
+
+(defun c-string-to-string (sap external-format element-type)
(declare (type system-area-pointer sap))
(locally
- (declare (optimize (speed 3) (safety 0)))
- (let ((byte-length (do* ((offset 0 (1+ offset))
- (byte #1=(sap-ref-8 sap offset) #1#))
- ((zerop byte) offset))))
- (handler-bind ((sb!impl::octet-decoding-error #'sb!impl::use-unicode-replacement-char))
- (sb!impl::utf8->string-sap-ref-8 sap 0 byte-length)))))
+ (declare (optimize (speed 3) (safety 0)))
+ (let ((func (sb!impl::get-external-format-function external-format 9)))
+ (unless func
+ (error "Undefined external-format ~A.~%" external-format))
+ (funcall (symbol-function func) sap element-type))))
-(defun %deport-utf8-string (string)
- (declare (type simple-string string))
- (sb!impl::string->utf8 string 0 (length string) 1))
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.
;;; 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) #\/))))
(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)
(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
(t
(error "invalid pattern piece: ~S" piece))))))
(apply #'concatenate
- 'simple-base-string
+ 'simple-string
(strings))))))
(defun unparse-unix-directory-list (directory)
(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))
(error "type component can't have a #\. inside: ~S" pathname)))
(strings ".")
(strings (unparse-unix-piece type))))
- (apply #'concatenate 'simple-base-string (strings))))
+ (apply #'concatenate 'simple-string (strings))))
(/show0 "filesys.lisp 406")
(defun unparse-unix-namestring (pathname)
(declare (type pathname pathname))
- (concatenate 'simple-base-string
+ (concatenate 'simple-string
(unparse-unix-directory pathname)
(unparse-unix-file pathname)))
(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))
(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 ".")
\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))
(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)
;;; 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...)
: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)
(push pathname previous-pathnames))))
(defun unix-simplify-pathname (src)
- (declare (type simple-base-string src))
+ (declare (type simple-string src))
(let* ((src-len (length src))
- (dst (make-string src-len :element-type 'base-char))
+ (dst (make-string src-len :element-type 'character))
(dst-len 0)
(dots 0)
(last-slash nil))
(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)
(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))
(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) #\/)
(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)
(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)
(t
(error "invalid pattern piece: ~S" piece))))))
(apply #'concatenate
- 'simple-base-string
+ 'simple-string
(strings))))))
(defun unparse-win32-directory-list (directory)
(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))
(error "type component can't have a #\. inside: ~S" pathname)))
(strings ".")
(strings (unparse-unix-piece type))))
- (apply #'concatenate 'simple-base-string (strings))))
+ (apply #'concatenate 'simple-string (strings))))
(defun unparse-win32-namestring (pathname)
(declare (type pathname pathname))
- (concatenate 'simple-base-string
+ (concatenate 'simple-string
(unparse-win32-device pathname)
(unparse-win32-directory pathname)
(unparse-win32-file pathname)))
(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)
(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 ".")
(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
;;; 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"
projects / sbcl.git / commitdiff