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

370.4

Browse Source 
svn: r6710
This commit is contained in:
Matthew Flatt 2007-06-20 21:11:38 +00:00
parent 67575ca88f
commit d518f24039
13 changed files with 1745 additions and 1598 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
collects/drscheme/private/language-configuration.ss
View File

@ -1300,6 +1300,7 @@
(λ ()
(read-square-bracket-as-paren #f)
(read-curly-brace-as-paren #f)
(read-accept-infix-dot #f)
(print-vector-length #f))))
(define/override (default-settings)
(drscheme:language:make-simple-settings #f 'write 'mixed-fraction-e #f #t 'debug))

1
collects/mzlib/file.ss
View File

@ -284,6 +284,7 @@
[read-accept-graph #t]
[read-decimal-as-inexact #t]
[read-accept-dot #t]
[read-accept-infix-dot #t]
[read-accept-quasiquote #t]
[read-accept-reader #f]
[print-struct #f]

1
collects/syntax/modread.ss
View File

@ -15,6 +15,7 @@
[read-accept-graph #t]
[read-decimal-as-inexact #t]
[read-accept-dot #t]
[read-accept-infix-dot #t]
[read-accept-quasiquote #t]
[read-accept-reader #t]
[current-readtable #f])

10
collects/tests/mzscheme/basic.ss
View File

@ -2061,6 +2061,16 @@
(test #f hash-table? (make-hash-table 'weak) 'weak 'equal)
(test #t hash-table? (make-hash-table 'weak 'equal) 'weak 'equal)
;; Check for proper clearing of weak hash tables
;; (internally, value should get cleared along with key):
(let ([ht (make-hash-table 'weak)])
(let loop ([n 10])
(unless (zero? n)
(hash-table-put! ht (make-string 10) #f)
(loop (sub1 n))))
(collect-garbage)
(map (lambda (i) (format "~a" i)) (hash-table-map ht cons)))
;; Double check that table are equal after deletions
(let ([test-del-eq
(lambda (flags)

62
collects/tests/mzscheme/param.ss
View File

@ -67,6 +67,7 @@
x
(add1 'x)))))
(define test-param3 (make-parameter 'three list))
(define test-param4 (make-derived-parameter test-param3 box))
(test 'one test-param1)
(test 'two test-param2)
@ -91,20 +92,75 @@
(test-param3 'other-three)
(test '(other-three) test-param3)
(test '(other-three) test-param4)
(test-param3 'three)
(test '(three) test-param3)
(test '(three) test-param4)
(parameterize ([test-param3 'yet-another-three])
(test '(yet-another-three) test-param3)
(test '(yet-another-three) test-param4)
(parameterize ([test-param3 'yet-another-three!!])
(test '(yet-another-three!!) test-param3))
(test '(yet-another-three!!) test-param3)
(test '(yet-another-three!!) test-param4))
(test-param3 'more-three?)
(test '(more-three?) test-param3)
(test '(more-three?) test-param4)
(parameterize ([test-param3 'yet-another-three!!!])
(test '(yet-another-three!!!) test-param3)
(test '(yet-another-three!!!) test-param4)
(test-param3 'more-three??)
(test '(more-three??) test-param3))
(test '(more-three?) test-param3))
(test '(more-three??) test-param3)
(test '(more-three??) test-param4))
(test '(more-three?) test-param3)
(test '(more-three?) test-param4))
(test '(three) test-param3)
(test '(three) test-param4)
(test-param4 'other-three)
(test '(#&other-three) test-param3)
(test '(#&other-three) test-param4)
(parameterize ([test-param4 'yet-another-three])
(test '(#&yet-another-three) test-param3)
(test '(#&yet-another-three) test-param4))
(let ([cd (make-derived-parameter current-directory values)])
(test (current-directory) cd)
(let* ([v (current-directory)]
[sub (path->directory-path (build-path v "sub"))])
(cd "sub")
(test sub cd)
(test sub current-directory)
(cd v)
(test v cd)
(test v current-directory)
(parameterize ([cd "sub"])
(test sub cd)
(test sub current-directory))
(test v cd)
(test v current-directory)
(parameterize ([current-directory "sub"])
(test sub cd)
(test sub current-directory))))
(let ([l null])
(let ([cd (make-derived-parameter current-directory
(lambda (x)
(set! l (cons x l))
"sub"))]
[v (current-directory)])
(let ([sub (path->directory-path (build-path v "sub"))])
(parameterize ([cd "foo"])
(test '("foo") values l)
(test sub cd)
(test sub current-directory))
(test v cd)
(test v current-directory)
(cd "goo")
(test '("goo" "foo") values l)
(test sub cd)
(test sub current-directory)
(current-directory v)
(test '("goo" "foo") values l)
(test v cd)
(test v current-directory))))
(arity-test make-parameter 1 2)
(err/rt-test (make-parameter 0 zero-arg-proc))

4
doc/release-notes/mzscheme/HISTORY
View File

@ -1,3 +1,7 @@
Version 370.4
Added read-accept-infix-dot
Added make-derived-parameter
Version 370.3
Added hash-table-iterate-{first,next,key,value}

1
src/mzscheme/include/scheme.h
View File

@ -1126,6 +1126,7 @@ enum {
MZCONFIG_CAN_READ_BOX,
MZCONFIG_CAN_READ_PIPE_QUOTE,
MZCONFIG_CAN_READ_DOT,
MZCONFIG_CAN_READ_INFIX_DOT,
MZCONFIG_CAN_READ_QUASI,
MZCONFIG_CAN_READ_READER,
MZCONFIG_READ_DECIMAL_INEXACT,

3159
src/mzscheme/src/cstartup.inc
View File

File diff suppressed because it is too large Load Diff

1
src/mzscheme/src/portfun.c
View File

@ -4562,6 +4562,7 @@ static Scheme_Object *default_load(int argc, Scheme_Object *argv[])
config = scheme_extend_config(config, MZCONFIG_CAN_READ_BOX, scheme_true);
config = scheme_extend_config(config, MZCONFIG_CAN_READ_PIPE_QUOTE, scheme_true);
config = scheme_extend_config(config, MZCONFIG_CAN_READ_DOT, scheme_true);
config = scheme_extend_config(config, MZCONFIG_CAN_READ_INFIX_DOT, scheme_true);
config = scheme_extend_config(config, MZCONFIG_CAN_READ_QUASI, scheme_true);
config = scheme_extend_config(config, MZCONFIG_CAN_READ_READER, scheme_true);
config = scheme_extend_config(config, MZCONFIG_READ_DECIMAL_INEXACT, scheme_true);

20
src/mzscheme/src/read.c
View File

@ -65,6 +65,7 @@ static Scheme_Object *read_accept_box(int, Scheme_Object *[]);
static Scheme_Object *read_accept_pipe_quote(int, Scheme_Object *[]);
static Scheme_Object *read_decimal_as_inexact(int, Scheme_Object *[]);
static Scheme_Object *read_accept_dot(int, Scheme_Object *[]);
static Scheme_Object *read_accept_infix_dot(int, Scheme_Object *[]);
static Scheme_Object *read_accept_quasi(int, Scheme_Object *[]);
static Scheme_Object *read_accept_reader(int, Scheme_Object *[]);
#ifdef LOAD_ON_DEMAND
@ -125,6 +126,7 @@ typedef struct ReadParams {
int curly_braces_are_parens;
int read_decimal_inexact;
int can_read_dot;
int can_read_infix_dot;
int can_read_quasi;
int honu_mode;
Readtable *table;
@ -480,6 +482,11 @@ void scheme_init_read(Scheme_Env *env)
"read-accept-dot",
MZCONFIG_CAN_READ_DOT),
env);
scheme_add_global_constant("read-accept-infix-dot",
scheme_register_parameter(read_accept_infix_dot,
"read-accept-infix-dot",
MZCONFIG_CAN_READ_INFIX_DOT),
env);
scheme_add_global_constant("read-accept-quasiquote",
scheme_register_parameter(read_accept_quasi,
"read-accept-quasiquote",
@ -680,6 +687,12 @@ read_accept_dot(int argc, Scheme_Object *argv[])
DO_CHAR_PARAM("read-accept-dot", MZCONFIG_CAN_READ_DOT);
}
static Scheme_Object *
read_accept_infix_dot(int argc, Scheme_Object *argv[])
{
DO_CHAR_PARAM("read-accept-infix-dot", MZCONFIG_CAN_READ_INFIX_DOT);
}
static Scheme_Object *
read_accept_quasi(int argc, Scheme_Object *argv[])
{
@ -1983,6 +1996,8 @@ _scheme_internal_read(Scheme_Object *port, Scheme_Object *stxsrc, int crc, int h
params.can_read_quasi = SCHEME_TRUEP(v);
v = scheme_get_param(config, MZCONFIG_CAN_READ_DOT);
params.can_read_dot = SCHEME_TRUEP(v);
v = scheme_get_param(config, MZCONFIG_CAN_READ_INFIX_DOT);
params.can_read_infix_dot = SCHEME_TRUEP(v);
if (!delay_load_info)
delay_load_info = scheme_get_param(config, MZCONFIG_DELAY_LOAD_INFO);
if (SCHEME_TRUEP(delay_load_info))
@ -2535,7 +2550,9 @@ read_list(Scheme_Object *port,
ch = skip_whitespace_comments(port, stxsrc, ht, indentation, params);
effective_ch = readtable_effective_char(params->table, ch);
if (effective_ch != closer) {
if ((effective_ch == '.') && next_is_delim(port, params, brackets, braces)) {
if (params->can_read_infix_dot
&& (effective_ch == '.')
&& next_is_delim(port, params, brackets, braces)) {
/* Parse as infix: */
if (shape == mz_shape_hash_elem) {
@ -4261,6 +4278,7 @@ static Scheme_Object *read_compact(CPort *port, int use_stack)
params.curly_braces_are_parens = 1;
params.read_decimal_inexact = 1;
params.can_read_dot = 1;
params.can_read_infix_dot = 1;
params.can_read_quasi = 1;
params.honu_mode = 0;
params.table = NULL;

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

@ -13,7 +13,7 @@
#define USE_COMPILED_STARTUP 1
#define EXPECTED_PRIM_COUNT 902
#define EXPECTED_PRIM_COUNT 904
#ifdef MZSCHEME_SOMETHING_OMITTED
# undef USE_COMPILED_STARTUP

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

@ -9,6 +9,6 @@
#define MZSCHEME_VERSION_MAJOR 370
#define MZSCHEME_VERSION_MINOR 3
#define MZSCHEME_VERSION_MINOR 4
#define MZSCHEME_VERSION "370.3" _MZ_SPECIAL_TAG
#define MZSCHEME_VERSION "370.4" _MZ_SPECIAL_TAG

77
src/mzscheme/src/thread.c
View File

@ -330,6 +330,7 @@ static Scheme_Object *namespace_p(int argc, Scheme_Object *args[]);
static Scheme_Object *parameter_p(int argc, Scheme_Object *args[]);
static Scheme_Object *parameter_procedure_eq(int argc, Scheme_Object *args[]);
static Scheme_Object *make_parameter(int argc, Scheme_Object *args[]);
static Scheme_Object *make_derived_parameter(int argc, Scheme_Object *args[]);
static Scheme_Object *extend_parameterization(int argc, Scheme_Object *args[]);
static Scheme_Object *parameterization_p(int argc, Scheme_Object *args[]);
@ -385,6 +386,7 @@ Scheme_Object *mtrace_cmark_key = NULL;
typedef struct {
MZTAG_IF_REQUIRED
short is_derived;
Scheme_Object *key;
Scheme_Object *guard;
Scheme_Object *defcell;
@ -644,6 +646,11 @@ void scheme_init_thread(Scheme_Env *env)
"make-parameter",
1, 2),
env);
scheme_add_global_constant("make-derived-parameter",
scheme_make_prim_w_arity(make_derived_parameter,
"make-derived-parameter",
2, 2),
env);
scheme_add_global_constant("parameter-procedure=?",
scheme_make_prim_w_arity(parameter_procedure_eq,
"parameter-procedure=?",
@ -6026,7 +6033,7 @@ static Scheme_Object *parameterization_p(int argc, Scheme_Object **argv)
static Scheme_Object *extend_parameterization(int argc, Scheme_Object *argv[])
{
Scheme_Object *key, *a[2];
Scheme_Object *key, *a[2], *param;
Scheme_Config *c;
int i;
@ -6042,13 +6049,22 @@ static Scheme_Object *extend_parameterization(int argc, Scheme_Object *argv[])
}
a[0] = argv[i + 1];
a[1] = scheme_false;
if (SCHEME_PRIMP(argv[i])) {
Scheme_Prim *proc;
proc = (Scheme_Prim *)((Scheme_Primitive_Proc *)argv[i])->prim_val;
key = proc(2, a); /* leads to scheme_param_config to set a[1] */
} else {
/* sets a[1] */
key = do_param(((Scheme_Closed_Primitive_Proc *)argv[i])->data, 2, a);
param = argv[i];
while (1) {
if (SCHEME_PRIMP(param)) {
Scheme_Prim *proc;
proc = (Scheme_Prim *)((Scheme_Primitive_Proc *)param)->prim_val;
key = proc(2, a); /* leads to scheme_param_config to set a[1] */
break;
} else {
/* sets a[1] */
key = do_param(((Scheme_Closed_Primitive_Proc *)param)->data, 2, a);
if (SCHEME_PARAMETERP(key)) {
param = key;
a[0] = a[1];
} else
break;
}
}
c = do_extend_config(c, key, a[1]);
}
@ -6066,12 +6082,13 @@ static Scheme_Object *parameter_p(int argc, Scheme_Object **argv)
: scheme_false);
}
static Scheme_Object *do_param(void *data, int argc, Scheme_Object *argv[])
static Scheme_Object *do_param(void *_data, int argc, Scheme_Object *argv[])
{
Scheme_Object *guard, **argv2, *pos[2];
ParamData *data = (ParamData *)_data;
if (argc && argv[0]) {
guard = ((ParamData *)data)->guard;
guard = data->guard;
if (guard) {
Scheme_Object *v;
@ -6080,7 +6097,7 @@ static Scheme_Object *do_param(void *data, int argc, Scheme_Object *argv[])
if (argc == 2) {
/* Special hook for parameterize: */
argv[1] = v;
return ((ParamData *)data)->key;
return data->key;
}
argv2 = MALLOC_N(Scheme_Object *, argc);
@ -6089,14 +6106,18 @@ static Scheme_Object *do_param(void *data, int argc, Scheme_Object *argv[])
} else if (argc == 2) {
/* Special hook for parameterize: */
argv[1] = argv[0];
return ((ParamData *)data)->key;
return data->key;
} else
argv2 = argv;
} else
argv2 = argv;
argv2 = argv;
pos[0] = ((ParamData *)data)->key;
pos[1] = ((ParamData *)data)->defcell;
if (data->is_derived) {
return _scheme_tail_apply(data->key, argc, argv2);
}
pos[0] = data->key;
pos[1] = data->defcell;
return scheme_param_config("parameter-procedure",
(Scheme_Object *)(void *)pos,
@ -6131,6 +6152,31 @@ static Scheme_Object *make_parameter(int argc, Scheme_Object **argv)
return p;
}
static Scheme_Object *make_derived_parameter(int argc, Scheme_Object **argv)
{
Scheme_Object *p;
ParamData *data;
if (!SCHEME_PARAMETERP(argv[0]))
scheme_wrong_type("make-derived-parameter", "parameter", 0, argc, argv);
scheme_check_proc_arity("make-derived-parameter", 1, 1, argc, argv);
data = MALLOC_ONE_RT(ParamData);
#ifdef MZTAG_REQUIRED
data->type = scheme_rt_param_data;
#endif
data->is_derived = 1;
data->key = argv[0];
data->guard = argv[1];
p = scheme_make_closed_prim_w_arity(do_param, (void *)data,
"parameter-procedure", 0, 1);
((Scheme_Primitive_Proc *)p)->pp.flags |= SCHEME_PRIM_IS_PARAMETER;
return p;
}
static Scheme_Object *parameter_procedure_eq(int argc, Scheme_Object **argv)
{
Scheme_Object *a, *b;
@ -6200,6 +6246,7 @@ static void make_initial_config(Scheme_Thread *p)
init_param(cells, paramz, MZCONFIG_CAN_READ_BOX, scheme_true);
init_param(cells, paramz, MZCONFIG_CAN_READ_PIPE_QUOTE, scheme_true);
init_param(cells, paramz, MZCONFIG_CAN_READ_DOT, scheme_true);
init_param(cells, paramz, MZCONFIG_CAN_READ_INFIX_DOT, scheme_true);
init_param(cells, paramz, MZCONFIG_CAN_READ_QUASI, scheme_true);
init_param(cells, paramz, MZCONFIG_READ_DECIMAL_INEXACT, scheme_true);
init_param(cells, paramz, MZCONFIG_CAN_READ_READER, scheme_false);