From d977a2c65d2c459c33d88bf1c9209b553c2e3895 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 25 Apr 2013 10:24:48 -0600 Subject: [PATCH] update kernel parameter checks to new error-message format --- collects/scribblings/inside/params.scrbl | 15 ++- collects/scribblings/reference/collects.scrbl | 4 +- collects/scribblings/reference/eval.scrbl | 3 +- collects/scribblings/reference/read.scrbl | 2 +- src/racket/include/scheme.h | 7 +- src/racket/src/error.c | 24 ++--- src/racket/src/file.c | 34 +++---- src/racket/src/module.c | 41 ++++---- src/racket/src/numstr.c | 16 ++-- src/racket/src/port.c | 6 +- src/racket/src/portfun.c | 49 +++++----- src/racket/src/read.c | 44 +++++---- src/racket/src/string.c | 24 ++--- src/racket/src/thread.c | 94 ++++++++++++------- 14 files changed, 217 insertions(+), 146 deletions(-) diff --git a/collects/scribblings/inside/params.scrbl b/collects/scribblings/inside/params.scrbl index 9158c95c57..c0659feede 100644 --- a/collects/scribblings/inside/params.scrbl +++ b/collects/scribblings/inside/params.scrbl @@ -195,7 +195,7 @@ Call this procedure in a primitive parameter procedure to implement always @cpp{1} and an array that contains the potential parameter value. If @var{isbool} is @cpp{0} and @var{check} returns @cpp{scheme_false}, then a type error is reported using @var{name} - and @var{expected}. If @var{isbool} is @cpp{1}, then a type error is + and @var{expected} as a type description. If @var{isbool} is @cpp{1}, then a type error is reported only when @var{check} returns @cpp{NULL} and any non-@cpp{NULL} return value is used as the actual value to be stored for the parameter.} @@ -207,3 +207,16 @@ Call this procedure in a primitive parameter procedure to implement This function is only available to embedding applications (i.e., not extensions).} + +@function[(Scheme_Object* scheme_param_config2 + [char* name] + [Scheme_Object* param] + [int argc] + [Scheme_Object** argv] + [int arity] + [Scheme_Prim* check] + [char* expected_contract] + [int isbool])]{ + +The same as @cpp{scheme_param_config}, but with +@var{expected_contract} as a contract instead of type description.} diff --git a/collects/scribblings/reference/collects.scrbl b/collects/scribblings/reference/collects.scrbl index d55583774e..68b4aa5624 100644 --- a/collects/scribblings/reference/collects.scrbl +++ b/collects/scribblings/reference/collects.scrbl @@ -164,7 +164,9 @@ be used, instead, to support splicing of library-collection trees at the file level.} -@defparam[current-library-collection-paths paths (listof (and/c path? complete-path?))]{ +@defparam*[current-library-collection-paths paths + (listof (and/c path-string? complete-path?)) + (listof (and/c path? complete-path?))]{ Parameter that determines a list of complete directory paths for library collections used by @racket[require]. See diff --git a/collects/scribblings/reference/eval.scrbl b/collects/scribblings/reference/eval.scrbl index 2e53ef1cb6..16642e7479 100644 --- a/collects/scribblings/reference/eval.scrbl +++ b/collects/scribblings/reference/eval.scrbl @@ -331,7 +331,8 @@ immediately expanded (see @secref["pathutils"]) and converted to a path. (The directory need not exist.)} -@defparam*[use-compiled-file-paths paths (listof path-string?) (listof path?)]{ +@defparam*[use-compiled-file-paths paths (listof (and/c path-string? relative-path?)) + (listof (and/c path? relative-path?))]{ A list of relative paths, which defaults to @racket[(list (string->path "compiled"))]. It is used by the @tech{compiled-load diff --git a/collects/scribblings/reference/read.scrbl b/collects/scribblings/reference/read.scrbl index d1fdfb2c9d..6413873def 100644 --- a/collects/scribblings/reference/read.scrbl +++ b/collects/scribblings/reference/read.scrbl @@ -274,7 +274,7 @@ adjusts the parsing of S-expression input, where @racket[#f] implies the default behavior. See @secref["readtables"] for more information.} -@defparam[read-on-demand-source path (and/c path? complete-path?)]{ +@defparam[read-on-demand-source path (or/c #f (and/c path? complete-path?))]{ A @tech{parameter} that enables lazy parsing of compiled code, so that closure bodies and syntax objects are extracted (and validated) from diff --git a/src/racket/include/scheme.h b/src/racket/include/scheme.h index d3d54241de..0077a9d99b 100644 --- a/src/racket/include/scheme.h +++ b/src/racket/include/scheme.h @@ -1963,8 +1963,13 @@ MZ_EXTERN int scheme_new_param(void); MZ_EXTERN Scheme_Object *scheme_param_config(char *name, Scheme_Object *pos, int argc, Scheme_Object **argv, int arity, - Scheme_Prim *check, char *expected, + Scheme_Prim *check, char *expected_type, int isbool); +MZ_EXTERN Scheme_Object *scheme_param_config2(char *name, Scheme_Object *pos, + int argc, Scheme_Object **argv, + int arity, + Scheme_Prim *check, char *expected_contract, + int isbool); MZ_EXTERN Scheme_Object *scheme_register_parameter(Scheme_Prim *function, char *name, int which); #endif /* SCHEME_DIRECT_EMBEDDED */ diff --git a/src/racket/src/error.c b/src/racket/src/error.c index 2b5544c710..4af0111b87 100644 --- a/src/racket/src/error.c +++ b/src/racket/src/error.c @@ -3017,10 +3017,10 @@ static Scheme_Object *good_print_width(int c, Scheme_Object **argv) static Scheme_Object *error_print_width(int argc, Scheme_Object *argv[]) { - return scheme_param_config("error-print-width", - scheme_make_integer(MZCONFIG_ERROR_PRINT_WIDTH), - argc, argv, - -1, good_print_width, "exact integer greater than three", 0); + return scheme_param_config2("error-print-width", + scheme_make_integer(MZCONFIG_ERROR_PRINT_WIDTH), + argc, argv, + -1, good_print_width, "(and/c exact-integer? (>=/c 3))", 0); } static Scheme_Object *good_print_context_length(int c, Scheme_Object **argv) @@ -3038,10 +3038,10 @@ static Scheme_Object *good_print_context_length(int c, Scheme_Object **argv) static Scheme_Object *error_print_context_length(int argc, Scheme_Object *argv[]) { - return scheme_param_config("error-print-context-length", - scheme_make_integer(MZCONFIG_ERROR_PRINT_CONTEXT_LENGTH), - argc, argv, - -1, good_print_context_length, "non-negative integer", 0); + return scheme_param_config2("error-print-context-length", + scheme_make_integer(MZCONFIG_ERROR_PRINT_CONTEXT_LENGTH), + argc, argv, + -1, good_print_context_length, "exact-nonnegative-integer?", 0); } static Scheme_Object *error_print_srcloc(int argc, Scheme_Object *argv[]) @@ -3902,10 +3902,10 @@ logger_p(int argc, Scheme_Object *argv[]) static Scheme_Object * current_logger(int argc, Scheme_Object *argv[]) { - return scheme_param_config("current-logger", - scheme_make_integer(MZCONFIG_LOGGER), - argc, argv, - -1, logger_p, "logger", 0); + return scheme_param_config2("current-logger", + scheme_make_integer(MZCONFIG_LOGGER), + argc, argv, + -1, logger_p, "logger?", 0); } static Scheme_Object * diff --git a/src/racket/src/file.c b/src/racket/src/file.c index c5cfb7aaad..395f28506d 100644 --- a/src/racket/src/file.c +++ b/src/racket/src/file.c @@ -5844,11 +5844,11 @@ static Scheme_Object *current_directory(int argc, Scheme_Object **argv) if (!argc) scheme_security_check_file("current-directory", NULL, SCHEME_GUARD_FILE_EXISTS); - return scheme_param_config("current-directory", - scheme_make_integer(MZCONFIG_CURRENT_DIRECTORY), - argc, argv, - -1, cwd_check, - "complete path or string", 1); + return scheme_param_config2("current-directory", + scheme_make_integer(MZCONFIG_CURRENT_DIRECTORY), + argc, argv, + -1, cwd_check, + "path-string?", 1); } #endif @@ -5923,10 +5923,10 @@ Scheme_Object *scheme_current_library_collection_paths(int argc, Scheme_Object * static Scheme_Object *current_library_collection_paths(int argc, Scheme_Object *argv[]) { - return scheme_param_config("current-library-collection-paths", - scheme_make_integer(MZCONFIG_COLLECTION_PATHS), - argc, argv, - -1, collpaths_p, "list of complete paths and strings", 1); + return scheme_param_config2("current-library-collection-paths", + scheme_make_integer(MZCONFIG_COLLECTION_PATHS), + argc, argv, + -1, collpaths_p, "(listof (and/c path-string? complete-path?))", 1); } #endif @@ -5938,10 +5938,10 @@ static Scheme_Object *compiled_kind_p(int argc, Scheme_Object **argv) static Scheme_Object *use_compiled_kind(int argc, Scheme_Object *argv[]) { - return scheme_param_config("use-compiled-file-paths", - scheme_make_integer(MZCONFIG_USE_COMPILED_KIND), - argc, argv, - -1, compiled_kind_p, "list of relative paths and strings", 1); + return scheme_param_config2("use-compiled-file-paths", + scheme_make_integer(MZCONFIG_USE_COMPILED_KIND), + argc, argv, + -1, compiled_kind_p, "(listof (and/c path-string? relative-path?))", 1); } static Scheme_Object *compiled_roots_p(int argc, Scheme_Object **argv) @@ -5956,10 +5956,10 @@ Scheme_Object *scheme_compiled_file_roots(int argc, Scheme_Object *argv[]) static Scheme_Object *compiled_file_roots(int argc, Scheme_Object *argv[]) { - return scheme_param_config("current-compiled-file-roots", - scheme_make_integer(MZCONFIG_USE_COMPILED_ROOTS), - argc, argv, - -1, compiled_roots_p, "list of paths, string, and 'same", 1); + return scheme_param_config2("current-compiled-file-roots", + scheme_make_integer(MZCONFIG_USE_COMPILED_ROOTS), + argc, argv, + -1, compiled_roots_p, "(listof (or/c path-string? 'same))", 1); } static Scheme_Object *use_user_paths(int argc, Scheme_Object *argv[]) diff --git a/src/racket/src/module.c b/src/racket/src/module.c index 0c09a4d116..c986b561b9 100644 --- a/src/racket/src/module.c +++ b/src/racket/src/module.c @@ -989,10 +989,13 @@ static Scheme_Object *check_resolver(int argc, Scheme_Object **argv) static Scheme_Object * current_module_name_resolver(int argc, Scheme_Object *argv[]) { - return scheme_param_config("current-module-name-resolver", - scheme_make_integer(MZCONFIG_CURRENT_MODULE_RESOLVER), - argc, argv, - -1, check_resolver, "procedure of arity 1 and 4", 1); + return scheme_param_config2("current-module-name-resolver", + scheme_make_integer(MZCONFIG_CURRENT_MODULE_RESOLVER), + argc, argv, + -1, check_resolver, + "(and/c (procedure-arity-includes/c 1)" + /* */ " (procedure-arity-includes/c 4))", + 1); } static Scheme_Object *prefix_p(int argc, Scheme_Object **argv) @@ -1008,10 +1011,10 @@ static Scheme_Object *prefix_p(int argc, Scheme_Object **argv) static Scheme_Object * current_module_name_prefix(int argc, Scheme_Object *argv[]) { - return scheme_param_config("current-module-declared-name", - scheme_make_integer(MZCONFIG_CURRENT_MODULE_NAME), - argc, argv, - -1, prefix_p, "resolved-module-path or #f", 1); + return scheme_param_config2("current-module-declared-name", + scheme_make_integer(MZCONFIG_CURRENT_MODULE_NAME), + argc, argv, + -1, prefix_p, "(or/c resolved-module-path? #f)", 1); } static Scheme_Object *source_p(int argc, Scheme_Object **argv) @@ -1032,10 +1035,12 @@ static Scheme_Object *source_p(int argc, Scheme_Object **argv) static Scheme_Object * current_module_name_source(int argc, Scheme_Object *argv[]) { - return scheme_param_config("current-module-declared-name", - scheme_make_integer(MZCONFIG_CURRENT_MODULE_SRC), - argc, argv, - -1, source_p, "symbol, complete path, or #f", 1); + return scheme_param_config2("current-module-declared-name", + scheme_make_integer(MZCONFIG_CURRENT_MODULE_SRC), + argc, argv, + -1, source_p, + "(or/c symbol? (and/c path-string? complete-path?) #f)", + 1); } static Scheme_Object *load_path_p(int argc, Scheme_Object **argv) @@ -1054,10 +1059,14 @@ static Scheme_Object *load_path_p(int argc, Scheme_Object **argv) static Scheme_Object * current_module_load_path(int argc, Scheme_Object *argv[]) { - return scheme_param_config("current-module-path-for-load", - scheme_make_integer(MZCONFIG_CURRENT_MODULE_LOAD_PATH), - argc, argv, - -1, load_path_p, "module path, module path as syntax, or #f", 1); + return scheme_param_config2("current-module-path-for-load", + scheme_make_integer(MZCONFIG_CURRENT_MODULE_LOAD_PATH), + argc, argv, + -1, load_path_p, + "(or/c module-path?" + /**/ " (and/c syntax? (lambda (stx) (module-path? (syntax->datum stx))))" + /**/ " #f)", + 1); } /**********************************************************************/ diff --git a/src/racket/src/numstr.c b/src/racket/src/numstr.c index d1596a1d19..3705e89025 100644 --- a/src/racket/src/numstr.c +++ b/src/racket/src/numstr.c @@ -2814,18 +2814,18 @@ sch_unpack(int argc, Scheme_Object *argv[]) static Scheme_Object *current_pseudo_random_generator(int argc, Scheme_Object *argv[]) { - return scheme_param_config("current-pseudo-random-generator", - scheme_make_integer(MZCONFIG_RANDOM_STATE), - argc, argv, - -1, pseudo_random_generator_p, "pseudo-random-generator", 0); + return scheme_param_config2("current-pseudo-random-generator", + scheme_make_integer(MZCONFIG_RANDOM_STATE), + argc, argv, + -1, pseudo_random_generator_p, "pseudo-random-generator?", 0); } static Scheme_Object *current_sched_pseudo_random_generator(int argc, Scheme_Object *argv[]) { - return scheme_param_config("current-evt-pseudo-random-generator", - scheme_make_integer(MZCONFIG_SCHEDULER_RANDOM_STATE), - argc, argv, - -1, pseudo_random_generator_p, "pseudo-random-generator", 0); + return scheme_param_config2("current-evt-pseudo-random-generator", + scheme_make_integer(MZCONFIG_SCHEDULER_RANDOM_STATE), + argc, argv, + -1, pseudo_random_generator_p, "pseudo-random-generator?", 0); } static Scheme_Object *make_pseudo_random_generator(int argc, Scheme_Object **argv) diff --git a/src/racket/src/port.c b/src/racket/src/port.c index cd68937005..f75ee683c3 100644 --- a/src/racket/src/port.c +++ b/src/racket/src/port.c @@ -8948,9 +8948,9 @@ static Scheme_Object *subproc_cust_mode_p(int argc, Scheme_Object **argv) static Scheme_Object *current_subproc_cust_mode (int argc, Scheme_Object *argv[]) { - return scheme_param_config("current-subprocess-custodian-mode", scheme_make_integer(MZCONFIG_SUBPROC_CUSTODIAN_MODE), - argc, argv, - -1, subproc_cust_mode_p, "'interrupt, 'kill, or #f", 1); + return scheme_param_config2("current-subprocess-custodian-mode", scheme_make_integer(MZCONFIG_SUBPROC_CUSTODIAN_MODE), + argc, argv, + -1, subproc_cust_mode_p, "(or/c 'interrupt 'kill #f)", 1); } static Scheme_Object *subproc_group_on (int argc, Scheme_Object *argv[]) diff --git a/src/racket/src/portfun.c b/src/racket/src/portfun.c index 35a2bb277e..230d1f8890 100644 --- a/src/racket/src/portfun.c +++ b/src/racket/src/portfun.c @@ -2240,23 +2240,23 @@ intptr_t scheme_port_closed_p (Scheme_Object *port) { static Scheme_Object *current_input_port(int argc, Scheme_Object *argv[]) { - return scheme_param_config("current-input-port", scheme_make_integer(MZCONFIG_INPUT_PORT), - argc, argv, - -1, input_port_p, "input-port", 0); + return scheme_param_config2("current-input-port", scheme_make_integer(MZCONFIG_INPUT_PORT), + argc, argv, + -1, input_port_p, "input-port?", 0); } static Scheme_Object *current_output_port(int argc, Scheme_Object *argv[]) { - return scheme_param_config("current-output-port", scheme_make_integer(MZCONFIG_OUTPUT_PORT), - argc, argv, - -1, output_port_p, "output-port", 0); + return scheme_param_config2("current-output-port", scheme_make_integer(MZCONFIG_OUTPUT_PORT), + argc, argv, + -1, output_port_p, "output-port?", 0); } static Scheme_Object *current_error_port(int argc, Scheme_Object *argv[]) { - return scheme_param_config("current-error-port", scheme_make_integer(MZCONFIG_ERROR_PORT), - argc, argv, - -1, output_port_p, "output-port", 0); + return scheme_param_config2("current-error-port", scheme_make_integer(MZCONFIG_ERROR_PORT), + argc, argv, + -1, output_port_p, "output-port?", 0); } static Scheme_Object * @@ -4257,10 +4257,10 @@ static Scheme_Object *filter_print_handler(int argc, Scheme_Object **argv) static Scheme_Object *global_port_print_handler(int argc, Scheme_Object *argv[]) { - return scheme_param_config("global-port-print-handler", - scheme_make_integer(MZCONFIG_PORT_PRINT_HANDLER), - argc, argv, - -1, filter_print_handler, "procedure (arity 2)", 1); + return scheme_param_config2("global-port-print-handler", + scheme_make_integer(MZCONFIG_PORT_PRINT_HANDLER), + argc, argv, + -1, filter_print_handler, "(procedure-arity-includes/c 2)", 1); } static Scheme_Object *port_count_lines(int argc, Scheme_Object *argv[]) @@ -4901,10 +4901,12 @@ static Scheme_Object *lr_abs_directory_p(int argc, Scheme_Object **argv) static Scheme_Object * current_load_directory(int argc, Scheme_Object *argv[]) { - return scheme_param_config("current-load-relative-directory", - scheme_make_integer(MZCONFIG_LOAD_DIRECTORY), - argc, argv, - -1, lr_abs_directory_p, "path, string, or #f", 1); + return scheme_param_config2("current-load-relative-directory", + scheme_make_integer(MZCONFIG_LOAD_DIRECTORY), + argc, argv, + -1, lr_abs_directory_p, + "(or/c (and/c path-string? complete-path?) #f)", + 1); } static Scheme_Object *wr_abs_directory_p(int argc, Scheme_Object **argv) @@ -4929,10 +4931,15 @@ static Scheme_Object *wr_abs_directory_p(int argc, Scheme_Object **argv) static Scheme_Object * current_write_directory(int argc, Scheme_Object *argv[]) { - return scheme_param_config("current-write-relative-directory", - scheme_make_integer(MZCONFIG_WRITE_DIRECTORY), - argc, argv, - -1, wr_abs_directory_p, "path, string, or #f", 1); + return scheme_param_config2("current-write-relative-directory", + scheme_make_integer(MZCONFIG_WRITE_DIRECTORY), + argc, argv, + -1, wr_abs_directory_p, + "(or/c (and/c path-string? complete-path?)" + /**/ " (cons/c (and/c path-string? complete-path?)" + /* */ " (and/c path-string? complete-path?))" + /**/ " #f)", + 1); } #ifdef LOAD_ON_DEMAND diff --git a/src/racket/src/read.c b/src/racket/src/read.c index 59944af419..ac4d62c8b0 100644 --- a/src/racket/src/read.c +++ b/src/racket/src/read.c @@ -787,26 +787,34 @@ static Scheme_Object *good_syntax_width(int c, Scheme_Object **argv) static Scheme_Object * print_syntax_width(int argc, Scheme_Object *argv[]) { - return scheme_param_config("print-syntax-width", - scheme_make_integer(MZCONFIG_PRINT_SYNTAX_WIDTH), - argc, argv, - -1, good_syntax_width, "+inf.0, 0, or exact integer greater than three", 0); + return scheme_param_config2("print-syntax-width", + scheme_make_integer(MZCONFIG_PRINT_SYNTAX_WIDTH), + argc, argv, + -1, good_syntax_width, + "(or/c +inf.0 0 (and/c exact-integer? (>=/c 3)))", 0); } #ifdef LOAD_ON_DEMAND static Scheme_Object *rdl_check(int argc, Scheme_Object **argv) { - return argv[0]; + Scheme_Object *s = argv[0]; + + return (SCHEME_FALSEP(s) + || (SCHEME_PATHP(s) + && scheme_is_complete_path(SCHEME_PATH_VAL(s), + SCHEME_PATH_LEN(s), + SCHEME_PLATFORM_PATH_KIND))); } static Scheme_Object * read_delay_load(int argc, Scheme_Object *argv[]) { - return scheme_param_config("read-on-demand-source", - scheme_make_integer(MZCONFIG_DELAY_LOAD_INFO), - argc, argv, - -1, rdl_check, - "complete path or string, optionally paired with an exact integer", 1); + return scheme_param_config2("read-on-demand-source", + scheme_make_integer(MZCONFIG_DELAY_LOAD_INFO), + argc, argv, + -1, rdl_check, + "(or/c #f (and/c path-string? complete-path?))", + 1); } #endif @@ -6286,18 +6294,18 @@ static Scheme_Object *readtable_or_false_p(int argc, Scheme_Object **argv) static Scheme_Object *current_readtable(int argc, Scheme_Object **argv) { - return scheme_param_config("current-readtable", - scheme_make_integer(MZCONFIG_READTABLE), - argc, argv, - -1, readtable_or_false_p, "readtable", 0); + return scheme_param_config2("current-readtable", + scheme_make_integer(MZCONFIG_READTABLE), + argc, argv, + -1, readtable_or_false_p, "readtable?", 0); } static Scheme_Object *current_reader_guard(int argc, Scheme_Object **argv) { - return scheme_param_config("current-reader-guard", - scheme_make_integer(MZCONFIG_READER_GUARD), - argc, argv, - 1, NULL, NULL, 0); + return scheme_param_config2("current-reader-guard", + scheme_make_integer(MZCONFIG_READER_GUARD), + argc, argv, + 1, NULL, NULL, 0); } static Scheme_Object *no_val_thunk(void *d, int argc, Scheme_Object **argv) diff --git a/src/racket/src/string.c b/src/racket/src/string.c index e90b1db390..77fbaeac5e 100644 --- a/src/racket/src/string.c +++ b/src/racket/src/string.c @@ -2124,10 +2124,10 @@ static Scheme_Object *current_environment_variables(int argc, Scheme_Object *arg { Scheme_Object *v; - v = scheme_param_config("current-environment-variables", - scheme_make_integer(MZCONFIG_CURRENT_ENV_VARS), - argc, argv, - -1, env_p, "environment-variables?", 0); + v = scheme_param_config2("current-environment-variables", + scheme_make_integer(MZCONFIG_CURRENT_ENV_VARS), + argc, argv, + -1, env_p, "environment-variables?", 0); return v; } @@ -2800,10 +2800,10 @@ static Scheme_Object *ok_cmdline(int argc, Scheme_Object **argv) static Scheme_Object *cmdline_args(int argc, Scheme_Object *argv[]) { - return scheme_param_config("current-command-line-arguments", - scheme_make_integer(MZCONFIG_CMDLINE_ARGS), - argc, argv, - -1, ok_cmdline, "vector of strings", 1); + return scheme_param_config2("current-command-line-arguments", + scheme_make_integer(MZCONFIG_CMDLINE_ARGS), + argc, argv, + -1, ok_cmdline, "(vectorof string?)", 1); } /**********************************************************************/ @@ -2831,10 +2831,10 @@ static Scheme_Object *current_locale(int argc, Scheme_Object *argv[]) { Scheme_Object *v; - v = scheme_param_config("current-locale", - scheme_make_integer(MZCONFIG_LOCALE), - argc, argv, - -1, ok_locale, "#f or string", 1); + v = scheme_param_config2("current-locale", + scheme_make_integer(MZCONFIG_LOCALE), + argc, argv, + -1, ok_locale, "(or/c #f string?)", 1); return v; } diff --git a/src/racket/src/thread.c b/src/racket/src/thread.c index 231ca2a059..17b32e963d 100644 --- a/src/racket/src/thread.c +++ b/src/racket/src/thread.c @@ -1588,10 +1588,10 @@ static Scheme_Object *custodian_to_list(int argc, Scheme_Object *argv[]) static Scheme_Object *current_custodian(int argc, Scheme_Object *argv[]) { - return scheme_param_config("current-custodian", - scheme_make_integer(MZCONFIG_CUSTODIAN), - argc, argv, - -1, custodian_p, "custodian", 0); + return scheme_param_config2("current-custodian", + scheme_make_integer(MZCONFIG_CUSTODIAN), + argc, argv, + -1, custodian_p, "custodian?", 0); } Scheme_Custodian *scheme_get_current_custodian() @@ -1917,10 +1917,10 @@ static Scheme_Object *thread_set_p(int argc, Scheme_Object *argv[]) static Scheme_Object *current_thread_set(int argc, Scheme_Object *argv[]) { - return scheme_param_config("current-thread-group", - scheme_make_integer(MZCONFIG_THREAD_SET), - argc, argv, - -1, thread_set_p, "thread-group", 0); + return scheme_param_config2("current-thread-group", + scheme_make_integer(MZCONFIG_THREAD_SET), + argc, argv, + -1, thread_set_p, "thread-group?", 0); } static TSET_IL void set_t_set_next(Scheme_Object *o, Scheme_Object *n) @@ -7588,19 +7588,20 @@ Scheme_Object *scheme_register_parameter(Scheme_Prim *function, char *name, int typedef Scheme_Object *(*PCheck_Proc)(int, Scheme_Object **, Scheme_Config *); -Scheme_Object *scheme_param_config(char *name, Scheme_Object *pos, - int argc, Scheme_Object **argv, - int arity, - /* -3 => like -1, plus use check to unmarshall the value - -2 => user parameter; pos is array [key, defcell] - -1 => use check; if isboolorfilter, check is a filter - (and expected is ignored), and if check is NULL, - parameter is boolean-valued - 0+ => check argument for this arity */ - Scheme_Object *(*check)(int, Scheme_Object **), - /* Actually called with (int, S_O **, Scheme_Config *) */ - char *expected, - int isboolorfilter) +static Scheme_Object *do_param_config(char *name, Scheme_Object *pos, + int argc, Scheme_Object **argv, + int arity, + /* -3 => like -1, plus use check to unmarshall the value + -2 => user parameter; pos is array [key, defcell] + -1 => use check; if isboolorfilter, check is a filter + (and expected is ignored), and if check is NULL, + parameter is boolean-valued + 0+ => check argument for this arity */ + Scheme_Object *(*check)(int, Scheme_Object **), + /* Actually called with (int, S_O **, Scheme_Config *) */ + char *expected, + int isboolorfilter, + int expected_is_contract) { Scheme_Config *config; @@ -7644,7 +7645,10 @@ Scheme_Object *scheme_param_config(char *name, Scheme_Object *pos, r = NULL; if (!r) { - scheme_wrong_type(name, expected, 0, 1, argv); + if (expected_is_contract) + scheme_wrong_contract(name, expected, 0, 1, argv); + else + scheme_wrong_type(name, expected, 0, 1, argv); return NULL; } @@ -7677,6 +7681,28 @@ Scheme_Object *scheme_param_config(char *name, Scheme_Object *pos, } } +Scheme_Object *scheme_param_config(char *name, Scheme_Object *pos, + int argc, Scheme_Object **argv, + int arity, + Scheme_Object *(*check)(int, Scheme_Object **), + char *expected_type, + int isboolorfilter) +{ + return do_param_config(name, pos, argc, argv, arity, check, + expected_type, isboolorfilter, 0); +} + +Scheme_Object *scheme_param_config2(char *name, Scheme_Object *pos, + int argc, Scheme_Object **argv, + int arity, + Scheme_Object *(*check)(int, Scheme_Object **), + char *expected_contract, + int isboolorfilter) +{ + return do_param_config(name, pos, argc, argv, arity, check, + expected_contract, isboolorfilter, 1); +} + static Scheme_Object * exact_positive_integer_p (int argc, Scheme_Object *argv[]) { @@ -7691,10 +7717,10 @@ exact_positive_integer_p (int argc, Scheme_Object *argv[]) static Scheme_Object *current_thread_initial_stack_size(int argc, Scheme_Object *argv[]) { - return scheme_param_config("current-thread-initial-stack-size", - scheme_make_integer(MZCONFIG_THREAD_INIT_STACK_SIZE), - argc, argv, - -1, exact_positive_integer_p, "exact positive integer", 0); + return scheme_param_config2("current-thread-initial-stack-size", + scheme_make_integer(MZCONFIG_THREAD_INIT_STACK_SIZE), + argc, argv, + -1, exact_positive_integer_p, "exact-positive-integer?", 0); } static Scheme_Object *phantom_bytes_p(int argc, Scheme_Object *argv[]) @@ -7790,10 +7816,10 @@ static Scheme_Object *namespace_p(int argc, Scheme_Object **argv) static Scheme_Object *current_namespace(int argc, Scheme_Object *argv[]) { - return scheme_param_config("current-namespace", - scheme_make_integer(MZCONFIG_ENV), - argc, argv, - -1, namespace_p, "namespace", 0); + return scheme_param_config2("current-namespace", + scheme_make_integer(MZCONFIG_ENV), + argc, argv, + -1, namespace_p, "namespace?", 0); } /*========================================================================*/ @@ -7831,10 +7857,10 @@ static Scheme_Object *security_guard_p(int argc, Scheme_Object *argv[]) static Scheme_Object *current_security_guard(int argc, Scheme_Object *argv[]) { - return scheme_param_config("current-security-guard", - scheme_make_integer(MZCONFIG_SECURITY_GUARD), - argc, argv, - -1, security_guard_p, "security-guard", 0); + return scheme_param_config2("current-security-guard", + scheme_make_integer(MZCONFIG_SECURITY_GUARD), + argc, argv, + -1, security_guard_p, "security-guard?", 0); }