From 763d37d775d2deca0337e58deb3f15ac7d9c9208 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 21 Jul 2008 17:04:25 +0000 Subject: [PATCH] properties can now effectively inherit properties (v4.0.2.5) svn: r10848 --- collects/mzscheme/mzscheme.scrbl | 15 +- collects/scheme/private/kw.ss | 56 ++- collects/scheme/private/pre-base.ss | 3 +- collects/scribble/scribble.css | 10 +- .../scribblings/reference/procedures.scrbl | 52 +-- collects/scribblings/reference/regexps.scrbl | 17 +- collects/scribblings/reference/struct.scrbl | 39 +- collects/tests/mzscheme/struct.ss | 74 +++- doc/release-notes/mzscheme/HISTORY.txt | 2 + src/mzscheme/src/mzmark.c | 2 + src/mzscheme/src/mzmarksrc.c | 1 + src/mzscheme/src/schpriv.h | 1 + src/mzscheme/src/schvers.h | 4 +- src/mzscheme/src/struct.c | 340 ++++++++++++------ 14 files changed, 437 insertions(+), 179 deletions(-) diff --git a/collects/mzscheme/mzscheme.scrbl b/collects/mzscheme/mzscheme.scrbl index 626cf2578f..4bbcadc5a0 100644 --- a/collects/mzscheme/mzscheme.scrbl +++ b/collects/mzscheme/mzscheme.scrbl @@ -16,7 +16,7 @@ @(define-syntax-rule (def-base base-define base-define-struct base-if base-cond base-case base-top-interaction - base-open-input-file base-apply + base-open-input-file base-apply base-prop:procedure base-free-identifier=? base-free-template-identifier=? base-free-transformer-identifier=? base-free-label-identifier=?) (begin @@ -29,13 +29,14 @@ (define base-top-interaction (scheme #%top-interaction)) (define base-open-input-file (scheme open-input-file)) (define base-apply (scheme apply)) + (define base-prop:procedure (scheme prop:procedure)) (define base-free-identifier=? (scheme free-identifier=?)) (define base-free-template-identifier=? (scheme free-template-identifier=?)) (define base-free-transformer-identifier=? (scheme free-transformer-identifier=?)) (define base-free-label-identifier=? (scheme free-label-identifier=?)))) @(def-base base-define base-define-struct base-if base-cond base-case base-top-interaction - base-open-input-file base-apply + base-open-input-file base-apply base-prop:procedure base-free-identifier=? base-free-template-identifier=? base-free-transformer-identifier=? base-free-label-identifier=?) @@ -201,6 +202,16 @@ The same as @|base-top-interaction| in @schememodname[scheme/base].} Like @base-apply from @schememodname[scheme/base], but without support for keyword arguments.} +@defthing[prop:procedure struct-type-property?]{ + +Like @base-prop:procedure from @schememodname[scheme/base], but even +if the property's value for a structure type is a procedure that +accepts keyword arguments, then instances of the structure type still +do not accept keyword arguments. (In contrast, if the property's value +is an integer for a field index, then a keyword-accepting procedure in +the field for an instance causes the instance to accept keyword +arguments.)} + @deftogether[( @defproc[(open-input-file [file path-string?] [mode (one-of/c 'text 'binary) 'binary]) input-port?] diff --git a/collects/scheme/private/kw.ss b/collects/scheme/private/kw.ss index 97d718218a..6a3d69d0ff 100644 --- a/collects/scheme/private/kw.ss +++ b/collects/scheme/private/kw.ss @@ -17,10 +17,11 @@ (rename *make-keyword-procedure make-keyword-procedure) keyword-apply procedure-keywords - procedure-reduce-keyword-arity) + procedure-reduce-keyword-arity + new-prop:procedure) ;; ---------------------------------------- - + (-define-struct keyword-procedure (proc required allowed)) (define-values (struct:keyword-method make-km keyword-method? km-ref km-set!) (make-struct-type 'procedure @@ -113,6 +114,11 @@ (list (cons prop:arity-string generate-arity-string)) (current-inspector) fail-proc)]) mk)) + + ;; Allows keyword application to see into a "method"-style procedure attribute: + (define-values (new-prop:procedure new-procedure? new-procedure-ref) + (make-struct-type-property 'procedure #f + (list (cons prop:procedure values)))) ;; ---------------------------------------- @@ -188,11 +194,16 @@ [(keyword-procedure? p) (values (keyword-procedure-required p) (keyword-procedure-allowed p))] - [(procedure? p) - (let ([p (procedure-extract-target p)]) - (if p - (procedure-keywords p) - (values null null)))] + [(procedure? p) + (let ([p2 (procedure-extract-target p)]) + (if p2 + (procedure-keywords p2) + (if (new-procedure? p) + (let ([v (new-procedure-ref p)]) + (if (procedure? v) + (procedure-keywords v) + (values null null))) + (values null null))))] [else (raise-type-error 'procedure-keywords "procedure" p)])) @@ -716,7 +727,7 @@ ;; Extracts the procedure using the keyword-argument protocol. ;; If `p' doesn't accept keywords, make up a procedure that ;; reports an error. - (define (keyword-procedure-extract kws n p) + (define (keyword-procedure-extract/method kws n p method-n) (if (and (keyword-procedure? p) (procedure-arity-includes? (keyword-procedure-proc p) n) (let-values ([(missing-kw extra-kw) (check-kw-args p kws)]) @@ -727,22 +738,35 @@ (let ([p2 (if (keyword-procedure? p) #f (if (procedure? p) - (procedure-extract-target p) + (or (procedure-extract-target p) + (and (new-procedure? p) + 'method)) #f))]) (if p2 ;; Maybe the target is ok: - (keyword-procedure-extract kws n p2) + (if (eq? p2 'method) + ;; Build wrapper method: + (let ([p3 (keyword-procedure-extract/method kws (add1 n) + (new-procedure-ref p) + (add1 method-n))]) + (lambda (kws kw-args . args) + (apply p3 kws kw-args (cons p args)))) + ;; Recur: + (keyword-procedure-extract/method kws n p2 method-n)) ;; Not ok, period: (lambda (kws kw-args . args) (let-values ([(missing-kw extra-kw) (if (keyword-procedure? p) (check-kw-args p kws) (values #f (car kws)))] - [(n) (if (and (positive? n) - (or (keyword-method? p) - (okm? p))) - (sub1 n) - n)]) + [(n) (let ([method-n (+ method-n + (if (or (keyword-method? p) + (okm? p)) + 1 + 0))]) + (if (n . >= . method-n) + (- n method-n) + n))]) (let ([args-str (if (and (null? args) (null? kws)) @@ -791,6 +815,8 @@ p args-str))) (current-continuation-marks)))))))))) + (define (keyword-procedure-extract kws n p) + (keyword-procedure-extract/method kws n p 0)) ;; setting procedure arity (define (procedure-reduce-keyword-arity proc arity req-kw allowed-kw) diff --git a/collects/scheme/private/pre-base.ss b/collects/scheme/private/pre-base.ss index a34751c581..83433586c9 100644 --- a/collects/scheme/private/pre-base.ss +++ b/collects/scheme/private/pre-base.ss @@ -64,11 +64,12 @@ (rename new-define define) (rename new-app #%app) (rename new-apply apply) + (rename new-prop:procedure prop:procedure) (rename #%app #%plain-app) (rename lambda #%plain-lambda) (rename #%module-begin #%plain-module-begin) (rename module-begin #%module-begin) - (all-from-except '#%kernel lambda λ #%app #%module-begin apply) + (all-from-except '#%kernel lambda λ #%app #%module-begin apply prop:procedure) (all-from "reqprov.ss") (all-from "for.ss") #%top-interaction diff --git a/collects/scribble/scribble.css b/collects/scribble/scribble.css index 25b28ec173..60b3523501 100644 --- a/collects/scribble/scribble.css +++ b/collects/scribble/scribble.css @@ -144,7 +144,7 @@ table td { margin-right: 2em; } .tocset td { - vertical-align: top; + vertical-align: text-top; } .tocview { @@ -387,7 +387,7 @@ i { .inlinetop{ display: inline; - vertical-align: top; + vertical-align: text-top; } .together { @@ -395,7 +395,7 @@ i { } .prototype td { - vertical-align: top; + vertical-align: text-top; } .longprototype td { vertical-align: bottom; @@ -406,7 +406,7 @@ i { } .argcontract td { - vertical-align: top; + vertical-align: text-top; } .ghost { @@ -458,7 +458,7 @@ i { .techoutside:hover>.techinside { color: inherit; } .bibliography td { - vertical-align: top; + vertical-align: text-top; } .imageleft { diff --git a/collects/scribblings/reference/procedures.scrbl b/collects/scribblings/reference/procedures.scrbl index d698472a60..168ca303b5 100644 --- a/collects/scribblings/reference/procedures.scrbl +++ b/collects/scribblings/reference/procedures.scrbl @@ -257,11 +257,12 @@ immutability of procedure fields disallows cycles in the procedure graph, so that the procedure call will eventually continue with a non-structure procedure.) That procedure receives all of the arguments from the application expression. The procedure's name (see -@scheme[object-name]) and arity (see @scheme[procedure-arity]) are also -used for the name and arity of the structure. If the value in the -designated field is not a procedure, then the instance behaves like -@scheme[(case-lambda)] (i.e., a procedure which does not accept any -number of arguments). See also @scheme[procedure-extract-target]. +@scheme[object-name]), arity (see @scheme[procedure-arity]), and +keyword protocol (see @scheme[procedure-keywords]) are also used for +the name, arity, and keyword protocol of the structure. If the value +in the designated field is not a procedure, then the instance behaves +like @scheme[(case-lambda)] (i.e., a procedure which does not accept +any number of arguments). See also @scheme[procedure-extract-target]. Providing an integer @scheme[proc-spec] argument to @scheme[make-struct-type] is the same as both supplying the value with @@ -283,16 +284,18 @@ redundant and disallowed). ] When the @scheme[prop:procedure] value is a procedure, it should -accept at least one argument. When an instance of the structure is -used in an application expression, the property-value procedure is -called with the instance as the first argument. The remaining -arguments to the property-value procedure are the arguments from the -application expression. Thus, if the application expression contained -five arguments, the property-value procedure is called with six -arguments. The name of the instance (see @scheme[object-name]) is -unaffected by the property-value procedure, but the instance's arity -is determined by subtracting one from every possible argument count of -the property-value procedure. If the property-value procedure cannot +accept at least one non-keyword argument. When an instance of the +structure is used in an application expression, the property-value +procedure is called with the instance as the first argument. The +remaining arguments to the property-value procedure are the arguments +from the application expression (including keyword arguments). Thus, +if the application expression provides five non-keyword arguments, the +property-value procedure is called with six non-keyword arguments. The +name of the instance (see @scheme[object-name]) and its keyword +protocol (see @scheme[procedure-keywords]) are unaffected by the +property-value procedure, but the instance's arity is determined by +subtracting one from every possible non-keyword argument count of the +property-value procedure. If the property-value procedure cannot accept at least one argument, then the instance behaves like @scheme[(case-lambda)]. @@ -315,14 +318,7 @@ is disallowed). (fish-weight wanda) (for-each wanda '(1 2 3)) (fish-weight wanda) -] - -If a structure type generates procedure instances, then subtypes of -the type also generate procedure instances. The instances behave the -same as instances of the original type. When a @scheme[prop:procedure] -property or non-@scheme[#f] @scheme[proc-spec] is supplied to -@scheme[make-struct-type] with a supertype that already behaves as a -procedure, the @exnraise[exn:fail:contract].} +]} @defproc[(procedure-struct-type? [type struct-type?]) boolean?]{ @@ -336,7 +332,15 @@ If @scheme[proc] is an instance of a structure type with property @scheme[prop:procedure], and if the property value indicates a field of the structure, and if the field value is a procedure, then @scheme[procedure-extract-target] returns the field value. Otherwise, -the result if @scheme[#f].} +the result if @scheme[#f]. + +When a @scheme[prop:procedure] property value is a procedure, the +procedure is @emph{not} returned by +@scheme[procedure-extract-target]. Such a procedure is different from +one accessed through a structure field, because it consumes an extra +argument, which is always the structure that was applied as a +procedure. Keeping the procedure private ensures that is it always +called with a suitable first argument.} @defthing[prop:arity-string struct-type-property?]{ diff --git a/collects/scribblings/reference/regexps.scrbl b/collects/scribblings/reference/regexps.scrbl index 080fae142b..d9553444d1 100644 --- a/collects/scribblings/reference/regexps.scrbl +++ b/collects/scribblings/reference/regexps.scrbl @@ -553,19 +553,22 @@ an end-of-file if @scheme[input] is an input port). @defproc[(regexp-replace [pattern (or/c string? bytes? regexp? byte-regexp?)] [input (or/c string? bytes?)] [insert (or/c string? bytes? - (string? . -> . string?) - (bytes? . -> . bytes?))]) + ((string?) () #:rest (listof string?) . ->* . string?) + ((bytes?) () #:rest (listof bytes?) . ->* . bytes?))]) (or/c string? bytes?)]{ Performs a match using @scheme[pattern] on @scheme[input], and then returns a string or byte string in which the matching portion of @scheme[input] is replaced with @scheme[insert]. If @scheme[pattern] matches no part of @scheme[input], then @scheme[iput] is returned -unmodified. @scheme[insert] can be either a (byte) string, or a -function that returns a (byte) string --- in this case, the function -is applied on the list of values that @scheme[regexp-match] would -return (i.e., the first argument is the complete match, and then one -argument for each parenthesized sub-expression). +unmodified. + +The @scheme[insert] argument can be either a (byte) string, or a +function that returns a (byte) string. In the latter case, the +function is applied on the list of values that @scheme[regexp-match] +would return (i.e., the first argument is the complete match, and then +one argument for each parenthesized sub-expression) to obtain a +replacement (byte) string. If @scheme[pattern] is a string or character regexp and @scheme[input] is a string, then @scheme[insert] must be a string or a procedure that diff --git a/collects/scribblings/reference/struct.scrbl b/collects/scribblings/reference/struct.scrbl index dc77e07b17..9105c07995 100644 --- a/collects/scribblings/reference/struct.scrbl +++ b/collects/scribblings/reference/struct.scrbl @@ -119,9 +119,12 @@ are initialized with @scheme[auto-v]. The total field count (including The @scheme[props] argument is a list of pairs, where the @scheme[car] of each pair is a structure type property descriptor, and the -@scheme[cdr] is an arbitrary value. See @secref["structprops"] for -more information about properties. When @scheme[inspector] is -@scheme['prefab], then @scheme[props] must be @scheme[null]. +@scheme[cdr] is an arbitrary value. Each property in @scheme[props] +must be distinct, including properties that are automatically added by +properties that are directly included in @scheme[props]. See +@secref["structprops"] for more information about properties. When +@scheme[inspector] is @scheme['prefab], then @scheme[props] must be +@scheme[null]. The @scheme[inspector] argument normally controls access to reflective information about the structure type and its instances; see @@ -133,9 +136,9 @@ If @scheme[proc-spec] is an integer or procedure, instances of the structure type act as procedures. See @scheme[prop:procedure] for further information. Providing a non-@scheme[#f] value for @scheme[proc-spec] is the same as pairing the value with -@scheme[prop:procedure] in @scheme[props], plus including -@scheme[proc-spec] in @scheme[immutables] when -@scheme[proc-spec] is an integer. +@scheme[prop:procedure] at the end of @scheme[props], plus including +@scheme[proc-spec] in @scheme[immutables] when @scheme[proc-spec] is +an integer. The @scheme[immutables] argument provides a list of field positions. Each element in the list must be unique, otherwise @@ -274,12 +277,15 @@ A @deftech{structure type property} allows per-type information to be property value with a new value. @defproc[(make-struct-type-property [name symbol?] - [guard (or/c procedure? false/c) #f]) + [guard (or/c procedure? false/c) #f] + [supers (listof (cons/c struct-type-property? + (any/c . -> . any/c))) + null]) (values struct-type-property? procedure? procedure?)]{ - Creates a new structure type property and returns three values: +Creates a new structure type property and returns three values: @itemize{ @@ -317,6 +323,14 @@ inappropriate for the property), the @scheme[guard] can raise an exception. Such an exception prevents @scheme[make-struct-type] from returning a structure type descriptor. +The optional @scheme[supers] argument is a list of properties that are +automatically associated with some structure type when the newly +created property is associated to the structure type. Each property in +@scheme[supers] is paired with a procedure that receives the value +supplied for the new property (after it is processed by +@scheme[guard]) and returns a value for the associated property (which +is then sent to that property's guard, of any). + @examples[ #:eval struct-eval (define-values (prop:p p? p-ref) (make-struct-type-property 'p)) @@ -333,6 +347,15 @@ returning a structure type descriptor. (define-values (struct:b make-b b? b-ref b-set!) (make-struct-type 'b #f 0 0 #f)) (p? struct:b) + +(define-values (prop:q q? q-ref) (make-struct-type-property + 'q (lambda (v si) (add1 v)) + (list (cons prop:p sqrt)))) +(define-values (struct:c make-c c? c-ref c-set!) + (make-struct-type 'c #f 0 0 'uninit + (list (cons prop:q 8)))) +(q-ref struct:c) +(p-ref struct:c) ]} @defproc[(struct-type-property? [v any/c]) boolean?]{ diff --git a/collects/tests/mzscheme/struct.ss b/collects/tests/mzscheme/struct.ss index a66f4e2d6f..f2fb73a171 100644 --- a/collects/tests/mzscheme/struct.ss +++ b/collects/tests/mzscheme/struct.ss @@ -7,7 +7,7 @@ [(prop:p2 p2? p2-ref) (make-struct-type-property 'prop2)] [(insp1) (make-inspector)] [(insp2) (make-inspector)]) - (arity-test make-struct-type-property 1 2) + (arity-test make-struct-type-property 1 3) (test 3 primitive-result-arity make-struct-type-property) (arity-test p? 1 1) (arity-test p-ref 1 1) @@ -323,10 +323,12 @@ (cons b a)) 2 values values '(2 . 1) t-insp)) -(err/rt-test (let-values ([(s:s make-s s? s-ref s-set!) - (make-struct-type 'a #f 1 1 #f null (current-inspector) 0)]) - (make-struct-type 'b s:s 1 1 #f null (current-inspector) 0)) - exn:application:mismatch?) +;; Override super-struct procedure spec: +(let-values ([(s:s make-s s? s-ref s-set!) + (make-struct-type 'a #f 1 1 #f null (current-inspector) 0)]) + (let-values ([(s:b make-b b? b-ref s-set!) + (make-struct-type 'b s:s 1 1 #f null (current-inspector) 0)]) + (test 11 (make-b 1 add1) 10))) (let-values ([(type make pred sel set) (make-struct-type 'p #f 1 0 #f null (current-inspector) (lambda () 5))]) (let ([useless (make 7)]) @@ -633,6 +635,68 @@ two132-a x132 6 one32-y x132 4)))) +;; ------------------------------------------------------------ +;; Property type supers + +(require (only-in mzscheme [prop:procedure mz:prop:procedure])) ; more primitive - no keywords + +(let ([try + (lambda (base prop:procedure) + (err/rt-test (make-struct-type '? base 1 0 #f (list (cons prop:procedure 0) + (cons prop:procedure 0)) + #f #f '(0))) + (err/rt-test (make-struct-type '? base 1 0 #f (list (cons prop:procedure 0)) #f 0)) + (let-values ([(prop:s s? s-get) + (make-struct-type-property 's #f (list (cons prop:procedure (lambda (v) (add1 v)))))]) + (define-struct a (x y) #:super base #:property prop:s 0) + (test 0 s-get struct:a) + (test #t procedure-struct-type? struct:a) + (test 5 (make-a 1 (lambda (v) (+ 2 v))) 3) + + (err/rt-test (make-struct-type-property 't #f 10)) + (err/rt-test (make-struct-type-property 't #f (list (cons prop:s 10)))) + (err/rt-test (make-struct-type-property 't #f (list (cons prop:s void) (cons prop:procedure void)))) + + (let-values ([(prop:t t? t-get) + (make-struct-type-property 't #f (list (cons prop:s (lambda (v) (add1 v)))))] + [(prop:u u? u-get) + (make-struct-type-property 'u)]) + (define-struct b (x y z) #:super base #:property prop:u '? #:property prop:t 0) + (test 8 (make-b 1 2 (lambda (v) (- v 4))) 12) + (test 0 t-get struct:b) + (test 1 s-get struct:b) + (test '? u-get struct:b) + + (let-values ([(prop:w w? w-get) + (make-struct-type-property 'w (lambda (v s) (sub1 v)) (list (cons prop:u values)))] + [(prop:z z? z-get) + (make-struct-type-property 'z #f (list (cons prop:u values)))]) + (define-struct c () #:super base #:property prop:w 10) + (test 9 w-get struct:c) + (test 9 u-get struct:c) ; i.e., after guard + + (err/rt-test (make-struct-type '? base 0 0 #f (list (cons prop:w 3) (cons prop:z 3)))) + (err/rt-test (make-struct-type '? base 3 0 #f (list (cons prop:s 0) (cons prop:t 0)) #f #f '(0 1 2))) + (err/rt-test (make-struct-type '? base 3 0 #f (list (cons prop:s 0) (cons prop:procedure 0)) #f #f '(0 1 2))) + ))))]) + + (try #f mz:prop:procedure) + (try #f prop:procedure) + (let ([props (map (lambda (n) + (let-values ([(prop ? -get) (make-struct-type-property n)]) + prop)) + '(a b c d e f g h j i))]) + (let-values ([(s: make-s s? s-ref s-set!) + (make-struct-type 'base #f 0 0 #f (map (lambda (p) (cons p 5)) props))]) + (try s: mz:prop:procedure) + (try s: prop:procedure)))) + +(let () + (define-struct a (x y) #:property prop:procedure (lambda (s v #:kw [kw #f]) (list (a-x s) v kw))) + (test '(1 3 #f) (make-a 1 2) 3) + (test '(1 3 8) 'kw ((make-a 1 2) 3 #:kw 8)) + (test-values '(() (#:kw)) (lambda () (procedure-keywords (make-a 1 2))))) + ;; ------------------------------------------------------------ ;; Check that struct definiton sequences work: diff --git a/doc/release-notes/mzscheme/HISTORY.txt b/doc/release-notes/mzscheme/HISTORY.txt index 01999c4757..3ea68d65b7 100644 --- a/doc/release-notes/mzscheme/HISTORY.txt +++ b/doc/release-notes/mzscheme/HISTORY.txt @@ -2,6 +2,8 @@ Version 4.1 Changed namespaces to have a base phase; for example, calling eval at compile-time uses a phase-1 namespace Added logging facilities: make-logger, etc. +Added "inheritance" to structure type properties, and change + prop:procedure from scheme/base to better support keywords Version 4.0, June 2008 >> See MzScheme_4.txt diff --git a/src/mzscheme/src/mzmark.c b/src/mzscheme/src/mzmark.c index 2a5827ea10..d12df5ef6b 100644 --- a/src/mzscheme/src/mzmark.c +++ b/src/mzscheme/src/mzmark.c @@ -4578,6 +4578,7 @@ static int mark_struct_property_MARK(void *p) { Scheme_Struct_Property *i = (Scheme_Struct_Property *)p; gcMARK(i->name); gcMARK(i->guard); + gcMARK(i->supers); return gcBYTES_TO_WORDS(sizeof(Scheme_Struct_Property)); } @@ -4586,6 +4587,7 @@ static int mark_struct_property_FIXUP(void *p) { Scheme_Struct_Property *i = (Scheme_Struct_Property *)p; gcFIXUP(i->name); gcFIXUP(i->guard); + gcFIXUP(i->supers); return gcBYTES_TO_WORDS(sizeof(Scheme_Struct_Property)); } diff --git a/src/mzscheme/src/mzmarksrc.c b/src/mzscheme/src/mzmarksrc.c index e6170b2a79..c2999acb61 100644 --- a/src/mzscheme/src/mzmarksrc.c +++ b/src/mzscheme/src/mzmarksrc.c @@ -1863,6 +1863,7 @@ mark_struct_property { Scheme_Struct_Property *i = (Scheme_Struct_Property *)p; gcMARK(i->name); gcMARK(i->guard); + gcMARK(i->supers); size: gcBYTES_TO_WORDS(sizeof(Scheme_Struct_Property)); } diff --git a/src/mzscheme/src/schpriv.h b/src/mzscheme/src/schpriv.h index 65db4c3969..058c74b31c 100644 --- a/src/mzscheme/src/schpriv.h +++ b/src/mzscheme/src/schpriv.h @@ -507,6 +507,7 @@ typedef struct Scheme_Struct_Property { Scheme_Object so; Scheme_Object *name; /* a symbol */ Scheme_Object *guard; /* NULL or a procedure */ + Scheme_Object *supers; /* implied properties: listof (cons ) */ } Scheme_Struct_Property; int scheme_inspector_sees_part(Scheme_Object *s, Scheme_Object *insp, int pos); diff --git a/src/mzscheme/src/schvers.h b/src/mzscheme/src/schvers.h index 5749ddb116..105f3d3913 100644 --- a/src/mzscheme/src/schvers.h +++ b/src/mzscheme/src/schvers.h @@ -13,12 +13,12 @@ consistently.) */ -#define MZSCHEME_VERSION "4.0.2.4" +#define MZSCHEME_VERSION "4.0.2.5" #define MZSCHEME_VERSION_X 4 #define MZSCHEME_VERSION_Y 0 #define MZSCHEME_VERSION_Z 2 -#define MZSCHEME_VERSION_W 4 +#define MZSCHEME_VERSION_W 5 #define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y) #define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W) diff --git a/src/mzscheme/src/struct.c b/src/mzscheme/src/struct.c index 77a9a5d610..75d2bd8ef7 100644 --- a/src/mzscheme/src/struct.c +++ b/src/mzscheme/src/struct.c @@ -20,6 +20,7 @@ */ #include "schpriv.h" +#include "schmach.h" #define PROP_USE_HT_COUNT 5 @@ -360,7 +361,7 @@ scheme_init_struct (Scheme_Env *env) scheme_add_global_constant("make-struct-type-property", scheme_make_prim_w_arity2(make_struct_type_property, "make-struct-type-property", - 1, 2, + 1, 3, 3, 3), env); @@ -751,16 +752,63 @@ static Scheme_Object *prop_accessor(int argc, Scheme_Object **args, Scheme_Objec static Scheme_Object *make_struct_type_property(int argc, Scheme_Object *argv[]) { Scheme_Struct_Property *p; - Scheme_Object *a[3], *v; + Scheme_Object *a[3], *v, *supers = scheme_null; char *name; int len; if (!SCHEME_SYMBOLP(argv[0])) scheme_wrong_type("make-struct-type-property", "symbol", 0, argc, argv); - if ((argc > 1) - && SCHEME_TRUEP(argv[1]) - && !scheme_check_proc_arity(NULL, 2, 1, argc, argv)) { - scheme_wrong_type("make-struct-type-property", "procedure (arity 2) or #f", 1, argc, argv); + if (argc > 1) { + if (SCHEME_TRUEP(argv[1]) + && !scheme_check_proc_arity(NULL, 2, 1, argc, argv)) + scheme_wrong_type("make-struct-type-property", "procedure (arity 2) or #f", 1, argc, argv); + + if (argc > 2) { + supers = argv[2]; + if (scheme_proper_list_length(supers) < 0) + supers = NULL; + else { + Scheme_Object *pr; + for (pr = supers; supers && SCHEME_PAIRP(pr); pr = SCHEME_CDR(pr)) { + v = SCHEME_CAR(pr); + if (!SCHEME_PAIRP(v)) { + supers = NULL; + } else { + if (!SAME_TYPE(SCHEME_TYPE(SCHEME_CAR(v)), scheme_struct_property_type)) + supers = NULL; + a[0] = SCHEME_CDR(v); + if (!scheme_check_proc_arity(NULL, 1, 0, 1, a)) + supers = NULL; + } + } + } + + if (!supers) { + scheme_wrong_type("make-struct-type-property", + "list of pairs of structure type properties and procedures (arity 1)", + 2, argc, argv); + } + + if (SCHEME_PAIRP(supers) && SCHEME_PAIRP(SCHEME_CDR(supers))) { + /* check for duplicates */ + Scheme_Hash_Table *ht; + Scheme_Object *stack = supers; + ht = scheme_make_hash_table(SCHEME_hash_ptr); + while (SCHEME_PAIRP(stack)) { + v = SCHEME_CAR(stack); + if (SCHEME_PAIRP(v)) v = SCHEME_CAR(v); /* appended item */ + p = (Scheme_Struct_Property *)v; + stack = SCHEME_CDR(stack); + if (scheme_hash_get(ht, (Scheme_Object *)p)) { + scheme_arg_mismatch("make-struct-type-property", + "super structure type property appears twice in given hierarchy: ", + (Scheme_Object *)p); + } + scheme_hash_set(ht, (Scheme_Object *)p, scheme_true); + stack = scheme_append(p->supers, stack); + } + } + } } p = MALLOC_ONE_TAGGED(Scheme_Struct_Property); @@ -768,6 +816,7 @@ static Scheme_Object *make_struct_type_property(int argc, Scheme_Object *argv[]) p->name = argv[0]; if ((argc > 1) && SCHEME_TRUEP(argv[1])) p->guard = argv[1]; + p->supers = supers; a[0] = (Scheme_Object *)p; @@ -828,20 +877,61 @@ static Scheme_Object *guard_property(Scheme_Object *prop, Scheme_Object *v, Sche { Scheme_Struct_Property *p = (Scheme_Struct_Property *)prop; - if (p->guard) { - Scheme_Object *a[2], *info[mzNUM_ST_INFO], *l; + if (SAME_OBJ(prop, proc_property)) { + /* prop:procedure guard: */ + Scheme_Object *orig_v = v; + if (SCHEME_INTP(v) || SCHEME_BIGNUMP(v)) { + long pos; - a[0] = (Scheme_Object *)t; - get_struct_type_info(1, a, info, 1); + if (SCHEME_INTP(v)) + pos = SCHEME_INT_VAL(v); + else + pos = t->num_slots; /* too big */ - l = scheme_build_list(mzNUM_ST_INFO, info); + if (pos >= t->num_islots) { + scheme_arg_mismatch("make-struct-type", "index for procedure >= initialized-field count: ", v); + return NULL; + } + + if (t->name_pos > 0) { + Scheme_Struct_Type *parent_type; + parent_type = t->parent_types[t->name_pos - 1]; + + pos += parent_type->num_slots; + v = scheme_make_integer(pos); + } + } + + t->proc_attr = v; + + if (SCHEME_INTP(v)) { + long pos; + pos = SCHEME_INT_VAL(v); + if (!t->immutables || !t->immutables[pos]) { + scheme_arg_mismatch("make-struct-type", + "field is not specified as immutable for a prop:procedure index: ", + orig_v); + } + } - a[0] = v; - a[1] = l; - - return _scheme_apply(p->guard, 2, a); - } else return v; + } else { + /* Normal guard handling: */ + if (p->guard) { + Scheme_Object *a[2], *info[mzNUM_ST_INFO], *l; + + a[0] = (Scheme_Object *)t; + get_struct_type_info(1, a, info, 1); + + l = scheme_build_list(mzNUM_ST_INFO, info); + + a[0] = v; + a[1] = l; + + return _scheme_apply(p->guard, 2, a); + } else + return v; + } } /*========================================================================*/ @@ -2627,6 +2717,77 @@ Scheme_Object *scheme_make_struct_exptime(Scheme_Object **names, int count, /* struct type */ /*========================================================================*/ +static Scheme_Object *count_k(void); + +static int count_non_proc_props(Scheme_Object *props) +{ + Scheme_Struct_Property *p; + Scheme_Object *v; + int count = 0; + + { +#include "mzstkchk.h" + { + scheme_current_thread->ku.k.p1 = (void *)props; + return SCHEME_INT_VAL(scheme_handle_stack_overflow(count_k)); + } + } + SCHEME_USE_FUEL(1); + + for (; SCHEME_PAIRP(props); props = SCHEME_CDR(props)) { + v = SCHEME_CAR(props); + p = (Scheme_Struct_Property *)SCHEME_CAR(v); + if (!SAME_OBJ((Scheme_Object *)p, proc_property)) + count++; + if (p->supers) { + count += count_non_proc_props(p->supers); + } + } + + return count; +} + +static Scheme_Object *count_k(void) +{ + Scheme_Thread *p = scheme_current_thread; + Scheme_Object *props = (Scheme_Object *)p->ku.k.p1; + int c; + + p->ku.k.p1 = NULL; + + c = count_non_proc_props(props); + + return scheme_make_integer(c); +} + +static Scheme_Object *append_super_props(Scheme_Struct_Property *p, Scheme_Object *arg, Scheme_Object *orig) +{ + Scheme_Object *first = NULL, *last = NULL, *props, *pr, *v, *a[1]; + + if (p->supers) { + props = p->supers; + for (; SCHEME_PAIRP(props); props = SCHEME_CDR(props)) { + v = SCHEME_CAR(props); + + a[0] = arg; + v = scheme_make_pair(SCHEME_CAR(v), _scheme_apply(SCHEME_CDR(v), 1, a)); + + pr = scheme_make_pair(v, scheme_null); + if (last) + SCHEME_CDR(last) = pr; + else + first = pr; + last = pr; + } + } + + if (last) { + SCHEME_CDR(last) = orig; + return first; + } else + return orig; +} + static Scheme_Object *_make_struct_type(Scheme_Object *basesym, const char *base, int blen, Scheme_Object *parent, Scheme_Object *inspector, @@ -2640,7 +2801,6 @@ static Scheme_Object *_make_struct_type(Scheme_Object *basesym, const char *base { Scheme_Struct_Type *struct_type, *parent_type; int j, depth; - int props_delta = 0, prop_needs_const = 0; parent_type = (Scheme_Struct_Type *)parent; @@ -2711,58 +2871,9 @@ static Scheme_Object *_make_struct_type(Scheme_Object *basesym, const char *base uninit_val = scheme_false; struct_type->uninit_val = uninit_val; - if (props) { - Scheme_Object *l; - for (l = props; !SCHEME_NULLP(l); l = SCHEME_CDR(l)) { - if (SAME_OBJ(SCHEME_CAAR(l), proc_property)) { - if (proc_attr) { - scheme_arg_mismatch("make-struct-type", - "given both a prop:procedure property value and a procedure specification: ", - proc_attr); - } - proc_attr = SCHEME_CDR(SCHEME_CAR(l)); - if (SCHEME_INTP(proc_attr)) - prop_needs_const = 1; - props_delta = 1; - break; - } - } - } - - if (proc_attr) { - Scheme_Object *pa = proc_attr; - - if (SCHEME_INTP(pa) || SCHEME_BIGNUMP(pa)) { - long pos; - - if (SCHEME_INTP(pa)) - pos = SCHEME_INT_VAL(pa); - else - pos = struct_type->num_slots; /* too big */ - - if (pos >= struct_type->num_islots) { - scheme_arg_mismatch("make-struct-type", "index for procedure >= initialized-field count: ", pa); - return NULL; - } - - if (parent_type) { - if (parent_type->proc_attr) { - scheme_arg_mismatch("make-struct-type", - "parent type already has procedure specification, new one disallowed: ", - pa); - return NULL; - } - - pos += parent_type->num_slots; - pa = scheme_make_integer(pos); - } - } - - struct_type->proc_attr = pa; - } - if ((struct_type->proc_attr && SCHEME_INTP(struct_type->proc_attr)) - || !SCHEME_NULLP(immutable_pos_list)) { + || !SCHEME_NULLP(immutable_pos_list) + || (proc_attr && SCHEME_INTP(proc_attr))) { Scheme_Object *l, *a; char *ims; int n, p; @@ -2773,9 +2884,12 @@ static Scheme_Object *_make_struct_type(Scheme_Object *basesym, const char *base ims = (char *)scheme_malloc_atomic(n); memset(ims, 0, n); - if (proc_attr && SCHEME_INTP(proc_attr) && !prop_needs_const) { + if (proc_attr && SCHEME_INTP(proc_attr)) { p = SCHEME_INT_VAL(proc_attr); - ims[p] = 1; + if (parent_type) + p += parent_type->num_slots; + if (p < struct_type->num_slots) + ims[p] = 1; } for (l = immutable_pos_list; SCHEME_PAIRP(l); l = SCHEME_CDR(l)) { @@ -2801,15 +2915,6 @@ static Scheme_Object *_make_struct_type(Scheme_Object *basesym, const char *base ims[p] = 1; } - - if (proc_attr && SCHEME_INTP(proc_attr) && prop_needs_const) { - p = SCHEME_INT_VAL(proc_attr); - if (!ims[p]) { - scheme_arg_mismatch("make-struct-type", - "field is not specified as immutable for a prop:procedure index: ", - proc_attr); - } - } struct_type->immutables = ims; } @@ -2817,14 +2922,19 @@ static Scheme_Object *_make_struct_type(Scheme_Object *basesym, const char *base /* We add properties last, because a property guard receives a struct-type descriptor. */ + if (proc_attr) + props = scheme_append(props ? props : scheme_null, + scheme_make_pair(scheme_make_pair(proc_property, proc_attr), + scheme_null)); + if (props) { - int num_props, i; + int num_props, i, proc_prop_set = 0; Scheme_Hash_Table *can_override; Scheme_Object *l, *a, *prop, *propv; can_override = scheme_make_hash_table(SCHEME_hash_ptr); - num_props = scheme_list_length(props) - props_delta; + num_props = count_non_proc_props(props); if ((struct_type->num_props < 0) || (struct_type->num_props + num_props > PROP_USE_HT_COUNT)) { Scheme_Hash_Table *ht; @@ -2849,27 +2959,30 @@ static Scheme_Object *_make_struct_type(Scheme_Object *basesym, const char *base } /* Add new props: */ - for (l = props; SCHEME_PAIRP(l); l = SCHEME_CDR(l)) { + for (l = props; SCHEME_PAIRP(l); ) { a = SCHEME_CAR(l); prop = SCHEME_CAR(a); - if (SAME_OBJ(prop, proc_property)) { - if (props_delta) - props_delta = 0; - else + + if (scheme_hash_get(ht, prop)) { + /* Property is already in the superstruct_type */ + if (!scheme_hash_get(can_override, prop)) + break; + /* otherwise we override */ + scheme_hash_set(can_override, prop, NULL); + } else if (SAME_OBJ(prop, proc_property)) { + if (proc_prop_set) break; - } else { - if (scheme_hash_get(ht, prop)) { - /* Property is already in the superstruct_type */ - if (!scheme_hash_get(can_override, prop)) - break; - /* otherwise we override */ - scheme_hash_set(can_override, prop, NULL); - } - - propv = guard_property(prop, SCHEME_CDR(a), struct_type); - - scheme_hash_set(ht, prop, propv); } + + propv = guard_property(prop, SCHEME_CDR(a), struct_type); + + l = SCHEME_CDR(l); + l = append_super_props((Scheme_Struct_Property *)prop, propv, l); + + if (SAME_OBJ(prop, proc_property)) + proc_prop_set = 1; + else + scheme_hash_set(ht, prop, propv); } struct_type->props = (Scheme_Object **)ht; @@ -2890,18 +3003,17 @@ static Scheme_Object *_make_struct_type(Scheme_Object *basesym, const char *base num_props = i; - for (l = props; SCHEME_PAIRP(l); l = SCHEME_CDR(l)) { + for (l = props; SCHEME_PAIRP(l); ) { a = SCHEME_CAR(l); prop = SCHEME_CAR(a); + /* Check whether already in table: */ if (SAME_OBJ(prop, proc_property)) { - if (props_delta) - props_delta = 0; - else + if (proc_prop_set) break; + j = 0; } else { - /* Check whether already in table: */ for (j = 0; j < num_props; j++) { if (SAME_OBJ(SCHEME_CAR(pa[j]), prop)) break; @@ -2912,19 +3024,27 @@ static Scheme_Object *_make_struct_type(Scheme_Object *basesym, const char *base break; /* overriding it: */ scheme_hash_set(can_override, prop, NULL); - } else { + } else num_props++; - } - - propv = guard_property(prop, SCHEME_CDR(a), struct_type); + } + + propv = guard_property(prop, SCHEME_CDR(a), struct_type); + l = SCHEME_CDR(l); + l = append_super_props((Scheme_Struct_Property *)prop, propv, l); + + if (SAME_OBJ(prop, proc_property)) + proc_prop_set = 1; + else { a = scheme_make_pair(prop, propv); pa[j] = a; } } - - struct_type->num_props = num_props; - struct_type->props = pa; + + if (num_props) { + struct_type->num_props = num_props; + struct_type->props = pa; + } } if (!SCHEME_NULLP(l)) {