Changeset 30898 in project


Ignore:
Timestamp:
05/20/14 12:31:02 (6 years ago)
Author:
evhan
Message:

r7rs: read/write for shared data

Location:
release/4/r7rs/trunk
Files:
4 edited

Legend:

Unmodified
Added
Removed
  • release/4/r7rs/trunk/r7rs.setup

    r30325 r30898  
    55
    66(define scheme-modules
    7   '("case-lambda" "char" "complex" "cxr" "eval" "file" "inexact" "lazy" "load" "process-context" "r5rs" "read" "repl" "time" "write")) ;XXX
     7  '("case-lambda" "char" "complex" "cxr" "eval" "file" "inexact" "lazy" "load" "process-context" "r5rs" "read" "repl" "time" "write"))
    88
    99(make (("r7rs-compile-time.so" ("r7rs-compile-time.scm" "r7rs-compile-time-module.scm")
  • release/4/r7rs/trunk/scheme.char.scm

    r30890 r30898  
    4848(define-extended-arity-comparator string-ci>=? %string-ci>=? ##sys#check-string)
    4949
    50 (: char-foldcase (char --> char))
     50(: char-foldcase (char -> char))
    5151(define (char-foldcase c) (char-downcase c))
    5252
    53 (: string-foldcase (string --> string))
     53(: string-foldcase (string -> string))
    5454(define (string-foldcase s) (string-map char-foldcase s))
    5555
    56 (: digit-value (char --> (or fixnum boolean)))
     56(: digit-value (char -> (or fixnum boolean)))
    5757(define (digit-value c)
    5858  (let ((i (char->integer c)))
  • release/4/r7rs/trunk/scheme.read.scm

    r29323 r30898  
    11(module scheme.read (read)
    2   (import scheme))
     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)))))
  • release/4/r7rs/trunk/scheme.write.scm

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