/[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.2 - (hide annotations)
Thu Jun 19 21:08:17 2008 UTC (5 years, 9 months ago) by rtoy
Branch: unicode-utf16-branch
Changes since 1.2.4.1: +3 -7 lines
Merge changes from HEAD for the ext-formats search-list change.
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.2 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/extfmts.lisp,v 1.2.4.2 2008/06/19 21:08:17 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.1 (defconstant +ef-os+ 2)
25     (defconstant +ef-so+ 3)
26     (defconstant +ef-en+ 4)
27     (defconstant +ef-de+ 5)
28     (defconstant +ef-max+ 6)
29    
30 rtoy 1.1 (define-condition external-format-not-implemented (error)
31     ()
32     (:report
33     (lambda (condition stream)
34     (declare (ignore condition))
35     (format stream "Attempting unimplemented external-format I/O."))))
36    
37     (defun %efni (a b c d)
38     (declare (ignore a b c d))
39     (error 'external-format-not-implemented))
40    
41     (defstruct (external-format
42     (:conc-name ef-)
43     (:print-function %print-external-format)
44 rtoy 1.2.4.1 (:constructor make-external-format (name composingp
45 rtoy 1.1 &optional slots slotd
46     octets-to-code
47     code-to-octets)))
48 rtoy 1.2.4.1 (name (ext:required-argument) :type (or keyword cons) :read-only t)
49     (composingp (ext:required-argument) :type boolean :read-only t)
50 rtoy 1.1 (slots #() :type simple-vector :read-only t)
51     (slotd nil :type list :read-only t)
52     (octets-to-code #'%efni :type function :read-only t)
53 rtoy 1.2.4.1 (code-to-octets #'%efni :type function :read-only t)
54     (cache (make-array +ef-max+ :initial-element nil)))
55 rtoy 1.1
56     (defun %print-external-format (ef stream depth)
57     (declare (ignore depth))
58     (print-unreadable-object (ef stream :type t :identity t)
59     (princ (ef-name ef) stream)))
60    
61 rtoy 1.2.4.1 (defun %whatsit (ef)
62     (setf (gethash (ef-name ef) *external-formats*) ef))
63    
64 rtoy 1.1 (defmacro define-external-format (name octets-to-code code-to-octets)
65 rtoy 1.2.4.1 (let ((tmp1 (gensym)) (tmp2 (gensym)))
66     `(macrolet ((octets-to-code ((state input unput &rest vars) body)
67     `(lambda (,',tmp1 ,state ,input ,unput)
68     (declare (ignore ,',tmp1)
69     (ignorable ,state ,input ,unput)
70     (optimize (ext:inhibit-warnings 3)))
71     (let ((,input `(the (or (unsigned-byte 8) null) ,,input))
72     ,@(loop for var in vars collect `(,var (gensym))))
73     ,body)))
74     (code-to-octets ((code state output &rest vars) body)
75     `(lambda (,',tmp1 ,',tmp2 ,state ,output)
76     (declare (ignore ,',tmp1)
77 rtoy 1.1 (ignorable ,state ,output)
78 rtoy 1.2.4.1 (optimize (ext:inhibit-warnings 3)))
79     (let ((,code ',code)
80     ,@(loop for var in vars collect `(,var (gensym))))
81     `(let ((,',code (the (unsigned-byte 31) ,,',tmp2)))
82     (declare (ignorable ,',code))
83     ,,body)))))
84     (%whatsit (make-external-format ,name nil #() '()
85     ,octets-to-code ,code-to-octets)))))
86    
87     (defmacro define-composing-external-format (name input output)
88     (let ((tmp1 (gensym)) (tmp2 (gensym)))
89     `(macrolet ((input ((state input unput &rest vars) body)
90     `(lambda (,',tmp1 ,state ,input ,unput)
91     (declare (ignore ,',tmp1)
92     (ignorable ,state ,input ,unput)
93     (optimize (ext:inhibit-warnings 3)))
94     (let ((,input `(the (values (or (unsigned-byte 31) null)
95     lisp::index)
96     ,,input))
97     ,@(loop for var in vars collect `(,var (gensym))))
98     ,body)))
99     (output ((code state output &rest vars) body)
100     `(lambda (,',tmp1 ,',tmp2 ,state ,output)
101     (declare (ignore ,',tmp1)
102     (ignorable ,state ,output)
103     (optimize (ext:inhibit-warnings 3)))
104     (let ((,code ',code)
105     ,@(loop for var in vars collect `(,var (gensym))))
106     `(let ((,',code (the (unsigned-byte 31) ,,',tmp2)))
107     (declare (ignorable ,',code))
108     ,,body)))))
109     (%whatsit (make-external-format ,name t #() '()
110     ,input ,output)))))
111 rtoy 1.1
112     (defun load-external-format-aliases ()
113     (let ((*package* (find-package "KEYWORD")))
114 rtoy 1.2.4.2 (with-open-file (stm "ext-formats:aliases" :if-does-not-exist nil)
115 rtoy 1.1 (when stm
116     (do ((alias (read stm nil stm) (read stm nil stm))
117     (value (read stm nil stm) (read stm nil stm)))
118     ((or (eq alias stm) (eq value stm))
119     (unless (eq alias stm)
120     (warn "External-format aliases file ends early.")))
121     (if (and (keywordp alias) (keywordp value))
122     (setf (gethash alias *external-format-aliases*) value)
123     (warn "Bad entry in external-format aliases file: ~S => ~S."
124     alias value)))))))
125    
126 rtoy 1.2.4.1 (defun %find-external-format (name)
127 rtoy 1.1 (when (zerop (hash-table-count *external-format-aliases*))
128     (setf (gethash :latin1 *external-format-aliases*) :iso8859-1)
129     (setf (gethash :latin-1 *external-format-aliases*) :iso8859-1)
130     (setf (gethash :iso-8859-1 *external-format-aliases*) :iso8859-1)
131     (load-external-format-aliases))
132    
133     (do ((tmp (gethash name *external-format-aliases*)
134     (gethash tmp *external-format-aliases*))
135     (cnt 0 (1+ cnt)))
136     ((or (null tmp) (= cnt 50))
137     (unless (null tmp)
138     (error "External-format aliasing depth exceeded.")))
139     (setq name tmp))
140    
141     (or (gethash name *external-formats*)
142 rtoy 1.2 (and (let ((*package* (find-package "STREAM"))
143     (lisp::*enable-package-locked-errors* nil))
144 rtoy 1.2.4.2 (load (format nil "ext-formats:~(~A~)" name)
145 rtoy 1.2 :if-does-not-exist nil))
146 rtoy 1.2.4.1 (gethash name *external-formats*))))
147    
148     (defun %composed-ef-name (a b)
149     (if (consp a) (append a (list b)) (list a b)))
150    
151     (defun %compose-external-formats (a b &optional name)
152     (when (ef-composingp a)
153     (error "~S is a Composing-External-Format." (ef-name a)))
154     (unless (ef-composingp b)
155     (error "~S is not a Composing-External-Format." (ef-name b)))
156     (make-external-format (or name (%composed-ef-name (ef-name a) (ef-name b)))
157     nil #() '()
158     (lambda (tmp state input unput)
159     (declare (ignore tmp))
160     (funcall (ef-octets-to-code b) b
161     state
162     (funcall (ef-octets-to-code a) a
163     state
164     input
165     unput)
166     unput))
167     (lambda (tmp code state output)
168     (declare (ignore tmp))
169     (funcall (ef-code-to-octets b) b
170     code
171     state
172     `(lambda (x)
173     ,(funcall (ef-code-to-octets a) a
174     'x state output))))))
175    
176     (defun find-external-format (name &optional (error-p t))
177     (when (external-format-p name)
178     (return-from find-external-format name))
179    
180     (or (if (consp name) (every #'keywordp name) (keywordp name))
181     (error "~S is not a valid external format name." name))
182 rtoy 1.1
183 rtoy 1.2.4.1 (when (eq name :default)
184     (setq name *default-external-format*))
185    
186     (when (and (consp name) (not (cdr name)))
187     (setq name (car name)))
188    
189     (if (consp name)
190     (let ((efs (mapcar #'%find-external-format name)))
191     (if (member nil efs)
192     (if error-p (error "External format ~S not found." name) nil)
193     (let ((name (reduce #'%composed-ef-name (mapcar #'ef-name efs))))
194     (or (gethash name *external-formats*)
195     (%whatsit (reduce #'%compose-external-formats efs))))))
196     (or (%find-external-format name)
197     (if error-p (error "External format ~S not found." name) nil))))
198 rtoy 1.1
199     (define-condition void-external-format (error)
200     ()
201     (:report
202     (lambda (condition stream)
203     (declare (ignore condition))
204     (format stream "Attempting I/O through void external-format."))))
205    
206     (define-external-format :void
207     (octets-to-code (state input unput)
208 rtoy 1.2.4.1 `(error 'void-external-format))
209 rtoy 1.1 (code-to-octets (code state output)
210 rtoy 1.2.4.1 `(error 'void-external-format)))
211 rtoy 1.1
212     (define-external-format :iso8859-1
213     (octets-to-code (state input unput)
214 rtoy 1.2.4.1 `(values ,input 1))
215 rtoy 1.1 (code-to-octets (code state output)
216 rtoy 1.2.4.1 `(,output (if (> ,code 255) #x3F ,code))))
217 rtoy 1.1
218     (defmacro octets-to-codepoint (external-format state count input unput)
219 rtoy 1.2.4.1 (let ((tmp1 (gensym)) (tmp2 (gensym)))
220     `(let ((body (funcall (ef-octets-to-code ,external-format) ,external-format
221     ',state ',input ',unput)))
222     `(multiple-value-bind (,',tmp1 ,',tmp2) ,body
223     (setf ,',count (the lisp::index ,',tmp2))
224     (the (or (unsigned-byte 31) null) ,',tmp1)))))
225 rtoy 1.1
226     (defmacro codepoint-to-octets (external-format code state output)
227 rtoy 1.2.4.1 `(funcall (ef-code-to-octets ,external-format) ,external-format
228     ',code ',state ',output))
229    
230    
231    
232     (defvar *ef-base* +ef-max+)
233     (defvar *ef-extensions* '())
234    
235     (defun ensure-cache (ef id reqd)
236     (let ((base (or (getf *ef-extensions* id)
237     (setf (getf *ef-extensions* id)
238     (prog1 *ef-base* (incf *ef-base* reqd))))))
239     (when (< (length (ef-cache ef)) (+ base reqd))
240     (setf (ef-cache ef)
241     (adjust-array (ef-cache ef) (+ base reqd) :initial-element nil)))
242     base))
243    
244     (defmacro def-ef-macro (name (ef id reqd idx) body)
245     (let ((tmp (gensym)))
246     `(defun ,name (,ef)
247     (let ((,tmp ,(if (eq id 'lisp::lisp)
248     idx
249     `(+ (ensure-cache ,ef ',id ,reqd) ,idx))))
250     (or (aref (ef-cache ,ef) ,tmp)
251     (setf (aref (ef-cache ,ef) ,tmp)
252     (let ((*compile-print* nil)) (compile nil ,body))))))))
253 rtoy 1.1
254    
255    
256     (defmacro octets-to-char (external-format state count input unput)
257 rtoy 1.2.4.1 `(let ((body (octets-to-codepoint ,external-format
258 rtoy 1.1 ,state ,count ,input ,unput)))
259 rtoy 1.2.4.1 `(let ((code ,body))
260     (declare (type (unsigned-byte 31) code))
261     (if (< code #x100) (code-char code) #\?))))
262 rtoy 1.1
263     (defmacro char-to-octets (external-format char state output)
264     `(codepoint-to-octets ,external-format (char-code ,char) ,state ,output))
265    
266 rtoy 1.2.4.1 (def-ef-macro ef-string-to-octets (extfmt lisp::lisp +ef-max+ +ef-so+)
267     `(lambda (string start end buffer &aux (ptr 0) (state nil))
268     (declare #|(optimize (speed 3) (safety 0) (space 0) (debug 0))|#
269     (type simple-string string)
270     (type lisp::index start end ptr)
271     (type (simple-array (unsigned-byte 8) (*)) buffer)
272     (ignorable state))
273     (dotimes (i (- end start) (values buffer ptr))
274     (declare (type lisp::index i))
275     ,(char-to-octets extfmt (schar string (+ start i)) state
276     (lambda (b)
277     (when (= ptr (length buffer))
278     (setq buffer (adjust-array buffer (* 2 ptr))))
279     (setf (aref buffer (1- (incf ptr))) b))))))
280    
281 rtoy 1.2 (defun string-to-octets (string &key (start 0) end (external-format :default)
282     (buffer nil bufferp))
283 rtoy 1.1 (declare (type string string)
284 rtoy 1.2.4.1 (type lisp::index start)
285     (type (or lisp::index null) end)
286     (type (or (simple-array (unsigned-byte 8) (*)) null) buffer))
287     (multiple-value-bind (buffer ptr)
288     (lisp::with-array-data ((string string) (start start) (end end))
289     (funcall (ef-string-to-octets (find-external-format external-format))
290     string start end
291     (or buffer (make-array (length string)
292     :element-type '(unsigned-byte 8)))))
293     (values (if bufferp buffer (lisp::shrink-vector buffer ptr)) ptr)))
294    
295     (def-ef-macro ef-octets-to-string (extfmt lisp::lisp +ef-max+ +ef-os+)
296     `(lambda (octets ptr end string &aux (pos -1) (count 0) (state nil))
297     (declare #|(optimize (speed 3) (safety 0) (space 0) (debug 0))|#
298     (type (simple-array (unsigned-byte 8) (*)) octets)
299     (type lisp::index end count)
300     (type (integer -1 (#.array-dimension-limit)) ptr pos)
301     (type simple-string string)
302     (ignorable state))
303     (loop until (>= ptr end)
304     do (when (= pos (length string))
305     (setq string (adjust-array string (* 2 pos))))
306     (setf (schar string (incf pos))
307     ,(octets-to-char extfmt state count
308     (aref octets (incf ptr)) ;;@@ EOF??
309     (lambda (n) (decf ptr n))))
310     finally (return (values string pos)))))
311 rtoy 1.1
312 rtoy 1.2 (defun octets-to-string (octets &key (start 0) end (external-format :default)
313     (string nil stringp))
314 rtoy 1.1 (declare (type (simple-array (unsigned-byte 8) (*)) octets)
315 rtoy 1.2.4.1 (type lisp::index start)
316     (type (or lisp::index null) end)
317     (type (or simple-string null) string))
318     (multiple-value-bind (string pos)
319     (funcall (ef-octets-to-string (find-external-format external-format))
320     octets (1- start) (1- (or end (length octets)))
321     (or string (make-string (length octets))))
322 rtoy 1.2 (values (if stringp string (lisp::shrink-vector string pos)) pos)))
323 rtoy 1.1
324    
325    
326 rtoy 1.2.4.1 (def-ef-macro ef-encode (extfmt lisp::lisp +ef-max+ +ef-en+)
327     `(lambda (string start end result &aux (ptr 0) (state nil))
328     (declare #|(optimize (speed 3) (safety 0) (space 0) (debug 0))|#
329     (type simple-string string)
330     (type lisp::index start end ptr)
331     (type simple-base-string result)
332     (ignorable state))
333     (dotimes (i (- end start) (values result ptr))
334     (declare (type lisp::index i))
335     ,(char-to-octets extfmt (schar string (+ start i)) state
336     (lambda (b)
337     (when (= ptr (length result))
338     (setq result (adjust-array result (* 2 ptr))))
339     (setf (aref result (1- (incf ptr)))
340     (code-char b)))))))
341    
342     (defun string-encode (string external-format &optional (start 0) end)
343     (multiple-value-bind (result ptr)
344     (lisp::with-array-data ((string string) (start start) (end end))
345     (funcall (ef-encode (find-external-format external-format))
346     string start end
347     (make-string (length string) :element-type 'base-char)))
348     (lisp::shrink-vector result ptr)))
349    
350     (def-ef-macro ef-decode (extfmt lisp::lisp +ef-max+ +ef-de+)
351     `(lambda (string ptr end result &aux (pos -1) (count 0) (state nil))
352     (declare #|(optimize (speed 3) (safety 0) (space 0) (debug 0))|#
353     (type simple-string string)
354     (type lisp::index end count)
355     (type (integer -1 (#.array-dimension-limit)) ptr pos)
356     (type simple-string result)
357     (ignorable state))
358     (loop until (>= ptr end)
359     ;; increasing size of result shouldn't ever be necessary, unless
360     ;; someone implements an encoding smaller than the source string...
361     do (setf (schar result (incf pos))
362     ,(octets-to-char extfmt state count
363     ;; note the need to return NIL for EOF
364     (if (= (1+ ptr) (length string))
365     nil
366     (char-code (char string (incf ptr))))
367     (lambda (n) (decf ptr n))))
368     finally (return (values result pos)))))
369    
370     (defun string-decode (string external-format &optional (start 0) end)
371     (multiple-value-bind (result pos)
372     (lisp::with-array-data ((string string) (start start) (end end))
373     (funcall (ef-decode (find-external-format external-format))
374     string (1- start) (1- end) (make-string (length string))))
375 rtoy 1.1 (lisp::shrink-vector result (1+ pos))))

  ViewVC Help
Powered by ViewVC 1.1.5