scsh-0.6/scheme/big/dump.scm

430 lines
12 KiB
Scheme

; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
; Dump and restore
; Unix has special meanings for
; ETX, FS, DEL, ETB, NAK, DC2, EOT, EM (or SUB?), DC3, DC1, SI, SYN,
; 3 28 127 23 21 18 4 25 26 19 17 15 22
; so avoid using them.
(define type/null #\n)
(define type/true #\t)
(define type/false #\f)
(define type/unspecific #\u)
(define type/pair #\p) ;obj1 obj2
(define type/string #\s) ;length chars
(define type/number #\i) ;#chars rep
(define type/symbol #\y) ;length chars
(define type/char #\c) ;char
(define type/vector #\v) ;length objects
(define type/template #\a) ;length objects
(define type/code-vector #\k) ;length bytes (each byte is 2 hex digits?)
(define type/location #\l) ;uid
(define type/closure #\q) ;template-info
(define type/ellipsis #\e)
(define type/random #\r)
; Recursive entry
(define (dump obj write-char depth)
(cond ((null? obj) (dump-type type/null write-char))
((eq? obj #t) (dump-type type/true write-char))
((eq? obj #f) (dump-type type/false write-char))
((pair? obj) (dump-pair obj write-char depth))
;; Template case needs to precede vector case
((template? obj) (dump-template obj write-char depth))
((vector? obj) (dump-vector obj write-char depth))
((symbol? obj) (dump-symbol obj write-char))
((number? obj) (dump-number obj write-char))
((string? obj) (dump-string obj write-char))
((char? obj) (dump-char-literal obj write-char))
((code-vector? obj) (dump-code-vector obj write-char))
((location? obj) (dump-location obj write-char))
((unspecific? obj) (dump-type type/unspecific write-char))
((closure? obj) (dump-closure obj write-char))
(else (dump-random obj write-char depth))))
(define (restore read-char)
(let ((type (restore-type read-char)))
((vector-ref restorers (char->ascii type)) type read-char)))
(define restorers
(make-vector 256 (lambda (type read-char)
;; Invalid type
(error "invalid type code" type))))
(define (define-restorer! type proc)
(vector-set! restorers (char->ascii type) proc))
; Particular dumpers & restorers
(define-restorer! type/null (lambda (c read-char) '()))
(define-restorer! type/false (lambda (c read-char) #f))
(define-restorer! type/true (lambda (c read-char) #t))
(define-restorer! type/unspecific (lambda (c read-char) (if #f #f)))
; Pairs
(define (dump-pair obj write-char depth)
(if (= depth 0)
(dump-ellipsis obj write-char)
(let ((depth (- depth 1)))
(dump-type type/pair write-char)
(dump (car obj) write-char depth)
(dump (cdr obj) write-char depth))))
(define-restorer! type/pair
(lambda (c write-char)
c ;ignored
(let ((the-car (restore write-char)))
(cons the-car (restore write-char)))))
; Symbols
(define (dump-symbol obj write-char)
(dump-type type/symbol write-char)
(dump-a-string (symbol-case-converter (symbol->string obj)) write-char))
(define-restorer! type/symbol
(lambda (c read-char)
c ;ignored
(string->symbol (symbol-case-converter (restore-a-string read-char)))))
; Numbers
; <space> ... _ represent 0 ... 63,
; {<space> ... {_ represent 64 ... 127, -- { is ascii 123
; |<space> ... |_ represent 128 ... 191, -- | is ascii 124
; }<space> ... }_ represent 192 ... 256. -- } is ascii 125
(define (dump-number n write-char)
(if (not (communicable-number? n))
(error "can't dump this number" n))
(if (and (integer? n)
(>= n 0)
(< n 256))
(dump-byte n write-char)
(begin (dump-type type/number write-char)
;; Note logarithmic recursion
(dump-a-string (number->string n comm-radix) write-char))))
(define (communicable-number? n) #t) ;this gets redefined in client
(define (dump-byte n write-char) ;Dump a number between 0 and 255
(if (< n 64)
(write-char (ascii->char (+ n ascii-space)))
(begin (write-char (ascii->char (+ (arithmetic-shift n -6)
122)))
(write-char (ascii->char (+ (bitwise-and n 63)
ascii-space))))))
(define ascii-space (char->ascii #\space)) ;32
(define (restore-small-integer c read-char)
(- (char->ascii c) ascii-space))
(do ((i (+ ascii-space 63) (- i 1)))
((< i ascii-space))
(define-restorer! (ascii->char i) restore-small-integer))
(define (restore-medium-integer c read-char)
(+ (arithmetic-shift (- (char->ascii c) 122) 6)
(- (char->ascii (read-char)) ascii-space)))
(do ((i 123 (+ i 1)))
((> i 125))
(define-restorer! (ascii->char i) restore-medium-integer))
(define (restore-number read-char)
(let ((c (read-char)))
(if (char=? c type/number)
(string->number (restore-a-string read-char) comm-radix)
(let ((n (char->ascii c)))
(if (> n 122)
(restore-medium-integer c read-char)
(- n ascii-space))))))
(define-restorer! type/number
(lambda (c read-char)
c ;ignored
(string->number (restore-a-string read-char) comm-radix)))
(define comm-radix 16)
; String literals
(define (dump-string obj write-char)
(dump-type type/string write-char)
(dump-a-string obj write-char))
(define-restorer! type/string
(lambda (c read-char)
c ;ignored
(restore-a-string read-char)))
; Characters
(define (dump-char-literal obj write-char)
(dump-type type/char write-char)
(dump-a-char obj write-char))
(define-restorer! type/char
(lambda (c read-char)
c ;ignored
(restore-a-char read-char)))
; Vectors
(define (dump-vector obj write-char depth)
(dump-vector-like obj write-char depth
type/vector vector-length vector-ref))
(define (dump-template obj write-char depth)
(dump-vector-like obj write-char depth
type/template template-length template-ref))
(define (dump-vector-like obj write-char depth type vector-length vector-ref)
(if (= depth 0)
(dump-ellipsis obj write-char)
(let ((depth (- depth 1))
(len (vector-length obj)))
(dump-type type write-char)
(dump-length len write-char)
(do ((i 0 (+ i 1)))
((= i len) 'done)
(dump (vector-ref obj i) write-char depth)))))
(define (restore-vector-like make-vector vector-set!)
(lambda (c read-char)
c ;ignored
(let* ((len (restore-length read-char))
(v (make-vector len #\?)))
(do ((i 0 (+ i 1)))
((= i len) v)
(vector-set! v i (restore read-char))))))
(define-restorer! type/vector
(restore-vector-like make-vector vector-set!))
(define-restorer! type/template
(restore-vector-like make-template template-set!))
; Code vectors
(define (dump-code-vector obj write-char)
(dump-type type/code-vector write-char)
(let ((len (code-vector-length obj)))
(dump-length len write-char)
(do ((i 0 (+ i 1)))
((= i len) 'done)
(dump-byte (code-vector-ref obj i) write-char))))
(define-restorer! type/code-vector
(lambda (c read-char)
c ;ignored
(let* ((len (restore-length read-char))
(cv (make-code-vector len 0)))
(do ((i 0 (+ i 1)))
((= i len) cv)
(code-vector-set! cv i
(restore-number read-char))))))
; Locations
(define (dump-location obj write-char)
(dump-type type/location write-char)
(dump-number (location->uid obj) write-char))
(define (location->uid obj)
(or ((fluid $dump-index) obj)
(location-id obj)))
(define-restorer! type/location
(lambda (c read-char)
c ;ignored
(uid->location (restore-number read-char))))
(define (uid->location uid)
(or ((fluid $restore-index) uid)
(table-ref uid->location-table uid)
(let ((loc (make-undefined-location uid)))
(note-location! loc)
loc)))
(define $restore-index (make-fluid (lambda (uid) #f)))
(define uid->location-table (make-table))
(define (note-location! den)
(table-set! uid->location-table
(location-id den)
den))
(define $dump-index (make-fluid (lambda (loc) #f)))
; For simulation purposes, it's better for location uid's not to
; conflict with any that might be in the base Scheme 48 system. (In the
; real server system there isn't any base Scheme 48 system, so there's
; no danger of conflict.)
; (define location-uid-origin 5000)
; Closure
(define (dump-closure obj write-char)
(dump-type type/closure write-char)
(let ((id (template-info (closure-template obj))))
(dump-number (if (integer? id) id 0) write-char)))
(define-restorer! type/closure
(lambda (c read-char)
c ;ignored
(make-random (list 'closure (restore-number read-char)))))
; Random
(define random-type (make-record-type 'random '(disclosure)))
(define make-random (record-constructor random-type '(disclosure)))
(define-record-discloser random-type
(let ((d (record-accessor random-type 'disclosure)))
(lambda (r) (cons "Remote" (d r)))))
(define (dump-random obj write-char depth)
(dump-type type/random write-char)
(dump (or (disclose obj) (list '?))
write-char
depth))
(define-restorer! type/random
(lambda (c read-char)
(make-random (restore read-char))))
; Ellipsis
(define (dump-ellipsis obj write-char)
(dump-type type/ellipsis write-char))
(define-restorer! type/ellipsis
(lambda (c read-char) (make-random (list (string->symbol "---")))))
; Auxiliaries:
; Strings (not necessarily preceded by type code)
(define (dump-a-string obj write-char)
(let ((len (string-length obj)))
(dump-length len write-char)
(do ((i 0 (+ i 1)))
((= i len) 'done)
(dump-a-char (string-ref obj i) write-char))))
(define (restore-a-string read-char)
(let* ((len (restore-length read-char))
(str (make-string len #\?)))
(do ((i 0 (+ i 1)))
((= i len) str)
(string-set! str i (restore-a-char read-char)))))
(define (dump-a-char c write-char)
(write-char c))
(define (restore-a-char read-char)
(read-char))
; Type characters
(define (dump-type c write-char)
(write-char c))
(define (restore-type read-char)
(read-char))
(define dump-length dump-number)
(define restore-length restore-number)
;(define char->ascii char->integer) -- defined in p-features.scm
;(define ascii->char integer->char) -- ditto
; Miscellaneous support
(define (unspecific? obj)
(eq? obj *unspecific*))
(define *unspecific* (if #f #f)) ;foo
;(define (integer->digit-char n)
; (ascii->char (+ n (if (< n 10) ascii-zero a-minus-ten))))
;
;(define (digit-char->integer c)
; (cond ((char-numeric? c)
; (- (char->ascii c) ascii-zero))
; ((char=? c #\#) 0)
; (else
; (- (char->ascii (char-downcase c)) a-minus-ten))))
;
;(define ascii-zero (char->ascii #\0))
;
;(define a-minus-ten (- (char->integer #\a) 10))
; These modified from s48/boot/transport.scm
(define (string-case-converter string)
(let ((new (make-string (string-length string) #\?)))
(do ((i 0 (+ i 1)))
((>= i (string-length new)) new)
(string-set! new i (invert-case (string-ref string i))))))
(define (invert-case c)
(cond ((char-upper-case? c) (char-downcase c))
((char-lower-case? c) (char-upcase c))
(else c)))
(define symbol-case-converter
(if (char=? (string-ref (symbol->string 't) 0) #\t)
(lambda (string) string)
string-case-converter))
; ASCII
; !"#$%&'()*+,-./0123456789:;<=>?
; @ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_
; `abcdefghijklmnopqrstuvwxyz{|}~
;(define (tst x)
; (let ((l '()))
; (dump x (lambda (c) (set! l (cons c l))) -1)
; (let ((l (reverse l)))
; (restore (lambda ()
; (let ((c (car l)))
; (set! l (cdr l))
; c))))))
;(define cwcc call-with-current-continuation)
;
;(define (tst x)
; (letrec ((write-cont (lambda (ignore)
; (dump x
; (lambda (c)
; (cwcc (lambda (k)
; (set! write-cont k)
; (read-cont c))))
; -1)))
; (read-cont #f))
; (restore (lambda ()
; (cwcc (lambda (k)
; (set! read-cont k)
; (write-cont 'ignore)))))))