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

add raise-result-arity-error

Browse Source 
Use it to provide some proper errors from the expander.

Closes #2029
This commit is contained in:
Matthew Flatt 2018-04-10 18:58:27 +02:00
parent f66b3312df
commit fcfa72e73a
15 changed files with 2736 additions and 2626 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

27
pkgs/racket-doc/scribblings/reference/exns.scrbl
View File

@ -309,7 +309,32 @@ The @racket[arg-v] arguments are the actual supplied
arguments, which are shown in the error message (using the error value
conversion handler; see @racket[error-value->string-handler]); also,
the number of supplied @racket[arg-v]s is explicitly mentioned in the
message.}
message.
@examples[
(eval:error (raise-arity-error 'unite (arity-at-least 13) "Virginia" "Maryland"))
]}
@defproc[(raise-result-arity-error [name (or/c symbol? #f)]
[arity-v exact-nonnegative-integer?]
[detail-str (or/c string? #f)]
[result-v any/c] ...)
any]{
Like @racket[raise-arity-error], but reports a ``result'' mismatch
instead of an ``argument'' mismatch. The @racket[name] argument can be
@racket[#f] to omit an initial source for the error. The
@racket[detail-str] argument, if non-@racket[#f], should be a string
that starts with a newline, since it is added near the end of the
generated error message.
@examples[
(eval:error (raise-result-arity-error 'let-values 2 "\n in: example" 'a 2.0 "three"))
]
@history[#:added "6.90.0.26"]}
@defproc[(raise-syntax-error [name (or/c symbol? #f)]
[message string?]

10
pkgs/racket-test-core/tests/racket/basic.rktl
View File

@ -2121,6 +2121,12 @@
(err/rt-test (raise-arity-error + (make-arity-at-least 5)) exn:fail:contract:arity?)
(err/rt-test (raise-arity-error + (list 1 (make-arity-at-least 5))) exn:fail:contract:arity?)
(err/rt-test (raise-result-arity-error 'f 5 #f) exn:fail:contract:arity?)
(err/rt-test (raise-result-arity-error #f 5 #f) exn:fail:contract:arity?)
(err/rt-test (raise-result-arity-error #f (expt 2 100) #f) exn:fail:contract:arity?)
(err/rt-test (raise-result-arity-error #f (expt 2 100) "\n in: extra") exn:fail:contract:arity?)
(err/rt-test (raise-result-arity-error #f (expt 2 100) "\n in: extra" 1 2 3 4 5) exn:fail:contract:arity?)
(define (exn:fail:contract:arity?/#f e) (not (exn:fail:contract:arity? e)))
(err/rt-test (raise-arity-error 'f -5) exn:fail:contract:arity?/#f)
@ -2130,7 +2136,9 @@
(err/rt-test (raise-arity-error 1 1) exn:fail:contract:arity?/#f)
(err/rt-test (raise-arity-error 1 1) exn:fail:contract?)
(err/rt-test (raise-result-arity-error "f" 7 #f) exn:fail:contract:arity?/#f)
(err/rt-test (raise-result-arity-error 'f -7 #f) exn:fail:contract:arity?/#f)
(err/rt-test (raise-result-arity-error 'f 7 #"oops") exn:fail:contract:arity?/#f)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; continuations

1
racket/src/cs/primitive/kernel.ss
View File

@ -695,6 +695,7 @@
[raise-mismatch-error (known-procedure -8)]
[raise-range-error (known-procedure 384)]
[raise-result-error (known-procedure -8)]
[raise-result-arity-error (known-procedure -16)]
[raise-type-error (known-procedure -8)]
[raise-user-error (known-procedure -2)]
[random (known-procedure 7)]

1
racket/src/cs/rumble.sls
View File

@ -181,6 +181,7 @@
raise-mismatch-error
raise-range-error
raise-arity-error
raise-result-arity-error
raise-type-error
raise-binding-result-arity-error ; not exported to Racket

2
racket/src/cs/rumble/control.ss
View File

@ -1511,7 +1511,7 @@
(call-with-values (lambda () (apply wrapper args))
(lambda new-args
(unless (= (length args) (length new-args))
(raise-result-arity-error at-when (length args) new-args))
(raise-result-arity-error #f (length args) (string-append "\n at: " at-when) new-args))
(when chaperone?
(for-each (lambda (arg new-arg)
(unless (chaperone-of? new-arg arg)

9
racket/src/cs/rumble/error.ss
View File

@ -339,20 +339,21 @@
(number->string (arity-at-least-value arity))))]
[else ""])))
(define (raise-result-arity-error where num-expected-args args)
(define (raise-result-arity-error who num-expected-args where args)
(raise
(|#%app|
exn:fail:contract:arity
(string-append
(if who (string-append (symbol->string who) ": ") "")
"result arity mismatch;\n"
" expected number of values not received\n"
" received: " (number->string (length args)) "\n"
" expected: " (number->string num-expected-args) "\n"
" in: " where)
" expected: " (number->string num-expected-args)
where)
(current-continuation-marks))))
(define (raise-binding-result-arity-error expected-args args)
(raise-result-arity-error "local-binding form" (length expected-args) args))
(raise-result-arity-error #f (length expected-args) "\n at: local-binding form" args))
(define raise-unsupported-error
(case-lambda

2
racket/src/expander/expand/body.rkt
View File

@ -173,7 +173,7 @@
(log-expand body-ctx 'prepare-env)
(prepare-next-phase-namespace ctx)
(log-expand body-ctx 'enter-bind)
(define vals (eval-for-syntaxes-binding (m 'rhs) ids body-ctx))
(define vals (eval-for-syntaxes-binding 'define-syntaxes (m 'rhs) ids body-ctx))
(define extended-env (for/fold ([env (expand-context-env body-ctx)]) ([key (in-list keys)]
[val (in-list vals)]
[id (in-list ids)])

3
racket/src/expander/expand/definition-context.rkt
View File

@ -84,7 +84,8 @@
(hash-set env sym variable)))
(log-expand ctx 'enter-bind)
(define vals
(eval-for-syntaxes-binding input-s ids
(eval-for-syntaxes-binding 'syntax-local-bind-syntaxes
input-s ids
(make-local-expand-context (struct*-copy expand-context ctx
[env tmp-env])
#:context 'expression

3
racket/src/expander/expand/expr.rkt
View File

@ -216,7 +216,8 @@
(define trans-valss (for/list ([rhs (in-list (if syntaxes? (stx-m 'trans-rhs) '()))]
[ids (in-list trans-idss)])
(log-expand* ctx ['next] ['enter-bind])
(define trans-val (eval-for-syntaxes-binding (add-scope rhs sc) ids ctx))
(define trans-val (eval-for-syntaxes-binding 'letrec-syntaxes+values
(add-scope rhs sc) ids ctx))
(log-expand ctx 'exit-bind)
trans-val))
;; Fill expansion-time environment:

20
racket/src/expander/expand/main.rkt
View File

@ -612,7 +612,7 @@
;; Expand and evaluate `s` as a compile-time expression, ensuring that
;; the number of returned values matches the number of target
;; identifiers; return the expanded form as well as its values
(define (expand+eval-for-syntaxes-binding rhs ids ctx
(define (expand+eval-for-syntaxes-binding who rhs ids ctx
#:log-next? [log-next? #t])
(define exp-rhs (expand-transformer rhs (as-named-context ctx ids)))
(define phase (add1 (expand-context-phase ctx)))
@ -623,7 +623,8 @@
(when log-next? (log-expand ctx 'next))
(values exp-rhs
parsed-rhs
(eval-for-bindings ids
(eval-for-bindings who
ids
parsed-rhs
phase
(namespace->namespace-at-phase
@ -633,15 +634,15 @@
;; Expand and evaluate `s` as a compile-time expression, returning
;; only the compile-time values
(define (eval-for-syntaxes-binding rhs ids ctx)
(define (eval-for-syntaxes-binding who rhs ids ctx)
(define-values (exp-rhs parsed-rhs vals)
(expand+eval-for-syntaxes-binding rhs ids ctx))
(expand+eval-for-syntaxes-binding who rhs ids ctx))
vals)
;; Expand and evaluate `s` as an expression in the given phase;
;; ensuring that the number of returned values matches the number of
;; target identifiers; return the values
(define (eval-for-bindings ids p phase ns ctx)
(define (eval-for-bindings who ids p phase ns ctx)
(define compiled (if (can-direct-eval? p ns (root-expand-context-self-mpi ctx))
#f
(compile-single p (make-compile-context
@ -657,8 +658,13 @@
(direct-eval p ns (root-expand-context-self-mpi ctx)))))
list))
(unless (= (length vals) (length ids))
(error "wrong number of results (" (length vals) "vs." (length ids) ")"
"from" p))
(apply raise-result-arity-error
who
(length ids)
(cond
[(null? ids) ""]
[else (format "\n in: definition of ~a~a" (syntax-e (car ids)) (if (pair? (cdr ids)) " ..." ""))])
vals))
vals)
;; ----------------------------------------

5
racket/src/expander/expand/module.rkt
View File

@ -793,7 +793,8 @@
(add-defined-syms! requires+provides syms phase #:as-transformer? #t)
;; Expand and evaluate RHS:
(define-values (exp-rhs parsed-rhs vals)
(expand+eval-for-syntaxes-binding (m 'rhs) ids
(expand+eval-for-syntaxes-binding 'define-syntaxes
(m 'rhs) ids
(struct*-copy expand-context partial-body-ctx
[lifts #f]
;; require lifts ok, others disallowed
@ -1273,7 +1274,7 @@
(cond
[(parsed-define-values? p)
(define ids (parsed-define-values-ids p))
(define vals (eval-for-bindings ids (parsed-define-values-rhs p) phase m-ns ctx))
(define vals (eval-for-bindings 'define-values ids (parsed-define-values-rhs p) phase m-ns ctx))
(for ([id (in-list ids)]
[sym (in-list (parsed-define-values-syms p))]
[val (in-list vals)])

54
racket/src/racket/src/error.c
View File

@ -105,6 +105,7 @@ static Scheme_Object *raise_mismatch_error(int argc, Scheme_Object *argv[]);
static Scheme_Object *raise_arguments_error(int argc, Scheme_Object *argv[]);
static Scheme_Object *raise_range_error(int argc, Scheme_Object *argv[]);
static Scheme_Object *raise_arity_error(int argc, Scheme_Object *argv[]);
static Scheme_Object *raise_result_arity_error(int argc, Scheme_Object *argv[]);
static Scheme_Object *error_escape_handler(int, Scheme_Object *[]);
static Scheme_Object *error_display_handler(int, Scheme_Object *[]);
static Scheme_Object *error_value_string_handler(int, Scheme_Object *[]);
@ -816,6 +817,7 @@ void scheme_init_error(Scheme_Startup_Env *env)
scheme_raise_arity_error_proc = scheme_make_noncm_prim(raise_arity_error, "raise-arity-error", 2, -1);
scheme_addto_prim_instance("raise-arity-error", scheme_raise_arity_error_proc, env);
ESCAPING_NONCM_PRIM("raise-result-arity-error", raise_result_arity_error, 2, -1, env);
ADD_PARAMETER("error-display-handler", error_display_handler, MZCONFIG_ERROR_DISPLAY_HANDLER, env);
ADD_PARAMETER("error-value->string-handler", error_value_string_handler, MZCONFIG_ERROR_PRINT_VALUE_HANDLER, env);
@ -2517,16 +2519,14 @@ void scheme_wrong_return_arity(const char *where,
"%s%sresult arity mismatch;\n"
" expected number of values not received\n"
" expected: %d\n"
" received: %d\n"
"%s%t%s"
" received: %d"
"%t\n"
" values...:%t",
where ? where : "",
where ? ": " : "",
expected,
got,
slen ? " from: " : "",
s, slen,
slen ? "\n" : "",
v, vlen);
scheme_raise_exn(MZEXN_FAIL_CONTRACT_ARITY,
@ -2981,7 +2981,7 @@ static Scheme_Object *raise_arity_error(int argc, Scheme_Object *argv[])
if (!scheme_nonneg_exact_p(argv[1])
&& !is_arity_at_least(argv[1])
&& !is_arity_list(argv[1]))
scheme_wrong_contract("raise-mismatch-error",
scheme_wrong_contract("raise-arity-error",
"(or/c exact-nonnegative-integer? arity-at-least? (listof (or/c exact-nonnegative-integer? arity-at-least?)))",
1, argc, argv);
@ -3017,6 +3017,50 @@ static Scheme_Object *raise_arity_error(int argc, Scheme_Object *argv[])
return NULL;
}
static Scheme_Object *raise_result_arity_error(int argc, Scheme_Object *argv[])
{
const char *where, *detail;
Scheme_Object **got_argv;
int i, expected;
if (SCHEME_FALSEP(argv[0]))
where = NULL;
else if (SCHEME_SYMBOLP(argv[0]))
where = scheme_symbol_val(argv[0]);
else
scheme_wrong_contract("raise-result-arity-error", "(or/c symbol? #f)", 0, argc, argv);
if (SCHEME_INTP(argv[1])) {
expected = SCHEME_INT_VAL(argv[1]);
} else if (SCHEME_BIGNUMP(argv[1]) && SCHEME_BIGPOS(argv[1]))
expected = (int)(((unsigned)-1) >> 1); /* not right, but as big as we can report */
else
expected = -1;
if (expected < 0)
scheme_wrong_contract("raise-result-arity-error", "exact-nonnegative-integer?", 1, argc, argv);
if (SCHEME_FALSEP(argv[2]))
detail = NULL;
else if (SCHEME_CHAR_STRINGP(argv[2])) {
Scheme_Object *bstr;
bstr = scheme_char_string_to_byte_string(argv[2]);
detail = SCHEME_BYTE_STR_VAL(bstr);
} else
scheme_wrong_contract("raise-result-arity-error", "(or/c string? #f)", 2, argc, argv);
got_argv = MALLOC_N(Scheme_Object*, argc-3);
for (i = 3; i < argc; i++) {
got_argv[i-3] = argv[i];
}
scheme_wrong_return_arity(where, expected,
argc-3, got_argv,
detail,
NULL);
return scheme_void;
}
static Scheme_Object *good_print_width(int c, Scheme_Object **argv)
{
int ok;

2
racket/src/racket/src/schminc.h
View File

@ -14,7 +14,7 @@
#define USE_COMPILED_STARTUP 1
#define EXPECTED_PRIM_COUNT 1430
#define EXPECTED_PRIM_COUNT 1431
#ifdef MZSCHEME_SOMETHING_OMITTED
# undef USE_COMPILED_STARTUP

4
racket/src/racket/src/schvers.h
View File

@ -13,12 +13,12 @@
consistently.)
*/
#define MZSCHEME_VERSION "6.90.0.25"
#define MZSCHEME_VERSION "6.90.0.26"
#define MZSCHEME_VERSION_X 6
#define MZSCHEME_VERSION_Y 90
#define MZSCHEME_VERSION_Z 0
#define MZSCHEME_VERSION_W 25
#define MZSCHEME_VERSION_W 26
#define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y)
#define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W)

5219
racket/src/racket/src/startup.inc
View File

File diff suppressed because it is too large Load Diff