Ajout mecanisme de trace dans les parsers ocamlyacc

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

10 files changed, 84 insertions, 25 deletions

diff --git a/Changes b/Changes
index 53789c0f0..80c141170 100644
--- a/Changes
+++ b/Changes
@@ -14,7 +14,7 @@ Language:
   and UnixLabels. "open StdLabels" gives access to the first three.
 - Extended polymorphic variant type syntax, allowing union types and
   row abbreviations for both sub- and super-types. #t deprecated in types.
-- See the Upgrading file for how to adapt to all the above changes.
+- See the "Upgrading" file for how to adapt to all the changes above.
 
 Type-checker:
 - Fixed obscure bug in module typing causing the type-checker to loop
@@ -34,8 +34,6 @@ Byte-code compiler:
 - Protect against VM stack overflow caused by module initialization code
   with many local variables.
 - Support for dynamic loading of the C part of mixed Caml/C libraries.
-- Removed the -use-runtime and -make-runtime flags, obsoleted by dynamic
-  loading of C libraries.
 
 Native-code compiler:
 - Attempt to recover gracefully from system stack overflow.  Currently
@@ -55,6 +53,8 @@ Tools:
   They provide easy transition from classic mode ocaml 3.02 sources,
   depending on whether you want to keep labels or not.
 - ocamldep: added -pp option to handle preprocessed source files.
+- ocamlyacc: added parser debugging support (set OCAMLRUNPARAM=p to get
+  a trace of the pushdown automaton actions).
 
 Run-time system:
 - Support for dynamic loading of the C part of mixed Caml/C libraries.
@@ -68,6 +68,8 @@ Run-time system:
 
 Standard library:
 - Added Pervasives.flush_all to flush all opened output channels.
+- Pervasives.float_of_string: now raises Failure on ill-formed input.
+- Pervasives: added useful float constants max_float, min_float, epsilon_float.
 - printf functions in Printf and Format: added % formats for int32, nativeint,
   int64; "*" in width and precision specifications now supported 
   (contributed by Thorsten Ohl).
diff --git a/asmrun/startup.c b/asmrun/startup.c
index d6e996ed3..275b06b08 100644
--- a/asmrun/startup.c
+++ b/asmrun/startup.c
@@ -29,6 +29,7 @@
 #include "ui.h"
 #endif
 
+extern int parser_trace;
 header_t atom_table[256];
 char * static_data_start, * static_data_end;
 char * code_area_start, * code_area_end;
@@ -99,6 +100,7 @@ static void parse_camlrunparam(void)
       case 'o': scanmult (opt, &percent_free_init); break;
       case 'O': scanmult (opt, &max_percent_free_init); break;
       case 'v': scanmult (opt, &verb_gc); break;
+      case 'p': parser_trace = 1; break;
       }
     }
   }
