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