suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

properties can now effectively inherit properties (v4.0.2.5)

Browse Source 
svn: r10848
This commit is contained in:
Matthew Flatt 2008-07-21 17:04:25 +00:00
parent 5a6a9ed653
commit 763d37d775
14 changed files with 437 additions and 179 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

15
collects/mzscheme/mzscheme.scrbl
View File

@ -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?]

56
collects/scheme/private/kw.ss
View File

@ -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)

3
collects/scheme/private/pre-base.ss
View File

@ -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

10
collects/scribble/scribble.css
View File

@ -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 {

52
collects/scribblings/reference/procedures.scrbl
View File

@ -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?]{

17
collects/scribblings/reference/regexps.scrbl
View File

@ -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

39
collects/scribblings/reference/struct.scrbl
View File

@ -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?]{

74
collects/tests/mzscheme/struct.ss
View File

@ -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:

2
doc/release-notes/mzscheme/HISTORY.txt
View File

@ -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

2
src/mzscheme/src/mzmark.c
View File

@ -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));
}

1
src/mzscheme/src/mzmarksrc.c
View File

@ -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));
}

1
src/mzscheme/src/schpriv.h
View File

@ -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 <prop> <proc>) */
} Scheme_Struct_Property;
int scheme_inspector_sees_part(Scheme_Object *s, Scheme_Object *insp, int pos);

4
src/mzscheme/src/schvers.h
View File

@ -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)

340
src/mzscheme/src/struct.c
View File

@ -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)) {