Commit 68ac9a3e authored by rtoy's avatar rtoy
Browse files

Merge Unicode work to trunk. From label

unicode-utf16-extfmt-2009-06-11.
parent 3642a59e
......@@ -5,7 +5,7 @@
;;; Carnegie Mellon University, and has been placed in the public domain.
;;;
(ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/assembly/alpha/array.lisp,v 1.3 2003/08/03 11:27:52 gerd Exp $")
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/assembly/alpha/array.lisp,v 1.4 2009/06/11 16:03:55 rtoy Rel $")
;;;
;;; **********************************************************************
;;;
......@@ -28,7 +28,7 @@
(:res result descriptor-reg a0-offset)
(:temp ndescr non-descriptor-reg nl0-offset))
;; This is kinda sleezy, changing words like this. But we can because
;; This is kinda sleazy, changing words like this. But we can because
;; the vop thinks it is temporary.
(inst addq words (+ (1- (ash 1 lowtag-bits))
(* vector-data-offset word-bytes))
......
......@@ -7,7 +7,7 @@
;;; Scott Fahlman or slisp-group@cs.cmu.edu.
;;;
(ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/assembly/amd64/assem-rtns.lisp,v 1.3 2004/07/27 23:28:41 cwang Exp $")
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/assembly/amd64/assem-rtns.lisp,v 1.4 2009/06/11 16:03:55 rtoy Rel $")
;;;
;;; **********************************************************************
;;;
......@@ -113,8 +113,8 @@
;;;; tail-call-variable.
;;; For tail-call-variable, we have to copy the arguments from the end of our
;;; stack frame (were args are produced) to the start of our stack frame
;;; (were args are expected).
;;; stack frame (where args are produced) to the start of our stack frame
;;; (where args are expected).
;;;
;;; We take the function to call in rAX and a pointer to the arguments in
;;; rSI. rBP says the same over the jump, and the old frame pointer is
......@@ -144,14 +144,14 @@
(inst cmp rcx (fixnumize 3))
(inst jmp :le REGISTER-ARGS)
;; Save the OLD-FP and RETURN-PC because the blit it going to trash
;; Save the OLD-FP and RETURN-PC because the blit is going to trash
;; those stack locations. Save the rCX, because the loop is going
;; to trash it.
(pushw rbp-tn -1)
(loadw rbx rbp-tn -2)
(inst push rcx)
;; Do the blit. Because we are coping from smaller addresses to larger
;; Do the blit. Because we are copying from smaller addresses to larger
;; addresses, we have to start at the largest pair and work our way down.
(inst shr rcx 2) ; fixnum to raw words
(inst std) ; count down
......@@ -178,10 +178,10 @@
(inst push rbx)
;; And jump into the function.
(inst jmp
(make-ea :byte :base rax
:disp (- (* closure-function-slot word-bytes)
function-pointer-type)))
(inst jmp
(make-ea :byte :base rax
:disp (- (* closure-function-slot word-bytes)
function-pointer-type)))
;; All the arguments fit in registers, so load them.
REGISTER-ARGS
......
......@@ -5,7 +5,7 @@
;;; Carnegie Mellon University, and has been placed in the public domain.
;;;
(ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/assembly/hppa/arith.lisp,v 1.9 2003/08/03 11:27:51 gerd Exp $")
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/assembly/hppa/arith.lisp,v 1.10 2009/06/11 16:03:55 rtoy Rel $")
;;;
;;; **********************************************************************
;;;
......@@ -77,12 +77,12 @@
;; Move abs(divident) into quo.
(inst move dividend quo :>=)
(inst sub zero-tn quo quo)
;; Do one divive-step with -divisor to prime V (use rem as a temp)
;; Do one divide-step with -divisor to prime V (use rem as a temp)
(inst sub zero-tn divisor rem)
(inst ds zero-tn rem zero-tn)
;; Shift the divident/quotient one bit, setting the carry flag.
;; Shift the dividend/quotient one bit, setting the carry flag.
(inst add quo quo quo)
;; The first real divive-step.
;; The first real divide-step.
(inst ds zero-tn divisor rem)
(inst addc quo quo quo)
;; And 31 more of them.
......
......@@ -5,7 +5,7 @@
;;; Carnegie Mellon University, and has been placed in the public domain.
;;;
(ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/assembly/mips/alloc.lisp,v 1.9 2003/08/03 11:27:51 gerd Exp $")
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/assembly/mips/alloc.lisp,v 1.10 2009/06/11 16:03:55 rtoy Rel $")
;;;
;;; **********************************************************************
;;;
......@@ -38,7 +38,7 @@
(inst beq ndescr large-alloc-entry)
(inst nop)
;; Round words up to a dual-word. This is kinda sleezy, changing words like
;; Round words up to a dual-word. This is kinda sleazy, changing words like
;; this. But we can because the vop thinks it is temporary.
(inst addu words (+ (1- (ash 1 lowtag-bits))
(* vector-data-offset word-bytes)))
......
......@@ -5,7 +5,7 @@
;;; Carnegie Mellon University, and has been placed in the public domain.
;;;
(ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/assembly/mips/array.lisp,v 1.25 2003/08/03 11:27:51 gerd Exp $")
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/assembly/mips/array.lisp,v 1.26 2009/06/11 16:03:55 rtoy Rel $")
;;;
;;; **********************************************************************
;;;
......@@ -29,7 +29,7 @@
(:temp ndescr non-descriptor-reg nl0-offset)
(:temp pa-flag non-descriptor-reg nl4-offset))
;; This is kinda sleezy, changing words like this. But we can because
;; This is kinda sleazy, changing words like this. But we can because
;; the vop thinks it is temporary.
(inst addu words (+ (1- (ash 1 lowtag-bits))
(* vector-data-offset word-bytes)))
......
......@@ -7,7 +7,7 @@
;;; Scott Fahlman (FAHLMAN@CMUC).
;;; **********************************************************************
;;;
;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/assembly/ppc/array.lisp,v 1.7 2006/01/18 15:21:26 rtoy Exp $
;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/assembly/ppc/array.lisp,v 1.8 2009/06/11 16:03:55 rtoy Rel $
;;;
;;; This file contains the support routines for arrays and vectors.
;;;
......@@ -138,6 +138,9 @@
(:temp offset non-descriptor-reg nl3-offset))
(emit-label sxhash-simple-substring-entry)
#+unicode
(inst slwi length length 1) ; Number of bytes = twice the length
(inst li offset (- (* vm:vector-data-offset vm:word-bytes) vm:other-pointer-type))
(move accum zero-tn)
(inst b test)
......
......@@ -5,11 +5,11 @@
;;; Carnegie Mellon University, and has been placed in the public domain.
;;;
(ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/assembly/rt/assem-rtns.lisp,v 1.7 2003/08/03 11:27:50 gerd Exp $")
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/assembly/rt/assem-rtns.lisp,v 1.8 2009/06/11 16:03:55 rtoy Rel $")
;;;
;;; **********************************************************************
;;;
;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/assembly/rt/assem-rtns.lisp,v 1.7 2003/08/03 11:27:50 gerd Exp $
;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/assembly/rt/assem-rtns.lisp,v 1.8 2009/06/11 16:03:55 rtoy Rel $
;;;
(in-package "RT")
......@@ -198,7 +198,7 @@
(:temp temp any-reg ocfp-offset))
;; First, save count/src (the NFP) on the number stack. We need to do this
;; instead of with the other saves, because we need to use this register to
;; figure out where to save the others. We can't same them all there,
;; figure out where to save the others. We can't save them all there,
;; because some of the others hold descriptor values.
(storew count/src nsp-tn -1)
;; How many more args are there to copy to the stack?
......
......@@ -5,11 +5,11 @@
;;; Carnegie Mellon University, and has been placed in the public domain.
;;;
(ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/assembly/sparc/array.lisp,v 1.10 2004/04/07 02:47:53 rtoy Exp $")
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/assembly/sparc/array.lisp,v 1.11 2009/06/11 16:03:56 rtoy Rel $")
;;;
;;; **********************************************************************
;;;
;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/assembly/sparc/array.lisp,v 1.10 2004/04/07 02:47:53 rtoy Exp $
;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/assembly/sparc/array.lisp,v 1.11 2009/06/11 16:03:56 rtoy Rel $
;;;
;;; This file contains the support routines for arrays and vectors.
;;;
......@@ -124,6 +124,9 @@ ub4 one_at_a_time(char *key, ub4 len)
(:temp offset non-descriptor-reg nl3-offset))
(emit-label sxhash-simple-substring-entry)
#+unicode
(inst sll length 1) ; Number of bytes = twice the length
(inst li offset (- (* vector-data-offset word-bytes) other-pointer-type))
(inst b test)
(move accum zero-tn)
......
......@@ -7,7 +7,7 @@
;;; Scott Fahlman or slisp-group@cs.cmu.edu.
;;;
(ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/assembly/x86/array.lisp,v 1.10 2008/04/01 07:09:28 cshapiro Exp $")
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/assembly/x86/array.lisp,v 1.11 2009/06/11 16:03:56 rtoy Rel $")
;;;
;;; **********************************************************************
;;;
......@@ -79,6 +79,9 @@
(inst lea esi (make-ea :byte :base string
:disp (- (* vector-data-offset word-bytes)
other-pointer-type)))
#+unicode
(inst shl length 1) ; Number of bytes = twice the length
;; Initialize the result.
(inst xor result result)
;; Get the count. If it's zero, blow out.
......
......@@ -7,7 +7,7 @@
;;; Scott Fahlman or slisp-group@cs.cmu.edu.
;;;
(ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/assembly/x86/assem-rtns.lisp,v 1.7 2008/04/01 07:25:08 cshapiro Exp $")
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/assembly/x86/assem-rtns.lisp,v 1.8 2009/06/11 16:03:56 rtoy Rel $")
;;;
;;; **********************************************************************
;;;
......@@ -55,7 +55,7 @@
;; Blit the values down the stack. Note: there might be overlap, so we have
;; to be careful not to clobber values before we've read them. Because the
;; stack builds down, we are coping to a larger address. Therefore, we need
;; stack builds down, we are copying to a larger address. Therefore, we need
;; to iterate from larger addresses to smaller addresses.
;; pfw-this says copy ecx words from esi to edi counting down.
(inst shr ecx 2) ; fixnum to raw word count
......@@ -114,11 +114,11 @@
;;;; tail-call-variable.
;;; For tail-call-variable, we have to copy the arguments from the end of our
;;; stack frame (were args are produced) to the start of our stack frame
;;; (were args are expected).
;;; stack frame (where args are produced) to the start of our stack frame
;;; (where args are expected).
;;;
;;; We take the function to call in EAX and a pointer to the arguments in
;;; ESI. EBP says the same over the jump, and the old frame pointer is
;;; ESI. EBP stays the same over the jump, and the old frame pointer is
;;; still saved in the first stack slot. The return-pc is saved in
;;; the second stack slot, so we have to push it to make it look like
;;; we actually called. We also have to compute ECX from the difference
......@@ -140,18 +140,18 @@
(move ecx esi)
(inst sub ecx esp-tn)
;; Check for all the args fitting the the registers.
;; Check for all the args fitting in the registers.
(inst cmp ecx (fixnumize 3))
(inst jmp :le REGISTER-ARGS)
;; Save the OLD-FP and RETURN-PC because the blit it going to trash
;; Save the OLD-FP and RETURN-PC because the blit is going to trash
;; those stack locations. Save the ECX, because the loop is going
;; to trash it.
(pushw ebp-tn -1)
(loadw ebx ebp-tn -2)
(inst push ecx)
;; Do the blit. Because we are coping from smaller addresses to larger
;; Do the blit. Because we are copying from smaller addresses to larger
;; addresses, we have to start at the largest pair and work our way down.
(inst shr ecx 2) ; fixnum to raw words
(inst lea edi (make-ea :dword :base ebp-tn :disp (- word-bytes)))
......@@ -179,10 +179,10 @@
(inst push ebx)
;; And jump into the function.
(inst jmp
(make-ea :byte :base eax
:disp (- (* closure-function-slot word-bytes)
function-pointer-type)))
(inst jmp
(make-ea :byte :base eax
:disp (- (* closure-function-slot word-bytes)
function-pointer-type)))
;; All the arguments fit in registers, so load them.
REGISTER-ARGS
......@@ -229,7 +229,7 @@
EXIT
;; Hear EAX points to catch block containing symbol pointed to by EDX.
;; Here EAX points to catch block containing symbol pointed to by EDX.
(inst jmp (make-fixup 'unwind :assembly-routine)))
;;;; Non-local exit noise.
......
;;; Common part for cross-compiling 16-bit strings for Unicode.
;;; This part is independent of the architecture.
(pushnew :unicode *features*)
(pushnew :unicode-bootstrap *features*)
(in-package "C")
(handler-bind ((error #'(lambda (c)
(declare (ignore c))
(invoke-restart 'kernel::continue))))
;; Update so we create the correct size of arrays for characters.
(defconstant array-info
'((base-char #\NULL 16 old-vm:simple-string-type)
(single-float 0.0f0 32 old-vm:simple-array-single-float-type)
(double-float 0.0d0 64 old-vm:simple-array-double-float-type)
#+long-float (long-float 0.0l0 #+x86 96 #+sparc 128
old-vm:simple-array-long-float-type)
#+double-double
(double-double-float 0w0 128
old-vm::simple-array-double-double-float-type)
(bit 0 1 old-vm:simple-bit-vector-type)
((unsigned-byte 2) 0 2 old-vm:simple-array-unsigned-byte-2-type)
((unsigned-byte 4) 0 4 old-vm:simple-array-unsigned-byte-4-type)
((unsigned-byte 8) 0 8 old-vm:simple-array-unsigned-byte-8-type)
((unsigned-byte 16) 0 16 old-vm:simple-array-unsigned-byte-16-type)
((unsigned-byte 32) 0 32 old-vm:simple-array-unsigned-byte-32-type)
((signed-byte 8) 0 8 old-vm:simple-array-signed-byte-8-type)
((signed-byte 16) 0 16 old-vm:simple-array-signed-byte-16-type)
((signed-byte 30) 0 32 old-vm:simple-array-signed-byte-30-type)
((signed-byte 32) 0 32 old-vm:simple-array-signed-byte-32-type)
((complex single-float) #C(0.0f0 0.0f0) 64
old-vm:simple-array-complex-single-float-type)
((complex double-float) #C(0.0d0 0.0d0) 128
old-vm:simple-array-complex-double-float-type)
#+long-float
((complex long-float) #C(0.0l0 0.0l0) #+x86 192 #+sparc 256
old-vm:simple-array-complex-long-float-type)
#+double-double
((complex double-double-float) #C(0.0w0 0.0w0) 256
old-vm::simple-array-complex-double-double-float-type)
(t 0 32 old-vm:simple-vector-type)))
)
(handler-bind ((error #'(lambda (c)
(declare (ignore c))
(invoke-restart 'kernel::clobber-it))))
(defstruct (fd-stream
(:print-function %print-fd-stream)
(:constructor %make-fd-stream)
(:include file-stream
(misc #'fd-stream-misc-routine)))
(name nil) ; The name of this stream
(file nil) ; The file this stream is for
;;
;; The backup file namestring for the old file, for :if-exists :rename or
;; :rename-and-delete.
(original nil :type (or simple-string null))
(delete-original nil) ; for :if-exists :rename-and-delete
;;
;;; Number of bytes per element.
(element-size 1 :type index)
(element-type 'base-char) ; The type of element being transfered.
(fd -1 :type fixnum) ; The file descriptor
;;
;; Controls when the output buffer is flushed.
(buffering :full :type (member :full :line :none))
;;
;; Character position if known.
(char-pos nil :type (or index null))
;;
;; T if input is waiting on FD. :EOF if we hit EOF.
(listen nil :type (member nil t :eof))
;;
;; The input buffer.
(unread nil)
(ibuf-sap nil :type (or system-area-pointer null))
(ibuf-length nil :type (or index null))
(ibuf-head 0 :type index)
(ibuf-tail 0 :type index)
;; The output buffer.
(obuf-sap nil :type (or system-area-pointer null))
(obuf-length nil :type (or index null))
(obuf-tail 0 :type index)
;; Output flushed, but not written due to non-blocking io.
(output-later nil)
(handler nil)
;;
;; Timeout specified for this stream, or NIL if none.
(timeout nil :type (or index null))
;;
;; Pathname of the file this stream is opened to (returned by PATHNAME.)
(pathname nil :type (or pathname null))
;;
;; External formats
;; @@ I want to use :default here, but keyword pkg isn't set up yet at boot
;; so initialize to NIL and fix it in SET-ROUTINES
#+unicode
(external-format nil :type (or null keyword cons))
#+unicode
(oc-state nil)
#+unicode
(co-state nil)
#+unicode
(last-char-read-size 0 :type index)))
(defun %print-fd-stream (fd-stream stream depth)
(declare (ignore depth) (stream stream))
(format stream "#<Stream for ~A>"
(fd-stream-name fd-stream)))
;; Dump a character of a string to a fasl file in the byte correct
;; order.
(defun dump-string-char (code file)
;; Do we want *native-backend* or *target-backend*? Use
;; *native-backend* because we're assuming we're cross-compiling
;; from the same arch as the desired arch.
(ecase (c::backend-byte-order c::*native-backend*)
(:little-endian
(dump-byte (ldb (byte 8 0) code) file)
(dump-byte (ldb (byte 8 8) code) file))
(:big-endian
(dump-byte (ldb (byte 8 8) code) file)
(dump-byte (ldb (byte 8 0) code) file))))
;; Dump a string one character at a time because in the
;; cross-compiler, we're still using 8-bit strings, but want 16-bit
;; strings in the resulting fasl file.
(defun dump-simple-string (s file)
(declare (type simple-base-string s))
(let ((length (length s)))
(dump-fop* length lisp::fop-small-string lisp::fop-string file)
(dotimes (k length)
(dump-string-char (char-code (aref s k)) file)))
(undefined-value))
;; Like dump-simple-string
(defun dump-symbol (s file)
(let* ((pname (symbol-name s))
(pname-length (length pname))
(pkg (symbol-package s)))
(cond ((null pkg)
(dump-fop* pname-length lisp::fop-uninterned-small-symbol-save
lisp::fop-uninterned-symbol-save file))
;; Why do we do this? It causes weird things to happen if
;; you're in, say, the KERNEL package when you compile-file
;; something and load the fasl back in when you're in a
;; different package.
#-(and)
((eq pkg *package*)
(dump-fop* pname-length lisp::fop-small-symbol-save
lisp::fop-symbol-save file))
((eq pkg ext:*lisp-package*)
(dump-fop* pname-length lisp::fop-lisp-small-symbol-save
lisp::fop-lisp-symbol-save file))
((eq pkg ext:*keyword-package*)
(dump-fop* pname-length lisp::fop-keyword-small-symbol-save
lisp::fop-keyword-symbol-save file))
((< pname-length 256)
(dump-fop* (dump-package pkg file)
lisp::fop-small-symbol-in-byte-package-save
lisp::fop-small-symbol-in-package-save file)
(dump-byte pname-length file))
(t
(dump-fop* (dump-package pkg file)
lisp::fop-symbol-in-byte-package-save
lisp::fop-symbol-in-package-save file)
(dump-unsigned-32 pname-length file)))
(dotimes (k pname-length)
(dump-string-char (char-code (aref pname k)) file))
(unless *cold-load-dump*
(setf (gethash s (fasl-file-eq-table file)) (fasl-file-table-free file)))
(incf (fasl-file-table-free file)))
(undefined-value))
;; We always dump characters in little endian order, which seems to be
;; the way most fops are done.
(defun dump-character (ch file)
(dump-fop 'lisp::fop-short-character file)
(let ((code (char-code ch)))
(dump-byte (ldb (byte 8 0) code) file)
(dump-byte (ldb (byte 8 8) code) file)))
(defun dump-fixups (fixups file)
(declare (list fixups) (type fasl-file file))
(dolist (info fixups)
(let* ((kind (first info))
(fixup (second info))
(name (fixup-name fixup))
(flavor (fixup-flavor fixup))
(offset (third info)))
(dump-fop 'lisp::fop-normal-load file)
(let ((*cold-load-dump* t))
(dump-object kind file))
(dump-fop 'lisp::fop-maybe-cold-load file)
(ecase flavor
(:assembly-routine
(assert (symbolp name))
(dump-fop 'lisp::fop-normal-load file)
(let ((*cold-load-dump* t))
(dump-object name file))
(dump-fop 'lisp::fop-maybe-cold-load file)
(dump-fop 'lisp::fop-assembler-fixup file))
((:foreign :foreign-data)
(assert (stringp name))
(if (eq flavor :foreign)
(dump-fop 'lisp::fop-foreign-fixup file)
(dump-fop 'lisp::fop-foreign-data-fixup file))
(let ((len (length name)))
(assert (< len 256))
(dump-byte len file)
(dotimes (i len)
(dump-string-char (char-code (schar name i)) file))))
(:code-object
(dump-fop 'lisp::fop-code-object-fixup file)))
(dump-unsigned-32 offset file)))
(undefined-value))
(in-package "LISP")
;; See print.lisp.
(defconstant othercase-attribute (ash 1 9))
(handler-bind ((error #'(lambda (c)
(declare (ignore c))
(invoke-restart 'kernel::continue))))
(defconstant attribute-names
`((number . number-attribute) (lowercase . lowercase-attribute)
(uppercase . uppercase-attribute) (letter . letter-attribute)
(sign . sign-attribute) (extension . extension-attribute)
(dot . dot-attribute) (slash . slash-attribute)
(other . other-attribute) (funny . funny-attribute)
(othercase . othercase-attribute))))
;; Opposite of dump-string-char.
(defmacro load-string-char ()
(ecase (c::backend-byte-order c::*native-backend*)
(:little-endian
`(code-char (+ (read-arg 1)
(ash (read-arg 1) 8))))
(:big-endian
`(code-char (+ (ash (read-arg 1) 8)
(read-arg 1))))))
;; Needed to read in 16-bit strings.
(clone-fop (fop-string 37)
(fop-small-string 38)
(let* ((arg (clone-arg))
(res (make-string arg)))
(dotimes (k arg)
(setf (aref res k) (load-string-char)))
res))
;; Read in characters. They're always dumped in little-endian order.
(define-fop (fop-short-character 69)
(code-char (+ (read-arg 1)
(ash (read-arg 1) 8))))
;; Needed to read in 16-bit strings to create the symbols.
(macrolet ((frob (name code name-size package)
(let ((n-package (gensym "PACKAGE-"))
(n-size (gensym "SIZE-"))
(n-buffer (gensym "BUFFER-"))
(k (gensym "IDX-")))
`(define-fop (,name ,code)
(prepare-for-fast-read-byte *fasl-file*
(let ((,n-package ,package)
(,n-size (fast-read-u-integer ,name-size)))
(when (> ,n-size *load-symbol-buffer-size*)
(setq *load-symbol-buffer*
(make-string (setq *load-symbol-buffer-size*
(* ,n-size 2)))))
(done-with-fast-read-byte)
(let ((,n-buffer *load-symbol-buffer*))
(dotimes (,k ,n-size)
(setf (aref ,n-buffer ,k) (load-string-char)))
(push-table (intern* ,n-buffer ,n-size ,n-package)))))))))
(frob fop-symbol-save 6 4 *package*)
(frob fop-small-symbol-save 7 1 *package*)
(frob fop-lisp-symbol-save 75 4 *lisp-package*)
(frob fop-lisp-small-symbol-save 76 1 *lisp-package*)
(frob fop-keyword-symbol-save 77 4 *keyword-package*)
(frob fop-keyword-small-symbol-save 78 1 *keyword-package*)
(frob fop-symbol-in-package-save 8 4
(svref *current-fop-table* (fast-read-u-integer 4)))
(frob fop-small-symbol-in-package-save 9 1
(svref *current-fop-table* (fast-read-u-integer 4)))
(frob fop-symbol-in-byte-package-save 10 4
(svref *current-fop-table* (fast-read-u-integer 1)))
(frob fop-small-symbol-in-byte-package-save 11 1
(svref *current-fop-table* (fast-read-u-integer 1))))
(clone-fop (fop-uninterned-symbol-save 12)
(fop-uninterned-small-symbol-save 13)
(let* ((arg (clone-arg))
(res (make-string arg)))
(dotimes (k arg)
(setf (aref res k) (load-string-char)))
(push-table (make-symbol res))))