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

Fixes strange error messages for invalid generic method definitions

Browse Source 
Closes PR 13681

Please merge to v5.3.4
(cherry picked from commit d84494dd44)
This commit is contained in:
Claire Alvis 2013-04-12 14:13:09 -04:00 committed by Ryan Culpepper
parent 70ab423b71
commit 2001098046
2 changed files with 47 additions and 3 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

21
collects/racket/private/generic.rkt
View File

@ -4,7 +4,8 @@
racket/local racket/local
racket/syntax racket/syntax
syntax/stx) syntax/stx)
(only-in "define-struct.rkt" define/generic)) (only-in "define-struct.rkt" define/generic)
(only-in racket/function arity-includes?))
(define-for-syntax (keyword-stx? v) (define-for-syntax (keyword-stx? v)
(keyword? (syntax->datum v))) (keyword? (syntax->datum v)))
@ -136,7 +137,20 @@
(let*-values ([(p) (lambda fake-args #f)] (let*-values ([(p) (lambda fake-args #f)]
[(generic-arity-spec) (procedure-arity p)] [(generic-arity-spec) (procedure-arity p)]
[(generic-required-kws generic-allowed-kws) (procedure-keywords p)]) [(generic-required-kws generic-allowed-kws) (procedure-keywords p)])
(lambda (f) (lambda (method-name f)
(unless (procedure? f)
(raise-arguments-error
'name
"generic method definition is not a function"
"method" method-name
"given" f))
(unless (arity-includes? (procedure-arity f) generic-arity-spec)
(raise-arguments-error
'name
"method definition has an incorrect arity"
"method" method-name
"given arity" (procedure-arity f)
"expected arity" generic-arity-spec))
(procedure-reduce-keyword-arity f generic-arity-spec generic-required-kws generic-allowed-kws)))) (procedure-reduce-keyword-arity f generic-arity-spec generic-required-kws generic-allowed-kws))))
... ...
#,@(if prop-defined-already? #,@(if prop-defined-already?
@ -159,7 +173,7 @@
(vector-length generic-vector))) (vector-length generic-vector)))
(vector (let ([mthd-generic (vector-ref generic-vector generic-idx)]) (vector (let ([mthd-generic (vector-ref generic-vector generic-idx)])
(and mthd-generic (and mthd-generic
(generic-arity-coerce mthd-generic))) (generic-arity-coerce 'generic mthd-generic)))
...)) ...))
null #t)) null #t))
;; overrides the interface predicate so that any of the default ;; overrides the interface predicate so that any of the default
@ -185,6 +199,7 @@
;; Define generic functions ;; Define generic functions
(define generic (define generic
(generic-arity-coerce (generic-arity-coerce
'generic
(make-keyword-procedure (make-keyword-procedure
(lambda (kws kws-args . given-args) (lambda (kws kws-args . given-args)
(define this (list-ref given-args generic-this-idx)) (define this (list-ref given-args generic-this-idx))

29
collects/tests/generic/errors.rkt
View File

@ -11,4 +11,33 @@
(check-exn #rx"not a name for a generics group" (check-exn #rx"not a name for a generics group"
(lambda () (convert-compile-time-error (lambda () (convert-compile-time-error
(struct foo () #:methods bad)))) (struct foo () #:methods bad))))
(check-exn #rx"method definition has an incorrect arity"
(lambda () (convert-compile-time-error
(let ()
(define-generics foobar
[foo foobar x])
(struct inst ()
#:methods gen:foobar
[(define (foo) 0)])
'ignore))))
(check-exn #rx"method definition has an incorrect arity"
(lambda () (convert-compile-time-error
(let ()
(define-generics foobar
[foo foobar x]
[bar foobar x])
(struct inst ()
#:methods gen:foobar
[(define (foo foobar x) 0)
(define (bar foobar) 1)])
'ignore))))
(check-exn #rx"generic method definition is not a function"
(lambda () (convert-compile-time-error
(let ()
(define-generics foobar
[foo foobar x])
(struct inst ()
#:methods gen:foobar
[(define foo 0)])
'ignore))))
) )