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

update kernel parameter checks to new error-message format

Browse Source
This commit is contained in:
Matthew Flatt 2013-04-25 10:24:48 -06:00
parent bbb0d27e85
commit d977a2c65d
14 changed files with 217 additions and 146 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

15
collects/scribblings/inside/params.scrbl
View File

@ -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 always @cpp{1} and an array that contains the potential parameter
value. If @var{isbool} is @cpp{0} and @var{check} returns value. If @var{isbool} is @cpp{0} and @var{check} returns
@cpp{scheme_false}, then a type error is reported using @var{name} @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 reported only when @var{check} returns @cpp{NULL} and any
non-@cpp{NULL} return value is used as the actual value to be stored non-@cpp{NULL} return value is used as the actual value to be stored
for the parameter.} 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 This function is only available to embedding applications (i.e., not
extensions).} 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.}

4
collects/scribblings/reference/collects.scrbl
View File

@ -164,7 +164,9 @@ be used, instead, to support splicing of library-collection trees at
the file level.} 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 Parameter that determines a list of complete directory paths for
library collections used by @racket[require]. See library collections used by @racket[require]. See

3
collects/scribblings/reference/eval.scrbl
View File

@ -331,7 +331,8 @@ immediately expanded (see @secref["pathutils"]) and converted to a
path. (The directory need not exist.)} 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 A list of relative paths, which defaults to @racket[(list
(string->path "compiled"))]. It is used by the @tech{compiled-load (string->path "compiled"))]. It is used by the @tech{compiled-load

2
collects/scribblings/reference/read.scrbl
View File

@ -274,7 +274,7 @@ adjusts the parsing of S-expression input, where @racket[#f] implies the
default behavior. See @secref["readtables"] for more information.} 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 A @tech{parameter} that enables lazy parsing of compiled code, so that
closure bodies and syntax objects are extracted (and validated) from closure bodies and syntax objects are extracted (and validated) from

7
src/racket/include/scheme.h
View File

@ -1963,8 +1963,13 @@ MZ_EXTERN int scheme_new_param(void);
MZ_EXTERN Scheme_Object *scheme_param_config(char *name, Scheme_Object *pos, MZ_EXTERN Scheme_Object *scheme_param_config(char *name, Scheme_Object *pos,
int argc, Scheme_Object **argv, int argc, Scheme_Object **argv,
int arity, int arity,
Scheme_Prim *check, char *expected, Scheme_Prim *check, char *expected_type,
int isbool); 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); MZ_EXTERN Scheme_Object *scheme_register_parameter(Scheme_Prim *function, char *name, int which);
#endif /* SCHEME_DIRECT_EMBEDDED */ #endif /* SCHEME_DIRECT_EMBEDDED */

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

@ -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[]) static Scheme_Object *error_print_width(int argc, Scheme_Object *argv[])
{ {
return scheme_param_config("error-print-width", return scheme_param_config2("error-print-width",
scheme_make_integer(MZCONFIG_ERROR_PRINT_WIDTH), scheme_make_integer(MZCONFIG_ERROR_PRINT_WIDTH),
argc, argv, argc, argv,
-1, good_print_width, "exact integer greater than three", 0); -1, good_print_width, "(and/c exact-integer? (>=/c 3))", 0);
} }
static Scheme_Object *good_print_context_length(int c, Scheme_Object **argv) 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[]) static Scheme_Object *error_print_context_length(int argc, Scheme_Object *argv[])
{ {
return scheme_param_config("error-print-context-length", return scheme_param_config2("error-print-context-length",
scheme_make_integer(MZCONFIG_ERROR_PRINT_CONTEXT_LENGTH), scheme_make_integer(MZCONFIG_ERROR_PRINT_CONTEXT_LENGTH),
argc, argv, argc, argv,
-1, good_print_context_length, "non-negative integer", 0); -1, good_print_context_length, "exact-nonnegative-integer?", 0);
} }
static Scheme_Object *error_print_srcloc(int argc, Scheme_Object *argv[]) 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 * static Scheme_Object *
current_logger(int argc, Scheme_Object *argv[]) current_logger(int argc, Scheme_Object *argv[])
{ {
return scheme_param_config("current-logger", return scheme_param_config2("current-logger",
scheme_make_integer(MZCONFIG_LOGGER), scheme_make_integer(MZCONFIG_LOGGER),
argc, argv, argc, argv,
-1, logger_p, "logger", 0); -1, logger_p, "logger?", 0);
} }
static Scheme_Object * static Scheme_Object *

