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

  1(module scheme.write (display
  2		      write
  3		      write-shared
  4		      write-simple)
  5  (import (rename scheme (display display-simple) (write write-simple))
  6	  (only chicken.base foldl when optional)
  7	  (only chicken.platform feature?)
  8	  (only chicken.type :)
  9	  (only chicken.fixnum fx+ fx= fx<=))
 10
 11  (when (feature? 'csi)
 12    (set! ##sys#repl-print-hook
 13      (lambda (o p)
 14        (write o p)
 15        (newline))))
 16
 17  (define (interesting? o)
 18    (or (pair? o)
 19	(and (vector? o)
 20	     (fx<= 1 (vector-length o)))))
 21
 22  (define (uninteresting? o)
 23    (not (interesting? o)))
 24
 25  (define (display-char c p)
 26    ((##sys#slot (##sys#slot p 2) 2) p c))
 27
 28  (define (display-string s p)
 29    ((##sys#slot (##sys#slot p 2) 3) p s))
 30
 31  ;; Build an alist mapping `interesting?` objects to boolean values
 32  ;; indicating whether those objects occur shared in `o`.
 33  (define (find-shared o cycles-only?)
 34
 35    (define seen '())
 36    (define (seen? x) (assq x seen))
 37    (define (seen! x) (set! seen (cons (cons x 1) seen)))
 38
 39    ;; Walk the form, tallying the number of times each object is
 40    ;; encountered. This has the effect of filling `seen` with
 41    ;; occurence counts for all objects satisfying `interesting?`.
 42    (let walk! ((o o))
 43      (when (interesting? o)
 44	(cond ((seen? o) =>
 45	       (lambda (p)
 46		 (set-cdr! p (fx+ (cdr p) 1))))
 47	      ((pair? o)
 48	       (seen! o)
 49	       (walk! (car o))
 50	       (walk! (cdr o)))
 51	      ((vector? o)
 52	       (seen! o)
 53	       (let ((len (vector-length o)))
 54		 (do ((i 0 (fx+ i 1)))
 55		     ((fx= i len))
 56		   (walk! (vector-ref o i))))))
 57	;; If we're only interested in cycles and this object isn't
 58	;; self-referential, discount it (resulting in `write` rather
 59	;; than `write-shared` behavior).
 60	(when cycles-only?
 61	  (let ((p (seen? o)))
 62	    (when (fx<= (cdr p) 1)
 63	      (set-cdr! p 0))))))
 64
 65    ;; Mark shared objects #t, unshared objects #f.
 66    (foldl (lambda (a p)
 67	     (if (fx<= (cdr p) 1)
 68		 (cons (cons (car p) #f) a)
 69		 (cons (cons (car p) #t) a)))
 70	   '()
 71	   seen))
 72
 73  (define (write-with-shared-structure writer obj cycles-only? port)
 74
 75    (define label 0)
 76    (define (assign-label! pair)
 77      (set-cdr! pair label)
 78      (set! label (fx+ label 1)))
 79
 80    (define shared
 81      (find-shared obj cycles-only?))
 82
 83    (define (write-interesting/shared o)
 84      (cond ((pair? o)
 85	     (display-char #\( port)
 86	     (write/shared (car o))
 87	     (let loop ((o (cdr o)))
 88	       (cond ((null? o)
 89		      (display-char #\) port))
 90		     ((and (pair? o)
 91			   (not (cdr (assq o shared))))
 92		      (display-char #\space port)
 93		      (write/shared (car o))
 94		      (loop (cdr o)))
 95		     (else
 96		      (display-string " . " port)
 97		      (write/shared o)
 98		      (display-char #\) port)))))
 99	    ((vector? o)
100	     (display-string "#(" port)
101	     (write/shared (vector-ref o 0))
102	     (let ((len (vector-length o)))
103	       (do ((i 1 (fx+ i 1)))
104		   ((fx= i len)
105		    (display-char #\) port))
106		 (display-char #\space port)
107		 (write/shared (vector-ref o i)))))))
108
109    (define (write/shared o)
110      (if (uninteresting? o)
111	  (writer o port)
112	  (let* ((p (assq o shared))
113		 (d (cdr p)))
114	    (cond ((not d)
115		   (write-interesting/shared o))
116		  ((number? d)
117		   (display-char #\# port)
118		   (writer d port)
119		   (display-char #\# port))
120		  (else
121		   (display-char #\# port)
122		   (writer label port)
123		   (display-char #\= port)
124		   (assign-label! p)
125		   (write-interesting/shared o))))))
126
127    (write/shared obj))
128
129  (: display (* #!optional output-port -> undefined))
130  (define (display o . p)
131    (write-with-shared-structure
132     display-simple
133     o
134     #t
135     (optional p (current-output-port))))
136
137  (: write (* #!optional output-port -> undefined))
138  (define (write o . p)
139    (write-with-shared-structure
140     write-simple
141     o
142     #t
143     (optional p (current-output-port))))
144
145  (: write-shared (* #!optional output-port -> undefined))
146  (define (write-shared o . p)
147    (write-with-shared-structure
148     write-simple
149     o
150     #f
151     (optional p (current-output-port)))))