Honu:

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

collects/honu/private/typechecker/typecheck-utils.ss

@@ -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))))
+
+  )

collects/honu/private/typechecker/typechecker.ss

@@ -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))
+         (check-valid-type! "function return type" type)
-             (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)
+         (for-each (curry check-valid-type! "function argument type")
-                     (if (not (type-valid? t))
-                         (raise-read-error-with-stx
-                          "Type of function argument is undefined"
-                          (honu:ast-stx 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)
+                   (if (not (and (not n)
-                                      (honu:type-top? t)))
+                                 (honu:type-top? t)))
-                            (not (type-valid? t)))
+                       (check-valid-type! "top-level bound variable type" t)))
-                       (raise-read-error-with-stx
-                        "Type of top-level bound variable is undefined"
-                        (honu:ast-stx 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)
+       (for-each (curry check-valid-type! "interface supertype")
-                   (if (not (type-valid? t))
-                       (raise-read-error-with-stx
-                        "No definition for supertype"
-                        (honu:ast-stx t))))
                  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))
+       (check-valid-type! "class self-type" type)
-           (raise-read-error-with-stx
+       (for-each (curry check-valid-type! "implemented type of class")
-            "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))))
                  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)
+       (for-each (curry check-valid-type! "init slot type")
-                   (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))
        (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))
+       (check-valid-type! "mixin argument type" arg-type)
-           (raise-read-error-with-stx
+       (check-valid-type! "mixin result type" type)
-            "Argument type of mixin is undefined"
+       (for-each (curry check-valid-type! "mixin implemented type")
-            (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))))
                  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)
+       (for-each (curry check-valid-type! "init slot type")
-                   (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))
        (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)
+       (for-each (curry check-valid-type! "type of expected init slot")
-                   (if (not (type-valid? t))
-                       (raise-read-error-with-stx
-                        "Type of expected init slot is undefined"
-                        (honu:ast-stx type))))
                  (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))
+       (check-valid-type! "field type" type)]
-           (raise-read-error-with-stx
-            "Type of field is undefined"
-            stx))]
       [(struct honu:method-decl (stx name type args))
-       (if (not (type-valid? type))
+       (check-valid-type! "method return type" type)
-           (raise-read-error-with-stx
+       (for-each (curry check-valid-type! "method argument type")
-            "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))))
                  args)]))
 
   )

collects/honu/utils.ss

@@ -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))))
+  
   )