[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
Re: reading external representation
On Feb 18, Matthew Flatt wrote:
>
> You'll have to manually marshal and unmarshal the objects.
> (General-purpose automatic object marhsaling would be difficult or
> impossible to add to MzScheme, due to first-class classes.)
Here's some code I had lying around... It converts any structure of
objects to an array that can be written to a file -- as long as you
specify a way for all included object types to construct an object of
the same type, a way to pull out its components and a way to set them.
(So it doesn't cover functions and classes/instances (I have a similar
thing for Swindle, of course...)) (A nice thing I used this for is a
list of global values that are made persistent with a file.)
-------------------------------------------------------------------------------
#!/bin/sh
#|
exec mzscheme -mf "$0"
|#
;;=============================================================================
;; Get a value and return a value that can be printed and also used to
;; reconstruct this value back. The return value is a vector of entries, each
;; one is a list of a symbol that will construct a value of the desired type
;; given some arguments, and the arguments follow - either simple values, or a
;; list with a single integer index that stands for an entry in this vector.
;;
;; The whole thing is controlled by a table with entries for a predicate for
;; these values, a deconstructor and a constructor:
;; predicate: returns #t for values of this entry's type (tested in order
;; of defined predicates);
;; destructor: gets this value and returns a list of values which can be
;; used to compose an `equal?' value;
;; constructor: a function of one argument that returns a value of the wanted
;; type, the argument is the number of subvalues given;
;; setter: gets the constructed value and a list of values as returned
;; by the destructor and reconstruct the object.
;; If the destructor is #f, then there is no way to destruct the value which
;; means that it is primitive. If it is #t, then again it is primitive, but
;; the identity of this primitive should be preserved (e.g., strings).
(define marshall-info (make-hash-table))
(define marshall-predicates '())
(define (set-marshall-info! name predicate destructor . constructor+setter)
(define constructor
(and (not (null? constructor+setter))
(car constructor+setter)))
(define setter
(and constructor (not (null? (cdr constructor+setter)))
(cadr constructor+setter)))
(hash-table-put! marshall-info name
(list name predicate destructor constructor setter))
(let ((p (assq name marshall-predicates)))
(if p
(set-cdr! p predicate)
;; add to the end so common cases come first
(set! marshall-predicates
(append! marshall-predicates (list (cons predicate name)))))))
(define (value->marshall value)
(define table (make-hash-table))
(define output '())
(define count! (let ((c -1)) (lambda () (set! c (add1 c)) c)))
(define (get-info x)
(let ((info (ormap (lambda (p)
(and ((car p) x)
(hash-table-get marshall-info (cdr p))))
marshall-predicates)))
(or info (error 'marshall-value "got a bad value: ~e." x))))
(define (scan! x)
(let* ((info (get-info x))
(tag (car info))
(dest (caddr info)))
(if dest
;; composed value, or value with identity
(list (car (hash-table-get
table x
(lambda ()
(let ((entry (list (count!) tag)))
;; must make sure that x is in before recursing
(hash-table-put! table x entry)
(set! output (cons entry output))
;; primitive values with identity do not recurse
(set-cdr! (cdr entry)
(if (procedure? dest)
(map scan! (dest x))
(list x)))
entry)))))
;; primitive values
x)))
(scan! value)
(if (null? output)
(vector (list value)) ; got a top-level atomic value
(list->vector (map cdr (reverse! output)))))
(define (marshall->value marshall)
(define len (vector-length marshall))
(do ((i 0 (add1 i))) ((= i len))
(let* ((entry (vector-ref marshall i))
(tag (car entry))
(info (hash-table-get marshall-info tag))
(const (cadddr info))
(setter (car (cddddr info))))
(set-car! entry
(cons (if const (const (length (cdr entry))) (cadr entry))
setter))))
(do ((i 0 (add1 i))) ((= i len))
(let* ((entry (vector-ref marshall i))
(obj (caar entry))
(setter (cdar entry)))
(when setter
(apply setter obj
(map (lambda (v)
(if (pair? v) (caar (vector-ref marshall (car v))) v))
(cdr entry))))))
(caar (vector-ref marshall 0)))
;; Set some primitive cases
(set-marshall-info! 'num number? #f)
(set-marshall-info! 'sym symbol? #f)
(set-marshall-info! 'bool boolean? #f)
(set-marshall-info! 'char char? #f)
(set-marshall-info! 'null null? #f)
(set-marshall-info! 'str string? #t)
(set-marshall-info! 'pair pair?
(lambda (x) (list (car x) (cdr x)))
(lambda (n) (cons #f #f))
(lambda (p x y) (set-car! p x) (set-cdr! p y)))
(set-marshall-info! 'vec vector?
(lambda (x) (vector->list x))
(lambda (n) (make-vector n #f))
(lambda (v . args)
(do ((i 0 (add1 i)) (args args (cdr args)))
((null? args))
(vector-set! v i (car args)))))
(set-marshall-info! 'void void? (lambda (v) '()) void void)
(set-marshall-info! 'box box?
(lambda (b) (list (unbox b)))
(lambda (n) (box #f))
(lambda (b x) (set-box! b x)))
(let ((x (vector (box 1) #f)))
(vector-set! x 1 x)
(printf ">>> Before: ~s~%>>> After: ~s~%"
x
(marshall->value (value->marshall x))))
(exit)
-------------------------------------------------------------------------------
--
((lambda (x) (x x)) (lambda (x) (x x))) Eli Barzilay:
http://www.barzilay.org/ Maze is Life!