Compare commits
No commits in common. "81c80320914d09d8f72c56237a758c49c3da1ff7" and "647ea457332b4e5e7fb3d42b0fc9e5aa94c1fe7c" have entirely different histories.
81c8032091
...
647ea45733
@ -20,7 +20,8 @@
|
||||
[let1E (var : Symbol) (te : TypeExp) (value : Exp) (body : Exp)]
|
||||
[recE (var : Symbol) (te : TypeExp) (value : Exp) (body : Exp)]
|
||||
[objE (fields : (Listof (Symbol * Exp)))]
|
||||
[msgE (obj : Exp) (selector : Symbol)])
|
||||
[msgE (obj : Exp) (selector : Symbol)]
|
||||
)
|
||||
|
||||
(define-type Type
|
||||
[numT]
|
||||
@ -61,35 +62,7 @@
|
||||
(objT (hash (list (pair 'add1 (arrowT (numT) (numT)))
|
||||
(pair 'compare (arrowT (numT) (boolT))))))))
|
||||
|
||||
(define (subtype? X Y)
|
||||
(type-case Type X
|
||||
[(numT) (type-case Type Y
|
||||
[(numT) #t]
|
||||
[else #f])]
|
||||
[(boolT) (type-case Type Y
|
||||
[(boolT) #t]
|
||||
[else #f])]
|
||||
[(arrowT X-arg X-result)
|
||||
(type-case Type Y
|
||||
[(arrowT Y-arg Y-result)
|
||||
(and (subtype? Y-arg X-arg) ;; Contravariance of arguments
|
||||
(subtype? X-result Y-result))] ;; Covariance of results
|
||||
[else #f])]
|
||||
[(objT X-fields)
|
||||
(type-case Type Y
|
||||
[(objT Y-fields)
|
||||
(local [(define (loop keys)
|
||||
(if (empty? keys)
|
||||
#t
|
||||
(let ([key (first keys)])
|
||||
(let ([Y-type (some-v (hash-ref Y-fields key))])
|
||||
(type-case (Optionof Type) (hash-ref X-fields key)
|
||||
[(none) #f] ;; Key not found in X-fields
|
||||
[(some X-type)
|
||||
(and (subtype? X-type Y-type) ;; Check subtyping of field types
|
||||
(loop (rest keys)))])))))] ;; Recurse on remaining keys
|
||||
(loop (hash-keys Y-fields)))]
|
||||
[else #f])]))
|
||||
(define (subtype? X Y) ....)
|
||||
|
||||
(module+ test
|
||||
(define hello-t (objT (hash (list (pair 'hello (numT))))))
|
||||
@ -112,6 +85,7 @@
|
||||
type
|
||||
(error 'typecheck "expected 2 num"))))]
|
||||
(type-case Exp exp
|
||||
|
||||
[(numE n) (numT)]
|
||||
[(boolE b) (boolT)]
|
||||
[(plusE l r) (num2 l r (numT))]
|
||||
@ -127,7 +101,7 @@
|
||||
(type-case Type (typecheck fn env)
|
||||
[(arrowT arg-type result-type)
|
||||
(let ([actual-type (typecheck arg env)])
|
||||
(if (subtype? actual-type arg-type) ;; Use subtype? to check compatibility
|
||||
(if (equal? arg-type actual-type)
|
||||
result-type
|
||||
(error 'typecheck "argument type")))]
|
||||
[else (error 'typecheck "not function")])]
|
||||
@ -153,29 +127,31 @@
|
||||
(if (equal? var-t val-t)
|
||||
body-t
|
||||
(error 'typecheck "type does not match annotation")))]
|
||||
[(objE fields)
|
||||
(let*
|
||||
([extract-exp (lambda (obj) (pair (fst obj) (typecheck (snd obj) env)))]
|
||||
[(objE fields) (let* ([extract-exp (lambda (obj) (pair (fst obj) (typecheck (snd obj) env)))]
|
||||
[field-list (map extract-exp fields)])
|
||||
(objT (hash field-list)))]
|
||||
[(msgE obj selector)
|
||||
(type-case Exp obj
|
||||
[(objE fields)
|
||||
(type-case (Optionof Exp) (hash-ref (make-hash fields) selector)
|
||||
(objT (make-hash field-list)))]
|
||||
[(msgE obj selector) (type-case Exp obj
|
||||
[(objE fields) (type-case (Optionof Exp) (hash-ref (make-hash fields) selector)
|
||||
[(none) (error 'typecheck "unknown field")]
|
||||
[(some v) (typecheck v env)])]
|
||||
[(varE name)
|
||||
(type-case Type (type-lookup name env)
|
||||
[(objT fields) (type-lookup selector fields)]
|
||||
[(varE name) (type-case Type (type-lookup name env)
|
||||
[(objT fields) (type-case (Optionof Type) (hash-ref fields selector)
|
||||
[(none) (error 'typecheck "dasdas")]
|
||||
[(some v) (type-case Type v
|
||||
[(arrowT a b) b]
|
||||
[else (error 'dasdas "dasdas")])])]
|
||||
[else (error 'typecheck "bound variable is not an object")])]
|
||||
[else (error 'typecheck "passing message to non-object")])])))
|
||||
|
||||
[else (error 'typecheck "passing message to non-object")])]
|
||||
)))
|
||||
|
||||
(define (parse-error sx)
|
||||
(error 'parse (string-append "parse error: " (to-string sx))))
|
||||
|
||||
(module+ test
|
||||
(test/exn (parse `"strings are not in our language") "parse")
|
||||
(test/exn (parse `{& 1 2}) "parse"))
|
||||
(test/exn (parse `{& 1 2}) "parse")
|
||||
)
|
||||
|
||||
(define (sx-ref sx n) (list-ref (s-exp->list sx) n))
|
||||
|
||||
@ -252,7 +228,9 @@
|
||||
(pair 'goodbye (numE 42)))))
|
||||
(test (parse `{lam {x : (obj (n-func (num -> num)))} x})
|
||||
(lamE 'x (objTE (list (pair 'n-func (arrowTE (numTE) (numTE)))))
|
||||
(varE 'x))))
|
||||
(varE 'x)))
|
||||
|
||||
)
|
||||
|
||||
|
||||
(tc : (S-Exp -> Type))
|
||||
@ -296,7 +274,9 @@
|
||||
{obj {run {lam {n : num}
|
||||
{if {<= n 0} 1 {* n {{msg fact run} {- n 1}}}}}}}
|
||||
{{msg fact run} 10}})
|
||||
(numT)))
|
||||
(numT))
|
||||
|
||||
)
|
||||
|
||||
(module+ test
|
||||
(test (tc `{,obj-fun {obj {n-func {lam {x : num} x}}
|
||||
@ -306,24 +286,3 @@
|
||||
,obj-fun
|
||||
{f ,sampler}})
|
||||
(numT)))
|
||||
|
||||
(module+ test
|
||||
(test (subtype? (arrowT hello-t hello-t)
|
||||
(arrowT hello-t hello-t)) #t)
|
||||
(test (subtype? (arrowT hello-t hello-t)
|
||||
(arrowT hello-t hello-goodbye-t)) #f)
|
||||
(test (subtype? (arrowT hello-t hello-goodbye-t)
|
||||
(arrowT hello-t hello-t)) #t)
|
||||
(test (subtype? (arrowT hello-t hello-goodbye-t)
|
||||
(arrowT hello-goodbye-t hello-t)) #t)
|
||||
(test (subtype? (arrowT hello-goodbye-t hello-goodbye-t)
|
||||
(arrowT hello-t hello-t)) #f)
|
||||
;; for coverage
|
||||
(define non-object-fun `{lam {x : num} {msg x hello}})
|
||||
;; `x` is bound to `numT`, which is not an object type
|
||||
(test/exn (tc non-object-fun) "bound variable is not an object")
|
||||
(test (subtype? hello-t (boolT)) #f)
|
||||
(test (subtype? (boolT) (boolT)) #t)
|
||||
(test (subtype? (boolT) (numT)) #f)
|
||||
(test (subtype? (arrowT (numT) (numT)) (numT)) #f)
|
||||
(test (subtype? (numT) (arrowT (numT) (numT))) #f))
|
||||
Loading…
x
Reference in New Issue
Block a user