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

add structure-type sealing

Browse Source 
The predicate for a seald structure type can be faster than a
predicate for a non-sealed structure type, and Chez Scheme takes
advantage of that opportunity.

The BC JIT could be improved to take advanatge of sealed structure
types, but it isn't.

This commit also fixes CS checking of a supertype for certain shapes
of prefab struct-type declarations.
This commit is contained in:
Matthew Flatt 2021-02-13 07:01:06 -07:00
parent 1f68962d67
commit 0523a5311c
41 changed files with 6760 additions and 6307 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
.makefile
View File

@ -344,7 +344,7 @@ RACKET_FOR_BOOTFILES = $(RACKET)
RACKET_FOR_BUILD = $(RACKET)
# This branch name changes each time the pb boot files are updated:
PB_BRANCH == circa-8.0.0.6-3
PB_BRANCH == circa-8.0.0.7-1
PB_REPO = https://github.com/racket/pb
# Alternative source for Chez Scheme boot files, normally set by

12
Makefile
View File

@ -47,7 +47,7 @@ RACKETCS_SUFFIX =
RACKET =
RACKET_FOR_BOOTFILES = $(RACKET)
RACKET_FOR_BUILD = $(RACKET)
PB_BRANCH = circa-8.0.0.6-3
PB_BRANCH = circa-8.0.0.7-1
PB_REPO = https://github.com/racket/pb
EXTRA_REPOS_BASE =
CS_CROSS_SUFFIX =
@ -309,18 +309,18 @@ maybe-fetch-pb-as-is:
echo done
fetch-pb-from:
mkdir -p racket/src/ChezScheme/boot
if [ ! -d racket/src/ChezScheme/boot/pb ] ; then git clone -q -b circa-8.0.0.6-3 $(PB_REPO) racket/src/ChezScheme/boot/pb ; else cd racket/src/ChezScheme/boot/pb && git fetch -q origin circa-8.0.0.6-3:remotes/origin/circa-8.0.0.6-3 ; fi
cd racket/src/ChezScheme/boot/pb && git checkout -q circa-8.0.0.6-3
if [ ! -d racket/src/ChezScheme/boot/pb ] ; then git clone -q -b circa-8.0.0.7-1 $(PB_REPO) racket/src/ChezScheme/boot/pb ; else cd racket/src/ChezScheme/boot/pb && git fetch -q origin circa-8.0.0.7-1:remotes/origin/circa-8.0.0.7-1 ; fi
cd racket/src/ChezScheme/boot/pb && git checkout -q circa-8.0.0.7-1
pb-fetch:
$(MAKE) fetch-pb EXTRA_REPOS_BASE="$(EXTRA_REPOS_BASE)" PB_REPO="$(PB_REPO)"
pb-build:
cd racket/src/ChezScheme && racket rktboot/main.rkt --machine pb
pb-stage:
cd racket/src/ChezScheme/boot/pb && git branch circa-8.0.0.6-3
cd racket/src/ChezScheme/boot/pb && git checkout circa-8.0.0.6-3
cd racket/src/ChezScheme/boot/pb && git branch circa-8.0.0.7-1
cd racket/src/ChezScheme/boot/pb && git checkout circa-8.0.0.7-1
cd racket/src/ChezScheme/boot/pb && git add . && git commit --amend -m "new build"
pb-push:
cd racket/src/ChezScheme/boot/pb && git push -u origin circa-8.0.0.6-3
cd racket/src/ChezScheme/boot/pb && git push -u origin circa-8.0.0.7-1
win-cs-base:
IF "$(RACKET_FOR_BUILD)" == "" $(MAKE) win-bc-then-cs-base SETUP_BOOT_MODE=--boot WIN32_BUILD_LEVEL=bc PLAIN_RACKET=racket\racketbc DISABLE_STATIC_LIBS="$(DISABLE_STATIC_LIBS)" EXTRA_REPOS_BASE="$(EXTRA_REPOS_BASE)" JOB_OPTIONS="$(JOB_OPTIONS)" PLT_SETUP_OPTIONS="$(PLT_SETUP_OPTIONS)" RACKETBC_SUFFIX="$(RACKETBC_SUFFIX)" RACKETCS_SUFFIX="$(RACKETCS_SUFFIX)"
IF not "$(RACKET_FOR_BUILD)" == "" $(MAKE) win-just-cs-base SETUP_BOOT_MODE=--chain DISABLE_STATIC_LIBS="$(DISABLE_STATIC_LIBS)" EXTRA_REPOS_BASE="$(EXTRA_REPOS_BASE)" JOB_OPTIONS="$(JOB_OPTIONS)" PLT_SETUP_OPTIONS="$(PLT_SETUP_OPTIONS)" RACKETCS_SUFFIX="$(RACKETCS_SUFFIX)" RACKET_FOR_BUILD="$(RACKET_FOR_BUILD)"

2
pkgs/base/info.rkt
View File

