.
original commit: 69d9b669b4c6bf3a02f0c0a3a506dd4f44eeeb98
This commit is contained in:
parent
98266572ca
commit
be205971e3
|
@ -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))
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -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 ()
|
||||
|
|
Loading…
Reference in New Issue
Block a user