/[cmucl]/src/bootfiles/19e/boot-2008-05-cross-unicode-common.lisp
ViewVC logotype

Contents of /src/bootfiles/19e/boot-2008-05-cross-unicode-common.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.3 - (show annotations)
Mon Aug 10 16:47:41 2009 UTC (4 years, 8 months ago) by rtoy
Branch: MAIN
CVS Tags: GIT-CONVERSION, cross-sol-x86-base, sparc-tramp-assem-base, post-merge-intl-branch, snapshot-2010-12, snapshot-2010-11, cross-sol-x86-merged, snapshot-2011-09, snapshot-2011-06, snapshot-2011-07, snapshot-2011-04, intl-2-branch-base, snapshot-2011-02, snapshot-2011-03, snapshot-2011-01, release-20a-pre1, snapshot-2009-11, snapshot-2010-06, pre-merge-intl-branch, intl-branch-working-2010-02-19-1000, unicode-string-buffer-impl-base, intl-branch-working-2010-02-11-1000, release-20b-pre1, release-20b-pre2, unicode-string-buffer-base, cross-sparc-branch-base, intl-branch-base, snapshot-2010-05, snapshot-2010-04, snapshot-2010-07, sparc-tramp-assem-2010-07-19, snapshot-2010-01, snapshot-2010-03, snapshot-2010-02, snapshot-2010-08, snapshot-2009-08, release-20a-base, RELEASE_20b, RELEASE_20a, cross-sol-x86-2010-12-20, amd64-dd-start, intl-branch-2010-03-18-1300, snapshot-2009-12, HEAD
Branch point for: RELEASE-20A-BRANCH, unicode-string-buffer-branch, cross-sol-x86-branch, cross-sparc-branch, sparc-tramp-assem-branch, amd64-dd-branch, unicode-string-buffer-impl-branch, intl-2-branch, RELEASE-20B-BRANCH, intl-branch
Changes since 1.2: +2 -0 lines
Fixes from Paul Foley:

o Standard streams no longer change formats when
  *default-external-format* changes.  Use
  stream:set-system-external-format instead, or (setf
  external-format).
o char-to-octets properly handles surrogate characters being written.
o Makes simple-streams work again.

