/[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.2.4.3.2.9 by rtoy, Sat Mar 28 13:31:42 2009 UTC
# Line 21  Line 21 
21  (defvar *external-formats* (make-hash-table :test 'equal))  (defvar *external-formats* (make-hash-table :test 'equal))
22  (defvar *external-format-aliases* (make-hash-table))  (defvar *external-format-aliases* (make-hash-table))
23    
24  (defconstant +ef-os+ 2)  (defconstant +ef-cin+ 2)
25  (defconstant +ef-so+ 3)  (defconstant +ef-cout+ 3)
26  (defconstant +ef-en+ 4)  (defconstant +ef-sin+ 4)
27  (defconstant +ef-de+ 5)  (defconstant +ef-sout+ 5)
28  (defconstant +ef-max+ 6)  (defconstant +ef-os+ 6)
29    (defconstant +ef-so+ 7)
30    (defconstant +ef-en+ 8)
31    (defconstant +ef-de+ 9)
32    (defconstant +ef-max+ 10)
33    
34  (define-condition external-format-not-implemented (error)  (define-condition external-format-not-implemented (error)
35    ()    ()
# Line 41  Line 45 
45  (defstruct efx  (defstruct efx
46    (octets-to-code #'%efni :type function :read-only t)    (octets-to-code #'%efni :type function :read-only t)
47    (code-to-octets #'%efni :type function :read-only t)    (code-to-octets #'%efni :type function :read-only t)
48    (cache nil :type (or null simple-vector)))    (cache nil :type (or null simple-vector))
49      (min 1 :type kernel:index :read-only t)
50      (max 1 :type kernel:index :read-only t))
51    
52  (defstruct (external-format  (defstruct (external-format
53               (:conc-name ef-)               (:conc-name ef-)
# Line 59  Line 65 
65    (print-unreadable-object (ef stream :type t :identity t)    (print-unreadable-object (ef stream :type t :identity t)
66      (princ (ef-name ef) stream)))      (princ (ef-name ef) stream)))
67    
68  (defun %whatsit (ef)  (defun %intern-ef (ef)
69    (setf (gethash (ef-name ef) *external-formats*) ef))    (setf (gethash (ef-name ef) *external-formats*) ef))
70    
71  (declaim (inline ef-octets-to-code ef-code-to-octets ef-cache))  (declaim (inline ef-octets-to-code ef-code-to-octets ef-cache
72                     ef-min-octets ef-max-octets))
73    
74  (defun ef-octets-to-code (ef)  (defun ef-octets-to-code (ef)
75    (efx-octets-to-code (ef-efx ef)))    (efx-octets-to-code (ef-efx ef)))
# Line 73  Line 80 
80  (defun ef-cache (ef)  (defun ef-cache (ef)
81    (efx-cache (ef-efx ef)))    (efx-cache (ef-efx ef)))
82    
83  (defmacro define-external-format (name octets-to-code code-to-octets)  (defun ef-min-octets (ef)
84    (let ((tmp1 (gensym)) (tmp2 (gensym)))    (efx-min (ef-efx ef)))
85    
86    (defun ef-max-octets (ef)
87      (efx-max (ef-efx ef)))
88    
89    (eval-when (:compile-toplevel :load-toplevel :execute)
90      (defun %merge-slots (old new)
91        (let* ((pos (length old))
92               (tmp (mapcar (lambda (x)
93                              (let* ((name (if (consp x) (first x) x))
94                                     (init (if (consp x) (second x) nil))
95                                     (list (if (consp x) (nthcdr 2 x) nil))
96                                     (prev (assoc name old))
97                                     (posn (if prev (second prev) (1- (incf pos)))))
98                                (list name posn init (getf list :type t))))
99                            new)))
100          (delete-duplicates (stable-sort (append old tmp) #'< :key #'second)
101                             :key #'second))))
102    
103    ;;; DEFINE-EXTERNAL-FORMAT  -- Public
104    ;;;
105    ;;; name (&key min max size) (&rest slots) octets-to-code code-to-octets
106    ;;;   Define a new external format.  Min/Max/Size are the minimum and
107    ;;;   maximum number of octets that make up a character (:size N is just
108    ;;;   shorthand for :min N :max N).  Slots is a list of slot descriptions
109    ;;;   similar to defstruct.
110    ;;;
111    ;;; name (base) (&rest slots)
112    ;;;   Define an external format based on a previously-defined external
113    ;;;   format, Base.  The slot names used in Slots must match those in Base.
114    ;;;
115    ;;; Note: external-formats work on code-points, not characters, so that
116    ;;;   the entire 31 bit ISO-10646 range can be used internally regardless of
117    ;;;   the size of a character recognized by Lisp and external formats
118    ;;;   can be useful to people who want to process characters outside the
119    ;;;   Lisp range (see CODEPOINT-TO-OCTETS, OCTETS-TO-CODEPOINT)
120    ;;;
121    (defmacro define-external-format (name (&rest args) (&rest slots)
122                                           &optional octets-to-code code-to-octets)
123      (when (and (oddp (length args)) (not (= (length args) 1)))
124        (warn "Nonsensical argument (~S) to DEFINE-EXTERNAL-FORMAT." args))
125      (let* ((tmp (gensym))
126             (min (if (evenp (length args))
127                      (or (getf args :min) (getf args :size) 1)
128                      1))
129             (max (if (evenp (length args))
130                      (or (getf args :max) (getf args :size) 6)
131                      6))
132             (base (if (= (length args) 1)
133                       (find-external-format (first args))
134                       nil))
135             (bslotd (if base (ef-slotd base) nil))
136             (slotd (%merge-slots bslotd slots))
137             (slotb (loop for slot in slotd
138                      collect `(,(first slot)
139                                `(the ,',(fourth slot)
140                                  ;; IDENTITY is here to protect against SETF
141                                  (identity (svref %slots% ,',(second slot))))))))
142      `(macrolet ((octets-to-code ((state input unput &rest vars) body)      `(macrolet ((octets-to-code ((state input unput &rest vars) body)
143                    `(lambda (,',tmp1 ,state ,input ,unput)                    `(lambda (,state ,input ,unput)
144                       (declare (ignore ,',tmp1)                       (declare (ignorable ,state ,input ,unput)
                               (ignorable ,state ,input ,unput)  
145                                (optimize (ext:inhibit-warnings 3)))                                (optimize (ext:inhibit-warnings 3)))
146                       (let ((,input `(the (or (unsigned-byte 8) null) ,,input))                       (let (,@',slotb
147                               (,input `(the (or (unsigned-byte 8) null) ,,input))
148                             ,@(loop for var in vars collect `(,var (gensym))))                             ,@(loop for var in vars collect `(,var (gensym))))
149                         ,body)))                         ,body)))
150                  (code-to-octets ((code state output &rest vars) body)                  (code-to-octets ((code state output &rest vars) body)
151                    `(lambda (,',tmp1 ,',tmp2 ,state ,output)                    `(lambda (,',tmp ,state ,output)
152                       (declare (ignore ,',tmp1)                       (declare (ignorable ,state ,output)
                               (ignorable ,state ,output)  
153                                (optimize (ext:inhibit-warnings 3)))                                (optimize (ext:inhibit-warnings 3)))
154                       (let ((,code ',code)                       (let (,@',slotb
155                               (,code ',code)
156                             ,@(loop for var in vars collect `(,var (gensym))))                             ,@(loop for var in vars collect `(,var (gensym))))
157                         `(let ((,',code (the (unsigned-byte 31) ,,',tmp2)))                         `(let ((,',code (the (unsigned-byte 31) ,,',tmp)))
158                            (declare (ignorable ,',code))                            (declare (ignorable ,',code))
159                            ,,body)))))                            ,,body)))))
160         (%whatsit (make-external-format ,name         (%intern-ef (make-external-format ,name
161                    (make-efx :octets-to-code ,octets-to-code                      ,(if base
162                              :code-to-octets ,code-to-octets                           `(ef-efx (find-external-format ,(ef-name base)))
163                              :cache (make-array +ef-max+ :initial-element nil))                           `(make-efx :octets-to-code ,octets-to-code
164                    nil                                      :code-to-octets ,code-to-octets
165                    #() '())))))                                      :cache (make-array +ef-max+
166                                                              :initial-element nil)
167  (defmacro define-composing-external-format (name input output)                                      :min ,(min min max) :max ,(max min max)))
168    (let ((tmp1 (gensym)) (tmp2 (gensym)))                      nil
169                        (vector ,@(mapcar #'third slotd))
170                        ',slotd)))))
171    
172    ;;; DEFINE-COMPOSING-EXTERNAL-FORMAT  -- Public
173    ;;;
174    ;;; A composing-external-format differs from an (ordinary) external-format
175    ;;; in that it translates characters (really codepoints, of course) into
176    ;;; other characters, rather than translating between characters and binary
177    ;;; octets.  They have to be composed with a non-composing external-format
178    ;;; to be of any use.
179    ;;;
180    (defmacro define-composing-external-format (name (&key min max size)
181                                                     input output)
182      (let ((tmp (gensym))
183            (min (or min size 1))
184            (max (or max size 1)))
185      `(macrolet ((input ((state input unput &rest vars) body)      `(macrolet ((input ((state input unput &rest vars) body)
186                    `(lambda (,',tmp1 ,state ,input ,unput)                    `(lambda (,state ,input ,unput)
187                       (declare (ignore ,',tmp1)                       (declare (ignorable ,state ,input ,unput)
                               (ignorable ,state ,input ,unput)  
188                                (optimize (ext:inhibit-warnings 3)))                                (optimize (ext:inhibit-warnings 3)))
189                       (let ((,input `(the (values (or (unsigned-byte 31) null)                       (let ((,input `(the (values (or (unsigned-byte 31) null)
190                                                   lisp::index)                                                   kernel:index)
191                                           ,,input))                                           ,,input))
192                             ,@(loop for var in vars collect `(,var (gensym))))                             ,@(loop for var in vars collect `(,var (gensym))))
193                         ,body)))                         ,body)))
194                  (output ((code state output &rest vars) body)                  (output ((code state output &rest vars) body)
195                    `(lambda (,',tmp1 ,',tmp2 ,state ,output)                    `(lambda (,',tmp ,state ,output)
196                       (declare (ignore ,',tmp1)                       (declare (ignorable ,state ,output)
                               (ignorable ,state ,output)  
197                                (optimize (ext:inhibit-warnings 3)))                                (optimize (ext:inhibit-warnings 3)))
198                       (let ((,code ',code)                       (let ((,code ',code)
199                             ,@(loop for var in vars collect `(,var (gensym))))                             ,@(loop for var in vars collect `(,var (gensym))))
200                         `(let ((,',code (the (unsigned-byte 31) ,,',tmp2)))                         `(let ((,',code (the (unsigned-byte 31) ,,',tmp)))
201                            (declare (ignorable ,',code))                            (declare (ignorable ,',code))
202                            ,,body)))))                            ,,body)))))
203         (%whatsit (make-external-format ,name         (%intern-ef (make-external-format ,name
204                    (make-efx :octets-to-code ,input                      (make-efx :octets-to-code ,input
205                              :code-to-octets ,output)                                :code-to-octets ,output
206                    t                                :min ,(min min max) :max ,(max min max))
207                    #() '())))))                      t
208                        #() '())))))
209    
210  (defun load-external-format-aliases ()  (defun load-external-format-aliases ()
211    (let ((*package* (find-package "KEYWORD")))    (let ((*package* (find-package "KEYWORD"))
212            (unix::*filename-encoding* :iso8859-1))
213      (with-open-file (stm "ext-formats:aliases" :if-does-not-exist nil)      (with-open-file (stm "ext-formats:aliases" :if-does-not-exist nil)
214        (when stm        (when stm
215          (do ((alias (read stm nil stm) (read stm nil stm))          (do ((alias (read stm nil stm) (read stm nil stm))
216               (value (read stm nil stm) (read stm nil stm)))               (value (read stm nil stm) (read stm nil stm)))
217              ((or (eq alias stm) (eq value stm))              ((or (eq alias stm) (eq value stm))
218               (unless (eq alias stm)               (unless (eq alias stm)
219                 (warn "External-format aliases file ends early.")))                 (warn "External-format aliases file ends early.")))
220            (if (and (keywordp alias) (keywordp value))            (if (and (keywordp alias) (keywordp value))
221                (setf (gethash alias *external-format-aliases*) value)                (setf (gethash alias *external-format-aliases*) value)
222                (warn "Bad entry in external-format aliases file: ~S => ~S."                (warn "Bad entry in external-format aliases file: ~S => ~S."
223                      alias value)))))))                      alias value)))))))
224    
225  (defun %find-external-format (name)  (defun %find-external-format (name)
226      ;; avoid loading files, etc., early in the boot sequence
227      (when (or (eq name :iso8859-1)
228                (and (eq name :default) (eq *default-external-format* :iso8859-1)))
229        (return-from %find-external-format
230          (gethash :iso8859-1 *external-formats*)))
231    
232    (when (zerop (hash-table-count *external-format-aliases*))    (when (zerop (hash-table-count *external-format-aliases*))
233      (setf (gethash :latin1 *external-format-aliases*) :iso8859-1)      (setf (gethash :latin1 *external-format-aliases*) :iso8859-1)
234      (setf (gethash :latin-1 *external-format-aliases*) :iso8859-1)      (setf (gethash :latin-1 *external-format-aliases*) :iso8859-1)
# Line 159  Line 245 
245    
246    (or (gethash name *external-formats*)    (or (gethash name *external-formats*)
247        (and (let ((*package* (find-package "STREAM"))        (and (let ((*package* (find-package "STREAM"))
248                   (lisp::*enable-package-locked-errors* nil))                   (lisp::*enable-package-locked-errors* nil)
249               (load (format nil "ext-formats:~(~A~)" name)                   (*default-external-format* :iso8859-1)
250                     :if-does-not-exist nil))                   (unix::*filename-encoding* :iso8859-1)
251                     (s (open (format nil "ext-formats:~(~A~).lisp" name) :if-does-not-exist nil)))
252                 (when s
253                   (null (nth-value 1 (ext:compile-from-stream s)))))
254             (gethash name *external-formats*))))             (gethash name *external-formats*))))
255    
256  (defun %composed-ef-name (a b)  (defun %composed-ef-name (a b)
257    (if (consp a) (append a (list b)) (list a b)))    (if (consp a) (append a (list b)) (list a b)))
258    
259  (defun %compose-external-formats (a b &optional name)  (defun %compose-external-formats (a b)
260    (when (ef-composingp a)    (when (ef-composingp a)
261      (error "~S is a Composing-External-Format." (ef-name a)))      (error "~S is a Composing-External-Format." (ef-name a)))
262    (unless (ef-composingp b)    (unless (ef-composingp b)
263      (error "~S is not a Composing-External-Format." (ef-name b)))      (error "~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))))  
264    (make-external-format    (make-external-format
265     (%composed-ef-name (ef-name a) (ef-name b))     (%composed-ef-name (ef-name a) (ef-name b))
266     (make-efx     (make-efx
267      :octets-to-code (lambda (tmp state input unput)      :octets-to-code (lambda (state input unput)
268                        (declare (ignore tmp))                        (funcall (ef-octets-to-code b) state
269                        (funcall (ef-octets-to-code b) (ef-slots b)                                 (funcall (ef-octets-to-code a)
270                                 state                                          state input unput)
                                (funcall (ef-octets-to-code a) (ef-slots a)  
                                         state  
                                         input  
                                         unput)  
271                                 unput))                                 unput))
272      :code-to-octets (lambda (tmp code state output)      :code-to-octets (lambda (code state output)
273                        (declare (ignore tmp))                        (funcall (ef-code-to-octets b) code state
                       (funcall (ef-code-to-octets b) (ef-slots b)  
                                code  
                                state  
274                                 `(lambda (x)                                 `(lambda (x)
275                                   ,(funcall (ef-code-to-octets a)                                   ,(funcall (ef-code-to-octets a)
                                            (ef-slots a)  
276                                             'x state output))))                                             'x state output))))
277      :cache (make-array +ef-max+ :initial-element nil))      :cache (make-array +ef-max+ :initial-element nil)
278        :min (* (ef-min-octets a) (ef-min-octets b))
279        :max (* (ef-max-octets a) (ef-max-octets b)))
280     nil #() '()))     nil #() '()))
281    
282  (defun find-external-format (name &optional (error-p t))  (defun find-external-format (name &optional (error-p t))
# Line 212  Line 292 
292    (when (and (consp name) (not (cdr name)))    (when (and (consp name) (not (cdr name)))
293      (setq name (car name)))      (setq name (car name)))
294    
295    (if (consp name)    (flet ((not-found ()
296        (let ((efs (mapcar #'%find-external-format name)))             (when (equal *default-external-format* name)
297          (if (member nil efs)               (setq *default-external-format* :iso8859-1))
298              (if error-p (error "External format ~S not found." name) nil)             (if error-p (error "External format ~S not found." name) nil)))
299              (let ((name (reduce #'%composed-ef-name (mapcar #'ef-name efs))))      (if (consp name)
300                (or (gethash name *external-formats*)          (let ((efs (mapcar #'%find-external-format name)))
301                    (%whatsit (reduce #'%compose-external-formats efs))))))            (if (member nil efs)
302        (or (%find-external-format name)                (not-found)
303            (if error-p (error "External format ~S not found." name) nil))))                (let ((name (reduce #'%composed-ef-name (mapcar #'ef-name efs))))
304                    (or (gethash name *external-formats*)
305                        (%intern-ef (reduce #'%compose-external-formats efs))))))
306            (or (%find-external-format name) (not-found)))))
307    
308    (defun flush-external-formats ()
309      (maphash (lambda (name ef)
310                 (declare (ignore name))
311                 (fill (ef-cache ef) nil))
312               *external-formats*))
313    
314    (defvar *.table-inverse.* (make-hash-table :test 'eq :size 7))
315    
316    (defun invert-table (table)
317      (declare (type (or (simple-array (unsigned-byte 31) *)
318                         (simple-array (unsigned-byte 16) *))
319                     table)
320               (optimize (speed 3) (space 0) (safety 0) (debug 0)
321                         (ext:inhibit-warnings 3)))
322      (or (gethash table *.table-inverse.*)
323          (let* ((result (make-hash-table))
324                 (width (array-dimension table 0))
325                 (power (1- (array-rank table)))
326                 (base (if (= width 94) 1 0)))
327            (assert (and (< power 3) (<= width 256)))
328            (dotimes (i (array-total-size table))
329              (declare (type (integer 0 (#.array-dimension-limit)) i))
330              (let ((tmp i) (val (row-major-aref table i)) (z 0))
331                (declare (type (integer 0 (#.array-dimension-limit)) tmp)
332                         (type (unsigned-byte 32) z))
333                (unless (or (= val #xFFFE) (gethash val result))
334                  (dotimes (j power)
335                    ;; j is only ever 0 in reality, since no n^3 tables are
336                    ;; defined; z was declared as 32-bit above, so that limits
337                    ;; us to 0 <= j <= 2   (see the ASSERT)
338                    (declare (type (integer 0 2) j))
339                    (multiple-value-bind (x y) (floor tmp width)
340                      (setq tmp x)
341                      (setq z (logior z (ash (the (integer 0 255) (+ y base))
342                                             (the (integer 0 24)
343                                               (* 8 (- power j))))))))
344                  (setf (gethash val result) (logior z (+ tmp base))))))
345            (setf (gethash table *.table-inverse.*) result))))
346    
347    
348  (define-condition void-external-format (error)  (define-condition void-external-format (error)
349    ()    ()
# Line 229  Line 352 
352        (declare (ignore condition))        (declare (ignore condition))
353        (format stream "Attempting I/O through void external-format."))))        (format stream "Attempting I/O through void external-format."))))
354    
355  (define-external-format :void  (define-external-format :void (:size 0) ()
356    (octets-to-code (state input unput)    (octets-to-code (state input unput)
357      `(error 'void-external-format))      `(error 'void-external-format))
358    (code-to-octets (code state output)    (code-to-octets (code state output)
359      `(error 'void-external-format)))      `(error 'void-external-format)))
360    
361  (define-external-format :iso8859-1  (define-external-format :iso8859-1 (:size 1) ()
362    (octets-to-code (state input unput)    (octets-to-code (state input unput)
363      `(values ,input 1))      `(values ,input 1))
364    (code-to-octets (code state output)    (code-to-octets (code state output)
365      `(,output (if (> ,code 255) #x3F ,code))))      `(,output (if (> ,code 255) #x3F ,code))))
366    
367    ;;; OCTETS-TO-CODEPOINT, CODEPOINT-TO-OCTETS  -- Semi-Public
368    ;;;
369    ;;; Normally you'd want to use OCTETS-TO-CHAR and CHAR-TO-OCTETS instead of
370    ;;; these, but that limits you to Lisp's idea of a character - either Latin-1
371    ;;; in 8 bit Lisp images, or the Unicode BMP in 16 bit images.  If you want
372    ;;; to read or write texts containing characters not supported by your Lisp,
373    ;;; these macros can be used instead.
374  (defmacro octets-to-codepoint (external-format state count input unput)  (defmacro octets-to-codepoint (external-format state count input unput)
375    (let ((tmp1 (gensym)) (tmp2 (gensym)))    (let ((tmp1 (gensym)) (tmp2 (gensym))
376      `(let ((body (funcall (ef-octets-to-code ,external-format)          (ef (find-external-format external-format)))
377                            (ef-slots ,external-format)      `(multiple-value-bind (,tmp1 ,tmp2)
378                            ',state ',input ',unput)))           ,(funcall (ef-octets-to-code ef) state input unput)
379         `(multiple-value-bind (,',tmp1 ,',tmp2) ,body         (setf ,count (the kernel:index ,tmp2))
380            (setf ,',count (the lisp::index ,',tmp2))         (the (or (unsigned-byte 31) null) ,tmp1))))
           (the (or (unsigned-byte 31) null) ,',tmp1)))))  
381    
382  (defmacro codepoint-to-octets (external-format code state output)  (defmacro codepoint-to-octets (external-format code state output)
383    `(funcall (ef-code-to-octets ,external-format) (ef-slots ,external-format)    (let ((ef (find-external-format external-format)))
384              ',code ',state ',output))      (funcall (ef-code-to-octets ef) code state output)))
385    
386    
387    
# Line 268  Line 397 
397            (adjust-array (ef-cache ef) (+ base reqd) :initial-element nil)))            (adjust-array (ef-cache ef) (+ base reqd) :initial-element nil)))
398      base))      base))
399    
400    ;;; DEF-EF-MACRO  -- Public
401    ;;;
402    ;;;
403  (defmacro def-ef-macro (name (ef id reqd idx) body)  (defmacro def-ef-macro (name (ef id reqd idx) body)
404    (let ((tmp (gensym)))    (let ((tmp1 (gensym))
405      `(defun ,name (,ef)          (tmp2 (gensym))
406         (let ((,tmp ,(if (eq id 'lisp::lisp)          (%name (intern (format nil "%~A" name) (symbol-package name))))
407                          idx      `(progn
408                          `(+ (ensure-cache ,ef ',id ,reqd) ,idx))))         (defun ,%name (,ef)
409           (or (aref (ef-cache ,ef) ,tmp)           (let* ((,tmp1 (find-external-format ,ef))
410               (setf (aref (ef-cache ,ef) ,tmp)                  (,tmp2 ,(if (eq id 'lisp::lisp)
411                   (let ((*compile-print* nil)) (compile nil ,body))))))))                              idx
412                                `(+ (ensure-cache ,tmp1 ',id ,reqd) ,idx))))
413               (funcall (or (aref (ef-cache ,tmp1) ,tmp2)
414                            (setf (aref (ef-cache ,tmp1) ,tmp2)
415                                (let ((*compile-print* nil)
416                                      ;; Set default format when we compile so we
417                                      ;; can see compiler messages.  if we don't,
418                                      ;; we run into a problem that we might be
419                                      ;; changing the default format while we're
420                                      ;; compiling, and we don't know how to output
421                                      ;; the compiler messages.
422                                      (*default-external-format* :iso8859-1))
423                                  (compile nil `(lambda (%slots%)
424                                                  (declare (ignorable %slots%))
425                                                  ,,body)))))
426                        (ef-slots ,tmp1))))
427           (declaim (inline ,name))
428           (defun ,name (,tmp1)
429             (let ((,tmp2 (load-time-value (cons nil nil))))
430               (when (eq ,tmp1 :default)
431                 (setq ,tmp1 *default-external-format*))
432               (if (eq ,tmp1 (car ,tmp2))
433                   (cdr ,tmp2)
434                   (setf (car ,tmp2) ,tmp1
435                         (cdr ,tmp2) (,%name ,tmp1))))))))
436    
437    
438    
439    ;;; OCTETS-TO-CHAR, CHAR-TO-OCTETS  -- Public
440    ;;;
441    ;;; Read and write one character through an external-format
442    ;;;
443  (defmacro octets-to-char (external-format state count input unput)  (defmacro octets-to-char (external-format state count input unput)
444    `(let ((body (octets-to-codepoint ,external-format    `(let ((code (octets-to-codepoint ,external-format
445                                      ,state ,count ,input ,unput)))                                      ,state ,count ,input ,unput)))
446       `(let ((code ,body))       (declare (type (unsigned-byte 31) code))
447          (declare (type (unsigned-byte 31) code))       (if (< code char-code-limit) (code-char code)
448          (if (< code char-code-limit) (code-char code) #\?))))           #-(and unicode (not unicode-bootstrap)) #\?
449             #+(and unicode (not unicode-bootstrap)) #\U+FFFD)))
450    
451  (defmacro char-to-octets (external-format char state output)  (defmacro char-to-octets (external-format char state output)
452    `(codepoint-to-octets ,external-format (char-code ,char) ,state ,output))    `(codepoint-to-octets ,external-format (char-code ,char) ,state ,output))
453    
454    
455  (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+)
456    `(lambda (string start end buffer &aux (ptr 0) (state nil))    `(lambda (string start end buffer &aux (ptr 0) (state nil))
457       (declare #|(optimize (speed 3) (safety 0) (space 0) (debug 0))|#       (declare #|(optimize (speed 3) (safety 0) (space 0) (debug 0))|#
458                (type simple-string string)                (type simple-string string)
459                (type lisp::index start end ptr)                (type kernel:index start end ptr)
460                (type (simple-array (unsigned-byte 8) (*)) buffer)                (type (simple-array (unsigned-byte 8) (*)) buffer)
461                (ignorable state))                (ignorable state))
462       (dotimes (i (- end start) (values buffer ptr))       (dotimes (i (- end start) (values buffer ptr))
463         (declare (type lisp::index i))         (declare (type kernel:index i))
464         ,(char-to-octets extfmt (schar string (+ start i)) state         (char-to-octets ,extfmt (schar string (+ start i)) state
465                          (lambda (b)                         (lambda (b)
466                            (when (= ptr (length buffer))                           (when (= ptr (length buffer))
467                              (setq buffer (adjust-array buffer (* 2 ptr))))                             (setq buffer (adjust-array buffer (* 2 ptr))))
468                            (setf (aref buffer (1- (incf ptr))) b))))))                           (setf (aref buffer (1- (incf ptr))) b))))))
469    
470  (defun string-to-octets (string &key (start 0) end (external-format :default)  (defun string-to-octets (string &key (start 0) end (external-format :default)
471                                       (buffer nil bufferp))                                       (buffer nil bufferp))
472    (declare (type string string)    (declare (type string string)
473             (type lisp::index start)             (type kernel:index start)
474             (type (or lisp::index null) end)             (type (or kernel:index null) end)
475             (type (or (simple-array (unsigned-byte 8) (*)) null) buffer))             (type (or (simple-array (unsigned-byte 8) (*)) null) buffer))
476    (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)  
477                                          :element-type '(unsigned-byte 8)))))                                          :element-type '(unsigned-byte 8)))))
478      (values (if bufferp buffer (lisp::shrink-vector buffer ptr)) ptr)))      (multiple-value-bind (buffer ptr)
479            (lisp::with-array-data ((string string) (start start) (end end))
480              (funcall (ef-string-to-octets external-format)
481                       string start end buffer))
482          (values (if bufferp buffer (lisp::shrink-vector buffer ptr)) ptr))))
483    
484  (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+)
485    `(lambda (octets ptr end string &aux (pos -1) (count 0) (state nil))    `(lambda (octets ptr end string &aux (pos -1) (count 0) (state nil))
486       (declare #|(optimize (speed 3) (safety 0) (space 0) (debug 0))|#       (declare #|(optimize (speed 3) (safety 0) (space 0) (debug 0))|#
487                (type (simple-array (unsigned-byte 8) (*)) octets)                (type (simple-array (unsigned-byte 8) (*)) octets)
488                (type lisp::index end count)                (type kernel:index end count)
489                (type (integer -1 (#.array-dimension-limit)) ptr pos)                (type (integer -1 (#.array-dimension-limit)) ptr pos)
490                (type simple-string string)                (type simple-string string)
491                (ignorable state))                (ignorable state))
# Line 331  Line 493 
493          do (when (= pos (length string))          do (when (= pos (length string))
494               (setq string (adjust-array string (* 2 pos))))               (setq string (adjust-array string (* 2 pos))))
495             (setf (schar string (incf pos))             (setf (schar string (incf pos))
496                 ,(octets-to-char extfmt state count                 (octets-to-char ,extfmt state count
497                                  (aref octets (incf ptr)) ;;@@ EOF??                                 (aref octets (incf ptr)) ;;@@ EOF??
498                                  (lambda (n) (decf ptr n))))                                 (lambda (n) (decf ptr n))))
499          finally (return (values string (1+ pos))))))          finally (return (values string (1+ pos))))))
500    
501  (defun octets-to-string (octets &key (start 0) end (external-format :default)  (defun octets-to-string (octets &key (start 0) end (external-format :default)
502                                       (string nil stringp))                                       (string nil stringp))
503    (declare (type (simple-array (unsigned-byte 8) (*)) octets)    (declare (type (simple-array (unsigned-byte 8) (*)) octets)
504             (type lisp::index start)             (type kernel:index start)
505             (type (or lisp::index null) end)             (type (or kernel:index null) end)
506             (type (or simple-string null) string))             (type (or simple-string null) string))
507    (multiple-value-bind (string pos)    (multiple-value-bind (string pos)
508        (funcall (ef-octets-to-string (find-external-format external-format))        (funcall (ef-octets-to-string external-format)
509                 octets (1- start) (1- (or end (length octets)))                 octets (1- start) (1- (or end (length octets)))
510                 (or string (make-string (length octets))))                 (or string (make-string (length octets))))
511      (values (if stringp string (lisp::shrink-vector string pos)) pos)))      (values (if stringp string (lisp::shrink-vector string pos)) pos)))
# Line 354  Line 516 
516    `(lambda (string start end result &aux (ptr 0) (state nil))    `(lambda (string start end result &aux (ptr 0) (state nil))
517       (declare #|(optimize (speed 3) (safety 0) (space 0) (debug 0))|#       (declare #|(optimize (speed 3) (safety 0) (space 0) (debug 0))|#
518                (type simple-string string)                (type simple-string string)
519                (type lisp::index start end ptr)                (type kernel:index start end ptr)
520                (type simple-base-string result)                (type simple-base-string result)
521                (ignorable state))                (ignorable state))
522       (dotimes (i (- end start) (values result ptr))       (dotimes (i (- end start) (values result ptr))
523         (declare (type lisp::index i))         (declare (type kernel:index i))
524         ,(char-to-octets extfmt (schar string (+ start i)) state         (char-to-octets ,extfmt (schar string (+ start i)) state
525                          (lambda (b)                         (lambda (b)
526                            (when (= ptr (length result))                           (when (= ptr (length result))
527                              (setq result (adjust-array result (* 2 ptr))))                             (setq result (adjust-array result (* 2 ptr))))
528                            (setf (aref result (1- (incf ptr)))                           (setf (aref result (1- (incf ptr)))
529                                (code-char b)))))))                               (code-char b)))))))
530    
531  (defun string-encode (string external-format &optional (start 0) end)  (defun string-encode (string external-format &optional (start 0) end)
532      (when (zerop (length string))
533        (return-from string-encode string))
534    (multiple-value-bind (result ptr)    (multiple-value-bind (result ptr)
535        (lisp::with-array-data ((string string) (start start) (end end))        (lisp::with-array-data ((string string) (start start) (end end))
536          (funcall (ef-encode (find-external-format external-format))          (funcall (ef-encode external-format) string start end
                  string start end  
537                   (make-string (length string) :element-type 'base-char)))                   (make-string (length string) :element-type 'base-char)))
538      (lisp::shrink-vector result ptr)))      (lisp::shrink-vector result ptr)))
539    
# Line 378  Line 541 
541    `(lambda (string ptr end result &aux (pos -1) (count 0) (state nil))    `(lambda (string ptr end result &aux (pos -1) (count 0) (state nil))
542       (declare #|(optimize (speed 3) (safety 0) (space 0) (debug 0))|#       (declare #|(optimize (speed 3) (safety 0) (space 0) (debug 0))|#
543                (type simple-string string)                (type simple-string string)
544                (type lisp::index end count)                (type kernel:index end count)
545                (type (integer -1 (#.array-dimension-limit)) ptr pos)                (type (integer -1 (#.array-dimension-limit)) ptr pos)
546                (type simple-string result)                (type simple-string result)
547                (ignorable state))                (ignorable state))
# Line 386  Line 549 
549          ;; increasing size of result shouldn't ever be necessary, unless          ;; increasing size of result shouldn't ever be necessary, unless
550          ;; someone implements an encoding smaller than the source string...          ;; someone implements an encoding smaller than the source string...
551          do (setf (schar result (incf pos))          do (setf (schar result (incf pos))
552                 ,(octets-to-char extfmt state count                 (octets-to-char ,extfmt state count
553                                  ;; note the need to return NIL for EOF                                 ;; note the need to return NIL for EOF
554                                  (if (= (1+ ptr) (length string))                                 (if (= (1+ ptr) (length string))
555                                      nil                                     nil
556                                      (char-code (char string (incf ptr))))                                     (char-code (char string (incf ptr))))
557                                  (lambda (n) (decf ptr n))))                                 (lambda (n) (decf ptr n))))
558          finally (return (values result (1+ pos))))))          finally (return (values result (1+ pos))))))
559    
560  (defun string-decode (string external-format &optional (start 0) end)  (defun string-decode (string external-format &optional (start 0) end)
561      (when (zerop (length string))
562        (return-from string-decode string))
563    (multiple-value-bind (result pos)    (multiple-value-bind (result pos)
564        (lisp::with-array-data ((string string) (start start) (end end))        (lisp::with-array-data ((string string) (start start) (end end))
565          (funcall (ef-decode (find-external-format external-format))          (funcall (ef-decode external-format)
566                   string (1- start) (1- end) (make-string (length string))))                   string (1- start) (1- end) (make-string (length string))))
567      (lisp::shrink-vector result pos)))      (lisp::shrink-vector result pos)))

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

  ViewVC Help
Powered by ViewVC 1.1.5