From 28a87853fa775f718b00640d1a4537acc8d3d3cf Mon Sep 17 00:00:00 2001 From: Kathy Gray Date: Sun, 29 Jul 2007 19:57:18 +0000 Subject: [PATCH] Corrected errors in grammar, and in error selection svn: r6982 --- .../private-combinator/combinator.scm | 12 ++-- .../private-combinator/structs.scm | 6 +- collects/profj/check.ss | 70 ++++++++++++++----- collects/profj/comb-parsers/parser-units.scm | 32 +++++---- 4 files changed, 81 insertions(+), 39 deletions(-) diff --git a/collects/combinator-parser/private-combinator/combinator.scm b/collects/combinator-parser/private-combinator/combinator.scm index 3a5967e7fb..6bb2568a02 100644 --- a/collects/combinator-parser/private-combinator/combinator.scm +++ b/collects/combinator-parser/private-combinator/combinator.scm @@ -51,7 +51,7 @@ (position-token-end-pos token))) build)]) - (opt-lambda (input [last-src (list 0 0 0 0)] [alts 1]) + (opt-lambda (input [last-src (list 1 0 1 0)] [alts 1]) #;(!!! (printf "terminal ~a~n" name)) #;(!!! (printf "input ~a~n" (cons? input))) #;(!!! (if (eq? input return-name) @@ -118,7 +118,7 @@ [else (!!! (printf "~a~n" r)) (error 'stop1)]))] [my-error (sequence-error-gen name sequence-length)] [my-walker (seq-walker id-position name my-error)]) - (opt-lambda (input [last-src (list 0 0 0 0)] [alts 1]) + (opt-lambda (input [last-src (list 1 0 1 0)] [alts 1]) #;(!!! (printf "seq ~a~n" name)) (cond [(eq? input return-name) name] @@ -234,7 +234,7 @@ (res-msg (repeat-res-a res)) #f (res-first-tok (repeat-res-a res)) new-alts)] - [else (!!! (printf "~a~n" res))(error 'stop) ])) lst)] + [else (!!! (printf "~a~n" res))(error 'stop) ])) (correct-list lst))] [(correct-rsts) (correct-list rsts)]) #;(printf "rsts =~a~n" rsts) #;(printf "correct-rsts ~a~n" (map res-a correct-rsts)) @@ -395,7 +395,7 @@ [(pair? rest-ans) (map (lambda (r) (process-rest curr-ans r)) rest-ans)] [else (error 'here4)]))]) - (opt-lambda (input [last-src (list 0 0 0 0)] [alts 1]) + (opt-lambda (input [last-src (list 1 0 1 0)] [alts 1]) (cond [(eq? input return-name) repeat-name] [(hash-table-get memo-table input #f) (hash-table-get memo-table input)] @@ -494,7 +494,9 @@ (fourth src)))) (define (update-src-end src new-end) - (list (first src) (second src) (third src) + (list (max (first src) 1) + (second src) + (max (third src) 1) (- (position-offset new-end) (third src)))) (define (repeat op) diff --git a/collects/combinator-parser/private-combinator/structs.scm b/collects/combinator-parser/private-combinator/structs.scm index 614615b387..be08f3a833 100644 --- a/collects/combinator-parser/private-combinator/structs.scm +++ b/collects/combinator-parser/private-combinator/structs.scm @@ -22,7 +22,7 @@ ;(make-sequence-fail float fail-src string symbol (list string) string 'a boolean string) (define-struct (sequence-fail fail-type) (id kind correct expected found repeat? last-seen)) ;(make-choice-fail float fail-src string int (list string) (list fail-type) boolean) - (define-struct (choice-fail fail-type) (options names messages ended?) (make-inspector)) + (define-struct (choice-fail fail-type) (options names ended? messages) (make-inspector)) ;(make-options-fail float #f #f (list fail-type)) (define-struct (options-fail fail-type) (opts)) @@ -53,8 +53,8 @@ (make-choice-fail chance src name used may-use (!!! (choice-fail-options fail)) (!!! (choice-fail-names fail)) - (map !!!-fail (!!! (choice-fail-messages fail))) - (!!! (choice-fail-ended? fail)))] + (!!! (choice-fail-ended? fail)) + (map !!!-fail (!!! (choice-fail-messages fail))))] [(options-fail? fail) (make-options-fail chance src name used may-use (map !!!-fail (!!! (options-fail-opts fail))))] diff --git a/collects/profj/check.ss b/collects/profj/check.ss index 0ba5fa2264..451db8e7ee 100644 --- a/collects/profj/check.ss +++ b/collects/profj/check.ss @@ -37,16 +37,16 @@ ;;Environment variable properties ;;(make-properties bool bool bool bool bool bool) - (define-struct properties (parm? field? static? settable? final? usable?)) - (define parm (make-properties #t #f #f #t #f #t)) - (define final-parm (make-properties #t #f #f #f #t #t)) - (define method-var (make-properties #f #f #f #t #f #t)) - (define final-method-var (make-properties #f #f #f #f #t #t)) - (define obj-field (make-properties #f #t #f #t #f #t)) - (define (final-field settable) (make-properties #f #t #f settable #t #t)) - (define class-field (make-properties #f #t #t #f #t #t)) - (define (final-class-field settable) (make-properties #f #t #t settable #t #t)) - (define inherited-conflict (make-properties #f #t #f #f #f #f)) + (define-struct properties (parm? field? static? settable? final? usable? set?) (make-inspector)) + (define parm (make-properties #t #f #f #t #f #t #t)) + (define final-parm (make-properties #t #f #f #f #t #t #t)) + (define method-var (make-properties #f #f #f #t #f #t #f)) + (define final-method-var (make-properties #f #f #f #f #t #t #f)) + (define (obj-field set?) (make-properties #f #t #f #t #f #t set?)) + (define (final-field settable) (make-properties #f #t #f settable #t #t #f)) + (define (class-field set?) (make-properties #f #t #t #f #t #t set?)) + (define (final-class-field settable) (make-properties #f #t #t settable #t #t #f)) + (define inherited-conflict (make-properties #f #t #f #f #f #f #f)) ;; add-var-to-env: string type properties env -> env (define (add-var-to-env name type properties env) @@ -65,6 +65,16 @@ (car env) (lookup (cdr env))))))) (lookup (environment-types env)))) + + (define (lookup-field-in-env name env) + (letrec ([lookup + (lambda (env) + (and (not (null? env)) + (if (and (string=? name (var-type-var (car env))) + (properties-field? (var-type-properties (car env)))) + (car env) + (lookup (cdr env)))))]) + (lookup (environment-types env)))) ;lookup-specific-this: name env symbol type-records -> bool (define (lookup-enclosing-this name env level type-recs) @@ -429,7 +439,7 @@ (define (tested-not-found test class src) (raise-error 'tests - (format "test ~a does not test class ~a, as the class cannot be found." + (format "test ~a cannot test class ~a, as the class cannot be found." (id->ext-name test) (path->ext (name->path class))) 'tests src)) @@ -492,10 +502,10 @@ (set! setting-fields (cons member setting-fields)))) (if static? (loop (cdr rest) - (add-var-to-env name type class-field statics) - (add-var-to-env name type class-field fields)) + (add-var-to-env name type (class-field (var-init? member)) statics) + (add-var-to-env name type (class-field (var-init? member)) fields)) (loop (cdr rest) statics - (add-var-to-env name type obj-field fields))))) + (add-var-to-env name type (obj-field #f #;(var-init? member)) fields))))) ((def? member) (check-inner-def member level type-recs c-class field-env) (loop (cdr rest) statics fields)) @@ -533,9 +543,9 @@ (field-record-type field) (cond ((and in-env? (not current?)) inherited-conflict) - ((and (not static?) (not final?)) obj-field) + ((and (not static?) (not final?)) (obj-field #f)) ((and (not static?) final?) (final-field current?)) - ((and static? (not final?)) class-field) + ((and static? (not final?)) (class-field #f)) ((and static? final?) (final-class-field current?))) (create-field-env (cdr fields) env class)))))) @@ -1726,6 +1736,23 @@ (special-name? obj) (not (lookup-var-in-env fname env))) (access-before-define (string->symbol fname) src)) + + (when (and (eq? 'beginner level) + assign-left? + (special-name? obj) + (properties-set? (var-type-properties (lookup-field-in-env fname env)))) + (assign-twice (string->symbol fname) src)) + + (when (and (eq? 'beginner level) + assign-left? + (special-name? obj)) + (set-properties-set?! (var-type-properties (lookup-field-in-env fname env)) #t)) + + (when (and (eq? 'beginner level) + (special-name? obj) + (not (properties-set? (var-type-properties (lookup-field-in-env fname env))))) + (access-before-assign (string->symbol fname) src)) + (when (and (field-access-access acc) (var-access-static? (field-access-access acc))) @@ -3007,6 +3034,17 @@ (format "Field ~a cannot be accessed before its declaration." name) name src)) + ;assign-twice: symbol src -> void + (define (assign-twice name src) + (raise-error name + (format "Field ~a has been initialized and cannot be initialized again." name) + name src)) + + (define (access-before-assign name src) + (raise-error name + (format "Field ~a cannot be accessed before it is initialized." name) + name src)) + ;not-static-field-access-error symbol symbol src -> void (define (not-static-field-access-error name level src) (raise-error diff --git a/collects/profj/comb-parsers/parser-units.scm b/collects/profj/comb-parsers/parser-units.scm index ef932fa671..f9a2272261 100644 --- a/collects/profj/comb-parsers/parser-units.scm +++ b/collects/profj/comb-parsers/parser-units.scm @@ -206,9 +206,11 @@ (choice (list base-t voidT) "method return")) (define (array-type base-t) - (choice (base-t (sequence (base-t O_BRACKET C_BRACKET - (repeat (sequence (O_BRACKET C_BRACKET) id))) id - "array type")) "type")) + (choose (base-t + (sequence (base-t O_BRACKET C_BRACKET + (repeat-greedy + (sequence (O_BRACKET C_BRACKET) id "array type"))) + id "type")) "type")) ) @@ -265,7 +267,7 @@ (export general-productions^) (define (comma-sep term name) - (sequence (term (repeat (sequence (COMMA term) id))) id (string-append "a list of " name))) + (sequence (term (repeat-greedy (sequence (COMMA term) id))) id (string-append "a list of " name))) (define (variable-declaration type expr share-type? name) (let* ([f (choose (IDENTIFIER (sequence ((^ IDENTIFIER) EQUAL expr) id)) (string-append name " declaration"))] @@ -682,7 +684,7 @@ (repeat-greedy (class-body (list field method constructor))))) (define program - (make-program #f (repeat import-dec) (repeat-greedy (top-member (list class interface))))) + (make-program #f (repeat-greedy import-dec) (repeat-greedy (top-member (list class interface))))) ) (define-unit intermediate-grammar@ @@ -740,7 +742,7 @@ (method-signature tok:abstract (method-type (value+name-type prim-type)) args #f identifier)) (define method - (choose ((make-method method-sig-no-abs statement) + (choose ((make-method method-sig-no-abs (repeat-greedy statement)) (method-header method-sig-abs)) "method definition")) (define constructor @@ -761,7 +763,7 @@ (define program - (make-program #f (repeat import-dec) (repeat-greedy (top-member (list class interface))))) + (make-program #f (repeat-greedy import-dec) (repeat-greedy (top-member (list class interface))))) ) @@ -841,7 +843,7 @@ (repeat-greedy (class-body (list field method constructor))))) (define program - (make-program #f (repeat import-dec) + (make-program #f (repeat-greedy import-dec) (repeat-greedy (top-member (list class interface))))) ) @@ -891,7 +893,7 @@ (sequence (unique-base (repeat unique-end) field-access-end) id) (sequence (unique-base (repeat unique-end) array-access-end) id)) "asignee") - assignment-ops expression) + assignment-ops) (sequence (expression ++) id "unary mutation") (sequence (expression --) id "unary mutation") (sequence (++ expression) id "unary mutation") @@ -900,10 +902,10 @@ (define statement (choose ((if-s #t (eta statement)) (return-s #t) - (variable-declaration (value+name-type prim-type) expression #t "local variable") + (variable-declaration (array-type (value+name-type prim-type)) expression #t "local variable") (block #t) (sequence (stmt-expr SEMI_COLON) id) - (for-l (choose ((variable-declaration (value+name-type prim-type) expression #t "for loop variable") + (for-l (choose ((variable-declaration (array-type (value+name-type prim-type)) expression #t "for loop variable") (comma-sep stmt-expr "initializations")) "for loop initialization") #t #t (comma-sep stmt-expr "for loop increments") #t (block #t)) @@ -912,14 +914,14 @@ (break-s #f) (cont-s #f)) "statement")) - (define field (make-field (global-mods access-mods) (value+name-type prim-type) expression #t)) + (define field (make-field (global-mods access-mods) (array-type (value+name-type prim-type)) expression #t)) (define method-sig-no-abs (method-signature (global-mods access-mods) - (method-type (value+name-type prim-type)) args #f IDENTIFIER)) + (method-type (array-type (value+name-type prim-type))) args #f IDENTIFIER)) (define method-sig-abs (method-signature (method-mods (global-mods access-mods)) - (method-type (value+name-type prim-type)) args #f IDENTIFIER)) + (method-type (array-type (value+name-type prim-type))) args #f IDENTIFIER)) (define method (choose ((make-method method-sig-no-abs statement) @@ -947,7 +949,7 @@ (define program (make-program (sequence (tok:package name SEMI_COLON) id "package specification") - (repeat import-dec) + (repeat-greedy import-dec) (repeat-greedy (top-member (list class interface))))) )