34
src/racket/src/file.c
View File

@ -5844,11 +5844,11 @@ static Scheme_Object *current_directory(int argc, Scheme_Object **argv)
if (!argc) if (!argc)
scheme_security_check_file("current-directory", NULL, SCHEME_GUARD_FILE_EXISTS); scheme_security_check_file("current-directory", NULL, SCHEME_GUARD_FILE_EXISTS);
return scheme_param_config("current-directory", return scheme_param_config2("current-directory",
scheme_make_integer(MZCONFIG_CURRENT_DIRECTORY), scheme_make_integer(MZCONFIG_CURRENT_DIRECTORY),
argc, argv, argc, argv,
-1, cwd_check, -1, cwd_check,
"complete path or string", 1); "path-string?", 1);
} }
#endif #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[]) static Scheme_Object *current_library_collection_paths(int argc, Scheme_Object *argv[])
{ {
return scheme_param_config("current-library-collection-paths", return scheme_param_config2("current-library-collection-paths",
scheme_make_integer(MZCONFIG_COLLECTION_PATHS), scheme_make_integer(MZCONFIG_COLLECTION_PATHS),
argc, argv, argc, argv,
-1, collpaths_p, "list of complete paths and strings", 1); -1, collpaths_p, "(listof (and/c path-string? complete-path?))", 1);
} }
#endif #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[]) static Scheme_Object *use_compiled_kind(int argc, Scheme_Object *argv[])
{ {
return scheme_param_config("use-compiled-file-paths", return scheme_param_config2("use-compiled-file-paths",
scheme_make_integer(MZCONFIG_USE_COMPILED_KIND), scheme_make_integer(MZCONFIG_USE_COMPILED_KIND),
argc, argv, argc, argv,
-1, compiled_kind_p, "list of relative paths and strings", 1); -1, compiled_kind_p, "(listof (and/c path-string? relative-path?))", 1);
} }
static Scheme_Object *compiled_roots_p(int argc, Scheme_Object **argv) 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[]) static Scheme_Object *compiled_file_roots(int argc, Scheme_Object *argv[])
{ {
return scheme_param_config("current-compiled-file-roots", return scheme_param_config2("current-compiled-file-roots",
scheme_make_integer(MZCONFIG_USE_COMPILED_ROOTS), scheme_make_integer(MZCONFIG_USE_COMPILED_ROOTS),
argc, argv, argc, argv,
-1, compiled_roots_p, "list of paths, string, and 'same", 1); -1, compiled_roots_p, "(listof (or/c path-string? 'same))", 1);
} }
static Scheme_Object *use_user_paths(int argc, Scheme_Object *argv[]) static Scheme_Object *use_user_paths(int argc, Scheme_Object *argv[])

41
src/racket/src/module.c
View File

