/[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.21 by rtoy, Wed May 20 21:47:36 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    ;;; octets-to-code (state input unput &rest vars)
116    ;;;   Defines a form to be used by the external format to convert
117    ;;;   octets to a code point.  State is a form that can be used by the
118    ;;;   body to access the state variable of the stream.  Input is a
119    ;;;   form that can be used to read one more octets from the input
120    ;;;   strema.  Similarly, Unput is a form to put back one octet to the
121    ;;;   input stream.  Vars is a list of vars that need to be defined
122    ;;;   for any symbols used within the form.
123    ;;;
124    ;;;   This should return two values: the code and the number of octets
125    ;;;   read to form the code.
126    ;;;
127    ;;; code-to-octets (code state output &rest vars)
128    ;;;   Defines a form to be used by the external format to convert a
129    ;;;   code point to octets for output.  Code is the code point to be
130    ;;;   converted.  State is a form to access the current value of the
131    ;;;   stream's state variable.  Output is a form that writes one octet
132    ;;;   to the output stream.
133    ;;;
134    ;;; Note: external-formats work on code-points, not
135    ;;;   characters, so that the entire 31 bit ISO-10646 range can be
136    ;;;   used internally regardless of the size of a character recognized
137    ;;;   by Lisp and external formats can be useful to people who want to
138    ;;;   process characters outside the Lisp range (see
139    ;;;   CODEPOINT-TO-OCTETS, OCTETS-TO-CODEPOINT)
140    ;;;
141    (defmacro define-external-format (name (&rest args) (&rest slots)
142                                           &optional octets-to-code code-to-octets)
143      (when (and (oddp (length args)) (not (= (length args) 1)))
144        (warn "Nonsensical argument (~S) to DEFINE-EXTERNAL-FORMAT." args))
145      (let* ((tmp (gensym))
146             (min (if (evenp (length args))
147                      (or (getf args :min) (getf args :size) 1)
148                      1))
149             (max (if (evenp (length args))
150                      (or (getf args :max) (getf args :size) 6)
151                      6))
152             (base (if (= (length args) 1)
153                       (find-external-format (first args))
154                       nil))
155             (bslotd (if base (ef-slotd base) nil))
156             (slotd (%merge-slots bslotd slots))
157             (slotb (loop for slot in slotd
158                      collect `(,(first slot)
159                                `(the ,',(fourth slot)
160                                  ;; IDENTITY is here to protect against SETF
161                                  (identity (svref %slots% ,',(second slot))))))))
162      `(macrolet ((octets-to-code ((state input unput &rest vars) body)      `(macrolet ((octets-to-code ((state input unput &rest vars) body)
163                    `(lambda (,',tmp1 ,state ,input ,unput)                    `(lambda (,state ,input ,unput)
164                       (declare (ignore ,',tmp1)                       (declare (ignorable ,state ,input ,unput)
                               (ignorable ,state ,input ,unput)  
165                                (optimize (ext:inhibit-warnings 3)))                                (optimize (ext:inhibit-warnings 3)))
166                       (let ((,input `(the (or (unsigned-byte 8) null) ,,input))                       (let (,@',slotb
167                               (,input `(the (or (unsigned-byte 8) null) ,,input))
168                             ,@(loop for var in vars collect `(,var (gensym))))                             ,@(loop for var in vars collect `(,var (gensym))))
169                         ,body)))                         ,body)))
170                  (code-to-octets ((code state output &rest vars) body)                  (code-to-octets ((code state output &rest vars) body)
171                    `(lambda (,',tmp1 ,',tmp2 ,state ,output)                    `(lambda (,',tmp ,state ,output)
172                       (declare (ignore ,',tmp1)                       (declare (ignorable ,state ,output)
                               (ignorable ,state ,output)  
173                                (optimize (ext:inhibit-warnings 3)))                                (optimize (ext:inhibit-warnings 3)))
174                       (let ((,code ',code)                       (let (,@',slotb
175                               (,code ',code)
176                             ,@(loop for var in vars collect `(,var (gensym))))                             ,@(loop for var in vars collect `(,var (gensym))))
177                         `(let ((,',code (the (unsigned-byte 31) ,,',tmp2)))                         `(let ((,',code (the (unsigned-byte 21) ,,',tmp)))
178                            (declare (ignorable ,',code))                            (declare (ignorable ,',code))
179                            ,,body)))))                            ,,body)))))
180         (%whatsit (make-external-format ,name         (%intern-ef (make-external-format ,name
181                    (make-efx :octets-to-code ,octets-to-code                      ,(if base
182                              :code-to-octets ,code-to-octets                           `(ef-efx (find-external-format ,(ef-name base)))
183                              :cache (make-array +ef-max+ :initial-element nil))                           `(make-efx :octets-to-code ,octets-to-code
184                    nil                                      :code-to-octets ,code-to-octets
185                    #() '())))))                                      :cache (make-array +ef-max+
186                                                              :initial-element nil)
187  (defmacro define-composing-external-format (name input output)                                      :min ,(min min max) :max ,(max min max)))
188    (let ((tmp1 (gensym)) (tmp2 (gensym)))                      nil
189                        (let* ,(loop for x in slotd
190                                     collect (list (first x) (third x)))
191                          (vector ,@(mapcar #'first slotd)))
192                        ',slotd)))))
193    
194    ;;; DEFINE-COMPOSING-EXTERNAL-FORMAT  -- Public
195    ;;;
196    ;;; A composing-external-format differs from an (ordinary) external-format
197    ;;; in that it translates characters (really codepoints, of course) into
198    ;;; other characters, rather than translating between characters and binary
199    ;;; octets.  They have to be composed with a non-composing external-format
200    ;;; to be of any use.
201    ;;;
202    (defmacro define-composing-external-format (name (&key min max size)
203                                                     input output)
204      (let ((tmp (gensym))
205            (min (or min size 1))
206            (max (or max size 1)))
207      `(macrolet ((input ((state input unput &rest vars) body)      `(macrolet ((input ((state input unput &rest vars) body)
208                    `(lambda (,',tmp1 ,state ,input ,unput)                    `(lambda (,state ,input ,unput)
209                       (declare (ignore ,',tmp1)                       (declare (ignorable ,state ,input ,unput)
                               (ignorable ,state ,input ,unput)  
210                                (optimize (ext:inhibit-warnings 3)))                                (optimize (ext:inhibit-warnings 3)))
211                       (let ((,input `(the (values (or (unsigned-byte 31) null)                       (let ((,input `(the (values (or (unsigned-byte 21) null)
212                                                   lisp::index)                                                   kernel:index)
213                                           ,,input))                                           ,,input))
214                             ,@(loop for var in vars collect `(,var (gensym))))                             ,@(loop for var in vars collect `(,var (gensym))))
215                         ,body)))                         ,body)))
216                  (output ((code state output &rest vars) body)                  (output ((code state output &rest vars) body)
217                    `(lambda (,',tmp1 ,',tmp2 ,state ,output)                    `(lambda (,',tmp ,state ,output)
218                       (declare (ignore ,',tmp1)                       (declare (ignorable ,state ,output)
                               (ignorable ,state ,output)  
219                                (optimize (ext:inhibit-warnings 3)))                                (optimize (ext:inhibit-warnings 3)))
220                       (let ((,code ',code)                       (let ((,code ',code)
221                             ,@(loop for var in vars collect `(,var (gensym))))                             ,@(loop for var in vars collect `(,var (gensym))))
222                         `(let ((,',code (the (unsigned-byte 31) ,,',tmp2)))                         `(let ((,',code (the (unsigned-byte 21) ,,',tmp)))
223                            (declare (ignorable ,',code))                            (declare (ignorable ,',code))
224                            ,,body)))))                            ,,body)))))
225         (%whatsit (make-external-format ,name         (%intern-ef (make-external-format ,name
226                    (make-efx :octets-to-code ,input                      (make-efx :octets-to-code ,input
227                              :code-to-octets ,output)                                :code-to-octets ,output
228                    t                                :min ,(min min max) :max ,(max min max))
229                    #() '())))))                      t
230                        #() '())))))
231    
232  (defun load-external-format-aliases ()  (defun load-external-format-aliases ()
233    (let ((*package* (find-package "KEYWORD")))    (let ((*package* (find-package "KEYWORD"))
234      (with-open-file (stm "ext-formats:aliases" :if-does-not-exist nil)          (unix::*filename-encoding* :iso8859-1))
235        (with-open-file (stm "ext-formats:aliases" :if-does-not-exist nil :external-format :iso8859-1)
236        (when stm        (when stm
237          (do ((alias (read stm nil stm) (read stm nil stm))          (do ((alias (read stm nil stm) (read stm nil stm))
238               (value (read stm nil stm) (read stm nil stm)))               (value (read stm nil stm) (read stm nil stm)))
239              ((or (eq alias stm) (eq value stm))              ((or (eq alias stm) (eq value stm))
240               (unless (eq alias stm)               (unless (eq alias stm)
241                 (warn "External-format aliases file ends early.")))                 (warn "External-format aliases file ends early.")))
242            (if (and (keywordp alias) (keywordp value))            (if (and (keywordp alias) (keywordp value))
243                (setf (gethash alias *external-format-aliases*) value)                (setf (gethash alias *external-format-aliases*) value)
244                (warn "Bad entry in external-format aliases file: ~S => ~S."                (warn "Bad entry in external-format aliases file: ~S => ~S."
245                      alias value)))))))                      alias value)))))))
246    
247  (defun %find-external-format (name)  (defun %find-external-format (name)
248      ;; avoid loading files, etc., early in the boot sequence
249      (when (or (eq name :iso8859-1)
250                (and (eq name :default) (eq *default-external-format* :iso8859-1)))
251        (return-from %find-external-format
252          (gethash :iso8859-1 *external-formats*)))
253    
254    (when (zerop (hash-table-count *external-format-aliases*))    (when (zerop (hash-table-count *external-format-aliases*))
255      (setf (gethash :latin1 *external-format-aliases*) :iso8859-1)      (setf (gethash :latin1 *external-format-aliases*) :iso8859-1)
256      (setf (gethash :latin-1 *external-format-aliases*) :iso8859-1)      (setf (gethash :latin-1 *external-format-aliases*) :iso8859-1)
# Line 159  Line 267 
267    
268    (or (gethash name *external-formats*)    (or (gethash name *external-formats*)
269        (and (let ((*package* (find-package "STREAM"))        (and (let ((*package* (find-package "STREAM"))
270                   (lisp::*enable-package-locked-errors* nil))                   (lisp::*enable-package-locked-errors* nil)
271               (load (format nil "ext-formats:~(~A~)" name)                   (*default-external-format* :iso8859-1)
272                     :if-does-not-exist nil))                   (unix::*filename-encoding* :iso8859-1)
273                     (s (open (format nil "ext-formats:~(~A~).lisp" name) :if-does-not-exist nil
274                              :external-format :iso8859-1)))
275                 (when s
276                   (null (nth-value 1 (ext:compile-from-stream s)))))
277             (gethash name *external-formats*))))             (gethash name *external-formats*))))
278    
279  (defun %composed-ef-name (a b)  (defun %composed-ef-name (a b)
280    (if (consp a) (append a (list b)) (list a b)))    (if (consp a) (append a (list b)) (list a b)))
281    
282  (defun %compose-external-formats (a b &optional name)  (defun %compose-external-formats (a b)
283    (when (ef-composingp a)    (when (ef-composingp a)
284      (error "~S is a Composing-External-Format." (ef-name a)))      (error "~S is a Composing-External-Format." (ef-name a)))
285    (unless (ef-composingp b)    (unless (ef-composingp b)
286      (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))))  
287    (make-external-format    (make-external-format
288     (%composed-ef-name (ef-name a) (ef-name b))     (%composed-ef-name (ef-name a) (ef-name b))
289     (make-efx     (make-efx
290      :octets-to-code (lambda (tmp state input unput)      :octets-to-code (lambda (state input unput)
291                        (declare (ignore tmp))                        (funcall (ef-octets-to-code b) state
292                        (funcall (ef-octets-to-code b) (ef-slots b)                                 (funcall (ef-octets-to-code a)
293                                 state                                          state input unput)
                                (funcall (ef-octets-to-code a) (ef-slots a)  
                                         state  
                                         input  
                                         unput)  
294                                 unput))                                 unput))
295      :code-to-octets (lambda (tmp code state output)      :code-to-octets (lambda (code state output)
296                        (declare (ignore tmp))                        (funcall (ef-code-to-octets b) code state
                       (funcall (ef-code-to-octets b) (ef-slots b)  
                                code  
                                state  
297                                 `(lambda (x)                                 `(lambda (x)
298                                   ,(funcall (ef-code-to-octets a)                                   ,(funcall (ef-code-to-octets a)
                                            (ef-slots a)  
299                                             'x state output))))                                             'x state output))))
300      :cache (make-array +ef-max+ :initial-element nil))      :cache (make-array +ef-max+ :initial-element nil)
301        :min (* (ef-min-octets a) (ef-min-octets b))
302        :max (* (ef-max-octets a) (ef-max-octets b)))
303     nil #() '()))     nil #() '()))
304    
305  (defun find-external-format (name &optional (error-p t))  (defun find-external-format (name &optional (error-p t))
# Line 212  Line 315 
315    (when (and (consp name) (not (cdr name)))    (when (and (consp name) (not (cdr name)))
316      (setq name (car name)))      (setq name (car name)))
317    
318    (if (consp name)    (flet ((not-found ()
319        (let ((efs (mapcar #'%find-external-format name)))             (when (equal *default-external-format* name)
320          (if (member nil efs)               (setq *default-external-format* :iso8859-1))
321              (if error-p (error "External format ~S not found." name) nil)             (if error-p (error "External format ~S not found." name) nil)))
322              (let ((name (reduce #'%composed-ef-name (mapcar #'ef-name efs))))      (if (consp name)
323                (or (gethash name *external-formats*)          (let ((efs (mapcar #'%find-external-format name)))
324                    (%whatsit (reduce #'%compose-external-formats efs))))))            (if (member nil efs)
325        (or (%find-external-format name)                (not-found)
326            (if error-p (error "External format ~S not found." name) nil))))                (let ((name (reduce #'%composed-ef-name (mapcar #'ef-name efs))))
327                    (or (gethash name *external-formats*)
328                        (%intern-ef (reduce #'%compose-external-formats efs))))))
329            (or (%find-external-format name) (not-found)))))
330    
331    (defun flush-external-formats ()
332      (maphash (lambda (name ef)
333                 (declare (ignore name))
334                 (fill (ef-cache ef) nil))
335               *external-formats*))
336    
337    (defvar *.table-inverse.* (make-hash-table :test 'eq :size 7))
338    
339    (defun invert-table (table)
340      (declare (type (or (simple-array (unsigned-byte 31) *)
341                         (simple-array (unsigned-byte 16) *))
342                     table)
343               (optimize (speed 3) (space 0) (safety 0) (debug 0)
344                         (ext:inhibit-warnings 3)))
345      (or (gethash table *.table-inverse.*)
346          (let* ((mbits (if (= (array-total-size table) 128) 7 8))
347                 (lbits (cond ((> (array-total-size table) 256) 3)
348                              ((< (array-total-size table) 100) 6)
349                              (t 5)))
350                 (hvec (make-array (1+ (ash #x110000 (- 0 mbits lbits)))
351                                   :element-type '(unsigned-byte 16)
352                                   :initial-element #xFFFF))
353                 (mvec (make-array 0 :element-type '(unsigned-byte 16)))
354                 (lvec (make-array 0 :element-type '(unsigned-byte 16)))
355                 (width (array-dimension table 0))
356                 (power (1- (array-rank table)))
357                 (base (if (= width 94) 1 0))
358                 hx mx lx)
359            (assert (and (< power 2) (<= width 256)))
360            (dotimes (i (array-total-size table))
361              (declare (type (integer 0 (#.array-dimension-limit)) i))
362              (let ((tmp i) (val (row-major-aref table i)) (z 0))
363                (declare (type (integer 0 (#.array-dimension-limit)) tmp)
364                         (type (unsigned-byte 16) z))
365                (unless (= val #xFFFE)
366                  (when (plusp power)
367                    (multiple-value-bind (x y) (floor tmp width)
368                      (setq tmp x)
369                      (setq z (logior z (ash (the (integer 0 255) (+ y base))
370                                             (the (integer 0 24)
371                                               (* 8 power)))))))
372                  (setq hx (ash val (- 0 mbits lbits)))
373                  (when (= (aref hvec hx) #xFFFF)
374                    (setf (aref hvec hx) (length mvec))
375                    (let ((tmp (make-array (+ (length mvec) (ash 1 mbits))
376                                           :element-type '(unsigned-byte 16)
377                                           :initial-element #xFFFF)))
378                      (replace tmp mvec)
379                      (setq mvec tmp)))
380                  (setq mx (logand (ash val (- lbits)) (lognot (ash -1 mbits))))
381                  (when (= (aref mvec (+ hx mx)) #xFFFF)
382                    (setf (aref mvec (+ hx mx)) (length lvec))
383                    (let ((tmp (make-array (+ (length lvec) (ash 1 lbits))
384                                           :element-type '(unsigned-byte 16)
385                                           :initial-element #xFFFF)))
386                      (replace tmp lvec)
387                      (setq lvec tmp)))
388                  (setq lx (logand val (lognot (ash -1 lbits))))
389                  (setf (aref lvec (+ (aref mvec (+ hx mx)) lx))
390                      (logior z (+ tmp base))))))
391            (setf (gethash table *.table-inverse.*)
392                (lisp::make-ntrie16 :split (logior (ash (1- mbits) 4) (1- lbits))
393                                    :hvec hvec :mvec mvec :lvec lvec)))))
394    
395    (declaim (inline get-inverse))
396    (defun get-inverse (ntrie code)
397      (declare (type lisp::ntrie16 ntrie) (type (integer 0 #x10FFFF) code))
398      (let ((n (lisp::qref ntrie code)))
399        (and n (let ((m (aref (lisp::ntrie16-lvec ntrie) n)))
400                 (if (= m #xFFFF) nil m)))))
401    
402    
403  (define-condition void-external-format (error)  (define-condition void-external-format (error)
404    ()    ()
# Line 229  Line 407 
407        (declare (ignore condition))        (declare (ignore condition))
408        (format stream "Attempting I/O through void external-format."))))        (format stream "Attempting I/O through void external-format."))))
409    
410  (define-external-format :void  (define-external-format :void (:size 0) ()
411    (octets-to-code (state input unput)    (octets-to-code (state input unput)
412      `(error 'void-external-format))      `(error 'void-external-format))
413    (code-to-octets (code state output)    (code-to-octets (code state output)
414      `(error 'void-external-format)))      `(error 'void-external-format)))
415    
416  (define-external-format :iso8859-1  (define-external-format :iso8859-1 (:size 1) ()
417    (octets-to-code (state input unput)    (octets-to-code (state input unput)
418      `(values ,input 1))      `(values ,input 1))
419    (code-to-octets (code state output)    (code-to-octets (code state output)
420      `(,output (if (> ,code 255) #x3F ,code))))      `(,output (if (> ,code 255) #x3F ,code))))
421    
422    ;;; OCTETS-TO-CODEPOINT, CODEPOINT-TO-OCTETS  -- Semi-Public
423    ;;;
424    ;;; Normally you'd want to use OCTETS-TO-CHAR and CHAR-TO-OCTETS instead of
425    ;;; these, but that limits you to Lisp's idea of a character - either Latin-1
426    ;;; in 8 bit Lisp images, or the Unicode BMP in 16 bit images.  If you want
427    ;;; to read or write texts containing characters not supported by your Lisp,
428    ;;; these macros can be used instead.
429  (defmacro octets-to-codepoint (external-format state count input unput)  (defmacro octets-to-codepoint (external-format state count input unput)
430    (let ((tmp1 (gensym)) (tmp2 (gensym)))    (let ((tmp1 (gensym)) (tmp2 (gensym))
431      `(let ((body (funcall (ef-octets-to-code ,external-format)          (ef (find-external-format external-format)))
432                            (ef-slots ,external-format)      `(multiple-value-bind (,tmp1 ,tmp2)
433                            ',state ',input ',unput)))           ,(funcall (ef-octets-to-code ef) state input unput)
434         `(multiple-value-bind (,',tmp1 ,',tmp2) ,body         (setf ,count (the kernel:index ,tmp2))
435            (setf ,',count (the lisp::index ,',tmp2))         (the (or (unsigned-byte 21) null) ,tmp1))))
           (the (or (unsigned-byte 31) null) ,',tmp1)))))  
436    
437  (defmacro codepoint-to-octets (external-format code state output)  (defmacro codepoint-to-octets (external-format code state output)
438    `(funcall (ef-code-to-octets ,external-format) (ef-slots ,external-format)    (let ((ef (find-external-format external-format)))
439              ',code ',state ',output))      (funcall (ef-code-to-octets ef) code state output)))
440    
441    
442    
# Line 268  Line 452 
452            (adjust-array (ef-cache ef) (+ base reqd) :initial-element nil)))            (adjust-array (ef-cache ef) (+ base reqd) :initial-element nil)))
453      base))      base))
454    
455    ;;; DEF-EF-MACRO  -- Public
456    ;;;
457    ;;;
458  (defmacro def-ef-macro (name (ef id reqd idx) body)  (defmacro def-ef-macro (name (ef id reqd idx) body)
459    (let ((tmp (gensym)))    (let ((tmp1 (gensym))
460      `(defun ,name (,ef)          (tmp2 (gensym))
461         (let ((,tmp ,(if (eq id 'lisp::lisp)          (%name (intern (format nil "%~A" name) (symbol-package name))))
462                          idx      `(progn
463                          `(+ (ensure-cache ,ef ',id ,reqd) ,idx))))         (defun ,%name (,ef)
464           (or (aref (ef-cache ,ef) ,tmp)           (let* ((,tmp1 (find-external-format ,ef))
465               (setf (aref (ef-cache ,ef) ,tmp)                  (,tmp2 ,(if (eq id 'lisp::lisp)
466                   (let ((*compile-print* nil)) (compile nil ,body))))))))                              idx
467                                `(+ (ensure-cache ,tmp1 ',id ,reqd) ,idx))))
468               (funcall (or (aref (ef-cache ,tmp1) ,tmp2)
469                            (setf (aref (ef-cache ,tmp1) ,tmp2)
470                                (let ((*compile-print* nil)
471                                      ;; Set default format when we compile so we
472                                      ;; can see compiler messages.  If we don't,
473                                      ;; we run into a problem that we might be
474                                      ;; changing the default format while we're
475                                      ;; compiling, and we don't know how to output
476                                      ;; the compiler messages.
477                                      (*default-external-format* :iso8859-1))
478                                  (compile nil `(lambda (%slots%)
479                                                  (declare (ignorable %slots%))
480                                                  ,,body)))))
481                        (ef-slots ,tmp1))))
482           (declaim (inline ,name))
483           (defun ,name (,tmp1)
484             (let ((,tmp2 (load-time-value (cons nil nil))))
485               (when (eq ,tmp1 :default)
486                 (setq ,tmp1 *default-external-format*))
487               (if (eq ,tmp1 (car ,tmp2))
488                   (cdr ,tmp2)
489                   (setf (car ,tmp2) ,tmp1
490                         (cdr ,tmp2) (,%name ,tmp1))))))))
491    
492    
493    
494    ;;; OCTETS-TO-CHAR, CHAR-TO-OCTETS  -- Public
495    ;;;
496    ;;; Read and write one character through an external-format
497    ;;;
498  (defmacro octets-to-char (external-format state count input unput)  (defmacro octets-to-char (external-format state count input unput)
499    `(let ((body (octets-to-codepoint ,external-format    (let ((s (gensym "STATE-"))
500                                      ,state ,count ,input ,unput)))          (code (gensym "CODE-")))
501       `(let ((code ,body))      `(let ((,s ,state))
502          (declare (type (unsigned-byte 31) code))         (when (null ,s)
503          (if (< code char-code-limit) (code-char code) #\?))))           ;; Need our own state variable to hold our state and the
504             ;; state for the external format.
505             (setq ,s (setf ,state (cons nil nil))))
506           (if (car ,s)
507               ;; Return the trailing surrgate.  Must set count to 0 to
508               ;; tell the stream code we didn't consume any octets!
509               (prog1 (the character (car ,s))
510                 (setf (car ,s) nil)
511                 (setf ,count 0))
512               (let ((,code (octets-to-codepoint ,external-format
513                                                (cdr ,s) ,count ,input ,unput)))
514                 (declare (type (unsigned-byte 31) ,code))
515                 (cond ((or (lisp::surrogatep ,code)
516                            (> ,code #x10FFFF))
517                        #-(and unicode (not unicode-bootstrap)) #\?
518                        #+(and unicode (not unicode-bootstrap)) #\U+FFFD)
519                       #+unicode
520                       ((> ,code #xFFFF)
521                        (multiple-value-bind (hi lo)
522                            (lisp::surrogates ,code)
523                          (setf (car ,state) lo)
524                          hi))
525                       (t (code-char ,code))))))))
526    
527    ;; This doesn't handle surrogate code units correctly.  It just
528    ;; outputs the surrogate value to the external format.  External
529    ;; formats almost never allow surrogate code points (except UTF-16).
530  (defmacro char-to-octets (external-format char state output)  (defmacro char-to-octets (external-format char state output)
531    `(codepoint-to-octets ,external-format (char-code ,char) ,state ,output))    `(codepoint-to-octets ,external-format (char-code ,char) ,state ,output))
532    
533    
534  (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+)
535    `(lambda (string start end buffer &aux (ptr 0) (state nil))    `(lambda (string start end buffer &aux (ptr 0) (state nil) (code 0) (c 0) widep)
536       (declare #|(optimize (speed 3) (safety 0) (space 0) (debug 0))|#       (declare #|(optimize (speed 3) (safety 0) (space 0) (debug 0))|#
537                (type simple-string string)                (type simple-string string)
538                (type lisp::index start end ptr)                (type kernel:index start end ptr)
539                (type (simple-array (unsigned-byte 8) (*)) buffer)                (type (simple-array (unsigned-byte 8) (*)) buffer)
540                  (type (integer 0 #x10ffff) code c)
541                  (type (or null fixnum) widep)
542                (ignorable state))                (ignorable state))
543       (dotimes (i (- end start) (values buffer ptr))      (loop with i of-type kernel:index = start
544         (declare (type lisp::index i))            while (< i end)
545         ,(char-to-octets extfmt (schar string (+ start i)) state            do
546                          (lambda (b)            (multiple-value-bind (c widep)
547                            (when (= ptr (length buffer))                (lisp::codepoint string i end)
548                              (setq buffer (adjust-array buffer (* 2 ptr))))              (incf i (if widep 2 1))
549                            (setf (aref buffer (1- (incf ptr))) b))))))              (codepoint-to-octets ,extfmt c state
550                                     (lambda (b)
551                                       (when (= ptr (length buffer))
552                                         (setq buffer (adjust-array buffer (* 2 ptr))))
553                                       (setf (aref buffer (1- (incf ptr))) b)))))))
554    
555  (defun string-to-octets (string &key (start 0) end (external-format :default)  (defun string-to-octets (string &key (start 0) end (external-format :default)
556                                       (buffer nil bufferp))                                       (buffer nil bufferp))
557    (declare (type string string)    (declare (type string string)
558             (type lisp::index start)             (type kernel:index start)
559             (type (or lisp::index null) end)             (type (or kernel:index null) end)
560             (type (or (simple-array (unsigned-byte 8) (*)) null) buffer))             (type (or (simple-array (unsigned-byte 8) (*)) null) buffer))
561    (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)  
562                                          :element-type '(unsigned-byte 8)))))                                          :element-type '(unsigned-byte 8)))))
563      (values (if bufferp buffer (lisp::shrink-vector buffer ptr)) ptr)))      (multiple-value-bind (buffer ptr)
564            (lisp::with-array-data ((string string) (start start) (end end))
565              (funcall (ef-string-to-octets external-format)
566                       string start end buffer))
567          (values (if bufferp buffer (lisp::shrink-vector buffer ptr)) ptr))))
568    
569  (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+)
570    `(lambda (octets ptr end string &aux (pos -1) (count 0) (state nil))    `(lambda (octets ptr end string &aux (pos -1) (count 0) (state nil) (code 0))
571       (declare #|(optimize (speed 3) (safety 0) (space 0) (debug 0))|#       (declare #|(optimize (speed 3) (safety 0) (space 0) (debug 0))|#
572                (type (simple-array (unsigned-byte 8) (*)) octets)                (type (simple-array (unsigned-byte 8) (*)) octets)
573                (type lisp::index end count)                (type kernel:index end count)
574                (type (integer -1 (#.array-dimension-limit)) ptr pos)                (type (integer -1 (#.array-dimension-limit)) ptr pos)
575                (type simple-string string)                (type simple-string string)
576                  (type (integer 0 #x10ffff) code)
577                (ignorable state))                (ignorable state))
578       (loop until (>= ptr end)       (loop until (>= ptr end)
579          do (when (= pos (length string))          do (when (= pos (length string))
580               (setq string (adjust-array string (* 2 pos))))               (setq string (adjust-array string (* 2 pos))))
581             (setf (schar string (incf pos))             (setf code
582                 ,(octets-to-char extfmt state count                 (octets-to-codepoint ,extfmt state count
583                                  (aref octets (incf ptr)) ;;@@ EOF??                                 (aref octets (incf ptr)) ;;@@ EOF??
584                                  (lambda (n) (decf ptr n))))                                 (lambda (n) (decf ptr n))))
585               ;; Convert codepoint to UTF-16 surrogate pairs if needed
586               (multiple-value-bind (high low)
587                   (surrogates code)
588                 (setf (aref string (incf pos)) high)
589                 (when low
590                   (setf (aref string (incf pos)) low)))
591          finally (return (values string (1+ pos))))))          finally (return (values string (1+ pos))))))
592    
593  (defun octets-to-string (octets &key (start 0) end (external-format :default)  (defun octets-to-string (octets &key (start 0) end (external-format :default)
594                                       (string nil stringp))                                       (string nil stringp))
595    (declare (type (simple-array (unsigned-byte 8) (*)) octets)    (declare (type (simple-array (unsigned-byte 8) (*)) octets)
596             (type lisp::index start)             (type kernel:index start)
597             (type (or lisp::index null) end)             (type (or kernel:index null) end)
598             (type (or simple-string null) string))             (type (or simple-string null) string))
599    (multiple-value-bind (string pos)    (multiple-value-bind (string pos)
600        (funcall (ef-octets-to-string (find-external-format external-format))        (funcall (ef-octets-to-string external-format)
601                 octets (1- start) (1- (or end (length octets)))                 octets (1- start) (1- (or end (length octets)))
602                 (or string (make-string (length octets))))                 (or string (make-string (length octets))))
603      (values (if stringp string (lisp::shrink-vector string pos)) pos)))      (values (if stringp string (lisp::shrink-vector string pos)) pos)))
# Line 354  Line 608 
608    `(lambda (string start end result &aux (ptr 0) (state nil))    `(lambda (string start end result &aux (ptr 0) (state nil))
609       (declare #|(optimize (speed 3) (safety 0) (space 0) (debug 0))|#       (declare #|(optimize (speed 3) (safety 0) (space 0) (debug 0))|#
610                (type simple-string string)                (type simple-string string)
611                (type lisp::index start end ptr)                (type kernel:index start end ptr)
612                (type simple-base-string result)                (type simple-base-string result)
613                (ignorable state))                (ignorable state))
614       (dotimes (i (- end start) (values result ptr))       (dotimes (i (- end start) (values result ptr))
615         (declare (type lisp::index i))         (declare (type kernel:index i))
616         ,(char-to-octets extfmt (schar string (+ start i)) state         (char-to-octets ,extfmt (schar string (+ start i)) state
617                          (lambda (b)                         (lambda (b)
618                            (when (= ptr (length result))                           (when (= ptr (length result))
619                              (setq result (adjust-array result (* 2 ptr))))                             (setq result (adjust-array result (* 2 ptr))))
620                            (setf (aref result (1- (incf ptr)))                           (setf (aref result (1- (incf ptr)))
621                                (code-char b)))))))                               (code-char b)))))))
622    
623  (defun string-encode (string external-format &optional (start 0) end)  (defun string-encode (string external-format &optional (start 0) end)
624      "Encode the given String using External-Format and return a new
625      string.  The characters of the new string are the octets of the
626      encoded result, with each octet converted to a character via
627      code-char.  This is the inverse to String-Decode"
628      (when (zerop (length string))
629        (return-from string-encode string))
630    (multiple-value-bind (result ptr)    (multiple-value-bind (result ptr)
631        (lisp::with-array-data ((string string) (start start) (end end))        (lisp::with-array-data ((string string) (start start) (end end))
632          (funcall (ef-encode (find-external-format external-format))          (funcall (ef-encode external-format) string start end
                  string start end  
633                   (make-string (length string) :element-type 'base-char)))                   (make-string (length string) :element-type 'base-char)))
634      (lisp::shrink-vector result ptr)))      (lisp::shrink-vector result ptr)))
635    
# Line 378  Line 637 
637    `(lambda (string ptr end result &aux (pos -1) (count 0) (state nil))    `(lambda (string ptr end result &aux (pos -1) (count 0) (state nil))
638       (declare #|(optimize (speed 3) (safety 0) (space 0) (debug 0))|#       (declare #|(optimize (speed 3) (safety 0) (space 0) (debug 0))|#
639                (type simple-string string)                (type simple-string string)
640                (type lisp::index end count)                (type kernel:index end count)
641                (type (integer -1 (#.array-dimension-limit)) ptr pos)                (type (integer -1 (#.array-dimension-limit)) ptr pos)
642                (type simple-string result)                (type simple-string result)
643                (ignorable state))                (ignorable state))
# Line 386  Line 645 
645          ;; increasing size of result shouldn't ever be necessary, unless          ;; increasing size of result shouldn't ever be necessary, unless
646          ;; someone implements an encoding smaller than the source string...          ;; someone implements an encoding smaller than the source string...
647          do (setf (schar result (incf pos))          do (setf (schar result (incf pos))
648                 ,(octets-to-char extfmt state count                 (octets-to-char ,extfmt state count
649                                  ;; note the need to return NIL for EOF                                 ;; note the need to return NIL for EOF
650                                  (if (= (1+ ptr) (length string))                                 (if (= (1+ ptr) (length string))
651                                      nil                                     nil
652                                      (char-code (char string (incf ptr))))                                     (char-code (char string (incf ptr))))
653                                  (lambda (n) (decf ptr n))))                                 (lambda (n) (decf ptr n))))
654          finally (return (values result (1+ pos))))))          finally (return (values result (1+ pos))))))
655    
656  (defun string-decode (string external-format &optional (start 0) end)  (defun string-decode (string external-format &optional (start 0) end)
657      "Decode String using the given External-Format and return the new
658      string.  The input string is treated as if it were an array of
659      octets, where the char-code of each character is the octet.  This is
660      the inverse of String-Encode."
661      (when (zerop (length string))
662        (return-from string-decode string))
663    (multiple-value-bind (result pos)    (multiple-value-bind (result pos)
664        (lisp::with-array-data ((string string) (start start) (end end))        (lisp::with-array-data ((string string) (start start) (end end))
665          (funcall (ef-decode (find-external-format external-format))          (funcall (ef-decode external-format)
666                   string (1- start) (1- end) (make-string (length string))))                   string (1- start) (1- end) (make-string (length string))))
667      (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.21

  ViewVC Help
Powered by ViewVC 1.1.5