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

merging 355:360 from branches/sstrickl

Browse Source 
Added basic uniqueness checks for type/class members, fun args, etc.  Also
added checks to make sure that all exports for the same type agree in what
they're exporting.

svn: r361
This commit is contained in:
Stevie Strickland 2005-07-06 03:07:18 +00:00
parent b752dcddef
commit db07756a73
4 changed files with 134 additions and 2 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

36
collects/honu/private/compiler/translate-class-utils.ss
View File

@ -1,8 +1,10 @@
(module translate-class-utils mzscheme
(require (lib "list.ss" "srfi" "1")
(only (lib "list.ss") quicksort)
(lib "plt-match.ss")
"../../ast.ss"
"../../readerr.ss"
"../../tenv.ss"
"../../utils.ss"
"../typechecker/type-utils.ss"
@ -81,7 +83,38 @@
(honu:exp-bind-new (car exp-binds))
(honu:type-disp? (tenv:member-type matched)))
comp-binds)))))))))
(define (sort-binds export)
(quicksort (comp:export-binds export)
(lambda (b1 b2)
(tenv-key<? (comp:exp-bind-new b1)
(comp:exp-bind-new b2)))))
(define (check-exports exports)
(let* ([main-export (car exports)]
[main-export-binds (sort-binds main-export)])
(let loop ([exports (cdr exports)])
(if (null? exports)
(void)
(let loop2 ([binds-1 main-export-binds]
[binds-2 (sort-binds (car exports))])
;; if one's empty, both must be since we passed the typechecker
(cond
[(null? binds-1)
(loop (cdr exports))]
[(tenv-key=? (comp:exp-bind-old (car binds-1))
(comp:exp-bind-old (car binds-2)))
(loop2 (cdr binds-1) (cdr binds-2))]
[else
(raise-read-error-with-stx
(format "Different local names exported for member ~a of type ~a: ~a here and ~a elsewhere"
(printable-type (comp:export-type main-export))
(printable-key (comp:exp-bind-new (car binds-1)))
(printable-key (comp:exp-bind-old (car binds-1)))
(printable-key (comp:exp-bind-old (car binds-2))))
(comp:exp-bind-old (car binds-1)))]))))))
(define (filter-exports exports)
(let loop ([exports exports]
[kept-exps '()])
@ -92,6 +125,7 @@
(comp:export-type (car exports))
(comp:export-type exp)))
exports)])
(check-exports matches)
(let ([exp-with-stx (find comp:export-stx (cons (car exports) matches))])
(if exp-with-stx
(loop non-matches (cons exp-with-stx kept-exps))

23
collects/honu/private/typechecker/typecheck-expression.ss
View File

@ -221,6 +221,22 @@
"Unknown operator"
op-stx)])]
[(struct honu:lambda (stx ret-type args body))
(if (not (type-valid? ret-type))
(raise-read-error-with-stx
"Return type of anonymous function is invalid"
(honu:ast-stx ret-type)))
(let ([conflicting-name (get-first-non-unique-name (map honu:formal-name args))])
(if conflicting-name
(raise-read-error-with-stx
(format "Variable name ~a used more than once in function arguments"
(printable-key conflicting-name))
conflicting-name)))
(for-each (lambda (t)
(if (not (type-valid? t))
(raise-read-error-with-stx
"Type of argument of anonymous function is invalid"
(honu:ast-stx t))))
(map honu:formal-type args))
;; since we have explicit return type annotations now, we use them for the body's ctype and rtype.
(let ([body-lenv (fold (lambda (f e)
(extend-fenv (honu:formal-name f)
@ -535,6 +551,13 @@
(define (typecheck-binding lenv binding)
(match binding
[(struct honu:binding (stx names types value))
;; make sure to remove all the #f for don't care arguments.
(let ([conflicting-name (get-first-non-unique-name (filter (lambda (n) n) names))])
(if conflicting-name
(raise-read-error-with-stx
(format "Variable name ~a used more than once in binding form"
(printable-key conflicting-name))
conflicting-name)))
(for-each (lambda (n t)
(if (and (not (and (not n)
(honu:type-top? t)))

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

@ -39,6 +39,12 @@
(raise-read-error-with-stx
"Return type of function is undefined"
(honu:ast-stx 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
@ -97,6 +103,18 @@
"No definition for supertype"
(honu:ast-stx t))))
supers)
(let ([conflicting-name (get-first-non-unique-name (map (lambda (d)
(cond
[(honu:field-decl? d)
(honu:field-decl-name d)]
[(honu:method-decl? d)
(honu:method-decl-name d)]))
members))])
(if conflicting-name
(raise-read-error-with-stx
(format "Field/method name ~a used more than once"
(printable-key conflicting-name))
conflicting-name)))
(for-each (lambda (m)
(typecheck-member-decl m))
members)
@ -112,6 +130,21 @@
"Implemented type is undefined"
(honu:ast-stx type))))
impls)
(let ([conflicting-name (get-first-non-unique-name (append (map honu:formal-name inits)
(map (lambda (d)
(cond
[(honu:init-field? d)
(honu:init-field-name d)]
[(honu:field? d)
(honu:field-name d)]
[(honu:method? d)
(honu:method-name d)]))
members)))])
(if conflicting-name
(raise-read-error-with-stx
(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
@ -145,12 +178,38 @@
"Implemented type is undefined"
(honu:ast-stx 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)
(tenv:type-inherited arg-tentry)))
(map honu:formal-name inits)
(map (lambda (d)
(cond
[(honu:init-field? d)
(honu:init-field-name d)]
[(honu:field? d)
(honu:field-name d)]
[(honu:method? d)
(honu:method-name d)]))
(append members-before
members-after))))])
(if conflicting-name
(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 defn))))
(for-each (lambda (t)
(if (not (type-valid? t))
(raise-read-error-with-stx
"Type of init slot is undefined"
(honu:ast-stx type))))
(map honu:formal-type inits))
(map honu:formal-type inits))
(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 (lambda (t)
(if (not (type-valid? t))
(raise-read-error-with-stx

16
collects/honu/utils.ss
View File

@ -1,6 +1,22 @@
(module utils mzscheme
(require "ast.ss")
(require (lib "list.ss" "srfi" "1"))
(require (only (lib "list.ss") quicksort))
(define (identifier<? a b)
(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
[(null? lst) #f]
[(null? (cdr lst)) #f]
[(bound-identifier=? (car lst) (cadr lst))
;; since quicksort isn't stable, just return the first
(car lst)]
[else #f])))
(provide fold-with-rest)
(define (fold-with-rest f init l)