suzanne.soy/compatibility
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

.

Browse Source 
original commit: 544beacbb3c3117b1dec5edb7b40b0a696cc8a4b
This commit is contained in:
Matthew Flatt 2005-02-02 22:03:08 +00:00
parent 3b811dceec
commit 3a218448a8
1 changed files with 161 additions and 128 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

289
collects/mzlib/serialize.ss
View File

@ -17,7 +17,8 @@
serialize serialize
deserialize) deserialize)
(define-struct serialize-info (vectorizer maker-id type-id graph-maker)) (define-struct serialize-info (vectorizer deserialize-id dir))
(define-struct deserialize-info (maker graph-maker))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; define-serializable-struct ;; define-serializable-struct
@ -25,86 +26,96 @@
;; generate-struct-declaration wants a function to generate the actual ;; generate-struct-declaration wants a function to generate the actual
;; call to `make-struct-type'. This is where we insert the serializable property. ;; call to `make-struct-type'. This is where we insert the serializable property.
(define-for-syntax (make-make-make-struct-type inspector-stx) (define-for-syntax (make-make-make-struct-type inspector+deserializer-stx)
(lambda (orig-stx name-stx defined-name-stxes super-info) (let-values ([(inspector-stx deserialize-id)
(when super-info (apply values (syntax->list inspector+deserializer-stx))])
(unless (andmap values (list-ref super-info 3)) (lambda (orig-stx name-stx defined-name-stxes super-info)
(raise-syntax-error (when super-info
#f (unless (andmap values (list-ref super-info 3))
"not all fields are known for parent struct type" (raise-syntax-error
orig-stx #f
(syntax-case orig-stx () "not all fields are known for parent struct type"
[(_ (__ super-id) . rest) #'super-id])))) orig-stx
(let ([num-fields (/ (- (length defined-name-stxes) 3) 2)]) (syntax-case orig-stx ()
#`(letrec-values ([(type maker pred access mutate) [(_ (__ super-id) . rest) #'super-id]))))
(make-struct-type '#,name-stx (let ([num-fields (/ (- (length defined-name-stxes) 3) 2)])
#,(and super-info (list-ref super-info 0)) #`(letrec-values ([(type maker pred access mutate)
#,num-fields (make-struct-type '#,name-stx
0 #f #,(and super-info (list-ref super-info 0))
(list #,num-fields
(cons 0 #f
prop:serializable (list
(make-serialize-info ;; --- The prop:serializable property means this is serializable
;; The struct-to-vector function: -------------------- (cons
(lambda (v) prop:serializable
(vector (make-serialize-info
#,@(if super-info ;; The struct-to-vector function: --------------------
(reverse (lambda (v)
(map (lambda (sel) (vector
#`(#,sel v)) #,@(if super-info
(list-ref super-info 3))) (reverse
null) (map (lambda (sel)
#,@(let loop ([n num-fields][r null]) #`(#,sel v))
(if (zero? n) (list-ref super-info 3)))
r null)
(loop (sub1 n) #,@(let loop ([n num-fields][r null])
(cons (if (zero? n)
#`(access v #,(sub1 n)) r
r)))))) (loop (sub1 n)
;; The constructor id: -------------------- (cons
(quote-syntax #`(access v #,(sub1 n))
#,((syntax-local-certifier) r))))))
(list-ref defined-name-stxes 1))) ;; The serializer id: --------------------
;; The struct type id: -------------------- (quote-syntax
(quote-syntax #,((syntax-local-certifier)
#,((syntax-local-certifier) deserialize-id))
(list-ref defined-name-stxes 0))) ;; Directory for last-ditch resolution --------------------
;; The shell function: -------------------- (or (current-load-relative-directory)
;; Returns an shell object plus (current-directory))))
;; a function to update the shell (used for ;; --- The prop:internal-deserialize property just communicates
;; building cycles): ;; information to the deserialize binding (because it's more
(let ([super-sets ;; convenient to generate the deserialize info here)
(list #,@(if super-info (cons
(list-ref super-info 4) prop:internal-deserialize
null))]) (list
(lambda () ;; The maker-getter: --------------------
(let ([s0 (lambda () maker)
(#,(list-ref defined-name-stxes 1) ;; The shell function: --------------------
#,@(append ;; Returns an shell object plus
(if super-info ;; a function to update the shell (used for
(map (lambda (x) #f) ;; building cycles):
(list-ref super-info 3)) (let ([super-sets
null) (list #,@(if super-info
(vector->list (list-ref super-info 4)
(make-vector num-fields #f))))]) null))])
(values (lambda ()
s0 (let ([s0
(lambda (s) (#,(list-ref defined-name-stxes 1)
#,@(if super-info #,@(append
(map (lambda (set get) (if super-info
#`(#,set s0 (#,get s))) (map (lambda (x) #f)
(list-ref super-info 4) (list-ref super-info 3))
(list-ref super-info 3)) null)
null) (vector->list
#,@(let loop ([n num-fields]) (make-vector num-fields #f))))])
(if (zero? n) (values
null s0
(let ([n (sub1 n)]) (lambda (s)
(cons #`(mutate s0 #,n (access s #,n)) #,@(if super-info
(loop n))))) (map (lambda (set get)
(void))))))))) #`(#,set s0 (#,get s)))
#,inspector-stx)]) (list-ref super-info 4)
(values type maker pred access mutate))))) (list-ref super-info 3))
null)
#,@(let loop ([n num-fields])
(if (zero? n)
null
(let ([n (sub1 n)])
(cons #`(mutate s0 #,n (access s #,n))
(loop n)))))
(void)))))))))
#,inspector-stx)])
(values type maker pred access mutate))))))
(define-syntax define-serializable-struct (define-syntax define-serializable-struct
(let () (let ()
@ -194,14 +205,40 @@
;; Generate the result expression. This is complicated ;; Generate the result expression. This is complicated
;; by the fact that super-id information may or may not be ;; by the fact that super-id information may or may not be
;; immediately available, so we insert a delay ;; immediately available, so we also need continue-define-...
(define (generate-result stx id super-id field-ids inspector-stx) (define (generate-result stx id super-id field-ids inspector-stx)
(generate-struct-declaration stx (with-syntax ([deserializer-id (datum->syntax-object
id super-id field-ids id
(syntax-local-context) (string->symbol
(make-make-make-struct-type inspector-stx) (format "deserializer:~a" (syntax-e id)))
#'continue-define-serializable-struct inspector-stx)) id)]
[struct-type-id (datum->syntax-object
id
(string->symbol
(format "struct:~a" (syntax-e id)))
id)]
[inspector-expr inspector-stx])
#`(begin
#,(generate-struct-declaration stx
id super-id field-ids
(syntax-local-context)
(make-make-make-struct-type #'(inspector-expr deserializer-id))
#'continue-define-serializable-struct
#'(inspector-expr deserializer-id))
(define deserializer-id (let ([l (internal-deserialize-info struct-type-id)])
(make-deserialize-info
((car l))
(cadr l))))
#,@(if (eq? 'top-level (syntax-local-context))
null
(list #'(provide deserializer-id))))))
(lambda (stx) (lambda (stx)
(unless (memq (syntax-local-context) '(top-level module))
(raise-syntax-error
#f
"allowed only at the top level or within a module top level"
stx))
(main stx)))) (main stx))))
(define-syntax (continue-define-serializable-struct stx) (define-syntax (continue-define-serializable-struct stx)
@ -232,20 +269,29 @@
(date? v) (date? v)
(arity-at-least? v))) (arity-at-least? v)))
(define (mod-to-id maker-id struct-id mod-map cache) (define (mod-to-id info mod-map cache)
(hash-table-get (let ([deserialize-id (serialize-info-deserialize-id info)])
cache maker-id (hash-table-get
(lambda () cache deserialize-id
(let ([id (lambda ()
(let* ([names (cons maker-id struct-id)]) (let ([id
(hash-table-get (let ([path+name
mod-map names (cons
(lambda () (let ([b (identifier-binding deserialize-id)])
(let ([id (hash-table-count mod-map)]) (and (list? b)
(hash-table-put! mod-map names id) (collapse-module-path-index
id))))]) (car b)
(hash-table-put! cache maker-id id) `(file ,(build-path (serialize-info-dir info)
id)))) "here.ss")))))
(syntax-e deserialize-id))])
(hash-table-get
mod-map path+name
(lambda ()
(let ([id (hash-table-count mod-map)])
(hash-table-put! mod-map path+name id)
id))))])
(hash-table-put! cache deserialize-id id)
id)))))
(define (is-mutable? o) (define (is-mutable? o)
(or (and (or (pair? o) (or (and (or (pair? o)
@ -374,9 +420,7 @@
v] v]
[(serializable-struct? v) [(serializable-struct? v)
(let ([info (serializable-info v)]) (let ([info (serializable-info v)])
(cons (mod-to-id (serialize-info-maker-id info) (cons (mod-to-id info mod-map mod-map-cache)
(serialize-info-type-id info)
mod-map mod-map-cache)
(map (serial #t) (map (serial #t)
(vector->list (vector->list
((serialize-info-vectorizer info) v)))))] ((serialize-info-vectorizer info) v)))))]
@ -419,9 +463,7 @@
(cond (cond
[(serializable-struct? v) [(serializable-struct? v)
(let ([info (serializable-info v)]) (let ([info (serializable-info v)])
(mod-to-id (serialize-info-maker-id info) (mod-to-id info mod-map mod-map-cache))]
(serialize-info-type-id info)
mod-map mod-map-cache))]
[(vector? v) [(vector? v)
(cons 'v (vector-length v))] (cons 'v (vector-length v))]
[(pair? v) [(pair? v)
@ -481,6 +523,9 @@
;; deserialize ;; deserialize
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define-values (prop:internal-deserialize internal-deserialize? internal-deserialize-info)
(make-struct-type-property 'internal-deserialize #f))
(define (deserialize-one v share mod-map) (define (deserialize-one v share mod-map)
(let loop ([v v]) (let loop ([v v])
(cond (cond
@ -496,8 +541,8 @@
(bytes->immutable-bytes v)] (bytes->immutable-bytes v)]
[(number? (car v)) [(number? (car v))
;; Struct instance: ;; Struct instance:
(let ([m (vector-ref mod-map (car v))]) (let ([info (vector-ref mod-map (car v))])
(apply (car m) (map loop (cdr v))))] (apply (deserialize-info-maker info) (map loop (cdr v))))]
[else [else
(case (car v) (case (car v)
[(?) (vector-ref share (cdr v))] [(?) (vector-ref share (cdr v))]
@ -534,9 +579,8 @@
(cond (cond
[(number? v) [(number? v)
;; Struct instance ;; Struct instance
(let* ([m (vector-ref mod-map v)] (let* ([info (vector-ref mod-map v)])
[info (serializable-info (cdr m))]) (let-values ([(obj fix) ((deserialize-info-graph-maker info))])
(let-values ([(obj fix) ((serialize-info-graph-maker info))])
(vector-set! fixup n fix) (vector-set! fixup n fix)
obj))] obj))]
[(pair? v) [(pair? v)
@ -604,23 +648,12 @@
;; Load constructor mapping ;; Load constructor mapping
(let loop ([n 0][l mod-map-l]) (let loop ([n 0][l mod-map-l])
(unless (null? l) (unless (null? l)
(let ([a (car l)]) (let* ([path+name (car l)]
;; Load module, if any: [des (if (car path+name)
(let ([b (identifier-binding (car a))]) (dynamic-require (car path+name) (cdr path+name))
(when (list? b) (namespace-variable-value (cdr path+name)))])
(unless (symbol? (car b))
(let ([path (collapse-module-path-index
(car b)
`(file ,(build-path (or (current-load-relative-directory)
(current-directory))
"here.ss")))])
(dynamic-require path #f)))))
;; Register maker and struct type: ;; Register maker and struct type:
(vector-set! mod-map n (cons (vector-set! mod-map n des))
;; Maker:
(eval-syntax (car a))
;; Struct type:
(eval-syntax (cdr a)))))
(loop (add1 n) (cdr l)))) (loop (add1 n) (cdr l))))
;; Create vector for sharing: ;; Create vector for sharing:
(let ([share (make-vector share-n #f)] (let ([share (make-vector share-n #f)]