From be205971e34a6692d06e77d178902315a6b98a49 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 6 May 2005 03:53:51 +0000 Subject: [PATCH] . original commit: 69d9b669b4c6bf3a02f0c0a3a506dd4f44eeeb98 --- collects/mzlib/class.ss | 9 ++-- collects/mzlib/serialize.ss | 9 +--- collects/mzlib/struct.ss | 103 +++++++++++++++++++++++++++++++++++- 3 files changed, 109 insertions(+), 12 deletions(-) diff --git a/collects/mzlib/class.ss b/collects/mzlib/class.ss index 487101b..f98c652 100644 --- a/collects/mzlib/class.ss +++ b/collects/mzlib/class.ss @@ -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)) \ No newline at end of file + super-make-object super-instantiate super-new + inspect)) diff --git a/collects/mzlib/serialize.ss b/collects/mzlib/serialize.ss index a3293d2..12efa78 100644 --- a/collects/mzlib/serialize.ss +++ b/collects/mzlib/serialize.ss @@ -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) diff --git a/collects/mzlib/struct.ss b/collects/mzlib/struct.ss index a2a8fc5..a3c0b3b 100644 --- a/collects/mzlib/struct.ss +++ b/collects/mzlib/struct.ss @@ -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 ()