fail.[ch], stacks.c: ajout de l'exception Stack_overflow

printexc.c: meilleur affichage
memory.c: parentheser comme le suggere gcc


git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@1552 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02

byterun/fail.c

@@ -102,6 +102,11 @@ void raise_out_of_memory()
   mlraise((value) &(out_of_memory_bucket.exn));
 }
 
+void raise_stack_overflow()
+{
+  raise_constant(Field(global_data, STACK_OVERFLOW_EXN));
+}
+
 void raise_sys_error(msg)
      value msg;
 {

byterun/fail.h

@@ -27,6 +27,7 @@
 #define ZERO_DIVIDE_EXN 5       /* "Division_by_zero" */
 #define NOT_FOUND_EXN 6         /* "Not_found" */
 #define MATCH_FAILURE_EXN 7     /* "Match_failure" */
+#define STACK_OVERFLOW_EXN 8    /* "Stack_overflow" */
 
 #ifdef POSIX_SIGNALS
 struct longjmp_buffer {
@@ -50,6 +51,7 @@ void raise_with_string P((value tag, char * msg)) Noreturn;
 void failwith P((char *)) Noreturn;
 void invalid_argument P((char *)) Noreturn;
 void raise_out_of_memory P((void)) Noreturn;
+void raise_stack_overflow P((void)) Noreturn;
 void raise_sys_error P((value)) Noreturn;
 void raise_end_of_file P((void)) Noreturn;
 void raise_zero_divide P((void)) Noreturn;

byterun/memory.c

@@ -187,11 +187,11 @@ value alloc_shr (wosize, tag)
   Assert (Is_in_heap (Val_hp (hp)));
 
   if (gc_phase == Phase_mark
-      || gc_phase == Phase_sweep && (addr)hp >= (addr)gc_sweep_hp){
+      || (gc_phase == Phase_sweep && (addr)hp >= (addr)gc_sweep_hp)){
     Hd_hp (hp) = Make_header (wosize, tag, Black);
   }else{
     Assert (gc_phase == Phase_idle
-	    || gc_phase == Phase_sweep && (addr)hp < (addr)gc_sweep_hp);
+	    || (gc_phase == Phase_sweep && (addr)hp < (addr)gc_sweep_hp));
     Hd_hp (hp) = Make_header (wosize, tag, White);
   }
   allocated_words += Whsize_wosize (wosize);

byterun/printexc.c

@@ -15,6 +15,7 @@
 
 #include <stdio.h>
 #include <stdlib.h>
+#include <string.h>
 #include "fail.h"
 #include "misc.h"
 #include "mlvalues.h"
@@ -22,37 +23,79 @@
 #include "ui.h"
 #endif
 
+struct stringbuf {
+  char * ptr;
+  char * end;
+  char data[256];
+};
+
+static void add_char(buf, c)
+     struct stringbuf * buf;
+     char c;
+{
+  if (buf->ptr < buf->end) *(buf->ptr++) = c;
+}
+
+static void add_string(buf, s)
+     struct stringbuf * buf;
+     char * s;
+{
+  int len = strlen(s);
+  if (buf->ptr + len > buf->end) len = buf->end - buf->ptr;
+  if (len > 0) bcopy(s, buf->ptr, len);
+  buf->ptr += len;
+}
+  
 #ifdef HAS_UI
-#define errprintf1(fmt) ui_print_stderr(fmt, NULL)
-#define errprintf2(fmt,arg) ui_print_stderr(fmt, (char *)(arg))
+#define errprintf(fmt,arg) ui_print_stderr(fmt, arg)
 #else
-#define errprintf1(fmt) fprintf(stderr, fmt)
-#define errprintf2(fmt,arg) fprintf(stderr, fmt, arg)
+#define errprintf(fmt,arg) fprintf(stderr, fmt, arg)
 #endif
 
 void fatal_uncaught_exception(exn)
      value exn;
 {
-  mlsize_t i;
-  value v;
+  mlsize_t start, i;
+  value bucket, v;
+  struct stringbuf buf;
+  char intbuf[64];
 
-  errprintf2("Fatal error: uncaught exception %s",
-             String_val(Field(Field(exn, 0), 0)));
+  buf.ptr = buf.data;
+  buf.end = buf.data + sizeof(buf.data) - 1;
+  add_string(&buf, String_val(Field(Field(exn, 0), 0)));
   if (Wosize_val(exn) >= 2) {
-    errprintf1("(");
-    for (i = 1; i < Wosize_val(exn); i++) {
-      if (i > 1) errprintf1(", ");
-      v = Field(exn, i);
-      if (Is_long(v))
-        errprintf2("%ld", Long_val(v));
-      else if (Tag_val(v) == String_tag)
-        errprintf2("\"%s\"", String_val(v));
-      else
-        errprintf1("_");
+    /* Check for exceptions in the style of Match_failure and Assert_failure */
+    if (Wosize_val(exn) == 2 &&
+        Is_block(Field(exn, 1)) &&
+        Tag_val(Field(exn, 1)) == 0) {
+      bucket = Field(exn, 1);
+      start = 0;
+    } else {
+      bucket = exn;
+      start = 1;
     }
-    errprintf1(")");
+    add_char(&buf, '(');
+    for (i = start; i < Wosize_val(bucket); i++) {
+      if (i > start) add_string(&buf, ", ");
+      v = Field(bucket, i);
+      if (Is_long(v)) {
+        sprintf(intbuf, "%ld", Long_val(v));
+        add_string(&buf, intbuf);
+      } else if (Tag_val(v) == String_tag) {
+        add_char(&buf, '"');
+        add_string(&buf, String_val(v));
+        add_char(&buf, '"');
+      } else {
+        add_char(&buf, '_');
+      }
+    }
+    add_char(&buf, ')');
   }
-  errprintf1("\n");
+  *buf.ptr = 0;              /* Terminate string */
+  errprintf("Fatal error: uncaught exception %s\n", buf.data);
+#ifdef HAS_UI
+  ui_exit(2);
+#else
   exit(2);
+#endif
 }
-

byterun/stacks.c

@@ -50,7 +50,7 @@ void realloc_stack()
 
   Assert(extern_sp >= stack_low);
   size = stack_high - stack_low;
-  if (size >= max_stack_size) raise_out_of_memory();
+  if (size >= max_stack_size) raise_stack_overflow();
   size *= 2;
   gc_message ("Growing stack to %luk bytes\n",
 	      (unsigned long) size * sizeof(value) / 1024);