@ -989,10 +989,13 @@ static Scheme_Object *check_resolver(int argc, Scheme_Object **argv)
static Scheme_Object * static Scheme_Object *
current_module_name_resolver(int argc, Scheme_Object *argv[]) current_module_name_resolver(int argc, Scheme_Object *argv[])
{ {
return scheme_param_config("current-module-name-resolver", return scheme_param_config2("current-module-name-resolver",
scheme_make_integer(MZCONFIG_CURRENT_MODULE_RESOLVER), scheme_make_integer(MZCONFIG_CURRENT_MODULE_RESOLVER),
argc, argv, argc, argv,
-1, check_resolver, "procedure of arity 1 and 4", 1); -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) 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 * static Scheme_Object *
current_module_name_prefix(int argc, Scheme_Object *argv[]) current_module_name_prefix(int argc, Scheme_Object *argv[])
{ {
return scheme_param_config("current-module-declared-name", return scheme_param_config2("current-module-declared-name",
scheme_make_integer(MZCONFIG_CURRENT_MODULE_NAME), scheme_make_integer(MZCONFIG_CURRENT_MODULE_NAME),
argc, argv, argc, argv,
-1, prefix_p, "resolved-module-path or #f", 1); -1, prefix_p, "(or/c resolved-module-path? #f)", 1);
} }
static Scheme_Object *source_p(int argc, Scheme_Object **argv) 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 * static Scheme_Object *
current_module_name_source(int argc, Scheme_Object *argv[]) current_module_name_source(int argc, Scheme_Object *argv[])
{ {
return scheme_param_config("current-module-declared-name", return scheme_param_config2("current-module-declared-name",
scheme_make_integer(MZCONFIG_CURRENT_MODULE_SRC), scheme_make_integer(MZCONFIG_CURRENT_MODULE_SRC),
argc, argv, argc, argv,
-1, source_p, "symbol, complete path, or #f", 1); -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) 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 * static Scheme_Object *
current_module_load_path(int argc, Scheme_Object *argv[]) current_module_load_path(int argc, Scheme_Object *argv[])
{ {
return scheme_param_config("current-module-path-for-load", return scheme_param_config2("current-module-path-for-load",
scheme_make_integer(MZCONFIG_CURRENT_MODULE_LOAD_PATH), scheme_make_integer(MZCONFIG_CURRENT_MODULE_LOAD_PATH),
argc, argv, argc, argv,
-1, load_path_p, "module path, module path as syntax, or #f", 1); -1, load_path_p,
"(or/c module-path?"
/**/ " (and/c syntax? (lambda (stx) (module-path? (syntax->datum stx))))"
/**/ " #f)",
1);
} }
/**********************************************************************/ /**********************************************************************/

16
src/racket/src/numstr.c
View File

@ -2814,18 +2814,18 @@ sch_unpack(int argc, Scheme_Object *argv[])
static Scheme_Object *current_pseudo_random_generator(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", return scheme_param_config2("current-pseudo-random-generator",
scheme_make_integer(MZCONFIG_RANDOM_STATE), scheme_make_integer(MZCONFIG_RANDOM_STATE),
argc, argv, argc, argv,
-1, pseudo_random_generator_p, "pseudo-random-generator", 0); -1, pseudo_random_generator_p, "pseudo-random-generator?", 0);
} }
static Scheme_Object *current_sched_pseudo_random_generator(int argc, Scheme_Object *argv[]) static Scheme_Object *current_sched_pseudo_random_generator(int argc, Scheme_Object *argv[])
{ {
return scheme_param_config("current-evt-pseudo-random-generator", return scheme_param_config2("current-evt-pseudo-random-generator",
scheme_make_integer(MZCONFIG_SCHEDULER_RANDOM_STATE), scheme_make_integer(MZCONFIG_SCHEDULER_RANDOM_STATE),
argc, argv, argc, argv,
-1, pseudo_random_generator_p, "pseudo-random-generator", 0); -1, pseudo_random_generator_p, "pseudo-random-generator?", 0);
} }
static Scheme_Object *make_pseudo_random_generator(int argc, Scheme_Object **argv) static Scheme_Object *make_pseudo_random_generator(int argc, Scheme_Object **argv)

6
src/racket/src/port.c
View File

@ -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[]) 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), return scheme_param_config2("current-subprocess-custodian-mode", scheme_make_integer(MZCONFIG_SUBPROC_CUSTODIAN_MODE),
argc, argv, argc, argv,
-1, subproc_cust_mode_p, "'interrupt, 'kill, or #f", 1); -1, subproc_cust_mode_p, "(or/c 'interrupt 'kill #f)", 1);
} }
static Scheme_Object *subproc_group_on (int argc, Scheme_Object *argv[]) static Scheme_Object *subproc_group_on (int argc, Scheme_Object *argv[])

49
src/racket/src/portfun.c
View File

