370.4

svn: r6710

collects/drscheme/private/language-configuration.ss

@@ -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))

collects/mzlib/file.ss

@@ -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]

collects/syntax/modread.ss

@@ -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])

collects/tests/mzscheme/basic.ss

@@ -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)

collects/tests/mzscheme/param.ss

@@ -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))

doc/release-notes/mzscheme/HISTORY

@@ -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}
 

src/mzscheme/include/scheme.h

@@ -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,

src/mzscheme/src/portfun.c

@@ -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);

src/mzscheme/src/read.c

@@ -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;

src/mzscheme/src/schminc.h

@@ -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

src/mzscheme/src/schvers.h

@@ -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

src/mzscheme/src/thread.c

@@ -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])) {
+      param = argv[i];
+      while (1) {
+        if (SCHEME_PRIMP(param)) {
           Scheme_Prim *proc;
-	proc = (Scheme_Prim *)((Scheme_Primitive_Proc *)argv[i])->prim_val;
+          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 *)argv[i])->data, 2, a);
+          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;
 
-  pos[0] = ((ParamData *)data)->key;
+  if (data->is_derived) {
-  pos[1] = ((ParamData *)data)->defcell;
+    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);