original commit: 69d9b669b4c6bf3a02f0c0a3a506dd4f44eeeb98
This commit is contained in:
Matthew Flatt 2005-05-06 03:53:51 +00:00
parent 98266572ca
commit be205971e3
3 changed files with 109 additions and 12 deletions

View File

@ -4,12 +4,12 @@
;; which provides extra (private) functionality to contract.ss.
(require "private/class-internal.ss")
(provide class
class*
(provide class class* class/derived
define-serializable-class define-serializable-class*
class?
mixin
interface interface?
object% object?
object% object? externalizable<%>
object=?
new make-object instantiate
send send/apply send* class-field-accessor class-field-mutator with-method
@ -37,4 +37,5 @@
field init init-field
rename-super rename-inner inherit
this super inner
super-make-object super-instantiate super-new))
super-make-object super-instantiate super-new
inspect))

View File

@ -2,7 +2,8 @@
(require-for-syntax (lib "struct.ss" "syntax"))
(require (lib "moddep.ss" "syntax")
(lib "etc.ss")
(lib "list.ss"))
(lib "list.ss")
"private/serialize-structs.ss")
(provide define-serializable-struct
define-serializable-struct/versions
@ -19,9 +20,6 @@
serialize
deserialize)
(define-struct serialize-info (vectorizer deserialize-id can-cycle? dir))
(define-struct deserialize-info (maker cycle-maker))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; define-serializable-struct
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -413,9 +411,6 @@
;; serialize
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define-values (prop:serializable serializable-struct? serializable-info)
(make-struct-type-property 'serializable #f))
(define (serializable? v)
(or (serializable-struct? v)
(boolean? v)

View File

@ -2,11 +2,16 @@
;; by Jacob Matthews (and others)
(module struct mzscheme
(provide copy-struct make-->vector)
(provide copy-struct
define-struct/properties
make-->vector)
(require-for-syntax (lib "struct.ss" "syntax")
"list.ss"
(lib "stx.ss" "syntax"))
;; ------------------------------------------------------------
;; copy-struct
;; copy-struct expands to `do-copy-struct' to delay the expansion
;; in an internal-definition context. (The `begin0' wrapper
;; effectively declares the form to be an expression.)
@ -71,7 +76,103 @@
(lambda (field) (or (new-binding-for field) #`(#,field the-struct)))
(reverse accessors)))
(raise-type-error '_ #,(format "struct:~a" (syntax-object->datum #'info)) the-struct))))))]))]))
;; --------------------------------------------------
;; define-struct/properties
;; Used at run time:
(define (check-prop v)
(unless (struct-type-property? v)
(raise-type-error
'define-struct/properties
"struct-type property"
v))
v)
;; This compile-time proc fills in the crucial part of the expansion.
;; Because it's called through a syntax trampoline, the arguments have to
;; to be packaged as a syntax object.
(define-for-syntax (make-make-make-struct-type props+insp-stx)
(with-syntax ([(([prop expr] ...) inspector) props+insp-stx])
(lambda (orig-stx name-stx defined-name-stxes super-info)
#`(make-struct-type '#,name-stx
#,(and super-info (list-ref super-info 0))
#,(/ (- (length defined-name-stxes) 3) 2)
0 #f
(list
(cons (check-prop prop)
expr)
...)
inspector))))
;; The main macro:
(define-syntax (define-struct/properties stx)
;; Start paring. Exploit `parse-define-struct' as much as possible.
(define (parse-at-main)
(syntax-case stx ()
[(_ id/sup fields . rest)
;; Check initial part:
(let-values ([(id sup-id fields _)
(parse-define-struct #`(_ id/sup fields) stx)])
(parse-at-props id sup-id fields #'rest))]
[_
;; Not even right up to define-struct, so let the
;; simple parser report the problem:
(parse-define-struct stx stx)]))
;; So far, so good. Parse props.
(define (parse-at-props id sup-id fields rest)
(syntax-case rest ()
[(([prop expr] ...) . rrest)
(parse-at-inspector id sup-id fields (stx-car rest) (stx-cdr rest))]
[((bad ...) . rest)
(for-each (lambda (bad)
(syntax-case bad ()
[(a b) 'ok]
[_ (raise-syntax-error
#f
"expected a parenthesized property--value pairing"
stx
bad)]))
(syntax->list #'(bad ...)))]
[(bad . rest)
(raise-syntax-error
#f
"expected a parenthesized sequence of property--value pairings"
stx
#'bad)]
[_
(raise-syntax-error
#f
"expected a parenthesized sequence of property--value pairings after fields"
stx)]))
;; Finally, parse optional inspector expr, again exploting
;; `parse-define-struct'.
(define (parse-at-inspector id sup-id fields props rest)
(let-values ([(_ __ ___ inspector-stx)
(parse-define-struct #`(ds id () #,@rest) stx)])
(build-result id sup-id fields props inspector-stx)))
;; Build the result using `generate-struct-declaration', which
;; sometimes needs the `continue-ds/p' trampoline to eventually get
;; to make-make-make-struct-type.
(define (build-result id sup-id fields props inspector)
(let ([props+insp #`(#,props #,inspector)])
(generate-struct-declaration stx
id sup-id fields
(syntax-local-context)
(make-make-make-struct-type props+insp)
#'continue-ds/p props+insp)))
(parse-at-main))
(define-syntax (continue-ds/p stx)
(generate-delayed-struct-declaration stx make-make-make-struct-type))
;; ------------------------------------------------------------
;; make->vector
(define-syntax (make-->vector stx)
(syntax-case stx ()