今回は、シンボルをフリーストアに書き込み、それを読み出します。
ひとまず、以下にソースを掲載します。これは前回提示したものと（前回の記事を改訂したため）同じです。行頭に行番号を付加してあります。
1(load "standard.scm")
2(load "unicode.scm")
3(load "malloc.scm")
4(load "hashtab.scm")
5
6(define *core* (binary-buffer-create #x4000000))
7(define *fountain* (malloc *core* #x40000 #x4000000))
8(define *symbol-table-size* 256)
9
10(define *type-table*
11 (vector
12 'unspecified
13 'nil
14 'symbol
15 'number
16 'integer
17 'char
18 'pair
19 'vector
20 'int-vector
21 'string))
22
23(define find-type
24 (lambda (sym)
25 (let loop ((i 0))
26 (if (>= i (vector-length *type-table*))
27 '()
28 (if (eq? sym (vector-ref *type-table* i))
29 i
30 (loop (+ i 1)))))))
31
32(define type-unspecified (find-type 'unspecified))
33(define type-nil (find-type 'nil))
34(define type-symbol (find-type 'symbol))
35(define type-number (find-type 'number))
36(define type-integer (find-type 'integer))
37(define type-char (find-type 'char))
38(define type-pair (find-type 'pair))
39(define type-vector (find-type 'vector))
40(define type-int-vector (find-type 'int-vector))
41(define type-string (find-type 'string))
42
43(define tag->type-number (lambda (tag) (logand tag #x7ff)))
44
45(define assemble-tag (lambda (type) (logor type)))
46
47(define tag->symbol
48 (lambda (tag) (vector-ref *type-table* (tag->type-number tag))))
49
50(define retrieve-genealogy
51 (lambda (m genealogy)
52 (let loop ((g genealogy))
53 (if (null? g)
54 '()
55 (let ((f ((car g) m)))
56 (if (null? f)
57 (loop (cdr g))
58 f))))))
59
60(define v-base-template
61 (lambda ()
62 (let ((^genealogy '()) ; certainly '() but not *NIL*
63 (^address 0))
64 (define ^addisp
65 (lambda (m)
66 (cond
67 ((eq? m 'locate)
68 (lambda (address)
69 (set! ^address address)
70 address))
71 ((eq? m 'address) (lambda () ^address))
72 ((eq? m 'tag)
73 (lambda () (binary-buffer-load *core* ^address 'tetra)))
74 ((eq? m 'type) (lambda () (tag->symbol ((^dispatch 'tag)))))
75 ((eq? m 'p) (lambda (x) (eq? ((x 'type)) ((^dispatch 'type)))))
76 ((eq? m 'eval) (lambda () ^address))
77 ((eq? m 'print)
78 (lambda () (display "*UNSPECIFIED*") *UNSPECIFIED*))
79 ;;
80 ((eq? m 'core-size) (lambda () 12))
81 ((eq? m 'init!)
82 (lambda ()
83 ((^dispatch 'store-tag!))
84 ((^dispatch 'address))))
85 ((eq? m 'store-tag!)
86 (lambda ()
87 (binary-buffer-store!
88 *core* ^address (assemble-tag type-unspecified) 'tetra)))
89 ((eq? m 'give-way)
90 (lambda (son)
91 (set! ^genealogy (cons son ^genealogy))
92 ^dispatch))
93 (else
94 (display "; unknown message. (")
95 (display m)
96 (display ")")
97 (newline)
98 *UNSPECIFIED*))))
99 (set! ^genealogy (cons ^addisp ^genealogy))
100 (define ^dispatch
101 (lambda (m)
102 (retrieve-genealogy m ^genealogy)))
103 ^dispatch)))
104
105(define *UNSPECIFIED* (v-base-template))
106
107(define v-unspecified
108 (let ((^dispatch (v-base-template)))
109 (define ^addisp
110 (lambda (m)
111 (cond
112 ((eq? m 'store-tag!)
113 (lambda ()
114 (binary-buffer-store!
115 *core* ((^dispatch 'address))
116 (assemble-tag type-unspecified) 'tetra)))
117 (else '()))))
118 ((^dispatch 'give-way) ^addisp)))
119
120(define v-nil
121 (let ((^dispatch (v-base-template)))
122 (define ^addisp
123 (lambda (m)
124 (cond
125 ((eq? m 'print) (lambda () (display "()") *UNSPECIFIED*))
126 ((eq? m 'store-tag!)
127 (lambda ()
128 (binary-buffer-store!
129 *core* ((^dispatch 'address)) (assemble-tag type-nil) 'tetra)))
130 ((eq? m 'car)
131 (let ((address ((^dispatch 'address))))
132 (lambda () (binary-buffer-load *core* (+ address 4) 'tetra))))
133 ((eq? m 'cdr)
134 (let ((address ((^dispatch 'address))))
135 (lambda () (binary-buffer-load *core* (+ address 8) 'tetra))))
136 ;;
137 ((eq? m 'init!)
138 (lambda ()
139 ((^dispatch 'store-tag!))
140 ;; think of these as signatures.
141 (let ((address ((^dispatch 'address))))
142 (binary-buffer-store! *core* (+ address 4) address 'tetra)
143 (binary-buffer-store! *core* (+ address 8) address 'tetra)
144 address)))
145 (else '()))))
146 ((^dispatch 'give-way) ^addisp)))
147
148(define v-pair
149 (let ((^dispatch (v-base-template)))
150 (define ^addisp
151 (lambda (m)
152 (cond
153 ((eq? m 'car)
154 (lambda ()
155 (binary-buffer-load
156 *core* (+ ((^dispatch 'address)) 4) 'tetra)))
157 ((eq? m 'cdr)
158 (lambda ()
159 (binary-buffer-load
160 *core* (+ ((^dispatch 'address)) 8) 'tetra)))
161 ((eq? m 'set-car!)
162 (lambda (p)
163 (binary-buffer-store!
164 *core* (+ ((^dispatch 'address)) 4) p 'tetra)))
165 ((eq? m 'set-cdr!)
166 (lambda (p)
167 (binary-buffer-store!
168 *core* (+ ((^dispatch 'address)) 8) p 'tetra)))
169 ((eq? m 'print)
170 (lambda ()
171 (display #\()
172 (let ((o ((^dispatch 'address))))
173 (((core->lambda ((^dispatch 'car))) 'print))
174 (display " . ")
175 (((core->lambda ((^dispatch 'cdr))) 'print))
176 ((^dispatch 'locate) o))
177 (display #\))
178 *UNSPECIFIED*))
179 ;;
180 ((eq? m 'store-tag!)
181 (lambda ()
182 (binary-buffer-store!
183 *core* ((^dispatch 'address))
184 (assemble-tag type-pair) 'tetra)))
185 (else '()))))
186 ((^dispatch 'give-way) ^addisp)))
187
188(define v-number-template
189 (lambda ()
190 (let ((^dispatch (v-base-template)))
191 (define ^addisp
192 (lambda (m)
193 (cond
194 ((eq? m 'value)
195 (lambda ()
196 (binary-buffer-load
197 *core* (+ ((^dispatch 'address)) 4) 'tetra)))
198 ((eq? m 'set-value!)
199 (lambda (x)
200 (binary-buffer-store!
201 *core* (+ ((^dispatch 'address)) 4) x 'tetra)))
202 ((eq? m '+)
203 (lambda (x)
204 (binary-buffer-store!
205 *core* ((^dispatch 'address))
206 (+ ((^dispatch 'value)) ((x 'value))) 'tetra)))
207 ((eq? m '-)
208 (lambda (x)
209 (binary-buffer-store!
210 *core* ((^dispatch 'address))
211 (- ((^dispatch 'value)) ((x 'value))) 'tetra)))
212 ((eq? m '*)
213 (lambda (x)
214 (binary-buffer-store!
215 *core* ((^dispatch 'address))
216 (* ((^dispatch 'value)) ((x 'value))) 'tetra)))
217 ((eq? m '/)
218 (lambda (x)
219 (binary-buffer-store!
220 *core* ((^dispatch 'address))
221 (/ ((^dispatch 'value)) ((x 'value))) 'tetra)))
222 ((eq? m 'print)
223 (lambda () (display ((^dispatch 'value))) *UNSPECIFIED*))
224 ;;
225 ((eq? m 'core-size) (lambda () 8))
226 ((eq? m 'store-tag!)
227 (lambda ()
228 (binary-buffer-store!
229 *core* ((^dispatch 'address))
230 (assemble-tag type-number) 'tetra)))
231 (else '()))))
232 ((^dispatch 'give-way) ^addisp))))
233
234(define v-number (v-number-template))
235
236(define v-integer
237 (let ((^dispatch (v-number-template)))
238 (define ^addisp
239 (lambda (m)
240 (cond
241 ((eq? m 'quotient)
242 (lambda (x)
243 (binary-buffer-store!
244 *core* ((^dispatch 'address))
245 (quotient ((^dispatch 'value)) ((x 'value))) 'tetra)))
246 ((eq? m 'remainer)
247 (lambda (x)
248 (binary-buffer-store!
249 *core* ((^dispatch 'address))
250 (remainder ((^dispatch 'value)) ((x 'value))) 'tetra)))
251 ((eq? m 'print)
252 (lambda () (display ((^dispatch 'value))) *UNSPECIFIED*))
253 ;;
254 ((eq? m 'store-tag!)
255 (lambda ()
256 (binary-buffer-store!
257 *core* ((^dispatch 'address))
258 (assemble-tag type-integer) 'tetra)))
259 (else '()))))
260 ((^dispatch 'give-way) ^addisp)))
261
262(define v-char
263 (let ((^dispatch (v-base-template)))
264 (define ^addisp
265 (lambda (m)
266 (cond
267 ((eq? m 'value)
268 (lambda ()
269 (binary-buffer-load
270 *core* (+ ((^dispatch 'address)) 4) 'tetra)))
271 ((eq? m 'set-value!)
272 (lambda (x)
273 (binary-buffer-store!
274 *core* (+ ((^dispatch 'address)) 4) x 'tetra)))
275 ((eq? m 'print)
276 (lambda ()
277 (display "#\\")
278 (display (integer->char ((^dispatch 'value))))
279 *UNSPECIFIED*))
280 ;;
281 ((eq? m 'core-size) (lambda () 8))
282 ((eq? m 'store-tag!)
283 (lambda ()
284 (binary-buffer-store!
285 *core* ((^dispatch 'address))
286 (assemble-tag type-char) 'tetra)))
287 (else '()))))
288 ((^dispatch 'give-way) ^addisp)))
289
290(define v-vector-template
291 (lambda ()
292 (let ((^dispatch (v-base-template)))
293 (define ^addisp
294 (lambda (m)
295 (cond
296 ((eq? m 'length)
297 (lambda ()
298 (binary-buffer-load
299 *core* (+ ((^dispatch 'address)) 4) 'tetra)))
300 ((eq? m 'value)
301 (lambda ()
302 (binary-buffer-load
303 *core* (+ ((^dispatch 'address)) 8) 'tetra)))
304 ((eq? m 'set-value!)
305 (lambda (a)
306 (binary-buffer-store!
307 *core* (+ ((^dispatch 'address)) 8) a 'tetra)))
308 ((eq? m 'length)
309 (lambda ()
310 (binary-buffer-load
311 *core* (+ ((^dispatch 'address)) 4) 'tetra)))
312 ((eq? m 'set-length!)
313 (lambda (n)
314 (binary-buffer-store!
315 *core* (+ ((^dispatch 'address)) 4) n 'tetra)))
316 ((eq? m 'ref)
317 (lambda (i)
318 (binary-buffer-load
319 *core* (+ ((^dispatch 'value)) (* i 4)) 'tetra)))
320 ((eq? m 'set!)
321 (lambda (i x)
322 (binary-buffer-store!
323 *core* (+ ((^dispatch 'value)) (* i 4)) x 'tetra)))
324 ((eq? m 'print)
325 (lambda ()
326 (display "#(")
327 (let ((n ((^dispatch 'length))))
328 (let loop ((i 0))
329 (if (>= i n)
330 (begin
331 (display ")")
332 *UNSPECIFIED*)
333 (begin
334 (if (> i 0) (display " "))
335 (display ((^dispatch 'ref) i))
336 (loop (+ i 1))))))))
337 ;;
338 ((eq? m 'core-size) (lambda () 12))
339 ((eq? m 'store-tag!)
340 (lambda ()
341 (binary-buffer-store!
342 *core* ((^dispatch 'address))
343 (assemble-tag type-vector) 'tetra)))
344 (else '()))))
345 ((^dispatch 'give-way) ^addisp))))
346
347(define v-vector
348 (let ((^dispatch (v-vector-template)))
349 (define ^addisp
350 (lambda (m)
351 (cond
352 ((eq? m 'print)
353 (lambda ()
354 (display "#(")
355 (let ((n ((^dispatch 'length))))
356 (let loop ((i 0))
357 (if (>= i n)
358 (begin
359 (display #\))
360 *UNSPECIFIED*)
361 (begin
362 (if (> i 0) (display #\space))
363 (let ((o ((^dispatch 'address))))
364 (((core->lambda ((^dispatch 'ref) i)) 'print))
365 ((^dispatch 'locate) o))
366 (loop (+ i 1))))))))
367 (else '()))))
368 ((^dispatch 'give-way) ^addisp)))
369
370(define v-int-vector
371 (let ((^dispatch (v-vector-template)))
372 (define ^addisp
373 (lambda (m)
374 (cond
375 ((eq? m 'print-as-integer)
376 (lambda ()
377 (display "#(")
378 (let ((n ((^dispatch 'length))))
379 (let loop ((i 0))
380 (if (>= i n)
381 (begin
382 (display #\))
383 *UNSPECIFIED*)
384 (begin
385 (if (> i 0) (display #\space))
386 (display ((^dispatch 'ref) i))
387 (loop (+ i 1))))))))
388 ((eq? m 'print)
389 (lambda ()
390 (display #\")
391 (let ((n ((^dispatch 'length))))
392 (let loop ((i 0))
393 (if (>= i n)
394 (begin
395 (display #\")
396 *UNSPECIFIED*)
397 (begin
398 (display (integer->char ((^dispatch 'ref) i)))
399 (loop (+ i 1))))))))
400 ;;
401 ((eq? m 'store-tag!)
402 (lambda ()
403 (binary-buffer-store!
404 *core* ((^dispatch 'address))
405 (assemble-tag type-int-vector) 'tetra)))
406 (else '()))))
407 ((^dispatch 'give-way) ^addisp)))
408
409(define v-string-template
410 (lambda ()
411 (let ((^dispatch (v-vector-template)))
412 (define ^addisp
413 (lambda (m)
414 (cond
415 ((eq? m 'ref)
416 (lambda (i)
417 (binary-buffer-load
418 *core* (+ ((^dispatch 'value)) i) 'byte)))
419 ((eq? m 'set!)
420 (lambda (i x)
421 (binary-buffer-store!
422 *core* (+ ((^dispatch 'value)) i) x 'byte)))
423 ((eq? m 'digest)
424 (lambda () (string-digest ((^dispatch 'address)))))
425 ((eq? m 'print-as-integer)
426 (lambda ()
427 (display #\#)
428 (display #\()
429 (let ((n ((^dispatch 'length))))
430 (let loop ((i 0))
431 (if (< i n)
432 (begin
433 (if (> i 0) (display #\space))
434 (display ((^dispatch 'ref) i))
435 (loop (+ i 1))))))
436 (display #\))
437 *UNSPECIFIED*))
438 ((eq? m 'print-raw)
439 (lambda ()
440 (display (v-string->string ((^dispatch 'address))))
441 *UNSPECIFIED*))
442 ((eq? m 'print)
443 (lambda ()
444 (display #\")
445 ((^addisp 'print-raw))
446 (display #\")
447 *UNSPECIFIED*))
448 ;;
449 ((eq? m 'store-tag!)
450 (lambda ()
451 (binary-buffer-store!
452 *core* ((^dispatch 'address))
453 (assemble-tag type-string) 'tetra)))
454 (else '()))))
455 ((^dispatch 'give-way) ^addisp))))
456
457(define v-string (v-string-template))
458
459(define string-digest
460 (lambda (key)
461 ((v-string 'locate) key)
462 (let ((n ((v-string 'length))))
463 (let loop ((i 0) (acc 0))
464 (if (>= i n)
465 (logand acc #x7ffffffff)
466 (loop (+ i 1) (+ acc ((v-string 'ref) i))))))))
467
468(define v-symbol
469 (let ((^dispatch (v-base-template)))
470 (define ^addisp
471 (lambda (m)
472 (cond
473 ((eq? m 'name)
474 (lambda ()
475 (binary-buffer-load
476 *core* (+ ((^dispatch 'address)) 4) 'tetra)))
477 ((eq? m 'digest)
478 (lambda () (string-digest ((^dispatch 'name)))))
479 ((eq? m 'from-string!)
480 (lambda (s)
481 ;;s must be cloned. Do you know why?
482 ((^dispatch 'set-name!) s)
483 (fun-sethash! ((^dispatch 'address)) *symbol-table*)))
484 ((eq? m 'print)
485 (lambda ()
486 (let ((o ((^dispatch 'address))))
487 ((v-string 'locate) ((^dispatch 'name)))
488 ((v-string 'print-raw))
489 ((v-string 'locate) o))
490 *UNSPECIFIED*))
491 ;;
492 ((eq? m 'set-name!)
493 (lambda (name)
494 (binary-buffer-store!
495 *core* (+ ((^dispatch 'address)) 4) name 'tetra)))
496 ((eq? m 'store-tag!)
497 (lambda ()
498 (binary-buffer-store!
499 *core*
500 ((^dispatch 'address))
501 (assemble-tag type-symbol) 'tetra)))
502 (else '()))))
503 ((^dispatch 'give-way) ^addisp)))
504
505(define core->lambda
506 (let ((table (let ((n (vector-length *type-table*)))
507 (let loop ((i 0) (acc '()))
508 (if (>= i n)
509 (list->vector (reverse acc))
510 (loop (+ i 1)
511 (cons
512 (eval
513 (string->symbol
514 (string-append
515 "v-"
516 (symbol->string
517 (vector-ref *type-table* i)))))
518 acc)))))))
519 (lambda (address)
520 (let ((f (vector-ref
521 table
522 (tag->type-number
523 (binary-buffer-load *core* address 'tetra)))))
524 ((f 'locate) address)
525 f))))
526
527(define *UNSPECIFIED*
528 (let* ((size ((v-unspecified 'core-size)))
529 (address ((*fountain* 'alloc) size)))
530 ((v-unspecified 'locate) address)
531 ((v-unspecified 'init!))
532 address))
533
534(define *NIL*
535 (let* ((size ((v-nil 'core-size)))
536 (address ((*fountain* 'alloc) size)))
537 ((v-nil 'locate) address)
538 ((v-nil 'init!))
539 address))
540
541(define vop-integer
542 (lambda (x)
543 (let* ((p v-integer)
544 (size ((p 'core-size)))
545 (address ((*fountain* 'alloc) size)))
546 ((p 'locate) address)
547 ((p 'init!))
548 ((p 'set-value!) x)
549 ((p 'address)))))
550
551(define vop-char
552 (lambda (x)
553 (let* ((p v-char)
554 (size ((p 'core-size)))
555 (address ((*fountain* 'alloc) size)))
556 ((p 'locate) address)
557 ((p 'init!))
558 ((p 'set-value!) x)
559 ((p 'address)))))
560
561(define vop-cons
562 (lambda (x y)
563 (let* ((p v-pair)
564 (size ((p 'core-size)))
565 (address ((*fountain* 'alloc) size)))
566 ((p 'locate) address)
567 ((p 'init!))
568 ((p 'set-car!) x)
569 ((p 'set-cdr!) y)
570 ((p 'address)))))
571
572(define vop-vector
573 (lambda (n)
574 (let* ((p v-vector)
575 (size ((p 'core-size)))
576 (address ((*fountain* 'alloc) size)))
577 ((p 'locate) address)
578 ((p 'init!))
579 ((p 'set-length!) n)
580 ((p 'set-value!) ((*fountain* 'alloc) (* n 4)))
581 ((p 'address)))))
582
583(define vop-int-vector
584 (lambda (n)
585 (let* ((p v-int-vector)
586 (size ((p 'core-size)))
587 (address ((*fountain* 'alloc) size)))
588 ((p 'locate) address)
589 ((p 'init!))
590 ((p 'set-length!) n)
591 ((p 'set-value!) ((*fountain* 'alloc) (* n 4)))
592 ((p 'address)))))
593
594(define vop-string
595 (lambda (n)
596 (let* ((p v-string)
597 (size ((p 'core-size)))
598 (address ((*fountain* 'alloc) size)))
599 ((p 'locate) address)
600 ((p 'init!))
601 ((p 'set-length!) n)
602 ((p 'set-value!) ((*fountain* 'alloc) n))
603 address)))
604
605(define vop-symbol
606 (lambda ()
607 (let* ((p v-symbol)
608 (size ((p 'core-size)))
609 (address ((*fountain* 'alloc) size)))
610 ((p 'locate) address)
611 ((p 'init!))
612 address)))
613
614(define *symbol-table*
615 (fun-make-hash-table
616 *symbol-table-size*
617 (lambda (x y)
618 (let ((x (begin
619 ((v-symbol 'locate) x)
620 ((v-symbol 'name))))
621 (y (begin
622 ((v-symbol 'locate) y)
623 ((v-symbol 'name)))))
624 (fun-string= x y)))))
625
626(define v-int-vector->utf-8-list
627 (lambda (vec)
628 ((v-int-vector 'locate) vec)
629 (let ((n ((v-int-vector 'length))))
630 (let loop ((i 0) (acc '()))
631 (if (>= i n)
632 (apply append (reverse acc))
633 (loop (+ i 1)
634 (cons (integer->utf-8 ((v-int-vector 'ref) i)) acc)))))))
635
636(define list->v-string
637 (lambda (lst)
638 (let* ((n (length lst))
639 (s ((v-string 'locate) (vop-string n))))
640 (let loop ((lst lst) (i 0))
641 (if (null? lst)
642 s
643 (begin
644 ((v-string 'set!) i (car lst))
645 (loop (cdr lst) (+ i 1))))))))
646
647(define v-int-vector->v-string
648 (lambda (vec)
649 (list->v-string
650 (v-int-vector->utf-8-list vec))))
651
652(define v-string->list
653 (lambda (s)
654 ((v-string 'locate) s)
655 (let ((n ((v-string 'length))))
656 (let loop ((i 0) (j 0) (v 0) (acc '()))
657 (if (>= i n)
658 (reverse acc)
659 (let ((c ((v-string 'ref) i)))
660 (if (<= j 0)
661 (cond
662 ((= (logand c #x80) 0)
663 (loop (+ i 1) 0 0 (cons c acc)))
664 ((= (logand c #xe0) #xc0)
665 (loop (+ i 1) 1 (logand c #x1f) acc))
666 ((= (logand c #xf0) #xe0)
667 (loop (+ i 1) 2 (logand c #x0f) acc))
668 ((= (logand c #xf8) #xf0)
669 (loop (+ i 1) 3 (logand c #x07) acc))
670 ((= (logand c #xfc) #xf8)
671 (loop (+ i 1) 4 (logand c #x03) acc))
672 ((= (logand c #xfe) #xfc)
673 (loop (+ i 1) 5 (logand c #x01) acc))
674 (else
675 (display "v-string->list: leading is wrong.")
676 (newline)
677 (reverse acc)))
678 (if (= (logand c #xc0) #x80)
679 (let ((v (logor (bits-shift-left v 6)
680 (logand c #x3f))))
681 (if (> j 1)
682 (loop (+ i 1) (- j 1) v acc)
683 (loop (+ i 1) 0 0 (cons v acc))))
684 (begin
685 (display "v-string->list: trailing is wrong.")
686 (newline)
687 (reverse acc))))))))))
688
689(define list->v-int-vector
690 (lambda (lst)
691 (let* ((n (length lst))
692 (vec ((v-int-vector 'locate) (vop-int-vector n))))
693 (let loop ((lst lst) (i 0))
694 (if (null? lst)
695 vec
696 (begin
697 ((v-int-vector 'set!) i (car lst))
698 (loop (cdr lst) (+ i 1))))))))
699
700(define v-string->v-int-vector
701 (lambda (s)
702 (list->v-int-vector
703 (v-string->list s))))
704
705(define string->v-int-vector
706 (lambda (s)
707 (let* ((n (string-length s))
708 (vec ((v-int-vector 'locate) (vop-int-vector n))))
709 (let loop ((i 0))
710 (if (>= i n)
711 vec
712 (begin
713 ((v-int-vector 'set!) i (char->integer (string-ref s i)))
714 (loop (+ i 1))))))))
715
716(define string->v-string
717 (lambda (s)
718 (v-int-vector->v-string (string->v-int-vector s))))
719
720(define v-string->string
721 (lambda (s)
722 (let ((o ((v-int-vector 'address))))
723 (v-string->v-int-vector s)
724 (let* ((n ((v-int-vector 'length))) (s (make-string n)))
725 (let loop ((i 0))
726 (if (>= i n)
727 (begin ((v-int-vector 'locate) o) s)
728 (begin
729 (string-set! s i (integer->char ((v-int-vector 'ref) i)))
730 (loop (+ i 1)))))))))
731
732(define string->v-symbol
733 (lambda (s)
734 (vop-symbol)
735 ((v-symbol 'from-string!) (string->v-string s))))
types.scm）
この他にも以下のファイルが必要です。最新版をダウンロードしてください。
standard.scm
unicode.scm
malloc.scm
hashtab.scm
以上のファイルは全て2018-09-18に前回の文書を改訂したと同時にアップデートしてあります。新たにダウンロードして、それらを利用してください。
まずはtypes.scmをロードします。> (load "types.scm")
シンボルをいくつか作ります。> (define a (string->v-symbol "foo"))
> (define b (string->v-symbol "bar"))
> (define c (string->v-symbol "baz"))
> a, b, cをそれぞれ評価します。> a以上の整数（評価値）はポインタ（論理アドレス）です。
67107696
> b
67107504
> c
67107312
>
※これらの操作を行う前にフリーストアからメモリをアロケートしたりしていれば値は変わっている筈です。
それでは、aにアクセサを当ててアクセスしてみます。> ((v-symbol 'locate) a)
67107696
> ((v-symbol 'type))
symbol
> ((v-symbol 'name))
67107600
> (define f (core->lambda ((v-symbol 'name))))
> f
<procedure>
> ((f 'type))
string
> ((f 'print))
"foo"67108832
> *UNSPECIFIED*
67108832v-symbolやfはアクセサです。結果的にfはv-stringと等値です。これらはlambdaを返すlambdaです。したがって、これらを呼び出すとlambdaが帰ってきますので、さらに、それらを評価するため外側にもうひとつ括弧を書きます。（二重括弧）
ここでシンボルがメモリ上でどのように表現されているかを以下の表に示します。
| オフセット | 名前 | サイズ(bytes) | 値 |
|---|---|---|---|
| 0 | tag | 4 | type-symbol |
| 4 | name | 4 | ポインタ( |
同様にb,cでも試してみるとよいと思います。
ところで、((f 'print))を評価した結果、"foo"67108832のようになっています。このとき、"foo"は副作用により表示されます。一方、67108832はNumb-LambdaのREPLが表示しており、これは評価値です。printメッセージでの副作用は改行されないため、このように副作用の結果と評価値が並んで表示されます。また、この評価値は*UNSPECIFIED*と等値であることがわかります。
さて、ここでシンボルと文字列が異るということを示します。同じ綴りを持つシンボルはひとつしか存在できません。一方、文字列は同じ綴りでも複数存在できます。また、シンボルはimmutableですが文字列はmutableです。シンボルのnameメッセージで得た文字列を変更してはいけません。
確認しましょう。> (string->v-symbol "foo")このように
67107696
> a
67107696fooというシンボルは既に存在するためstring->v-symbolで新たにfooという綴りのシンボルを作ろうとしても同じ値のポインタが返ってきます。
上述の性質によりシンボルの比較はポインタのみ比較すれば済みます。つまり、eq?述語で比較できます。> (eq? b (string->v-symbol "bar"))
#t
> (eq? c (string->v-symbol "bar"))
#f
> (eq? c (string->v-symbol "baz"))
#t
>
一方で文字列の比較にeq?述語は使えません。> (eq? (string->v-string "foo") (string->v-string "foo"))
#f
> ((v-symbol 'locate) a)
67107696
> ((v-symbol 'name))
67107600
> (eq? ((v-symbol 'name)) (string->v-string "foo"))
#f
>
文字列の比較にはfun-string=を利用します。ただし、この関数は暫定的なもので将来は別の名前になる可能性があります。> (fun-string= (string->v-string "foo") (string->v-string "foo"))
#t
> (fun-string= ((v-symbol 'name)) (string->v-symbol "foo"))
#t
> (fun-string= ((v-symbol 'name)) (string->v-string "foo"))
#t
> fun-string=の定義はhashtab.scmにあります。読んでみると違いが理解できるとはずです。
シンボルは、*symbol-table*に格納されています。*symbol-table*の実態はハッシュテーブルであり還元すればベクタです。
ハッシュ関数により、このベクタのどのエントリに格納するか決定します。異る綴りのシンボルでもハッシュ値は同じ値をとることがあるためベクタの各エントリはリストとなっています。このリストの要素はCONSセルであり*NIL*で終端されています。このCONSセルのCAR部にシンボルを繋ぎます。CDR部は次のCONSセルか*NIL*を指すことは言うまでもありません。
次にハッシュテーブルの実装（hashtab.scm）を示します。
1(define fun-make-vector
2 (lambda (n)
3 (let ((v (vop-vector n)))
4 ((v-vector 'locate) v)
5 (let loop ((i 0))
6 (if (>= i n)
7 v
8 (begin
9 ((v-vector 'set!) i *NIL*)
10 (loop (+ i 1))))))))
11
12(define fun-null? (lambda (x) (eq? x *NIL*)))
13
14(define fun-integer=
15 (lambda (x y)
16 (= (begin
17 ((v-integer 'locate) x)
18 ((v-integer 'value)))
19 (begin
20 ((v-integer 'locate) y)
21 ((v-integer 'value))))))
22
23(define fun-string=
24 (lambda (s t)
25 (let ((m (begin
26 ((v-string 'locate) s)
27 ((v-string 'length))))
28 (n (begin
29 ((v-string 'locate) t)
30 ((v-string 'length)))))
31 (if (not (= m n))
32 #f
33 (let loop ((i 0))
34 (if (>= i n)
35 #t
36 (if (not (= (begin
37 ((v-string 'locate) s)
38 ((v-string 'ref) i))
39 (begin
40 ((v-string 'locate) t)
41 ((v-string 'ref) i))))
42 #f
43 (loop (+ i 1)))))))))
44
45(define fun-member
46 (lambda (item lst test)
47 (let loop ((p lst))
48 (if (fun-null? p)
49 *NIL*
50 (begin
51 ((v-pair 'locate) p)
52 (if (test ((v-pair 'car)) item)
53 p
54 (loop ((v-pair 'cdr)))))))))
55
56(define fun-pushnew-incomplete
57 (lambda (item place test)
58 (let ((p (fun-member item place test)))
59 (if (fun-null? p)
60 (vop-cons item place)
61 place))))
62
63(define fun-make-hash-table
64 (lambda (size test)
65 (let ((size size)
66 (test test)
67 (vect (fun-make-vector size)))
68 (lambda (op)
69 (cond
70 ((eq? op 'size) (lambda () size))
71 ((eq? op 'test) (lambda () test))
72 ((eq? op 'vect) (lambda () vect))
73 (else (lambda () vect)))))))
74
75(define fun-gethash
76 (lambda (key hash-table)
77 (let ((test ((hash-table 'test)))
78 (vect ((hash-table 'vect)))
79 (h (remainder (((core->lambda key) 'digest))
80 ((hash-table 'size)))))
81 ((v-vector 'locate) vect)
82 (let ((p (fun-member key ((v-vector 'ref) h) test)))
83 (if (fun-null? p)
84 *NIL*
85 (begin
86 ((v-pair 'locate) p)
87 ((v-pair 'car))))))))
88
89(define fun-sethash!
90 (lambda (key hash-table)
91 (let ((test ((hash-table 'test)))
92 (vect ((hash-table 'vect)))
93 (h (remainder (((core->lambda key) 'digest))
94 ((hash-table 'size)))))
95 ((v-vector 'locate) vect)
96 (let ((p (fun-pushnew-incomplete key ((v-vector 'ref) h) test)))
97 ((v-vector 'set!) h p) ;overwrite
98 ((v-pair 'locate) p)
99 ((v-pair 'car))))))
ハッシュテーブルはアクセサがdigestメッセージをハンドル可能なデータを格納することができます。前掲のプログラムリスト中、次の3つがAPIとして利用されます。
fun-make-hash-tablefun-gethashfun-sethash!
> (define ht (fun-make-hash-table 4 fun-string=))
> (fun-sethash! (string->v-string "qux") ht)
67105200
> (fun-sethash! (string->v-string "qux") ht)
67105200
> (fun-sethash! (string->v-string "quux") ht)
67104912
> (fun-sethash! (string->v-string "quux") ht)
67104912
> (fun-gethash (string->v-string "quux") ht)
67104912> (fun-gethash (string->v-string "qux") ht)
67105200
> (fun-gethash (string->v-string "quux") ht)
67104912
>
fun-make-hash-tableはハッシュテーブルを生成します。第1引数にサイズ、第2引数にキーの比較関数を与えます。fun-gethashはハッシュテーブルを検索して見つかれば当該データへのポインタを返します。見つからなければ*NIL*を返します。第1引数はキーを含むデータで、これはdigestメッセージをハンドリングできなければなりません。このdigest値からハッシュ関数が導かれます。第2引数にはハッシュテーブルを与えます。fun-sethash!はfun-gethashと同様ですが見つからなければハッシュテーブルに新しくCONSを作ります。引数はfun-gethashのときと同じです。
あとがき
今回はシンボルの実装を以って基本型のほとんどが完成しました。次回はレキシカルアナライザ（字句解析器）を作るための下準備として正規表現を実装する予定です。またはリストのプリティ・プリントを実装してみるのも良いと考えています。