-
Notifications
You must be signed in to change notification settings - Fork 1
/
writer.scm
110 lines (91 loc) · 3.13 KB
/
writer.scm
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
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
(use gauche.sequence)
(use gauche.uvector)
;;; address-space (buffer size relocation-list symbol-table)
;;; relocation-list (address ...)
;;; symbol-table ((symbol . saddr-of-symbol) ...)
(define word-size 4)
(define (make-address-space)
(list (make-u8vector 256 0) 0 '() '()))
(define (as-allocate as size)
(define (round-up-to-8 num)
(let1 r (remainder num 8)
(if (= r 0)
num
(+ num (- 8 r)))))
(let* ((address (cadr as))
(next (+ address (round-up-to-8 size))))
(let1 alloc (u8vector-length (car as))
(if (> next alloc)
(begin
(while (> next alloc)
(set! alloc (+ alloc (quotient alloc 2))))
(let1 newvec (make-u8vector alloc)
(u8vector-copy! newvec 0 (car as))
(set-car! as newvec)))))
(set! (cadr as) next)
address))
(define (as-put as obj)
(cond ((integer? obj) (as-put-integer as obj))
((pair? obj) (as-put-pair as obj))
((string? obj) (as-put-string as obj))
((symbol? obj) (as-put-symbol as obj))
((vector? obj) (as-put-vector as obj))
((u8vector? obj) (as-put-bytevector as obj))
((null? obj) (as-put-null as obj))
((eq? #t obj) (as-put-true as obj))
((eq? #f obj) (as-put-false as obj))
(else (errorf "cannot as-put object ~a" obj))))
(define (as-put-integer as num)
(ash num 3))
(define (as-put-pair as pair)
(let* ((addr (as-allocate as 8))
(a (as-put as (car pair)))
(b (as-put as (cdr pair))))
(as-word-set! as addr a)
(as-word-set! as (+ 4 addr) b)
(logior addr 1)))
(define (as-put-string as str)
(let1 addr (as-allocate as (+ word-size (string-length str)))
(as-word-set! as addr (string-length str))
(as-u8vector-copy! as (+ word-size addr) (string->u8vector str))
(logior addr 2)))
(define (as-put-symbol as sym)
(let* ((str (symbol->string sym))
(len (string-length str))
(addr (as-allocate as (+ word-size len))))
(as-word-set! as addr len)
(as-u8vector-copy! as (+ word-size addr) (string->u8vector str))
(logior addr 3)))
(define (as-put-vector as vec)
(let1 addr (as-allocate as (* (+ 1 (vector-length vec)) word-size))
(as-word-set! as addr (vector-length vec))
(for-each-with-index (lambda (i obj)
(as-word-set! as (+ addr (* (+ i 1) word-size))
(as-put as obj)))
vec)
(logior addr 4)))
(define (as-put-bytevector as bytes)
(let1 addr (as-allocate as (+ (* 2 word-size) (u8vector-length bytes)))
(as-word-set! as addr 2)
(as-word-set! as (+ 4 addr) (u8vector-length bytes))
(as-u8vector-copy! as (+ 8 addr) bytes)
(logior addr 6)))
(define (as-put-null as num)
#x0f)
(define (as-put-true as num)
#x1f)
(define (as-put-false as num)
#x2f)
(define (as-word-set! as address value)
(for-each-with-index (lambda (i byte)
(u8vector-set! (car as)
(+ address i)
(remainder byte 256)))
(list (quotient value (* 256 256 256))
(quotient value (* 256 256))
(quotient value 256)
value)))
(define (as-u8vector-copy! as address uv)
(u8vector-copy! (car as) address uv))
(define (write-address-space as out)
(write-block (car as) out 0 (cadr as)))