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

Corrected reference before defined bug, including allowing the cases where Java allows it, and making sure that we won't get <undefined> when that happens.

Browse Source 
svn: r2149
This commit is contained in:
Kathy Gray 2006-02-07 04:54:48 +00:00
parent 2b5797c2b1
commit b3947cc82f
4 changed files with 107 additions and 56 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

28
collects/profj/check.ss
View File

@ -409,7 +409,7 @@
(fields (class-record-fields class-record)) (fields (class-record-fields class-record))
(field-env (create-field-env fields env (car c-class))) (field-env (create-field-env fields env (car c-class)))
(base-fields (create-field-env (filter (lambda (field) (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))) fields) env (car c-class)))
(ctor-throw-env (if iface? field-env (ctor-throw-env (if iface? field-env
(consolidate-throws (consolidate-throws
@ -725,6 +725,13 @@
(format "Inherited field ~a must be set in the constructor for the current class" name) (format "Inherited field ~a must be set in the constructor for the current class" name)
(string->symbol name) src)) (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 ;check-method: method env type-records (list string) boolean boolean-> void
(define (check-method method env level type-recs c-class static? iface?) (define (check-method method env level type-recs c-class static? iface?)
(let* ((ctor? (eq? 'ctor (type-spec-name (method-type method)))) (let* ((ctor? (eq? 'ctor (type-spec-name (method-type method))))
@ -1675,7 +1682,8 @@
(and (null? (cdr field-class)) (and (null? (cdr field-class))
(lookup-local-inner (car field-class) env)))) (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))) (not (lookup-var-in-env fname env)))
(access-before-define (string->symbol fname) src)) (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)))) (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? (id-string (car acc)))
(close-to-keyword-error 'field (car acc) (id-src (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 (else
(variable-not-found-error 'not-found (car acc) (id-src (car acc)))))))))) (variable-not-found-error 'not-found (car acc) (id-src (car acc))))))))))
(set-access-name! exp new-acc) (set-access-name! exp new-acc)
@ -2721,7 +2735,7 @@
(raise-error (raise-error
field field
(case kind (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) ((class-name)
(format "Class named ~a is being erroneously accessed as a field" field)) (format "Class named ~a is being erroneously accessed as a field" field))
((method-name) ((method-name)
@ -2732,26 +2746,26 @@
((array) ((array)
(format "~a only has a length field, attempted to access ~a" t field)) (format "~a only has a length field, attempted to access ~a" t field))
((primitive) ((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))) field src)))
;unusable-var-error: symbol src -> void ;unusable-var-error: symbol src -> void
(define (unusable-var-error name src) (define (unusable-var-error name src)
(raise-error (raise-error
name 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)) name src))
;unset-var-error: symbol src -> void ;unset-var-error: symbol src -> void
(define (unset-var-error name src) (define (unset-var-error name src)
(raise-error name (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)
name src)) name src))
;access-before-defined: symbol src -> void ;access-before-defined: symbol src -> void
(define (access-before-define name src) (define (access-before-define name src)
(raise-error name (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)) name src))
;not-static-field-access-error symbol symbol src -> void ;not-static-field-access-error symbol symbol src -> void

34
collects/profj/to-scheme.ss
View File

