new-style define-serializable-struct
svn: r7871
This commit is contained in:
Matthew Flatt
parent
73bc0e2d52
commit
f520abb24c
|
|
@ -1,4 +1,216 @@
|
|||
|
||||
(module serialize scheme/base
|
||||
(require mzlib/serialize)
|
||||
(provide (all-from-out mzlib/serialize)))
|
||||
(require mzlib/private/serialize
|
||||
(for-syntax scheme/base
|
||||
scheme/struct-info))
|
||||
|
||||
(provide (all-from-out mzlib/private/serialize)
|
||||
define-serializable-struct
|
||||
define-serializable-struct/versions)
|
||||
|
||||
(define-syntax (define-serializable-struct/versions/derived stx)
|
||||
(syntax-case stx ()
|
||||
;; First check `id/sup':
|
||||
[(_ orig-stx id/sup . _)
|
||||
(not (or (identifier? #'id/sup)
|
||||
(syntax-case #'id/sup ()
|
||||
[(id sup) (and (identifier? #'id)
|
||||
(identifier? #'sup)
|
||||
(let ([v (syntax-local-value #'sup (lambda () #f))])
|
||||
(struct-info? v)))]
|
||||
[_ #f])))
|
||||
;; Not valid, so let `define-struct/derived' complain:
|
||||
#'(define-struct/derived orig-stx id/sup ())]
|
||||
;; Check version:
|
||||
[(_ orig-stx id/sup vers . _)
|
||||
(not (exact-nonnegative-integer? (syntax-e #'vers)))
|
||||
(raise-syntax-error #f "expected a nonnegative exact integer for a version" #'orig-stx #'vers)]
|
||||
;; Main case:
|
||||
[(_ orig-stx id/sup vers (field ...) ([other-vers make-proc-expr cycle-make-proc-expr] ...)
|
||||
prop ...)
|
||||
(let* ([id (if (identifier? #'id/sup)
|
||||
#'id/sup
|
||||
(car (syntax-e #'id/sup)))]
|
||||
[super-info (if (identifier? #'id/sup)
|
||||
#f
|
||||
(extract-struct-info (syntax-local-value (cadr (syntax->list #'id/sup)))))]
|
||||
[fields (syntax->list #'(field ...))]
|
||||
[maker (datum->syntax id
|
||||
(string->symbol
|
||||
(format "make-~a" (syntax-e id)))
|
||||
id)]
|
||||
[getters (map (lambda (field)
|
||||
(datum->syntax
|
||||
id
|
||||
(string->symbol
|
||||
(format "~a-~a"
|
||||
(syntax-e id)
|
||||
(syntax-e
|
||||
(if (identifier? field)
|
||||
field
|
||||
(syntax-case field ()
|
||||
[(id . _)
|
||||
(if (identifier? #'id)
|
||||
#'id
|
||||
#'bad)]
|
||||
[_ #'bad])))))))
|
||||
fields)]
|
||||
[mutable? (ormap (lambda (x)
|
||||
(eq? '#:mutable (syntax-e x)))
|
||||
(syntax->list #'(prop ...)))]
|
||||
[setters (map (lambda (field)
|
||||
(let-values ([(field-id mut?)
|
||||
(if (identifier? field)
|
||||
(values field #f)
|
||||
(syntax-case field ()
|
||||
[(id prop ...)
|
||||
(values (if (identifier? #'id)
|
||||
#'id
|
||||
#'bad)
|
||||
(ormap (lambda (x)
|
||||
(eq? '#:mutable (syntax-e x)))
|
||||
(syntax->list #'(prop ...))))]
|
||||
[_ (values #'bad #f)]))])
|
||||
(and (or mutable? mut?)
|
||||
(datum->syntax
|
||||
id
|
||||
(string->symbol
|
||||
(format "set-~a-~a!"
|
||||
(syntax-e id)
|
||||
(syntax-e field-id)))))))
|
||||
fields)]
|
||||
[make-deserialize-id (lambda (vers)
|
||||
(datum->syntax id
|
||||
(string->symbol
|
||||
(format "deserialize-info:~a-v~a"
|
||||
(syntax-e id)
|
||||
(syntax-e vers)))
|
||||
id))]
|
||||
[deserialize-id (make-deserialize-id #'vers)]
|
||||
[other-deserialize-ids (map make-deserialize-id
|
||||
(syntax->list #'(other-vers ...)))])
|
||||
(when super-info
|
||||
(unless (andmap values (list-ref super-info 3))
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"not all fields are known for parent struct type"
|
||||
#'orig-stx
|
||||
(syntax-case #'id/sup ()
|
||||
[(_ sup) #'sup]))))
|
||||
#`(begin
|
||||
;; =============== struct with serialize property ================
|
||||
(define-struct/derived orig-stx
|
||||
id/sup
|
||||
(field ...)
|
||||
prop ...
|
||||
#:property prop:serializable
|
||||
(make-serialize-info
|
||||
;; The struct-to-vector function: --------------------
|
||||
(lambda (v)
|
||||
(vector
|
||||
#,@(if super-info
|
||||
(reverse
|
||||
(map (lambda (sel)
|
||||
#`(#,sel v))
|
||||
(list-ref super-info 3)))
|
||||
null)
|
||||
#,@(map (lambda (getter)
|
||||
#`(#,getter v))
|
||||
getters)))
|
||||
;; The serializer id: --------------------
|
||||
(quote-syntax #,deserialize-id)
|
||||
;; Can handle cycles? --------------------
|
||||
;; Yes, as long as we have mutators for the
|
||||
;; superclass.
|
||||
#,(and (andmap values setters)
|
||||
(or (not super-info)
|
||||
(andmap values (list-ref super-info 4))))
|
||||
;; Directory for last-ditch resolution --------------------
|
||||
(or (current-load-relative-directory)
|
||||
(current-directory))))
|
||||
;; =============== deserialize info ================
|
||||
(define #,deserialize-id
|
||||
(make-deserialize-info
|
||||
;; The maker: --------------------
|
||||
#,maker
|
||||
;; The shell function: --------------------
|
||||
;; Returns an shell object plus
|
||||
;; a function to update the shell (used for
|
||||
;; building cycles):
|
||||
(let ([super-sets
|
||||
(list #,@(if super-info
|
||||
(list-ref super-info 4)
|
||||
null))])
|
||||
(lambda ()
|
||||
(let ([s0
|
||||
(#,maker
|
||||
#,@(append
|
||||
(if super-info
|
||||
(map (lambda (x) #f)
|
||||
(list-ref super-info 3))
|
||||
null)
|
||||
(map (lambda (g)
|
||||
#f)
|
||||
getters)))])
|
||||
(values
|
||||
s0
|
||||
(lambda (s)
|
||||
#,@(if super-info
|
||||
(map (lambda (set get)
|
||||
#`(#,set s0 (#,get s)))
|
||||
(list-ref super-info 4)
|
||||
(list-ref super-info 3))
|
||||
null)
|
||||
#,@(map (lambda (getter setter)
|
||||
#`(#,setter s0 (#,getter s)))
|
||||
getters
|
||||
setters)
|
||||
(void))))))))
|
||||
#,@(map (lambda (other-deserialize-id proc-expr cycle-proc-expr)
|
||||
#`(define #,other-deserialize-id
|
||||
(make-deserialize-info proc-expr cycle-proc-expr)))
|
||||
other-deserialize-ids
|
||||
(syntax->list #'(make-proc-expr ...))
|
||||
(syntax->list #'(cycle-make-proc-expr ...)))
|
||||
;; =============== provide ===============
|
||||
#,@(map (lambda (deserialize-id)
|
||||
(if (eq? 'top-level (syntax-local-context))
|
||||
;; Top level; in case deserializer-id-stx is macro-introduced,
|
||||
;; explicitly use namespace-set-variable-value!
|
||||
#`(namespace-set-variable-value! '#,deserialize-id
|
||||
#,deserialize-id)
|
||||
;; In a module; provide:
|
||||
#`(provide #,deserialize-id)))
|
||||
(cons deserialize-id
|
||||
other-deserialize-ids))))]
|
||||
;; -- More error cases ---
|
||||
;; Check fields
|
||||
[(_ orig-stx id/sup vers fields . _rest)
|
||||
;; fields isn't a sequence:
|
||||
#`(define-struct/derived orig-stx fields)]
|
||||
;; vers-spec bad?
|
||||
[(_ orig-stx id/sup vers fields vers-spec prop ...)
|
||||
;; Improve this:
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"expected a parenthesized sequence of version mappings"
|
||||
#'orig-stx
|
||||
#'vers-spec)]
|
||||
;; Last-ditch error:
|
||||
[(_ orig-stx . _)
|
||||
(raise-syntax-error #f "bad syntax" #'orig-stx)]))
|
||||
|
||||
(define-syntax (define-serializable-struct/versions stx)
|
||||
(syntax-case stx ()
|
||||
[(_ . rest)
|
||||
#`(define-serializable-struct/versions/derived #,stx . rest)]))
|
||||
|
||||
(define-syntax (define-serializable-struct stx)
|
||||
(syntax-case stx ()
|
||||
[(_ id/sup (field ...) prop ...)
|
||||
#`(define-serializable-struct/versions/derived #,stx
|
||||
id/sup 0 (field ...) () prop ...)]
|
||||
[(_ . rest)
|
||||
#`(define-struct/derived #,stx . rest)]))
|
||||
|
||||
)
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
|
||||
(module struct scheme/base
|
||||
(require mzlib/serialize
|
||||
(require scheme/serialize
|
||||
scheme/contract
|
||||
(for-syntax scheme/base))
|
||||
|
||||
|
|
@ -66,7 +66,7 @@
|
|||
(syntax-case stx ()
|
||||
[(_ (id ([field ct] ...)) ...)
|
||||
#`(begin
|
||||
(define-serializable-struct id (field ...)) ...
|
||||
(define-serializable-struct id (field ...) #:mutable) ...
|
||||
(provide/contract
|
||||
#,@(let ([ids (syntax->list #'(id ...))]
|
||||
[fields+cts (syntax->list #'(([field ct] ...) ...))])
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user