/[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.4 by rtoy, Wed Jul 2 14:53:44 2008 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* ((tmp1 (gensym)) (tmp2 (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 (svref ,tmp1 ,(second slot))))))))
141      `(macrolet ((octets-to-code ((state input unput &rest vars) body)      `(macrolet ((octets-to-code ((state input unput &rest vars) body)
142                    `(lambda (,',tmp1 ,state ,input ,unput)                    `(lambda (,',tmp1 ,state ,input ,unput)
143                       (declare (ignore ,',tmp1)                       (declare (type simple-vector ,',tmp1)
144                                (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 (,',tmp1 ,',tmp2 ,state ,output)
152                       (declare (ignore ,',tmp1)                       (declare (type simple-vector ,',tmp1)
153                                (ignorable ,state ,output)                                (ignorable ,state ,output)
154                                (optimize (ext:inhibit-warnings 3)))                                (optimize (ext:inhibit-warnings 3)))
155                       (let ((,code ',code)                       (let (,@',slotb
156                               (,code ',code)
157                             ,@(loop for var in vars collect `(,var (gensym))))                             ,@(loop for var in vars collect `(,var (gensym))))
158                         `(let ((,',code (the (unsigned-byte 31) ,,',tmp2)))                         `(let ((,',code (the (unsigned-byte 31) ,,',tmp2)))
159                            (declare (ignorable ,',code))                            (declare (ignorable ,',code))
160                            ,,body)))))                            ,,body)))))
161         (%whatsit (make-external-format ,name         (%intern-ef (make-external-format ,name
162                    (make-efx :octets-to-code ,octets-to-code                      ,(if base
163                              :code-to-octets ,code-to-octets                           `(ef-efx (find-external-format ,(ef-name base)))
164                              :cache (make-array +ef-max+ :initial-element nil))                           `(make-efx :octets-to-code ,octets-to-code
165                    nil                                      :code-to-octets ,code-to-octets
166                    #() '())))))                                      :cache (make-array +ef-max+
167                                                              :initial-element nil)
168  (defmacro define-composing-external-format (name input output)                                      :min ,(min min max) :max ,(max min max)))
169    (let ((tmp1 (gensym)) (tmp2 (gensym)))                      nil
170                        (vector ,@(mapcar #'third slotd))
171                        ',slotd)))))
172    
173    ;;; DEFINE-COMPOSING-EXTERNAL-FORMAT  -- Public
174    ;;;
175    ;;; A composing-external-format differs from an (ordinary) external-format
176    ;;; in that it translates characters (really codepoints, of course) into
177    ;;; other characters, rather than translating between characters and binary
178    ;;; octets.  They have to be composed with a non-composing external-format
179    ;;; to be of any use.
180    ;;;
181    (defmacro define-composing-external-format (name (&key min max size)
182                                                     input output)
183      (let ((tmp1 (gensym)) (tmp2 (gensym))
184            (min (or min size 1))
185            (max (or max size 1)))
186      `(macrolet ((input ((state input unput &rest vars) body)      `(macrolet ((input ((state input unput &rest vars) body)
187                    `(lambda (,',tmp1 ,state ,input ,unput)                    `(lambda (,',tmp1 ,state ,input ,unput)
188                       (declare (ignore ,',tmp1)                       (declare (ignore ,',tmp1)
189                                (ignorable ,state ,input ,unput)                                (ignorable ,state ,input ,unput)
190                                (optimize (ext:inhibit-warnings 3)))                                (optimize (ext:inhibit-warnings 3)))
191                       (let ((,input `(the (values (or (unsigned-byte 31) null)                       (let ((,input `(the (values (or (unsigned-byte 31) null)
192                                                   lisp::index)                                                   kernel:index)
193                                           ,,input))                                           ,,input))
194                             ,@(loop for var in vars collect `(,var (gensym))))                             ,@(loop for var in vars collect `(,var (gensym))))
195                         ,body)))                         ,body)))
# Line 122  Line 203 
203                         `(let ((,',code (the (unsigned-byte 31) ,,',tmp2)))                         `(let ((,',code (the (unsigned-byte 31) ,,',tmp2)))
204                            (declare (ignorable ,',code))                            (declare (ignorable ,',code))
205                            ,,body)))))                            ,,body)))))
206         (%whatsit (make-external-format ,name         (%intern-ef (make-external-format ,name
207                    (make-efx :octets-to-code ,input                      (make-efx :octets-to-code ,input
208                              :code-to-octets ,output)                                :code-to-octets ,output
209                    t                                :min ,(min min max) :max ,(max min max))
210                    #() '())))))                      t
211                        #() '())))))
212    
213  (defun load-external-format-aliases ()  (defun load-external-format-aliases ()
214    (let ((*package* (find-package "KEYWORD")))    (let ((*package* (find-package "KEYWORD"))
215            (unix::*filename-encoding* :iso8859-1))
216      (with-open-file (stm "ext-formats:aliases" :if-does-not-exist nil)      (with-open-file (stm "ext-formats:aliases" :if-does-not-exist nil)
217        (when stm        (when stm
218          (do ((alias (read stm nil stm) (read stm nil stm))          (do ((alias (read stm nil stm) (read stm nil stm))
219               (value (read stm nil stm) (read stm nil stm)))               (value (read stm nil stm) (read stm nil stm)))
220              ((or (eq alias stm) (eq value stm))              ((or (eq alias stm) (eq value stm))
221               (unless (eq alias stm)               (unless (eq alias stm)
222                 (warn "External-format aliases file ends early.")))                 (warn "External-format aliases file ends early.")))
223            (if (and (keywordp alias) (keywordp value))            (if (and (keywordp alias) (keywordp value))
224                (setf (gethash alias *external-format-aliases*) value)                (setf (gethash alias *external-format-aliases*) value)
225                (warn "Bad entry in external-format aliases file: ~S => ~S."                (warn "Bad entry in external-format aliases file: ~S => ~S."
226                      alias value)))))))                      alias value)))))))
227    
228  (defun %find-external-format (name)  (defun %find-external-format (name)
229    (when (zerop (hash-table-count *external-format-aliases*))    (when (ext:search-list-defined-p "ext-formats:")
230      (setf (gethash :latin1 *external-format-aliases*) :iso8859-1)      (when (zerop (hash-table-count *external-format-aliases*))
231      (setf (gethash :latin-1 *external-format-aliases*) :iso8859-1)        (setf (gethash :latin1 *external-format-aliases*) :iso8859-1)
232      (setf (gethash :iso-8859-1 *external-format-aliases*) :iso8859-1)        (setf (gethash :latin-1 *external-format-aliases*) :iso8859-1)
233      (load-external-format-aliases))        (setf (gethash :iso-8859-1 *external-format-aliases*) :iso8859-1)
234          (load-external-format-aliases)))
235    
236    (do ((tmp (gethash name *external-format-aliases*)    (do ((tmp (gethash name *external-format-aliases*)
237              (gethash tmp *external-format-aliases*))              (gethash tmp *external-format-aliases*))
# Line 159  Line 243 
243    
244    (or (gethash name *external-formats*)    (or (gethash name *external-formats*)
245        (and (let ((*package* (find-package "STREAM"))        (and (let ((*package* (find-package "STREAM"))
246                   (lisp::*enable-package-locked-errors* nil))                   (lisp::*enable-package-locked-errors* nil)
247                     (*default-external-format* :iso8859-1)
248                     (unix::*filename-encoding* :iso8859-1))
249               (load (format nil "ext-formats:~(~A~)" name)               (load (format nil "ext-formats:~(~A~)" name)
250                     :if-does-not-exist nil))                     :if-does-not-exist nil))
251             (gethash name *external-formats*))))             (gethash name *external-formats*))))
# Line 167  Line 253 
253  (defun %composed-ef-name (a b)  (defun %composed-ef-name (a b)
254    (if (consp a) (append a (list b)) (list a b)))    (if (consp a) (append a (list b)) (list a b)))
255    
256  (defun %compose-external-formats (a b &optional name)  (defun %compose-external-formats (a b)
257    (when (ef-composingp a)    (when (ef-composingp a)
258      (error "~S is a Composing-External-Format." (ef-name a)))      (error "~S is a Composing-External-Format." (ef-name a)))
259    (unless (ef-composingp b)    (unless (ef-composingp b)
260      (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))))  
261    (make-external-format    (make-external-format
262     (%composed-ef-name (ef-name a) (ef-name b))     (%composed-ef-name (ef-name a) (ef-name b))
263     (make-efx     (make-efx
# Line 196  Line 279 
279                                   ,(funcall (ef-code-to-octets a)                                   ,(funcall (ef-code-to-octets a)
280                                             (ef-slots a)                                             (ef-slots a)
281                                             'x state output))))                                             'x state output))))
282      :cache (make-array +ef-max+ :initial-element nil))      :cache (make-array +ef-max+ :initial-element nil)
283        :min (* (ef-min-octets a) (ef-min-octets b))
284        :max (* (ef-max-octets a) (ef-max-octets b)))
285     nil #() '()))     nil #() '()))
286    
287  (defun find-external-format (name &optional (error-p t))  (defun find-external-format (name &optional (error-p t))
# Line 218  Line 303 
303              (if error-p (error "External format ~S not found." name) nil)              (if error-p (error "External format ~S not found." name) nil)
304              (let ((name (reduce #'%composed-ef-name (mapcar #'ef-name efs))))              (let ((name (reduce #'%composed-ef-name (mapcar #'ef-name efs))))
305                (or (gethash name *external-formats*)                (or (gethash name *external-formats*)
306                    (%whatsit (reduce #'%compose-external-formats efs))))))                    (%intern-ef (reduce #'%compose-external-formats efs))))))
307        (or (%find-external-format name)        (or (%find-external-format name)
308            (if error-p (error "External format ~S not found." name) nil))))            (if error-p (error "External format ~S not found." name) nil))))
309    
310    (defun flush-external-formats ()
311      (maphash (lambda (name ef)
312                 (declare (ignore name))
313                 (fill (ef-cache ef) nil))
314               *external-formats*))
315    
316  (define-condition void-external-format (error)  (define-condition void-external-format (error)
317    ()    ()
318    (:report    (:report
# Line 229  Line 320 
320        (declare (ignore condition))        (declare (ignore condition))
321        (format stream "Attempting I/O through void external-format."))))        (format stream "Attempting I/O through void external-format."))))
322    
323  (define-external-format :void  (define-external-format :void (:size 0) ()
324    (octets-to-code (state input unput)    (octets-to-code (state input unput)
325      `(error 'void-external-format))      `(error 'void-external-format))
326    (code-to-octets (code state output)    (code-to-octets (code state output)
327      `(error 'void-external-format)))      `(error 'void-external-format)))
328    
329  (define-external-format :iso8859-1  (define-external-format :iso8859-1 (:size 1) ()
330    (octets-to-code (state input unput)    (octets-to-code (state input unput)
331      `(values ,input 1))      `(values ,input 1))
332    (code-to-octets (code state output)    (code-to-octets (code state output)
333      `(,output (if (> ,code 255) #x3F ,code))))      `(,output (if (> ,code 255) #x3F ,code))))
334    
335    ;;; OCTETS-TO-CODEPOINT, CODEPOINT-TO-OCTETS  -- Semi-Public
336    ;;;
337    ;;; Normally you'd want to use OCTETS-TO-CHAR and CHAR-TO-OCTETS instead of
338    ;;; these, but that limits you to Lisp's idea of a character - either Latin-1
339    ;;; in 8 bit Lisp images, or the Unicode BMP in 16 bit images.  If you want
340    ;;; to read or write texts containing characters not supported by your Lisp,
341    ;;; these macros can be used instead.
342  (defmacro octets-to-codepoint (external-format state count input unput)  (defmacro octets-to-codepoint (external-format state count input unput)
343    (let ((tmp1 (gensym)) (tmp2 (gensym)))    (let ((tmp1 (gensym)) (tmp2 (gensym)))
344      `(let ((body (funcall (ef-octets-to-code ,external-format)      `(let ((body (funcall (ef-octets-to-code ,external-format)
345                            (ef-slots ,external-format)                            (ef-slots ,external-format)
346                            ',state ',input ',unput)))                            ',state ',input ',unput)))
347         `(multiple-value-bind (,',tmp1 ,',tmp2) ,body         `(multiple-value-bind (,',tmp1 ,',tmp2) ,body
348            (setf ,',count (the lisp::index ,',tmp2))            (setf ,',count (the kernel:index ,',tmp2))
349            (the (or (unsigned-byte 31) null) ,',tmp1)))))            (the (or (unsigned-byte 31) null) ,',tmp1)))))
350    
351  (defmacro codepoint-to-octets (external-format code state output)  (defmacro codepoint-to-octets (external-format code state output)
# Line 268  Line 366 
366            (adjust-array (ef-cache ef) (+ base reqd) :initial-element nil)))            (adjust-array (ef-cache ef) (+ base reqd) :initial-element nil)))
367      base))      base))
368    
369    ;;; DEF-EF-MACRO  -- Public
370    ;;;
371    ;;;
372  (defmacro def-ef-macro (name (ef id reqd idx) body)  (defmacro def-ef-macro (name (ef id reqd idx) body)
373    (let ((tmp (gensym)))    (let ((tmp (gensym)))
374      `(defun ,name (,ef)      `(defun ,name (,ef)
# Line 280  Line 381 
381    
382    
383    
384    ;;; OCTETS-TO-CHAR, CHAR-TO-OCTETS  -- Public
385    ;;;
386    ;;; Read and write one character through an external-format
387    ;;;
388  (defmacro octets-to-char (external-format state count input unput)  (defmacro octets-to-char (external-format state count input unput)
389    `(let ((body (octets-to-codepoint ,external-format    `(let ((body (octets-to-codepoint ,external-format
390                                      ,state ,count ,input ,unput)))                                      ,state ,count ,input ,unput)))
391       `(let ((code ,body))       `(let ((code ,body))
392          (declare (type (unsigned-byte 31) code))          (declare (type (unsigned-byte 31) code))
393          (if (< code char-code-limit) (code-char code) #\?))))          (if (< code char-code-limit) (code-char code)
394                #-(and unicode (not unicode-bootstrap)) #\?
395                #+(and unicode (not unicode-bootstrap)) #\U+FFFD))))
396    
397  (defmacro char-to-octets (external-format char state output)  (defmacro char-to-octets (external-format char state output)
398    `(codepoint-to-octets ,external-format (char-code ,char) ,state ,output))    `(codepoint-to-octets ,external-format (char-code ,char) ,state ,output))
399    
400    
401  (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+)
402    `(lambda (string start end buffer &aux (ptr 0) (state nil))    `(lambda (string start end buffer &aux (ptr 0) (state nil))
403       (declare #|(optimize (speed 3) (safety 0) (space 0) (debug 0))|#       (declare #|(optimize (speed 3) (safety 0) (space 0) (debug 0))|#
404                (type simple-string string)                (type simple-string string)
405                (type lisp::index start end ptr)                (type kernel:index start end ptr)
406                (type (simple-array (unsigned-byte 8) (*)) buffer)                (type (simple-array (unsigned-byte 8) (*)) buffer)
407                (ignorable state))                (ignorable state))
408       (dotimes (i (- end start) (values buffer ptr))       (dotimes (i (- end start) (values buffer ptr))
409         (declare (type lisp::index i))         (declare (type kernel:index i))
410         ,(char-to-octets extfmt (schar string (+ start i)) state         ,(char-to-octets extfmt (schar string (+ start i)) state
411                          (lambda (b)                          (lambda (b)
412                            (when (= ptr (length buffer))                            (when (= ptr (length buffer))
# Line 308  Line 416 
416  (defun string-to-octets (string &key (start 0) end (external-format :default)  (defun string-to-octets (string &key (start 0) end (external-format :default)
417                                       (buffer nil bufferp))                                       (buffer nil bufferp))
418    (declare (type string string)    (declare (type string string)
419             (type lisp::index start)             (type kernel:index start)
420             (type (or lisp::index null) end)             (type (or kernel:index null) end)
421             (type (or (simple-array (unsigned-byte 8) (*)) null) buffer))             (type (or (simple-array (unsigned-byte 8) (*)) null) buffer))
422    (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)  
423                                          :element-type '(unsigned-byte 8)))))                                          :element-type '(unsigned-byte 8)))))
424      (values (if bufferp buffer (lisp::shrink-vector buffer ptr)) ptr)))      (multiple-value-bind (buffer ptr)
425            (lisp::with-array-data ((string string) (start start) (end end))
426              (funcall (ef-string-to-octets (find-external-format external-format))
427                       string start end buffer))
428          (values (if bufferp buffer (lisp::shrink-vector buffer ptr)) ptr))))
429    
430  (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+)
431    `(lambda (octets ptr end string &aux (pos -1) (count 0) (state nil))    `(lambda (octets ptr end string &aux (pos -1) (count 0) (state nil))
432       (declare #|(optimize (speed 3) (safety 0) (space 0) (debug 0))|#       (declare #|(optimize (speed 3) (safety 0) (space 0) (debug 0))|#
433                (type (simple-array (unsigned-byte 8) (*)) octets)                (type (simple-array (unsigned-byte 8) (*)) octets)
434                (type lisp::index end count)                (type kernel:index end count)
435                (type (integer -1 (#.array-dimension-limit)) ptr pos)                (type (integer -1 (#.array-dimension-limit)) ptr pos)
436                (type simple-string string)                (type simple-string string)
437                (ignorable state))                (ignorable state))
# Line 339  Line 447 
447  (defun octets-to-string (octets &key (start 0) end (external-format :default)  (defun octets-to-string (octets &key (start 0) end (external-format :default)
448                                       (string nil stringp))                                       (string nil stringp))
449    (declare (type (simple-array (unsigned-byte 8) (*)) octets)    (declare (type (simple-array (unsigned-byte 8) (*)) octets)
450             (type lisp::index start)             (type kernel:index start)
451             (type (or lisp::index null) end)             (type (or kernel:index null) end)
452             (type (or simple-string null) string))             (type (or simple-string null) string))
453    (multiple-value-bind (string pos)    (multiple-value-bind (string pos)
454        (funcall (ef-octets-to-string (find-external-format external-format))        (funcall (ef-octets-to-string (find-external-format external-format))
# Line 354  Line 462 
462    `(lambda (string start end result &aux (ptr 0) (state nil))    `(lambda (string start end result &aux (ptr 0) (state nil))
463       (declare #|(optimize (speed 3) (safety 0) (space 0) (debug 0))|#       (declare #|(optimize (speed 3) (safety 0) (space 0) (debug 0))|#
464                (type simple-string string)                (type simple-string string)
465                (type lisp::index start end ptr)                (type kernel:index start end ptr)
466                (type simple-base-string result)                (type simple-base-string result)
467                (ignorable state))                (ignorable state))
468       (dotimes (i (- end start) (values result ptr))       (dotimes (i (- end start) (values result ptr))
469         (declare (type lisp::index i))         (declare (type kernel:index i))
470         ,(char-to-octets extfmt (schar string (+ start i)) state         ,(char-to-octets extfmt (schar string (+ start i)) state
471                          (lambda (b)                          (lambda (b)
472                            (when (= ptr (length result))                            (when (= ptr (length result))
# Line 378  Line 486 
486    `(lambda (string ptr end result &aux (pos -1) (count 0) (state nil))    `(lambda (string ptr end result &aux (pos -1) (count 0) (state nil))
487       (declare #|(optimize (speed 3) (safety 0) (space 0) (debug 0))|#       (declare #|(optimize (speed 3) (safety 0) (space 0) (debug 0))|#
488                (type simple-string string)                (type simple-string string)
489                (type lisp::index end count)                (type kernel:index end count)
490                (type (integer -1 (#.array-dimension-limit)) ptr pos)                (type (integer -1 (#.array-dimension-limit)) ptr pos)
491                (type simple-string result)                (type simple-string result)
492                (ignorable state))                (ignorable state))

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

  ViewVC Help
Powered by ViewVC 1.1.5