~ chicken-r7rs (master) /scheme.read.scm

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