@ -14,7 +14,7 @@
;; In the Racket source repo, this version should change only when
;; "racket_version.h" changes:
(define version "8.0.0.6")
(define version "8.0.0.7")
(define deps `("racket-lib"
["racket" #:version ,version]))

14
pkgs/racket-doc/scribblings/reference/define-struct.scrbl
View File

@ -25,6 +25,7 @@
(code:line #:property prop-expr val-expr)
(code:line #:transparent)
(code:line #:prefab)
(code:line #:sealed)
(code:line #:authentic)
(code:line #:name name-id)
(code:line #:extra-name name-id)
@ -155,9 +156,10 @@ so on. By convention, property names start with @racketidfont{prop:}.}
The @racket[#:prefab] option obtains a @techlink{prefab} (pre-defined,
globally shared) structure type, as opposed to creating a new
structure type. Such a structure type is inherently transparent and
cannot have a guard or properties, so using @racket[#:prefab] with
non-sealed, and it cannot have a guard or properties, so using @racket[#:prefab] with
@racket[#:transparent], @racket[#:inspector], @racket[#:guard],
@racket[#:property], @racket[#:authentic], or @racket[#:methods] is a syntax error.
@racket[#:property], @racket[#:sealed], @racket[#:authentic],
or @racket[#:methods] is a syntax error.
If a supertype is specified, it must also be a @tech{prefab} structure type.
@examples[#:eval posn-eval
@ -166,6 +168,11 @@ If a supertype is specified, it must also be a @tech{prefab} structure type.
(prefab-point? #s(prefab-point 1 2))
]
The @racket[#:sealed] option is a shorthand for @racket[#:property
prop:sealed #t], which prevents the structure type from being
used as the supertype of another structure type. See
@racket[prop:sealed] for more information.
The @racket[#:authentic] option is a shorthand for @racket[#:property
prop:authentic #t], which prevents instances of the structure type
from being impersonated (see @racket[impersonate-struct]), chaperoned
@ -299,7 +306,8 @@ cp
For serialization, see @racket[define-serializable-struct].
@history[#:changed "6.9.0.4" @elem{Added @racket[#:authentic].}]}
@history[#:changed "6.9.0.4" @elem{Added @racket[#:authentic].}
#:changed "8.0.0.7" @elem{Added @racket[#:sealed].}]}
@defform[(struct-field-index field-id)]{

17
pkgs/racket-doc/scribblings/reference/struct-inspectors.scrbl
View File

@ -129,6 +129,23 @@ Returns eight values that provide information about the structure type
If the type for @racket[struct-type] is not controlled by the current inspector,
the @exnraise[exn:fail:contract].}
@defproc[(struct-type-sealed? [struct-type struct-type?]) boolean?]{
Reports whether @racket[struct-type] has the @racket[prop:sealed]
structure type property.
@history[#:added "8.0.0.7"]}
@defproc[(struct-type-authentic? [struct-type struct-type?]) boolean?]{
Reports whether @racket[struct-type] has the @racket[prop:authentic]
structure type property.
@history[#:added "8.0.0.7"]}
@defproc[(struct-type-make-constructor [struct-type struct-type?]
[constructor-name (or/c symbol? #f) #f])
struct-constructor-procedure?]{

16
pkgs/racket-doc/scribblings/reference/struct.scrbl
View File

@ -275,6 +275,22 @@ structure type if @racket[field-name] is a symbol.
For examples, see @racket[make-struct-type].}
@defthing[prop:sealed struct-type-property?]{
A @tech{structure type property} that declares a structure type as
@deftech{sealed}. The value associated with the property is ignored;
the presence of the property itself makes the structure type
sealed.
A @tech{sealed} structure type cannot be used as the supertype of
another structure type. Declaring a structure type as @tech{sealed} is
typically just a performance hint, since checking for an instance of a
sealed structure type can be slightly faster than checking for an
instance of a structure type that might have subtypes.
@history[#:added "8.0.0.7"]}
@;------------------------------------------------------------------------
@section[#:tag "structprops"]{Structure Type Properties}

69
pkgs/racket-test-core/tests/racket/struct.rktl
View File

@ -497,6 +497,8 @@
(syntax-test #'(define-struct a (b c) #:prefab #:property 1 10))
(syntax-test #'(define-struct a (b c) #:guard 10 #:prefab))
(syntax-test #'(define-struct a (b c) #:property 1 10 #:prefab))
(syntax-test #'(define-struct a (b c) #:sealed #:prefab))
(syntax-test #'(define-struct a (b c) #:prefab #:sealed))
(define-struct base0 ())
(define-struct base1 (a))
@ -842,6 +844,47 @@
(err/rt-test (make-struct-type 'bad struct:date 2 0 #f null 'prefab))
;; ------------------------------------------------------------
;; Sealed
(err/rt-test (let ()
(struct x () #:sealed)
(struct y x ())
(y))
exn:fail:contract?
"make-struct-type: cannot make a subtype of a sealed type")
(err/rt-test (let ()
(struct x () #:sealed)
(struct y x () #:sealed)
(y))
exn:fail:contract?
"make-struct-type: cannot make a subtype of a sealed type")
(err/rt-test (let ()
(define-values (prop:s s? s-ref)
(make-struct-type-property 's #f (list (cons prop:sealed (lambda (x) #t)))))
(struct x () #:property prop:s #t)
(struct y x ())
(y))
exn:fail:contract?
"make-struct-type: cannot make a subtype of a sealed type")
(test '(#f #t) cdr (let ()
(struct x ())
(struct y x () #:sealed)
(list (y)
(struct-type-sealed? struct:x)
(struct-type-sealed? struct:y))))
(err/rt-test (let ()
(struct x ())
(struct y x () #:sealed)
(struct z y ())
(y))
exn:fail:contract?
"make-struct-type: cannot make a subtype of a sealed type")
;; ------------------------------------------------------------
;; Misc. built-in structures
@ -1325,6 +1368,7 @@
(let ()
(struct posn (x y) #:authentic)
(test 1 posn-x (posn 1 2))
(test #t struct-type-authentic? struct:posn)
(err/rt-test (chaperone-struct (posn 1 2) posn-x (lambda (p x) x)))
;; Subtype must be consistent:
@ -1334,6 +1378,7 @@
(let ()
(struct posn (x y))
(test #f struct-type-authentic? struct:posn)
;; Subtype must be consistent:
(err/rt-test (let ()
@ -1566,6 +1611,30 @@
;; ----------------------------------------
(err/rt-test
(let ()
(struct x ())
(define unknown struct:x)
(set! unknown unknown)
(define-values (struct:y y y? y-z)
(let-values ([(struct:_1 make-_2 ?_3 -ref_4 -set!_5)
(let-values ()
(let-values ()
(make-struct-type 'y unknown 1 0 #f
(list)
'prefab ; (current-inspector)
#f '() #f 'y)))])
(values
struct:_1
make-_2
?_3
(make-struct-field-accessor -ref_4 0 'z))))
'done)
exn:fail:contract?
"generative supertype disallowed for non-generative structure type")
(err/rt-test
(let ()
;; Should be arity error (as opposed to a crash)

26
racket/collects/racket/private/define-struct.rkt
View File

@ -269,6 +269,7 @@
(#:name . #f)
(#:only-name? . #f)
(#:authentic . #f)
(#:sealed . #f)
(#:omit-define-values . #f)
(#:omit-define-syntaxes . #f))]
[nongen? #f])
@ -354,6 +355,14 @@
(loop (cdr p)
(extend-config config '#:authentic #'#t)
nongen?)]
[(eq? '#:sealed (syntax-e (car p)))
(when nongen?
(bad "cannot use" (car p) " for prefab structure type"))
(when (lookup config '#:sealed)
(bad "multiple" "#:sealed" "s" (car p)))
(loop (cdr p)
(extend-config config '#:sealed #'#t)
nongen?)]
[(or (eq? '#:constructor-name (syntax-e (car p)))
(eq? '#:extra-constructor-name (syntax-e (car p))))
(check-exprs 1 p "identifier")
@ -390,6 +399,8 @@
(bad "multiple" insp-keys "s" (car p)))
(when (pair? (lookup config '#:props))
(bad "cannot use" (car p) " for a structure type with properties"))
(when (lookup config '#:sealed)
(bad "cannot use" (car p) " for a sealed structure type"))
(when (lookup config '#:guard)
(bad "cannot use" (car p) " for a structure type with a guard"))
(loop (cdr p)
@ -488,11 +499,16 @@
(values (lookup config '#:inspector)
(lookup config '#:super)
(let ([l (lookup config '#:props)]
[a (lookup config '#:authentic)])
(if a
(cons (cons #'prop:authentic #'#t)
l)
l))
[a? (lookup config '#:authentic)]
[s? (lookup config '#:sealed)])
(let ([l (if a?
(cons (cons #'prop:authentic #'#t)
l)
l)])
(if s?
(cons (cons #'prop:sealed #'#t)
l)
l)))
(lookup config '#:auto-value)
(lookup config '#:guard)
(lookup config '#:constructor-name)

2
racket/src/ChezScheme/csug/objects.stex
View File

@ -4402,7 +4402,7 @@ count and mutability mask in place of a vector of field descriptions,
which results in a record type with anonymous fields. The \var{fields}
argument must be a non-negative fixnum for the field count, and it is
added to any fields present in \var{parent} to determine the record
type's total numnber of fields. The \var{mutability} argument must be
type's total number of fields. The \var{mutability} argument must be
an exact non-negative integer that is treated as a bit array; a
\scheme{1} bit indicates the the corresponding field among
\var{fields} is mutable.

2
racket/src/ChezScheme/makefiles/Mf-install.in
View File

@ -62,7 +62,7 @@ InstallLZ4Target=
# no changes should be needed below this point #
###############################################################################
Version=csv9.5.5.3
Version=csv9.5.5.4
Include=boot/$m
PetiteBoot=boot/$m/petite.boot
SchemeBoot=boot/$m/scheme.boot

3
racket/src/ChezScheme/s/cmacros.ss
View File

@ -357,7 +357,7 @@
;; ---------------------------------------------------------------------
;; Version and machine types:
(define-constant scheme-version #x09050503)
(define-constant scheme-version #x09050504)
(define-syntax define-machine-types
(lambda (x)
@ -1640,6 +1640,7 @@
(define-constant rtd-generative #b0001)
(define-constant rtd-opaque #b0010)
(define-constant rtd-sealed #b0100)
(define-constant rtd-act-sealed #b1000)
(define-constant ancestry-parent-offset 2)
(define-constant minimum-ancestry-vector-length 2)

2
racket/src/ChezScheme/s/cpnanopass.ss
View File

@ -11123,6 +11123,8 @@
[(e) (go e (constant rtd-opaque))])
(define-inline 3 record-type-sealed?
[(e) (go e (constant rtd-sealed))])
(define-inline 3 $record-type-act-sealed?
[(e) (go e (fxior (constant rtd-sealed) (constant rtd-act-sealed)))])
(define-inline 3 record-type-generative?
[(e) (go e (constant rtd-generative))]))
(let ()

2
racket/src/ChezScheme/s/primdata.ss
View File

@ -2319,6 +2319,8 @@
($record-oops [sig [(maybe-who sub-ptr rtd) -> (bottom)]] [flags abort-op])
($record-ref [sig [(ptr sub-index) -> (ptr)]] [flags single-valued discard cp03])
($record-set! [sig [(ptr sub-index ptr) -> (void)]] [flags true cptypes2])
($record-type-act-sealed! [sig [(ptr) -> (void)]] [flags single-valued true])
($record-type-act-sealed? [sig [(ptr) -> (boolean)]] [flags single-valued])
($record-type-descriptor [flags single-valued pure mifoldable discard true])
($record-type-field-offsets [flags single-valued pure mifoldable discard true])
($record-type-field-count [sig [(ptr) -> (fixnum)]] [flags single-valued pure mifoldable discard true])

18
racket/src/ChezScheme/s/record.ss
View File

@ -555,8 +555,8 @@
(define ($mrt who base-rtd name parent uid flags fields mutability-mask extras)
(include "layout.ss")
(when parent
(when (record-type-sealed? parent)
($oops who "cannot extend sealed record type ~s" parent))
(when ($record-type-act-sealed? parent)
($oops who "cannot extend sealed record type ~s as ~s" parent name))
(if (fixnum? fields)
(unless (fixnum? (rtd-flds parent))
($oops who "cannot make anonymous-field record type ~s from named-field parent record type ~s" name parent))
@ -901,6 +901,20 @@
($oops 'record-type-sealed? "~s is not a record type descriptor" rtd))
(#3%record-type-sealed? rtd)))
(set-who! $record-type-act-sealed!
(lambda (rtd)
(unless (record-type-descriptor? rtd)
($oops who "~s is not a record type descriptor" rtd))
(unless ($record-type-act-sealed? rtd)
($object-set! 'scheme-object rtd (constant record-type-flags-disp)
(fxior (rtd-flags rtd) (constant rtd-act-sealed))))))
(set-who! $record-type-act-sealed?
(lambda (rtd)
(unless (record-type-descriptor? rtd)
($oops who "~s is not a record type descriptor" rtd))
(#3%$record-type-act-sealed? rtd)))
(set! record-type-generative?
(lambda (rtd)
(unless (record-type-descriptor? rtd)

2
racket/src/bc/src/schminc.h
View File

@ -15,7 +15,7 @@
#define USE_COMPILED_STARTUP 1
#define EXPECTED_PRIM_COUNT 1485
#define EXPECTED_PRIM_COUNT 1488
#ifdef MZSCHEME_SOMETHING_OMITTED
# undef USE_COMPILED_STARTUP

14
racket/src/bc/src/schpriv.h
View File

@ -700,6 +700,7 @@ extern Scheme_Object *scheme_app_mark_impersonator_property;
extern Scheme_Object *scheme_no_arity_property;
extern Scheme_Object *scheme_authentic_property;
extern Scheme_Object *scheme_sealed_property;
extern Scheme_Object *scheme_chaperone_undefined_property;
@ -1095,9 +1096,10 @@ typedef struct Scheme_Struct_Type {
mzshort num_slots; /* initialized + auto + parent-initialized + parent-auto */
mzshort num_islots; /* initialized + parent-initialized */
mzshort name_pos;
char authentic; /* 1 => chaperones/impersonators disallowed */
char more_flags; /* STRUCT_TYPE_FLAG_NONFAIL_CONSTRUCTOR => constructor never fails
STRUCT_TYPE_FLAG_SYSTEM_OPAQUE => #f for `object-name`, for example */
int more_flags; /* STRUCT_TYPE_FLAG_AUTHENTIC => chaperones/impersonators disallowed
STRUCT_TYPE_FLAG_SEALED => subtypes disallowed
STRUCT_TYPE_FLAG_NONFAIL_CONSTRUCTOR => constructor never fails
STRUCT_TYPE_FLAG_SYSTEM_OPAQUE => #f for `object-name`, for example */
Scheme_Object *name;
@ -1131,6 +1133,8 @@ typedef struct Scheme_Struct_Type {
/* for `more_flags` field */
#define STRUCT_TYPE_FLAG_NONFAIL_CONSTRUCTOR 0x1
#define STRUCT_TYPE_FLAG_SYSTEM_OPAQUE 0x2
#define STRUCT_TYPE_FLAG_AUTHENTIC 0x4
#define STRUCT_TYPE_FLAG_SEALED 0x8
typedef struct Scheme_Structure
{
@ -3108,6 +3112,7 @@ typedef struct {
int normal_ops; /* are selectors and predicates in the usual order? */
int indexed_ops; /* do selectors have the index built in (as opposed to taking an index argument)? */
int authentic; /* conservatively 0 is ok */
int sealed; /* conservatively 0 is ok */
int nonfail_constructor;
int prefab;
int num_gets, num_sets;
@ -3144,7 +3149,8 @@ Scheme_Object *scheme_make_struct_proc_shape(intptr_t k, Scheme_Object *identity
#define STRUCT_PROC_SHAPE_GETTER 3
#define STRUCT_PROC_SHAPE_SETTER 4
#define STRUCT_PROC_SHAPE_OTHER 5
#define STRUCT_PROC_SHAPE_MASK 0xF
#define STRUCT_PROC_SHAPE_MASK 0x7
#define STRUCT_PROC_SHAPE_SEALED 0x8
#define STRUCT_PROC_SHAPE_AUTHENTIC 0x10
#define STRUCT_PROC_SHAPE_NONFAIL_CONSTR 0x20
#define STRUCT_PROC_SHAPE_PREFAB 0x40

7
racket/src/bc/src/startup.inc
View File

@ -5943,6 +5943,7 @@ static const char *startup_source =
" 0"
" #f"
"(list"
"(cons prop:sealed #t)"
"(cons prop:authentic #t)"
"(cons"
" prop:reach-scopes"
@ -8910,6 +8911,7 @@ static const char *startup_source =
" 0"
" #f"
"(list"
"(cons prop:sealed #t)"
"(cons prop:authentic #t)"
"(cons"
" prop:scope-with-bindings"
@ -9113,6 +9115,7 @@ static const char *startup_source =
" 0"
" #f"
"(list"
"(cons prop:sealed #t)"
"(cons prop:authentic #t)"
"(cons"
" prop:reach-scopes"
@ -9976,6 +9979,7 @@ static const char *startup_source =
" 0"
" #f"
"(list"
"(cons prop:sealed #t)"
"(cons prop:authentic #t)"
"(cons prop:propagation-set-tamper(lambda(p_0 v_0)(propagation-set-tamper p_0 v_0)))"
"(cons prop:propagation-tamper(lambda(p_0)(propagation-tamper p_0)))"
@ -20887,13 +20891,14 @@ static const char *startup_source =
" record-accessor"
" record-mutator"
" record-predicate"
" struct-type-install-properties!"
" make-struct-type-install-properties"
" #%struct-constructor"
" #%struct-predicate"
" #%struct-field-accessor"
" #%struct-field-mutator"
" #%nongenerative-uid"
" unsafe-struct?"
" unsafe-sealed-struct?"
" unsafe-struct"
" raise-binding-result-arity-error"
" raise-definition-result-arity-error"

83
racket/src/bc/src/struct.c
View File

@ -28,6 +28,7 @@ READ_ONLY Scheme_Object *scheme_app_mark_impersonator_property;
READ_ONLY Scheme_Object *scheme_object_name_property;
READ_ONLY Scheme_Object *scheme_struct_to_vector_proc;
READ_ONLY Scheme_Object *scheme_authentic_property;
READ_ONLY Scheme_Object *scheme_sealed_property;
READ_ONLY Scheme_Object *scheme_unsafe_poller_proc;
READ_ONLY static Scheme_Object *location_struct;
@ -115,6 +116,8 @@ static Scheme_Object *struct_info(int argc, Scheme_Object *argv[]);
static Scheme_Object *struct_type_info(int argc, Scheme_Object *argv[]);
static Scheme_Object *struct_type_pred(int argc, Scheme_Object *argv[]);
static Scheme_Object *struct_type_constr(int argc, Scheme_Object *argv[]);
static Scheme_Object *struct_type_sealed_p(int argc, Scheme_Object *argv[]);
static Scheme_Object *struct_type_authentic_p(int argc, Scheme_Object *argv[]);
static Scheme_Object *struct_to_vector(int argc, Scheme_Object *argv[]);
static Scheme_Object *prefab_struct_key(int argc, Scheme_Object *argv[]);
static Scheme_Object *make_prefab_struct(int argc, Scheme_Object *argv[]);
@ -445,6 +448,12 @@ scheme_init_struct (Scheme_Startup_Env *env)
scheme_addto_prim_instance("prop:authentic", scheme_authentic_property, env);
}
{
REGISTER_SO(scheme_sealed_property);
scheme_sealed_property = scheme_make_struct_type_property(scheme_intern_symbol("sealed"));
scheme_addto_prim_instance("prop:sealed", scheme_sealed_property, env);
}
REGISTER_SO(scheme_recur_symbol);
REGISTER_SO(scheme_display_symbol);
REGISTER_SO(scheme_write_special_symbol);
@ -577,6 +586,16 @@ scheme_init_struct (Scheme_Startup_Env *env)
"struct-type-make-constructor",
1, 2),
env);
scheme_addto_prim_instance("struct-type-sealed?",
scheme_make_prim_w_arity(struct_type_sealed_p,
"struct-type-sealed?",
1, 1),
env);
scheme_addto_prim_instance("struct-type-authentic?",
scheme_make_prim_w_arity(struct_type_authentic_p,
"struct-type-authentic?",
1, 1),
env);
REGISTER_SO(scheme_struct_to_vector_proc);
scheme_struct_to_vector_proc = scheme_make_noncm_prim(struct_to_vector,
@ -2962,6 +2981,24 @@ static Scheme_Object *struct_type_info(int argc, Scheme_Object *argv[])
return scheme_values(mzNUM_ST_INFO, a);
}
static Scheme_Object *struct_type_sealed_p(int argc, Scheme_Object *argv[]) {
if (!SCHEME_STRUCT_TYPEP(argv[0]))
scheme_wrong_contract("struct-type-sealed?", "struct-type?", 0, argc, argv);
return ((((Scheme_Struct_Type *)argv[0])->more_flags & STRUCT_TYPE_FLAG_SEALED)
? scheme_true
: scheme_false);
}
static Scheme_Object *struct_type_authentic_p(int argc, Scheme_Object *argv[]) {
if (!SCHEME_STRUCT_TYPEP(argv[0]))
scheme_wrong_contract("struct-type-authentic?", "struct-type?", 0, argc, argv);
return ((((Scheme_Struct_Type *)argv[0])->more_flags & STRUCT_TYPE_FLAG_AUTHENTIC)
? scheme_true
: scheme_false);
}
static Scheme_Object *struct_type_pred(int argc, Scheme_Object *argv[])
{
Scheme_Struct_Type *stype;
@ -3428,7 +3465,8 @@ intptr_t scheme_get_or_check_structure_shape(Scheme_Object *e, Scheme_Object *ex
else
want_v = ((st->num_slots << STRUCT_PROC_SHAPE_SHIFT)
| STRUCT_PROC_SHAPE_STRUCT
| ((st->authentic && (!expected || (v & STRUCT_PROC_SHAPE_AUTHENTIC)))
| (((st->more_flags & STRUCT_TYPE_FLAG_AUTHENTIC)
&& (!expected || (v & STRUCT_PROC_SHAPE_AUTHENTIC)))
? STRUCT_PROC_SHAPE_AUTHENTIC
: 0)
| (((st->more_flags & STRUCT_TYPE_FLAG_NONFAIL_CONSTRUCTOR)
@ -3455,7 +3493,8 @@ intptr_t scheme_get_or_check_structure_shape(Scheme_Object *e, Scheme_Object *ex
} else if (i == SCHEME_PRIM_STRUCT_TYPE_PRED) {
st = (Scheme_Struct_Type *)SCHEME_PRIM_CLOSURE_ELS(e)[0];
want_v = (STRUCT_PROC_SHAPE_PRED
| ((st->authentic && (!expected || (v & STRUCT_PROC_SHAPE_AUTHENTIC)))
| (((st->more_flags & STRUCT_TYPE_FLAG_AUTHENTIC)
&& (!expected || (v & STRUCT_PROC_SHAPE_AUTHENTIC)))
? STRUCT_PROC_SHAPE_AUTHENTIC
: 0));
} else if (i == SCHEME_PRIM_STRUCT_TYPE_INDEXED_SETTER) {
@ -3471,7 +3510,8 @@ intptr_t scheme_get_or_check_structure_shape(Scheme_Object *e, Scheme_Object *ex
pos = 0; /* => unknown, since simple struct info can't track it */
want_v = ((pos << STRUCT_PROC_SHAPE_SHIFT)
| STRUCT_PROC_SHAPE_SETTER
| ((st->authentic && (!expected || (v & STRUCT_PROC_SHAPE_AUTHENTIC)))
| (((st->more_flags & STRUCT_TYPE_FLAG_AUTHENTIC)
&& (!expected || (v & STRUCT_PROC_SHAPE_AUTHENTIC)))
? STRUCT_PROC_SHAPE_AUTHENTIC
: 0));
} else if (i == SCHEME_PRIM_STRUCT_TYPE_INDEXED_GETTER) {
@ -3479,7 +3519,8 @@ intptr_t scheme_get_or_check_structure_shape(Scheme_Object *e, Scheme_Object *ex
st = (Scheme_Struct_Type *)SCHEME_PRIM_CLOSURE_ELS(e)[0];
want_v = ((pos << STRUCT_PROC_SHAPE_SHIFT)
| STRUCT_PROC_SHAPE_GETTER
| ((st->authentic && (!expected || (v & STRUCT_PROC_SHAPE_AUTHENTIC)))
| (((st->more_flags & STRUCT_TYPE_FLAG_AUTHENTIC)
&& (!expected || (v & STRUCT_PROC_SHAPE_AUTHENTIC)))
? STRUCT_PROC_SHAPE_AUTHENTIC
: 0));
} else if ((i == SCHEME_PRIM_STRUCT_TYPE_INDEXLESS_SETTER)
@ -4751,7 +4792,6 @@ Scheme_Struct_Type *scheme_make_prefab_struct_type_raw(Scheme_Object *base,
struct_type->num_slots = num_fields + num_uninit_fields + (parent_type ? parent_type->num_slots : 0);
struct_type->num_islots = num_fields + (parent_type ? parent_type->num_islots : 0);
struct_type->name_pos = depth;
struct_type->authentic = 0;
struct_type->more_flags = STRUCT_TYPE_FLAG_NONFAIL_CONSTRUCTOR;
struct_type->inspector = scheme_false;
struct_type->uninit_val = uninit_val;
@ -4946,7 +4986,9 @@ static Scheme_Object *_make_struct_type(Scheme_Object *name,
if (SAME_OBJ(prop, scheme_chaperone_undefined_property))
chaperone_undefined = 1;
if (SAME_OBJ(prop, scheme_authentic_property))
struct_type->authentic = 1;
struct_type->more_flags |= STRUCT_TYPE_FLAG_AUTHENTIC;
if (SAME_OBJ(prop, scheme_sealed_property))
struct_type->more_flags |= STRUCT_TYPE_FLAG_SEALED;
propv = guard_property(prop, SCHEME_CDR(a), struct_type);
@ -5008,7 +5050,9 @@ static Scheme_Object *_make_struct_type(Scheme_Object *name,
if (SAME_OBJ(prop, scheme_chaperone_undefined_property))
chaperone_undefined = 1;
if (SAME_OBJ(prop, scheme_authentic_property))
struct_type->authentic = 1;
struct_type->more_flags |= STRUCT_TYPE_FLAG_AUTHENTIC;
if (SAME_OBJ(prop, scheme_sealed_property))
struct_type->more_flags |= STRUCT_TYPE_FLAG_SEALED;
propv = guard_property(prop, SCHEME_CDR(a), struct_type);
@ -5062,8 +5106,9 @@ static Scheme_Object *_make_struct_type(Scheme_Object *name,
}
}
if (parent_type && (parent_type->authentic != struct_type->authentic)) {
if (parent_type->authentic)
if (parent_type && ((parent_type->more_flags & STRUCT_TYPE_FLAG_AUTHENTIC)
!= (struct_type->more_flags & STRUCT_TYPE_FLAG_AUTHENTIC))) {
if (parent_type->more_flags & STRUCT_TYPE_FLAG_AUTHENTIC)
scheme_contract_error("make-struct-type",
"cannot make a non-authentic subtype of an authentic type",
"type name", 1, struct_type->name,
@ -5402,8 +5447,24 @@ static Scheme_Object *make_struct_type(int argc, Scheme_Object **argv)
uninit_val,
immutable_array);
} else {
Scheme_Object *parent = SCHEME_FALSEP(argv[1]) ? NULL : argv[1];
Scheme_Struct_Type *parent_type;
if (parent && SCHEME_NP_CHAPERONEP(parent))
parent_type = (Scheme_Struct_Type *)SCHEME_CHAPERONE_VAL(parent);
else
parent_type = (Scheme_Struct_Type *)parent;
if (parent_type && (parent_type->more_flags & STRUCT_TYPE_FLAG_SEALED)) {
scheme_contract_error("make-struct-type",
"cannot make a subtype of a sealed type",
"type name", 1, argv[0],
"sealed type", 1, parent,
NULL);
}
type = (Scheme_Struct_Type *)_make_struct_type(argv[0],
SCHEME_FALSEP(argv[1]) ? NULL : argv[1],
parent,
inspector,
initc, uninitc,
uninit_val, props,
@ -6247,7 +6308,7 @@ static Scheme_Object *do_chaperone_struct(const char *name, int is_impersonator,
return NULL;
}
if (SCHEME_STRUCTP(val) && ((Scheme_Structure *)val)->stype->authentic) {
if (SCHEME_STRUCTP(val) && ((Scheme_Structure *)val)->stype->more_flags & STRUCT_TYPE_FLAG_AUTHENTIC) {
scheme_contract_error(name,
(is_impersonator
? "cannot impersonate instance of an authentic structure type"

2
racket/src/cs/compile-file.ss
View File

@ -2,7 +2,7 @@
;; Check to make we're using a build of Chez Scheme
;; that has all the features we need.
(define-values (need-maj need-min need-sub need-dev)
(values 9 5 5 1))
(values 9 5 5 4))
(unless (guard (x [else #f]) (eval 'scheme-fork-version-number))
(error 'compile-file

2
racket/src/cs/primitive/internal.ss
View File

@ -8,7 +8,7 @@
[impersonator-val (known-constant)]
[impersonate-ref (known-constant)]
[impersonate-set! (known-constant)]
[struct-type-install-properties! (known-constant)]
[make-struct-type-install-properties (known-constant)]
[structure-type-lookup-prefab-uid (known-constant)]
[struct-type-constructor-add-guards (known-constant)]
[|#%call-with-values| (known-constant)]

3
racket/src/cs/primitive/kernel.ss
View File

@ -686,6 +686,7 @@
[prop:object-name (known-constant)]
[prop:output-port (known-constant)]
[prop:procedure (known-struct-type-property/immediate-guard)]
[prop:sealed (known-struct-type-property/immediate-guard)]
[pseudo-random-generator->vector (known-procedure/no-prompt 2)]
[pseudo-random-generator-vector? (known-procedure/no-prompt 2)]
[pseudo-random-generator? (known-procedure/pure/folding 2)]
@ -840,12 +841,14 @@
[struct-info (known-procedure 2)]
[struct-mutator-procedure? (known-procedure/pure/folding 2)]
[struct-predicate-procedure? (known-procedure/pure/folding 2)]
[struct-type-authentic? (known-procedure/single-valued 2)]
[struct-type-info (known-procedure 2)]
[struct-type-make-constructor (known-procedure/single-valued 6)]
[struct-type-make-predicate (known-procedure/single-valued 2)]
[struct-type-property-accessor-procedure? (known-procedure/single-valued 2)]
[struct-type-property-predicate-procedure? (known-procedure/single-valued 6)]
[struct-type-property? (known-procedure/no-prompt 2)]
[struct-type-sealed? (known-procedure/single-valued 2)]
[struct-type? (known-procedure/no-prompt 2)]
[struct:arity-at-least (known-constant)]
[struct:date (known-constant)]

12
racket/src/cs/rumble.sls
View File

@ -218,8 +218,8 @@
struct-type-property-accessor-procedure?
struct-type-property-predicate-procedure?
make-struct-type
struct-type-install-properties! ; not exported to Racket
structure-type-lookup-prefab-uid ; not exported to Racket
make-struct-type-install-properties ; not exported to Racket
structure-type-lookup-prefab-uid ; not exported to Racket
make-struct-field-accessor
make-struct-field-mutator
struct-type-constructor-add-guards ; not exported to Racket
@ -237,6 +237,8 @@
struct-type?
procedure-struct-type?
struct-type-info
struct-type-sealed?
struct-type-authentic?
struct-info
struct-type-make-constructor
struct-type-make-predicate
@ -247,6 +249,7 @@
make-prefab-struct
prop:authentic
prop:equal+hash
prop:sealed
inspector?
inspector-superior?
impersonate-struct
@ -696,8 +699,9 @@
unsafe-struct*-ref
unsafe-struct*-set!
unsafe-struct*-cas!
unsafe-struct? ; not exported to racket
unsafe-struct ; not exported to racket
unsafe-struct? ; not exported to racket
unsafe-sealed-struct? ; not exported to racket
unsafe-struct ; not exported to racket
unsafe-s16vector-ref
unsafe-s16vector-set!

8
racket/src/cs/rumble/error-rewrite.ss
View File

@ -59,7 +59,8 @@
fxarithmetic-shift-left fxlshift
fxsll/wraparound fxlshift/wraparound
real->flonum ->fl
time-utc->date seconds->date)
time-utc->date seconds->date
make-record-type-descriptor* make-struct-type)
(set! rewrites-added? #t)))
(getprop n 'error-rename n)))
@ -140,6 +141,11 @@
(let ([ctc (desc->contract (substring str (string-length is-not-a-str) (string-length str)))])
(format-error-values (string-append "contract violation\n expected: " ctc "\n given: ~s")
irritants))]
[(equal? str "cannot extend sealed record type ~s as ~s")
(format-error-values (string-append "cannot make a subtype of a sealed type\n"
" type name: ~s\n"
" sealed type: ~s")
(reverse irritants))]
[(eq? who 'time-utc->date)
(values "integer is out-of-range" null)]
[else

403
racket/src/cs/rumble/struct.ss
View File

@ -183,8 +183,10 @@
;; ----------------------------------------
;; returns a procedure that takes an rtd and finishes creating/installing it
(define (check-make-struct-type-arguments who name parent-rtd init-count auto-count
props insp proc-spec immutables guard constructor-name)
props insp proc-spec immutables guard constructor-name
system?)
(check who symbol? name)
(check who :or-false struct-type? parent-rtd)
(check who exact-nonnegative-integer? init-count)
@ -215,120 +217,164 @@
(check who :or-false procedure? guard)
(check who :or-false symbol? constructor-name)
;; The rest has to be delayed until we have an rtd:
(lambda (rtd parent-rtd* all-immutables)
(let ([props-ht
;; Check for duplicates and record property values
(let ([get-struct-info
(lambda ()
(let ([parent-total*-count (if parent-rtd*
(struct-type-total*-field-count parent-rtd*)
0)])
(list name
init-count
auto-count
(make-position-based-accessor rtd parent-total*-count (+ init-count auto-count))
(make-position-based-mutator rtd parent-total*-count (+ init-count auto-count))
all-immutables
parent-rtd
#f)))])
(let loop ([props props] [ht empty-hasheq])
(cond
[(eq? insp 'prefab)
(let ([bad
(or (and (impersonator? parent-rtd)
"chaperoned supertype disallowed for non-generative structure type")
(and parent-rtd
(not (eq? (inspector-ref (strip-impersonator parent-rtd)) 'prefab))
"generative supertype disallowed for non-generative structure type")
(and (pair? props)
"properties disallowed for non-generative structure type")
(and proc-spec
"procedure specification disallowed for non-generative structure type")
(and guard
"guard disallowed for non-generative structure type"))])
(when bad
(raise-arguments-error who bad
"structure type name" name))
;; everything else to be done for a for prefab must be covered in `prefab-key+count->rtd`
(lambda (rtd)
(void)))]
[else
(when parent-rtd
(when (#%$record-type-act-sealed? (strip-impersonator parent-rtd))
(raise-arguments-error who
"cannot make a subtype of a sealed type"
"type name" name
"sealed type" parent-rtd)))
;; The rest has to be delayed until we have an rtd:
(lambda (rtd)
(let* ([parent-rtd* (strip-impersonator parent-rtd)]
[parent-props
(if parent-rtd*
(eq-hashtable-ref rtd-props parent-rtd* '())
'())]
[all-immutables (if (integer? proc-spec)
(cons proc-spec immutables)
immutables)])
(when (not parent-rtd*)
(record-type-equal-procedure rtd default-struct-equal?)
(record-type-hash-procedure rtd default-struct-hash))
;; Record properties implemented by this type:
(let ([props (let ([props (append (map car props) parent-props)])
(if proc-spec
(cons prop:procedure props)
props))])
(add-to-table! rtd-props rtd props))
;; Copy parent properties for this type:
(for-each (lambda (prop)
(let loop ([prop prop])
(struct-property-set! prop rtd (struct-property-ref prop parent-rtd* #f))
(for-each (lambda (super)
(loop (car super)))
(struct-type-prop-supers prop))))
parent-props)
;; Finish checking and install new property values:
(let ([props-ht
;; Check for duplicates and record property values
(let ([get-struct-info
(lambda ()
(let ([parent-total*-count (if parent-rtd*
(struct-type-total*-field-count parent-rtd*)
0)])
(list name
init-count
auto-count
(make-position-based-accessor rtd parent-total*-count (+ init-count auto-count))
(make-position-based-mutator rtd parent-total*-count (+ init-count auto-count))
all-immutables
parent-rtd
#f)))])
(let loop ([props props] [ht empty-hasheq])
(cond
[(null? props)
(if proc-spec
(let-values ([(ht props) (check-and-add-property who prop:procedure proc-spec rtd ht '()
get-struct-info)])
ht)
ht)]
[else
(let-values ([(ht props) (check-and-add-property who (caar props) (cdar props) rtd ht (cdr props)
get-struct-info)])
(loop props ht))])))])
(let loop ([ht empty-hasheqv] [imms immutables])
(cond
[(null? imms) (void)]
[else
(let ([i (car imms)])
(when (hash-ref ht i #f)
(raise-arguments-error who
"redundant immutable field index"
"index" i
"in list" immutables))
(unless (< i init-count)
(raise-arguments-error who
"index for immutable field >= initialized-field count"
"index" i
"initialized-field count" init-count
"in list" immutables))
(loop (hash-set ht i #t) (cdr imms)))]))
(let ([v (hash-ref props-ht prop:procedure #f)])
(when v
(cond
[(null? props)
(if proc-spec
(let-values ([(ht props) (check-and-add-property who prop:procedure proc-spec rtd ht '()
get-struct-info)])
ht)
ht)]
[else
(let-values ([(ht props) (check-and-add-property who (caar props) (cdar props) rtd ht (cdr props)
get-struct-info)])
(loop props ht))])))])
(when (eq? insp 'prefab)
(let ([bad
(or (and (impersonator? parent-rtd)
"chaperoned supertype disallowed for non-generative structure type")
(and parent-rtd
(not (eq? (inspector-ref parent-rtd) 'prefab))
"generative supertype disallowed for non-generative structure type")
(and (pair? props)
"properties disallowed for non-generative structure type")
(and proc-spec
"procedure specification disallowed for non-generative structure type")
(and guard
"guard disallowed for non-generative structure type"))])
(when bad
(raise-arguments-error who bad
"structure type name" name))))
(let loop ([ht empty-hasheqv] [imms immutables])
(cond
[(null? imms) (void)]
[else
(let ([i (car imms)])
(when (hash-ref ht i #f)
(raise-arguments-error who
"redundant immutable field index"
"index" i
"in list" immutables))
(unless (< i init-count)
(raise-arguments-error who
"index for immutable field >= initialized-field count"
"index" i
"initialized-field count" init-count
"in list" immutables))
(loop (hash-set ht i #t) (cdr imms)))]))
(let ([v (hash-ref props-ht prop:procedure #f)])
(when v
(cond
[(exact-nonnegative-integer? v)
(unless (< v init-count)
(raise-arguments-error who
"index for procedure >= initialized-field count"
"index" v
"field count" init-count))
(unless (or (eq? v proc-spec) (chez:memv v immutables))
(raise-arguments-error who
"field is not specified as immutable for a prop:procedure index"
"index" v))]
[(procedure? v)
(void)]
[else
(raise-arguments-error who
"given value did not satisfy the contract for prop:procedure"
"expected" "(or/c procedure? exact-nonnegative-integer?)"
"given" v)])))
(let ([parent-rtd* (strip-impersonator parent-rtd)])
(when parent-rtd*
(let ([authentic? (not (eq? (hash-ref props-ht prop:authentic none) none))]
[authentic-parent? (struct-property-ref prop:authentic parent-rtd* #f)])
(when (not (eq? authentic? authentic-parent?))
(if authentic?
[(exact-nonnegative-integer? v)
(unless (< v init-count)
(raise-arguments-error who
"index for procedure >= initialized-field count"
"index" v
"field count" init-count))
(unless (or (eq? v proc-spec) (chez:memv v immutables))
(raise-arguments-error who
"field is not specified as immutable for a prop:procedure index"
"index" v))]
[(procedure? v)
(void)]
[else
(raise-arguments-error who
"cannot make an authentic subtype of a non-authentic type"
"type name" name
"non-authentic type" parent-rtd)
(raise-arguments-error who
"cannot make a non-authentic subtype of an authentic type"
"type name" name
"authentic type" parent-rtd)))))
"given value did not satisfy the contract for prop:procedure"
"expected" "(or/c procedure? exact-nonnegative-integer?)"
"given" v)])))
(when guard
(let ([expected-count (+ 1
init-count
(if parent-rtd*
(get-field-info-init*-count (struct-type-field-info parent-rtd*))
0))])
(unless (procedure-arity-includes? guard expected-count)
(raise-arguments-error who
(string-append
"guard procedure does not accept correct number of arguments;\n"
" should accept one more than the number of constructor arguments")
"guard procedure" guard
"expected arity" expected-count))))))))
(let ([parent-rtd* (strip-impersonator parent-rtd)])
(when parent-rtd*
(let ([authentic? (not (eq? (hash-ref props-ht prop:authentic none) none))]
[authentic-parent? (struct-property-ref prop:authentic parent-rtd* #f)])
(when (not (eq? authentic? authentic-parent?))
(if authentic?
(raise-arguments-error who
"cannot make an authentic subtype of a non-authentic type"
"type name" name
"non-authentic type" parent-rtd)
(raise-arguments-error who
"cannot make a non-authentic subtype of an authentic type"
"type name" name
"authentic type" parent-rtd)))))
(when guard
(let ([expected-count (+ 1
init-count
(if parent-rtd*
(get-field-info-init*-count (struct-type-field-info parent-rtd*))
0))])
(unless (procedure-arity-includes? guard expected-count)
(raise-arguments-error who
(string-append
"guard procedure does not accept correct number of arguments;\n"
" should accept one more than the number of constructor arguments")
"guard procedure" guard
"expected arity" expected-count))))))
;; Record inspector
(unless (and system? insp)
(inspector-set! rtd insp))
;; Register guard
(register-guards! rtd parent-rtd guard 'at-start)))]))
(define (check-and-add-property who prop val rtd ht props get-struct-info)
(let* ([guarded-val
@ -359,17 +405,42 @@
p
(lambda (v h) (|#%app| p v h)))))
(struct-property-set! 'secondary-hash rtd (cadddr guarded-val)))
(struct-property-set! prop rtd guarded-val)
(values (hash-set ht prop check-val)
(append
(if (eq? old-v none)
(map (lambda (super)
(cons (car super)
(|#%app| (cdr super) guarded-val)))
(struct-type-prop-supers prop))
;; skip supers, because property is already added
null)
props))))
(cond
[(eq? prop prop:sealed)
(#%$record-type-act-sealed! rtd)
(values ht props)]
[else
(struct-property-set! prop rtd guarded-val)
(values (hash-set ht prop check-val)
(append
(if (eq? old-v none)
(map (lambda (super)
(cons (car super)
(|#%app| (cdr super) guarded-val)))
(struct-type-prop-supers prop))
;; skip supers, because property is already added
null)
props))])))
;; variant of `check-make-struct-type-arguments` called by schemified
(define make-struct-type-install-properties
(case-lambda
[(name init-count auto-count parent-rtd)
(make-struct-type-install-properties name init-count auto-count parent-rtd '() (current-inspector) #f '() #f #f)]
[(name init-count auto-count parent-rtd props)
(make-struct-type-install-properties name init-count auto-count parent-rtd props (current-inspector) #f '() #f #f)]
[(name init-count auto-count parent-rtd props insp)
(make-struct-type-install-properties name init-count auto-count parent-rtd props insp #f '() #f #f)]
[(name init-count auto-count parent-rtd props insp proc-spec)
(make-struct-type-install-properties name init-count auto-count parent-rtd props insp proc-spec '() #f #f)]
[(name init-count auto-count parent-rtd props insp proc-spec immutables)
(make-struct-type-install-properties name init-count auto-count parent-rtd props insp proc-spec immutables #f #f)]
[(name init-count auto-count parent-rtd props insp proc-spec immutables guard)
(make-struct-type-install-properties name init-count auto-count parent-rtd props insp proc-spec immutables guard #f)]
[(name init-count auto-count parent-rtd props insp proc-spec immutables guard constructor-name)
;; returns a finishing procedure
(check-make-struct-type-arguments 'make-struct-type (if (pair? name) (car name) name) parent-rtd init-count auto-count
props insp proc-spec immutables guard constructor-name (pair? name))]))
;; ----------------------------------------
@ -488,9 +559,8 @@
[(name parent-rtd init-count auto-count auto-val props insp proc-spec immutables guard)
(make-struct-type name parent-rtd init-count auto-count auto-val props insp proc-spec immutables guard #f)]
[(name parent-rtd init-count auto-count auto-val props insp proc-spec immutables guard constructor-name)
(let* ([install-props!
(check-make-struct-type-arguments 'make-struct-type name parent-rtd init-count auto-count
props insp proc-spec immutables guard constructor-name)]
(let* ([finish! (check-make-struct-type-arguments 'make-struct-type name parent-rtd init-count auto-count
props insp proc-spec immutables guard constructor-name #f)]
[prefab-uid (and (eq? insp 'prefab)
(structure-type-lookup-prefab-uid name parent-rtd init-count auto-count auto-val immutables))]
[parent-rtd* (strip-impersonator parent-rtd)]
@ -499,7 +569,9 @@
empty-field-info)]
[rtd (make-record-type-descriptor* name
parent-rtd*
prefab-uid #f #f
prefab-uid
(#%ormap (lambda (p) (eq? prop:sealed (car p))) props)
#f
(+ init-count auto-count)
(let ([mask (sub1 (general-arithmetic-shift 1 (+ init-count auto-count)))])
(if (eq? insp 'prefab)
@ -527,9 +599,7 @@
(when (or parent-rtd* auto-field-adder)
(let ([field-info (make-field-info init*-count auto*-count auto-field-adder)])
(putprop (record-type-uid rtd) 'field-info field-info)))
(struct-type-install-properties! rtd name init-count auto-count parent-rtd
props insp proc-spec immutables guard constructor-name
install-props!)
(finish! rtd)
(let ([ctr (struct-type-constructor-add-guards
(let ([c (record-constructor rtd)])
(procedure-rename
@ -554,63 +624,6 @@
(make-position-based-accessor rtd parent-total*-count (+ init-count auto-count))
(make-position-based-mutator rtd parent-total*-count (+ init-count auto-count)))))]))
;; Called both by `make-struct-type` and by a `schemify` transformation:
(define struct-type-install-properties!
(case-lambda
[(rtd name init-count auto-count parent-rtd)
(struct-type-install-properties! rtd name init-count auto-count parent-rtd '() (current-inspector) #f '() #f #f #f)]
[(rtd name init-count auto-count parent-rtd props)
(struct-type-install-properties! rtd name init-count auto-count parent-rtd props (current-inspector) #f '() #f #f #f)]
[(rtd name init-count auto-count parent-rtd props insp)
(struct-type-install-properties! rtd name init-count auto-count parent-rtd props insp #f '() #f #f #f)]
[(rtd name init-count auto-count parent-rtd props insp proc-spec)
(struct-type-install-properties! rtd name init-count auto-count parent-rtd props insp proc-spec '() #f #f #f)]
[(rtd name init-count auto-count parent-rtd props insp proc-spec immutables)
(struct-type-install-properties! rtd name init-count auto-count parent-rtd props insp proc-spec immutables #f #f #f)]
[(rtd name init-count auto-count parent-rtd props insp proc-spec immutables guard)
(struct-type-install-properties! rtd name init-count auto-count parent-rtd props insp proc-spec immutables guard #f #f)]
[(rtd name init-count auto-count parent-rtd props insp proc-spec immutables guard constructor-name)
(struct-type-install-properties! rtd name init-count auto-count parent-rtd props insp proc-spec immutables guard constructor-name #f)]
[(rtd name init-count auto-count parent-rtd props insp proc-spec immutables guard constructor-name install-props!)
(let ([install-props!
(or install-props!
(check-make-struct-type-arguments 'make-struct-type (if (pair? name) (car name) name) parent-rtd init-count auto-count
props insp proc-spec immutables guard constructor-name))])
(unless (eq? insp 'prefab) ; everything for prefab must be covered in `prefab-key+count->rtd`
(let* ([parent-rtd* (strip-impersonator parent-rtd)]
[parent-props
(if parent-rtd*
(eq-hashtable-ref rtd-props parent-rtd* '())
'())]
[all-immutables (if (integer? proc-spec)
(cons proc-spec immutables)
immutables)])
(when (not parent-rtd*)
(record-type-equal-procedure rtd default-struct-equal?)
(record-type-hash-procedure rtd default-struct-hash))
;; Record properties implemented by this type:
(let ([props (let ([props (append (map car props) parent-props)])
(if proc-spec
(cons prop:procedure props)
props))])
(add-to-table! rtd-props rtd props))
;; Copy parent properties for this type:
(for-each (lambda (prop)
(let loop ([prop prop])
(struct-property-set! prop rtd (struct-property-ref prop parent-rtd* #f))
(for-each (lambda (super)
(loop (car super)))
(struct-type-prop-supers prop))))
parent-props)
;; Finish checking and install new property values:
(install-props! rtd parent-rtd* all-immutables)
;; Record inspector
(unless (and (pair? name) ; pair implies a system structure type
insp)
(inspector-set! rtd insp))
;; Register guard
(register-guards! rtd parent-rtd guard 'at-start))))]))
;; Field count (init + auto) not including parent fields
(define (record-type-field-count rtd)
(fx- (#%$record-type-field-count rtd)
@ -878,6 +891,14 @@
"current inspector cannot extract info for structure type"
"structure type" rtd)))
(define/who (struct-type-sealed? rtd)
(check who struct-type? rtd)
(#%$record-type-act-sealed? (strip-impersonator rtd)))
(define/who (struct-type-authentic? rtd)
(check who struct-type? rtd)
(struct-property-ref prop:authentic (strip-impersonator rtd) #f))
(define/who struct-type-make-constructor
(case-lambda
[(rtd) (struct-type-make-constructor rtd #f)]
@ -1085,6 +1106,8 @@
(#%$record-set! s i v))
(define (unsafe-struct? v r)
(#3%record? v r))
(define (unsafe-sealed-struct? v r)
(#3%$sealed-record? v r))
;; internal use only, so doesn't need to have 'unsafe-struct as it's name, etc.:
(define unsafe-struct #%$record)
@ -1133,6 +1156,12 @@
(define-values (prop:authentic-override authentic-override? authentic-override-ref)
(make-struct-type-property 'authentic-override (lambda (val info) #t)))
;; A struct with prop:sealed is normally also `record-type-sealed?`, but
;; the schemify transformation might pessimistically generate a non-sealed
;; record type
(define-values (prop:sealed sealed? sealed-ref)
(make-struct-type-property 'sealed (lambda (val info) #t)))
(define (struct-type-immediate-transparent? rtd)
(let ([insp (inspector-ref rtd)])
(and (not (eq? insp none))

3421
racket/src/cs/schemified/expander.scm
View File

File diff suppressed because it is too large Load Diff

1730
racket/src/cs/schemified/io.scm
View File

File diff suppressed because it is too large Load Diff

1124
racket/src/cs/schemified/known.scm
View File

File diff suppressed because it is too large Load Diff

360
racket/src/cs/schemified/regexp.scm
View File

@ -865,18 +865,8 @@
(define rx:line-end 'line-end)
(define rx:word-boundary 'word-boundary)
(define rx:not-word-boundary 'not-word-boundary)
(define struct:rx:alts
(make-record-type-descriptor*
'rx:alts
#f
(|#%nongenerative-uid| rx:alts)
#f
#f
2
0))
(define effect_1936
(struct-type-install-properties!
struct:rx:alts
(define finish39
(make-struct-type-install-properties
'(rx:alts)
2
0
@ -887,6 +877,16 @@
'(0 1)
#f
'rx:alts))
(define struct:rx:alts
(make-record-type-descriptor*
'rx:alts
#f
(|#%nongenerative-uid| rx:alts)
#f
#f
2
0))
(define effect_2414 (finish39 struct:rx:alts))
(define rx:alts1.1
(|#%name|
rx:alts
@ -921,18 +921,8 @@
(rx:alts-rx_2917 s)
($value
(impersonate-ref rx:alts-rx_2917 struct:rx:alts 1 s 'rx:alts 'rx2))))))
(define struct:rx:sequence
(make-record-type-descriptor*
'rx:sequence
#f
(|#%nongenerative-uid| rx:sequence)
#f
#f
2
0))
(define effect_2662
(struct-type-install-properties!
struct:rx:sequence
(define finish44
(make-struct-type-install-properties
'(rx:sequence)
2
0
@ -943,6 +933,16 @@
'(0 1)
#f
'rx:sequence))
(define struct:rx:sequence
(make-record-type-descriptor*
'rx:sequence
#f
(|#%nongenerative-uid| rx:sequence)
#f
#f
2
0))
(define effect_2459 (finish44 struct:rx:sequence))
(define rx:sequence2.1
(|#%name|
rx:sequence
@ -992,18 +992,8 @@
s
'rx:sequence
'needs-backtrack?))))))
(define struct:rx:group
(make-record-type-descriptor*
'rx:group
#f
(|#%nongenerative-uid| rx:group)
#f
#f
2
0))
(define effect_3021
(struct-type-install-properties!
struct:rx:group
(define finish49
(make-struct-type-install-properties
'(rx:group)
2
0
@ -1014,6 +1004,16 @@
'(0 1)
#f
'rx:group))
(define struct:rx:group
(make-record-type-descriptor*
'rx:group
#f
(|#%nongenerative-uid| rx:group)
#f
#f
2
0))
(define effect_1819 (finish49 struct:rx:group))
(define rx:group3.1
(|#%name|
rx:group
@ -1060,18 +1060,8 @@
s
'rx:group
'number))))))
(define struct:rx:repeat
(make-record-type-descriptor*
'rx:repeat
#f
(|#%nongenerative-uid| rx:repeat)
#f
#f
4
0))
(define effect_2413
(struct-type-install-properties!
struct:rx:repeat
(define finish54
(make-struct-type-install-properties
'(rx:repeat)
4
0
@ -1082,6 +1072,16 @@
'(0 1 2 3)
#f
'rx:repeat))
(define struct:rx:repeat
(make-record-type-descriptor*
'rx:repeat
#f
(|#%nongenerative-uid| rx:repeat)
#f
#f
4
0))
(define effect_2312 (finish54 struct:rx:repeat))
(define rx:repeat4.1
(|#%name|
rx:repeat
@ -1161,18 +1161,8 @@
s
'rx:repeat
'non-greedy?))))))
(define struct:rx:maybe
(make-record-type-descriptor*
'rx:maybe
#f
(|#%nongenerative-uid| rx:maybe)
#f
#f
2
0))
(define effect_1615
(struct-type-install-properties!
struct:rx:maybe
(define finish61
(make-struct-type-install-properties
'(rx:maybe)
2
0
@ -1183,6 +1173,16 @@
'(0 1)
#f
'rx:maybe))
(define struct:rx:maybe
(make-record-type-descriptor*
'rx:maybe
#f
(|#%nongenerative-uid| rx:maybe)
#f
#f
2
0))
(define effect_2202 (finish61 struct:rx:maybe))
(define rx:maybe5.1
(|#%name|
rx:maybe
@ -1229,18 +1229,8 @@
s
'rx:maybe
'non-greedy?))))))
(define struct:rx:conditional
(make-record-type-descriptor*
'rx:conditional
#f
(|#%nongenerative-uid| rx:conditional)
#f
#f
6
0))
(define effect_2714
(struct-type-install-properties!
struct:rx:conditional
(define finish66
(make-struct-type-install-properties
'(rx:conditional)
6
0
@ -1251,6 +1241,16 @@
'(0 1 2 3 4 5)
#f
'rx:conditional))
(define struct:rx:conditional
(make-record-type-descriptor*
'rx:conditional
#f
(|#%nongenerative-uid| rx:conditional)
#f
#f
6
0))
(define effect_2905 (finish66 struct:rx:conditional))
(define rx:conditional6.1
(|#%name|
rx:conditional
@ -1366,18 +1366,8 @@
s
'rx:conditional
'needs-backtrack?))))))
(define struct:rx:lookahead
(make-record-type-descriptor*
'rx:lookahead
#f
(|#%nongenerative-uid| rx:lookahead)
#f
#f
4
0))
(define effect_2193
(struct-type-install-properties!
struct:rx:lookahead
(define finish75
(make-struct-type-install-properties
'(rx:lookahead)
4
0
@ -1388,6 +1378,16 @@
'(0 1 2 3)
#f
'rx:lookahead))
(define struct:rx:lookahead
(make-record-type-descriptor*
'rx:lookahead
#f
(|#%nongenerative-uid| rx:lookahead)
#f
#f
4
0))
(define effect_2486 (finish75 struct:rx:lookahead))
(define rx:lookahead7.1
(|#%name|
rx:lookahead
@ -1469,18 +1469,8 @@
s
'rx:lookahead
'num-n))))))
(define struct:rx:lookbehind
(make-record-type-descriptor*
'rx:lookbehind
#f
(|#%nongenerative-uid| rx:lookbehind)
#f
#f
6
12))
(define effect_2578
(struct-type-install-properties!
struct:rx:lookbehind
(define finish82
(make-struct-type-install-properties
'(rx:lookbehind)
6
0
@ -1491,6 +1481,16 @@
'(0 1 4 5)
#f
'rx:lookbehind))
(define struct:rx:lookbehind
(make-record-type-descriptor*
'rx:lookbehind
#f
(|#%nongenerative-uid| rx:lookbehind)
#f
#f
6
12))
(define effect_2468 (finish82 struct:rx:lookbehind))
(define rx:lookbehind8.1
(|#%name|
rx:lookbehind
@ -1640,18 +1640,8 @@
v
'rx:lookbehind
'lb-max))))))
(define struct:rx:cut
(make-record-type-descriptor*
'rx:cut
#f
(|#%nongenerative-uid| rx:cut)
#f
#f
4
0))
(define effect_2428
(struct-type-install-properties!
struct:rx:cut
(define finish93
(make-struct-type-install-properties
'(rx:cut)
4
0
@ -1662,6 +1652,16 @@
'(0 1 2 3)
#f
'rx:cut))
(define struct:rx:cut
(make-record-type-descriptor*
'rx:cut
#f
(|#%nongenerative-uid| rx:cut)
#f
#f
4
0))
(define effect_2158 (finish93 struct:rx:cut))
(define rx:cut9.1
(|#%name|
rx:cut
@ -1733,18 +1733,8 @@
s
'rx:cut
'needs-backtrack?))))))
(define struct:rx:reference
(make-record-type-descriptor*
'rx:reference
#f
(|#%nongenerative-uid| rx:reference)
#f
#f
2
0))
(define effect_2572
(struct-type-install-properties!
struct:rx:reference
(define finish100
(make-struct-type-install-properties
'(rx:reference)
2
0
@ -1755,6 +1745,16 @@
'(0 1)
#f
'rx:reference))
(define struct:rx:reference
(make-record-type-descriptor*
'rx:reference
#f
(|#%nongenerative-uid| rx:reference)
#f
#f
2
0))
(define effect_2306 (finish100 struct:rx:reference))
(define rx:reference10.1
(|#%name|
rx:reference
@ -1806,18 +1806,8 @@
s
'rx:reference
'case-sensitive?))))))
(define struct:rx:range
(make-record-type-descriptor*
'rx:range
#f
(|#%nongenerative-uid| rx:range)
#f
#f
1
0))
(define effect_2430
(struct-type-install-properties!
struct:rx:range
(define finish105
(make-struct-type-install-properties
'(rx:range)
1
0
@ -1828,6 +1818,16 @@
'(0)
#f
'rx:range))
(define struct:rx:range
(make-record-type-descriptor*
'rx:range
#f
(|#%nongenerative-uid| rx:range)
#f
#f
1
0))
(define effect_2071 (finish105 struct:rx:range))
(define rx:range11.1
(|#%name|
rx:range
@ -1858,18 +1858,8 @@
s
'rx:range
'range))))))
(define struct:rx:unicode-categories
(make-record-type-descriptor*
'rx:unicode-categories
#f
(|#%nongenerative-uid| rx:unicode-categories)
#f
#f
2
0))
(define effect_2489
(struct-type-install-properties!
struct:rx:unicode-categories
(define finish109
(make-struct-type-install-properties
'(rx:unicode-categories)
2
0
@ -1880,6 +1870,16 @@
'(0 1)
#f
'rx:unicode-categories))
(define struct:rx:unicode-categories
(make-record-type-descriptor*
'rx:unicode-categories
#f
(|#%nongenerative-uid| rx:unicode-categories)
#f
#f
2
0))
(define effect_2341 (finish109 struct:rx:unicode-categories))
(define rx:unicode-categories12.1
(|#%name|
rx:unicode-categories
@ -2129,18 +2129,8 @@
num-n_0
(let ((or-part_0 (needs-backtrack? pces1_0)))
(if or-part_0 or-part_0 (needs-backtrack? pces2_0))))))
(define struct:parse-config
(make-record-type-descriptor*
'parse-config
#f
(|#%nongenerative-uid| parse-config)
#f
#f
7
0))
(define effect_2522
(struct-type-install-properties!
struct:parse-config
(define finish123
(make-struct-type-install-properties
'(parse-config)
7
0
@ -2151,6 +2141,16 @@
'(0 1 2 3 4 5 6)
#f
'parse-config))
(define struct:parse-config
(make-record-type-descriptor*
'parse-config
#f
(|#%nongenerative-uid| parse-config)
#f
#f
7
0))
(define effect_2622 (finish123 struct:parse-config))
(define parse-config1.1
(|#%name|
parse-config
@ -4697,18 +4697,8 @@
(zero-sized? (rx:cut-rx rx_0))
#f)))))))))))))))))))
(define union (lambda (a_0 b_0) (if a_0 (if b_0 (range-union a_0 b_0) #f) #f)))
(define struct:lazy-bytes
(make-record-type-descriptor*
'lazy-bytes
#f
(|#%nongenerative-uid| lazy-bytes)
#f
#f
13
3075))
(define effect_2409
(struct-type-install-properties!
struct:lazy-bytes
(define finish535
(make-struct-type-install-properties
'(lazy-bytes)
13
0
@ -4719,6 +4709,16 @@
'(2 3 4 5 6 7 8 9 12)
#f
'lazy-bytes))
(define struct:lazy-bytes
(make-record-type-descriptor*
'lazy-bytes
#f
(|#%nongenerative-uid| lazy-bytes)
#f
#f
13
3075))
(define effect_2741 (finish535 struct:lazy-bytes))
(define lazy-bytes1.1
(|#%name|
lazy-bytes
@ -7242,18 +7242,8 @@
(if (rx:range? rx_0)
(range-matcher* (compile-range (rx:range-range rx_0)) max_0)
#f))))))
(define struct:rx:regexp
(make-record-type-descriptor*
'regexp
#f
(|#%nongenerative-uid| regexp)
#f
#f
10
0))
(define effect_2528
(struct-type-install-properties!
struct:rx:regexp
(define finish621
(make-struct-type-install-properties
'(regexp)
10
0
@ -7281,6 +7271,16 @@
'(0 1 2 3 4 5 6 7 8 9)
#f
'rx:regexp))
(define struct:rx:regexp
(make-record-type-descriptor*
'regexp
#f
(|#%nongenerative-uid| regexp)
#f
#f
10
0))
(define effect_2726 (finish621 struct:rx:regexp))
(define rx:regexp1.1
(|#%name|
rx:regexp

4134
racket/src/cs/schemified/schemify.scm
View File

File diff suppressed because it is too large Load Diff

1496
racket/src/cs/schemified/thread.scm
View File

File diff suppressed because it is too large Load Diff

3
racket/src/expander/compile/built-in-symbol.rkt
View File

@ -85,13 +85,14 @@
record-accessor
record-mutator
record-predicate
struct-type-install-properties!
make-struct-type-install-properties
#%struct-constructor
#%struct-predicate
#%struct-field-accessor
#%struct-field-mutator
#%nongenerative-uid
unsafe-struct?
unsafe-sealed-struct?
unsafe-struct
raise-binding-result-arity-error
raise-definition-result-arity-error

3
racket/src/expander/syntax/scope.rkt
View File

@ -167,6 +167,7 @@
shifted ; box of table: interned shifted-multi-scopes for non-label phases
label-shifted) ; box of table: interned shifted-multi-scopes for label phases
#:authentic
#:sealed
#:property prop:serialize
(lambda (ms ser-push! state)
(ser-push! 'tag '#:multi-scope)
@ -247,6 +248,7 @@
(struct shifted-multi-scope (phase ; non-label phase shift or shifted-to-label-phase
multi-scope) ; a multi-scope
#:authentic
#:sealed
#:property prop:custom-write
(lambda (sms port mode)
(write-string "#<scope:" port)
@ -574,6 +576,7 @@
inspector ; #f or inspector
tamper) ; see "tamper.rkt"
#:authentic
#:sealed
#:property prop:propagation syntax-e
#:property prop:propagation-tamper (lambda (p) (propagation-tamper p))
#:property prop:propagation-set-tamper (lambda (p v) (propagation-set-tamper p v)))

1
racket/src/expander/syntax/syntax.rkt
View File

@ -58,6 +58,7 @@
props ; properties
inspector) ; inspector for access to protected bindings
#:authentic
#:sealed
;; Custom printer:
#:property prop:custom-write
(lambda (s port mode)

13
racket/src/schemify/find-definition.rkt
View File

@ -46,9 +46,10 @@
(known-struct-constructor (arithmetic-shift 1 (struct-type-info-field-count info)) type struct:s)
a-known-constant))]
[authentic? (struct-type-info-authentic? info)]
[sealed? (struct-type-info-sealed? info)]
[knowns (hash-set knowns
(unwrap s?)
(known-struct-predicate 2 type struct:s authentic?))]
(known-struct-predicate 2 type struct:s authentic? sealed?))]
[knowns
(let* ([immediate-count (struct-type-info-immediate-field-count info)]
[parent-count (- (struct-type-info-field-count info)
@ -76,7 +77,8 @@
[`,_ knowns])))])
(values (hash-set knowns (unwrap struct:s) (known-struct-type type
(struct-type-info-field-count info)
(struct-type-info-pure-constructor? info)))
(struct-type-info-pure-constructor? info)
(struct-type-info-sealed? info)))
info))]
[else (values knowns #f)])]
[`(define-values (,struct:s ,make-s ,s? ,s-ref ,s-set!) ,rhs) ; direct use of `make-struct-type`
@ -92,11 +94,14 @@
a-known-constant))]
[knowns (hash-set knowns
(unwrap s?)
(known-struct-predicate 2 type struct:s (struct-type-info-authentic? info)))])
(known-struct-predicate 2 type struct:s
(struct-type-info-authentic? info)
(struct-type-info-sealed? info)))])
;; For now, we don't try to track the position-consuming accessor or mutator
(hash-set knowns (unwrap struct:s) (known-struct-type type
(struct-type-info-field-count info)
(struct-type-info-pure-constructor? info))))
(struct-type-info-pure-constructor? info)
(struct-type-info-sealed? info))))
info)]
[else (values knowns #f)])]
[`(define-values (,prop:s ,s? ,s-ref)

1
racket/src/schemify/inline.rkt
View File

@ -266,6 +266,7 @@
(known-predicate-type k)
(known-struct-predicate-type-id k)
(known-struct-predicate-authentic? k)
(known-struct-predicate-sealed? k)
(needed->list needed))]
[else
(known-predicate (known-procedure-arity-mask k)

9
racket/src/schemify/known.rkt
View File

@ -29,13 +29,14 @@
known-procedure/has-unsafe/folding/limited known-procedure/has-unsafe/folding/limited?
known-procedure/has-unsafe/folding/limited-kind
known-struct-type known-struct-type? known-struct-type-type
known-struct-type-field-count known-struct-type-pure-constructor?
known-struct-type-field-count known-struct-type-pure-constructor? known-struct-type-sealed?
known-constructor known-constructor? known-constructor-type
known-predicate known-predicate? known-predicate-type
known-accessor known-accessor? known-accessor-type
known-mutator known-mutator? known-mutator-type
known-struct-constructor known-struct-constructor? known-struct-constructor-type-id
known-struct-predicate known-struct-predicate? known-struct-predicate-type-id known-struct-predicate-authentic?
known-struct-predicate known-struct-predicate? known-struct-predicate-type-id
known-struct-predicate-authentic? known-struct-predicate-sealed?
known-field-accessor known-field-accessor? known-field-accessor-type-id known-field-accessor-authentic?
known-field-accessor-pos known-field-accessor-known-immutable?
known-field-mutator known-field-mutator? known-field-mutator-type-id known-field-mutator-authentic?
@ -115,7 +116,7 @@
(struct known-procedure/has-unsafe/folding () #:prefab #:omit-define-syntaxes #:super struct:known-procedure/has-unsafe)
(struct known-procedure/has-unsafe/folding/limited (kind) #:prefab #:omit-define-syntaxes #:super struct:known-procedure/has-unsafe/folding)
(struct known-struct-type (type field-count pure-constructor?) #:prefab #:omit-define-syntaxes #:super struct:known-consistent)
(struct known-struct-type (type field-count pure-constructor? sealed?) #:prefab #:omit-define-syntaxes #:super struct:known-consistent)
;; procedures with a known connection to a structure type:
(struct known-constructor (type) #:prefab #:omit-define-syntaxes #:super struct:known-procedure/allocates)
@ -123,7 +124,7 @@
(struct known-accessor (type) #:prefab #:omit-define-syntaxes #:super struct:known-procedure/single-valued)
(struct known-mutator (type) #:prefab #:omit-define-syntaxes #:super struct:known-procedure/single-valued)
(struct known-struct-constructor (type-id) #:prefab #:omit-define-syntaxes #:super struct:known-constructor)
(struct known-struct-predicate (type-id authentic?) #:prefab #:omit-define-syntaxes #:super struct:known-predicate)
(struct known-struct-predicate (type-id authentic? sealed?) #:prefab #:omit-define-syntaxes #:super struct:known-predicate)
(struct known-field-accessor (type-id authentic? pos known-immutable?) #:prefab #:omit-define-syntaxes #:super struct:known-accessor)
(struct known-field-mutator (type-id authentic? pos) #:prefab #:omit-define-syntaxes #:super struct:known-mutator)
(struct known-struct-constructor/need-imports (needed) #:prefab #:omit-define-syntaxes #:super struct:known-struct-constructor)

9
racket/src/schemify/schemify.rkt
View File

@ -872,21 +872,24 @@
(define type-id (and (pair? args)
(null? (cdr args))
(inline-type-id k im add-import! mutated imports)))
(define unsafe-struct? (if (known-struct-predicate-sealed? k)
'unsafe-sealed-struct?
'unsafe-struct?))
(cond
[(not type-id) #f]
[(known-struct-predicate-authentic? k)
(define tmp (maybe-tmp (car args) 'v))
(define ques `(unsafe-struct? ,tmp ,(schemify type-id 'fresh)))
(define ques `(,unsafe-struct? ,tmp ,(schemify type-id 'fresh)))
(wrap-tmp tmp (car args)
ques)]
[else
(define tmp (maybe-tmp (car args) 'v))
(define schemified-type-id (schemify type-id 'fresh))
(define tmp-type-id (maybe-tmp schemified-type-id 'v))
(define ques `(if (unsafe-struct? ,tmp ,tmp-type-id)
(define ques `(if (,unsafe-struct? ,tmp ,tmp-type-id)
#t
(if (impersonator? ,tmp)
(unsafe-struct? (impersonator-val ,tmp) ,tmp-type-id)
(,unsafe-struct? (impersonator-val ,tmp) ,tmp-type-id)
#f)))
(wrap-tmp tmp (car args)
(wrap-tmp tmp-type-id schemified-type-id

35
racket/src/schemify/struct-convert.rkt
View File

@ -60,7 +60,24 @@
(define system-opaque? (and (aim? target 'system)
(or (not exports)
(eq? 'no (hash-ref exports (unwrap struct:s) 'no)))))
(define finish!-id (and (or (pair? (struct-type-info-rest sti))
(and (struct-type-info-prefab-immutables sti)
;; to ensure that the super is also a prefab:
(unwrap (struct-type-info-parent sti))))
(deterministic-gensym "finish")))
`(begin
,@(if finish!-id
`((define ,finish!-id
(make-struct-type-install-properties ',(if system-opaque?
;; list is recognized by `struct-type-install-properties!`
;; to indicate a system structure type:
(list (struct-type-info-name sti))
(struct-type-info-name sti))
,(struct-type-info-immediate-field-count sti)
0
,(schemify (struct-type-info-parent sti) knowns)
,@(schemify-body schemify knowns (struct-type-info-rest sti)))))
null)
(define ,struct:s (make-record-type-descriptor* ',(struct-type-info-name sti)
,(schemify (struct-type-info-parent sti) knowns)
,(if (not (struct-type-info-prefab-immutables sti))
@ -74,7 +91,7 @@
,(struct-type-info-immediate-field-count sti)
0 #f
',(struct-type-info-prefab-immutables sti)))
#f
,(struct-type-info-sealed? sti)
#f
,(struct-type-info-immediate-field-count sti)
,(let* ([n (struct-type-info-immediate-field-count sti)]
@ -91,19 +108,9 @@
(loop (cdr imms) (bitwise-and mask m)))])))]
[else
mask]))))
,@(if (null? (struct-type-info-rest sti))
null
`((define ,(deterministic-gensym "effect")
(struct-type-install-properties! ,struct:s
',(if system-opaque?
;; list is recognized by `struct-type-install-properties!`
;; to indincate a system structure type:
(list (struct-type-info-name sti))
(struct-type-info-name sti))
,(struct-type-info-immediate-field-count sti)
0
,(schemify (struct-type-info-parent sti) knowns)
,@(schemify-body schemify knowns (struct-type-info-rest sti))))))
,@(if finish!-id
`((define ,(deterministic-gensym "effect") (,finish!-id ,struct:s)))
null)
(define ,make-s ,(let ([ctr `(record-constructor
(make-record-constructor-descriptor ,struct:s #f #f))])
(define ctr-expr

2
racket/src/schemify/struct-type-info.rkt
View File

@ -17,6 +17,7 @@
field-count
pure-constructor?
authentic?
sealed?
prefab-immutables ; #f or immutable expression to be quoted
non-prefab-immutables ; #f or immutable expression to be quoted
constructor-name-expr ; an expression
@ -107,6 +108,7 @@
(not (unwrap (list-ref rest 4))))
(not (includes-property? 'prop:chaperone-unsafe-undefined)))
(includes-property? 'prop:authentic)
(includes-property? 'prop:sealed)
(if (eq? prefab-imms 'non-prefab)
#f
prefab-imms)

1
racket/src/thread/thread.rkt
View File

@ -131,6 +131,7 @@
[future #:mutable]) ; current would-be future
#:authentic
#:sealed
#:property host:prop:unsafe-authentic-override #t ; allow evt chaperone
#:property prop:waiter
(make-waiter-methods

2
racket/src/version/racket_version.h
View File

@ -16,7 +16,7 @@
#define MZSCHEME_VERSION_X 8
#define MZSCHEME_VERSION_Y 0
#define MZSCHEME_VERSION_Z 0
#define MZSCHEME_VERSION_W 6
#define MZSCHEME_VERSION_W 7
/* A level of indirection makes `#` work as needed: */
#define AS_a_STR_HELPER(x) #x