diff --git a/boot/ocamlc b/boot/ocamlc
index 0d23f3f91..59605d8c5 100755
--- a/boot/ocamlc
+++ b/boot/ocamlc
diff --git a/boot/ocamllex b/boot/ocamllex
index 2855abbcf..2d0ca6572 100755
--- a/boot/ocamllex
+++ b/boot/ocamllex
diff --git a/byterun/parsing.c b/byterun/parsing.c
index a0b2786e7..ffb43812d 100644
--- a/byterun/parsing.c
+++ b/byterun/parsing.c
@@ -37,6 +37,8 @@ struct parser_tables {    /* Mirrors parse_tables in ../stdlib/parsing.mli */
   char * table;
   char * check;
   value error_function;
+  char * names_const;
+  char * names_block;
 };
 
 struct parser_env {       /* Mirrors parser_env in ../stdlib/parsing.ml */
@@ -66,12 +68,7 @@ struct parser_env {       /* Mirrors parser_env in ../stdlib/parsing.ml */
 #define Short(tbl,n) (((short *)(tbl))[n])
 #endif
 
-#ifdef DEBUG
 int parser_trace = 0;
-#define Trace(act) if(parser_trace) act
-#else
-#define Trace(act)
-#endif
 
 /* Input codes */
 /* Mirrors parser_input in ../stdlib/parsing.ml */
@@ -103,6 +100,41 @@ int parser_trace = 0;
   state = Int_val(env->state), \
   errflag = Int_val(env->errflag)
 
+/* Auxiliary for printing token just read */
+
+static char * token_name(char * names, int number)
+{
+  for (/*nothing*/; number > 0; number--) {
+    if (names[0] == 0) return "<unknown token>";
+    names += strlen(names) + 1;
+  }
+  return names;
+}
+
+static void print_token(struct parser_tables *tables, int state, value tok)
+{
+  mlsize_t i;
+  value v;
+
+  if (Is_long(tok)) {
+    fprintf(stderr, "State %d: read token %s\n",
+            state, token_name(tables->names_const, Int_val(tok)));
+  } else {
+    fprintf(stderr, "State %d: read token %s(",
+            state, token_name(tables->names_block, Tag_val(tok)));
+    v = Field(tok, 0);
+    if (Is_long(v))
+      fprintf(stderr, "%ld", Long_val(v));
+    else if (Tag_val(v) == String_tag)
+      fprintf(stderr, "%s", String_val(v));
+    else if (Tag_val(v) == Double_tag)
+      fprintf(stderr, "%g", Double_val(v));
+    else
+      fprintf(stderr, "_");
+    fprintf(stderr, ")\n");
+  }          
+}      
+
 /* The pushdown automata */
 
 CAMLprim value parse_engine(struct parser_tables *tables,
@@ -121,7 +153,6 @@ CAMLprim value parse_engine(struct parser_tables *tables,
     errflag = 0;
 
   loop:
-    Trace(printf("Loop %d\n", state));
     n = Short(tables->defred, state);
     if (n != 0) goto reduce;
     if (Int_val(env->curr_char) >= 0) goto testshift;
@@ -138,7 +169,7 @@ CAMLprim value parse_engine(struct parser_tables *tables,
       env->curr_char = Field(tables->transl_const, Int_val(arg));
       modify(&env->lval, Val_long(0));
     }
-    Trace(printf("Token %d (0x%lx)\n", Int_val(env->curr_char), env->lval));
+    if (parser_trace) print_token(tables, state, arg);
     
   testshift:
     n1 = Short(tables->sindex, state);
@@ -167,12 +198,13 @@ CAMLprim value parse_engine(struct parser_tables *tables,
         n2 = n1 + ERRCODE;
         if (n1 != 0 && n2 >= 0 && n2 <= Int_val(tables->tablesize) &&
             Short(tables->check, n2) == ERRCODE) {
-          Trace(printf("Recovering in state %d\n", state1));
+          if (parser_trace) 
+            fprintf(stderr, "Recovering in state %d\n", state1);
           goto shift_recover;
         } else {
-          Trace(printf("Discarding state %d\n", state1));
+          if (parser_trace) fprintf(stderr, "Discarding state %d\n", state1);
           if (sp <= Int_val(env->stackbase)) {
-            Trace(printf("Fallen off bottom\n"));
+            if (parser_trace) fprintf(stderr, "No more states to discard\n");
             return RAISE_PARSE_ERROR; /* The ML code raises Parse_error */
           }
           sp--;
@@ -181,8 +213,7 @@ CAMLprim value parse_engine(struct parser_tables *tables,
     } else {
       if (Int_val(env->curr_char) == 0)
         return RAISE_PARSE_ERROR; /* The ML code raises Parse_error */
-      Trace(printf("Discarding token %d (0x%lx)\n",
-                   Int_val(env->curr_char), env->lval));
+      if (parser_trace) fprintf(stderr, "Discarding last token read\n");
       env->curr_char = Val_int(-1);
       goto loop;
     }
@@ -191,8 +222,10 @@ CAMLprim value parse_engine(struct parser_tables *tables,
     env->curr_char = Val_int(-1);
     if (errflag > 0) errflag--;
   shift_recover:
+    if (parser_trace)
+      fprintf(stderr, "State %d: shift to state %d\n",
+              state, Short(tables->table, n2));
     state = Short(tables->table, n2);
-    Trace(printf("Shift %d\n", state));
     sp++;
     if (sp < Long_val(env->stacksize)) goto push;
     SAVE;
@@ -208,7 +241,8 @@ CAMLprim value parse_engine(struct parser_tables *tables,
     goto loop;
 
   reduce:
-    Trace(printf("Reduce %d\n", n));
+    if (parser_trace)
+      fprintf(stderr, "State %d: reduce by rule %d\n", state, n);
     m = Short(tables->len, n);
     env->asp = Val_int(sp);
     env->rule_number = Val_int(n);
diff --git a/byterun/startup.c b/byterun/startup.c
index db1784c6c..eb40eb72a 100644
--- a/byterun/startup.c
+++ b/byterun/startup.c
@@ -60,6 +60,8 @@
 #define SEEK_END 2
 #endif
 
+extern int parser_trace;
+
 CAMLexport header_t atom_table[256];
 
 /* Initialize the atom table */
@@ -235,10 +237,6 @@ static int parse_command_line(char **argv)
     case 't':
       trace_flag = 1;
       break;
-    case 'P':
-      { extern int parser_trace;
-        parser_trace = 1;
-        break; }
 #endif
     case 'v':
       verb_gc = 1+4+8+16+32;
@@ -296,6 +294,7 @@ static void parse_camlrunparam(void)
       case 'O': scanmult (opt, &max_percent_free_init); break;
       case 'v': scanmult (opt, &verb_gc); break;
       case 'b': backtrace_active = 1; break;
+      case 'p': parser_trace = 1; break;
       }
     }
   }
diff --git a/stdlib/parsing.ml b/stdlib/parsing.ml
index 87270e846..e6a6f602a 100644
--- a/stdlib/parsing.ml
+++ b/stdlib/parsing.ml
@@ -50,7 +50,9 @@ type parse_tables =
     tablesize : int;
     table : string;
     check : string;
-    error_function : string -> unit }
+    error_function : string -> unit;
+    names_const : string;
+    names_block : string }
 
 exception YYexit of Obj.t
 exception Parse_error
diff --git a/stdlib/parsing.mli b/stdlib/parsing.mli
index 4e424d02b..8bb403858 100644
--- a/stdlib/parsing.mli
+++ b/stdlib/parsing.mli
@@ -70,7 +70,9 @@ type parse_tables =
     tablesize : int;
     table : string;
     check : string;
-    error_function : string -> unit }
+    error_function : string -> unit;
+    names_const : string;
+    names_block : string }
 
 exception YYexit of Obj.t
 
diff --git a/yacc/output.c b/yacc/output.c
index d7e89f5dc..09f2027d4 100644
--- a/yacc/output.c
+++ b/yacc/output.c
@@ -71,8 +71,8 @@ void output(void)
   output_rule_data();
   output_yydefred();
   output_actions();
-  free_parser();
   output_debug();
+  free_parser();
   if (sflag)
     fprintf(output_file,
       "let yyact = Array.new %d (fun _ -> (failwith \"parser\" : Obj.t))\n",
@@ -796,6 +796,22 @@ void output_stored_text(void)
 
 void output_debug(void)
 {
+  int i;
+
+  fprintf(code_file, "let yynames_const = \"\\\n");
+  for (i = 0; i < ntokens; i++) {
+    if (symbol_true_token[i] && symbol_tag[i] == NULL) {
+      fprintf(code_file, "  %s\\000\\\n", symbol_name[i]);
+    }
+  }
+  fprintf(code_file, "  \"\n\n");
+  fprintf(code_file, "let yynames_block = \"\\\n");
+  for (i = 0; i < ntokens; i++) {
+    if (symbol_true_token[i] && symbol_tag[i] != NULL) {
+      fprintf(code_file, "  %s\\000\\\n", symbol_name[i]);
+    }
+  }
+  fprintf(code_file, "  \"\n\n");
 }
 
 void output_trailing_text(void)
diff --git a/yacc/skeleton.c b/yacc/skeleton.c
index 98590f807..95b2d636c 100644
--- a/yacc/skeleton.c
+++ b/yacc/skeleton.c
@@ -38,7 +38,9 @@ char *define_tables[] =
   "    tablesize=yytablesize;",
   "    table=yytable;",
   "    check=yycheck;",
-  "    error_function=parse_error }",
+  "    error_function=parse_error;",
+  "    names_const=yynames_const;",
+  "    names_block=yynames_block }",
   0
 };