Fcalva/chibi-scheme
1
0
Fork 0
mirror of https://github.com/ashinn/chibi-scheme.git synced 2025-07-08 05:27:35 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions

Updating srfi-38 to support writing labels only for values which cause cycles.

Browse source 
Also switching to srfi-69 for efficiency.
This commit is contained in:
Alex Shinn 2012-08-12 21:28:36 +09:00
parent 10b1110439
commit 736ff434e6
2 changed files with 40 additions and 35 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

73
lib/srfi/38.scm
View file

@ -3,58 +3,63 @@
;; This code was written by Alex Shinn in 2009 and placed in the ;; This code was written by Alex Shinn in 2009 and placed in the
;; Public Domain. All warranties are disclaimed. ;; Public Domain. All warranties are disclaimed.
(define (extract-shared-objects x) (define (extract-shared-objects x cyclic-only?)
(let ((seen '())) (let ((seen (make-hash-table eq?)))
;; find shared references
(let find ((x x)) (let find ((x x))
(cond (let ((type (type-of x)))
((assq x seen) (cond ;; only interested in pairs, vectors and records
=> (lambda (cell) (set-cdr! cell (+ (cdr cell) 1)))) ((or (pair? x) (vector? x) (and type (type-printer type)))
((pair? x) ;; increment the count
(set! seen (cons (cons x 1) seen)) (hash-table-update!/default seen x (lambda (n) (+ n 1)) 0)
(find (car x)) ;; walk if this is the first time
(find (cdr x)))
((vector? x)
(set! seen (cons (cons x 1) seen))
(do ((i 0 (+ i 1)))
((= i (vector-length x)))
(find (vector-ref x i))))
(else
(let ((type (type-of x)))
(cond (cond
((and type (type-printer type)) ((> (hash-table-ref seen x) 1))
(set! seen (cons (cons x 1) seen)) ((pair? x)
(find (car x))
(find (cdr x)))
((vector? x)
(do ((i 0 (+ i 1)))
((= i (vector-length x)))
(find (vector-ref x i))))
(else
(let ((num-slots (type-num-slots type))) (let ((num-slots (type-num-slots type)))
(let lp ((i 0)) (let lp ((i 0))
(cond (cond ((< i num-slots)
((< i num-slots) (find (slot-ref type x i))
(find (slot-ref type x i)) (lp (+ i 1))))))))
(lp (+ i 1)))))))))))) ;; delete if this shouldn't count as a shared reference
(let extract ((ls seen) (res '())) (if (and cyclic-only?
(cond (<= (hash-table-ref/default seen x 0) 1))
((null? ls) res) (hash-table-delete! seen x))))))
((> (cdar ls) 1) (extract (cdr ls) (cons (cons (caar ls) #f) res))) ;; extract shared references
(else (extract (cdr ls) res)))))) (let ((res (make-hash-table eq?)))
(hash-table-walk
seen
(lambda (k v) (if (> v 1) (hash-table-set! res k #t))))
res)))
(define (write-with-shared-structure x . o) (define (write-with-shared-structure x . o)
(let ((out (if (pair? o) (car o) (current-output-port))) (let ((out (if (pair? o) (car o) (current-output-port)))
(shared (extract-shared-objects x)) (shared
(extract-shared-objects x (and (pair? o) (pair? (cdr o)) (cadr o))))
(count 0)) (count 0))
(define (check-shared x prefix cont) (define (check-shared x prefix cont)
(let ((cell (assq x shared))) (let ((index (hash-table-ref/default shared x #f)))
(cond ((and cell (cdr cell)) (cond ((integer? index)
(display prefix out) (display prefix out)
(display "#" out) (display "#" out)
(write (cdr cell) out) (write index out)
(display "#" out)) (display "#" out))
(else (else
(cond (cell (cond (index
(display prefix out) (display prefix out)
(display "#" out) (display "#" out)
(write count out) (write count out)
(display "=" out) (display "=" out)
(set-cdr! cell count) (hash-table-set! shared x count)
(set! count (+ count 1)))) (set! count (+ count 1))))
(cont x cell))))) (cont x index)))))
(let wr ((x x)) (let wr ((x x))
(check-shared (check-shared
x x

2
lib/srfi/38.sld
View file

@ -1,6 +1,6 @@
(define-library (srfi 38) (define-library (srfi 38)
(import (scheme) (chibi ast)) (import (scheme) (srfi 69) (chibi ast))
(export write-with-shared-structure write/ss (export write-with-shared-structure write/ss
read-with-shared-structure read/ss) read-with-shared-structure read/ss)
(include "38.scm")) (include "38.scm"))