From 10d276dd7b62c7cfd3bbc8107d31b0bf016de9ac Mon Sep 17 00:00:00 2001 From: Carl Eastlund Date: Sun, 15 Jan 2006 18:53:00 +0000 Subject: [PATCH] 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 --- .../private/typechecker/typecheck-utils.ss | 22 +++++ .../honu/private/typechecker/typechecker.ss | 88 ++++--------------- collects/honu/utils.ss | 27 +++--- 3 files changed, 57 insertions(+), 80 deletions(-) create mode 100644 collects/honu/private/typechecker/typecheck-utils.ss diff --git a/collects/honu/private/typechecker/typecheck-utils.ss b/collects/honu/private/typechecker/typecheck-utils.ss new file mode 100644 index 0000000000..bfee5f781d --- /dev/null +++ b/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)))) + + ) \ No newline at end of file diff --git a/collects/honu/private/typechecker/typechecker.ss b/collects/honu/private/typechecker/typechecker.ss index 58bbf8ac9e..057215541d 100644 --- a/collects/honu/private/typechecker/typechecker.ss +++ b/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)) - (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)])) ) diff --git a/collects/honu/utils.ss b/collects/honu/utils.ss index f66951b8f1..4fe4aa7079 100644 --- a/collects/honu/utils.ss +++ b/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 @@ (stringstring (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