From b3947cc82f85ae311c7531e6a98edf45bb798ff4 Mon Sep 17 00:00:00 2001 From: Kathy Gray Date: Tue, 7 Feb 2006 04:54:48 +0000 Subject: [PATCH] Corrected reference before defined bug, including allowing the cases where Java allows it, and making sure that we won't get when that happens. svn: r2149 --- collects/profj/check.ss | 32 +++++--- collects/profj/to-scheme.ss | 102 ++++++++++++++----------- collects/tests/profj/beginner-tests.ss | 7 ++ collects/tests/profj/full-tests.ss | 22 +++++- 4 files changed, 107 insertions(+), 56 deletions(-) diff --git a/collects/profj/check.ss b/collects/profj/check.ss index 73fbf5638d..9cac1e1c1a 100644 --- a/collects/profj/check.ss +++ b/collects/profj/check.ss @@ -409,7 +409,7 @@ (fields (class-record-fields class-record)) (field-env (create-field-env fields env (car c-class))) (base-fields (create-field-env (filter (lambda (field) - (not (equal? (field-record-class field) (car c-class)))) + (not (equal? (field-record-class field) c-class))) fields) env (car c-class))) (ctor-throw-env (if iface? field-env (consolidate-throws @@ -446,9 +446,9 @@ (add-required c-class (ref-type-class/iface type) (ref-type-path type) type-recs)) (if (var-init? member) (check-var-init (var-init-init member) - (lambda (e env) + (lambda (e env) (check-expr e env - level type-recs c-class #f + level type-recs c-class #f static? #f #f)) (if static? statics fields) type @@ -725,6 +725,13 @@ (format "Inherited field ~a must be set in the constructor for the current class" name) (string->symbol name) src)) + ;raise-forward-reference: id src -> void + (define (raise-forward-reference field src) + (let ((name (id->ext-name (id-string field)))) + (raise-error name + (format "Field ~a cannot be referenced before its declaration." name) + name src))) + ;check-method: method env type-records (list string) boolean boolean-> void (define (check-method method env level type-recs c-class static? iface?) (let* ((ctor? (eq? 'ctor (type-spec-name (method-type method)))) @@ -1675,7 +1682,8 @@ (and (null? (cdr field-class)) (lookup-local-inner (car field-class) env)))) - (when (and (special-name? obj) + (when (and (memq level '(beginner intermediate)) + (special-name? obj) (not (lookup-var-in-env fname env))) (access-before-define (string->symbol fname) src)) @@ -1822,6 +1830,12 @@ (variable-not-found-error (if class? 'class-name 'method-name) (car acc) (id-src (car acc)))) ((close-to-keyword? (id-string (car acc))) (close-to-keyword-error 'field (car acc) (id-src (car acc)))) + ((and (not static?) (not interact?) + (get-field-record (id-string (car acc)) + (send type-recs get-class-record + (var-type-type (lookup-var-in-env "this" env))) (lambda () #f))) + (access-before-define (string->symbol (id-string (car acc))) + (id-src (car acc)))) (else (variable-not-found-error 'not-found (car acc) (id-src (car acc)))))))))) (set-access-name! exp new-acc) @@ -2721,7 +2735,7 @@ (raise-error field (case kind - ((not-found) (format "field ~a not found for object with type ~a" field t)) + ((not-found) (format "Field ~a not found for object with type ~a." field t)) ((class-name) (format "Class named ~a is being erroneously accessed as a field" field)) ((method-name) @@ -2732,26 +2746,26 @@ ((array) (format "~a only has a length field, attempted to access ~a" t field)) ((primitive) - (format "attempted to access field ~a on ~a, this value does not have fields" field t))) + (format "Attempted to access field ~a on ~a; this value does not have fields." field t))) field src))) ;unusable-var-error: symbol src -> void (define (unusable-var-error name src) (raise-error name - (format "field ~a cannot be used in this class, as two or more parents contain a field with this name" name) + (format "Field ~a cannot be used in this class, as two or more parents contain a field with this name." name) name src)) ;unset-var-error: symbol src -> void (define (unset-var-error name src) (raise-error name - (format "local variable ~a was not set along all paths reaching this point, and cannot be used" + (format "Local variable ~a was not set along all paths reaching this point, and cannot be used." name) name src)) ;access-before-defined: symbol src -> void (define (access-before-define name src) (raise-error name - (format "field ~a cannot be accessed before its definition" name) + (format "Field ~a cannot be accessed before its declaration." name) name src)) ;not-static-field-access-error symbol symbol src -> void diff --git a/collects/profj/to-scheme.ss b/collects/profj/to-scheme.ss index 005815054f..cc80bfafee 100644 --- a/collects/profj/to-scheme.ss +++ b/collects/profj/to-scheme.ss @@ -177,14 +177,16 @@ prog)) #f)) ((field? prog) - (translate-field `(private) - (field-type-spec prog) - (field-name prog) - (and (var-init? prog) prog) - (if (var-init? prog) - (var-init-src prog) - (var-decl-src prog)) - #f)) + (create-syntax #f + `(begin ,@(translate-field `(private) + (field-type-spec prog) + (field-name prog) + (and (var-init? prog) prog) + (if (var-init? prog) + (var-init-src prog) + (var-decl-src prog)) + #f)) + #f)) ((statement? prog) (translate-statement prog type-recs)) ((expr? prog) (translate-expression prog)) (else @@ -599,18 +601,24 @@ ((null? args) null) (else (cons (string->symbol (format "~a~~f" (car args))) (loop (cdr args))))))))) - ,@(map (lambda (f) (translate-field (map modifier-kind (field-modifiers f)) - (field-type-spec f) - (field-name f) - (and (var-init? f) f) - (if (var-init? f) - (var-init-src f) - (var-decl-src f)) - #f)) - (append (accesses-public fields) - (accesses-package fields) - (accesses-protected fields) - (accesses-private fields))) + ,@(let ((translated-fields (map + (lambda (f) (translate-field (map modifier-kind (field-modifiers f)) + (field-type-spec f) + (field-name f) + (and (var-init? f) f) + (if (var-init? f) + (var-init-src f) + (var-decl-src f)) + #f)) + (append (accesses-public fields) + (accesses-package fields) + (accesses-protected fields) + (accesses-private fields))))) + (append + (map car translated-fields) + (map cadr translated-fields))) + + ,@(create-private-setters/getters (accesses-private fields)) ,@(generate-inner-makers (members-inner class-members) @@ -1479,39 +1487,43 @@ (f (car fields))) (cons (make-syntax #f `(define ,(translate-id name (id-src (field-name f))) - ,(translate-field-body (and (var-init? f) f) (field-type-spec f))) + ,(cadr (translate-field-body (and (var-init? f) f) (field-type-spec f)))) (build-src (if (var-init? f) (var-init-src f) (var-decl-src f)))) (create-static-fields (cdr names) (cdr fields)))))) - ;translate-field: (list symbol) type-spec id (U #f var-init) src bool -> syntax + ;translate-field: (list symbol) type-spec id (U #f var-init) src bool -> (list syntax) (define (translate-field access type name init? src static?) - (let ((value (translate-field-body init? type)) + (let ((values (translate-field-body init? type)) (field-name (translate-id (build-var-name (if static? (build-static-name (id-string name)) (id-string name))) (id-src name)))) - (if (or static? (private? access)) - (make-syntax #f `(define ,field-name ,value) (build-src src)) - (make-syntax #f `(field (,field-name ,value)) (build-src src))))) + (list (if (or static? (private? access)) + (make-syntax #f `(define ,field-name ,(car values)) (build-src src)) + (make-syntax #f `(field (,field-name ,(car values))) (build-src src))) + (create-syntax #f `(set! ,field-name ,(cadr values)) #f)))) - ;translate-field-body (U bool var-init) type-spec -> syntax + ;translate-field-body (U bool var-init) type-spec -> (list syntax) (define (translate-field-body init? type) - (cond - (init? - (let ((actual-type (if (array-init? (var-init-init init?)) - 'dynamic ;Problem: array type needed here - (expr-types (var-init-init init?)))) - (body-syntax (if (array-init? (var-init-init init?)) - (initialize-array (array-init-vals (var-init-init init?)) - type) - (translate-expression (var-init-init init?))))) - (cond - ((or (eq? 'dynamic (field-type init?)) - (dynamic-val? (field-type init?))) - (make-syntax #f (guard-convert-value body-syntax actual-type) body-syntax)) - ((and (memq (field-type init?) '(float double)) - (memq actual-type '(long int byte short))) - (make-syntax #f `(exact->inexact ,body-syntax) body-syntax)) - (else body-syntax)))) - (else (get-default-value type)))) + (let ((default-val (get-default-value type))) + (list + default-val + (cond + (init? + (let ((actual-type (if (array-init? (var-init-init init?)) + 'dynamic ;Problem: array type needed here + (expr-types (var-init-init init?)))) + (body-syntax (if (array-init? (var-init-init init?)) + (initialize-array (array-init-vals (var-init-init init?)) + type) + (translate-expression (var-init-init init?))))) + (cond + ((or (eq? 'dynamic (field-type init?)) + (dynamic-val? (field-type init?))) + (make-syntax #f (guard-convert-value body-syntax actual-type) body-syntax)) + ((and (memq (field-type init?) '(float double)) + (memq actual-type '(long int byte short))) + (make-syntax #f `(exact->inexact ,body-syntax) body-syntax)) + (else body-syntax)))) + (else default-val))))) ;translate-initialize: bool block src string type-records -> syntax (define (translate-initialize static? body src type-recs) diff --git a/collects/tests/profj/beginner-tests.ss b/collects/tests/profj/beginner-tests.ss index 1c6aabed18..1a2f0e2faf 100644 --- a/collects/tests/profj/beginner-tests.ss +++ b/collects/tests/profj/beginner-tests.ss @@ -117,6 +117,13 @@ ;;Execution tests that should produce errors + (execute-test + "class X { + int x = this.y; + int y = 3; + X() { } + }" language #t "Should be forward field error") + (execute-test "interface Z { int x(); diff --git a/collects/tests/profj/full-tests.ss b/collects/tests/profj/full-tests.ss index 8cf4e57f00..8f9fc66f21 100644 --- a/collects/tests/profj/full-tests.ss +++ b/collects/tests/profj/full-tests.ss @@ -4,19 +4,37 @@ (prepare-for-tests "Full") + (execute-test + "class X { + int x = y; + int y; + }" 'full #t "Forward reference error") + + (interact-test + "class X { + int x = this.y; + int y = 2; + }" + 'full + '("new X().x" "new X().y") + '(0 2) + "Testing no undefined fields") + (parameterize ((dynamic? #t)) + (interact-test "class X { }" 'full '("X x = new X();" "X y = (dynamic) x;" "x.equals(y)" "y.equals(x)" "y==x" "x==y") '((void) (void) #t #t #t #t) - "Equality test of a wrapped and unwrapped object") + "Equality test of a wrapped and unwrapped object")) (parameterize ((dynamic? #t)) + (interact-test "class X { int y; X(int y) { this.y = y; } }" 'full '("X x = new X(3);" "X y = (dynamic) x;" "x.y = 4" "y.y" "y.y=5" "x.y") '((void) (void) 4 4 5 5) - "Accessing fields of a dynamic value") + "Accessing fields of a dynamic value")) (execute-test "package a; class a { int x;