Remove certifiers for Opaque and Refinement types

Syntax certifiers are now deprecated. This change
should have no effect on the types.
This commit is contained in:
Asumu Takikawa 2013-08-22 18:38:09 -04:00
parent a2b780abee
commit 0e02b7e368
10 changed files with 22 additions and 25 deletions

View File

@ -322,7 +322,7 @@ This file defines two sorts of primitives. All of them are provided into any mod
(pattern #:name-exists)) (pattern #:name-exists))
(syntax-parse stx (syntax-parse stx
[(_ ty:id pred:id lib (~optional ne:name-exists-kw) ...) [(_ ty:id pred:id lib (~optional ne:name-exists-kw) ...)
(register-type-name #'ty (make-Opaque #'pred (syntax-local-certifier))) (register-type-name #'ty (make-Opaque #'pred))
(with-syntax ([hidden (generate-temporary #'pred)]) (with-syntax ([hidden (generate-temporary #'pred)])
(quasisyntax/loc stx (quasisyntax/loc stx
(begin (begin

View File

@ -57,10 +57,9 @@
,(sub flds) ,(sub proc) ,(sub poly?) ,(sub flds) ,(sub proc) ,(sub poly?)
(quote-syntax ,pred-id))] (quote-syntax ,pred-id))]
[(App: rator rands stx) `(make-App ,(sub rator) ,(sub rands) (quote-syntax ,stx))] [(App: rator rands stx) `(make-App ,(sub rator) ,(sub rands) (quote-syntax ,stx))]
[(Opaque: pred cert) `(make-Opaque (quote-syntax ,pred) (syntax-local-certifier))] [(Opaque: pred) `(make-Opaque (quote-syntax ,pred))]
[(Refinement: parent pred cert) `(make-Refinement ,(sub parent) [(Refinement: parent pred) `(make-Refinement ,(sub parent)
(quote-syntax ,pred) (quote-syntax ,pred))]
(syntax-local-certifier))]
[(Mu-name: n b) `(make-Mu ,(sub n) ,(sub b))] [(Mu-name: n b) `(make-Mu ,(sub n) ,(sub b))]
[(Poly-names: ns b) `(make-Poly (list ,@(map sub ns)) ,(sub b))] [(Poly-names: ns b) `(make-Poly (list ,@(map sub ns)) ,(sub b))]
[(PolyDots-names: ns b) `(make-PolyDots (list ,@(map sub ns)) ,(sub b))] [(PolyDots-names: ns b) `(make-PolyDots (list ,@(map sub ns)) ,(sub b))]

View File

@ -415,7 +415,7 @@
(nevermind))] (nevermind))]
;; refinements are erased to their bound ;; refinements are erased to their bound
[((Refinement: S _ _) T) [((Refinement: S _) T)
(cg S T)] (cg S T)]
;; variables that are in X and should be constrained ;; variables that are in X and should be constrained

View File

@ -182,7 +182,7 @@
(add-disappeared-use #'kw) (add-disappeared-use #'kw)
(match (lookup-type/lexical #'p?) (match (lookup-type/lexical #'p?)
[(and t (Function: (list (arr: (list dom) _ #f #f '())))) [(and t (Function: (list (arr: (list dom) _ #f #f '()))))
(make-Refinement dom #'p? (syntax-local-certifier))] (make-Refinement dom #'p?)]
[t (tc-error "cannot declare refinement for non-predicate ~a" t)])] [t (tc-error "cannot declare refinement for non-predicate ~a" t)])]
[((~and kw t:Struct) t) [((~and kw t:Struct) t)
(add-disappeared-use #'kw) (add-disappeared-use #'kw)
@ -264,7 +264,7 @@
(parse-all-type stx)] (parse-all-type stx)]
[((~and kw t:Opaque) p?) [((~and kw t:Opaque) p?)
(add-disappeared-use #'kw) (add-disappeared-use #'kw)
(make-Opaque #'p? (syntax-local-certifier))] (make-Opaque #'p?)]
[((~and kw t:Parameter) t) [((~and kw t:Parameter) t)
(let ([ty (parse-type #'t)]) (let ([ty (parse-type #'t)])
(add-disappeared-use #'kw) (add-disappeared-use #'kw)

View File

@ -338,8 +338,8 @@
[(== t:-Number type-equal?) #'(flat-named-contract 'Number number?)] [(== t:-Number type-equal?) #'(flat-named-contract 'Number number?)]
[(Base: sym cnt _ _ _) #`(flat-named-contract '#,sym (flat-contract-predicate #,cnt))] [(Base: sym cnt _ _ _) #`(flat-named-contract '#,sym (flat-contract-predicate #,cnt))]
[(Refinement: par p? cert) [(Refinement: par p?)
#`(and/c #,(t->c par) (flat-contract #,(cert p?)))] #`(and/c #,(t->c par) (flat-contract #,p?))]
[(Union: elems) [(Union: elems)
(let-values ([(vars notvars) (partition F? elems)]) (let-values ([(vars notvars) (partition F? elems)])
(unless (>= 1 (length vars)) (exit (fail))) (unless (>= 1 (length vars)) (exit (fail)))
@ -364,8 +364,8 @@
[(Promise: t) [(Promise: t)
(set-chaperone!) (set-chaperone!)
#`(promise/c #,(t->c t))] #`(promise/c #,(t->c t))]
[(Opaque: p? cert) [(Opaque: p?)
#`(flat-named-contract (quote #,(syntax-e p?)) #,(cert p?))] #`(flat-named-contract (quote #,(syntax-e p?)) #,p?)]
[(Continuation-Mark-Keyof: t) [(Continuation-Mark-Keyof: t)
(set-chaperone!) (set-chaperone!)
#`(continuation-mark-key/c #,(t->c/both t))] #`(continuation-mark-key/c #,(t->c/both t))]

View File

@ -237,8 +237,7 @@
(*PolyDots n (add-scopes n (type-rec-id body*))))]) (*PolyDots n (add-scopes n (type-rec-id body*))))])
;; pred : identifier ;; pred : identifier
;; cert : syntax certifier (def-type Opaque ([pred identifier?])
(def-type Opaque ([pred identifier?] [cert procedure?])
[#:intern (hash-id pred)] [#:frees #f] [#:fold-rhs #:base] [#:key pred]) [#:intern (hash-id pred)] [#:frees #f] [#:fold-rhs #:base] [#:key pred])
;; kw : keyword? ;; kw : keyword?
@ -336,7 +335,6 @@
;; poly? : is this type polymorphicly variant ;; poly? : is this type polymorphicly variant
;; If not, then the predicate is enough for higher order checks ;; If not, then the predicate is enough for higher order checks
;; pred-id : identifier for the predicate of the struct ;; pred-id : identifier for the predicate of the struct
;; cert : syntax certifier for pred-id
;; acc-ids : names of the accessors ;; acc-ids : names of the accessors
;; maker-id : name of the constructor ;; maker-id : name of the constructor
(def-type Struct ([name identifier?] (def-type Struct ([name identifier?]
@ -418,10 +416,10 @@
(def-type Hashtable ([key Type/c] [value Type/c]) [#:key 'hash] (def-type Hashtable ([key Type/c] [value Type/c]) [#:key 'hash]
[#:frees (λ (f) (combine-frees (list (make-invariant (f key)) (make-invariant (f value)))))]) [#:frees (λ (f) (combine-frees (list (make-invariant (f key)) (make-invariant (f value)))))])
(def-type Refinement ([parent Type/c] [pred identifier?] [cert procedure?]) (def-type Refinement ([parent Type/c] [pred identifier?])
[#:key (Type-key parent)] [#:key (Type-key parent)]
[#:intern (list (Rep-seq parent) (hash-id pred))] [#:intern (list (Rep-seq parent) (hash-id pred))]
[#:fold-rhs (*Refinement (type-rec-id parent) pred cert)] [#:fold-rhs (*Refinement (type-rec-id parent) pred)]
[#:frees (λ (f) (f parent))]) [#:frees (λ (f) (f parent))])

View File

@ -118,7 +118,7 @@
[(and t (Function: (list (arr: (list dom) (Values: (list (Result: rng _ _))) #f #f '())))) [(and t (Function: (list (arr: (list dom) (Values: (list (Result: rng _ _))) #f #f '()))))
(let ([new-t (make-pred-ty (list dom) (let ([new-t (make-pred-ty (list dom)
rng rng
(make-Refinement dom #'pred (syntax-local-certifier)))]) (make-Refinement dom #'pred))])
(register-type #'pred new-t)) (register-type #'pred new-t))
(list)] (list)]
[t (tc-error "cannot declare refinement for non-predicate ~a" t)])] [t (tc-error "cannot declare refinement for non-predicate ~a" t)])]

View File

@ -299,7 +299,7 @@
[(? tuple? t) [(? tuple? t)
(fp "~a" (cons 'List (tuple-elems t)))] (fp "~a" (cons 'List (tuple-elems t)))]
[(Base: n cnt _ _ _) (fp "~s" n)] [(Base: n cnt _ _ _) (fp "~s" n)]
[(Opaque: pred _) (fp "(Opaque ~a)" (syntax->datum pred))] [(Opaque: pred) (fp "(Opaque ~a)" (syntax->datum pred))]
[(Struct: nm par (list (fld: t _ _) ...) proc _ _) [(Struct: nm par (list (fld: t _ _) ...) proc _ _)
(fp "#(struct:~a ~a" nm t) (fp "#(struct:~a ~a" nm t)
(when proc (when proc
@ -381,7 +381,7 @@
[(Result: t fs (Empty:)) (fp "(~a : ~a)" t fs)] [(Result: t fs (Empty:)) (fp "(~a : ~a)" t fs)]
[(Result: t fs lo) (fp "(~a : ~a : ~a)" t fs lo)] [(Result: t fs lo) (fp "(~a : ~a : ~a)" t fs lo)]
[(MPair: s t) (fp "(MPairof ~a ~a)" s t)] [(MPair: s t) (fp "(MPairof ~a ~a)" s t)]
[(Refinement: parent p? _) [(Refinement: parent p?)
(fp "(Refinement ~a ~a)" parent (syntax-e p?))] (fp "(Refinement ~a ~a)" parent (syntax-e p?))]
[(Sequence: ts) [(Sequence: ts)
(fp "(Sequenceof") (fp "(Sequenceof")

View File

@ -33,8 +33,8 @@
[(list _ (Univ:)) #t] [(list _ (Univ:)) #t]
[(list (F: _) _) #t] [(list (F: _) _) #t]
[(list _ (F: _)) #t] [(list _ (F: _)) #t]
[(list (Opaque: _ _) _) #t] [(list (Opaque: _) _) #t]
[(list _ (Opaque: _ _)) #t] [(list _ (Opaque: _)) #t]
[(list (Name: n) (Name: n*)) [(list (Name: n) (Name: n*))
(or (free-identifier=? n n*) (or (free-identifier=? n n*)
(overlap (resolve-once t1) (resolve-once t2)))] (overlap (resolve-once t1) (resolve-once t2)))]
@ -45,8 +45,8 @@
[(list (? Mu?) _) (overlap (unfold t1) t2)] [(list (? Mu?) _) (overlap (unfold t1) t2)]
[(list _ (? Mu?)) (overlap t1 (unfold t2))] [(list _ (? Mu?)) (overlap t1 (unfold t2))]
[(list (Refinement: t _ _) t2) (overlap t t2)] [(list (Refinement: t _) t2) (overlap t t2)]
[(list t1 (Refinement: t _ _)) (overlap t1 t)] [(list t1 (Refinement: t _)) (overlap t1 t)]
[(list (Union: e) t) [(list (Union: e) t)
(ormap (lambda (t*) (overlap t* t)) e)] (ormap (lambda (t*) (overlap t* t)) e)]

View File

@ -392,7 +392,7 @@
(hash-set (make-simple-substitution ns (map make-F (take ms (length ns)))) (hash-set (make-simple-substitution ns (map make-F (take ms (length ns))))
n-dotted (i-subst (map make-F (drop ms (length ns)))))) n-dotted (i-subst (map make-F (drop ms (length ns))))))
(subtype* A0 (subst-all subst b1) b2)] (subtype* A0 (subst-all subst b1) b2)]
[((Refinement: par _ _) t) [((Refinement: par _) t)
(subtype* A0 par t)] (subtype* A0 par t)]
;; use unification to see if we can use the polytype here ;; use unification to see if we can use the polytype here
[((Poly: vs b) s) [((Poly: vs b) s)