source: project/release/4/r7rs/trunk/scheme.read.scm @ 30900

Last change on this file since 30900 was 30900, checked in by evhan, 6 years ago

r7rs: add missing ":" import for scheme.read & write

File size: 2.3 KB
Line 
1(module scheme.read (read)
2  (import (except scheme read)
3          (only chicken : current-read-table fx+ fx= optional unless when))
4
5  (define (data? o)
6    (not (procedure? o)))
7
8  (define (unthunk o fail)
9    (let ((v (o)))
10      (cond ((data? v) v)
11            ((eq? v o)
12             (fail "self-referential datum"))
13            (else
14             (unthunk v fail)))))
15
16  ;; Fills holes in `o` destructively.
17  (define (unthunkify! o fail)
18    (let loop! ((o o))
19      (cond ((pair? o)
20             (if (data? (car o))
21                 (loop! (car o))
22                 (set-car! o (unthunk (car o) fail)))
23             (if (data? (cdr o))
24                 (loop! (cdr o))
25                 (set-cdr! o (unthunk (cdr o) fail))))
26            ((vector? o)
27             (let ((len (vector-length o)))
28               (do ((i 0 (fx+ i 1)))
29                   ((fx= i len))
30                 (let ((v (vector-ref o i)))
31                   (if (data? v)
32                       (loop! v)
33                       (vector-set! o i (unthunk v fail))))))))))
34
35  (define (read-with-shared-structure port)
36
37    (define read-table (current-read-table))
38    (unless (##sys#slot read-table 3)
39      (##sys#setslot read-table 3 (##sys#make-vector 256 #f)))
40
41    (define read-hash/orig  (##sys#slot (##sys#slot read-table 3) 35))
42    (define read-equal/orig (##sys#slot (##sys#slot read-table 3) 61))
43
44    (define shared '())
45    (define (register-shared! n thunk)
46      (set! shared (cons (cons n thunk) shared)))
47
48    (define (read-hash/shared _ p n)
49      (##sys#read-char-0 p)
50      (cond ((assv n shared) => cdr)
51            (else (##sys#read-error p "undefined datum" n))))
52
53    (define (read-equal/shared _ p n)
54      (##sys#read-char-0 p)
55      (letrec ((o (begin
56                    (register-shared! n (lambda () o))
57                    (##sys#read p ##sys#default-read-info-hook))))
58        o))
59
60    (define (read/shared p)
61      (let ((o (##sys#read port ##sys#default-read-info-hook)))
62         (when (pair? shared)
63           (unthunkify! o (lambda a (apply ##sys#read-error p a))))
64         o))
65
66    (dynamic-wind
67     (lambda ()
68       (##sys#setslot (##sys#slot read-table 3) 35 read-hash/shared)
69       (##sys#setslot (##sys#slot read-table 3) 61 read-equal/shared))
70     (lambda ()
71       (read/shared port))
72     (lambda ()
73       (##sys#setslot (##sys#slot read-table 3) 35 read-hash/orig)
74       (##sys#setslot (##sys#slot read-table 3) 61 read-equal/orig))))
75
76  (: read (#!optional input-port -> *))
77  (define (read . port)
78    (read-with-shared-structure
79     (optional port (current-input-port)))))
Note: See TracBrowser for help on using the repository browser.