Skip to content
GitLab
Menu
Projects
Groups
Snippets
Loading...
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in / Register
Toggle navigation
Menu
Open sidebar
cmucl
cmucl
Commits
68ac9a3e
Commit
68ac9a3e
authored
Jun 11, 2009
by
rtoy
Browse files
Merge Unicode work to trunk. From label
unicode-utf16-extfmt-2009-06-11.
parent
3642a59e
Changes
169
Hide whitespace changes
Inline
Side-by-side
assembly/alpha/array.lisp
View file @
68ac9a3e
...
...
@@ -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
200
3
/0
8/03 11:27:52 gerd Exp
$"
)
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/assembly/alpha/array.lisp,v 1.
4
200
9
/0
6/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 sle
e
zy, changing words like this. But we can because
;; This is kinda sle
a
zy, 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
))
...
...
assembly/amd64/assem-rtns.lisp
View file @
68ac9a3e
...
...
@@ -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
200
4
/0
7/27 23:28:41 cwang Exp
$"
)
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/assembly/amd64/assem-rtns.lisp,v 1.
4
200
9
/0
6/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 (w
h
ere args are produced) to the start of our stack frame
;;; (w
h
ere 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 i
t
going to trash
;; Save the OLD-FP and RETURN-PC because the blit i
s
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 cop
y
ing 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
...
...
assembly/hppa/arith.lisp
View file @
68ac9a3e
...
...
@@ -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
200
3
/0
8/03 11:27:51 gerd Exp
$"
)
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/assembly/hppa/arith.lisp,v 1.
10
200
9
/0
6/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 divi
v
e-step with -divisor to prime V (use rem as a temp)
;; Do one divi
d
e-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 dividen
t
/quotient one bit, setting the carry flag.
;; Shift the dividen
d
/quotient one bit, setting the carry flag.
(
inst
add
quo
quo
quo
)
;; The first real divi
v
e-step.
;; The first real divi
d
e-step.
(
inst
ds
zero-tn
divisor
rem
)
(
inst
addc
quo
quo
quo
)
;; And 31 more of them.
...
...
assembly/mips/alloc.lisp
View file @
68ac9a3e
...
...
@@ -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
200
3
/0
8/03 11:27:51 gerd Exp
$"
)
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/assembly/mips/alloc.lisp,v 1.
10
200
9
/0
6/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 sle
e
zy, changing words like
;; Round words up to a dual-word. This is kinda sle
a
zy, 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
)))
...
...
assembly/mips/array.lisp
View file @
68ac9a3e
...
...
@@ -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.2
5
200
3
/0
8/03 11:27:51 gerd Exp
$"
)
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/assembly/mips/array.lisp,v 1.2
6
200
9
/0
6/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 sle
e
zy, changing words like this. But we can because
;; This is kinda sle
a
zy, 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
)))
...
...
assembly/ppc/array.lisp
View file @
68ac9a3e
...
...
@@ -7,7 +7,7 @@
;;; Scott Fahlman (FAHLMAN@CMUC).
;;; **********************************************************************
;;;
;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/assembly/ppc/array.lisp,v 1.
7
200
6
/0
1
/1
8
1
5:21:26
rtoy
Exp
$
;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/assembly/ppc/array.lisp,v 1.
8
200
9
/0
6
/1
1
1
6: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
)
...
...
assembly/rt/assem-rtns.lisp
View file @
68ac9a3e
...
...
@@ -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
200
3
/0
8/03 11:27:50 gerd Exp
$"
)
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/assembly/rt/assem-rtns.lisp,v 1.
8
200
9
/0
6/11 16:03:55 rtoy Rel
$"
)
;;;
;;; **********************************************************************
;;;
;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/assembly/rt/assem-rtns.lisp,v 1.
7
200
3
/0
8/03 11:27:50 gerd Exp
$
;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/assembly/rt/assem-rtns.lisp,v 1.
8
200
9
/0
6/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 sa
m
e them all there,
;; figure out where to save the others. We can't sa
v
e 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?
...
...
assembly/sparc/array.lisp
View file @
68ac9a3e
...
...
@@ -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.1
0
200
4
/0
4/07 02:47
:5
3
rtoy
Exp
$"
)
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/assembly/sparc/array.lisp,v 1.1
1
200
9
/0
6/11 16:03
:5
6
rtoy
Rel
$"
)
;;;
;;; **********************************************************************
;;;
;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/assembly/sparc/array.lisp,v 1.1
0
200
4
/0
4/07 02:47
:5
3
rtoy
Exp
$
;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/assembly/sparc/array.lisp,v 1.1
1
200
9
/0
6/11 16:03
:5
6
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
)
...
...
assembly/x86/array.lisp
View file @
68ac9a3e
...
...
@@ -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.1
0
200
8
/0
4/01 07:09:28 cshapiro Exp
$"
)
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/assembly/x86/array.lisp,v 1.1
1
200
9
/0
6/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.
...
...
assembly/x86/assem-rtns.lisp
View file @
68ac9a3e
...
...
@@ -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
200
8
/0
4/01 07:25:08 cshapiro Exp
$"
)
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/assembly/x86/assem-rtns.lisp,v 1.
8
200
9
/0
6/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 cop
y
ing 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 (w
h
ere args are produced) to the start of our stack frame
;;; (w
h
ere 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 s
t
ays 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 i
t
going to trash
;; Save the OLD-FP and RETURN-PC because the blit i
s
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 cop
y
ing 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
;; He
a
r EAX points to catch block containing symbol pointed to by EDX.
;; Her
e
EAX points to catch block containing symbol pointed to by EDX.
(
inst
jmp
(
make-fixup
'unwind
:assembly-routine
)))
;;;; Non-local exit noise.
...
...
bootfiles/19e/boot-2008-05-cross-unicode-common.lisp
0 → 100644
View file @
68ac9a3e
;;; 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
))))