1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
|
; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees. See file COPYING.
; Writing out a Scheme 48 image
; From GC.SCM
; (%write-string "This is a Scheme 48 heap image file." port)
; (%newline port)
; (%write-page port)
; (%newline port)
; (%write-number level port)
; (%write-number bytes-per-cell port)
; (%write-number (a-units->cells *newspace-begin*) port)
; (%write-number (a-units->cells *hp*) port)
; (%write-number restart-proc port)
; (%write-page port)
(define (write-image file start-proc id-string)
(if (not (= 0 (remainder bits-per-cell bits-per-io-byte)))
(error "io-bytes to not fit evenly into cells"))
(initialize-memory)
(call-with-output-file file
(lambda (port)
(let ((start (transport start-proc))) ; transport the start-proc
(display id-string port)
(newline port)
(write-page port)
(newline port)
(boot-write-number level port)
(boot-write-number bytes-per-cell port)
(boot-write-number 0 port) ; newspace begin
(boot-write-number (a-units->cells *hp*) port)
(boot-write-number start port) ; start-proc
(write-page port)
(write-descriptor 1 port) ; endianness indicator
(write-heap port)))) ; write out the heap
)
(define bits-per-io-byte 8) ; for writing images
(define (write-page port)
(write-char (ascii->char 12) port))
(define (write-byte byte port)
(write-char (ascii->char byte) port))
(define io-byte-mask
(low-bits -1 bits-per-io-byte))
;(define bits-per-cell -- defined in data.scm
; (* bits-per-byte bytes-per-cell))
(define (big-endian-write-descriptor thing port)
(let loop ((i (- bits-per-cell bits-per-io-byte)))
(cond ((>= i 0)
(write-byte (bitwise-and io-byte-mask
(arithmetic-shift thing (- 0 i))) port)
(loop (- i bits-per-io-byte))))))
(define (little-endian-write-descriptor thing port)
(let loop ((i 0))
(cond ((< i bits-per-cell)
(write-byte (bitwise-and io-byte-mask
(arithmetic-shift thing (- 0 i))) port)
(loop (+ i bits-per-io-byte))))))
(define write-descriptor little-endian-write-descriptor)
(define (boot-write-number n port)
(display n port)
(newline port))
|
