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

Merge branch 'master' of github.com:racket/typed-racket into improve-error-messages

Browse Source
This commit is contained in:
Georges Dupéron 2015-12-17 13:51:25 +01:00
commit c9e0197d51
21 changed files with 208 additions and 162 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

9
typed-racket-doc/typed-racket/scribblings/reference/experimental.scrbl
View File

@ -3,7 +3,7 @@
@begin[(require "../utils.rkt" scribble/eval)
(require (for-label (only-meta-in 0 [except-in typed/racket for])))]
@(define the-top-eval (make-base-eval))
@(define the-top-eval (make-base-eval #:lang 'typed/racket))
@(define-syntax-rule (ex . args)
(examples #:eval the-top-eval . args))
@ -27,6 +27,13 @@ The @racket[constructor] is defined as a function that takes a value of type
@racket[t] and produces a value of the new type @racket[name].
A @racket[define-new-subtype] definition is only allowed at the top level of a
file or module.
This is purely a type-level distinction, with no way to distinguish the new type
from the base type at runtime. Predicates made by @racket[make-predicate]
won't be able distinguish them properly, so they will return true for all values
that the base type's predicate would return true for. This is usually not what
you want, so you shouldn't use @racket[make-predicate] with these types.
@ex[(module m typed/racket
(provide Radians radians f)
(define-new-subtype Radians (radians Real))

4
typed-racket-doc/typed-racket/scribblings/reference/special-forms.scrbl
View File

@ -382,7 +382,9 @@ those functions.
(struct maybe-type-vars name-spec ([f : t] ...) options ...)
([maybe-type-vars code:blank (v ...)]
[name-spec name (code:line name parent)]
[options #:transparent #:mutable #:prefab])]{
[options #:transparent #:mutable #:prefab
(code:line #:constructor-name constructor-id)
(code:line #:extra-constructor-name constructor-id)])]{
Defines a @rtech{structure} with the name @racket[name], where the
fields @racket[f] have types @racket[t], similar to the behavior of @|struct-id|
from @racketmodname[racket/base].

2
typed-racket-lib/info.rkt
View File

@ -2,7 +2,7 @@
(define collection 'multi)
(define deps '(("base" #:version "6.2.900.16")
(define deps '(("base" #:version "6.3.0.8")
"pconvert-lib"
"source-syntax"
"compatibility-lib" ;; to assign types

12
typed-racket-lib/typed-racket/base-env/base-env-numeric.rkt
View File

@ -1607,8 +1607,8 @@
(-PosRat -Int . -> . -PosRat)
(-NonNegRat -Int . -> . -NonNegRat)
(-Rat -Int . -> . -Rat)
(-NonNegFlonum -NonNegFlonum . -> . -NonNegFlonum)
(-NonNegFlonum -NonNegReal . -> . (Un -NonNegFlonum -One))
(-NonNegFlonum -Flonum . -> . -NonNegFlonum)
(-NonNegFlonum -Real . -> . (Un -NonNegFlonum -One))
(-PosReal -NonNegFlonum . -> . (Un -NonNegFlonum -One))
;; even integer exponents can give complex results
;; too large exponents turn into infinities, and (expt -inf.0 -inf.0) => nan.0+nan.0i
@ -1617,18 +1617,18 @@
(-Flonum -Fixnum . -> . (Un -Flonum -One))
(-Flonum -Flonum . -> . (Un -Flonum -FloatComplex))
;; 1st arg can't be non-neg, -0.0 gives the wrong sign
(-PosSingleFlonum (Un -NonNegSingleFlonum -NegFixnum -PosFixnum) . -> . -NonNegSingleFlonum)
(-NonNegSingleFlonum (Un -NonNegSingleFlonum -NegFixnum -PosFixnum) . -> . -SingleFlonum)
(-PosSingleFlonum (Un -SingleFlonum -NegFixnum -PosFixnum) . -> . -NonNegSingleFlonum)
(-NonNegSingleFlonum (Un -SingleFlonum -NegFixnum -PosFixnum) . -> . -SingleFlonum)
(-SingleFlonum (Un -NegFixnum -PosFixnum) . -> . -SingleFlonum)
(-SingleFlonum -Fixnum . -> . (Un -SingleFlonum -One))
(-SingleFlonum -SingleFlonum . -> . (Un -SingleFlonum -SingleFlonumComplex))
(-PosInexactReal (Un -NegFixnum -PosFixnum) . -> . -NonNegInexactReal)
(-NonNegInexactReal (Un -NegFixnum -PosFixnum) . -> . -InexactReal)
(-PosReal -Real . -> . -NonNegReal)
(-NonNegReal -Fixnum . -> . -Real)
(-NonNegReal -Real . -> . -Real)
(-InexactReal (Un -NegFixnum -PosFixnum) . -> . -InexactReal)
(-InexactReal -InexactReal . -> . (Un -InexactReal -InexactComplex))
(-Real -Fixnum . -> . -Real)
(-Real -Nat . -> . -Real)
(-FloatComplex -FloatComplex . -> . -FloatComplex)
(-FloatComplex -Flonum . -> . (Un -FloatComplex -Flonum))
(-FloatComplex -InexactReal . -> . (Un -FloatComplex -InexactReal))

7
typed-racket-lib/typed-racket/base-env/base-env.rkt
View File

@ -17,7 +17,7 @@
racket/logging
racket/private/stx
(only-in mzscheme make-namespace)
(only-in racket/match/runtime match:error matchable? match-equality-test))
(only-in racket/match/runtime match:error matchable? match-equality-test syntax-srclocs))
"base-structs.rkt"
racket/file
(only-in racket/private/pre-base new-apply-proc)
@ -1173,6 +1173,7 @@
;[match:error (Univ . -> . (Un))]
[match-equality-test (-Param (Univ Univ . -> . Univ) (Univ Univ . -> . Univ))]
[matchable? (make-pred-ty (Un -String -Bytes))]
[syntax-srclocs (Univ . -> . Univ)]
;; Section 10.1
[values (-polydots (a b) (cl->*
@ -2971,7 +2972,9 @@
[will-try-execute (-> -Will-Executor ManyUniv)]
;; Section 16.4
[collect-garbage (-> -Void)]
[collect-garbage (cl->*
(-> -Void)
(-> (Un (-val 'minor) (-val 'major) (-val 'incremental)) -Void))]
[current-memory-use (-> -Nat)]
[dump-memory-stats (-> Univ)]

81
typed-racket-lib/typed-racket/base-env/prims-struct.rkt
View File

@ -72,10 +72,15 @@
(define-splicing-syntax-class struct-options
#:description "typed structure type options"
#:attributes (guard mutable? transparent? prefab? [prop 1] [prop-val 1])
#:attributes (guard mutable? transparent? prefab? cname ecname
[prop 1] [prop-val 1])
(pattern (~seq (~or (~optional (~seq (~and #:mutable mutable?)))
(~optional (~seq (~and #:transparent transparent?)))
(~optional (~seq (~and #:prefab prefab?)))
(~optional (~or (~and (~seq #:constructor-name cname)
(~bind [ecname #f]))
(~and (~seq #:extra-constructor-name ecname)
(~bind [cname #f]))))
;; FIXME: unsound, but relied on in core libraries
;; #:guard ought to be supportable with some work
;; #:property is harder
@ -121,38 +126,48 @@
;; User-facing macros for defining typed structure types
(define-syntaxes (define-typed-struct -struct)
(values
(lambda (stx)
(syntax-parse stx
[(_ vars:maybe-type-vars nm:struct-name (fs:fld-spec ...)
opts:struct-options)
(let ([mutable? (if (attribute opts.mutable?) #'(#:mutable) #'())]
[cname (second (build-struct-names #'nm.name null #t #t))]
[prefab? (if (attribute opts.prefab?) #'(#:prefab) #'())])
(with-syntax ([d-s (ignore-some
(syntax/loc stx (define-struct nm (fs.fld ...) . opts)))]
[dtsi (quasisyntax/loc stx
(dtsi* (vars.vars ...) nm (fs.form ...)
#:maker #,cname
#,@mutable?
#,@prefab?))])
#'(begin d-s dtsi)))]))
(lambda (stx)
(syntax-parse stx
[(_ vars:maybe-type-vars nm:struct-name/new (fs:fld-spec ...)
opts:struct-options)
(let ([mutable? (if (attribute opts.mutable?) #'(#:mutable) #'())]
[prefab? (if (attribute opts.prefab?) #'(#:prefab) #'())])
(with-syntax ([d-s (ignore (quasisyntax/loc stx
(struct #,@(attribute nm.new-spec) (fs.fld ...)
. opts)))]
[dtsi (quasisyntax/loc stx
(dtsi* (vars.vars ...)
nm.old-spec (fs.form ...)
#,@mutable?
#,@prefab?))])
#'(begin d-s dtsi)))]))))
(define-syntax (define-typed-struct stx)
(syntax-parse stx
[(_ vars:maybe-type-vars nm:struct-name (fs:fld-spec ...) opts:struct-options)
(quasisyntax/loc stx
(-struct #,@#'vars
#,@(if (stx-pair? #'nm)
#'nm
(list #'nm))
(fs ...)
;; If there's already a (extra) constructor name supplied,
;; then Racket's `define-struct` doesn't define a `make-`
;; constructor either so don't pass anything extra.
#,@(if (or (attribute opts.cname)
(attribute opts.ecname))
null
(list #'#:extra-constructor-name
(second (build-struct-names #'nm.name null #t #t))))
. opts))]))
(define-syntax (-struct stx)
(syntax-parse stx
[(_ vars:maybe-type-vars nm:struct-name/new (fs:fld-spec ...)
opts:struct-options)
(let ([mutable? (if (attribute opts.mutable?) #'(#:mutable) #'())]
[prefab? (if (attribute opts.prefab?) #'(#:prefab) #'())]
[maker (if (attribute opts.cname)
#`(#:maker #,(attribute opts.cname))
#'())]
[extra-maker (if (attribute opts.ecname)
#`(#:extra-maker #,(attribute opts.ecname))
#'())])
(with-syntax ([d-s (ignore (quasisyntax/loc stx
(struct #,@(attribute nm.new-spec) (fs.fld ...)
. opts)))]
[dtsi (quasisyntax/loc stx
(dtsi* (vars.vars ...)
nm.old-spec (fs.form ...)
#,@mutable?
#,@prefab?
#,@maker
#,@extra-maker))])
#'(begin d-s dtsi)))]))
;; this has to live here because it's used below

6
typed-racket-lib/typed-racket/optimizer/float-complex.rkt
View File

@ -569,8 +569,10 @@
(log-unboxing-opt "unboxed unary float complex")
#`(let*-values (c.bindings ...)
;; reuses the algorithm used by the Racket runtime
(let-values ([(q) (unsafe-fl/ c.real-binding c.imag-binding)])
(unsafe-fl* c.imag-binding
(let*-values ([(r) (unsafe-flabs c.real-binding)]
[(i) (unsafe-flabs c.imag-binding)]
[(q) (unsafe-fl/ r i)])
(unsafe-fl* i
(unsafe-flsqrt (unsafe-fl+ 1.0
(unsafe-fl* q q))))))])))

118
typed-racket-lib/typed-racket/rep/type-rep.rkt
View File

@ -61,7 +61,6 @@
(define Type/c?
(λ (e)
(and (Type? e)
(not (Scope? e))
(not (arr? e))
(not (fld? e))
(not (Values? e))
@ -75,7 +74,6 @@
(define Values/c?
(λ (e)
(and (Type? e)
(not (Scope? e))
(not (arr? e))
(not (fld? e))
(not (ValuesDots? e))
@ -93,19 +91,6 @@
;; Type is defined in rep-utils.rkt
;; t must be a Type
(def-type Scope ([t (or/c Type/c Scope?)]) [#:key (Type-key t)])
(define (scope-depth k)
(flat-named-contract
(format "Scope of depth ~a" k)
(lambda (sc)
(define (f k sc)
(cond [(= 0 k) (Type/c? sc)]
[(not (Scope? sc)) #f]
[else (f (sub1 k) (Scope-t sc))]))
(f k sc))))
;; this is ONLY used when a type error ocurrs
(def-type Error () [#:frees #f] [#:fold-rhs #:base])
@ -239,48 +224,43 @@
[(Keyword) 'keyword]
[else #f]))])
;; body is a Scope
(def-type Mu ([body (scope-depth 1)]) #:no-provide [#:frees (λ (f) (f body))]
[#:fold-rhs (*Mu (*Scope (type-rec-id (Scope-t body))))]
(def-type Mu ([body Type/c]) #:no-provide [#:frees (λ (f) (f body))]
[#:fold-rhs (*Mu (type-rec-id body))]
[#:key (Type-key body)])
;; n is how many variables are bound here
;; body is a Scope
;; body is a type
(def-type Poly (n body) #:no-provide
[#:contract (->i ([n natural-number/c]
[body (n) (scope-depth n)])
[#:contract (->i ([n natural-number/c]
[body Type/c])
(#:syntax [stx (or/c #f syntax?)])
[result Poly?])]
[#:frees (λ (f) (f body))]
[#:fold-rhs (let ([body* (remove-scopes n body)])
(*Poly n (add-scopes n (type-rec-id body*))))]
[#:fold-rhs (*Poly n (type-rec-id body))]
[#:key (Type-key body)])
;; n is how many variables are bound here
;; there are n-1 'normal' vars and 1 ... var
;; body is a Scope
(def-type PolyDots (n body) #:no-provide
[#:contract (->i ([n natural-number/c]
[body (n) (scope-depth n)])
[body Type/c])
(#:syntax [stx (or/c #f syntax?)])
[result PolyDots?])]
[#:key (Type-key body)]
[#:frees (λ (f) (f body))]
[#:fold-rhs (let ([body* (remove-scopes n body)])
(*PolyDots n (add-scopes n (type-rec-id body*))))])
[#:fold-rhs (*PolyDots n (type-rec-id body))])
;; interp. A row polymorphic function type
;; constraints are row absence constraints, represented
;; as a set for each of init, field, methods
(def-type PolyRow (constraints body) #:no-provide
[#:contract (->i ([constraints (list/c list? list? list? list?)]
[body (scope-depth 1)])
[body Type/c])
(#:syntax [stx (or/c #f syntax?)])
[result PolyRow?])]
[#:frees (λ (f) (f body))]
[#:fold-rhs (let ([body* (remove-scopes 1 body)])
(*PolyRow constraints
(add-scopes 1 (type-rec-id body*))))]
[#:fold-rhs (*PolyRow constraints
(type-rec-id body))]
[#:key (Type-key body)])
;; pred : identifier
@ -636,19 +616,6 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (add-scopes n t)
(if (zero? n) t
(add-scopes (sub1 n) (*Scope t))))
(define (remove-scopes n sc)
(if (zero? n)
sc
(match sc
[(Scope: sc*) (remove-scopes (sub1 n) sc*)]
[_ (int-err "Tried to remove too many scopes: ~a" sc)])))
(define ((sub-f st) e)
(filter-case (#:Type st
#:Filter (sub-f st)
@ -673,7 +640,7 @@
e))
;; abstract-many : Names Type -> Scope^n
;; abstract-many : Names Type -> Type
;; where n is the length of names
(define (abstract-many names ty)
;; mapping : dict[Type -> Natural]
@ -713,27 +680,23 @@
[#:ListDots dty dbound
(*ListDots (sb dty)
(transform dbound values dbound))]
[#:Mu (Scope: body) (*Mu (*Scope (loop (add1 outer) body)))]
[#:PolyRow constraints body*
(let ([body (remove-scopes 1 body*)])
(*PolyRow constraints
(add-scopes 1 (loop (+ 1 outer) body))))]
[#:PolyDots n body*
(let ([body (remove-scopes n body*)])
(*PolyDots n (add-scopes n (loop (+ n outer) body))))]
[#:Poly n body*
(let ([body (remove-scopes n body*)])
(*Poly n (add-scopes n (loop (+ n outer) body))))])))
[#:Mu body (*Mu (loop (add1 outer) body))]
[#:PolyRow constraints body
(*PolyRow constraints (loop (+ 1 outer) body))]
[#:PolyDots n body
(*PolyDots n (loop (+ n outer) body))]
[#:Poly n body
(*Poly n (loop (+ n outer) body))])))
(define n (length names))
(define mapping (for/list ([nm (in-list names)]
[i (in-range n 0 -1)])
(cons nm (sub1 i))))
(add-scopes n (nameTo mapping ty)))
(nameTo mapping ty))
;; instantiate-many : List[Type] Scope^n -> Type
;; instantiate-many : List[Type] Type -> Type
;; where n is the length of types
;; all of the types MUST be Fs
(define (instantiate-many images sc)
(define (instantiate-many images ty)
;; mapping : dict[Natural -> Type]
(define (replace mapping type)
(let loop ([outer 0] [ty type])
@ -770,21 +733,18 @@
[#:ListDots dty dbound
(*ListDots (sb dty)
(transform dbound F-n dbound))]
[#:Mu (Scope: body) (*Mu (*Scope (loop (add1 outer) body)))]
[#:PolyRow constraints body*
(let ([body (remove-scopes 1 body*)])
(*PolyRow constraints (add-scopes 1 (loop (+ 1 outer) body))))]
[#:PolyDots n body*
(let ([body (remove-scopes n body*)])
(*PolyDots n (add-scopes n (loop (+ n outer) body))))]
[#:Poly n body*
(let ([body (remove-scopes n body*)])
(*Poly n (add-scopes n (loop (+ n outer) body))))])))
[#:Mu body (*Mu (loop (add1 outer) body))]
[#:PolyRow constraints body
(*PolyRow constraints (loop (+ 1 outer) body))]
[#:PolyDots n body
(*PolyDots n (loop (+ n outer) body))]
[#:Poly n body
(*Poly n (loop (+ n outer) body))])))
(define n (length images))
(define mapping (for/list ([img (in-list images)]
[i (in-range n 0 -1)])
(cons (sub1 i) img)))
(replace mapping (remove-scopes n sc)))
(replace mapping ty))
(define (abstract name ty)
(abstract-many (list name) ty))
@ -801,8 +761,8 @@
;; the 'smart' destructor
(define (Mu-body* name t)
(match t
[(Mu: scope)
(instantiate (*F name) scope)]))
[(Mu: body)
(instantiate (*F name) body)]))
;; the 'smart' constructor
;;
@ -825,10 +785,10 @@
;; the 'smart' destructor
(define (Poly-body* names t)
(match t
[(Poly: n scope)
[(Poly: n body)
(unless (= (length names) n)
(int-err "Wrong number of names: expected ~a got ~a" n (length names)))
(instantiate-many (map *F names) scope)]))
(instantiate-many (map *F names) body)]))
;; the 'smart' constructor
(define (PolyDots* names body)
@ -840,10 +800,10 @@
;; the 'smart' destructor
(define (PolyDots-body* names t)
(match t
[(PolyDots: n scope)
[(PolyDots: n body)
(unless (= (length names) n)
(int-err "Wrong number of names: expected ~a got ~a" n (length names)))
(instantiate-many (map *F names) scope)]))
(instantiate-many (map *F names) body)]))
;; Constructor and destructor for row polymorphism
;;
@ -858,15 +818,15 @@
(define (PolyRow-body* names t)
(match t
[(PolyRow: constraints scope)
(instantiate-many (map *F names) scope)]))
[(PolyRow: constraints body)
(instantiate-many (map *F names) body)]))
(print-struct #t)
(define-match-expander Mu-unsafe:
(lambda (stx)
(syntax-case stx ()
[(_ bp) #'(? Mu? (app (lambda (t) (Scope-t (Mu-body t))) bp))])))
[(_ bp) #'(? Mu? (app (lambda (t) (Mu-body t)) bp))])))
(define-match-expander Poly-unsafe:
(lambda (stx)

9
typed-racket-lib/typed-racket/typecheck/internal-forms.rkt
View File

@ -74,12 +74,13 @@
;;; Helpers
(define-splicing-syntax-class dtsi-fields
#:attributes (mutable prefab type-only maker)
#:attributes (mutable prefab type-only maker extra-maker)
(pattern
(~seq
(~or (~optional (~and #:mutable (~bind (mutable #t))))
(~optional (~and #:prefab (~bind (prefab #t))))
(~optional (~and #:type-only (~bind (type-only #t))))
(~optional (~seq #:extra-maker extra-maker))
(~optional (~seq #:maker maker))) ...)))
(define-syntax-class struct-name
@ -88,14 +89,16 @@
(define-syntax-class define-typed-struct-body
#:attributes (name mutable prefab type-only maker nm (tvars 1) (fields 1) (types 1))
#:attributes (name mutable prefab type-only maker extra-maker nm
(tvars 1) (fields 1) (types 1))
(pattern ((~optional (tvars:id ...) #:defaults (((tvars 1) null)))
nm:struct-name ([fields:id : types:expr] ...) options:dtsi-fields)
#:attr name #'nm.nm
#:attr mutable (attribute options.mutable)
#:attr prefab (attribute options.prefab)
#:attr type-only (attribute options.type-only)
#:attr maker (or (attribute options.maker) #'nm.nm)))
#:attr maker (or (attribute options.maker) #'nm.nm)
#:attr extra-maker (attribute options.extra-maker)))
(define-syntax-class dviu-import/export
(pattern (sig-id:id member-id:id ...)

18
typed-racket-lib/typed-racket/typecheck/tc-send.rkt
View File

@ -3,7 +3,7 @@
;; This module provides typechecking for `send` method calls
(require "../utils/utils.rkt"
racket/match syntax/stx
racket/match syntax/stx racket/syntax
syntax/parse
(env lexical-env)
(typecheck signatures tc-funapp tc-metafunctions)
@ -65,16 +65,16 @@
#:literals (list)
[(#%plain-app meth obj arg ...)
(with-lexical-env/extend-types vars types
(tc-expr/check #'(#%plain-app meth arg ...)
(tc-expr/check (syntax/loc app-stx (#%plain-app meth arg ...))
expected))]
[(let-values ([(arg-var) arg] ...)
(#%plain-app (#%plain-app cpce s-kp meth kpe kws num)
kws2 kw-args
obj pos-arg ...))
(~and outer-loc (#%plain-app (~and inner-loc (#%plain-app cpce s-kp meth kpe kws num))
kws2 kw-args
obj pos-arg ...)))
(with-lexical-env/extend-types vars types
(tc-expr/check
#'(let-values ([(arg-var) arg] ...)
(#%plain-app (#%plain-app cpce s-kp meth kpe kws num)
kws2 kw-args
pos-arg ...))
(with-syntax* ([inner-app (syntax/loc app-stx (#%plain-app cpce s-kp meth kpe kws num))]
[outer-app (syntax/loc app-stx
(#%plain-app inner-app kws2 kw-args pos-arg ...))])
(syntax/loc app-stx (let-values ([(arg-var) arg] ...) outer-app)))
expected))]))

30
typed-racket-lib/typed-racket/typecheck/tc-structs.rkt
View File

@ -35,10 +35,11 @@
;; type-name : Id
;; struct-type : Id
;; constructor : Id
;; extra-constructor : (Option Id)
;; predicate : Id
;; getters : Listof[Id]
;; setters : Listof[Id] or #f
(struct struct-names (type-name struct-type constructor predicate getters setters) #:transparent)
(struct struct-names (type-name struct-type constructor extra-constructor predicate getters setters) #:transparent)
;;struct-fields: holds all the relevant information about a struct type's types
(struct struct-desc (parent-fields self-fields tvars mutable proc-ty) #:transparent)
@ -79,9 +80,8 @@
;; generate struct names given type name, field names
;; and optional constructor name
;; all have syntax loc of name
;; identifier listof[identifier] Option[identifier] ->
;; (values identifier identifier list[identifier] list[identifier])
(define (get-struct-names nm flds maker*)
;; identifier listof[identifier] Option[identifier] -> struct-names
(define (get-struct-names nm flds maker* extra-maker)
(define (split l)
(let loop ([l l] [getters '()] [setters '()])
(if (null? l)
@ -90,7 +90,7 @@
(match (build-struct-names nm flds #f #f nm #:constructor-name maker*)
[(list sty maker pred getters/setters ...)
(let-values ([(getters setters) (split getters/setters)])
(struct-names nm sty maker pred getters setters))]))
(struct-names nm sty maker extra-maker pred getters setters))]))
;; gets the fields of the parent type, if they exist
;; Option[Struct-Ty] -> Listof[Type]
@ -192,12 +192,23 @@
(make-def-binding s (poly-wrapper (->* (list poly-base t) -Void))))
null))))
(define extra-constructor (struct-names-extra-constructor names))
(add-struct-constructor! (struct-names-constructor names))
(when extra-constructor
(add-struct-constructor! extra-constructor))
(define constructor-binding
(make-def-binding (struct-names-constructor names) (poly-wrapper (->* all-fields poly-base))))
(make-def-binding (struct-names-constructor names)
(poly-wrapper (->* all-fields poly-base))))
(define constructor-bindings
(cons constructor-binding
(if extra-constructor
(list (make-def-binding extra-constructor
(poly-wrapper (->* all-fields poly-base))))
null)))
(for ([b (cons constructor-binding bindings)])
(for ([b (append constructor-bindings bindings)])
(register-type (binding-name b) (def-binding-ty b)))
(append
@ -238,6 +249,7 @@
(define (tc/struct vars nm/par fld-names tys
#:proc-ty [proc-ty #f]
#:maker [maker #f]
#:extra-maker [extra-maker #f]
#:mutable [mutable #f]
#:type-only [type-only #f]
#:prefab? [prefab? #f])
@ -265,7 +277,7 @@
;; create the actual structure type, and the types of the fields
;; that the outside world will see
;; then register it
(define names (get-struct-names nm fld-names maker))
(define names (get-struct-names nm fld-names maker extra-maker))
(cond [prefab?
(define-values (parent-key parent-fields)
@ -310,7 +322,7 @@
(and parent (resolve-name (make-Name parent 0 #t))))
(define parent-tys (map fld-t (get-flds parent-type)))
(define names (get-struct-names nm fld-names #f))
(define names (get-struct-names nm fld-names #f #f))
(define desc (struct-desc parent-tys tys null #t #f))
(define sty (mk/inner-struct-type names desc parent-type))

1
typed-racket-lib/typed-racket/typecheck/tc-toplevel.rkt
View File

@ -39,6 +39,7 @@
(tc/struct (attribute t.tvars) #'t.nm (syntax->list #'(t.fields ...)) (syntax->list #'(t.types ...))
#:mutable (attribute t.mutable)
#:maker (attribute t.maker)
#:extra-maker (attribute t.extra-maker)
#:type-only (attribute t.type-only)
#:prefab? (attribute t.prefab))]
[t:typed-struct/exec

4
typed-racket-lib/typed-racket/typecheck/toplevel-trampoline.rkt
View File

@ -43,7 +43,8 @@
(types utils abbrev printer generalize)
(typecheck tc-toplevel tc-app-helper)
(private type-contract syntax-properties)
(utils disarm lift utils timing tc-utils arm)))
(env mvar-env)
(utils disarm lift utils timing tc-utils arm mutated-vars)))
(provide tc-toplevel-trampoline
tc-toplevel-trampoline/report)
@ -85,6 +86,7 @@
(define fully-expanded
;; a non-begin form can still cause lifts, so still have to catch them
(disarm* (local-expand/capture* #'e 'top-level (list #'module*))))
(find-mutated-vars fully-expanded mvar-env)
;; Unlike the `begin` cases, we probably don't need to trampoline back
;; to the top-level because we're not catching lifts from macros at the
;; top-level context but instead from expression context.

2
typed-racket-lib/typed-racket/types/printer.rkt
View File

@ -440,7 +440,7 @@
[(Base: n cnt _ _) n]
[(Opaque: pred) `(Opaque ,(syntax->datum pred))]
[(Struct: nm par (list (fld: t _ _) ...) proc _ _)
`#(,(string->symbol (format "struct:~a" nm))
`#(,(string->symbol (format "struct:~a" (syntax-e nm)))
,(map t->s t)
,@(if proc (list (t->s proc)) null))]
[(Function: arities)

4
typed-racket-lib/typed-racket/utils/tc-utils.rkt
View File

@ -5,7 +5,7 @@ This file is for utilities that are only useful for Typed Racket, but
don't depend on any other portion of the system
|#
(require syntax/source-syntax "disappeared-use.rkt"
(require syntax/source-syntax "disappeared-use.rkt" racket/list
racket/promise racket/string racket/lazy-require
syntax/parse/pre (for-syntax racket/base syntax/parse/pre))
@ -121,7 +121,7 @@ don't depend on any other portion of the system
(raise-typecheck-error (err-msg f) (err-stx f))))
(define (report-all-errors)
(define l (reverse delayed-errors))
(define l (remove-duplicates (reverse delayed-errors)))
(cond [(null? l) (void)]
;; if there's only one, we don't need multiple-error handling
[(null? (cdr l))

8
typed-racket-test/fail/struct-extra-constructor.rkt Normal file
View File

@ -0,0 +1,8 @@
#;
(exn-pred "define-struct: expected typed structure type options")
#lang typed/racket/base
(define-struct foo ()
;; can't have both of these
#:constructor-name foo-cn
#:extra-constructor-name foo-ecn)

8
typed-racket-test/main.rkt
View File

@ -1,10 +1,10 @@
#lang racket/base
(require rackunit rackunit/text-ui racket/file
mzlib/etc racket/port
racket/port
compiler/compiler setup/setup racket/promise
racket/match syntax/modcode
racket/promise
racket/promise racket/runtime-path
"unit-tests/all-tests.rkt"
"unit-tests/test-utils.rkt"
"optimizer/run.rkt"
@ -43,9 +43,11 @@
[_
(exn-matches ".*Type Checker.*" exn:fail:syntax?)])))
(define-runtime-path src-dir ".")
(define (mk-tests dir test #:error [error? #f])
(lambda ()
(define path (build-path (this-expression-source-directory) dir))
(define path (build-path src-dir dir))
(define prms
(for/list ([p (directory-list path)]
#:when (scheme-file? p)

5
typed-racket-test/optimizer/known-bugs.rkt
View File

@ -95,7 +95,10 @@
(good-opt (- 0+0i 0.0+0.0i))
;; Conjugate should correctly compute sign of 0.0
(good-opt (conjugate 0.0+0.0i))))
(good-opt (conjugate 0.0+0.0i))
;; Magnitude should always return positive results
(good-opt (magnitude -1.0-2i))))
(module+ main
(require rackunit/text-ui)

15
typed-racket-test/succeed/struct-options.rkt Normal file
View File

@ -0,0 +1,15 @@
#lang typed/racket/base
;; Tests for constructor options for struct
(struct s1 ([x : Integer]) #:constructor-name cons-s1)
(define-struct s2 ([x : Integer]) #:constructor-name cons-s2)
(struct s3 ([x : Integer]) #:extra-constructor-name cons-s3)
(define-struct s4 ([x : Integer]) #:extra-constructor-name cons-s4)
(cons-s1 1)
(cons-s2 2)
(s3 3)
(cons-s3 3)
(s4 4)
(cons-s4 4)

11
typed-racket-test/unit-tests/interactive-tests.rkt
View File

@ -116,6 +116,17 @@
;; PR 14380
(test-form-not-exn (begin - (void)))
;; bug that delayed 6.3
(test-form-exn #rx"Any"
(let ((x : Any 0))
(define (f) (set! x #t))
(when (number? x)
(add1 x))))
(test-form-not-exn
(let ((x 0))
(set! x 1)))
;; test message for undefined id
(test-form-exn #rx"either undefined or missing a type annotation"
(a-name-that-isnt-bound))

16
typed-racket-test/unit-tests/typecheck-tests.rkt
View File

@ -416,24 +416,24 @@
(tc-e (expt 0.5 2) (t:Un -NonNegFlonum -One))
(tc-e (expt 0.5 0) -One)
(tc-e (expt -1/2 -1/2) -Number)
(tc-e (expt (ann 0.5 Float) (ann 2 Integer)) -Number)
(tc-e (expt (ann 0.5f0 Single-Flonum) (ann 2 Integer)) -Number)
(tc-e (expt (ann 0.5 Float) (ann 2 Natural)) -Real)
(tc-e (expt (ann 0.5f0 Single-Flonum) (ann 2 Natural)) -Real)
(tc-e (expt (*) -0.0) (t:Un -NonNegFlonum -One))
(tc-e (expt (*) 2.4521075152139656e-300) (t:Un -NonNegFlonum -One))
(tc-e (expt (*) -0.0) (t:Un -NonNegFlonum -One))
(tc-e (expt -0.0 -1.0) (t:Un -Flonum -FloatComplex))
(tc-e (expt -0.0 -1.0) -NonNegFlonum)
(tc-e (expt 0 (flabs (cos (real->double-flonum 2))))
-Number)
-Real)
(tc-e (expt
(sub1 (gcd (exact-round 1)))
(- (ceiling (real->double-flonum -2.6897657f0))))
-Number)
-Real)
(tc-e (expt (sqrt (+)) (cosh (flcos (real->double-flonum 0))))
-Number)
-Real)
(tc-e (expt
(tan (real->double-flonum 6))
(lcm (*) (exact-round -1.7976931348623153e+308) 6))
-Number)
-Real)
(tc-e (exact->inexact (expt 10 (/ -120.0 20))) ; from rsound
-NonNegInexactReal)
(tc-e (flexpt 0.5 0.3) -NonNegFlonum)
@ -458,7 +458,7 @@
(tc-e (/ (round (exact-round -2.7393196f0)) (real->double-flonum (inexact->exact (real->single-flonum -0.0)))) -Real)
(tc-e (bitwise-and (exact-round 1.7976931348623157e+308) (exact-round -29)) -Int)
(tc-e (flexpt -0.0 -1.0) -Flonum)
(tc-e (expt -0.0f0 -3.0) (t:Un -InexactReal -InexactComplex))
(tc-e (expt -0.0f0 -3.0) -Real)
(tc-e (expt -8.665778974912815f+107 -677460115195106837726964554590085563061636191189747) -Number)
(tc-e (expt (sin +inf.f) +nan.0+nan.0i) -Number)
(tc-e (/ (gcd 1 0) -0.0f0 2.718281828459045) -Real)