This change needs to be cross-compiled.  2009-07 binaries work for
cross-compiling using the 19e/boot-2008-05-cross-unicode-*.lisp
cross-compile script.
1 ;;; Common part for cross-compiling 16-bit strings for Unicode.
2 ;;; This part is independent of the architecture.
3
4 (load "target:bootfiles/19f/boot-2009-07")
5
6 (pushnew :unicode *features*)
7 (pushnew :unicode-bootstrap *features*)
8 (in-package "C")
9
10 (handler-bind ((error #'(lambda (c)
11 (declare (ignore c))
12 (invoke-restart 'kernel::continue))))
13 ;; Update so we create the correct size of arrays for characters.
14 (defconstant array-info
15 '((base-char #\NULL 16 old-vm:simple-string-type)
16 (single-float 0.0f0 32 old-vm:simple-array-single-float-type)
17 (double-float 0.0d0 64 old-vm:simple-array-double-float-type)
18 #+long-float (long-float 0.0l0 #+x86 96 #+sparc 128
19 old-vm:simple-array-long-float-type)
20 #+double-double
21 (double-double-float 0w0 128
22 old-vm::simple-array-double-double-float-type)
23 (bit 0 1 old-vm:simple-bit-vector-type)
24 ((unsigned-byte 2) 0 2 old-vm:simple-array-unsigned-byte-2-type)
25 ((unsigned-byte 4) 0 4 old-vm:simple-array-unsigned-byte-4-type)
26 ((unsigned-byte 8) 0 8 old-vm:simple-array-unsigned-byte-8-type)
27 ((unsigned-byte 16) 0 16 old-vm:simple-array-unsigned-byte-16-type)
28 ((unsigned-byte 32) 0 32 old-vm:simple-array-unsigned-byte-32-type)
29 ((signed-byte 8) 0 8 old-vm:simple-array-signed-byte-8-type)
30 ((signed-byte 16) 0 16 old-vm:simple-array-signed-byte-16-type)
31 ((signed-byte 30) 0 32 old-vm:simple-array-signed-byte-30-type)
32 ((signed-byte 32) 0 32 old-vm:simple-array-signed-byte-32-type)
33 ((complex single-float) #C(0.0f0 0.0f0) 64
34 old-vm:simple-array-complex-single-float-type)
35 ((complex double-float) #C(0.0d0 0.0d0) 128
36 old-vm:simple-array-complex-double-float-type)
37 #+long-float
38 ((complex long-float) #C(0.0l0 0.0l0) #+x86 192 #+sparc 256
39 old-vm:simple-array-complex-long-float-type)
40 #+double-double
41 ((complex double-double-float) #C(0.0w0 0.0w0) 256
42 old-vm::simple-array-complex-double-double-float-type)
43 (t 0 32 old-vm:simple-vector-type)))
44 )
45
46 (handler-bind ((error #'(lambda (c)
47 (declare (ignore c))
48 (invoke-restart 'kernel::clobber-it))))
49 (defstruct (fd-stream
50 (:print-function %print-fd-stream)
51 (:constructor %make-fd-stream)
52 (:include file-stream
53 (misc #'fd-stream-misc-routine)))
54
55 (name nil) ; The name of this stream
56 (file nil) ; The file this stream is for
57 ;;
58 ;; The backup file namestring for the old file, for :if-exists :rename or
59 ;; :rename-and-delete.
60 (original nil :type (or simple-string null))
61 (delete-original nil) ; for :if-exists :rename-and-delete
62 ;;
63 ;;; Number of bytes per element.
64 (element-size 1 :type index)
65 (element-type 'base-char) ; The type of element being transfered.
66 (fd -1 :type fixnum) ; The file descriptor
67 ;;
68 ;; Controls when the output buffer is flushed.
69 (buffering :full :type (member :full :line :none))
70 ;;
71 ;; Character position if known.
72 (char-pos nil :type (or index null))
73 ;;
74 ;; T if input is waiting on FD. :EOF if we hit EOF.
75 (listen nil :type (member nil t :eof))
76 ;;
77 ;; The input buffer.
78 (unread nil)
79 (ibuf-sap nil :type (or system-area-pointer null))
80 (ibuf-length nil :type (or index null))
81 (ibuf-head 0 :type index)
82 (ibuf-tail 0 :type index)
83
84 ;; The output buffer.
85 (obuf-sap nil :type (or system-area-pointer null))
86 (obuf-length nil :type (or index null))
87 (obuf-tail 0 :type index)
88
89 ;; Output flushed, but not written due to non-blocking io.
90 (output-later nil)
91 (handler nil)
92 ;;
93 ;; Timeout specified for this stream, or NIL if none.
94 (timeout nil :type (or index null))
95 ;;
96 ;; Pathname of the file this stream is opened to (returned by PATHNAME.)
97 (pathname nil :type (or pathname null))
98 ;;
99 ;; External formats
100 ;; @@ I want to use :default here, but keyword pkg isn't set up yet at boot
101 ;; so initialize to NIL and fix it in SET-ROUTINES
102 #+unicode
103 (external-format nil :type (or null keyword cons))
104 #+unicode
105 (oc-state nil)
106 #+unicode
107 (co-state nil)
108 #+unicode
109 (last-char-read-size 0 :type index)))
110
111 (defun %print-fd-stream (fd-stream stream depth)
112 (declare (ignore depth) (stream stream))
113 (format stream "#<Stream for ~A>"
114 (fd-stream-name fd-stream)))
115
116 ;; Dump a character of a string to a fasl file in the byte correct
117 ;; order.
118 (defun dump-string-char (code file)
119 ;; Do we want *native-backend* or *target-backend*? Use
120 ;; *native-backend* because we're assuming we're cross-compiling
121 ;; from the same arch as the desired arch.
122 (ecase (c::backend-byte-order c::*native-backend*)
123 (:little-endian
124 (dump-byte (ldb (byte 8 0) code) file)
125 (dump-byte (ldb (byte 8 8) code) file))
126 (:big-endian
127 (dump-byte (ldb (byte 8 8) code) file)
128 (dump-byte (ldb (byte 8 0) code) file))))
129
130 ;; Dump a string one character at a time because in the
131 ;; cross-compiler, we're still using 8-bit strings, but want 16-bit
132 ;; strings in the resulting fasl file.
133 (defun dump-simple-string (s file)
134 (declare (type simple-base-string s))
135 (let ((length (length s)))
136 (dump-fop* length lisp::fop-small-string lisp::fop-string file)
137 (dotimes (k length)
138 (dump-string-char (char-code (aref s k)) file)))
139 (undefined-value))
140
141 ;; Like dump-simple-string
142 (defun dump-symbol (s file)
143 (let* ((pname (symbol-name s))
144 (pname-length (length pname))
145 (pkg (symbol-package s)))
146
147 (cond ((null pkg)
148 (dump-fop* pname-length lisp::fop-uninterned-small-symbol-save
149 lisp::fop-uninterned-symbol-save file))
150 ;; Why do we do this? It causes weird things to happen if
151 ;; you're in, say, the KERNEL package when you compile-file
152 ;; something and load the fasl back in when you're in a
153 ;; different package.
154 #-(and)
155 ((eq pkg *package*)
156 (dump-fop* pname-length lisp::fop-small-symbol-save
157 lisp::fop-symbol-save file))
158 ((eq pkg ext:*lisp-package*)
159 (dump-fop* pname-length lisp::fop-lisp-small-symbol-save
160 lisp::fop-lisp-symbol-save file))
161 ((eq pkg ext:*keyword-package*)
162 (dump-fop* pname-length lisp::fop-keyword-small-symbol-save
163 lisp::fop-keyword-symbol-save file))
164 ((< pname-length 256)
165 (dump-fop* (dump-package pkg file)
166 lisp::fop-small-symbol-in-byte-package-save
167 lisp::fop-small-symbol-in-package-save file)
168 (dump-byte pname-length file))
169 (t
170 (dump-fop* (dump-package pkg file)
171 lisp::fop-symbol-in-byte-package-save
172 lisp::fop-symbol-in-package-save file)
173 (dump-unsigned-32 pname-length file)))
174
175 (dotimes (k pname-length)
176 (dump-string-char (char-code (aref pname k)) file))
177
178 (unless *cold-load-dump*
179 (setf (gethash s (fasl-file-eq-table file)) (fasl-file-table-free file)))
180
181 (incf (fasl-file-table-free file)))
182
183 (undefined-value))
184
185 ;; We always dump characters in little endian order, which seems to be
186 ;; the way most fops are done.
187 (defun dump-character (ch file)
188 (dump-fop 'lisp::fop-short-character file)
189 (let ((code (char-code ch)))
190 (dump-byte (ldb (byte 8 0) code) file)
191 (dump-byte (ldb (byte 8 8) code) file)))
192
193 (defun dump-fixups (fixups file)
194 (declare (list fixups) (type fasl-file file))
195 (dolist (info fixups)
196 (let* ((kind (first info))
197 (fixup (second info))
198 (name (fixup-name fixup))
199 (flavor (fixup-flavor fixup))
200 (offset (third info)))
201 (dump-fop 'lisp::fop-normal-load file)
202 (let ((*cold-load-dump* t))
203 (dump-object kind file))
204 (dump-fop 'lisp::fop-maybe-cold-load file)
205 (ecase flavor
206 (:assembly-routine
207 (assert (symbolp name))
208 (dump-fop 'lisp::fop-normal-load file)
209 (let ((*cold-load-dump* t))
210 (dump-object name file))
211 (dump-fop 'lisp::fop-maybe-cold-load file)
212 (dump-fop 'lisp::fop-assembler-fixup file))
213 ((:foreign :foreign-data)
214 (assert (stringp name))
215 (if (eq flavor :foreign)
216 (dump-fop 'lisp::fop-foreign-fixup file)
217 (dump-fop 'lisp::fop-foreign-data-fixup file))
218 (let ((len (length name)))
219 (assert (< len 256))
220 (dump-byte len file)
221 (dotimes (i len)
222 (dump-string-char (char-code (schar name i)) file))))
223 (:code-object
224 (dump-fop 'lisp::fop-code-object-fixup file)))
225 (dump-unsigned-32 offset file)))
226 (undefined-value))
227
228 (in-package "LISP")
229
230 ;; See print.lisp.
231 (defconstant othercase-attribute (ash 1 9))
232
233 (handler-bind ((error #'(lambda (c)
234 (declare (ignore c))
235 (invoke-restart 'kernel::continue))))
236 (defconstant attribute-names
237 `((number . number-attribute) (lowercase . lowercase-attribute)
238 (uppercase . uppercase-attribute) (letter . letter-attribute)
239 (sign . sign-attribute) (extension . extension-attribute)
240 (dot . dot-attribute) (slash . slash-attribute)
241 (other . other-attribute) (funny . funny-attribute)
242 (othercase . othercase-attribute))))
243
244 ;; Opposite of dump-string-char.
245 (defmacro load-string-char ()
246 (ecase (c::backend-byte-order c::*native-backend*)
247 (:little-endian
248 `(code-char (+ (read-arg 1)
249 (ash (read-arg 1) 8))))
250 (:big-endian
251 `(code-char (+ (ash (read-arg 1) 8)
252 (read-arg 1))))))
253
254 ;; Needed to read in 16-bit strings.
255 (clone-fop (fop-string 37)
256 (fop-small-string 38)
257 (let* ((arg (clone-arg))
258 (res (make-string arg)))
259 (dotimes (k arg)
260 (setf (aref res k) (load-string-char)))
261 res))
262
263 ;; Read in characters. They're always dumped in little-endian order.
264 (define-fop (fop-short-character 69)
265 (code-char (+ (read-arg 1)
266 (ash (read-arg 1) 8))))
267
268 ;; Needed to read in 16-bit strings to create the symbols.
269 (macrolet ((frob (name code name-size package)
270 (let ((n-package (gensym "PACKAGE-"))
271 (n-size (gensym "SIZE-"))
272 (n-buffer (gensym "BUFFER-"))
273 (k (gensym "IDX-")))
274 `(define-fop (,name ,code)
275 (prepare-for-fast-read-byte *fasl-file*
276 (let ((,n-package ,package)
277 (,n-size (fast-read-u-integer ,name-size)))
278 (when (> ,n-size *load-symbol-buffer-size*)
279 (setq *load-symbol-buffer*
280 (make-string (setq *load-symbol-buffer-size*
281 (* ,n-size 2)))))
282 (done-with-fast-read-byte)
283 (let ((,n-buffer *load-symbol-buffer*))
284 (dotimes (,k ,n-size)
285 (setf (aref ,n-buffer ,k) (load-string-char)))
286 (push-table (intern* ,n-buffer ,n-size ,n-package)))))))))
287 (frob fop-symbol-save 6 4 *package*)
288 (frob fop-small-symbol-save 7 1 *package*)
289 (frob fop-lisp-symbol-save 75 4 *lisp-package*)
290 (frob fop-lisp-small-symbol-save 76 1 *lisp-package*)
291 (frob fop-keyword-symbol-save 77 4 *keyword-package*)
292 (frob fop-keyword-small-symbol-save 78 1 *keyword-package*)
293
294 (frob fop-symbol-in-package-save 8 4
295 (svref *current-fop-table* (fast-read-u-integer 4)))
296 (frob fop-small-symbol-in-package-save 9 1
297 (svref *current-fop-table* (fast-read-u-integer 4)))
298 (frob fop-symbol-in-byte-package-save 10 4
299 (svref *current-fop-table* (fast-read-u-integer 1)))
300 (frob fop-small-symbol-in-byte-package-save 11 1
301 (svref *current-fop-table* (fast-read-u-integer 1))))
302
303 (clone-fop (fop-uninterned-symbol-save 12)
304 (fop-uninterned-small-symbol-save 13)
305 (let* ((arg (clone-arg))
306 (res (make-string arg)))
307 (dotimes (k arg)
308 (setf (aref res k) (load-string-char)))
309 (push-table (make-symbol res))))
310
311 (define-fop (fop-foreign-fixup 147)
312 (let* ((kind (pop-stack))
313 (code-object (pop-stack))
314 (len (read-arg 1))
315 (sym (make-string len)))
316 (dotimes (k len)
317 (setf (aref sym k) (load-string-char)))
318 (old-vm:fixup-code-object code-object (read-arg 4)
319 (foreign-symbol-address-aux sym :code)
320 kind)
321 code-object))
322
323 (define-fop (fop-foreign-data-fixup 150)
324 (let* ((kind (pop-stack))
325 (code-object (pop-stack))
326 (len (read-arg 1))
327 (sym (make-string len)))
328 (dotimes (k len)
329 (setf (aref sym k) (load-string-char)))
330 (old-vm:fixup-code-object code-object (read-arg 4)
331 (foreign-symbol-address-aux sym :data)
332 kind)
333 code-object))
334
335 ;; Kill the any deftransforms. They get in the way because they
336 ;; assume 8-bit strings.
337 (in-package "C")
338 (dolist (f '(concatenate subseq replace copy-seq))
339 (setf (c::function-info-transforms (c::function-info-or-lose f)) nil))
340
341 (in-package "C-CALL")
342
343 (def-alien-type-method (c-string :deport-gen) (type value)
344 (declare (ignore type))
345 (let ((s (gensym "C-STRING-"))
346 (len (gensym "LEN-"))
347 (k (gensym "IDX-")))
348 `(etypecase ,value
349 (null (int-sap 0))
350 ((alien (* char)) (alien-sap ,value))
351 (simple-base-string
352 (let* ((,len (length ,value))
353 (,s (make-array (1+ ,len) :element-type '(unsigned-byte 8))))
354 (dotimes (,k ,len)
355 (setf (aref ,s ,k) (logand #xff (char-code (aref ,value ,k)))))
356 (setf (aref ,s ,len) 0)
357 (vector-sap ,s))))))
358
359 ;;; Might as well update the FASL file version too, since we have to
360 ;;; do a cross-compile anyway, and the Unicode fasl's aren't even
361 ;;; close to being compatible with previous versions.
362
363 (in-package :c)
364
365 (setf lisp::*enable-package-locked-errors* nil)
366
367 ;;;
368 ;;; Note that BYTE-FASL-FILE-VERSION is a constant.
369 ;;;
370 ;;; (Be sure to change BYTE-FASL-FILE-VERSION in
371 ;;; compiler/byte-comp.lisp to the correct value too!)
372 ;;;
373 (setf (symbol-value 'byte-fasl-file-version) #x20a)
374 (setf (backend-fasl-file-version *target-backend*) #x20a)
375
376 ;;;
377 ;;; Don't check fasl versions in the compiling Lisp because we'll
378 ;;; load files compiled with the new version numbers.
379 ;;;
380 (setq lisp::*skip-fasl-file-version-check* t)
381
382 ;;;
383 ;;; This is here because BYTE-FASL-FILE-VERSION is constant-folded in
384 ;;; OPEN-FASL-FILE. To make the new version number take effect, we
385 ;;; have to redefine the function.
386 ;;;
387 (defun open-fasl-file (name where &optional byte-p)
388 (declare (type pathname name))
389 (let* ((stream (open name :direction :output
390 :if-exists :new-version
391 :element-type '(unsigned-byte 8)))
392 (res (make-fasl-file :stream stream)))
393 (multiple-value-bind
394 (version f-vers f-imp)
395 (if byte-p
396 (values "Byte code"
397 byte-fasl-file-version
398 (backend-byte-fasl-file-implementation *backend*))
399 (values (backend-version *backend*)
400 (backend-fasl-file-version *backend*)
401 (backend-fasl-file-implementation *backend*)))
402 (format stream
403 "FASL FILE output from ~A.~@
404 Compiled ~A on ~A~@
405 Compiler ~A, Lisp ~A~@
406 Targeted for ~A, FASL version ~X~%"
407 where
408 (ext:format-universal-time nil (get-universal-time))
409 (machine-instance) compiler-version
410 (lisp-implementation-version)
411 version f-vers)
412 ;;
413 ;; Terminate header.
414 (dump-byte 255 res)
415 ;;
416 ;; Specify code format.
417 (dump-fop 'lisp::fop-long-code-format res)
418 (dump-byte f-imp res)
419 (dump-unsigned-32 f-vers res))
420 res))

  ViewVC Help
Powered by ViewVC 1.1.5