@ -2240,23 +2240,23 @@ intptr_t scheme_port_closed_p (Scheme_Object *port) {
static Scheme_Object *current_input_port(int argc, Scheme_Object *argv[]) static Scheme_Object *current_input_port(int argc, Scheme_Object *argv[])
{ {
return scheme_param_config("current-input-port", scheme_make_integer(MZCONFIG_INPUT_PORT), return scheme_param_config2("current-input-port", scheme_make_integer(MZCONFIG_INPUT_PORT),
argc, argv, argc, argv,
-1, input_port_p, "input-port", 0); -1, input_port_p, "input-port?", 0);
} }
static Scheme_Object *current_output_port(int argc, Scheme_Object *argv[]) static Scheme_Object *current_output_port(int argc, Scheme_Object *argv[])
{ {
return scheme_param_config("current-output-port", scheme_make_integer(MZCONFIG_OUTPUT_PORT), return scheme_param_config2("current-output-port", scheme_make_integer(MZCONFIG_OUTPUT_PORT),
argc, argv, argc, argv,
-1, output_port_p, "output-port", 0); -1, output_port_p, "output-port?", 0);
} }
static Scheme_Object *current_error_port(int argc, Scheme_Object *argv[]) static Scheme_Object *current_error_port(int argc, Scheme_Object *argv[])
{ {
return scheme_param_config("current-error-port", scheme_make_integer(MZCONFIG_ERROR_PORT), return scheme_param_config2("current-error-port", scheme_make_integer(MZCONFIG_ERROR_PORT),
argc, argv, argc, argv,
-1, output_port_p, "output-port", 0); -1, output_port_p, "output-port?", 0);
} }
static Scheme_Object * 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[]) static Scheme_Object *global_port_print_handler(int argc, Scheme_Object *argv[])
{ {
return scheme_param_config("global-port-print-handler", return scheme_param_config2("global-port-print-handler",
scheme_make_integer(MZCONFIG_PORT_PRINT_HANDLER), scheme_make_integer(MZCONFIG_PORT_PRINT_HANDLER),
argc, argv, argc, argv,
-1, filter_print_handler, "procedure (arity 2)", 1); -1, filter_print_handler, "(procedure-arity-includes/c 2)", 1);
} }
static Scheme_Object *port_count_lines(int argc, Scheme_Object *argv[]) 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 * static Scheme_Object *
current_load_directory(int argc, Scheme_Object *argv[]) current_load_directory(int argc, Scheme_Object *argv[])
{ {
return scheme_param_config("current-load-relative-directory", return scheme_param_config2("current-load-relative-directory",
scheme_make_integer(MZCONFIG_LOAD_DIRECTORY), scheme_make_integer(MZCONFIG_LOAD_DIRECTORY),
argc, argv, argc, argv,
-1, lr_abs_directory_p, "path, string, or #f", 1); -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) 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 * static Scheme_Object *
current_write_directory(int argc, Scheme_Object *argv[]) current_write_directory(int argc, Scheme_Object *argv[])
{ {
return scheme_param_config("current-write-relative-directory", return scheme_param_config2("current-write-relative-directory",
scheme_make_integer(MZCONFIG_WRITE_DIRECTORY), scheme_make_integer(MZCONFIG_WRITE_DIRECTORY),
argc, argv, argc, argv,
-1, wr_abs_directory_p, "path, string, or #f", 1); -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 #ifdef LOAD_ON_DEMAND

44
src/racket/src/read.c
View File

@ -787,26 +787,34 @@ static Scheme_Object *good_syntax_width(int c, Scheme_Object **argv)
static Scheme_Object * static Scheme_Object *
print_syntax_width(int argc, Scheme_Object *argv[]) print_syntax_width(int argc, Scheme_Object *argv[])
{ {
return scheme_param_config("print-syntax-width", return scheme_param_config2("print-syntax-width",
scheme_make_integer(MZCONFIG_PRINT_SYNTAX_WIDTH), scheme_make_integer(MZCONFIG_PRINT_SYNTAX_WIDTH),
argc, argv, argc, argv,
-1, good_syntax_width, "+inf.0, 0, or exact integer greater than three", 0); -1, good_syntax_width,
"(or/c +inf.0 0 (and/c exact-integer? (>=/c 3)))", 0);
} }
#ifdef LOAD_ON_DEMAND #ifdef LOAD_ON_DEMAND
static Scheme_Object *rdl_check(int argc, Scheme_Object **argv) 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 * static Scheme_Object *
read_delay_load(int argc, Scheme_Object *argv[]) read_delay_load(int argc, Scheme_Object *argv[])
{ {
return scheme_param_config("read-on-demand-source", return scheme_param_config2("read-on-demand-source",
scheme_make_integer(MZCONFIG_DELAY_LOAD_INFO), scheme_make_integer(MZCONFIG_DELAY_LOAD_INFO),
argc, argv, argc, argv,
-1, rdl_check, -1, rdl_check,
"complete path or string, optionally paired with an exact integer", 1); "(or/c #f (and/c path-string? complete-path?))",
1);
} }
#endif #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) static Scheme_Object *current_readtable(int argc, Scheme_Object **argv)
{ {
return scheme_param_config("current-readtable", return scheme_param_config2("current-readtable",
scheme_make_integer(MZCONFIG_READTABLE), scheme_make_integer(MZCONFIG_READTABLE),
argc, argv, argc, argv,
-1, readtable_or_false_p, "readtable", 0); -1, readtable_or_false_p, "readtable?", 0);
} }
static Scheme_Object *current_reader_guard(int argc, Scheme_Object **argv) static Scheme_Object *current_reader_guard(int argc, Scheme_Object **argv)
{ {
return scheme_param_config("current-reader-guard", return scheme_param_config2("current-reader-guard",
scheme_make_integer(MZCONFIG_READER_GUARD), scheme_make_integer(MZCONFIG_READER_GUARD),
argc, argv, argc, argv,
1, NULL, NULL, 0); 1, NULL, NULL, 0);
} }
static Scheme_Object *no_val_thunk(void *d, int argc, Scheme_Object **argv) static Scheme_Object *no_val_thunk(void *d, int argc, Scheme_Object **argv)

24
src/racket/src/string.c
View File

@ -2124,10 +2124,10 @@ static Scheme_Object *current_environment_variables(int argc, Scheme_Object *arg
{ {
Scheme_Object *v; Scheme_Object *v;
v = scheme_param_config("current-environment-variables", v = scheme_param_config2("current-environment-variables",
scheme_make_integer(MZCONFIG_CURRENT_ENV_VARS), scheme_make_integer(MZCONFIG_CURRENT_ENV_VARS),
argc, argv, argc, argv,
-1, env_p, "environment-variables?", 0); -1, env_p, "environment-variables?", 0);
return v; 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[]) static Scheme_Object *cmdline_args(int argc, Scheme_Object *argv[])
{ {
return scheme_param_config("current-command-line-arguments", return scheme_param_config2("current-command-line-arguments",
scheme_make_integer(MZCONFIG_CMDLINE_ARGS), scheme_make_integer(MZCONFIG_CMDLINE_ARGS),
argc, argv, argc, argv,
-1, ok_cmdline, "vector of strings", 1); -1, ok_cmdline, "(vectorof string?)", 1);
} }
/**********************************************************************/ /**********************************************************************/
@ -2831,10 +2831,10 @@ static Scheme_Object *current_locale(int argc, Scheme_Object *argv[])
{ {
Scheme_Object *v; Scheme_Object *v;
v = scheme_param_config("current-locale", v = scheme_param_config2("current-locale",
scheme_make_integer(MZCONFIG_LOCALE), scheme_make_integer(MZCONFIG_LOCALE),
argc, argv, argc, argv,
-1, ok_locale, "#f or string", 1); -1, ok_locale, "(or/c #f string?)", 1);
return v; return v;
} }

94
src/racket/src/thread.c
View File

@ -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[]) static Scheme_Object *current_custodian(int argc, Scheme_Object *argv[])
{ {
return scheme_param_config("current-custodian", return scheme_param_config2("current-custodian",
scheme_make_integer(MZCONFIG_CUSTODIAN), scheme_make_integer(MZCONFIG_CUSTODIAN),
argc, argv, argc, argv,
-1, custodian_p, "custodian", 0); -1, custodian_p, "custodian?", 0);
} }
Scheme_Custodian *scheme_get_current_custodian() 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[]) static Scheme_Object *current_thread_set(int argc, Scheme_Object *argv[])
{ {
return scheme_param_config("current-thread-group", return scheme_param_config2("current-thread-group",
scheme_make_integer(MZCONFIG_THREAD_SET), scheme_make_integer(MZCONFIG_THREAD_SET),
argc, argv, argc, argv,
-1, thread_set_p, "thread-group", 0); -1, thread_set_p, "thread-group?", 0);
} }
static TSET_IL void set_t_set_next(Scheme_Object *o, Scheme_Object *n) 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 *); typedef Scheme_Object *(*PCheck_Proc)(int, Scheme_Object **, Scheme_Config *);
Scheme_Object *scheme_param_config(char *name, Scheme_Object *pos, static Scheme_Object *do_param_config(char *name, Scheme_Object *pos,
int argc, Scheme_Object **argv, int argc, Scheme_Object **argv,
int arity, int arity,
/* -3 => like -1, plus use check to unmarshall the value /* -3 => like -1, plus use check to unmarshall the value
-2 => user parameter; pos is array [key, defcell] -2 => user parameter; pos is array [key, defcell]
-1 => use check; if isboolorfilter, check is a filter -1 => use check; if isboolorfilter, check is a filter
(and expected is ignored), and if check is NULL, (and expected is ignored), and if check is NULL,
parameter is boolean-valued parameter is boolean-valued
0+ => check argument for this arity */ 0+ => check argument for this arity */
Scheme_Object *(*check)(int, Scheme_Object **), Scheme_Object *(*check)(int, Scheme_Object **),
/* Actually called with (int, S_O **, Scheme_Config *) */ /* Actually called with (int, S_O **, Scheme_Config *) */
char *expected, char *expected,
int isboolorfilter) int isboolorfilter,
int expected_is_contract)
{ {
Scheme_Config *config; Scheme_Config *config;
@ -7644,7 +7645,10 @@ Scheme_Object *scheme_param_config(char *name, Scheme_Object *pos,
r = NULL; r = NULL;
if (!r) { 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; 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 * static Scheme_Object *
exact_positive_integer_p (int argc, Scheme_Object *argv[]) 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[]) static Scheme_Object *current_thread_initial_stack_size(int argc, Scheme_Object *argv[])
{ {
return scheme_param_config("current-thread-initial-stack-size", return scheme_param_config2("current-thread-initial-stack-size",
scheme_make_integer(MZCONFIG_THREAD_INIT_STACK_SIZE), scheme_make_integer(MZCONFIG_THREAD_INIT_STACK_SIZE),
argc, argv, argc, argv,
-1, exact_positive_integer_p, "exact positive integer", 0); -1, exact_positive_integer_p, "exact-positive-integer?", 0);
} }
static Scheme_Object *phantom_bytes_p(int argc, Scheme_Object *argv[]) 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[]) static Scheme_Object *current_namespace(int argc, Scheme_Object *argv[])
{ {
return scheme_param_config("current-namespace", return scheme_param_config2("current-namespace",
scheme_make_integer(MZCONFIG_ENV), scheme_make_integer(MZCONFIG_ENV),
argc, argv, argc, argv,
-1, namespace_p, "namespace", 0); -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[]) static Scheme_Object *current_security_guard(int argc, Scheme_Object *argv[])
{ {
return scheme_param_config("current-security-guard", return scheme_param_config2("current-security-guard",
scheme_make_integer(MZCONFIG_SECURITY_GUARD), scheme_make_integer(MZCONFIG_SECURITY_GUARD),
argc, argv, argc, argv,
-1, security_guard_p, "security-guard", 0); -1, security_guard_p, "security-guard?", 0);
} }