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

Contents of /src/code/extfmts.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.2 - (show annotations)
Wed Oct 31 14:37:38 2007 UTC (6 years, 5 months ago) by rtoy
Branch: MAIN
CVS Tags: snapshot-2008-05, snapshot-2008-06, snapshot-2008-01, snapshot-2008-02, snapshot-2008-03, release-19e, release-19d, snapshot-2008-04, release-19e-pre1, release-19e-pre2, unicode-utf16-string-support, release-19e-base, unicode-utf16-base, snapshot-2007-12, snapshot-2007-11
Branch point for: unicode-utf16-branch, release-19e-branch
Changes since 1.1: +23 -19 lines
Update from Paul Foley.

o Disable package errors when loading up external formats.
o A minor patch allowing string-to-octets and vice versa to write into
  a preallocated array (though they might still allocate a bigger one
  if necessary),
o Fix up any confusion between simple-base-string and simple-string so
  that nothing breaks when/if they're not the same.
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 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/extfmts.lisp,v 1.2 2007/10/31 14:37:38 rtoy Exp $")
9 ;;;
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 encode-string decode-string))
18
19 (defvar *default-external-format* :iso8859-1)
20
21 (defvar *external-formats* (make-hash-table))
22 (defvar *external-format-aliases* (make-hash-table))
23
24 (define-condition external-format-not-implemented (error)
25 ()
26 (:report
27 (lambda (condition stream)
28 (declare (ignore condition))
29 (format stream "Attempting unimplemented external-format I/O."))))
30
31 (defun %efni (a b c d)
32 (declare (ignore a b c d))
33 (error 'external-format-not-implemented))
34
35 (defstruct (external-format
36 (:conc-name ef-)
37 (:print-function %print-external-format)
38 (:constructor make-external-format (name
39 &optional slots slotd
40 octets-to-code
41 code-to-octets)))
42 (name (ext:required-argument) :type keyword :read-only t)
43 (slots #() :type simple-vector :read-only t)
44 (slotd nil :type list :read-only t)
45 (octets-to-code #'%efni :type function :read-only t)
46 (code-to-octets #'%efni :type function :read-only t))
47
48 (defun %print-external-format (ef stream depth)
49 (declare (ignore depth))
50 (print-unreadable-object (ef stream :type t :identity t)
51 (princ (ef-name ef) stream)))
52
53 (defmacro define-external-format (name octets-to-code code-to-octets)
54 (let ((tmp (gensym)))
55 `(macrolet ((octets-to-code ((state input unput) &body body)
56 `(lambda (,',tmp ,state ,input ,unput)
57 (declare (type (function () (unsigned-byte 8)) ,input)
58 (type (function (lisp::index) t) ,unput)
59 (ignore ,',tmp)
60 (ignorable ,state ,unput)
61 (values (unsigned-byte 31) lisp::index t))
62 ,@body))
63 (code-to-octets ((code state output) &body body)
64 `(lambda (,',tmp ,code ,state ,output)
65 (declare (type (unsigned-byte 31) ,code)
66 (type (function ((unsigned-byte 8)) t) ,output)
67 (ignore ,',tmp)
68 (ignorable ,state ,output)
69 (values t))
70 ,@body)))
71 (setf (gethash ,name *external-formats*)
72 (make-external-format ,name #() '()
73 ,octets-to-code ,code-to-octets)))))
74
75 (defun load-external-format-aliases ()
76 (let ((*package* (find-package "KEYWORD")))
77 (with-open-file (stm "library:ext-formats/aliases" :if-does-not-exist nil)
78 (when stm
79 (do ((alias (read stm nil stm) (read stm nil stm))
80 (value (read stm nil stm) (read stm nil stm)))
81 ((or (eq alias stm) (eq value stm))
82 (unless (eq alias stm)
83 (warn "External-format aliases file ends early.")))
84 (if (and (keywordp alias) (keywordp value))
85 (setf (gethash alias *external-format-aliases*) value)
86 (warn "Bad entry in external-format aliases file: ~S => ~S."
87 alias value)))))))
88
89 (defun find-external-format (name &optional (error-p t))
90 (when (external-format-p name)
91 (return-from find-external-format name))
92
93 (when (eq name :default)
94 (setq name *default-external-format*))
95
96 #+(or)
97 (unless (ext:search-list-defined-p "ef:")
98 (setf (ext:search-list "ef:") '("library:ef/")))
99
100 (when (zerop (hash-table-count *external-format-aliases*))
101 (setf (gethash :latin1 *external-format-aliases*) :iso8859-1)
102 (setf (gethash :latin-1 *external-format-aliases*) :iso8859-1)
103 (setf (gethash :iso-8859-1 *external-format-aliases*) :iso8859-1)
104 (load-external-format-aliases))
105
106 (do ((tmp (gethash name *external-format-aliases*)
107 (gethash tmp *external-format-aliases*))
108 (cnt 0 (1+ cnt)))
109 ((or (null tmp) (= cnt 50))
110 (unless (null tmp)
111 (error "External-format aliasing depth exceeded.")))
112 (setq name tmp))
113
114 (or (gethash name *external-formats*)
115 (and (let ((*package* (find-package "STREAM"))
116 (lisp::*enable-package-locked-errors* nil))
117 (load (format nil "library:ext-formats/~(~A~)" name)
118 :if-does-not-exist nil))
119 (gethash name *external-formats*))
120 (if error-p (error "External format ~S not found." name) nil)))
121
122
123 (define-condition void-external-format (error)
124 ()
125 (:report
126 (lambda (condition stream)
127 (declare (ignore condition))
128 (format stream "Attempting I/O through void external-format."))))
129
130 (define-external-format :void
131 (octets-to-code (state input unput)
132 (declare (ignore input))
133 (error 'void-external-format))
134 (code-to-octets (code state output)
135 (declare (ignore code))
136 (error 'void-external-format)))
137
138 (define-external-format :iso8859-1
139 (octets-to-code (state input unput)
140 (declare (optimize (speed 3) (space 0) (safety 0) (debug 0)))
141 (values (funcall input) 1 nil))
142 (code-to-octets (code state output)
143 (declare (optimize (speed 3) (space 0) (safety 0) (debug 0)))
144 (funcall output (if (> code 255) #x3F code))
145 nil))
146
147
148 (defmacro octets-to-codepoint (external-format state count input unput)
149 (let ((tmp1 (gensym)) (tmp2 (gensym)) (tmp3 (gensym)))
150 `(multiple-value-bind (,tmp1 ,tmp2 ,tmp3)
151 (funcall (ef-octets-to-code ,external-format) ,external-format
152 ,state ,input ,unput)
153 (declare (type (unsigned-byte 31) ,tmp1) (type lisp::index ,tmp2))
154 (setf ,state ,tmp3 ,count ,tmp2)
155 ,tmp1)))
156
157 (defmacro codepoint-to-octets (external-format code state output)
158 `(progn
159 (setf ,state (funcall (ef-code-to-octets ,external-format)
160 ,external-format ,code ,state ,output))
161 nil))
162
163
164
165 (defmacro octets-to-char (external-format state count input unput)
166 `(let ((code (octets-to-codepoint ,external-format
167 ,state ,count ,input ,unput)))
168 (declare (type (unsigned-byte 31) code))
169 (if (< code #x100) (code-char code) #\?)))
170
171 (defmacro char-to-octets (external-format char state output)
172 `(codepoint-to-octets ,external-format (char-code ,char) ,state ,output))
173
174 (defun string-to-octets (string &key (start 0) end (external-format :default)
175 (buffer nil bufferp))
176 (declare (type string string)
177 (type lisp::index start)
178 (type (or null lisp::index) end)
179 (type (or null (simple-array (unsigned-byte 8) (*))) buffer)
180 #|(optimize (speed 3) (safety 0) (space 0) (debug 0))|#)
181 (let ((ef (find-external-format external-format))
182 (buffer (or buffer (make-array (length string)
183 :element-type '(unsigned-byte 8))))
184 (ptr 0)
185 (state nil))
186 (declare (type external-format ef)
187 (type (simple-array (unsigned-byte 8) (*)) buffer)
188 (type lisp::index ptr))
189 (flet ((out (b)
190 (when (= ptr (length buffer))
191 (setq buffer (adjust-array buffer (* 2 ptr))))
192 (setf (aref buffer (1- (incf ptr))) b)))
193 (dotimes (i (- (or end (length string)) start))
194 (declare (type lisp::index i))
195 (char-to-octets ef (char string (+ start i)) state #'out))
196 (values (if bufferp buffer (lisp::shrink-vector buffer ptr)) ptr))))
197
198 (defun octets-to-string (octets &key (start 0) end (external-format :default)
199 (string nil stringp))
200 (declare (type (simple-array (unsigned-byte 8) (*)) octets)
201 (type lisp::index start)
202 (type (or null lisp::index) end)
203 (type (or null simple-string string))
204 #|(optimize (speed 3) (safety 0) (space 0) (debug 0))|#)
205 (let ((ef (find-external-format external-format))
206 (end (1- (or end (length octets))))
207 (string (or string (make-string (length octets))))
208 (ptr (1- start))
209 (pos 0)
210 (count 0)
211 (state nil))
212 (declare (type external-format ef)
213 (type lisp::index end count)
214 (type (integer -1 (#.array-dimension-limit)) pos ptr)
215 (type simple-string string))
216 (flet ((input ()
217 (aref octets (incf ptr)))
218 (unput (n)
219 (decf ptr (the lisp::index n))))
220 (loop until (>= ptr end)
221 do (when (= pos (length string))
222 (setq string (adjust-array string (* 2 pos))))
223 (setf (schar string (1- (incf pos)))
224 (octets-to-char ef state count #'input #'unput))))
225 (values (if stringp string (lisp::shrink-vector string pos)) pos)))
226
227
228
229 (defun encode-string (string external-format &optional (start 0) end)
230 (declare (type string string)
231 (type lisp::index start)
232 (type (or null lisp::index) end)
233 #|(optimize (speed 3) (safety 0) (space 0) (debug 0))|#)
234 (let ((ef (find-external-format external-format))
235 (result (make-string (length string) :element-type 'base-char))
236 (ptr 0)
237 (state nil))
238 (declare (type external-format ef)
239 (type simple-base-string result)
240 (type lisp::index ptr))
241 (flet ((out (b)
242 (when (= ptr (length result))
243 (setq result (adjust-array result (* 2 ptr))))
244 (setf (char result (1- (incf ptr))) (code-char b))))
245 (dotimes (i (- (or end (length string)) start))
246 (declare (type lisp::index i))
247 (char-to-octets ef (char string (+ start i)) state #'out))
248 (lisp::shrink-vector result ptr))))
249
250 (defun decode-string (string external-format &optional (start 0) end)
251 (declare (type string string)
252 (type lisp::index start)
253 (type (or null lisp::index) end)
254 #|(optimize (speed 3) (safety 0) (space 0) (debug 0))|#)
255 (let ((ef (find-external-format external-format))
256 (end (1- (or end (length string))))
257 (result (make-string (length string)))
258 (ptr (1- start))
259 (pos -1)
260 (count 0)
261 (state nil))
262 (declare (type external-format ef)
263 (type lisp::index end count)
264 (type (integer -1 (#.array-dimension-limit)) pos ptr)
265 (type simple-string result))
266 (flet ((input ()
267 (char-code (char string (incf ptr))))
268 (unput (n)
269 (decf ptr (the lisp::index n))))
270 (loop until (>= ptr end)
271 ;; increasing size of result shouldn't ever be necessary, unless
272 ;; someone implements an encoding smaller than the source string...
273 do (setf (schar result (incf pos))
274 (octets-to-char ef state count #'input #'unput))))
275 (lisp::shrink-vector result (1+ pos))))

  ViewVC Help
Powered by ViewVC 1.1.5