Fix name of Type/c
Fix fold on Result. Add comments. New -struct constructor with opt args. Fix tests to agree with contracts. svn: r13934 original commit: 9d0ee637c74b0d7705d7b9fc60ee0712cac6b0f9
This commit is contained in:
parent
0674606052
commit
eb77d9debc
|
@ -8,7 +8,7 @@
|
|||
(for-syntax scheme/base))
|
||||
|
||||
|
||||
(require (types comparison type-utils)
|
||||
(require (types comparison utils)
|
||||
(schemeunit))
|
||||
|
||||
(provide private typecheck (rename-out [infer r:infer]) utils env rep types)
|
||||
|
|
|
@ -2,12 +2,12 @@
|
|||
|
||||
(require "test-utils.ss" "planet-requires.ss" (for-syntax scheme/base))
|
||||
(require (rep type-rep)
|
||||
(types comparison type-abbrev)
|
||||
(types comparison abbrev union)
|
||||
(schemeunit))
|
||||
|
||||
(provide type-equal-tests)
|
||||
|
||||
(define (-base x) (make-Base x #f))
|
||||
(define (-base x) (make-Base x #'dummy))
|
||||
|
||||
|
||||
(define-syntax (te-tests stx)
|
||||
|
@ -37,14 +37,12 @@
|
|||
[(-mu x (Un N Sym x)) (-mu y (Un N Sym y))]
|
||||
;; found bug
|
||||
[FAIL (Un (-mu heap-node
|
||||
(-struct 'heap-node #f (list (-base 'comparator) N (-v a) (Un heap-node (-base 'heap-empty))) #f #f #f values))
|
||||
(-struct 'heap-node #f (list (-base 'comparator) N (-v a) (Un heap-node (-base 'heap-empty)))))
|
||||
(-base 'heap-empty))
|
||||
(Un (-mu heap-node
|
||||
(-struct 'heap-node #f (list (-base 'comparator) N (-pair N N) (Un heap-node (-base 'heap-empty))) #f #f #f values))
|
||||
(-struct 'heap-node #f (list (-base 'comparator) N (-pair N N) (Un heap-node (-base 'heap-empty)))))
|
||||
(-base 'heap-empty))]))
|
||||
|
||||
|
||||
|
||||
(define-go
|
||||
type-equal-tests)
|
||||
|
||||
|
|
|
@ -12,7 +12,7 @@
|
|||
|
||||
(define Type/c
|
||||
(flat-named-contract
|
||||
"Type"
|
||||
'Type
|
||||
(λ (e)
|
||||
(and (Type? e)
|
||||
(not (Scope? e))
|
||||
|
@ -129,7 +129,7 @@
|
|||
|
||||
(dt Result ([t Type/c] [f LFilterSet?] [o LatentObject?])
|
||||
[#:frees (λ (frees) (combine-frees (map frees (list t f o))))]
|
||||
[#:fold-rhs (*Result (type-rec-id t) (latentfilter-rec-id f) (latentobject-rec-id f))])
|
||||
[#:fold-rhs (*Result (type-rec-id t) (latentfilter-rec-id f) (latentobject-rec-id o))])
|
||||
|
||||
;; types : Listof[Type]
|
||||
(dt Values ([rs (listof Result?)])
|
||||
|
|
|
@ -19,7 +19,6 @@
|
|||
|
||||
(define -values make-Values)
|
||||
(define -pair make-Pair)
|
||||
(define -struct make-Struct)
|
||||
(define -val make-Value)
|
||||
(define -Param make-Param)
|
||||
(define -box make-Box)
|
||||
|
@ -211,6 +210,9 @@
|
|||
(define (make-arr-dots dom rng dty dbound)
|
||||
(make-arr* dom rng #:drest (cons dty dbound)))
|
||||
|
||||
(define (-struct name parent flds [proc #f] [poly #f] [pred #'dummy] [cert values])
|
||||
(make-Struct name parent flds proc poly pred cert))
|
||||
|
||||
|
||||
(define make-pred-ty
|
||||
(case-lambda
|
||||
|
|
|
@ -1,4 +1,10 @@
|
|||
#lang scheme/base
|
||||
|
||||
#|
|
||||
This file is for utilities that are only useful for Typed Scheme, but
|
||||
don't depend on any other portion of the system
|
||||
|#
|
||||
|
||||
(provide (all-defined-out))
|
||||
(require "syntax-traversal.ss" (for-syntax scheme/base stxclass) scheme/match)
|
||||
|
||||
|
|
|
@ -1,5 +1,10 @@
|
|||
#lang scheme/base
|
||||
|
||||
#|
|
||||
This file is for utilities that are of general interest,
|
||||
at least theoretically.
|
||||
|#
|
||||
|
||||
(require (for-syntax scheme/base stxclass)
|
||||
scheme/contract mzlib/plt-match scheme/require-syntax scheme/provide-syntax
|
||||
mzlib/struct scheme/unit
|
||||
|
@ -15,9 +20,7 @@
|
|||
in-list-forever
|
||||
extend
|
||||
debug
|
||||
in-syntax
|
||||
;; require macros
|
||||
rep utils typecheck infer env private types)
|
||||
in-syntax)
|
||||
|
||||
(define-syntax (define-requirer stx)
|
||||
(syntax-parse stx
|
||||
|
|
Loading…
Reference in New Issue
Block a user