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

127
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,7 +26,9 @@
;; 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)
(let-values ([(inspector-stx deserialize-id)
(apply values (syntax->list inspector+deserializer-stx))])
(lambda (orig-stx name-stx defined-name-stxes super-info) (lambda (orig-stx name-stx defined-name-stxes super-info)
(when super-info (when super-info
(unless (andmap values (list-ref super-info 3)) (unless (andmap values (list-ref super-info 3))
@ -42,6 +45,7 @@
#,num-fields #,num-fields
0 #f 0 #f
(list (list
;; --- The prop:serializable property means this is serializable
(cons (cons
prop:serializable prop:serializable
(make-serialize-info (make-serialize-info
@ -61,14 +65,21 @@
(cons (cons
#`(access v #,(sub1 n)) #`(access v #,(sub1 n))
r)))))) r))))))
;; The constructor id: -------------------- ;; The serializer id: --------------------
(quote-syntax (quote-syntax
#,((syntax-local-certifier) #,((syntax-local-certifier)
(list-ref defined-name-stxes 1))) deserialize-id))
;; The struct type id: -------------------- ;; Directory for last-ditch resolution --------------------
(quote-syntax (or (current-load-relative-directory)
#,((syntax-local-certifier) (current-directory))))
(list-ref defined-name-stxes 0))) ;; --- The prop:internal-deserialize property just communicates
;; information to the deserialize binding (because it's more
;; convenient to generate the deserialize info here)
(cons
prop:internal-deserialize
(list
;; The maker-getter: --------------------
(lambda () maker)
;; The shell function: -------------------- ;; The shell function: --------------------
;; Returns an shell object plus ;; Returns an shell object plus
;; a function to update the shell (used for ;; a function to update the shell (used for
@ -104,7 +115,7 @@
(loop n))))) (loop n)))))
(void))))))))) (void)))))))))
#,inspector-stx)]) #,inspector-stx)])
(values type maker pred access mutate))))) (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
(string->symbol
(format "deserializer:~a" (syntax-e id)))
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 id super-id field-ids
(syntax-local-context) (syntax-local-context)
(make-make-make-struct-type inspector-stx) (make-make-make-struct-type #'(inspector-expr deserializer-id))
#'continue-define-serializable-struct inspector-stx)) #'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)
(let ([deserialize-id (serialize-info-deserialize-id info)])
(hash-table-get (hash-table-get
cache maker-id cache deserialize-id
(lambda () (lambda ()
(let ([id (let ([id
(let* ([names (cons maker-id struct-id)]) (let ([path+name
(cons
(let ([b (identifier-binding deserialize-id)])
(and (list? b)
(collapse-module-path-index
(car b)
`(file ,(build-path (serialize-info-dir info)
"here.ss")))))
(syntax-e deserialize-id))])
(hash-table-get (hash-table-get
mod-map names mod-map path+name
(lambda () (lambda ()
(let ([id (hash-table-count mod-map)]) (let ([id (hash-table-count mod-map)])
(hash-table-put! mod-map names id) (hash-table-put! mod-map path+name id)
id))))]) id))))])
(hash-table-put! cache maker-id id) (hash-table-put! cache deserialize-id 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)]