@ -177,7 +177,8 @@
prog)) prog))
#f)) #f))
((field? prog) ((field? prog)
(translate-field `(private) (create-syntax #f
`(begin ,@(translate-field `(private)
(field-type-spec prog) (field-type-spec prog)
(field-name prog) (field-name prog)
(and (var-init? prog) prog) (and (var-init? prog) prog)
@ -185,6 +186,7 @@
(var-init-src prog) (var-init-src prog)
(var-decl-src prog)) (var-decl-src prog))
#f)) #f))
#f))
((statement? prog) (translate-statement prog type-recs)) ((statement? prog) (translate-statement prog type-recs))
((expr? prog) (translate-expression prog)) ((expr? prog) (translate-expression prog))
(else (else
@ -599,7 +601,8 @@
((null? args) null) ((null? args) null)
(else (cons (string->symbol (format "~a~~f" (car args))) (else (cons (string->symbol (format "~a~~f" (car args)))
(loop (cdr args))))))))) (loop (cdr args)))))))))
,@(map (lambda (f) (translate-field (map modifier-kind (field-modifiers f)) ,@(let ((translated-fields (map
(lambda (f) (translate-field (map modifier-kind (field-modifiers f))
(field-type-spec f) (field-type-spec f)
(field-name f) (field-name f)
(and (var-init? f) f) (and (var-init? f) f)
@ -610,7 +613,12 @@
(append (accesses-public fields) (append (accesses-public fields)
(accesses-package fields) (accesses-package fields)
(accesses-protected fields) (accesses-protected fields)
(accesses-private fields))) (accesses-private fields)))))
(append
(map car translated-fields)
(map cadr translated-fields)))
,@(create-private-setters/getters (accesses-private fields)) ,@(create-private-setters/getters (accesses-private fields))
,@(generate-inner-makers (members-inner class-members) ,@(generate-inner-makers (members-inner class-members)
@ -1479,21 +1487,25 @@
(f (car fields))) (f (car fields)))
(cons (make-syntax #f (cons (make-syntax #f
`(define ,(translate-id name (id-src (field-name 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)))) (build-src (if (var-init? f) (var-init-src f) (var-decl-src f))))
(create-static-fields (cdr names) (cdr fields)))))) (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?) (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))) (field-name (translate-id (build-var-name (if static? (build-static-name (id-string name)) (id-string name)))
(id-src name)))) (id-src name))))
(if (or static? (private? access)) (list (if (or static? (private? access))
(make-syntax #f `(define ,field-name ,value) (build-src src)) (make-syntax #f `(define ,field-name ,(car values)) (build-src src))
(make-syntax #f `(field (,field-name ,value)) (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) (define (translate-field-body init? type)
(let ((default-val (get-default-value type)))
(list
default-val
(cond (cond
(init? (init?
(let ((actual-type (if (array-init? (var-init-init init?)) (let ((actual-type (if (array-init? (var-init-init init?))
@ -1511,7 +1523,7 @@
(memq actual-type '(long int byte short))) (memq actual-type '(long int byte short)))
(make-syntax #f `(exact->inexact ,body-syntax) body-syntax)) (make-syntax #f `(exact->inexact ,body-syntax) body-syntax))
(else body-syntax)))) (else body-syntax))))
(else (get-default-value type)))) (else default-val)))))
;translate-initialize: bool block src string type-records -> syntax ;translate-initialize: bool block src string type-records -> syntax
(define (translate-initialize static? body src type-recs) (define (translate-initialize static? body src type-recs)

7
collects/tests/profj/beginner-tests.ss
View File

@ -117,6 +117,13 @@
;;Execution tests that should produce errors ;;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 (execute-test
"interface Z { "interface Z {
int x(); int x();

22
collects/tests/profj/full-tests.ss
View File

@ -4,19 +4,37 @@
(prepare-for-tests "Full") (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)) (parameterize ((dynamic? #t))
(interact-test
"class X { }" "class X { }"
'full 'full
'("X x = new X();" "X y = (dynamic) x;" "x.equals(y)" "y.equals(x)" "y==x" "x==y") '("X x = new X();" "X y = (dynamic) x;" "x.equals(y)" "y.equals(x)" "y==x" "x==y")
'((void) (void) #t #t #t #t) '((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)) (parameterize ((dynamic? #t))
(interact-test
"class X { int y; X(int y) { this.y = y; } }" "class X { int y; X(int y) { this.y = y; } }"
'full 'full
'("X x = new X(3);" "X y = (dynamic) x;" "x.y = 4" "y.y" "y.y=5" "x.y") '("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) '((void) (void) 4 4 5 5)
"Accessing fields of a dynamic value") "Accessing fields of a dynamic value"))
(execute-test (execute-test
"package a; class a { int x; "package a; class a { int x;