[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
Re: reading external representation
thanks Eli
i will try this and give a feedback.
Hassoun
Eli Barzilay wrote:
> 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)
> -------------------------------------------------------------------------------
>
--
Hassoun Karam
hassoun.karam.1@agora.ulaval.ca