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

Honu:

Browse Source 
tenv.ss
- Moved provides to end of file
typecheck-utils.ss
- Added check-valid-types!
typechecker.ss
- Used check-valid-types!
- Added helpers for mixin name checking

svn: r1837
This commit is contained in:
Carl Eastlund 2006-01-15 22:05:40 +00:00
parent 029beb046a
commit 48a8dac067
3 changed files with 86 additions and 67 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
collects/honu/private/typechecker/typecheck-utils.ss
View File

@ -9,6 +9,7 @@
(provide/contract
[check-valid-type! (string? honu:type? . -> . void?)]
[check-valid-types! (string? (listof honu:type?) . -> . void?)]
)
;; check-valid-type! : Name Type -> Void
@ -19,4 +20,9 @@
(format "~s is undefined" name)
(honu:ast-stx type))))
;; check-valid-types! : Name [Listof Type] -> Void
;; Raises an error if any of the named types are not valid.
(define (check-valid-types! name types)
(for-each (curry check-valid-type! name) types))
)

64
collects/honu/private/typechecker/typechecker.ss
View File

@ -43,8 +43,7 @@
(format "Argument name ~a used more than once"
(printable-key conflicting-name))
conflicting-name)))
(for-each (curry check-valid-type! "function argument type")
(map honu:formal-type args))
(check-valid-types! "function argument type" (map honu:formal-type args))
(make-func-type stx (make-tuple-type stx (map honu:formal-type args)) type)]))
;; first we add the functions to the lexical environment so that when we typecheck
;; the bodies, they'll be in scope.
@ -97,8 +96,7 @@
(define (typecheck-iface iface)
(match iface
[(struct honu:iface (stx name supers members))
(for-each (curry check-valid-type! "interface supertype")
supers)
(check-valid-types! "interface supertype" supers)
(let ([conflicting-name (get-first-non-unique-name (map (lambda (d)
(cond
[(honu:field-decl? d)
@ -122,8 +120,7 @@
(match class
[(struct honu:class (stx name type final? impls inits members exports))
(check-valid-type! "class self-type" type)
(for-each (curry check-valid-type! "implemented type of class")
impls)
(check-valid-types! "implemented type of class" impls)
(let ([conflicting-name (get-first-non-unique-name (append (map honu:formal-name inits)
(map (lambda (d)
(cond
@ -139,8 +136,7 @@
(format "Init/field/method name ~a used more than once"
(printable-key conflicting-name))
conflicting-name)))
(for-each (curry check-valid-type! "init slot type")
(map honu:formal-type inits))
(check-valid-types! "init slot type" (map honu:formal-type inits))
(let ([cenv (srfi1:fold (lambda (a e)
(extend-fenv (honu:formal-name a)
(honu:formal-type a)
@ -153,16 +149,12 @@
(copy-struct honu:class class
[honu:class-members members])))]))
;; typecheck-mixin : Mixin -> Mixin
;; Typechecks a mixin definition and produces the annotated version.
(define (typecheck-mixin mixin)
;; check-mixin-internal-names! : Mixin -> Void
;; Raises an error if defined names in a mixin conflict with each other.
(define (check-mixin-internal-names! mixin)
(match mixin
[(struct honu:mixin (stx name type arg-type final? impls inits withs
supernew members-before members-after exports))
(check-valid-type! "mixin argument type" arg-type)
(check-valid-type! "mixin result type" type)
(for-each (curry check-valid-type! "mixin implemented type")
impls)
(let* ([arg-tentry (get-type-entry arg-type)]
[conflicting-name (get-first-non-unique-name (append (map tenv:member-name
(append (tenv:type-members arg-tentry)
@ -182,23 +174,40 @@
(raise-read-error-with-stx
(format "Init/field/method name ~a used more than once in mixin or conflicts with members of argument type"
(printable-key conflicting-name))
(honu:ast-stx mixin))))
(for-each (curry check-valid-type! "init slot type")
(map honu:formal-type inits))
(honu:ast-stx mixin))))]))
;; check-mixin-expected-init-names! : Mixin -> Void
;; Raises an error if init arguments expected of mixin's argument contain conflicts
(define (check-mixin-expected-init-names! mixin)
(match mixin
[(struct honu:mixin (stx name type arg-type final? impls inits withs
supernew members-before members-after exports))
(let ([conflicting-name (get-first-non-unique-name (map honu:formal-name withs))])
(if conflicting-name
(raise-read-error-with-stx
(format "Init name ~a used more than once in expected init slots"
(printable-key conflicting-name))
conflicting-name)))
(for-each (curry check-valid-type! "type of expected init slot")
(map honu:formal-type withs))
conflicting-name)))]))
;; typecheck-mixin : Mixin -> Mixin
;; Typechecks a mixin definition and produces the annotated version.
(define (typecheck-mixin mixin)
(match mixin
[(struct honu:mixin (stx name type arg-type final? impls inits withs
supernew members-before members-after exports))
(check-valid-type! "mixin argument type" arg-type)
(check-valid-type! "mixin result type" type)
(check-valid-types! "mixin implemented type" impls)
(check-mixin-internal-names! mixin)
(check-valid-types! "init slot type" (map honu:formal-type inits))
(check-mixin-expected-init-names! mixin)
(check-valid-types! "type of expected init slot" (map honu:formal-type withs))
(let ([cenv (srfi1:fold (lambda (a e)
(extend-fenv (honu:formal-name a)
(honu:formal-type a)
e))
(lambda (n) #f)
inits)])
(extend-fenv (honu:formal-name a)
(honu:formal-type a)
e))
empty-fenv
inits)])
(let*-values ([(lenv) (extend-fenv #'this type (wrap-lenv))]
[(members-before cenv) (typecheck-members cenv lenv type members-before)]
[(supernew) (typecheck-supernew cenv lenv withs supernew)]
@ -238,7 +247,6 @@
(check-valid-type! "field type" type)]
[(struct honu:method-decl (stx name type args))
(check-valid-type! "method return type" type)
(for-each (curry check-valid-type! "method argument type")
args)]))
(check-valid-types! "method argument type" args)]))
)

83
collects/honu/tenv.ss
View File

@ -7,15 +7,6 @@
"parameters.ss"
"readerr.ss")
(provide (struct tenv:entry (stx))
(struct tenv:init (name type optional?))
(struct tenv:member (stx name type))
(struct tenv:type (supers members inherited))
(struct tenv:class (sub-type impls inits final? super))
(struct tenv:mixin (arg-type sub-type impls inits
withs final?))
(struct tenv:value (type)))
(define-struct tenv:entry (stx) #f)
(define-struct tenv:init (name type optional?) #f)
@ -81,20 +72,8 @@
(make-honu:type-prim #f 'float)))
))
(provide tenv?)
(define tenv? bound-identifier-mapping?)
(provide/contract [printable-key (identifier? . -> . symbol?)]
[tenv-key=? (identifier? identifier? . -> . any)]
[tenv-key<? (identifier? identifier? . -> . any)]
[tenv-map (tenv?
(identifier? tenv:entry? . -> . any)
. -> .
list?)]
[tenv-for-each (tenv?
(identifier? tenv:entry? . -> . void?)
. -> .
void?)])
(define printable-key syntax-e)
(define tenv-key=? bound-identifier=?)
(define (tenv-key<? k1 k2)
@ -103,12 +82,6 @@
(define tenv-map bound-identifier-mapping-map)
(define tenv-for-each bound-identifier-mapping-for-each)
(provide/contract [empty-tenv (-> tenv?)]
[get-builtin-lenv (-> tenv?)]
[extend-tenv (identifier? tenv:entry? . -> . void?)]
[extend-lenv (identifier? tenv:value? . -> . void?)]
[extend-tenv-without-checking (identifier? tenv:entry? . -> . void?)])
(define (empty-tenv) (make-bound-identifier-mapping))
(define (get-builtin-lenv)
(create-tenv (map car builtin-list)
@ -142,21 +115,11 @@
table)))
;; only use this if you a) don't want an error or b) don't know what you should get.
(provide/contract [get-tenv-entry (identifier? . -> . (union tenv:entry? false/c))]
[get-lenv-entry (identifier? . -> . (union tenv:entry? false/c))])
(define (get-tenv-entry key)
(bound-identifier-mapping-get (current-type-environment) key (lambda () #f)))
(define (get-lenv-entry key)
(bound-identifier-mapping-get (current-lexical-environment) key (lambda () #f)))
(provide/contract [get-type-entry ((union honu:type-iface?
honu:type-iface-top?) . -> . tenv:type?)]
[get-class-entry (identifier? . -> . tenv:class?)]
[get-mixin-entry (identifier? . -> . tenv:mixin?)]
[get-member-type ((union honu:type-iface?
honu:type-iface-top?)
identifier? . -> . honu:type?)]
[get-value-entry (identifier? . -> . tenv:value?)])
(define (get-type-entry type)
(if (honu:type-iface-top? type)
(make-tenv:type #f (list) (list) (list))
@ -224,8 +187,7 @@
name)]
[else entry])))
(provide wrap-lenv extend-fenv)
(define (fenv? v) (and (procedure? v) (procedure-arity-includes? v 1)))
(define (wrap-lenv) (wrap-as-function (current-lexical-environment)))
(define (wrap-as-function tenv)
(lambda (name)
@ -238,4 +200,47 @@
value
(fenv name))))
(define empty-fenv (lambda (name) #f))
(provide (struct tenv:entry (stx))
(struct tenv:init (name type optional?))
(struct tenv:member (stx name type))
(struct tenv:type (supers members inherited))
(struct tenv:class (sub-type impls inits final? super))
(struct tenv:mixin (arg-type sub-type impls inits
withs final?))
(struct tenv:value (type)))
(provide/contract [tenv? (any/c . -> . boolean?)]
[printable-key (identifier? . -> . symbol?)]
[tenv-key=? (identifier? identifier? . -> . any)]
[tenv-key<? (identifier? identifier? . -> . any)]
[tenv-map (tenv?
(identifier? tenv:entry? . -> . any)
. -> .
list?)]
[tenv-for-each (tenv?
(identifier? tenv:entry? . -> . void?)
. -> .
void?)]
[empty-tenv (-> tenv?)]
[get-builtin-lenv (-> tenv?)]
[extend-tenv (identifier? tenv:entry? . -> . void?)]
[extend-lenv (identifier? tenv:value? . -> . void?)]
[extend-tenv-without-checking (identifier? tenv:entry? . -> . void?)]
[get-tenv-entry (identifier? . -> . (union tenv:entry? false/c))]
[get-lenv-entry (identifier? . -> . (union tenv:entry? false/c))]
[get-type-entry ((union honu:type-iface?
honu:type-iface-top?) . -> . tenv:type?)]
[get-class-entry (identifier? . -> . tenv:class?)]
[get-mixin-entry (identifier? . -> . tenv:mixin?)]
[get-member-type ((union honu:type-iface?
honu:type-iface-top?)
identifier? . -> . honu:type?)]
[get-value-entry (identifier? . -> . tenv:value?)]
[fenv? (any/c . -> . boolean?)]
[wrap-lenv (-> fenv?)]
[empty-fenv fenv?]
[extend-fenv (identifier? honu:type? fenv? . -> . fenv?)]
)
)