/[cmucl]/src/code/extfmts.lisp
ViewVC logotype

Diff of /src/code/extfmts.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.2.4.3 by rtoy, Mon Jun 23 15:03:31 2008 UTC revision 1.42 by rtoy, Tue Nov 30 04:09:42 2010 UTC
# Line 13  Line 13 
13    
14  (in-package "STREAM")  (in-package "STREAM")
15    
16  (export '(string-to-octets octets-to-string *default-external-format*  (intl:textdomain "cmucl")
           string-encode string-decode))  
   
 (defvar *default-external-format* :iso8859-1)  
17    
18  (defvar *external-formats* (make-hash-table :test 'equal))  (export '(string-to-octets octets-to-string *default-external-format*
19  (defvar *external-format-aliases* (make-hash-table))            string-encode string-decode set-system-external-format
20              +replacement-character-code+
21              list-all-external-formats
22              describe-external-format))
23    
24    (defvar *default-external-format*
25      :iso8859-1
26      "The default external format to use if no other external format is
27      specified")
28    
29    (defvar *external-formats*
30      (make-hash-table :test 'equal)
31      "Hash table of all the external formats that have been loaded")
32    
33    (defvar *external-format-aliases*
34      (make-hash-table)
35      "Hash table mapping an external format alias to the actual external
36      format implementation")
37    
38    ;; Each time DEF-EF-MACRO is used to define a new external format
39    ;; macro, a unique value must be used for the index.  The mapping
40    ;; between the macro and the index is here.
41    (vm::defenum (:prefix "+EF-" :suffix "+" :start 1)
42      str                                   ; string length
43      cin                                   ; input a character
44      cout                                  ; output a character
45      sin                                   ; input string
46      sout                                  ; output string
47      os                                    ; octets to string
48      so                                    ; string to octets
49      en                                    ; encode
50      de                                    ; decode
51      flush                                 ; flush state
52      copy-state                            ; copy state
53      osc                                   ; octets to string, counted
54      max)
55    
56  (defconstant +ef-os+ 2)  ;; Unicode replacement character U+FFFD
57  (defconstant +ef-so+ 3)  (defconstant +replacement-character-code+ #xFFFD)
 (defconstant +ef-en+ 4)  
 (defconstant +ef-de+ 5)  
 (defconstant +ef-max+ 6)  
58    
59  (define-condition external-format-not-implemented (error)  (define-condition external-format-not-implemented (error)
60    ()    ()
61    (:report    (:report
62      (lambda (condition stream)      (lambda (condition stream)
63        (declare (ignore condition))        (declare (ignore condition))
64        (format stream "Attempting unimplemented external-format I/O."))))        (format stream (intl:gettext "Attempting unimplemented external-format I/O.")))))
65    
66    (define-condition external-format-not-found (error)
67      ((name :reader external-format-not-found-name
68            :initarg :name))
69      (:report
70        (lambda (condition stream)
71          (format stream (intl:gettext "External format ~S not found.")
72                  (external-format-not-found-name condition)))))
73    
74  (defun %efni (a b c d)  (defun %efni (a b c d)
75    (declare (ignore a b c d))    (declare (ignore a b c d))
76    (error 'external-format-not-implemented))    (error 'external-format-not-implemented))
77    
78  (defstruct efx  (defstruct efx
79      ;;
80      ;; Function to read a sequence of octets from a stream and convert
81      ;; them a code point.
82    (octets-to-code #'%efni :type function :read-only t)    (octets-to-code #'%efni :type function :read-only t)
83      ;;
84      ;; Function to convert a codepoint to a sequence of octets and write
85      ;; them to an output stream.
86    (code-to-octets #'%efni :type function :read-only t)    (code-to-octets #'%efni :type function :read-only t)
87    (cache nil :type (or null simple-vector)))    ;;
88      ;; Function (or NIL) to force any state in the external format to be
89      ;; flushed to the output stream.  A NIL value means the external
90      ;; format does not need to do anything special.
91      (flush-state nil :type (or null function) :read-only t)
92      ;;
93      ;; Function to copy the state of the external-format.  If NIL, then
94      ;; there is no state to be copied.
95      (copy-state nil :type (or null function) :read-only t)
96      (cache nil :type (or null simple-vector))
97      ;;
98      ;; Minimum number of octets needed to form a codepoint
99      (min 1 :type kernel:index :read-only t)
100      ;;
101      ;; Maximum number of octets needed to form a codepoint.
102      (max 1 :type kernel:index :read-only t)
103      ;;
104      ;; Documentation for this external format
105      #+nil(documentation nil :type (or null string) :read-only t))
106    
107  (defstruct (external-format  (defstruct (external-format
108               (:conc-name ef-)               (:conc-name ef-)
109               (:print-function %print-external-format)               (:print-function %print-external-format)
110               (:constructor make-external-format (name efx composingp               (:constructor make-external-format (name efx composingp documentation
111                                                   &optional slots slotd)))                                                   &optional slots slotd)))
112    (name (ext:required-argument) :type (or keyword cons) :read-only t)    (name (ext:required-argument) :type (or keyword cons) :read-only t)
113    (efx (ext:required-argument) :type efx :read-only t)    (efx (ext:required-argument) :type efx :read-only t)
114    (composingp (ext:required-argument) :type boolean :read-only t)    (composingp (ext:required-argument) :type boolean :read-only t)
115    (slots #() :type simple-vector :read-only t)    (slots #() :type simple-vector :read-only t)
116    (slotd nil :type list :read-only t))    (slotd nil :type list :read-only t)
117      (documentation nil :type (or null string) :read-only t))
118    
119  (defun %print-external-format (ef stream depth)  (defun %print-external-format (ef stream depth)
120    (declare (ignore depth))    (declare (ignore depth))
121    (print-unreadable-object (ef stream :type t :identity t)    (print-unreadable-object (ef stream :type t :identity t)
122      (princ (ef-name ef) stream)))      (princ (ef-name ef) stream)))
123    
124  (defun %whatsit (ef)  (defun %intern-ef (ef)
125    (setf (gethash (ef-name ef) *external-formats*) ef))    (setf (gethash (ef-name ef) *external-formats*) ef))
126    
127  (declaim (inline ef-octets-to-code ef-code-to-octets ef-cache))  (declaim (inline ef-octets-to-code ef-code-to-octets ef-flush-state ef-copy-state
128                     ef-cache ef-min-octets ef-max-octets))
129    
130  (defun ef-octets-to-code (ef)  (defun ef-octets-to-code (ef)
131    (efx-octets-to-code (ef-efx ef)))    (efx-octets-to-code (ef-efx ef)))
# Line 70  Line 133 
133  (defun ef-code-to-octets (ef)  (defun ef-code-to-octets (ef)
134    (efx-code-to-octets (ef-efx ef)))    (efx-code-to-octets (ef-efx ef)))
135    
136    (defun ef-flush-state (ef)
137      (efx-flush-state (ef-efx ef)))
138    
139    (defun ef-copy-state (ef)
140      (efx-copy-state (ef-efx ef)))
141    
142  (defun ef-cache (ef)  (defun ef-cache (ef)
143    (efx-cache (ef-efx ef)))    (efx-cache (ef-efx ef)))
144    
145  (defmacro define-external-format (name octets-to-code code-to-octets)  (defun ef-min-octets (ef)
146    (let ((tmp1 (gensym)) (tmp2 (gensym)))    (efx-min (ef-efx ef)))
147      `(macrolet ((octets-to-code ((state input unput &rest vars) body)  
148                    `(lambda (,',tmp1 ,state ,input ,unput)  (defun ef-max-octets (ef)
149                       (declare (ignore ,',tmp1)    (efx-max (ef-efx ef)))
150                                (ignorable ,state ,input ,unput)  
151    (eval-when (:compile-toplevel :load-toplevel :execute)
152      (defun %merge-slots (old new)
153        (let* ((pos (length old))
154               (tmp (mapcar (lambda (x)
155                              (let* ((name (if (consp x) (first x) x))
156                                     (init (if (consp x) (second x) nil))
157                                     (list (if (consp x) (nthcdr 2 x) nil))
158                                     (prev (assoc name old))
159                                     (posn (if prev (second prev) (1- (incf pos)))))
160                                (list name posn init (getf list :type t))))
161                            new)))
162          (delete-duplicates (stable-sort (append old tmp) #'< :key #'second)
163                             :key #'second))))
164    
165    ;;; DEFINE-EXTERNAL-FORMAT  -- Public
166    ;;;
167    ;;; name (&key base min max size documentation) (&rest slots) octets-to-code
168    ;;;       code-to-octets flush-state copy-state
169    ;;;
170    ;;;   Define a new external format.  If base is specified, then an
171    ;;;   external format is defined that is based on a previously defined
172    ;;;   external format named Base.  The slot names used in Slots must
173    ;;;   match those defined in the Base format.
174    ;;;
175    ;;;   If Base is not specified, a new external format is defined.
176    ;;;   Min/Max/Size are the minimum and maximum number of octets that
177    ;;;   make up a character (:size N is just shorthand for :min N :max
178    ;;;   N).  Slots is a list of slot descriptions similar to defstruct.
179    ;;;
180    ;;;   In both cases, Documentation is a string that documents the
181    ;;;   external format.
182    ;;;
183    ;;; octets-to-code (state input unput error &rest vars)
184    ;;;   Defines a form to be used by the external format to convert
185    ;;;   octets to a code point.  State is a form that can be used by the
186    ;;;   body to access the state of the stream.  Input is a form that
187    ;;;   can be used to read one octet from the input stream.  (It can be
188    ;;;   called as many times as needed.)  Similarly, Unput is a form to
189    ;;;   put back one octet to the input stream.  Error is an error
190    ;;;   handler.  The default is NIL to indicate that the code should do
191    ;;;   its default handling.  Otherwise, it should be a function or
192    ;;;   symbol to indicate how errors are handled.  Vars is a list of
193    ;;;   vars that need to be defined for any symbols used within the
194    ;;;   form.
195    ;;;
196    ;;;   The error handler is a function of 3 arguments: a format message
197    ;;;   string, the offending octet (or NIL) and the number of octets
198    ;;;   read for this encoding.  If the function returns, it should
199    ;;;   return the codepoint to be used in place of the erroneous
200    ;;;   sequence.
201    ;;;
202    ;;;   This should return two values: the code and the number of octets
203    ;;;   read to form the code.
204    ;;;
205    ;;; code-to-octets (code state output error &rest vars)
206    ;;;   Defines a form to be used by the external format to convert a
207    ;;;   code point to octets for output.  Code is the code point to be
208    ;;;   converted.  State is a form to access the current value of the
209    ;;;   stream's state variable.  Output is a form that writes one octet
210    ;;;   to the output stream.  Error is the error handler.  A value of
211    ;;;   NIL means the external format should use its default method.
212    ;;;   Otherwise, it should be a symbol or function that will e called
213    ;;;   to handle the error.
214    ;;;
215    ;;;   The error function takes 2 arguments: a format message string
216    ;;;   and the offending codepoint.  If the function returns, it should
217    ;;;   be the desired replacement codepoint.
218    ;;;
219    ;;; flush-state (state output error &rest vars)
220    ;;;   Defines a form to be used by the external format to flush out
221    ;;;   any state when an output stream is closed.  Similar to
222    ;;;   CODE-TO-OCTETS, but there is no code.  Error is similar to the
223    ;;;   error parameter for code-to-octets.
224    ;;;
225    ;;; copy-state (state &rest vars)
226    ;;;   Defines a form to copy any state needed by the external format.
227    ;;;   This should probably be a deep copy so that if the original
228    ;;;   state is modified, the copy is not.
229    ;;;
230    ;;; Note: external-formats work on code-points, not
231    ;;;   characters, so that the entire 31 bit ISO-10646 range can be
232    ;;;   used internally regardless of the size of a character recognized
233    ;;;   by Lisp and external formats can be useful to people who want to
234    ;;;   process characters outside the Lisp range (see
235    ;;;   CODEPOINT-TO-OCTETS, OCTETS-TO-CODEPOINT)
236    ;;;
237    (defmacro define-external-format (name (&key base min max size (documentation ""))
238                                           (&rest slots)
239                                           &optional octets-to-code code-to-octets
240                                           flush-state copy-state)
241      (let* ((tmp (gensym))
242             (min (or min size 1))
243             (max (or max size 6))
244             (base (when base
245                     (find-external-format base)))
246             (bslotd (if base (ef-slotd base) nil))
247             (slotd (%merge-slots bslotd slots))
248             (slotb (loop for slot in slotd
249                      collect `(,(first slot)
250                                `(the ,',(fourth slot)
251                                  ;; IDENTITY is here to protect against SETF
252                                   (identity (svref %slots% ,',(second slot))))))))
253        (when documentation
254          (intl::note-translatable intl::*default-domain* documentation))
255        `(macrolet ((octets-to-code ((state input unput error &rest vars) body)
256                      `(lambda (,state ,input ,unput ,error)
257                         (declare (ignorable ,state ,input ,unput ,error)
258                                (optimize (ext:inhibit-warnings 3)))                                (optimize (ext:inhibit-warnings 3)))
259                       (let ((,input `(the (or (unsigned-byte 8) null) ,,input))                       (let (,@',slotb
260                               (,input `(the (or (unsigned-byte 8) null) ,,input))
261                             ,@(loop for var in vars collect `(,var (gensym))))                             ,@(loop for var in vars collect `(,var (gensym))))
262                         ,body)))                         ,body)))
263                  (code-to-octets ((code state output &rest vars) body)                  (code-to-octets ((code state output error &rest vars) body)
264                    `(lambda (,',tmp1 ,',tmp2 ,state ,output)                    `(lambda (,',tmp ,state ,output ,error)
265                       (declare (ignore ,',tmp1)                       (declare (ignorable ,state ,output ,error)
                               (ignorable ,state ,output)  
266                                (optimize (ext:inhibit-warnings 3)))                                (optimize (ext:inhibit-warnings 3)))
267                       (let ((,code ',code)                       (let (,@',slotb
268                               (,code ',code)
269                             ,@(loop for var in vars collect `(,var (gensym))))                             ,@(loop for var in vars collect `(,var (gensym))))
270                         `(let ((,',code (the (unsigned-byte 31) ,,',tmp2)))                         `(let ((,',code (the lisp:codepoint ,,',tmp)))
271                            (declare (ignorable ,',code))                            (declare (ignorable ,',code))
272                            ,,body)))))                            ,,body))))
273         (%whatsit (make-external-format ,name                  (flush-state ((state output error &rest vars) body)
274                    (make-efx :octets-to-code ,octets-to-code                    `(lambda (,state ,output ,error)
275                              :code-to-octets ,code-to-octets                       (declare (ignorable ,state ,output ,error))
276                              :cache (make-array +ef-max+ :initial-element nil))                       (let (,@',slotb
277                    nil                             ,@(loop for var in vars collect `(,var (gensym))))
278                    #() '())))))                         ,body)))
279                    (copy-state ((state &rest vars) body)
280  (defmacro define-composing-external-format (name input output)                    `(lambda (,state)
281    (let ((tmp1 (gensym)) (tmp2 (gensym)))                       (declare (ignorable ,state))
282                         (let (,@',slotb
283                               ,@(loop for var in vars collect `(,var (gensym))))
284                           ,body))))
285           (%intern-ef (make-external-format ,name
286                        ,(if base
287                             `(ef-efx (find-external-format ,(ef-name base)))
288                             `(make-efx :octets-to-code ,octets-to-code
289                                        :code-to-octets ,code-to-octets
290                                        :flush-state ,flush-state
291                                        :copy-state ,copy-state
292                                        :cache (make-array +ef-max+
293                                                              :initial-element nil)
294                                        :min ,(min min max)
295                                        :max ,(max min max)))
296                        nil
297                        ,documentation
298                        (let* ,(loop for x in slotd
299                                     collect (list (first x) (third x)))
300                          (vector ,@(mapcar #'first slotd)))
301                        ',slotd)))))
302    
303    ;;; DEFINE-COMPOSING-EXTERNAL-FORMAT  -- Public
304    ;;;
305    ;;; A composing-external-format differs from an (ordinary) external-format
306    ;;; in that it translates characters (really codepoints, of course) into
307    ;;; other characters, rather than translating between characters and binary
308    ;;; octets.  They have to be composed with a non-composing external-format
309    ;;; to be of any use.
310    ;;;
311    ;;;
312    ;;; name (&key min max size documentation) input output
313    ;;;   Defines a new composing external format.  The parameters Min,
314    ;;;   Max, Size, and Documentation are the same as for defining an
315    ;;;   external format.  The parameters input and output are forms to
316    ;;;   handle input and output.
317    ;;;
318    ;;; input (state input unput &rest vars)
319    ;;;   Defines a form to be used by the composing external format when
320    ;;;   reading input to transform a codepoint (or sequence of
321    ;;;   codepoints) to another.  State is a form that can be used by the
322    ;;;   body to access the state of the external format.  Input is a
323    ;;;   form that can be used to read one code point from the input
324    ;;;   stream.  (Input returns two values, the codepoint and the number
325    ;;;   of octets read.)  It may be called as many times as needed.
326    ;;;   This returns two values: the codepoint of the character (or NIL)
327    ;;;   and the number of octets read.  Similarly, Unput is a form to
328    ;;;   put back one octet to the input stream.  Vars is a list of vars
329    ;;;   that need to be defined for any symbols used within the form.
330    ;;;
331    ;;;   This should return two values: the code and the number of octets
332    ;;;   read to form the code.
333    ;;;
334    ;;; output (code state output &rest vars)
335    ;;;   Defines a form to be used by the composing external format to
336    ;;;   convert a code point to octets for output.  Code is the code
337    ;;;   point to be converted.  State is a form to access the current
338    ;;;   value of the stream's state variable.  Output is a form that
339    ;;;   writes one octet to the output stream.
340    
341    (defmacro define-composing-external-format (name (&key min max size documentation)
342                                                     input output)
343      (let ((tmp (gensym))
344            (min (or min size 1))
345            (max (or max size 1)))
346      `(macrolet ((input ((state input unput &rest vars) body)      `(macrolet ((input ((state input unput &rest vars) body)
347                    `(lambda (,',tmp1 ,state ,input ,unput)                    `(lambda (,state ,input ,unput)
348                       (declare (ignore ,',tmp1)                       (declare (ignorable ,state ,input ,unput)
                               (ignorable ,state ,input ,unput)  
349                                (optimize (ext:inhibit-warnings 3)))                                (optimize (ext:inhibit-warnings 3)))
350                       (let ((,input `(the (values (or (unsigned-byte 31) null)                       (let ((,input `(the (values (or lisp:codepoint null)
351                                                   lisp::index)                                                   kernel:index)
352                                           ,,input))                                           ,,input))
353                             ,@(loop for var in vars collect `(,var (gensym))))                             ,@(loop for var in vars collect `(,var (gensym))))
354                         ,body)))                         ,body)))
355                  (output ((code state output &rest vars) body)                  (output ((code state output &rest vars) body)
356                    `(lambda (,',tmp1 ,',tmp2 ,state ,output)                    `(lambda (,',tmp ,state ,output)
357                       (declare (ignore ,',tmp1)                       (declare (ignorable ,state ,output)
                               (ignorable ,state ,output)  
358                                (optimize (ext:inhibit-warnings 3)))                                (optimize (ext:inhibit-warnings 3)))
359                       (let ((,code ',code)                       (let ((,code ',code)
360                             ,@(loop for var in vars collect `(,var (gensym))))                             ,@(loop for var in vars collect `(,var (gensym))))
361                         `(let ((,',code (the (unsigned-byte 31) ,,',tmp2)))                         `(let ((,',code (the lisp:codepoint ,,',tmp)))
362                            (declare (ignorable ,',code))                            (declare (ignorable ,',code))
363                            ,,body)))))                            ,,body)))))
364         (%whatsit (make-external-format ,name         (%intern-ef (make-external-format ,name
365                    (make-efx :octets-to-code ,input                      (make-efx :octets-to-code ,input
366                              :code-to-octets ,output)                                :code-to-octets ,output
367                    t                                :min ,(min min max) :max ,(max min max))
368                    #() '())))))                      t
369                        ,documentation
370                        #() '())))))
371    
372  (defun load-external-format-aliases ()  (defun load-external-format-aliases ()
373    (let ((*package* (find-package "KEYWORD")))    (let ((*package* (find-package "KEYWORD"))
374      (with-open-file (stm "ext-formats:aliases" :if-does-not-exist nil)          (unix::*filename-encoding* :iso8859-1))
375        (with-open-file (stm "ext-formats:aliases" :if-does-not-exist nil
376                             :external-format :iso8859-1)
377        (when stm        (when stm
378          (do ((alias (read stm nil stm) (read stm nil stm))          (do ((alias (read stm nil stm) (read stm nil stm))
379               (value (read stm nil stm) (read stm nil stm)))               (value (read stm nil stm) (read stm nil stm)))
380              ((or (eq alias stm) (eq value stm))              ((or (eq alias stm) (eq value stm))
381               (unless (eq alias stm)               (unless (eq alias stm)
382                 (warn "External-format aliases file ends early.")))                 (warn (intl:gettext "External-format aliases file ends early."))))
383            (if (and (keywordp alias) (keywordp value))            (if (and (keywordp alias) (or (keywordp value)
384                (setf (gethash alias *external-format-aliases*) value)                                          (and (consp value)
385                (warn "Bad entry in external-format aliases file: ~S => ~S."                                               (every #'keywordp value))))
386                      alias value)))))))                (setf (gethash alias *external-format-aliases*) value)
387                  (warn (intl:gettext "Bad entry in external-format aliases file: ~S => ~S.")
388                        alias value)))))))
389    
390    (defun list-all-external-formats ()
391      "List the available external formats.  A list is returned where each
392      element is list of the external format and a list of aliases for the
393      format.  No distinction is made between external formats and
394      composing external formats."
395      ;; Look for all lisp files in the ext-formats directory.  These are
396      ;; the available formats.
397      (let ((ef (make-hash-table))
398            result)
399        (map nil #'(lambda (p)
400                     (setf (gethash (intern (string-upcase (pathname-name p)) :keyword) ef)
401                           nil))
402             (directory "ext-formats:*.lisp"))
403    
404        ;; Look through aliases and update formats with a list of aliases.
405        (load-external-format-aliases)
406        (maphash #'(lambda (k v)
407                     (push k (gethash v ef)))
408                 *external-format-aliases*)
409    
410        (maphash #'(lambda (k v)
411                     (push (if v
412                               (list k v)
413                               (list k))
414                           result))
415                 ef)
416        (sort result #'string< :key #'first)))
417    
418    (defun describe-external-format (external-format)
419      "Print a description of the given External-Format.  This may cause
420      the external format to be loaded (silently), if it is not already
421      loaded."
422      (when (zerop (hash-table-count
423                    *external-format-aliases*))
424        (load-external-format-aliases))
425      (let ((alias (gethash external-format *external-format-aliases*)))
426        (cond (alias
427               (format t (intl:gettext "~&~S is an alias for the external format ~S.~2%")
428                       external-format alias))
429              ((and (listp external-format)
430                    (> (length external-format) 1))
431               ;; Some kind of composed external format
432               (format t (intl:gettext "~&~S is a composed external format.~2%") external-format))
433              (t
434               (let ((ef (handler-case (let ((*compile-print* nil)
435                                             (ext:*compile-progress* nil)
436                                             (*compile-verbose* nil))
437                                         ;; Should we be this silent when
438                                         ;; loading the external format?
439                                         ;; We aren't when the normally
440                                         ;; loading the format.
441                                         (find-external-format external-format))
442                           (external-format-not-found ()
443                             (format *error-output*
444                                     (intl:gettext "~&Could not find external format ~S~%")
445                                     external-format)))))
446                 (when ef
447                   (let (aliases)
448                     ;; Find any aliases for this external format.  Doesn't need to be efficient.
449                     (maphash #'(lambda (k v)
450                                  (when (eq v external-format)
451                                    (push k aliases)))
452                              *external-format-aliases*)
453                     (format t (intl:gettext "~S~:[~; - [Aliases: ~{~S~^, ~}~]]~%")
454                             external-format aliases aliases))
455                   (when (ef-composingp ef)
456                     (format t (intl:gettext "~&~S is a composing external format.~2%")
457                             external-format))
458                   (format t "~&~A~%"
459                           (intl:gettext (or (ef-documentation ef) "")))))))))
460    
461  (defun %find-external-format (name)  (defun %find-external-format (name)
462      ;; avoid loading files, etc., early in the boot sequence
463      (when (or (eq name :iso8859-1)
464                (and (eq name :default) (eq *default-external-format* :iso8859-1)))
465        (return-from %find-external-format
466          (gethash :iso8859-1 *external-formats*)))
467    
468    (when (zerop (hash-table-count *external-format-aliases*))    (when (zerop (hash-table-count *external-format-aliases*))
469      (setf (gethash :latin1 *external-format-aliases*) :iso8859-1)      (setf (gethash :latin1 *external-format-aliases*) :iso8859-1)
470      (setf (gethash :latin-1 *external-format-aliases*) :iso8859-1)      (setf (gethash :latin-1 *external-format-aliases*) :iso8859-1)
# Line 154  Line 476 
476         (cnt 0 (1+ cnt)))         (cnt 0 (1+ cnt)))
477        ((or (null tmp) (= cnt 50))        ((or (null tmp) (= cnt 50))
478         (unless (null tmp)         (unless (null tmp)
479           (error "External-format aliasing depth exceeded.")))           (error (intl:gettext "External-format aliasing depth exceeded."))))
480      (setq name tmp))      (setq name tmp))
481    
482    (or (gethash name *external-formats*)    (or (gethash name *external-formats*)
483        (and (let ((*package* (find-package "STREAM"))        (and (consp name) (find-external-format name))
484                   (lisp::*enable-package-locked-errors* nil))        (and (with-standard-io-syntax
485               (load (format nil "ext-formats:~(~A~)" name)               ;; Use standard IO syntax so that changes by the user
486                     :if-does-not-exist nil))               ;; don't mess up compiling the external format.
487                 (let ((*package* (find-package "STREAM"))
488                       (lisp::*enable-package-locked-errors* nil)
489                       (s (open (format nil "ext-formats:~(~A~).lisp" name)
490                                :if-does-not-exist nil :external-format :iso8859-1)))
491                   (when s
492                     (null (nth-value 1 (ext:compile-from-stream s))))))
493             (gethash name *external-formats*))))             (gethash name *external-formats*))))
494    
495  (defun %composed-ef-name (a b)  (defun %composed-ef-name (a b)
496    (if (consp a) (append a (list b)) (list a b)))    (if (consp a) (append a (list b)) (list a b)))
497    
498  (defun %compose-external-formats (a b &optional name)  (defun %compose-external-formats (a b)
499    (when (ef-composingp a)    (when (ef-composingp a)
500      (error "~S is a Composing-External-Format." (ef-name a)))      (error (intl:gettext "~S is a Composing-External-Format.") (ef-name a)))
501    (unless (ef-composingp b)    (unless (ef-composingp b)
502      (error "~S is not a Composing-External-Format." (ef-name b)))      (error (intl:gettext "~S is not a Composing-External-Format.") (ef-name b)))
   (when name  
     (setf (getf name *external-format-aliases*)  
         (%composed-ef-name (ef-name a) (ef-name b))))  
503    (make-external-format    (make-external-format
504     (%composed-ef-name (ef-name a) (ef-name b))     (%composed-ef-name (ef-name a) (ef-name b))
505     (make-efx     (make-efx
506      :octets-to-code (lambda (tmp state input unput)      :octets-to-code (lambda (state input unput error)
507                        (declare (ignore tmp))                        (let ((nstate (gensym "STATE-")))
508                        (funcall (ef-octets-to-code b) (ef-slots b)                          `(let ((,nstate ,state))
509                                 state                             (when (null ,nstate)
510                                 (funcall (ef-octets-to-code a) (ef-slots a)                               (setq ,nstate (setf ,state (cons nil nil))))
511                                          state                             ,(funcall (ef-octets-to-code b) `(car ,nstate)
512                                          input                                       (funcall (ef-octets-to-code a)
513                                          unput)                                                `(cdr ,nstate) input unput error)
514                                 unput))                                       unput))))
515      :code-to-octets (lambda (tmp code state output)      :code-to-octets (lambda (code state output error)
516                        (declare (ignore tmp))                        (let ((nstate (gensym "STATE-")))
517                        (funcall (ef-code-to-octets b) (ef-slots b)                          `(let ((,nstate ,state))
518                                 code                             (when (null ,nstate)
519                                 state                               (setq ,nstate (setf ,state (cons nil nil))))
520                                 `(lambda (x)                             ,(funcall (ef-code-to-octets b) code `(car ,nstate)
521                                   ,(funcall (ef-code-to-octets a)                                       `(lambda (x)
522                                             (ef-slots a)                                         ,(funcall (ef-code-to-octets a)
523                                             'x state output))))                                                   'x `(cdr ,nstate) output error))))))
524      :cache (make-array +ef-max+ :initial-element nil))      :cache (make-array +ef-max+ :initial-element nil)
525        :min (* (ef-min-octets a) (ef-min-octets b))
526        :max (* (ef-max-octets a) (ef-max-octets b)))
527       nil
528     nil #() '()))     nil #() '()))
529    
530  (defun find-external-format (name &optional (error-p t))  (defun find-external-format (name &optional (error-p t))
# Line 204  Line 532 
532      (return-from find-external-format name))      (return-from find-external-format name))
533    
534    (or (if (consp name) (every #'keywordp name) (keywordp name))    (or (if (consp name) (every #'keywordp name) (keywordp name))
535        (error "~S is not a valid external format name." name))        (error (intl:gettext "~S is not a valid external format name.") name))
536    
537    (when (eq name :default)    (when (eq name :default)
538      (setq name *default-external-format*))      (setq name *default-external-format*))
# Line 212  Line 540 
540    (when (and (consp name) (not (cdr name)))    (when (and (consp name) (not (cdr name)))
541      (setq name (car name)))      (setq name (car name)))
542    
543    (if (consp name)    (flet ((not-found ()
544        (let ((efs (mapcar #'%find-external-format name)))             (when (equal *default-external-format* name)
545          (if (member nil efs)               (setq *default-external-format* :iso8859-1))
546              (if error-p (error "External format ~S not found." name) nil)             (if error-p (error 'external-format-not-found :name name) nil)))
547              (let ((name (reduce #'%composed-ef-name (mapcar #'ef-name efs))))      (if (consp name)
548                (or (gethash name *external-formats*)          (let ((efs (mapcar #'%find-external-format name)))
549                    (%whatsit (reduce #'%compose-external-formats efs))))))            (if (member nil efs)
550        (or (%find-external-format name)                (not-found)
551            (if error-p (error "External format ~S not found." name) nil))))                (let ((name (reduce #'%composed-ef-name (mapcar #'ef-name efs))))
552                    (or (gethash name *external-formats*)
553                        (%intern-ef (reduce #'%compose-external-formats efs))))))
554            (or (%find-external-format name) (not-found)))))
555    
556    (defun flush-external-formats ()
557      (maphash (lambda (name ef)
558                 (declare (ignore name))
559                 (fill (ef-cache ef) nil))
560               *external-formats*))
561    
562    (defvar *.table-inverse.* (make-hash-table :test 'eq :size 7))
563    
564    (defun invert-table (table)
565      (declare (type (or (simple-array (unsigned-byte 31) *)
566                         (simple-array (unsigned-byte 16) *))
567                     table)
568               (optimize (speed 3) (space 0) (safety 0) (debug 0)
569                         (ext:inhibit-warnings 3)))
570      (or (gethash table *.table-inverse.*)
571          (let* ((mbits (if (= (array-total-size table) 128) 7 8))
572                 (lbits (cond ((> (array-total-size table) 256) 3)
573                              ((< (array-total-size table) 100) 6)
574                              (t 5)))
575                 (hvec (make-array (1+ (ash #x110000 (- 0 mbits lbits)))
576                                   :element-type '(unsigned-byte 16)
577                                   :initial-element #xFFFF))
578                 (mvec (make-array 0 :element-type '(unsigned-byte 16)))
579                 (lvec (make-array 0 :element-type '(unsigned-byte 16)))
580                 (width (array-dimension table 0))
581                 (power (1- (array-rank table)))
582                 (base (if (= width 94) 1 0))
583                 hx mx lx)
584            (assert (and (< power 2) (<= width 256)))
585            (dotimes (i (array-total-size table))
586              (declare (type (integer 0 (#.array-dimension-limit)) i))
587              (let ((tmp i) (val (row-major-aref table i)) (z 0))
588                (declare (type (integer 0 (#.array-dimension-limit)) tmp)
589                         (type (unsigned-byte 16) z))
590                (unless (= val #xFFFE)
591                  (when (plusp power)
592                    (multiple-value-bind (x y) (floor tmp width)
593                      (setq tmp x)
594                      (setq z (logior z (ash (the (integer 0 255) (+ y base))
595                                             (the (integer 0 24)
596                                               (* 8 power)))))))
597                  (setq hx (ash val (- 0 mbits lbits)))
598                  (when (= (aref hvec hx) #xFFFF)
599                    (setf (aref hvec hx) (length mvec))
600                    (let ((tmp (make-array (+ (length mvec) (ash 1 mbits))
601                                           :element-type '(unsigned-byte 16)
602                                           :initial-element #xFFFF)))
603                      (replace tmp mvec)
604                      (setq mvec tmp)))
605                  (setq mx (logand (ash val (- lbits)) (lognot (ash -1 mbits))))
606                  (when (= (aref mvec (+ (aref hvec hx) mx)) #xFFFF)
607                    (setf (aref mvec (+ (aref hvec hx) mx)) (length lvec))
608                    (let ((tmp (make-array (+ (length lvec) (ash 1 lbits))
609                                           :element-type '(unsigned-byte 16)
610                                           :initial-element #xFFFF)))
611                      (replace tmp lvec)
612                      (setq lvec tmp)))
613                  (setq lx (logand val (lognot (ash -1 lbits))))
614                  (setf (aref lvec (+ (aref mvec (+ (aref hvec hx) mx)) lx))
615                      (logior z (+ tmp base))))))
616            (setf (gethash table *.table-inverse.*)
617                (lisp::make-ntrie16 :split (logior (ash (1- mbits) 4) (1- lbits))
618                                    :hvec hvec :mvec mvec :lvec lvec)))))
619    
620    (declaim (inline get-inverse))
621    (defun get-inverse (ntrie code)
622      (declare (type lisp::ntrie16 ntrie) (type (integer 0 #x10FFFF) code))
623      (let ((n (lisp::qref ntrie code)))
624        (and n (let ((m (aref (lisp::ntrie16-lvec ntrie) n)))
625                 (if (= m #xFFFF) nil m)))))
626    
627    
628  (define-condition void-external-format (error)  (define-condition void-external-format (error)
629    ()    ()
630    (:report    (:report
631      (lambda (condition stream)      (lambda (condition stream)
632        (declare (ignore condition))        (declare (ignore condition))
633        (format stream "Attempting I/O through void external-format."))))        (format stream (intl:gettext "Attempting I/O through void external-format.")))))
634    
635  (define-external-format :void  (define-external-format :void (:size 0 :documentation
636    (octets-to-code (state input unput)  "Void external format that signals an error on any input or output.")
637     ()
638      (octets-to-code (state input unput error)
639      `(error 'void-external-format))      `(error 'void-external-format))
640    (code-to-octets (code state output)    (code-to-octets (code state output error)
641      `(error 'void-external-format)))      `(error 'void-external-format)))
642    
643  (define-external-format :iso8859-1  (define-external-format :iso8859-1 (:size 1 :documentation
644    (octets-to-code (state input unput)  "ISO8859-1 is an 8-bit character encoding generally intended for
645      `(values ,input 1))  Western European languages including English, German, Italian,
646    (code-to-octets (code state output)  Norwegian, Portuguese, Spanish, Swedish and many others.
     `(,output (if (> ,code 255) #x3F ,code))))  
647    
648  (defmacro octets-to-codepoint (external-format state count input unput)  By default, illegal inputs are replaced by the Unicode replacement
649    (let ((tmp1 (gensym)) (tmp2 (gensym)))  character and illegal outputs are replaced by a question mark.")
650      `(let ((body (funcall (ef-octets-to-code ,external-format)    ()
651                            (ef-slots ,external-format)    (octets-to-code (state input unput error)
652                            ',state ',input ',unput)))      `(values ,input 1))
653         `(multiple-value-bind (,',tmp1 ,',tmp2) ,body    (code-to-octets (code state output error)
654            (setf ,',count (the lisp::index ,',tmp2))      `(,output (if (> ,code 255)
655            (the (or (unsigned-byte 31) null) ,',tmp1)))))                    (if ,error
656                          (locally
657  (defmacro codepoint-to-octets (external-format code state output)                            ;; No warnings about fdefinition
658    `(funcall (ef-code-to-octets ,external-format) (ef-slots ,external-format)                            (declare (optimize (ext:inhibit-warnings 3)))
659              ',code ',state ',output))                          (funcall ,error
660                                     (intl:gettext "Cannot output codepoint #x~X to ISO8859-1 stream")
661                                     ,code 1))
662                          #x3F)
663                      ,code))))
664    
665    ;;; OCTETS-TO-CODEPOINT, CODEPOINT-TO-OCTETS  -- Semi-Public
666    ;;;
667    ;;; Normally you'd want to use OCTETS-TO-CHAR and CHAR-TO-OCTETS instead of
668    ;;; these, but that limits you to Lisp's idea of a character - either Latin-1
669    ;;; in 8 bit Lisp images, or the Unicode BMP in 16 bit images.  If you want
670    ;;; to read or write texts containing characters not supported by your Lisp,
671    ;;; these macros can be used instead.
672    (defmacro octets-to-codepoint (external-format state count input unput &optional error)
673      (let ((tmp1 (gensym)) (tmp2 (gensym))
674            (ef (find-external-format external-format)))
675        `(multiple-value-bind (,tmp1 ,tmp2)
676             ,(funcall (ef-octets-to-code ef) state input unput error)
677           (setf ,count (the kernel:index ,tmp2))
678           (the (or lisp:codepoint null) ,tmp1))))
679    
680    (defmacro codepoint-to-octets (external-format code state output &optional error)
681      (let ((ef (find-external-format external-format)))
682        (funcall (ef-code-to-octets ef) code state output error)))
683    
684    
685    
# Line 262  Line 689 
689  (defun ensure-cache (ef id reqd)  (defun ensure-cache (ef id reqd)
690    (let ((base (or (getf *ef-extensions* id)    (let ((base (or (getf *ef-extensions* id)
691                    (setf (getf *ef-extensions* id)                    (setf (getf *ef-extensions* id)
692                        (prog1 *ef-base* (incf *ef-base* reqd))))))                          (prog1 *ef-base* (incf *ef-base* reqd))))))
693      (when (< (length (ef-cache ef)) (+ base reqd))      (when (< (length (ef-cache ef)) (+ base reqd))
694        (setf (efx-cache (ef-efx ef))        (setf (efx-cache (ef-efx ef))
695            (adjust-array (ef-cache ef) (+ base reqd) :initial-element nil)))            (adjust-array (ef-cache ef) (+ base reqd) :initial-element nil)))
696      base))      base))
697    
698    ;;; DEF-EF-MACRO  -- Public
699    ;;;
700    ;;; Create an ef-macro (external-format macro).  This creates a
701    ;;; function named Name that will process an external format in the
702    ;;; desired way.
703    ;;;
704    ;;; Paul Foley says:
705    ;;;   All the existing ef-macros are provided with the implementation,
706    ;;;   so they all use lisp::lisp as the id; it's intended for people
707    ;;;   who want to write their own macros~there are some number of
708    ;;;   slots (+ef-max+) used by the implementation; the idea is that
709    ;;;   you can write something like (def-ef-macro foo (ef my-tag 4 1)
710    ;;;   ...) to implement 1 of a total of 4 new macros in your own
711    ;;;   "namespace", without having to know how many are implemented by
712    ;;;   others (e.g., the 10 used by the base implementation...which
713    ;;;   could change with the next release -- and if several libraries
714    ;;;   each add their own, the total number, and the position of each
715    ;;;   one's slots within that total, may change depending on load
716    ;;;   order, etc.)  When you write the above, it allocates 4 new
717    ;;;   places and associates the base index with "my-tag", then the
718    ;;;   "idx" value is relative to that base.  The id lisp:lisp always
719    ;;;   has its base at 0, so it doesn't need to go through ensure-cache
720    ;;;   to find that out.
721  (defmacro def-ef-macro (name (ef id reqd idx) body)  (defmacro def-ef-macro (name (ef id reqd idx) body)
722    (let ((tmp (gensym)))    (let* ((tmp1 (gensym))
723      `(defun ,name (,ef)           (tmp2 (gensym))
724         (let ((,tmp ,(if (eq id 'lisp::lisp)           (blknm (nth-value 1 (lisp::valid-function-name-p name)))
725                          idx           (%name (intern (format nil "%~A" name) #|(symbol-package blknm)|#)))
726                          `(+ (ensure-cache ,ef ',id ,reqd) ,idx))))      `(progn
727           (or (aref (ef-cache ,ef) ,tmp)         (defun ,%name (,ef)
728               (setf (aref (ef-cache ,ef) ,tmp)           (let* ((,tmp1 (find-external-format ,ef))
729                   (let ((*compile-print* nil)) (compile nil ,body))))))))                  (,tmp2 ,(if (eq id 'lisp::lisp)
730                                idx
731                                `(+ (ensure-cache ,tmp1 ',id ,reqd) ,idx))))
732               (funcall (or (aref (ef-cache ,tmp1) ,tmp2)
733                            (setf (aref (ef-cache ,tmp1) ,tmp2)
734                                  (let ((*compile-print* nil)
735                                        ;; Set default format when we compile so we
736                                        ;; can see compiler messages.  If we don't,
737                                        ;; we run into a problem that we might be
738                                        ;; changing the default format while we're
739                                        ;; compiling, and we don't know how to output
740                                        ;; the compiler messages.
741                                        #|(*default-external-format* :iso8859-1)|#)
742                                    (compile nil `(lambda (%slots%)
743                                                    (declare (ignorable %slots%))
744                                                    (block ,',blknm
745                                                      ,,body))))))
746                        (ef-slots ,tmp1))))
747           (declaim (inline ,name))
748           (defun ,name (,tmp1)
749             (let ((,tmp2 (load-time-value (cons nil nil))))
750               (when (eq ,tmp1 :default)
751                 (setq ,tmp1 *default-external-format*))
752               (if (eq ,tmp1 (car ,tmp2))
753                   (cdr ,tmp2)
754                   (setf (car ,tmp2) ,tmp1
755                         (cdr ,tmp2) (,%name ,tmp1))))))))
756    
757    
758    
759  (defmacro octets-to-char (external-format state count input unput)  ;;; OCTETS-TO-CHAR, CHAR-TO-OCTETS  -- Public
760    `(let ((body (octets-to-codepoint ,external-format  ;;;
761                                      ,state ,count ,input ,unput)))  ;;; Read and write one character through an external-format
762       `(let ((code ,body))  ;;;
763          (declare (type (unsigned-byte 31) code))  (defmacro octets-to-char (external-format state count input unput &optional error)
764          (if (< code char-code-limit) (code-char code) #\?))))    (let ((nstate (gensym)))
765        `(let ((,nstate ,state))
766  (defmacro char-to-octets (external-format char state output)         (when (null ,nstate) (setq ,nstate (setf ,state (cons nil nil))))
767    `(codepoint-to-octets ,external-format (char-code ,char) ,state ,output))         (if (car ,nstate)
768               ;; Return the trailing surrgate.  Must set count to 0 to
769               ;; tell the stream code we didn't consume any octets!
770               (prog1 (the character (car ,nstate))
771                 (setf (car ,nstate) nil ,count 0))
772               (let ((code (octets-to-codepoint ,external-format
773                                                (cdr ,nstate) ,count ,input ,unput ,error)))
774                 (declare (type lisp:codepoint code))
775                 ;;@@ on non-Unicode builds, limit to 8-bit chars
776                 ;;@@ if unicode-bootstrap, can't use #\u+fffd
777                 (cond ((or (lisp::surrogatep code) (>= code lisp:codepoint-limit))
778                        ;; Surrogate characters (that weren't combined
779                        ;; into a codepoint by octets-to-codepoint) are
780                        ;; illegal.  So are codepoints that are too large.
781                        (if ,error
782                            (if (lisp::surrogatep code)
783                                (locally
784                                    (declare (optimize (ext:inhibit-warnings 3)))
785                                  (funcall ,error
786                                           (format nil (intl:gettext "Surrogate codepoint #x~~4,'0X is illegal for ~A")
787                                                   ,external-format)
788                                           code nil))
789                                (locally
790                                    (declare (optimize (ext:inhibit-warnings 3)))
791                                  (funcall ,error (intl:gettext "Illegal codepoint on input: #x~X") code nil)))
792                            #-(and unicode (not unicode-bootstrap)) #\?
793                            #+(and unicode (not unicode-bootstrap)) #\U+FFFD))
794                       #+unicode
795                       ((> code #xFFFF)
796                        (multiple-value-bind (hi lo) (surrogates code)
797                          (setf (car ,nstate) lo)
798                          hi))
799                       (t (code-char code))))))))
800    
801    (defmacro char-to-octets (external-format char state output &optional error)
802      (let ((nchar (gensym))
803            (nstate (gensym))
804            (wryte (gensym))
805            (ch (gensym)))
806        `(let ((,nchar ,char)
807               (,nstate ,state))
808           (when (null ,nstate) (setq ,nstate (setf ,state (cons nil nil))))
809           (if (lisp::surrogatep (char-code ,nchar) :high)
810               (setf (car ,nstate) ,nchar)
811               (flet ((,wryte (,ch)
812                        (codepoint-to-octets ,external-format ,ch (cdr ,nstate)
813                                             ,output ,error)))
814                 (declare (dynamic-extent #',wryte))
815                 (if (car ,nstate)
816                     (prog1
817                         ;; Invalid surrogate sequences get replaced with
818                         ;; the replacement character.
819                         (,wryte (if (lisp::surrogatep (char-code ,nchar) :low)
820                                     (surrogates-to-codepoint (car ,nstate) ,nchar)
821                                     (if ,error
822                                         (locally
823                                             (declare (optimize (ext:inhibit-warnings 3)))
824                                           (funcall ,error
825                                                    (intl:gettext "Cannot convert invalid surrogate #x~X to character")
826                                                    ,nchar))
827                                         +replacement-character-code+)))
828                       (setf (car ,nstate) nil))
829                     ;; A lone trailing (low) surrogate gets replaced with
830                     ;; the replacement character.
831                     (,wryte (if (lisp::surrogatep (char-code ,nchar) :low)
832                                 (if ,error
833                                     (locally
834                                         (declare (optimize (ext:inhibit-warnings 3)))
835                                       (funcall ,error
836                                                (intl:gettext "Cannot convert lone trailing surrogate #x~X to character")
837                                                ,nchar))
838                                     +replacement-character-code+)
839                                 (char-code ,nchar)))))))))
840    
841    (defmacro flush-state (external-format state output &optional error)
842      (let* ((ef (find-external-format external-format))
843             (f (ef-flush-state ef)))
844        (when f
845          (funcall f state output error))))
846    
847    (defmacro copy-state (external-format state)
848      (let* ((ef (find-external-format external-format))
849             (f (ef-copy-state ef)))
850        (when f
851          (funcall f state))))
852    
853  (def-ef-macro ef-string-to-octets (extfmt lisp::lisp +ef-max+ +ef-so+)  (def-ef-macro ef-string-to-octets (extfmt lisp::lisp +ef-max+ +ef-so+)
854    `(lambda (string start end buffer &aux (ptr 0) (state nil))    `(lambda (string start end buffer error &aux (ptr 0) (state nil))
855       (declare #|(optimize (speed 3) (safety 0) (space 0) (debug 0))|#       (declare #|(optimize (speed 3) (safety 0) (space 0) (debug 0))|#
856                (type simple-string string)                (type simple-string string)
857                (type lisp::index start end ptr)                (type kernel:index start end ptr)
858                (type (simple-array (unsigned-byte 8) (*)) buffer)                (type (simple-array (unsigned-byte 8) (*)) buffer)
859                (ignorable state))                (ignorable state))
860       (dotimes (i (- end start) (values buffer ptr))      (dotimes (i (- end start) (values buffer ptr))
861         (declare (type lisp::index i))        (declare (type kernel:index i))
862         ,(char-to-octets extfmt (schar string (+ start i)) state        (char-to-octets ,extfmt (schar string (+ start i)) state
863                          (lambda (b)                        (lambda (b)
864                            (when (= ptr (length buffer))                          (when (= ptr (length buffer))
865                              (setq buffer (adjust-array buffer (* 2 ptr))))                            (setq buffer (adjust-array buffer (* 2 ptr))))
866                            (setf (aref buffer (1- (incf ptr))) b))))))                          (setf (aref buffer (1- (incf ptr))) b))
867                          error))))
868    
869  (defun string-to-octets (string &key (start 0) end (external-format :default)  (defun string-to-octets (string &key (start 0) end (external-format :default)
870                                       (buffer nil bufferp))                                       (buffer nil bufferp)
871                                         error)
872      "Convert String to octets using the specified External-format.  The
873      string is bounded by Start (defaulting to 0) and End (defaulting to
874      the end of the string.  If Buffer is given, the octets are stored
875      there.  If not, a new buffer is created."
876    (declare (type string string)    (declare (type string string)
877             (type lisp::index start)             (type kernel:index start)
878             (type (or lisp::index null) end)             (type (or kernel:index null) end)
879             (type (or (simple-array (unsigned-byte 8) (*)) null) buffer))             (type (or (simple-array (unsigned-byte 8) (*)) null) buffer))
880    (multiple-value-bind (buffer ptr)    (let* ((buffer (or buffer (make-array (length string)
       (lisp::with-array-data ((string string) (start start) (end end))  
         (funcall (ef-string-to-octets (find-external-format external-format))  
                  string start end  
                  (or buffer (make-array (length string)  
881                                          :element-type '(unsigned-byte 8)))))                                          :element-type '(unsigned-byte 8)))))
882      (values (if bufferp buffer (lisp::shrink-vector buffer ptr)) ptr)))      (multiple-value-bind (buffer ptr)
883            (lisp::with-array-data ((string string) (start start) (end end))
884              (funcall (ef-string-to-octets external-format)
885                       string start end buffer error))
886          (values (if bufferp buffer (lisp::shrink-vector buffer ptr)) ptr))))
887    
888  (def-ef-macro ef-octets-to-string (extfmt lisp::lisp +ef-max+ +ef-os+)  (def-ef-macro ef-octets-to-string (extfmt lisp::lisp +ef-max+ +ef-os+)
889    `(lambda (octets ptr end string &aux (pos -1) (count 0) (state nil))    `(lambda (octets ptr end state string s-start s-end error
890       (declare #|(optimize (speed 3) (safety 0) (space 0) (debug 0))|#              &aux (pos s-start) (count 0) (last-octet 0))
891         (declare (optimize (speed 3) (safety 0) #|(space 0) (debug 0)|#)
892                (type (simple-array (unsigned-byte 8) (*)) octets)                (type (simple-array (unsigned-byte 8) (*)) octets)
893                (type lisp::index end count)                (type kernel:index pos end count last-octet s-start s-end)
894                (type (integer -1 (#.array-dimension-limit)) ptr pos)                (type (integer -1 (#.array-dimension-limit)) ptr)
895                (type simple-string string)                (type simple-string string)
896                (ignorable state))                (ignorable state))
897       (loop until (>= ptr end)       (catch 'end-of-octets
898          do (when (= pos (length string))         (loop while (< pos s-end)
899               (setq string (adjust-array string (* 2 pos))))            do (setf (schar string pos)
900             (setf (schar string (incf pos))                     (octets-to-char ,extfmt state count
901                 ,(octets-to-char extfmt state count                                     (if (>= ptr end)
902                                  (aref octets (incf ptr)) ;;@@ EOF??                                         (throw 'end-of-octets nil)
903                                  (lambda (n) (decf ptr n))))                                         (aref octets (incf ptr)))
904          finally (return (values string (1+ pos))))))                                     (lambda (n) (decf ptr n))
905                                       error))
906              (incf pos)
907              (incf last-octet count)))
908         (values string pos last-octet state)))
909    
910  (defun octets-to-string (octets &key (start 0) end (external-format :default)  (defun octets-to-string (octets &key (start 0) end (external-format :default)
911                                       (string nil stringp))                                       (string nil stringp)
912                                         (s-start 0) (s-end nil s-end-p)
913                                         (state nil)
914                                         error)
915      "Octets-to-string converts an array of octets in Octets to a string
916      according to the specified External-format.  The array of octets is
917      bounded by Start (defaulting ot 0) and End (defaulting to the end of
918      the array.  If String is not given, a new string is created.  If
919      String is given, the converted octets are stored in String, starting
920      at S-Start (defaulting to the 0) and ending at S-End (defaulting to
921      the length of String).  If the string is not large enough to hold
922      all of characters, then some octets will not be converted.  A State
923      may also be specified; this is used as the state of the external
924      format.  An error method may also be specified by Error, which
925      defaults to NIL to mean the default handling of conversion errors is
926      done.
927    
928      Four values are returned: the string, the position of where the next
929      character would be read into the string, the number of octets
930      actually consumed and the new state of the external format."
931    (declare (type (simple-array (unsigned-byte 8) (*)) octets)    (declare (type (simple-array (unsigned-byte 8) (*)) octets)
932             (type lisp::index start)             (type kernel:index start s-start)
933             (type (or lisp::index null) end)             (type (or kernel:index null) end)
934               (type (or simple-string null) string))
935      (let ((s-end (if s-end-p
936                       s-end
937                       (if stringp
938                           (length string)
939                           (length octets)))))
940        (multiple-value-bind (string pos last-octet new-state)
941            (funcall (ef-octets-to-string external-format)
942                     octets (1- start) (1- (or end (length octets)))
943                     state
944                     (or string (make-string (length octets)))
945                     s-start s-end
946                     error)
947          (values (if stringp string (lisp::shrink-vector string pos)) pos last-octet new-state))))
948    
949    
950    (def-ef-macro ef-octets-to-string-counted (extfmt lisp::lisp +ef-max+ +ef-osc+)
951      `(lambda (octets ptr end state ocount string s-start s-end error
952                &aux (pos s-start) (last-octet 0))
953         (declare (optimize (speed 3) (safety 0) #|(space 0) (debug 0)|#)
954                  (type (simple-array (unsigned-byte 8) (*)) octets ocount)
955                  (type kernel:index pos end last-octet s-start s-end)
956                  (type (integer -1 (#.array-dimension-limit)) ptr)
957                  (type simple-string string)
958                  (ignorable state))
959         (catch 'end-of-octets
960           (loop for k of-type fixnum from 0
961              while (< pos s-end)
962              do (setf (schar string pos)
963                       (octets-to-char ,extfmt state (aref ocount k)
964                                       (if (>= ptr end)
965                                           (throw 'end-of-octets nil)
966                                           (aref octets (incf ptr)))
967                                       (lambda (n) (decf ptr n))
968                                       error))
969              (incf pos)
970              (incf last-octet (aref ocount k))))
971         (values string pos last-octet state)))
972    
973    ;; Like OCTETS-TO-STRING, but we take an extra argument which is an
974    ;; array which will contain the number of octets read for each
975    ;; character placed in the output string.
976    (defun octets-to-string-counted (octets ocount
977                                     &key (start 0) end (external-format :default)
978                                     (string nil stringp)
979                                     (s-start 0) (s-end nil s-end-p)
980                                     (state nil)
981                                     error)
982      "Octets-to-string converts an array of octets in Octets to a string
983      according to the specified External-format.  The array of octets is
984      bounded by Start (defaulting ot 0) and End (defaulting to the end of
985      the array.  If String is not given, a new string is created.  If
986      String is given, the converted octets are stored in String, starting
987      at S-Start (defaulting to the 0) and ending at S-End (defaulting to
988      the length of String).  If the string is not large enough to hold
989      all of characters, then some octets will not be converted.  A State
990      may also be specified; this is used as the state of the external
991      format.
992    
993      In Ocount, the number of octets read for each character in the
994      string is saved
995    
996      Four values are returned: the string, the number of characters read,
997      the number of octets actually consumed and the new state of the
998      external format."
999      (declare (type (simple-array (unsigned-byte 8) (*)) octets ocount)
1000               (type kernel:index start s-start)
1001               (type (or kernel:index null) end)
1002             (type (or simple-string null) string))             (type (or simple-string null) string))
1003    (multiple-value-bind (string pos)    (let ((s-end (if s-end-p
1004        (funcall (ef-octets-to-string (find-external-format external-format))                     s-end
1005                 octets (1- start) (1- (or end (length octets)))                     (if stringp
1006                 (or string (make-string (length octets))))                         (length string)
1007      (values (if stringp string (lisp::shrink-vector string pos)) pos)))                         (length octets)))))
1008        (multiple-value-bind (string pos last-octet new-state)
1009            (funcall (ef-octets-to-string-counted external-format)
1010                     octets (1- start) (1- (or end (length octets)))
1011                     state
1012                     ocount
1013                     (or string (make-string (length octets)))
1014                     s-start s-end
1015                     error)
1016          (values (if stringp string (lisp::shrink-vector string pos)) (- pos s-start) last-octet new-state))))
1017    
1018    
1019    
1020  (def-ef-macro ef-encode (extfmt lisp::lisp +ef-max+ +ef-en+)  (def-ef-macro ef-encode (extfmt lisp::lisp +ef-max+ +ef-en+)
1021    `(lambda (string start end result &aux (ptr 0) (state nil))    `(lambda (string start end result error  &aux (ptr 0) (state nil))
1022       (declare #|(optimize (speed 3) (safety 0) (space 0) (debug 0))|#       (declare #|(optimize (speed 3) (safety 0) (space 0) (debug 0))|#
1023                (type simple-string string)                (type simple-string string)
1024                (type lisp::index start end ptr)                (type kernel:index start end ptr)
1025                (type simple-base-string result)                (type simple-base-string result)
1026                (ignorable state))                (ignorable state))
1027       (dotimes (i (- end start) (values result ptr))       (dotimes (i (- end start) (values result ptr))
1028         (declare (type lisp::index i))         (declare (type kernel:index i))
1029         ,(char-to-octets extfmt (schar string (+ start i)) state         (char-to-octets ,extfmt (schar string (+ start i)) state
1030                          (lambda (b)                         (lambda (b)
1031                            (when (= ptr (length result))                           (when (= ptr (length result))
1032                              (setq result (adjust-array result (* 2 ptr))))                             (setq result (adjust-array result (* 2 ptr))))
1033                            (setf (aref result (1- (incf ptr)))                           (setf (aref result (1- (incf ptr)))
1034                                (code-char b)))))))                                 (code-char b)))
1035                           error))))
1036  (defun string-encode (string external-format &optional (start 0) end)  
1037    (defun string-encode (string external-format &optional (start 0) end error)
1038      "Encode the given String using External-Format and return a new
1039      string.  The characters of the new string are the octets of the
1040      encoded result, with each octet converted to a character via
1041      code-char.  This is the inverse to String-Decode"
1042      (when (zerop (length string))
1043        (return-from string-encode string))
1044    (multiple-value-bind (result ptr)    (multiple-value-bind (result ptr)
1045        (lisp::with-array-data ((string string) (start start) (end end))        (lisp::with-array-data ((string string) (start start) (end end))
1046          (funcall (ef-encode (find-external-format external-format))          (funcall (ef-encode external-format) string start end
1047                   string start end                   (make-string (length string) :element-type 'base-char)
1048                   (make-string (length string) :element-type 'base-char)))                   error))
1049      (lisp::shrink-vector result ptr)))      (lisp::shrink-vector result ptr)))
1050    
1051  (def-ef-macro ef-decode (extfmt lisp::lisp +ef-max+ +ef-de+)  (def-ef-macro ef-decode (extfmt lisp::lisp +ef-max+ +ef-de+)
1052    `(lambda (string ptr end result &aux (pos -1) (count 0) (state nil))    `(lambda (string ptr end result error &aux (pos -1) (count 0) (state nil))
1053       (declare #|(optimize (speed 3) (safety 0) (space 0) (debug 0))|#       (declare #|(optimize (speed 3) (safety 0) (space 0) (debug 0))|#
1054                (type simple-string string)                (type simple-string string)
1055                (type lisp::index end count)                (type kernel:index end count)
1056                (type (integer -1 (#.array-dimension-limit)) ptr pos)                (type (integer -1 (#.array-dimension-limit)) ptr pos)
1057                (type simple-string result)                (type simple-string result)
1058                (ignorable state))                (ignorable state))
# Line 386  Line 1060 
1060          ;; increasing size of result shouldn't ever be necessary, unless          ;; increasing size of result shouldn't ever be necessary, unless
1061          ;; someone implements an encoding smaller than the source string...          ;; someone implements an encoding smaller than the source string...
1062          do (setf (schar result (incf pos))          do (setf (schar result (incf pos))
1063                 ,(octets-to-char extfmt state count                 (octets-to-char ,extfmt state count
1064                                  ;; note the need to return NIL for EOF                                 ;; note the need to return NIL for EOF
1065                                  (if (= (1+ ptr) (length string))                                 (if (= (1+ ptr) (length string))
1066                                      nil                                     nil
1067                                      (char-code (char string (incf ptr))))                                     (char-code (char string (incf ptr))))
1068                                  (lambda (n) (decf ptr n))))                                 (lambda (n) (decf ptr n))
1069                                   error))
1070          finally (return (values result (1+ pos))))))          finally (return (values result (1+ pos))))))
1071    
1072  (defun string-decode (string external-format &optional (start 0) end)  (defun string-decode (string external-format &optional (start 0) end error)
1073      "Decode String using the given External-Format and return the new
1074      string.  The input string is treated as if it were an array of
1075      octets, where the char-code of each character is the octet.  This is
1076      the inverse of String-Encode."
1077      (when (zerop (length string))
1078        (return-from string-decode string))
1079    (multiple-value-bind (result pos)    (multiple-value-bind (result pos)
1080        (lisp::with-array-data ((string string) (start start) (end end))        (lisp::with-array-data ((string string) (start start) (end end))
1081          (funcall (ef-decode (find-external-format external-format))          (funcall (ef-decode external-format)
1082                   string (1- start) (1- end) (make-string (length string))))                   string (1- start) (1- end) (make-string (length string))
1083                     error))
1084      (lisp::shrink-vector result pos)))      (lisp::shrink-vector result pos)))
1085    
1086    
1087    (defun set-system-external-format (terminal &optional filenames)
1088      "Change the external format of the standard streams to Terminal.
1089      The standard streams are sys::*stdin*, sys::*stdout*, and
1090      sys::*stderr*, which are normally the input and/or output streams
1091      for *standard-input* and *standard-output*.  Also sets sys::*tty*
1092      (normally *terminal-io* to the given external format.  If the
1093      optional argument Filenames is gvien, then the filename encoding is
1094      set to the specified format."
1095      (unless (find-external-format terminal)
1096        (error (intl:gettext "Can't find external-format ~S.") terminal))
1097      (setf (stream-external-format sys:*stdin*) terminal
1098            (stream-external-format sys:*stdout*) terminal
1099            (stream-external-format sys:*stderr*) terminal)
1100      (when (lisp::fd-stream-p sys:*tty*)
1101        (setf (stream-external-format sys:*tty*) terminal))
1102      (when filenames
1103        (unless (find-external-format filenames)
1104          (error (intl:gettext "Can't find external-format ~S.") filenames))
1105        (setq filenames (ef-name (find-external-format filenames)))
1106        (when (and unix::*filename-encoding*
1107                   (not (eq unix::*filename-encoding* filenames)))
1108          (cerror (intl:gettext "Change it anyway.")
1109                  (intl:gettext "The external-format for encoding filenames is already set.")))
1110        (setq unix::*filename-encoding* filenames))
1111      t)
1112    
1113    
1114    ;; Despite its name, this doesn't actually compile anything at all.  What it
1115    ;; does is expand into a lambda expression that can be compiled by the file
1116    ;; compiler.
1117    (defmacro precompile-ef-slot (ef slot)
1118      (let* ((ef (find-external-format ef)))
1119        ;; if there's no lambda expression available, flush it and regenerate
1120        (unless (and (aref (ef-cache ef) slot)
1121                     (function-lambda-expression (aref (ef-cache ef) slot)))
1122          (setf (aref (ef-cache ef) slot) nil)
1123          (ecase slot
1124            (#.+ef-cin+ (lisp::%ef-cin ef))
1125            (#.+ef-cout+ (lisp::%ef-cout ef))
1126            (#.+ef-sout+ (lisp::%ef-sout ef))
1127            (#.+ef-os+ (%ef-octets-to-string ef))
1128            (#.+ef-so+ (%ef-string-to-octets ef))
1129            (#.+ef-en+ (%ef-encode ef))
1130            (#.+ef-de+ (%ef-decode ef))))
1131        `(setf (aref (ef-cache (find-external-format ,(ef-name ef))) ,slot)
1132             ,(subst (ef-name ef) ef
1133                     (function-lambda-expression (aref (ef-cache ef) slot))))))

Legend:
Removed from v.1.2.4.3  
changed lines
  Added in v.1.42

  ViewVC Help
Powered by ViewVC 1.1.5