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

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

r7rs/read: #![no-]fold-case, check read's argument type

File size: 3.2 KB
Line 
1(module scheme.read (read)
2  (import (except scheme read)
3          (only chicken : current-read-table fx+ fx= optional unless when)
4          (only chicken case-sensitive define-constant define-inline parameterize))
5
6  ;;;
7  ;;; 2.1 Identifiers
8  ;;;
9
10  ;; XXX Slot 14 indicates whether or not a port is case-folded.
11  ;; Hopefully this doesn't interfere with anything else.
12
13  (define-constant port-fold-case-slot 14)
14
15  (define-inline (port-fold-case p)
16    (##sys#slot p port-fold-case-slot))
17
18  (##sys#set-read-mark!
19   'fold-case
20   (lambda (p)
21     (##sys#setslot p port-fold-case-slot 'fold-case)
22     (read p)))
23
24  (##sys#set-read-mark!
25   'no-fold-case
26   (lambda (p)
27     (##sys#setslot p port-fold-case-slot 'no-fold-case)
28     (read p)))
29
30  (set! ##sys#read
31    (let ((read ##sys#read))
32      (lambda (port hook)
33        (parameterize ((case-sensitive
34                        (case (port-fold-case port)
35                          ((fold-case) #f)
36                          ((no-fold-case) #t)
37                          (else (case-sensitive)))))
38          (read port hook)))))
39
40  ;;;
41  ;;; 6.13.2 Input
42  ;;;
43
44  (define (data? o)
45    (not (procedure? o)))
46
47  (define (unthunk o fail)
48    (let ((v (o)))
49      (cond ((data? v) v)
50            ((eq? v o)
51             (fail "self-referential datum"))
52            (else
53             (unthunk v fail)))))
54
55  ;; Fills holes in `o` destructively.
56  (define (unthunkify! o fail)
57    (let loop! ((o o))
58      (cond ((pair? o)
59             (if (data? (car o))
60                 (loop! (car o))
61                 (set-car! o (unthunk (car o) fail)))
62             (if (data? (cdr o))
63                 (loop! (cdr o))
64                 (set-cdr! o (unthunk (cdr o) fail))))
65            ((vector? o)
66             (let ((len (vector-length o)))
67               (do ((i 0 (fx+ i 1)))
68                   ((fx= i len))
69                 (let ((v (vector-ref o i)))
70                   (if (data? v)
71                       (loop! v)
72                       (vector-set! o i (unthunk v fail))))))))))
73
74  (define (read-with-shared-structure port)
75
76    (define read-table (current-read-table))
77    (unless (##sys#slot read-table 3)
78      (##sys#setslot read-table 3 (##sys#make-vector 256 #f)))
79
80    (define read-hash/orig  (##sys#slot (##sys#slot read-table 3) 35))
81    (define read-equal/orig (##sys#slot (##sys#slot read-table 3) 61))
82
83    (define shared '())
84    (define (register-shared! n thunk)
85      (set! shared (cons (cons n thunk) shared)))
86
87    (define (read-hash/shared _ p n)
88      (##sys#read-char-0 p)
89      (cond ((assv n shared) => cdr)
90            (else (##sys#read-error p "undefined datum" n))))
91
92    (define (read-equal/shared _ p n)
93      (##sys#read-char-0 p)
94      (letrec ((o (begin
95                    (register-shared! n (lambda () o))
96                    (##sys#read p ##sys#default-read-info-hook))))
97        o))
98
99    (define (read/shared p)
100      (let ((o (##sys#read port ##sys#default-read-info-hook)))
101         (when (pair? shared)
102           (unthunkify! o (lambda a (apply ##sys#read-error p a))))
103         o))
104
105    (dynamic-wind
106     (lambda ()
107       (##sys#setslot (##sys#slot read-table 3) 35 read-hash/shared)
108       (##sys#setslot (##sys#slot read-table 3) 61 read-equal/shared))
109     (lambda ()
110       (##sys#check-input-port port #t 'read)
111       (read/shared port))
112     (lambda ()
113       (##sys#setslot (##sys#slot read-table 3) 35 read-hash/orig)
114       (##sys#setslot (##sys#slot read-table 3) 61 read-equal/orig))))
115
116  (: read (#!optional input-port -> *))
117  (define (read . port)
118    (read-with-shared-structure
119     (optional port (current-input-port)))))
Note: See TracBrowser for help on using the repository browser.