From db07756a7393468cede9b2ee304d9b5eb3b1403b Mon Sep 17 00:00:00 2001
From: Stevie Strickland <sstrickl@racket-lang.org>
Date: Wed, 6 Jul 2005 03:07:18 +0000
Subject: [PATCH] merging 355:360 from branches/sstrickl

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
---
 .../private/compiler/translate-class-utils.ss | 36 ++++++++++-
 .../typechecker/typecheck-expression.ss       | 23 +++++++
 .../honu/private/typechecker/typechecker.ss   | 61 ++++++++++++++++++-
 collects/honu/utils.ss                        | 16 +++++
 4 files changed, 134 insertions(+), 2 deletions(-)

diff --git a/collects/honu/private/compiler/translate-class-utils.ss b/collects/honu/private/compiler/translate-class-utils.ss
index 316f0db2f6..cdaa3f66c5 100644
--- a/collects/honu/private/compiler/translate-class-utils.ss
+++ b/collects/honu/private/compiler/translate-class-utils.ss
@@ -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))
diff --git a/collects/honu/private/typechecker/typecheck-expression.ss b/collects/honu/private/typechecker/typecheck-expression.ss
index 13ca2d9e18..140c83c8cd 100644
--- a/collects/honu/private/typechecker/typecheck-expression.ss
+++ b/collects/honu/private/typechecker/typecheck-expression.ss
@@ -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)))
diff --git a/collects/honu/private/typechecker/typechecker.ss b/collects/honu/private/typechecker/typechecker.ss
index 096472e7c4..2a568ae752 100644
--- a/collects/honu/private/typechecker/typechecker.ss
+++ b/collects/honu/private/typechecker/typechecker.ss
@@ -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
diff --git a/collects/honu/utils.ss b/collects/honu/utils.ss
index 8c12f199da..c96945de2e 100644
--- a/collects/honu/utils.ss
+++ b/collects/honu/utils.ss
@@ -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)