[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