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

Contents of /src/code/extfmts.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.2.4.3.2.2 - (hide annotations)
Wed Jul 2 01:27:09 2008 UTC (5 years, 9 months ago) by rtoy
Branch: unicode-utf16-extfmt-branch
Changes since 1.2.4.3.2.1: +3 -2 lines
Oops.  Don't know how to read #\U+FFFD yet.  Use (code-char #xfffd)
instead.
1 rtoy 1.1 ;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Package: STREAM -*-
2     ;;;
3     ;;; **********************************************************************
4     ;;; This code was written by Paul Foley and has been placed in the public
5     ;;; domain.
6     ;;;
7     (ext:file-comment
8 rtoy 1.2.4.3.2.2 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/extfmts.lisp,v 1.2.4.3.2.2 2008/07/02 01:27:09 rtoy Exp $")
9 rtoy 1.1 ;;;
10     ;;; **********************************************************************
11     ;;;
12     ;;; Implementation of external-formats
13    
14     (in-package "STREAM")
15    
16     (export '(string-to-octets octets-to-string *default-external-format*
17 rtoy 1.2.4.1 string-encode string-decode))
18 rtoy 1.1
19     (defvar *default-external-format* :iso8859-1)
20    
21 rtoy 1.2.4.1 (defvar *external-formats* (make-hash-table :test 'equal))
22 rtoy 1.1 (defvar *external-format-aliases* (make-hash-table))
23    
24 rtoy 1.2.4.3.2.1 (defconstant +ef-cin+ 2)
25     (defconstant +ef-cout+ 3)
26     (defconstant +ef-sin+ 4)
27     (defconstant +ef-sout+ 5)
28     (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 rtoy 1.2.4.1
34 rtoy 1.1 (define-condition external-format-not-implemented (error)
35     ()
36     (:report
37     (lambda (condition stream)
38     (declare (ignore condition))
39     (format stream "Attempting unimplemented external-format I/O."))))
40    
41     (defun %efni (a b c d)
42     (declare (ignore a b c d))
43     (error 'external-format-not-implemented))
44    
45 rtoy 1.2.4.3 (defstruct efx
46     (octets-to-code #'%efni :type function :read-only t)
47     (code-to-octets #'%efni :type function :read-only t)
48 rtoy 1.2.4.3.2.1 (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 rtoy 1.2.4.3
52 rtoy 1.1 (defstruct (external-format
53     (:conc-name ef-)
54     (:print-function %print-external-format)
55 rtoy 1.2.4.3 (:constructor make-external-format (name efx composingp
56     &optional slots slotd)))
57 rtoy 1.2.4.1 (name (ext:required-argument) :type (or keyword cons) :read-only t)
58 rtoy 1.2.4.3 (efx (ext:required-argument) :type efx :read-only t)
59 rtoy 1.2.4.1 (composingp (ext:required-argument) :type boolean :read-only t)
60 rtoy 1.1 (slots #() :type simple-vector :read-only t)
61 rtoy 1.2.4.3 (slotd nil :type list :read-only t))
62 rtoy 1.1
63     (defun %print-external-format (ef stream depth)
64     (declare (ignore depth))
65     (print-unreadable-object (ef stream :type t :identity t)
66     (princ (ef-name ef) stream)))
67    
68 rtoy 1.2.4.3.2.1 (defun %intern-ef (ef)
69 rtoy 1.2.4.1 (setf (gethash (ef-name ef) *external-formats*) ef))
70    
71 rtoy 1.2.4.3.2.1 (declaim (inline ef-octets-to-code ef-code-to-octets ef-cache
72     ef-min-octets ef-max-octets))
73 rtoy 1.2.4.3
74     (defun ef-octets-to-code (ef)
75     (efx-octets-to-code (ef-efx ef)))
76    
77     (defun ef-code-to-octets (ef)
78     (efx-code-to-octets (ef-efx ef)))
79    
80     (defun ef-cache (ef)
81     (efx-cache (ef-efx ef)))
82    
83 rtoy 1.2.4.3.2.1 (defun ef-min-octets (ef)
84     (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 rtoy 1.2.4.1 `(macrolet ((octets-to-code ((state input unput &rest vars) body)
142     `(lambda (,',tmp1 ,state ,input ,unput)
143 rtoy 1.2.4.3.2.1 (declare (type simple-vector ,',tmp1)
144 rtoy 1.2.4.1 (ignorable ,state ,input ,unput)
145     (optimize (ext:inhibit-warnings 3)))
146 rtoy 1.2.4.3.2.1 (let (,@',slotb
147     (,input `(the (or (unsigned-byte 8) null) ,,input))
148 rtoy 1.2.4.1 ,@(loop for var in vars collect `(,var (gensym))))
149     ,body)))
150     (code-to-octets ((code state output &rest vars) body)
151     `(lambda (,',tmp1 ,',tmp2 ,state ,output)
152 rtoy 1.2.4.3.2.1 (declare (type simple-vector ,',tmp1)
153 rtoy 1.1 (ignorable ,state ,output)
154 rtoy 1.2.4.1 (optimize (ext:inhibit-warnings 3)))
155 rtoy 1.2.4.3.2.1 (let (,@',slotb
156     (,code ',code)
157 rtoy 1.2.4.1 ,@(loop for var in vars collect `(,var (gensym))))
158     `(let ((,',code (the (unsigned-byte 31) ,,',tmp2)))
159     (declare (ignorable ,',code))
160     ,,body)))))
161 rtoy 1.2.4.3.2.1 (%intern-ef (make-external-format ,name
162     ,(if base
163     `(ef-efx (find-external-format ,(ef-name base)))
164     `(make-efx :octets-to-code ,octets-to-code
165     :code-to-octets ,code-to-octets
166     :cache (make-array +ef-max+
167     :initial-element nil)
168     :min ,(min min max) :max ,(max min max)))
169     nil
170     (vector ,@(mapcar #'third slotd))
171     ',slotd)))))
172 rtoy 1.2.4.1
173 rtoy 1.2.4.3.2.1 ;;; 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 rtoy 1.2.4.1 `(macrolet ((input ((state input unput &rest vars) body)
187     `(lambda (,',tmp1 ,state ,input ,unput)
188     (declare (ignore ,',tmp1)
189     (ignorable ,state ,input ,unput)
190     (optimize (ext:inhibit-warnings 3)))
191     (let ((,input `(the (values (or (unsigned-byte 31) null)
192 rtoy 1.2.4.3.2.1 kernel:index)
193 rtoy 1.2.4.1 ,,input))
194     ,@(loop for var in vars collect `(,var (gensym))))
195     ,body)))
196     (output ((code state output &rest vars) body)
197     `(lambda (,',tmp1 ,',tmp2 ,state ,output)
198     (declare (ignore ,',tmp1)
199     (ignorable ,state ,output)
200     (optimize (ext:inhibit-warnings 3)))
201     (let ((,code ',code)
202     ,@(loop for var in vars collect `(,var (gensym))))
203     `(let ((,',code (the (unsigned-byte 31) ,,',tmp2)))
204     (declare (ignorable ,',code))
205     ,,body)))))
206 rtoy 1.2.4.3.2.1 (%intern-ef (make-external-format ,name
207     (make-efx :octets-to-code ,input
208     :code-to-octets ,output
209     :min ,(min min max) :max ,(max min max))
210     t
211     #() '())))))
212 rtoy 1.1
213     (defun load-external-format-aliases ()
214 rtoy 1.2.4.3.2.1 (let ((*package* (find-package "KEYWORD"))
215     (unix::*filename-encoding* :iso8859-1))
216 rtoy 1.2.4.2 (with-open-file (stm "ext-formats:aliases" :if-does-not-exist nil)
217 rtoy 1.1 (when stm
218 rtoy 1.2.4.3.2.1 (do ((alias (read stm nil stm) (read stm nil stm))
219     (value (read stm nil stm) (read stm nil stm)))
220     ((or (eq alias stm) (eq value stm))
221     (unless (eq alias stm)
222     (warn "External-format aliases file ends early.")))
223     (if (and (keywordp alias) (keywordp value))
224     (setf (gethash alias *external-format-aliases*) value)
225     (warn "Bad entry in external-format aliases file: ~S => ~S."
226     alias value)))))))
227 rtoy 1.1
228 rtoy 1.2.4.1 (defun %find-external-format (name)
229 rtoy 1.2.4.3.2.1 (when (ext:search-list-defined-p "ext-formats:")
230     (when (zerop (hash-table-count *external-format-aliases*))
231     (setf (gethash :latin1 *external-format-aliases*) :iso8859-1)
232     (setf (gethash :latin-1 *external-format-aliases*) :iso8859-1)
233     (setf (gethash :iso-8859-1 *external-format-aliases*) :iso8859-1)
234     (load-external-format-aliases)))
235 rtoy 1.1
236     (do ((tmp (gethash name *external-format-aliases*)
237     (gethash tmp *external-format-aliases*))
238     (cnt 0 (1+ cnt)))
239     ((or (null tmp) (= cnt 50))
240     (unless (null tmp)
241     (error "External-format aliasing depth exceeded.")))
242     (setq name tmp))
243    
244     (or (gethash name *external-formats*)
245 rtoy 1.2 (and (let ((*package* (find-package "STREAM"))
246 rtoy 1.2.4.3.2.1 (lisp::*enable-package-locked-errors* nil)
247     (*default-external-format* :iso8859-1)
248     (unix::*filename-encoding* :iso8859-1))
249 rtoy 1.2.4.2 (load (format nil "ext-formats:~(~A~)" name)
250 rtoy 1.2 :if-does-not-exist nil))
251 rtoy 1.2.4.1 (gethash name *external-formats*))))
252    
253     (defun %composed-ef-name (a b)
254     (if (consp a) (append a (list b)) (list a b)))
255    
256 rtoy 1.2.4.3.2.1 (defun %compose-external-formats (a b)
257 rtoy 1.2.4.1 (when (ef-composingp a)
258     (error "~S is a Composing-External-Format." (ef-name a)))
259     (unless (ef-composingp b)
260     (error "~S is not a Composing-External-Format." (ef-name b)))
261 rtoy 1.2.4.3 (make-external-format
262     (%composed-ef-name (ef-name a) (ef-name b))
263     (make-efx
264     :octets-to-code (lambda (tmp state input unput)
265     (declare (ignore tmp))
266     (funcall (ef-octets-to-code b) (ef-slots b)
267     state
268     (funcall (ef-octets-to-code a) (ef-slots a)
269     state
270     input
271     unput)
272     unput))
273     :code-to-octets (lambda (tmp code state output)
274     (declare (ignore tmp))
275     (funcall (ef-code-to-octets b) (ef-slots b)
276     code
277     state
278     `(lambda (x)
279     ,(funcall (ef-code-to-octets a)
280     (ef-slots a)
281     'x state output))))
282 rtoy 1.2.4.3.2.1 :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 rtoy 1.2.4.3 nil #() '()))
286 rtoy 1.2.4.1
287     (defun find-external-format (name &optional (error-p t))
288     (when (external-format-p name)
289     (return-from find-external-format name))
290    
291     (or (if (consp name) (every #'keywordp name) (keywordp name))
292     (error "~S is not a valid external format name." name))
293 rtoy 1.1
294 rtoy 1.2.4.1 (when (eq name :default)
295     (setq name *default-external-format*))
296    
297     (when (and (consp name) (not (cdr name)))
298     (setq name (car name)))
299    
300     (if (consp name)
301     (let ((efs (mapcar #'%find-external-format name)))
302     (if (member nil efs)
303     (if error-p (error "External format ~S not found." name) nil)
304     (let ((name (reduce #'%composed-ef-name (mapcar #'ef-name efs))))
305     (or (gethash name *external-formats*)
306 rtoy 1.2.4.3.2.1 (%intern-ef (reduce #'%compose-external-formats efs))))))
307 rtoy 1.2.4.1 (or (%find-external-format name)
308     (if error-p (error "External format ~S not found." name) nil))))
309 rtoy 1.1
310 rtoy 1.2.4.3.2.1 (defun flush-external-formats ()
311     (maphash (lambda (name ef)
312     (declare (ignore name))
313     (fill (ef-cache ef) nil))
314     *external-formats*))
315    
316 rtoy 1.1 (define-condition void-external-format (error)
317     ()
318     (:report
319     (lambda (condition stream)
320     (declare (ignore condition))
321     (format stream "Attempting I/O through void external-format."))))
322    
323 rtoy 1.2.4.3.2.1 (define-external-format :void (:size 0) ()
324 rtoy 1.1 (octets-to-code (state input unput)
325 rtoy 1.2.4.1 `(error 'void-external-format))
326 rtoy 1.1 (code-to-octets (code state output)
327 rtoy 1.2.4.1 `(error 'void-external-format)))
328 rtoy 1.1
329 rtoy 1.2.4.3.2.1 (define-external-format :iso8859-1 (:size 1) ()
330 rtoy 1.1 (octets-to-code (state input unput)
331 rtoy 1.2.4.1 `(values ,input 1))
332 rtoy 1.1 (code-to-octets (code state output)
333 rtoy 1.2.4.1 `(,output (if (> ,code 255) #x3F ,code))))
334 rtoy 1.1
335 rtoy 1.2.4.3.2.1 ;;; 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 rtoy 1.1 (defmacro octets-to-codepoint (external-format state count input unput)
343 rtoy 1.2.4.1 (let ((tmp1 (gensym)) (tmp2 (gensym)))
344 rtoy 1.2.4.3 `(let ((body (funcall (ef-octets-to-code ,external-format)
345     (ef-slots ,external-format)
346 rtoy 1.2.4.1 ',state ',input ',unput)))
347     `(multiple-value-bind (,',tmp1 ,',tmp2) ,body
348 rtoy 1.2.4.3.2.1 (setf ,',count (the kernel:index ,',tmp2))
349 rtoy 1.2.4.1 (the (or (unsigned-byte 31) null) ,',tmp1)))))
350 rtoy 1.1
351     (defmacro codepoint-to-octets (external-format code state output)
352 rtoy 1.2.4.3 `(funcall (ef-code-to-octets ,external-format) (ef-slots ,external-format)
353 rtoy 1.2.4.1 ',code ',state ',output))
354    
355    
356    
357     (defvar *ef-base* +ef-max+)
358     (defvar *ef-extensions* '())
359    
360     (defun ensure-cache (ef id reqd)
361     (let ((base (or (getf *ef-extensions* id)
362     (setf (getf *ef-extensions* id)
363     (prog1 *ef-base* (incf *ef-base* reqd))))))
364     (when (< (length (ef-cache ef)) (+ base reqd))
365 rtoy 1.2.4.3 (setf (efx-cache (ef-efx ef))
366 rtoy 1.2.4.1 (adjust-array (ef-cache ef) (+ base reqd) :initial-element nil)))
367     base))
368    
369 rtoy 1.2.4.3.2.1 ;;; DEF-EF-MACRO -- Public
370     ;;;
371     ;;;
372 rtoy 1.2.4.1 (defmacro def-ef-macro (name (ef id reqd idx) body)
373     (let ((tmp (gensym)))
374     `(defun ,name (,ef)
375     (let ((,tmp ,(if (eq id 'lisp::lisp)
376     idx
377     `(+ (ensure-cache ,ef ',id ,reqd) ,idx))))
378     (or (aref (ef-cache ,ef) ,tmp)
379     (setf (aref (ef-cache ,ef) ,tmp)
380     (let ((*compile-print* nil)) (compile nil ,body))))))))
381 rtoy 1.1
382    
383    
384 rtoy 1.2.4.3.2.1 ;;; OCTETS-TO-CHAR, CHAR-TO-OCTETS -- Public
385     ;;;
386     ;;; Read and write one character through an external-format
387     ;;;
388 rtoy 1.1 (defmacro octets-to-char (external-format state count input unput)
389 rtoy 1.2.4.1 `(let ((body (octets-to-codepoint ,external-format
390 rtoy 1.1 ,state ,count ,input ,unput)))
391 rtoy 1.2.4.1 `(let ((code ,body))
392     (declare (type (unsigned-byte 31) code))
393 rtoy 1.2.4.3.2.1 (if (< code char-code-limit) (code-char code)
394 rtoy 1.2.4.3.2.2 #-unicode #\?
395     #+unicode (code-char #xFFFD))))
396 rtoy 1.1
397     (defmacro char-to-octets (external-format char state output)
398     `(codepoint-to-octets ,external-format (char-code ,char) ,state ,output))
399    
400 rtoy 1.2.4.3.2.1
401 rtoy 1.2.4.1 (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))
403     (declare #|(optimize (speed 3) (safety 0) (space 0) (debug 0))|#
404     (type simple-string string)
405 rtoy 1.2.4.3.2.1 (type kernel:index start end ptr)
406 rtoy 1.2.4.1 (type (simple-array (unsigned-byte 8) (*)) buffer)
407     (ignorable state))
408     (dotimes (i (- end start) (values buffer ptr))
409 rtoy 1.2.4.3.2.1 (declare (type kernel:index i))
410 rtoy 1.2.4.1 ,(char-to-octets extfmt (schar string (+ start i)) state
411     (lambda (b)
412     (when (= ptr (length buffer))
413     (setq buffer (adjust-array buffer (* 2 ptr))))
414     (setf (aref buffer (1- (incf ptr))) b))))))
415    
416 rtoy 1.2 (defun string-to-octets (string &key (start 0) end (external-format :default)
417     (buffer nil bufferp))
418 rtoy 1.1 (declare (type string string)
419 rtoy 1.2.4.3.2.1 (type kernel:index start)
420     (type (or kernel:index null) end)
421 rtoy 1.2.4.1 (type (or (simple-array (unsigned-byte 8) (*)) null) buffer))
422 rtoy 1.2.4.3.2.1 (let* ((buffer (or buffer (make-array (length string)
423 rtoy 1.2.4.1 :element-type '(unsigned-byte 8)))))
424 rtoy 1.2.4.3.2.1 (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 rtoy 1.2.4.1
430     (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))
432     (declare #|(optimize (speed 3) (safety 0) (space 0) (debug 0))|#
433     (type (simple-array (unsigned-byte 8) (*)) octets)
434 rtoy 1.2.4.3.2.1 (type kernel:index end count)
435 rtoy 1.2.4.1 (type (integer -1 (#.array-dimension-limit)) ptr pos)
436     (type simple-string string)
437     (ignorable state))
438     (loop until (>= ptr end)
439     do (when (= pos (length string))
440     (setq string (adjust-array string (* 2 pos))))
441     (setf (schar string (incf pos))
442     ,(octets-to-char extfmt state count
443     (aref octets (incf ptr)) ;;@@ EOF??
444     (lambda (n) (decf ptr n))))
445 rtoy 1.2.4.3 finally (return (values string (1+ pos))))))
446 rtoy 1.1
447 rtoy 1.2 (defun octets-to-string (octets &key (start 0) end (external-format :default)
448     (string nil stringp))
449 rtoy 1.1 (declare (type (simple-array (unsigned-byte 8) (*)) octets)
450 rtoy 1.2.4.3.2.1 (type kernel:index start)
451     (type (or kernel:index null) end)
452 rtoy 1.2.4.1 (type (or simple-string null) string))
453     (multiple-value-bind (string pos)
454     (funcall (ef-octets-to-string (find-external-format external-format))
455     octets (1- start) (1- (or end (length octets)))
456     (or string (make-string (length octets))))
457 rtoy 1.2 (values (if stringp string (lisp::shrink-vector string pos)) pos)))
458 rtoy 1.1
459    
460    
461 rtoy 1.2.4.1 (def-ef-macro ef-encode (extfmt lisp::lisp +ef-max+ +ef-en+)
462     `(lambda (string start end result &aux (ptr 0) (state nil))
463     (declare #|(optimize (speed 3) (safety 0) (space 0) (debug 0))|#
464     (type simple-string string)
465 rtoy 1.2.4.3.2.1 (type kernel:index start end ptr)
466 rtoy 1.2.4.1 (type simple-base-string result)
467     (ignorable state))
468     (dotimes (i (- end start) (values result ptr))
469 rtoy 1.2.4.3.2.1 (declare (type kernel:index i))
470 rtoy 1.2.4.1 ,(char-to-octets extfmt (schar string (+ start i)) state
471     (lambda (b)
472     (when (= ptr (length result))
473     (setq result (adjust-array result (* 2 ptr))))
474     (setf (aref result (1- (incf ptr)))
475     (code-char b)))))))
476    
477     (defun string-encode (string external-format &optional (start 0) end)
478     (multiple-value-bind (result ptr)
479     (lisp::with-array-data ((string string) (start start) (end end))
480     (funcall (ef-encode (find-external-format external-format))
481     string start end
482     (make-string (length string) :element-type 'base-char)))
483     (lisp::shrink-vector result ptr)))
484    
485     (def-ef-macro ef-decode (extfmt lisp::lisp +ef-max+ +ef-de+)
486     `(lambda (string ptr end result &aux (pos -1) (count 0) (state nil))
487     (declare #|(optimize (speed 3) (safety 0) (space 0) (debug 0))|#
488     (type simple-string string)
489 rtoy 1.2.4.3.2.1 (type kernel:index end count)
490 rtoy 1.2.4.1 (type (integer -1 (#.array-dimension-limit)) ptr pos)
491     (type simple-string result)
492     (ignorable state))
493     (loop until (>= ptr end)
494     ;; increasing size of result shouldn't ever be necessary, unless
495     ;; someone implements an encoding smaller than the source string...
496     do (setf (schar result (incf pos))
497     ,(octets-to-char extfmt state count
498     ;; note the need to return NIL for EOF
499     (if (= (1+ ptr) (length string))
500     nil
501     (char-code (char string (incf ptr))))
502     (lambda (n) (decf ptr n))))
503 rtoy 1.2.4.3 finally (return (values result (1+ pos))))))
504 rtoy 1.2.4.1
505     (defun string-decode (string external-format &optional (start 0) end)
506     (multiple-value-bind (result pos)
507     (lisp::with-array-data ((string string) (start start) (end end))
508     (funcall (ef-decode (find-external-format external-format))
509     string (1- start) (1- end) (make-string (length string))))
510 rtoy 1.2.4.3 (lisp::shrink-vector result pos)))

  ViewVC Help
Powered by ViewVC 1.1.5