今回は、基本となるデータをフリーストアに書き込み、それを読み出します。ただし、掲載したソースはSCMLIB2-0.7.3以降でしか動作しませんのでダウンロードして差し換えてください。
ひとまず、以下にソースを掲載します。行頭に行番号を付加してあります。
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にこの文書を改訂したと同時にアップデートしてあります。新たにダウンロードして、それらを利用してください。
使い方は後ほど示します。改訂前と比べ、このソースを読むことは少し楽しくなっています。構造体のようなものを手の込んだ方法で実装しているのは変わりませんが多態のような利用も想定しています。使い方は従来どおり面白いものになっていると思います。
ここでサポートするデータには以下のものがあります。
nilintegercharpairvectorint-vectorstring
symbolはまだサポートしていません。これらのデータは全て参照（アドレス）を介してアクセスされます。上に掲載したコードは、いわゆるアクセサです。一種類の型についてインスタンスをひとつしか持っていません。したがって、これらはクラスとは違ったものとして捉えてください。こららを用いること及びバイナリバッファの特性からデータアクセスはとても遅くなっています。現在のバイナリバッファはバイト単位でしかアクセスできません。32ビットや64ビットのCPUを使っていてもデータアクセスは8ビット単位でアクセスします。これは後に改良する予定です。
また、pair型やvector型などデータの参照を含む複合データは通常、処理系を実装する際には最適化されます。つまり、数や文字など他の言語ではスカラー型と呼ばれるデータは参照ではなく即値を格納する工夫がされることが多くあります。しかし、ここではそれを行っていません。
以上の欠点はありますが最初は設計と実装を単純にするため敢えて性能は犠牲にします。
フォーマット
以下にデータのフォーマットを型毎に表形式で示します。
ヘッダ部
| オフセット | 名前 | サイズ(bytes) |
|---|---|---|
| 0 | tag | 4 |
nil| オフセット | 名前 | サイズ(bytes) | 値 |
|---|---|---|---|
| 0 | tag | 4 | type-nil |
| 4 | car | 4 | *NIL* |
| 8 | car | 4 | *NIL* |
integer| オフセット | 名前 | サイズ(bytes) | 値 |
|---|---|---|---|
| 0 | tag | 4 | type-integer |
| 4 | val | 4 | 整数値 |
char| オフセット | 名前 | サイズ(bytes) | 値 |
|---|---|---|---|
| 0 | tag | 4 | type-char |
| 4 | val | 4 | UNICODE |
pair| オフセット | 名前 | サイズ(bytes) | 値 |
|---|---|---|---|
| 0 | tag | 4 | type-pair |
| 4 | car | 4 | CARポインタ |
| 8 | cdr | 4 | CDRポインタ |
vector| オフセット | 名前 | サイズ(bytes) | 値 |
|---|---|---|---|
| 0 | tag | 4 | type-vector |
| 4 | length | 4 | 要素数 |
| 8 | value | 4 | ポインタ |
int-vector（主に内部で文字列処理に用いる）| オフセット | 名前 | サイズ(bytes) | 値 |
|---|---|---|---|
| 0 | tag | 4 | type-int-vector |
| 4 | length | 4 | 要素数 |
| 8 | value | 4 | ポインタ |
配列の要素は即値（32ビット符号付整数）
string| オフセット | 名前 | サイズ(bytes) | 値 |
|---|---|---|---|
| 0 | tag | 4 | type-char |
| 4 | length | 4 | 要素数 |
| 8 | value | 4 | ポインタ |
バイト配列はUTF-8にエンコードされた文字列
配列の要素は即値（8ビット符号無整数）
タグ(tag)
タグは現状32ビット整数を格納します。どの型のデータにも必ず先頭にタグが格納されています。各型に対応するtype-tableの添字となる数値を格納します。しかし、タグにはその他の情報も格納する予定です。assemble-tag関数がタグの値を返します。
pair型
pair型はCARとCDR要素をもっており、どちらにもポインタ(アドレス)を格納します。古くからの用語ではCONSセルとも言います。それらポインタはcore(メモリ)中のデータを指します。CDR部が*NIL*または別のpairを指すことによりリストを形成します。
*NIL*はnil型の唯一のインスタンスを指すポインタを表します。
vector型
vector型は他の言語では配列という表現が一般的です。ただし、配列の各要素は他のデータを指すポインタです。つまりvector型はどんなデータでも格納できます。同じvectorの要素は各々異る型のデータを指していても構いません。
ポインタを格納する領域は別にアロケートして、そのポインタをvalueのアドレスに格納します。（間接参照）vectorは自動伸縮することがないのでこれを変更してvalueの位置に連続した領域を取る代案もあります。（直接参照）
string型
stringは文字列を格納します。vectorと同様ですが格納される各要素はバイト即値です。（ポインタではありません）各要素はUTF-8エンコードされた文字データを表現します。一文字のデータ長はそれぞれ異る可能性がある点に注意してください。本言語の仕様上 mutable です。格納される文字が変更されると文字列全体を格納する連続した領域の長さが伸縮します。したがってvectorとは異り直接参照することは避けるべきです。
int-vector型
これは本言語の外部仕様では利用されません。つまり、本言語を利用してプログラムを記述する者はこれを利用しません。本言語において文字列は常にstringにUTF-8エンコードされた状態で格納されます。
int-vectorは文字列処理のために内部で利用します。UTF-8エンコードされた文字列は各文字が可変長となるため文字列処理には取り扱いが困難となります。文字列を走査あるいは操作する場合にはstringからこのint-vectorに一旦変換をした後に行い後にstringに書き戻します。このときstringのvalue（ポインタ）が示す領域は開放後アロケートし直される場合があります。
使い方
以下のテキストはREPLで式を評価させながらtypes.scmの使い方を示しています。;（セミコロン）から行末までは注釈です。この注釈で使い方を説明してありますので、これを読みつつ式を評価して確認してみてください。
1> ;;types.scm をロードする
2(load "types.scm")
3> ;;integer領域をひとつアロケートし1を格納する
4(vop-integer 1)
567107696
6> ;;型を得る
7((v-integer 'type))
8integer
9> ;;値を得る
10((v-integer 'value))
111
12> ;;ポインタをシンボルiにバインド
13(define i 67107696)
14> ;;新しい整数をアロケートしポインタをiiにバインド
15(define ii (vop-integer 2))
16> ;;iiにポインタを当てる
17((v-integer 'locate) ii)
1867107664
19> ;;型を得る
20((v-integer 'type))
21integer
22> ;;値を得る
23((v-integer 'value))
242
25> ;;最初にアロケートしたデータにポインタを当てる
26((v-integer 'locate) i)
2767107696
28> ;;値を得る
29((v-integer 'value))
301
31> ;;リスト(pair)を作る
32(define lst
33 (vop-cons (vop-integer 1)
34 (vop-cons (vop-integer 2)
35 (vop-cons (vop-integer 3)
36 (vop-cons (vop-integer 9)
37 *NIL*)))))
38> ((v-pair 'locate) lst)
3967107408
40> (begin ((v-pair 'print)) (newline))
41(1 . (2 . (3 . (9 . ()))))
42> ;;CARを得る; ポインタ(アドレス)が戻る
43((v-pair 'car))
4467107632
45> ;;CDRを得る; ポインタ(アドレス)が戻る
46((v-pair 'cdr))
4767107440
48> ;;動的にアクセサにCDRの値を当てる
49;;fに適切なアクセサがバインドされる
50;;型が判らなくても良い
51(define f (core->lambda ((v-pair 'cdr))))
52> ;;型を得る
53((f 'type))
54pair
55> ;;アドレスを得る
56((f 'address))
5767107440
58> ;;動的にアクセサにCDRの値を当てる
59(set! f (core->lambda ((f 'cdr))))
60> ((f 'type))
61pair
62> ;;動的にアクセサにCARの値を当て表示する
63(begin (((core->lambda ((f 'car))) 'print)) (newline))
643
65> (set! f (core->lambda ((f 'cdr))))
66> ((f 'type))
67pair
68> (begin (((core->lambda ((f 'car))) 'print)) (newline))
699
70> (set! f (core->lambda ((f 'cdr))))
71> ((f 'type))
72nil
73> ;;型はnilだったので終端にぶつかったようだ
74;;確認してみよう
75;;次の3つの式は全て同じ値になる筈
76((f 'car))
7767108800
78> ((f 'cdr))
7967108800
80> *NIL*
8167108800
82> ;;vectorをひとつ作ってみる
83(define v (vop-vector 10))
84> v
8567107376
86> ((v-vector 'locate) v)
8767107376
88> ;;各要素に値をバインドする
89(let loop ((i 0))
90 (if (< i 10)
91 (begin
92 ((v-vector 'set!) i (vop-integer (- 10 i)))
93 (loop (+ i 1)))))
94> ;;表示する
95(begin ((v-vector 'print)) (newline))
96#(10 9 8 7 6 5 4 3 2 1)
97> ;;7番目の要素にアクセサを当てて型、値を得る。また、表示する。
98(define iii (core->lambda ((v-vector 'ref) 6)))
99> ((iii 'type))
100integer
101> ((iii 'value))
1024
103> (begin ((iii 'print)) (newline))
1044
105> ;;8番目の要素を8に更新する
106((v-vector 'set!) 7 (vop-integer 8))
107> (begin ((v-vector 'print)) (newline))
108#(10 9 8 7 6 5 4 8 2 1)
109> ;;要素数を得る
110((v-vector 'length))
11110
112> ;;Numb-Lambdaネイティブ文字列からv-stringを作る
113(define s (string->v-string "平成30年酷暑の夏"))
114> ;;stringにアクセサを当てる
115(define t (core->lambda s))
116> ((t 'type))
117string
118> ;;バイト列（UTF-8）として表示
119(begin ((t 'print-as-integer)) (newline))
120#(229 185 179 230 136 144 51 48 229 185 180 233 133 183 230 154 145 227 129 174 229 164 143)
121> ;;文字列として表示
122(begin ((t 'print)) (newline))
123"平成30年酷暑の夏"
124> ;;stringからint-vectorを作る
125(define iv (v-string->v-int-vector s))
126> ;;アクセサを当てる
127(define t (core->lambda iv))
128> ((t 'type))
129int-vector
130> ;;文字列として表示する
131(begin ((t 'print)) (newline))
132"平成30年酷暑の夏"
133> ;;整数(UNICODE)列として表示する
134(begin ((t 'print-as-integer)) (newline))
135#(24179 25104 51 48 24180 37239 26257 12398 22799)
136>
あとがき
以上ですが、いかがでしょうか。たぶん、今回のプログラムについては異論が多いと思われます。しかし、以上のアクセサを使用せずbinary-buffer-store!関数とbinary-buffer-load関数を使って直接データを触ってみるとアクセサは便利であることがわかります。
これらはオブジェクト指向のデータのように見えて、そこ迄は扱い易くはありません。
前述のようにアクセサはクラスではありません。ただし多態のようなアクセスが可能になっています。コアに書くデータを何故オブジェクトにしないかという問いに対しては、こういった基本型を扱うのにオブジェクトを使うとメモリ使用量が増大してしまうためです。SCMLIB2（Numb-Lambdaインタープリタ）では実際にそれを行っています。しかし、それはJavaで記述する上で実行速度を考慮したとき他に選択の余地がなかったためです。
アクセサは常に1インスタンスのみが利用可能で複数の（同じ型の）データをアクセスする場合にはlocateを使ってアクセスしようとするアドレスを設定する必要があります。
次回はシンボルのデータフォーマットを定義しアクセサを作ります。シンボルが完成すると基本的なデータ型は全て揃います。