Corrected the following bugs:
Cleaned up language and highlighting for parse-error of three ids in a row. Removed () from many method error messages. Eliminated scheme-error when introducing overloaded method in subclass. svn: r2292
This commit is contained in:
Kathy Gray
parent
ce5eca215c
commit
70193deb1d
|
|
@ -1239,9 +1239,10 @@
|
|||
(when (and (memq level '(beginner intermediate))
|
||||
(member name (map method-record-name inherited-methods))
|
||||
(not over?))
|
||||
(inherited-overload-error name parms (method-record-atypes
|
||||
(car (filter (lambda (m) (equal? (method-record-name m) name))
|
||||
inherited-methods)))
|
||||
(inherited-overload-error (car cname) name parms
|
||||
(method-record-atypes
|
||||
(car (filter (lambda (m) (equal? (method-record-name m) name))
|
||||
inherited-methods)))
|
||||
(id-src (method-name method))))
|
||||
|
||||
(when (eq? ret 'ctor)
|
||||
|
|
@ -1568,7 +1569,8 @@
|
|||
(if (eq? kind 'inherited-conflict-field)
|
||||
(let ((n (id->ext-name name)))
|
||||
(raise-error n (format "Field ~a conflicts with a method of the same name from ~a" n class) n src))
|
||||
(let ((m-name (method-name->ext-name (id-string name) parms))
|
||||
(let ((m-name (method-name->ext-name (id-string name) null))
|
||||
(m-full-name (method-name->ext-name (id-string name) parms))
|
||||
(r-name (type->ext-name ret)))
|
||||
(raise-error
|
||||
m-name
|
||||
|
|
@ -1576,35 +1578,44 @@
|
|||
((illegal-abstract)
|
||||
(format
|
||||
"Abstract method ~a is not allowed in non-abstract class ~a, abstract methods must be in abstract classes"
|
||||
m-name class))
|
||||
m-full-name class))
|
||||
((repeated)
|
||||
(format "~a ~a has already been written in this class, ~a, and cannot be written again"
|
||||
(if ctor? "Constructor" "Method") m-name class))
|
||||
(if ctor? "Constructor" "Method") m-full-name class))
|
||||
((inherit-conflict)
|
||||
(format "Inherited method ~a from ~a conflicts with another method of the same name" m-name class))
|
||||
(format "Inherited method ~a from ~a conflicts with another method of the same name" m-full-name class))
|
||||
((conflict)
|
||||
(format "Method ~a conflicts with a method inherited from ~a" m-name class))
|
||||
((not-implement) (format "Method ~a returning ~a from ~a should be implemented and was not" m-name r-name class))
|
||||
(format "Method ~a conflicts with a method inherited from ~a" m-full-name class))
|
||||
((not-implement) (format "Method ~a returning ~a from ~a should be implemented and was not." m-full-name r-name class))
|
||||
((ctor-ret-value)
|
||||
(format "Constructor ~a for class ~a has a return type, which is not allowed" m-name class))
|
||||
(format "Constructor ~a for class ~a has a return type, which is not allowed." m-full-name class))
|
||||
((class-name)
|
||||
(format "Method ~a from ~a has the same name as a class, which is not allowed" m-name class))
|
||||
(format "Method ~a from ~a has the same name as a class, which is not allowed." m-full-name class))
|
||||
((bad-ret)
|
||||
(format "Methods with the same name must have the same return type. Found definitions of method ~a in ~a with return types ~a and ~a."
|
||||
m-name class r-name (type->ext-name ctor?))))
|
||||
m-full-name class r-name (type->ext-name ctor?))))
|
||||
m-name src))))
|
||||
|
||||
;inherited-overload-error: string (list type) (list type) src -> void
|
||||
(define (inherited-overload-error name new-type inherit-type src)
|
||||
(let ((n (string->symbol name))
|
||||
(nt (map type->ext-name new-type))
|
||||
(gt (map type->ext-name inherit-type)))
|
||||
(raise-error n
|
||||
(string-append
|
||||
(format "Attempted to override method ~a, but it should have ~a arguments with types ~a.~n"
|
||||
n (length inherit-type) gt)
|
||||
(format "Given ~a arguments with types ~a" (length new-type) nt))
|
||||
n src)))
|
||||
;inherited-overload-error: string string (list type) (list type) src -> void
|
||||
(define (inherited-overload-error curr-class name new-type inherit-type src)
|
||||
(let* ((n (string->symbol name))
|
||||
(nt (map type->ext-name new-type))
|
||||
(nt-l (length nt))
|
||||
(gt (map type->ext-name inherit-type))
|
||||
(gt-l (length gt)))
|
||||
(raise-error
|
||||
(string->symbol curr-class)
|
||||
(string-append
|
||||
(format "Attempted to override method ~a, but it should have " n)
|
||||
(cond
|
||||
((= gt-l 0) "no arguments.~n")
|
||||
((= gt-l 1) (format "1 argument with type ~a.~n" (car gt)))
|
||||
(else (format "~a arguments with types ~a." gt-l gt)))
|
||||
(cond
|
||||
((= nt-l 0) "Given a method with no arguments.")
|
||||
((= nt-l 1) (format "Given a method with one argument with type ~a." (car nt)))
|
||||
(else (format "Given a method with ~a arguments with types ~a" nt-l nt))))
|
||||
(string->symbol curr-class) src)))
|
||||
|
||||
;not-ctor-error: string string src -> void
|
||||
(define (not-ctor-error meth class src)
|
||||
|
|
@ -1664,14 +1675,15 @@
|
|||
;return-error string (list type) (list string) type type src -> void
|
||||
(define (override-return-error name parms class ret old-ret src)
|
||||
(let ((name (string->symbol name))
|
||||
(m-name-short (method-name->ext-name name null))
|
||||
(m-name (method-name->ext-name name parms)))
|
||||
(raise-error
|
||||
name
|
||||
(format
|
||||
"~a~n~a"
|
||||
(format "Method ~a of class ~a overrides an inherited method, in overriding the return type must remain the same"
|
||||
(format "Method ~a of class ~a overrides an inherited method, in overriding the return type must remain the same."
|
||||
m-name (car class))
|
||||
(format "~a's return has changed from ~a to ~a" m-name (type->ext-name old-ret) (type->ext-name ret)))
|
||||
(format "~a's return has changed from ~a to ~a." m-name-short (type->ext-name old-ret) (type->ext-name ret)))
|
||||
name src)))
|
||||
|
||||
;override-access-error symbol symbol string (list type) (list string) string src -> void
|
||||
|
|
@ -1685,13 +1697,13 @@
|
|||
(format
|
||||
"Method ~a in ~a attempts to override final method from ~a, final methods may not be overridden"
|
||||
m-name (car class) (if (list? parent) (car parent) parent))
|
||||
(format "Method ~a from ~a cannot be overridden in ~a" m-name parent (car class))))
|
||||
(format "Method ~a from ~a cannot be overridden in ~a" name parent (car class))))
|
||||
((static)
|
||||
(format "Method ~a in ~a attempts to override static method from ~a, which is not allowed"
|
||||
m-name (car class) parent))
|
||||
((public)
|
||||
(format "Method ~a in ~a must be public to override public method from ~a, ~a is not public"
|
||||
m-name (car class) parent m-name))
|
||||
m-name (car class) parent name))
|
||||
((protected)
|
||||
(format
|
||||
"Method ~a in ~a must be public or protected to override protected method from ~a, it is neither"
|
||||
|
|
|
|||
|
|
@ -78,8 +78,17 @@
|
|||
(substring parm-str 0 (sub1 (string-length parm-str))))))
|
||||
|
||||
;method-name->ext-name: string (list type) -> symbol
|
||||
;(define (method-name->ext-name name parms)
|
||||
; (string->symbol (format "~a(~a)" name (make-parm-string parms))))
|
||||
|
||||
(define (method-name->ext-name name parms)
|
||||
(string->symbol (format "~a(~a)" name (make-parm-string parms))))
|
||||
(string->symbol
|
||||
(cond
|
||||
((null? parms) name)
|
||||
((= 1 (length parms)) (format "~a, expecting one argument with type ~a, "
|
||||
name (type->ext-name (car parms))))
|
||||
(else
|
||||
(format "~a, expecting arguments with types ~a," name (make-parm-string parms))))))
|
||||
|
||||
;path->ext: (list string) -> string
|
||||
(define (path->ext path)
|
||||
|
|
|
|||
|
|
@ -662,7 +662,7 @@
|
|||
|
||||
;parse-members: token token symbol (->token) boolean -> token
|
||||
(define (parse-members pre cur state getter abstract-method? just-method?)
|
||||
;(printf "parse-members: state ~a pre ~a current ~a~n" state pre cur)
|
||||
;(printf "parse-members: state ~a pre ~a current ~a~n" state (get-tok pre) (get-tok cur))
|
||||
(let* ((tok (get-tok cur))
|
||||
(kind (get-token-name tok))
|
||||
(out (format-out tok))
|
||||
|
|
@ -670,6 +670,7 @@
|
|||
(end (get-end cur))
|
||||
(ps (if (null? pre) null (get-start pre)))
|
||||
(pe (if (null? pre) null (get-end pre))))
|
||||
;(printf "parse-members: pre-out ~a current-out ~a~n" (if (null? pre) null (format-out (get-tok pre))) out)
|
||||
|
||||
(case state
|
||||
((start)
|
||||
|
|
@ -709,19 +710,19 @@
|
|||
((and (advanced?) (o-bracket? tok))
|
||||
(parse-members pre cur 'method-or-field getter abstract-method? just-method?))
|
||||
((open-separator? tok)
|
||||
(parse-error (format "( must be used to start parameter list, found ~a" out) srt end))
|
||||
(parse-error (format "'(' must be used to start parameter list, found ~a" out) srt end))
|
||||
((prim-type? tok)
|
||||
(parse-error
|
||||
(format "methods and fields may not be named for primitive type ~a, which appears in the name position" kind)
|
||||
(format "Methods and fields may not be named for primitive type ~a, which appears in the name position." kind)
|
||||
srt end))
|
||||
((java-keyword? tok)
|
||||
(parse-error
|
||||
(format "Expected a name for this field or method, ~a is a reserved word and cannot be the name" kind)
|
||||
(format "Expected a name for this field or method, ~a is a reserved word and cannot be the name." kind)
|
||||
srt end))
|
||||
(else (parse-error (format "Expected a name for this field or method, found ~a" out) srt end))))
|
||||
(else (parse-error (format "Expected a name for this field or method, found ~a." out) srt end))))
|
||||
((method-or-field)
|
||||
(case kind
|
||||
((EOF) (parse-error "Method or field must have a name, class body still requires a }" ps pe))
|
||||
((EOF) (parse-error "Method or field must have a name, and the class body still requires a '}'." ps pe))
|
||||
((IDENTIFIER)
|
||||
(let* ((next (getter))
|
||||
(n-tok (get-tok next))
|
||||
|
|
@ -729,20 +730,20 @@
|
|||
(ne (get-end next)))
|
||||
(cond
|
||||
((eof? n-tok)
|
||||
(parse-error "Method or field has not completed, class body still requires a }" srt end))
|
||||
(parse-error "Method or field has not completed, and the class body still requires a '}'." srt end))
|
||||
;Just ended a field
|
||||
((semi-colon? n-tok) (parse-members next (getter) 'start getter #f just-method?))
|
||||
;Intermediate and Advanced
|
||||
((comma? n-tok)
|
||||
(if (or (intermediate?) (advanced?))
|
||||
(parse-members next (getter) 'field-list getter abstract-method? just-method?)
|
||||
(parse-error (format "Expected an end to field ~a, fields end in ';', ',' is not allowed" (token-value tok))
|
||||
(parse-error (format "Expected an end to field ~a, fields end in ';', ',' is not allowed." (token-value tok))
|
||||
srt ne)))
|
||||
((and #;(or (intermediate?) (advanced?)) (teaching-assignment-operator? n-tok))
|
||||
(let ((assign-exp (getter)))
|
||||
(cond
|
||||
((eof? (get-tok assign-exp))
|
||||
(parse-error (format "Expected an expression to bind to ~a, and class body still needs a }"
|
||||
(parse-error (format "Expected an expression to bind to ~a, and the class body still needs a '}'."
|
||||
(token-value tok)) srt end))
|
||||
((and (advanced?) (o-brace? (get-tok assign-exp)))
|
||||
(parse-members next (parse-array-init assign-exp (getter) 'start getter) 'field-init-end getter #f just-method?))
|
||||
|
|
@ -750,32 +751,27 @@
|
|||
(parse-members next (parse-expression null assign-exp 'start getter #f #f) 'field-init-end getter #f just-method?)))))
|
||||
((o-paren? n-tok) (parse-members next (getter) 'method-parms getter abstract-method? just-method?))
|
||||
((open-separator? n-tok)
|
||||
(parse-error (format "Method parameters must begin with ( found ~a" n-out) srt ne))
|
||||
(parse-error (format "Method parameters must begin with '(' found ~a." n-out) srt ne))
|
||||
((id-token? n-tok)
|
||||
(if (and (id-token? (get-tok pre))
|
||||
(close-to-keyword? (get-tok pre) 'abstract))
|
||||
(parse-error
|
||||
(string-append
|
||||
(format "Incorrectly formed field or method declaration.~n")
|
||||
(parse-error
|
||||
(string-append
|
||||
(format "Incorrectly formed field or method declaration. ~a may not appear here.~n" n-out)
|
||||
(if (and (id-token? (get-tok pre))
|
||||
(close-to-keyword? (get-tok pre) 'abstract))
|
||||
(format
|
||||
"~a is close to 'abstract' but miscapitalized or misspelled, and might make this a method declaration.~n"
|
||||
"~a is close to 'abstract' but may be miscapitalized or misspelled.~n"
|
||||
(format-out (get-tok pre)))
|
||||
"Otherwise, "
|
||||
(if (or (intermediate?) (advanced?))
|
||||
(format "Fields must be separated by commas, method paramters must be in ()s, ~a not allowed" n-out)
|
||||
(format "Fields must be separatley declared, method paramters must be in ()s, ~a not allowed" n-out)))
|
||||
ps ne)
|
||||
(parse-error
|
||||
(if (or (intermediate?) (advanced?))
|
||||
(format "Fields must be separated by commas, method paramters must be in ()s, ~a not allowed" n-out)
|
||||
(format "Fields must be separatley declared, method paramters must be in ()s, ~a not allowed" n-out))
|
||||
srt ne)))
|
||||
"")
|
||||
(if (or (intermediate?) (advanced?))
|
||||
"A field is Type Name followed by '=', ',', or ';'. A method is Type Name followed by '('."
|
||||
"A field is Type Name followed by '=', or ';''. A method is Type Name followed by '('."))
|
||||
ps ne))
|
||||
(else
|
||||
(if (or (intermediate?) (advanced?))
|
||||
(parse-error
|
||||
(format "Expected ';' to end field or abstract method parameter list, found ~a" n-out) srt ne)
|
||||
(format "Expected ';' to end field or abstract method parameter list, found ~a." n-out) srt ne)
|
||||
(parse-error
|
||||
(format "Expected ';' to end field. Found ~a" n-out) srt ne))))))
|
||||
(format "Expected ';' to end field. Found ~a." n-out) srt ne))))))
|
||||
(else
|
||||
(if (and (advanced?) (o-bracket? tok))
|
||||
(let* ((next (getter))
|
||||
|
|
@ -787,7 +783,7 @@
|
|||
(parse-error "Array type may not have [[. A closing ] is required before beginning a new []"
|
||||
srt (get-end next)))
|
||||
(else
|
||||
(parse-error (format "Array type is of the form type[]. ~a is not allowed" (format-out next-tok)) srt
|
||||
(parse-error (format "Array type is of the form Type[]. ~a is not allowed." (format-out next-tok)) srt
|
||||
(get-end next)))))
|
||||
(parse-error
|
||||
(if (java-keyword? tok)
|
||||
|
|
|
|||
|
|
@ -745,13 +745,15 @@
|
|||
|
||||
;generate-wrappers: string (list method-record) (list field) -> (list sexp)
|
||||
(define (generate-wrappers class-name super-name methods fields)
|
||||
(let* ((wrapped-methods
|
||||
(let* (;these methods will be used to detect when a method is now overloaded when it wasn't in the super class
|
||||
(wrapped-methods-initial
|
||||
(filter (lambda (m)
|
||||
(and (not (eq? (method-record-rtype m) 'ctor))
|
||||
(not (method-record-override m)))) methods))
|
||||
(wrapped-methods
|
||||
(filter
|
||||
(lambda (m)
|
||||
(and (not (eq? (method-record-rtype m) 'ctor))
|
||||
(equal? (car (method-record-class m)) class-name)
|
||||
(not (method-record-override m))))
|
||||
methods))
|
||||
(lambda (m) (equal? (car (method-record-class m)) class-name))
|
||||
wrapped-methods-initial))
|
||||
(add-ca
|
||||
(lambda (name) (build-identifier (string-append "convert-assert-" name))))
|
||||
(add-gc
|
||||
|
|
@ -776,7 +778,7 @@
|
|||
wrapped-methods) #f from-dynamic?)
|
||||
,@extra-methods
|
||||
))))
|
||||
(dynamic-callables (refine-method-list wrapped-methods)))
|
||||
(dynamic-callables (refine-method-list wrapped-methods-initial class-name)))
|
||||
(list
|
||||
`(define (,(build-identifier (string-append "wrap-convert-assert-" class-name)) obj p n s c)
|
||||
(let ((raise-error
|
||||
|
|
@ -953,23 +955,27 @@
|
|||
(else value))))
|
||||
|
||||
;Removes from the list all methods that are not callable from a dynamic context
|
||||
;refine-method-list: (list method-record) -> (list method-record)
|
||||
(define (refine-method-list methods)
|
||||
(cond
|
||||
((null? methods) methods)
|
||||
((method-record-override (car methods))
|
||||
(refine-method-list (cdr methods)))
|
||||
((eq? 'ctor (method-record-rtype (car methods)))
|
||||
(refine-method-list (cdr methods)))
|
||||
(else
|
||||
(let ((overloaded-removed
|
||||
(filter (lambda (m) (not (equal? (method-record-name (car methods))
|
||||
(method-record-name m))))
|
||||
(cdr methods))))
|
||||
(if (> (length (cdr methods))
|
||||
(length overloaded-removed))
|
||||
(refine-method-list overloaded-removed)
|
||||
(cons (car methods) (refine-method-list (cdr methods))))))))
|
||||
;refine-method-list: (list method-record) string -> (list method-record)
|
||||
(define (refine-method-list methods class)
|
||||
(letrec ((refine
|
||||
(lambda (methods)
|
||||
(cond
|
||||
((null? methods) methods)
|
||||
((method-record-override (car methods))
|
||||
(refine (cdr methods)))
|
||||
((eq? 'ctor (method-record-rtype (car methods)))
|
||||
(refine (cdr methods)))
|
||||
(else
|
||||
(let ((overloaded-removed
|
||||
(filter (lambda (m) (not (equal? (method-record-name (car methods))
|
||||
(method-record-name m))))
|
||||
(cdr methods))))
|
||||
(if (> (length (cdr methods))
|
||||
(length overloaded-removed))
|
||||
(refine overloaded-removed)
|
||||
(cons (car methods) (refine (cdr methods))))))))))
|
||||
(filter (lambda (m) (equal? (car (method-record-class m)) class))
|
||||
(refine methods))))
|
||||
|
||||
|
||||
;generate-dynamic-names: (list method) (list method)-> (list (list string method))
|
||||
|
|
|
|||
|
|
@ -4,6 +4,16 @@
|
|||
|
||||
(prepare-for-tests "Full")
|
||||
|
||||
(execute-test
|
||||
"class A {
|
||||
int f (A x) { return 4; }
|
||||
}
|
||||
class B extends A {
|
||||
int f( B x) { return 5; }
|
||||
}"
|
||||
'full #f
|
||||
"Overloading introduced on extends")
|
||||
|
||||
(execute-test
|
||||
"class X {
|
||||
int x = y;
|
||||
|
|
|
|||
|
|
@ -318,6 +318,13 @@
|
|||
|
||||
;;Execute tests with errors
|
||||
|
||||
(execute-test
|
||||
"class A {
|
||||
a b c;
|
||||
}"
|
||||
'intermediate
|
||||
#t "Parse error with three identifiers in a row")
|
||||
|
||||
(execute-test
|
||||
"interface A { int a(); }
|
||||
abstract class B implements A { }
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user