fix equal-hashing of characters, and also correct potential 3m allocations problem (at least on 64-bit machines, for now) in MzScheme/MrEd start-up

svn: r6156

collects/tests/mzscheme/basic.ss

@@ -105,6 +105,10 @@
 (test #f equal? (make-vector 5 'b) (make-vector 5 'a))
 (test #f equal? (box "a") (box "b"))
 
+(test #t equal? #\a #\a)
+(test #t equal? (integer->char 1024) (integer->char 1024))
+(test #f equal? (integer->char 1024) (integer->char 1025))
+
 (arity-test eq? 2 2)
 (arity-test eqv? 2 2)
 (arity-test equal? 2 2)
@@ -1935,7 +1939,8 @@
 			    (hash-table-put! h1 (save 123456789123456789123456789) 'bignum)
 			    (hash-table-put! h1 (save 3.45) 'flonum)
 			    (hash-table-put! h1 (save 3/45) 'rational)
-			    (hash-table-put! h1 (save 3+45i) 'complex))]
+			    (hash-table-put! h1 (save 3+45i) 'complex)
+                            (hash-table-put! h1 (save (integer->char 955)) 'char))]
 		   [puts2 (lambda ()
 			    (hash-table-put! h1 (save (list 5 7)) 'another-list)
 			    (hash-table-put! h1 (save 3+0.0i) 'izi-complex)
@@ -1950,7 +1955,7 @@
 		     (puts1))
 		   (begin 
 		     (puts1) 
-		     (test 6 hash-table-count h1)
+		     (test 7 hash-table-count h1)
 		     (puts2))))
 
              (when reorder?
@@ -1962,7 +1967,7 @@
                    (loop (add1 i))
                    (hash-table-remove! h1 i))))
 
-	     (test 12 hash-table-count h1)
+	     (test 13 hash-table-count h1)
 	     (test 'list hash-table-get h1 l)
 	     (test 'list hash-table-get h1 (list 1 2 3))
 	     (test 'another-list hash-table-get h1 (list 5 7))
@@ -1980,6 +1985,7 @@
 	     (test #f hash-table-get h1 (make-ax 1 2) (lambda () #f))
 	     (test 'box hash-table-get h1 b)
 	     (test 'box hash-table-get h1 #&(1 2 3))
+	     (test 'char hash-table-get h1 (integer->char 955))
 	     (test #t
 		   andmap
 		   (lambda (i)
@@ -1997,13 +2003,14 @@
 		     (#(5 6 7) . vector)
 		     (,(make-a 1 (make-a 2 3)) . struct)
 		     (,an-ax . structx)
+                     (#\u3BB . char)
 		     (#&(1 2 3) . box)))
 	     (hash-table-remove! h1 (list 1 2 3))
-	     (test 11 hash-table-count h1)
+	     (test 12 hash-table-count h1)
 	     (test 'not-there hash-table-get h1 l (lambda () 'not-there))
 	     (let ([c 0])
 	       (hash-table-for-each h1 (lambda (k v) (set! c (add1 c))))
-	       (test 11 'count c))
+	       (test 12 'count c))
 	     ;; return the hash table:
 	     h1))])
 

src/mred/mrmain.cxx

@@ -176,7 +176,7 @@ static void do_graph_repl(Scheme_Env *env)
   p->error_buf = &newbuf;
 
   if (!scheme_setjmp(newbuf)) {
-    if (xfa->alternate_rep)
+    if (xfa->a->alternate_rep)
       scheme_eval_string("(read-eval-print-loop)", env);
     else
       scheme_eval_string("(graphical-read-eval-print-loop)", env);
@@ -200,7 +200,7 @@ static int do_main_loop(FinishArgs *fa)
   xfa = fa;
 
 #ifdef wx_mac
-  if (!fa->no_front) {
+  if (!fa->a->no_front) {
     ProcessSerialNumber psn;
     GetCurrentProcess(&psn);    
     SetFrontProcess(&psn); /* kCurrentProcess doesn't work */

src/mzscheme/cmdline.inc

@@ -285,12 +285,14 @@ static char *make_embedded_load(const char *start, const char *end)
 #define mzcmd_LOAD 1
 #define mzcmd_MAIN 2
 
+/* To avoid having to create a specific mark procedure for
+   prcise GC, split argument information into purely atomic
+   and purely non-atomic records. */
+
 typedef struct {
   int start_with_req;
 #ifndef DONT_PARSE_COMMAND_LINE
-  char **evals_and_loads;
-  int *eval_kind, num_enl;
-  Scheme_Object *main_args;
+  int num_enl;
 #endif  
 #ifndef DONT_LOAD_INIT_FILE
   int no_init_file;
@@ -305,6 +307,15 @@ typedef struct {
 #ifdef CMDLINE_STDIO_FLAG
   int alternate_rep;
   int no_front;
+#endif
+} FinishArgsAtoms;
+
+typedef struct {
+  FinishArgsAtoms *a;
+#ifndef DONT_PARSE_COMMAND_LINE
+  char **evals_and_loads;
+  int *eval_kind;
+  Scheme_Object *main_args;
 #endif  
   Scheme_Env *global_env;
 } FinishArgs;
@@ -315,12 +326,12 @@ static int finish_cmd_line_run(FinishArgs *fa, Repl_Proc repl)
 {
   volatile int exit_val = 0;
 
-  if (fa->start_with_req) {
+  if (fa->a->start_with_req) {
     scheme_eval_string("(require mzscheme)", fa->global_env);    
   }
 
 #ifndef DONT_LOAD_INIT_FILE
-  if (!fa->no_init_file) {
+  if (!fa->a->no_init_file) {
     char *filename;
     filename = GET_INIT_FILENAME(fa->global_env);
     if (filename) {
@@ -336,7 +347,7 @@ static int finish_cmd_line_run(FinishArgs *fa, Repl_Proc repl)
     volatile int i;
     mz_jmp_buf * volatile save, newbuf;
 
-    for (i = 0; i < fa->num_enl; i++) {
+    for (i = 0; i < fa->a->num_enl; i++) {
       if (fa->eval_kind[i] == mzcmd_LOAD) {
 	if (!scheme_load(fa->evals_and_loads[i])) {
 	  exit_val = 1;
@@ -404,7 +415,7 @@ static int finish_cmd_line_run(FinishArgs *fa, Repl_Proc repl)
 #endif
 
 #ifndef DONT_RUN_REP
-  if (!fa->no_rep && !fa->script_mode) {
+  if (!fa->a->no_rep && !fa->a->script_mode) {
     /* enter read-eval-print loop */
     mz_jmp_buf * volatile save, newbuf;
     Scheme_Thread * volatile p;
@@ -417,7 +428,7 @@ static int finish_cmd_line_run(FinishArgs *fa, Repl_Proc repl)
     } else {
       exit_val = 1;
 #ifdef VERSION_YIELD_FLAG
-      fa->add_yield = 0;
+      fa->a->add_yield = 0;
 #endif
     }
     p->error_buf = save;
@@ -425,7 +436,7 @@ static int finish_cmd_line_run(FinishArgs *fa, Repl_Proc repl)
 #endif /* DONT_RUN_REP */
 
 #ifdef VERSION_YIELD_FLAG
-  if (fa->add_yield) {
+  if (fa->a->add_yield) {
     mz_jmp_buf * volatile save, newbuf;
     Scheme_Thread * volatile p;
     p = scheme_get_current_thread();
@@ -532,6 +543,7 @@ static int run_from_cmd_line(int argc, char *_argv[],
 #endif
   int no_lib_path = 0;
   FinishArgs *fa;
+  FinishArgsAtoms *fa_a;
 
 #ifdef GC_THINKS_ITS_A_DLL_BUT_ISNT
   DllMain(NULL, DLL_PROCESS_ATTACH, NULL);
@@ -1198,27 +1210,29 @@ static int run_from_cmd_line(int argc, char *_argv[],
     init_mred(global_env);
 #endif
 
+  fa_a = (FinishArgsAtoms *)scheme_malloc_atomic(sizeof(FinishArgsAtoms));
   fa = (FinishArgs *)scheme_malloc(sizeof(FinishArgs));
-  fa->start_with_req = start_with_req;
+  fa->a = fa_a;
+  fa->a->start_with_req = start_with_req;
 #ifndef DONT_PARSE_COMMAND_LINE
   fa->evals_and_loads = evals_and_loads;
   fa->eval_kind = eval_kind;
-  fa->num_enl = num_enl;
+  fa->a->num_enl = num_enl;
   fa->main_args = sch_argv;
 #endif  
 #ifndef DONT_LOAD_INIT_FILE
-  fa->no_init_file = no_init_file;
+  fa->a->no_init_file = no_init_file;
 #endif
 #ifndef DONT_RUN_REP
-  fa->no_rep = no_rep;
-  fa->script_mode = script_mode;
+  fa->a->no_rep = no_rep;
+  fa->a->script_mode = script_mode;
 #endif
 #ifdef VERSION_YIELD_FLAG
-  fa->add_yield = add_yield;
+  fa->a->add_yield = add_yield;
 #endif
 #ifdef CMDLINE_STDIO_FLAG
-  fa->alternate_rep = alternate_rep;
-  fa->no_front = no_front;
+  fa->a->alternate_rep = alternate_rep;
+  fa->a->no_front = no_front;
 #endif
   fa->global_env = global_env;
 

src/mzscheme/src/hash.c

@@ -953,6 +953,8 @@ static long equal_hash_key(Scheme_Object *o, long k)
       o = SCHEME_VEC_ELS(o)[len];
       break;
     }
+  case scheme_char_type:
+    return k + SCHEME_CHAR_VAL(o);
   case scheme_byte_string_type:
   case scheme_unix_path_type:
   case scheme_windows_path_type:
@@ -1183,6 +1185,8 @@ long scheme_equal_hash_key2(Scheme_Object *o)
       
       return k;
     }
+  case scheme_char_type:
+    return t;
   case scheme_byte_string_type:
   case scheme_unix_path_type:
   case scheme_windows_path_type: