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

Honu:

Browse Source 
util.ss
- Added curry function
- Reorganized provide list
typecheck-utils.ss
- Added module of general typechecker helpers
typechecker.ss
- Made use of typecheck-utils.ss

svn: r1834
This commit is contained in:
Carl Eastlund 2006-01-15 18:53:00 +00:00
parent 3692afbc59
commit 10d276dd7b
3 changed files with 57 additions and 80 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

22
collects/honu/private/typechecker/typecheck-utils.ss Normal file
View File

@ -0,0 +1,22 @@
(module typecheck-utils mzscheme
(require (lib "contract.ss")
"../../ast.ss"
"../../utils.ss"
"../../readerr.ss"
"type-utils.ss"
)
(provide/contract
[check-valid-type! (string? honu:type? . -> . void?)]
)
;; check-valid-type! : Name Type -> Void
;; Raises an error if named type is not valid.
(define (check-valid-type! name type)
(if (not (type-valid? type))
(raise-read-error-with-stx
(format "~s is undefined" name)
(honu:ast-stx type))))
)

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

@ -8,6 +8,7 @@
"../../readerr.ss"
"../../tenv.ss"
"../../utils.ss"
"typecheck-utils.ss"
"typecheck-class-utils.ss"
"typecheck-expression.ss"
"typecheck-parameters.ss"
@ -35,21 +36,14 @@
(define (check-function-type func)
(match func
[(struct honu:function (stx name type args body))
(if (not (type-valid? type))
(raise-read-error-with-stx
"Return type of function is undefined"
(honu:ast-stx type)))
(check-valid-type! "function return type" type)
(let ([conflicting-name (get-first-non-unique-name (map honu:formal-name args))])
(if conflicting-name
(raise-read-error-with-stx
(format "Argument name ~a used more than once"
(printable-key conflicting-name))
conflicting-name)))
(for-each (lambda (t)
(if (not (type-valid? t))
(raise-read-error-with-stx
"Type of function argument is undefined"
(honu:ast-stx type))))
(for-each (curry check-valid-type! "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
@ -87,12 +81,9 @@
(match bind-top
[(struct honu:bind-top (stx names types value))
(for-each (lambda (n t)
(if (and (not (and (not n)
(honu:type-top? t)))
(not (type-valid? t)))
(raise-read-error-with-stx
"Type of top-level bound variable is undefined"
(honu:ast-stx t))))
(if (not (and (not n)
(honu:type-top? t)))
(check-valid-type! "top-level bound variable type" t)))
names types)
(let-values ([(e1 t1) (typecheck-expression (wrap-lenv) (make-tuple-type stx types) value)])
(for-each (lambda (n t)
@ -106,11 +97,7 @@
(define (typecheck-iface-defn iface)
(match iface
[(struct honu:iface (stx name supers members))
(for-each (lambda (t)
(if (not (type-valid? t))
(raise-read-error-with-stx
"No definition for supertype"
(honu:ast-stx t))))
(for-each (curry check-valid-type! "interface supertype")
supers)
(let ([conflicting-name (get-first-non-unique-name (map (lambda (d)
(cond
@ -134,15 +121,8 @@
(define (typecheck-class-defn class)
(match class
[(struct honu:class (stx name type final? impls inits members exports))
(if (not (type-valid? type))
(raise-read-error-with-stx
"Self-type of class is undefined"
(honu:ast-stx type)))
(for-each (lambda (t)
(if (not (type-valid? t))
(raise-read-error-with-stx
"Implemented type is undefined"
(honu:ast-stx type))))
(check-valid-type! "class self-type" type)
(for-each (curry check-valid-type! "implemented type of class")
impls)
(let ([conflicting-name (get-first-non-unique-name (append (map honu:formal-name inits)
(map (lambda (d)
@ -159,11 +139,7 @@
(format "Init/field/method name ~a used more than once"
(printable-key conflicting-name))
conflicting-name)))
(for-each (lambda (t)
(if (not (type-valid? t))
(raise-read-error-with-stx
"Type of init slot is undefined"
(honu:ast-stx type))))
(for-each (curry check-valid-type! "init slot type")
(map honu:formal-type inits))
(let ([cenv (srfi1:fold (lambda (a e)
(extend-fenv (honu:formal-name a)
@ -183,19 +159,9 @@
(match mixin
[(struct honu:mixin (stx name type arg-type final? impls inits withs
supernew members-before members-after exports))
(if (not (type-valid? arg-type))
(raise-read-error-with-stx
"Argument type of mixin is undefined"
(honu:ast-stx arg-type)))
(if (not (type-valid? type))
(raise-read-error-with-stx
"Result type of mixin is undefined"
(honu:ast-stx type)))
(for-each (lambda (t)
(if (not (type-valid? t))
(raise-read-error-with-stx
"Implemented type is undefined"
(honu:ast-stx type))))
(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
@ -217,11 +183,7 @@
(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 (lambda (t)
(if (not (type-valid? t))
(raise-read-error-with-stx
"Type of init slot is undefined"
(honu:ast-stx type))))
(for-each (curry check-valid-type! "init slot type")
(map honu:formal-type inits))
(let ([conflicting-name (get-first-non-unique-name (map honu:formal-name withs))])
(if conflicting-name
@ -229,11 +191,7 @@
(format "Init name ~a used more than once in expected init slots"
(printable-key conflicting-name))
conflicting-name)))
(for-each (lambda (t)
(if (not (type-valid? t))
(raise-read-error-with-stx
"Type of expected init slot is undefined"
(honu:ast-stx type))))
(for-each (curry check-valid-type! "type of expected init slot")
(map honu:formal-type withs))
(let ([cenv (srfi1:fold (lambda (a e)
(extend-fenv (honu:formal-name a)
@ -277,20 +235,10 @@
(define (typecheck-member-decl member)
(match member
[(struct honu:field-decl (stx name type))
(if (not (type-valid? type))
(raise-read-error-with-stx
"Type of field is undefined"
stx))]
(check-valid-type! "field type" type)]
[(struct honu:method-decl (stx name type args))
(if (not (type-valid? type))
(raise-read-error-with-stx
"Return type of method is undefined"
(honu:ast-stx type)))
(for-each (lambda (t)
(if (not (type-valid? t))
(raise-read-error-with-stx
"Type of method argument is undefined"
(honu:ast-stx type))))
(check-valid-type! "method return type" type)
(for-each (curry check-valid-type! "method argument type")
args)]))
)

27
collects/honu/utils.ss
View File

@ -6,7 +6,18 @@
(require-for-template (lib "contract.ss"))
(provide define/p)
(provide define-struct/c
define-struct/p
define/c
define/p
fold-with-rest
get-first-non-unique-name
map-and-fold
map-two-values
partition-first
unique?
curry)
(define-syntax (define/p stx)
(syntax-case stx ()
[(_ (NAME . ARGS) BODY ...)
@ -19,7 +30,6 @@
(provide NAME))]
))
(provide define/c)
(define-syntax (define/c stx)
(syntax-case stx ()
[(_ (NAME . ARGS) CONTRACT BODY ...)
@ -32,7 +42,6 @@
(provide/contract [NAME CONTRACT]))]
))
(provide define-struct/p)
(define-syntax (define-struct/p stx)
(syntax-case stx ()
[(_ (NAME SUPER) (FIELD ...) REST ...)
@ -44,7 +53,6 @@
(define-struct NAME (FIELD ...) REST ...)
(provide (struct NAME (FIELD ...))))]))
(provide define-struct/c)
(define-syntax (define-struct/c stx)
(syntax-case stx ()
[(_ (NAME SUPER) ([FIELD CONTRACT] ...) REST ...)
@ -73,7 +81,6 @@
(string<? (symbol->string (syntax-e a))
(symbol->string (syntax-e b))))
(provide get-first-non-unique-name)
(define (get-first-non-unique-name lst)
(let loop ([lst (quicksort lst identifier<?)])
(cond
@ -84,13 +91,11 @@
(car lst)]
[else #f])))
(provide fold-with-rest)
(define (fold-with-rest f init l)
(if (null? l)
init
(fold-with-rest f (f (car l) (cdr l) init) (cdr l))))
(provide unique?)
(define (unique? cs)
(fold-with-rest (lambda (c cs acc)
(and acc
@ -103,7 +108,6 @@
(f defn)))
ds))
(provide map-and-fold)
(define (map-and-fold f i l)
(let loop ((l l)
(mapped '())
@ -115,7 +119,6 @@
(cons res mapped)
folded)))))
(provide map-two-values)
(define (map-two-values f . lists)
(let loop ((lists lists)
(map1 '())
@ -127,7 +130,6 @@
(cons m1 map1)
(cons m2 map2))))))
(provide partition-first)
(define (partition-first f lis)
(let loop ([lis lis]
[passed '()])
@ -138,4 +140,9 @@
(values (car lis) (append (reverse passed) (cdr lis)))]
[else
(loop (cdr lis) (cons (car lis) passed))])))
(define (curry f . args)
(lambda rest
(apply f (append args rest))))
)