diff --git a/typed-racket-lib/typed-racket/env/type-env-structs.rkt b/typed-racket-lib/typed-racket/env/type-env-structs.rkt index e3b41ec51..49e3941f4 100644 --- a/typed-racket-lib/typed-racket/env/type-env-structs.rkt +++ b/typed-racket-lib/typed-racket/env/type-env-structs.rkt @@ -21,6 +21,7 @@ [obj-types (hash/c Object? Type? #:immutable #t)] [props (listof Prop?)] [aliases immutable-free-id-table?]) + #:authentic #:transparent #:property prop:custom-write (lambda (e prt mode) diff --git a/typed-racket-lib/typed-racket/infer/infer-unit.rkt b/typed-racket-lib/typed-racket/infer/infer-unit.rkt index a306c052d..5ea9bc83a 100644 --- a/typed-racket-lib/typed-racket/infer/infer-unit.rkt +++ b/typed-racket-lib/typed-racket/infer/infer-unit.rkt @@ -182,15 +182,15 @@ ;; This is a unification of all of the dotted types that exist ListDots, ->..., and ValuesDots. ;; This allows for one implementation of the cgen algorithm for dotted types to be shared across all ;; of them. -(struct seq (types end) #:transparent) -(struct null-end () #:transparent) +(struct seq (types end) #:transparent #:authentic) +(struct null-end () #:transparent #:authentic) (define -null-end (null-end)) ;; ts is the pattern of the rest of the seq that can ;; occur 0 or more times ;; e.g. a rest argument of Num would just be (list Num) ;; a rest arg of (Num Str) would be (list Num Str) -(struct star-end (ts) #:transparent) -(struct dotted-end (type bound) #:transparent) +(struct star-end (ts) #:transparent #:authentic) +(struct dotted-end (type bound) #:transparent #:authentic) (define (Values->seq v) (match v diff --git a/typed-racket-lib/typed-racket/private/parse-type.rkt b/typed-racket-lib/typed-racket/private/parse-type.rkt index 5d8c85581..0dedcec99 100644 --- a/typed-racket-lib/typed-racket/private/parse-type.rkt +++ b/typed-racket-lib/typed-racket/private/parse-type.rkt @@ -608,8 +608,8 @@ [t (-val (syntax->datum #'t))])) -(struct parsing-mode () #:transparent) -(struct synth-mode parsing-mode (name args same-component-pred) #:transparent) +(struct parsing-mode () #:transparent #:authentic) +(struct synth-mode parsing-mode (name args same-component-pred) #:transparent #:authentic) ;; This mode is used to build up info about how types depend on each other -- ;; during this parsing, we can't check certain invariant successfully (i.e. when @@ -636,7 +636,7 @@ ;; ;; interp. same as referenced-aliases referenced-class-parents) - #:transparent) + #:transparent #:authentic) (define INIT-LEVEL 0) (define ALWAYS-PRODUCTIVE-LEVEL -1) diff --git a/typed-racket-lib/typed-racket/rep/core-rep.rkt b/typed-racket-lib/typed-racket/rep/core-rep.rkt index c3178cf4d..9e8a4dbda 100644 --- a/typed-racket-lib/typed-racket/rep/core-rep.rkt +++ b/typed-racket-lib/typed-racket/rep/core-rep.rkt @@ -73,6 +73,7 @@ (begin (struct name () #:constructor-name mk #:transparent + #:authentic #:property prop:custom-print-quotable 'never extra ... #:methods gen:custom-write diff --git a/typed-racket-lib/typed-racket/rep/free-variance.rkt b/typed-racket-lib/typed-racket/rep/free-variance.rkt index 2d16803c1..721d9abce 100644 --- a/typed-racket-lib/typed-racket/rep/free-variance.rkt +++ b/typed-racket-lib/typed-racket/rep/free-variance.rkt @@ -42,13 +42,13 @@ variance:const variance:dotted) (let () - (define-struct Variance () #:transparent) - (define-struct (Covariant Variance) () #:transparent) - (define-struct (Contravariant Variance) () #:transparent) - (define-struct (Invariant Variance) () #:transparent) - (define-struct (Constant Variance) () #:transparent) + (define-struct Variance () #:transparent #:authentic) + (define-struct (Covariant Variance) () #:transparent #:authentic) + (define-struct (Contravariant Variance) () #:transparent #:authentic) + (define-struct (Invariant Variance) () #:transparent #:authentic) + (define-struct (Constant Variance) () #:transparent #:authentic) ;; not really a variance, but is disjoint with the others - (define-struct (Dotted Variance) () #:transparent) + (define-struct (Dotted Variance) () #:transparent #:authentic) (values Variance? (make-Covariant) (make-Contravariant) (make-Invariant) (make-Constant) (make-Dotted)))) (define (variance:co? x) (eq? x variance:co)) @@ -74,9 +74,9 @@ ;;All of these are used internally ;;Only combined-frees is used externally -(struct combined-frees (table computed) #:transparent) -(struct app-frees (name args) #:transparent) -(struct remove-frees (inner name) #:transparent) +(struct combined-frees (table computed) #:transparent #:authentic) +(struct app-frees (name args) #:transparent #:authentic) +(struct remove-frees (inner name) #:transparent #:authentic) ;; Base constructors diff --git a/typed-racket-lib/typed-racket/rep/rep-utils.rkt b/typed-racket-lib/typed-racket/rep/rep-utils.rkt index 52d957664..8609aafe7 100644 --- a/typed-racket-lib/typed-racket/rep/rep-utils.rkt +++ b/typed-racket-lib/typed-racket/rep/rep-utils.rkt @@ -614,6 +614,7 @@ [struct-def (syntax/loc #'var.name (struct var.name parent ... (flds.ids ...) maybe-transparent ... + #:authentic #:constructor-name constructor-name #:property prop:uid uid-id #:property prop:mask rep-mask-body diff --git a/typed-racket-lib/typed-racket/rep/type-constr.rkt b/typed-racket-lib/typed-racket/rep/type-constr.rkt index 8ba2c2144..0b97ea25f 100644 --- a/typed-racket-lib/typed-racket/rep/type-constr.rkt +++ b/typed-racket-lib/typed-racket/rep/type-constr.rkt @@ -37,7 +37,7 @@ ;; kind*: whether this type constructor can take an arbitrary number of arguments ;; productive?: whether this type constructor is productive. (struct TypeConstructor (real-trep-constr arity kind*? productive? [variances #:mutable]) - #:transparent + #:transparent #:authentic #:property prop:kind #t #:property prop:procedure (lambda (me . args) diff --git a/typed-racket-lib/typed-racket/typecheck/check-class-unit.rkt b/typed-racket-lib/typed-racket/typecheck/check-class-unit.rkt index 8b81d8e48..214015fa0 100644 --- a/typed-racket-lib/typed-racket/typecheck/check-class-unit.rkt +++ b/typed-racket-lib/typed-racket/typecheck/check-class-unit.rkt @@ -47,7 +47,7 @@ ;; ;; interp. Represents the by-position and by-name initialization ;; arguments respectively provided by the class -(struct super-init-stxs (by-position by-name) #:transparent) +(struct super-init-stxs (by-position by-name) #:transparent #:authentic) ;; time debugging (define-syntax do-timing #f) diff --git a/typed-racket-lib/typed-racket/typecheck/check-unit-unit.rkt b/typed-racket-lib/typed-racket/typecheck/check-unit-unit.rkt index 947eab7c7..427484f15 100644 --- a/typed-racket-lib/typed-racket/typecheck/check-unit-unit.rkt +++ b/typed-racket-lib/typed-racket/typecheck/check-unit-unit.rkt @@ -162,7 +162,7 @@ ;; - internal names are the internal renamings of those variables in fully expanded ;; unit syntax, this renaming is performed by the untyped unit macro ;; - All references within a unit body use the internal names -(struct sig-info (name externals internals) #:transparent) +(struct sig-info (name externals internals) #:transparent #:authentic) ;; Process the various pieces of the fully expanded unit syntax to produce ;; sig-info structures for the unit's imports and exports, and a list of the @@ -410,7 +410,7 @@ ;; - export-links : the symbols corresponding to the link-bindings exported ;; by this unit (struct cu-expr-info (expr import-sigs import-links export-sigs export-links) - #:transparent) + #:transparent #:authentic) ;; parse-compound-unit : Syntax -> (Values (Listof (Cons Symbol Id)) ;; (Listof Symbol) diff --git a/typed-racket-lib/typed-racket/typecheck/renamer.rkt b/typed-racket-lib/typed-racket/typecheck/renamer.rkt index 90837be87..c986ad10f 100644 --- a/typed-racket-lib/typed-racket/typecheck/renamer.rkt +++ b/typed-racket-lib/typed-racket/typecheck/renamer.rkt @@ -18,6 +18,7 @@ ;; shallow-id : identifier ;; optional-id : identifier (struct typed-renaming (deep-id untyped-id shallow-id optional-id) + #:authentic ;; prevent the rename transformer from expanding in ;; module-begin context because the typed context flag ;; will not be set until the module-begin diff --git a/typed-racket-lib/typed-racket/typecheck/tc-lambda-unit.rkt b/typed-racket-lib/typed-racket/typecheck/tc-lambda-unit.rkt index c15cf1ac1..786bdac03 100644 --- a/typed-racket-lib/typed-racket/typecheck/tc-lambda-unit.rkt +++ b/typed-racket-lib/typed-racket/typecheck/tc-lambda-unit.rkt @@ -52,7 +52,7 @@ ;; rest: id or #f ;; syntax: syntax? - the improper syntax list of identifiers ;; (i.e. (append positional (or id '())) but syntax) -(struct formals (positional rest syntax) #:transparent) +(struct formals (positional rest syntax) #:transparent #:authentic) ;; When expanding a keyword or optional lambda, Racket adds into the expanded @@ -427,7 +427,7 @@ ;; [(x y z) ...] ; ==> (case-arities '(1 2 3) +inf.0) ;; [(x y . rst) ...] ; ==> (case-arities '(1 2) 2) ;; [l ...]) ; ==> (case-arities '() 0) -(struct case-arities (fixed-arities rest-pos) #:transparent) +(struct case-arities (fixed-arities rest-pos) #:transparent #:authentic) ;; initially, we have seen no fixed arities and it is impossible for ;; an argument to be in a rest argument from a previous clause diff --git a/typed-racket-lib/typed-racket/typecheck/tc-let-unit.rkt b/typed-racket-lib/typed-racket/typecheck/tc-let-unit.rkt index 013763f7c..f30380e25 100644 --- a/typed-racket-lib/typed-racket/typecheck/tc-let-unit.rkt +++ b/typed-racket-lib/typed-racket/typecheck/tc-let-unit.rkt @@ -267,7 +267,7 @@ ;; (lr-clause (Listof Identifier) Syntax) ;; ;; interp. represents a letrec binding -(struct lr-clause (names expr) #:transparent) +(struct lr-clause (names expr) #:transparent #:authentic) ;; get-non-recursive-clauses : (Listof lr-clause) (Listof Identifier) -> ;; (Listof lr-clause) (Listof lr-clause) (Listof Syntax) diff --git a/typed-racket-lib/typed-racket/typecheck/tc-structs.rkt b/typed-racket-lib/typed-racket/typecheck/tc-structs.rkt index 3afd62dd8..aca4cf5b5 100644 --- a/typed-racket-lib/typed-racket/typecheck/tc-structs.rkt +++ b/typed-racket-lib/typed-racket/typecheck/tc-structs.rkt @@ -60,7 +60,7 @@ ;; desc : struct-desc ;; struct-info : struct-info? ;; type-only : Boolean -(struct parsed-struct (sty names desc struct-info) #:transparent) +(struct parsed-struct (sty names desc struct-info) #:transparent #:authentic) ;; struct-name : Id (the identifier for the static struct info, ;; usually the same as the type-name) @@ -71,7 +71,7 @@ ;; predicate : Id ;; getters : Listof[Id] ;; setters : Listof[Id] or #f -(struct struct-names (struct-name type-name struct-type constructor extra-constructor predicate getters setters) #:transparent) +(struct struct-names (struct-name type-name struct-type constructor extra-constructor predicate getters setters) #:transparent #:authentic) ;; struct-desc holds all the relevant information about a struct type's types ;; parent-fields : (Listof Type) @@ -81,7 +81,7 @@ ;; parent-mutable: Any (struct struct-desc (parent-fields self-fields tvars mutable parent-mutable) - #:transparent) + #:transparent #:authentic) (define (struct-desc-all-fields fields) (append (struct-desc-parent-fields fields) (struct-desc-self-fields fields))) diff --git a/typed-racket-lib/typed-racket/utils/utils.rkt b/typed-racket-lib/typed-racket/utils/utils.rkt index 4b76d76d2..e41c4b1d6 100644 --- a/typed-racket-lib/typed-racket/utils/utils.rkt +++ b/typed-racket-lib/typed-racket/utils/utils.rkt @@ -217,10 +217,22 @@ at least theoretically. (syntax-parse stx [(_ head cnt . body) (syntax/loc stx (define head . body))])))) - (define-syntax define-struct/cond-contract (if enable-contracts? - (make-rename-transformer #'define-struct/contract) + ;; When contracts are enabled, filter out #:authentic since + ;; define-struct/contract doesn't support it + (lambda (stx) + (syntax-parse stx + [(_ hd ([i c] ...) . opts) + (define filtered-opts + (let loop ([opts (syntax->list #'opts)]) + (cond + [(null? opts) '()] + [(eq? (syntax-e (car opts)) '#:authentic) + (loop (cdr opts))] + [else (cons (car opts) (loop (cdr opts)))]))) + (with-syntax ([(opt ...) filtered-opts]) + #'(define-struct/contract hd ([i c] ...) opt ...))])) (syntax-rules () [(_ hd ([i c] ...) . opts) (define-struct hd (i ...) . opts)])))