mirror of
https://github.com/ashinn/chibi-scheme.git
synced 2025-07-07 05:06:37 +02:00
adding srfi-38
This commit is contained in:
Alex Shinn
parent
27a57b6e87
commit
e4b65f83d5
2 changed files with 261 additions and 0 deletions
6
lib/srfi/38.module
Normal file
6
lib/srfi/38.module
Normal file
|
|
@ -0,0 +1,6 @@
|
|||
|
||||
(define-module (srfi 38)
|
||||
(import-immutable (scheme))
|
||||
(export write-with-shared-structure write/ss
|
||||
read-with-shared-structure read/ss)
|
||||
(include "38.scm"))
|
||||
255
lib/srfi/38.scm
Normal file
255
lib/srfi/38.scm
Normal file
|
|
@ -0,0 +1,255 @@
|
|||
;;;; srfi-38.scm - reading and writing shared structures
|
||||
;;
|
||||
;; This code was written by Alex Shinn in 2009 and placed in the
|
||||
;; Public Domain. All warranties are disclaimed.
|
||||
|
||||
(define (extract-shared-objects x)
|
||||
(let ((seen '()))
|
||||
(let find ((x x))
|
||||
(cond
|
||||
((assq x seen)
|
||||
=> (lambda (cell) (set-cdr! cell (+ (cdr cell) 1))))
|
||||
((pair? x)
|
||||
(set! seen (cons (cons x 1) seen))
|
||||
(find (car x))
|
||||
(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))))))
|
||||
(let extract ((ls seen) (res '()))
|
||||
(cond
|
||||
((null? ls) res)
|
||||
((> (cdar ls) 1) (extract (cdr ls) (cons (cons (caar ls) #f) res)))
|
||||
(else (extract (cdr ls) res))))))
|
||||
|
||||
(define (write-with-shared-structure x . o)
|
||||
(let ((out (if (pair? o) (car o) (current-output-port)))
|
||||
(shared (extract-shared-objects x))
|
||||
(count 0))
|
||||
(define (check-shared x prefix cont)
|
||||
(let ((cell (assq x shared)))
|
||||
(cond ((and cell (cdr cell))
|
||||
(display prefix out)
|
||||
(display "#" out)
|
||||
(write (cdr cell))
|
||||
(display "#" out))
|
||||
(else
|
||||
(cond (cell
|
||||
(display prefix out)
|
||||
(display "#=" out)
|
||||
(write count out)
|
||||
(set-cdr! cell count)
|
||||
(set! count (+ count 1))))
|
||||
(cont x)))))
|
||||
(cond
|
||||
((null? shared)
|
||||
(write x out))
|
||||
(else
|
||||
(let wr ((x x))
|
||||
(check-shared
|
||||
x
|
||||
""
|
||||
(lambda (x)
|
||||
(cond
|
||||
((pair? x)
|
||||
(display "(" out)
|
||||
(wr (car x))
|
||||
(let lp ((ls (cdr x)))
|
||||
(check-shared
|
||||
ls
|
||||
" . "
|
||||
(lambda (ls)
|
||||
(cond ((null? ls))
|
||||
((pair? ls)
|
||||
(display " " out)
|
||||
(wr (car ls))
|
||||
(lp (cdr ls)))
|
||||
(else
|
||||
(display " . " out)
|
||||
(wr ls))))))
|
||||
(display ")" out))
|
||||
((vector? x)
|
||||
(display "#(" out)
|
||||
(let ((len (vector-length x)))
|
||||
(cond ((> len 0)
|
||||
(wr (vector-ref x 0))
|
||||
(do ((i 1 (+ i 1)))
|
||||
((= i len))
|
||||
(display " " out)
|
||||
(wr (vector-ref x i))))))
|
||||
(display ")" out))
|
||||
(else
|
||||
(write x out))))))))))
|
||||
|
||||
(define write/ss write-with-shared-structure)
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(define (skip-line in)
|
||||
(let ((c (read-char in)))
|
||||
(if (not (or (eof-object? c) (eqv? c #\newline)))
|
||||
(skip-line in))))
|
||||
|
||||
(define (skip-whitespace in)
|
||||
(case (peek-char in)
|
||||
((#\space #\tab #\newline #\return)
|
||||
(read-char in)
|
||||
(skip-whitespace in))
|
||||
((#\;)
|
||||
(skip-line in)
|
||||
(skip-whitespace in))))
|
||||
|
||||
(define (skip-comment in depth)
|
||||
(case (read-char in)
|
||||
((#\#) (skip-comment in (if (eqv? #\| (peek-char in)) (+ depth 1) depth)))
|
||||
((#\|) (if (eqv? #\# (peek-char in))
|
||||
(if (zero? depth) (read-char in) (skip-comment in (- depth 1)))
|
||||
(skip-comment in depth)))
|
||||
(else (if (eof-object? (peek-char in))
|
||||
(error "unterminated #| comment")
|
||||
(skip-comment in depth)))))
|
||||
|
||||
(define delimiters
|
||||
'(#\( #\) #\[ #\] #\space #\tab #\newline #\return))
|
||||
|
||||
(define read-with-shared-structure
|
||||
(let ((read read))
|
||||
(lambda o
|
||||
(let ((in (if (pair? o) (car o) (current-input-port)))
|
||||
(shared '()))
|
||||
(define (read-label res)
|
||||
(let ((c (char-downcase (peek-char in))))
|
||||
(if (if (char-numeric? c) #t (memv c '(#\a #\b #\c #\d #\e)))
|
||||
(read-label (cons (read-char in) res))
|
||||
(list->string (reverse res)))))
|
||||
(define (read-number base)
|
||||
(let* ((str (read-label '()))
|
||||
(n (string->number str base)))
|
||||
(if (or (not n) (not (memv (peek-char in) delimiters)))
|
||||
(error "read error: invalid number syntax" str (peek-char in))
|
||||
n)))
|
||||
(define (read-float-tail in) ;; called only after a leading period
|
||||
(let lp ((res 0.0) (k 0.1))
|
||||
(let ((c (peek-char in)))
|
||||
(cond
|
||||
((char-numeric? c) (lp (+ res (* (read-char in) k)) (* k 0.1)))
|
||||
((memv c delimiters) res)
|
||||
(else (error "invalid char in float syntax" c))))))
|
||||
(define (read-name c in)
|
||||
(let lp ((ls (if (char? c) (list c) '())))
|
||||
(let ((c (peek-char in)))
|
||||
(cond ((memv c delimiters) (list->string (reverse ls)))
|
||||
(else (lp (cons (read-char in) ls)))))))
|
||||
(define (read-named-char c in)
|
||||
(let ((name (read-name c in)))
|
||||
(cond ((string-ci=? name "space") #\space)
|
||||
((string-ci=? name "newline") #\newline)
|
||||
(else (error "unknown char name")))))
|
||||
(define (read-one)
|
||||
(skip-whitespace in)
|
||||
(case (peek-char in)
|
||||
((#\#)
|
||||
(read-char in)
|
||||
(case (char-downcase (peek-char in))
|
||||
((#\=)
|
||||
(read-char in)
|
||||
(let* ((str (read-label '()))
|
||||
(n (string->number str))
|
||||
(cell (list #f))
|
||||
(thunk (lambda () (car cell))))
|
||||
(if (not n) (error "read error: invalid reference" str))
|
||||
(set! shared (cons (cons n thunk) shared))
|
||||
(let ((x (read-one)))
|
||||
(set-car! cell x)
|
||||
x)))
|
||||
((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)
|
||||
(let ((n (string->number (read-label '()))))
|
||||
(cond
|
||||
((not (eqv? #\# (peek-char in)))
|
||||
(error "read error: expected # after #n" (read-char in)))
|
||||
(else
|
||||
(read-char in)
|
||||
(cond ((assv n shared) => cdr)
|
||||
(else (error "read error: unknown reference" n)))))))
|
||||
((#\;)
|
||||
(read-char in)
|
||||
(read-one) ;; discard
|
||||
(read-one))
|
||||
((#\|)
|
||||
(skip-comment in 0))
|
||||
((#\!) (skip-line in) (read-one in))
|
||||
((#\() (list->vector (read-one)))
|
||||
((#\') (read-char in) (list 'syntax (read-one)))
|
||||
((#\`) (read-char in) (list 'quasisyntax (read-one)))
|
||||
((#\t) (read-char in) #t)
|
||||
((#\f) (read-char in) #t) ; support SRFI-4 f32/64 vectors
|
||||
((#\d) (read-char in) (read in))
|
||||
((#\x) (read-char in) (read-number 16))
|
||||
((#\o) (read-char in) (read-number 8))
|
||||
((#\b) (read-char in) (read-number 2))
|
||||
((#\i) (read-char in) (exact->inexact (read-one)))
|
||||
((#\e) (read-char in) (inexact->exact (read-one)))
|
||||
((#\\)
|
||||
(read-char in)
|
||||
(let ((c (read-char in)))
|
||||
(if (memv (peek-char in) delimiters)
|
||||
c
|
||||
(read-named-char c in))))
|
||||
(else ; last resort
|
||||
(error "unknown # syntax: " (peek-char in)))))
|
||||
((#\()
|
||||
(read-char in)
|
||||
(let lp ((res '()))
|
||||
(skip-whitespace in)
|
||||
(case (peek-char in)
|
||||
((#\))
|
||||
(read-char in)
|
||||
(reverse res))
|
||||
((#\.)
|
||||
(read-char in)
|
||||
(cond
|
||||
((memv (peek-char in) delimiters)
|
||||
(let ((tail (read-one)))
|
||||
(skip-whitespace in)
|
||||
(if (eqv? #\) (peek-char in))
|
||||
(begin (read-char in) (append (reverse res) tail))
|
||||
(error "expected end of list after dot"))))
|
||||
((char-numeric? (peek-char in)) (read-float-tail in))
|
||||
(else (string->symbol (read-name #\. in)))))
|
||||
(else
|
||||
(lp (cons (read-one) res))))))
|
||||
((#\') (read-char in) (list 'quote (read-one)))
|
||||
((#\`) (read-char in) (list 'quasiquote (read-one)))
|
||||
((#\,)
|
||||
(read-char in)
|
||||
(list (if (eqv? #\@ (peek-char in))
|
||||
(begin (read-char in) 'unquote-splicing)
|
||||
'unquote)
|
||||
(read-one)))
|
||||
(else
|
||||
(read in))))
|
||||
;; body
|
||||
(let ((res (read-one)))
|
||||
(if (pair? shared)
|
||||
(patch res))
|
||||
res)))))
|
||||
|
||||
(define (hole? x) (procedure? x))
|
||||
(define (fill-hole x) (if (hole? x) (fill-hole (x)) x))
|
||||
|
||||
(define (patch x)
|
||||
(cond
|
||||
((pair? x)
|
||||
(if (hole? (car x)) (set-car! x (fill-hole (car x))) (patch (car x)))
|
||||
(if (hole? (cdr x)) (set-cdr! x (fill-hole (cdr x))) (patch (cdr x))))
|
||||
((vector? x)
|
||||
(do ((i (- (vector-length x) 1) (- i 1)))
|
||||
((< i 0))
|
||||
(let ((elt (vector-ref x i)))
|
||||
(if (hole? elt)
|
||||
(vector-set! x i (fill-hole elt))
|
||||
(patch elt)))))))
|
||||
|
||||
(define read/ss read-with-shared-structure)
|
||||
Loading…
Add table
Reference in a new issue