diff --git a/collects/profj/build-info.ss b/collects/profj/build-info.ss index e78feca4b2..fb38b63af0 100644 --- a/collects/profj/build-info.ss +++ b/collects/profj/build-info.ss @@ -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" diff --git a/collects/profj/error-messaging.ss b/collects/profj/error-messaging.ss index ca7805000a..9fffb5312c 100644 --- a/collects/profj/error-messaging.ss +++ b/collects/profj/error-messaging.ss @@ -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) diff --git a/collects/profj/parsers/parse-error.ss b/collects/profj/parsers/parse-error.ss index aa497bf1bd..06866ef340 100644 --- a/collects/profj/parsers/parse-error.ss +++ b/collects/profj/parsers/parse-error.ss @@ -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) diff --git a/collects/profj/to-scheme.ss b/collects/profj/to-scheme.ss index e73b756c68..fd7b006380 100644 --- a/collects/profj/to-scheme.ss +++ b/collects/profj/to-scheme.ss @@ -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)) diff --git a/collects/tests/profj/full-tests.ss b/collects/tests/profj/full-tests.ss index 8f9fc66f21..225b4b93d7 100644 --- a/collects/tests/profj/full-tests.ss +++ b/collects/tests/profj/full-tests.ss @@ -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; diff --git a/collects/tests/profj/intermediate-tests.ss b/collects/tests/profj/intermediate-tests.ss index b9f72b9d21..1d9c4739c4 100644 --- a/collects/tests/profj/intermediate-tests.ss +++ b/collects/tests/profj/intermediate-tests.ss @@ -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 { }