/[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.7 - (hide annotations)
Wed Jul 9 15:52:12 2008 UTC (5 years, 9 months ago) by rtoy
Branch: unicode-utf16-extfmt-branch
Changes since 1.2.4.3.2.6: +8 -4 lines
code/extfmts.lisp:
o Bind *DEFAULT-EXTERNAL-FORMAT* to :iso8859-1 when compiling the
  new external format code.  Then messages from the compiler at least
  have a chance of getting printed.
o Removed *compile-verbose*, *compile-progress*, and *gc-verbose*,
  since the compiler messages are working now.  (Should we leave them
  in?)

pcl/simple-streams/external-formats/utf-8.lisp
o Revert back to previous version, without LOCALLY.
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.7 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/extfmts.lisp,v 1.2.4.3.2.7 2008/07/09 15:52:12 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.5 ;; avoid loading files, etc., early in the boot sequence
230     (when (or (eq name :iso8859-1)
231     (and (eq name :default) (eq *default-external-format* :iso8859-1)))
232     (return-from %find-external-format
233     (gethash :iso8859-1 *external-formats*)))
234    
235     (when (zerop (hash-table-count *external-format-aliases*))
236     (setf (gethash :latin1 *external-format-aliases*) :iso8859-1)
237     (setf (gethash :latin-1 *external-format-aliases*) :iso8859-1)
238     (setf (gethash :iso-8859-1 *external-format-aliases*) :iso8859-1)
239     (load-external-format-aliases))
240 rtoy 1.1
241     (do ((tmp (gethash name *external-format-aliases*)
242     (gethash tmp *external-format-aliases*))
243     (cnt 0 (1+ cnt)))
244     ((or (null tmp) (= cnt 50))
245     (unless (null tmp)
246     (error "External-format aliasing depth exceeded.")))
247     (setq name tmp))
248    
249     (or (gethash name *external-formats*)
250 rtoy 1.2 (and (let ((*package* (find-package "STREAM"))
251 rtoy 1.2.4.3.2.1 (lisp::*enable-package-locked-errors* nil)
252     (*default-external-format* :iso8859-1)
253     (unix::*filename-encoding* :iso8859-1))
254 rtoy 1.2.4.2 (load (format nil "ext-formats:~(~A~)" name)
255 rtoy 1.2 :if-does-not-exist nil))
256 rtoy 1.2.4.1 (gethash name *external-formats*))))
257    
258     (defun %composed-ef-name (a b)
259     (if (consp a) (append a (list b)) (list a b)))
260    
261 rtoy 1.2.4.3.2.1 (defun %compose-external-formats (a b)
262 rtoy 1.2.4.1 (when (ef-composingp a)
263     (error "~S is a Composing-External-Format." (ef-name a)))
264     (unless (ef-composingp b)
265     (error "~S is not a Composing-External-Format." (ef-name b)))
266 rtoy 1.2.4.3 (make-external-format
267     (%composed-ef-name (ef-name a) (ef-name b))
268     (make-efx
269     :octets-to-code (lambda (tmp state input unput)
270     (declare (ignore tmp))
271     (funcall (ef-octets-to-code b) (ef-slots b)
272     state
273     (funcall (ef-octets-to-code a) (ef-slots a)
274     state
275     input
276     unput)
277     unput))
278     :code-to-octets (lambda (tmp code state output)
279     (declare (ignore tmp))
280     (funcall (ef-code-to-octets b) (ef-slots b)
281     code
282     state
283     `(lambda (x)
284     ,(funcall (ef-code-to-octets a)
285     (ef-slots a)
286     'x state output))))
287 rtoy 1.2.4.3.2.1 :cache (make-array +ef-max+ :initial-element nil)
288     :min (* (ef-min-octets a) (ef-min-octets b))
289     :max (* (ef-max-octets a) (ef-max-octets b)))
290 rtoy 1.2.4.3 nil #() '()))
291 rtoy 1.2.4.1
292     (defun find-external-format (name &optional (error-p t))
293     (when (external-format-p name)
294     (return-from find-external-format name))
295    
296     (or (if (consp name) (every #'keywordp name) (keywordp name))
297     (error "~S is not a valid external format name." name))
298 rtoy 1.1
299 rtoy 1.2.4.1 (when (eq name :default)
300     (setq name *default-external-format*))
301    
302     (when (and (consp name) (not (cdr name)))
303     (setq name (car name)))
304    
305 rtoy 1.2.4.3.2.5 (flet ((not-found ()
306     (when (equal *default-external-format* name)
307     (setq *default-external-format* :iso8859-1))
308     (if error-p (error "External format ~S not found." name) nil)))
309     (if (consp name)
310     (let ((efs (mapcar #'%find-external-format name)))
311     (if (member nil efs)
312     (not-found)
313     (let ((name (reduce #'%composed-ef-name (mapcar #'ef-name efs))))
314     (or (gethash name *external-formats*)
315     (%intern-ef (reduce #'%compose-external-formats efs))))))
316     (or (%find-external-format name) (not-found)))))
317 rtoy 1.1
318 rtoy 1.2.4.3.2.1 (defun flush-external-formats ()
319     (maphash (lambda (name ef)
320     (declare (ignore name))
321     (fill (ef-cache ef) nil))
322     *external-formats*))
323    
324 rtoy 1.2.4.3.2.5 (defvar *.table-inverse.* (make-hash-table :test 'eq :size 7))
325    
326     (defun invert-table (table)
327     (declare (type (or (simple-array (unsigned-byte 31) *)
328     (simple-array (unsigned-byte 16) *))
329     table)
330     (optimize (speed 3) (space 0) (safety 0) (debug 0)
331     (ext:inhibit-warnings 3)))
332     (or (gethash table *.table-inverse.*)
333     (let* ((result (make-hash-table))
334     (width (array-dimension table 0))
335     (power (1- (array-rank table)))
336     (base (if (= width 94) 1 0)))
337     (assert (and (< power 3) (<= width 256)))
338     (dotimes (i (array-total-size table))
339     (declare (type (integer 0 (#.array-dimension-limit)) i))
340     (let ((tmp i) (val (row-major-aref table i)) (z 0))
341     (declare (type (integer 0 (#.array-dimension-limit)) tmp)
342     (type (unsigned-byte 32) z))
343     (unless (or (= val #xFFFE) (gethash val result))
344     (dotimes (j power)
345     ;; j is only ever 0 in reality, since no n^3 tables are
346     ;; defined; z was declared as 32-bit above, so that limits
347     ;; us to 0 <= j <= 2 (see the ASSERT)
348     (declare (type (integer 0 2) j))
349     (multiple-value-bind (x y) (floor tmp width)
350     (setq tmp x)
351     (setq z (logior z (ash (the (integer 0 255) (+ y base))
352     (the (integer 0 24)
353     (* 8 (- power j))))))))
354     (setf (gethash val result) (logior z (+ tmp base))))))
355     (setf (gethash table *.table-inverse.*) result))))
356    
357    
358 rtoy 1.1 (define-condition void-external-format (error)
359     ()
360     (:report
361     (lambda (condition stream)
362     (declare (ignore condition))
363     (format stream "Attempting I/O through void external-format."))))
364    
365 rtoy 1.2.4.3.2.1 (define-external-format :void (:size 0) ()
366 rtoy 1.1 (octets-to-code (state input unput)
367 rtoy 1.2.4.1 `(error 'void-external-format))
368 rtoy 1.1 (code-to-octets (code state output)
369 rtoy 1.2.4.1 `(error 'void-external-format)))
370 rtoy 1.1
371 rtoy 1.2.4.3.2.1 (define-external-format :iso8859-1 (:size 1) ()
372 rtoy 1.1 (octets-to-code (state input unput)
373 rtoy 1.2.4.1 `(values ,input 1))
374 rtoy 1.1 (code-to-octets (code state output)
375 rtoy 1.2.4.1 `(,output (if (> ,code 255) #x3F ,code))))
376 rtoy 1.1
377 rtoy 1.2.4.3.2.1 ;;; OCTETS-TO-CODEPOINT, CODEPOINT-TO-OCTETS -- Semi-Public
378     ;;;
379     ;;; Normally you'd want to use OCTETS-TO-CHAR and CHAR-TO-OCTETS instead of
380     ;;; these, but that limits you to Lisp's idea of a character - either Latin-1
381     ;;; in 8 bit Lisp images, or the Unicode BMP in 16 bit images. If you want
382     ;;; to read or write texts containing characters not supported by your Lisp,
383     ;;; these macros can be used instead.
384 rtoy 1.1 (defmacro octets-to-codepoint (external-format state count input unput)
385 rtoy 1.2.4.1 (let ((tmp1 (gensym)) (tmp2 (gensym)))
386 rtoy 1.2.4.3 `(let ((body (funcall (ef-octets-to-code ,external-format)
387     (ef-slots ,external-format)
388 rtoy 1.2.4.1 ',state ',input ',unput)))
389     `(multiple-value-bind (,',tmp1 ,',tmp2) ,body
390 rtoy 1.2.4.3.2.1 (setf ,',count (the kernel:index ,',tmp2))
391 rtoy 1.2.4.1 (the (or (unsigned-byte 31) null) ,',tmp1)))))
392 rtoy 1.1
393     (defmacro codepoint-to-octets (external-format code state output)
394 rtoy 1.2.4.3 `(funcall (ef-code-to-octets ,external-format) (ef-slots ,external-format)
395 rtoy 1.2.4.1 ',code ',state ',output))
396    
397    
398    
399     (defvar *ef-base* +ef-max+)
400     (defvar *ef-extensions* '())
401    
402     (defun ensure-cache (ef id reqd)
403     (let ((base (or (getf *ef-extensions* id)
404     (setf (getf *ef-extensions* id)
405     (prog1 *ef-base* (incf *ef-base* reqd))))))
406     (when (< (length (ef-cache ef)) (+ base reqd))
407 rtoy 1.2.4.3 (setf (efx-cache (ef-efx ef))
408 rtoy 1.2.4.1 (adjust-array (ef-cache ef) (+ base reqd) :initial-element nil)))
409     base))
410    
411 rtoy 1.2.4.3.2.1 ;;; DEF-EF-MACRO -- Public
412     ;;;
413     ;;;
414 rtoy 1.2.4.1 (defmacro def-ef-macro (name (ef id reqd idx) body)
415     (let ((tmp (gensym)))
416     `(defun ,name (,ef)
417     (let ((,tmp ,(if (eq id 'lisp::lisp)
418     idx
419     `(+ (ensure-cache ,ef ',id ,reqd) ,idx))))
420     (or (aref (ef-cache ,ef) ,tmp)
421     (setf (aref (ef-cache ,ef) ,tmp)
422 rtoy 1.2.4.3.2.6 (let ((*compile-print* nil)
423 rtoy 1.2.4.3.2.7 ;; Set default format when we compile so we
424     ;; can see compiler messages. If we don't,
425     ;; we run into the problem that we might be
426     ;; changing the default format while we're
427     ;; compiling, and we don't know how to output
428     ;; the compiler messages.
429     (*default-external-format* :iso8859-1))
430 rtoy 1.2.4.3.2.6 (compile nil ,body))))))))
431 rtoy 1.1
432    
433    
434 rtoy 1.2.4.3.2.1 ;;; OCTETS-TO-CHAR, CHAR-TO-OCTETS -- Public
435     ;;;
436     ;;; Read and write one character through an external-format
437     ;;;
438 rtoy 1.1 (defmacro octets-to-char (external-format state count input unput)
439 rtoy 1.2.4.1 `(let ((body (octets-to-codepoint ,external-format
440 rtoy 1.1 ,state ,count ,input ,unput)))
441 rtoy 1.2.4.1 `(let ((code ,body))
442     (declare (type (unsigned-byte 31) code))
443 rtoy 1.2.4.3.2.1 (if (< code char-code-limit) (code-char code)
444 rtoy 1.2.4.3.2.4 #-(and unicode (not unicode-bootstrap)) #\?
445     #+(and unicode (not unicode-bootstrap)) #\U+FFFD))))
446 rtoy 1.1
447     (defmacro char-to-octets (external-format char state output)
448     `(codepoint-to-octets ,external-format (char-code ,char) ,state ,output))
449    
450 rtoy 1.2.4.3.2.1
451 rtoy 1.2.4.1 (def-ef-macro ef-string-to-octets (extfmt lisp::lisp +ef-max+ +ef-so+)
452     `(lambda (string start end buffer &aux (ptr 0) (state nil))
453     (declare #|(optimize (speed 3) (safety 0) (space 0) (debug 0))|#
454     (type simple-string string)
455 rtoy 1.2.4.3.2.1 (type kernel:index start end ptr)
456 rtoy 1.2.4.1 (type (simple-array (unsigned-byte 8) (*)) buffer)
457     (ignorable state))
458     (dotimes (i (- end start) (values buffer ptr))
459 rtoy 1.2.4.3.2.1 (declare (type kernel:index i))
460 rtoy 1.2.4.1 ,(char-to-octets extfmt (schar string (+ start i)) state
461     (lambda (b)
462     (when (= ptr (length buffer))
463     (setq buffer (adjust-array buffer (* 2 ptr))))
464     (setf (aref buffer (1- (incf ptr))) b))))))
465    
466 rtoy 1.2 (defun string-to-octets (string &key (start 0) end (external-format :default)
467     (buffer nil bufferp))
468 rtoy 1.1 (declare (type string string)
469 rtoy 1.2.4.3.2.1 (type kernel:index start)
470     (type (or kernel:index null) end)
471 rtoy 1.2.4.1 (type (or (simple-array (unsigned-byte 8) (*)) null) buffer))
472 rtoy 1.2.4.3.2.1 (let* ((buffer (or buffer (make-array (length string)
473 rtoy 1.2.4.1 :element-type '(unsigned-byte 8)))))
474 rtoy 1.2.4.3.2.1 (multiple-value-bind (buffer ptr)
475     (lisp::with-array-data ((string string) (start start) (end end))
476     (funcall (ef-string-to-octets (find-external-format external-format))
477     string start end buffer))
478     (values (if bufferp buffer (lisp::shrink-vector buffer ptr)) ptr))))
479 rtoy 1.2.4.1
480     (def-ef-macro ef-octets-to-string (extfmt lisp::lisp +ef-max+ +ef-os+)
481     `(lambda (octets ptr end string &aux (pos -1) (count 0) (state nil))
482     (declare #|(optimize (speed 3) (safety 0) (space 0) (debug 0))|#
483     (type (simple-array (unsigned-byte 8) (*)) octets)
484 rtoy 1.2.4.3.2.1 (type kernel:index end count)
485 rtoy 1.2.4.1 (type (integer -1 (#.array-dimension-limit)) ptr pos)
486     (type simple-string string)
487     (ignorable state))
488     (loop until (>= ptr end)
489     do (when (= pos (length string))
490     (setq string (adjust-array string (* 2 pos))))
491     (setf (schar string (incf pos))
492     ,(octets-to-char extfmt state count
493     (aref octets (incf ptr)) ;;@@ EOF??
494     (lambda (n) (decf ptr n))))
495 rtoy 1.2.4.3 finally (return (values string (1+ pos))))))
496 rtoy 1.1
497 rtoy 1.2 (defun octets-to-string (octets &key (start 0) end (external-format :default)
498     (string nil stringp))
499 rtoy 1.1 (declare (type (simple-array (unsigned-byte 8) (*)) octets)
500 rtoy 1.2.4.3.2.1 (type kernel:index start)
501     (type (or kernel:index null) end)
502 rtoy 1.2.4.1 (type (or simple-string null) string))
503     (multiple-value-bind (string pos)
504     (funcall (ef-octets-to-string (find-external-format external-format))
505     octets (1- start) (1- (or end (length octets)))
506     (or string (make-string (length octets))))
507 rtoy 1.2 (values (if stringp string (lisp::shrink-vector string pos)) pos)))
508 rtoy 1.1
509    
510    
511 rtoy 1.2.4.1 (def-ef-macro ef-encode (extfmt lisp::lisp +ef-max+ +ef-en+)
512     `(lambda (string start end result &aux (ptr 0) (state nil))
513     (declare #|(optimize (speed 3) (safety 0) (space 0) (debug 0))|#
514     (type simple-string string)
515 rtoy 1.2.4.3.2.1 (type kernel:index start end ptr)
516 rtoy 1.2.4.1 (type simple-base-string result)
517     (ignorable state))
518     (dotimes (i (- end start) (values result ptr))
519 rtoy 1.2.4.3.2.1 (declare (type kernel:index i))
520 rtoy 1.2.4.1 ,(char-to-octets extfmt (schar string (+ start i)) state
521     (lambda (b)
522     (when (= ptr (length result))
523     (setq result (adjust-array result (* 2 ptr))))
524     (setf (aref result (1- (incf ptr)))
525     (code-char b)))))))
526    
527     (defun string-encode (string external-format &optional (start 0) end)
528     (multiple-value-bind (result ptr)
529     (lisp::with-array-data ((string string) (start start) (end end))
530     (funcall (ef-encode (find-external-format external-format))
531     string start end
532     (make-string (length string) :element-type 'base-char)))
533     (lisp::shrink-vector result ptr)))
534    
535     (def-ef-macro ef-decode (extfmt lisp::lisp +ef-max+ +ef-de+)
536     `(lambda (string ptr end result &aux (pos -1) (count 0) (state nil))
537     (declare #|(optimize (speed 3) (safety 0) (space 0) (debug 0))|#
538     (type simple-string string)
539 rtoy 1.2.4.3.2.1 (type kernel:index end count)
540 rtoy 1.2.4.1 (type (integer -1 (#.array-dimension-limit)) ptr pos)
541     (type simple-string result)
542     (ignorable state))
543     (loop until (>= ptr end)
544     ;; increasing size of result shouldn't ever be necessary, unless
545     ;; someone implements an encoding smaller than the source string...
546     do (setf (schar result (incf pos))
547     ,(octets-to-char extfmt state count
548     ;; note the need to return NIL for EOF
549     (if (= (1+ ptr) (length string))
550     nil
551     (char-code (char string (incf ptr))))
552     (lambda (n) (decf ptr n))))
553 rtoy 1.2.4.3 finally (return (values result (1+ pos))))))
554 rtoy 1.2.4.1
555     (defun string-decode (string external-format &optional (start 0) end)
556     (multiple-value-bind (result pos)
557     (lisp::with-array-data ((string string) (start start) (end end))
558     (funcall (ef-decode (find-external-format external-format))
559     string (1- start) (1- end) (make-string (length string))))
560 rtoy 1.2.4.3 (lisp::shrink-vector result pos)))

  ViewVC Help
Powered by ViewVC 1.1.5