Ajout de la recuperation d'erreurs dans les parsers Yacc

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

6 files changed, 106 insertions, 32 deletions

diff --git a/byterun/parsing.c b/byterun/parsing.c
index 939edfc76..146b7f29e 100644
--- a/byterun/parsing.c
+++ b/byterun/parsing.c
@@ -6,6 +6,8 @@
 #include "memory.h"
 #include "alloc.h"
 
+#define ERRCODE 256
+
 struct parser_tables {    /* Mirrors parse_tables in ../stdlib/parsing.mli */
   value actions;
   value transl_const;
@@ -20,6 +22,7 @@ struct parser_tables {    /* Mirrors parse_tables in ../stdlib/parsing.mli */
   value tablesize;
   char * table;
   char * check;
+  value error_function;
 };
 
 struct parser_env {       /* Mirrors parser_env in ../stdlib/parsing.ml */
@@ -28,6 +31,7 @@ struct parser_env {       /* Mirrors parser_env in ../stdlib/parsing.ml */
   value symb_start_stack;
   value symb_end_stack;
   value stacksize;
+  value stackbase;
   value curr_char;
   value lval;
   value symb_start;
@@ -37,6 +41,7 @@ struct parser_env {       /* Mirrors parser_env in ../stdlib/parsing.ml */
   value rule_number;
   value sp;
   value state;
+  value errflag;
 };
 
 #ifdef BIG_ENDIAN
@@ -61,6 +66,7 @@ int parser_trace = 0;
 #define STACKS_GROWN_1 2
 #define STACKS_GROWN_2 3
 #define SEMANTIC_ACTION_COMPUTED 4
+#define ERROR_DETECTED 5
 
 /* Output codes */
 /* Mirrors parser_output in ../stdlib/parsing.ml */
@@ -69,6 +75,19 @@ int parser_trace = 0;
 #define GROW_STACKS_1 Val_int(2)
 #define GROW_STACKS_2 Val_int(3)
 #define COMPUTE_SEMANTIC_ACTION Val_int(4)
+#define CALL_ERROR_FUNCTION Val_int(5)
+
+/* To preserve local variables when communicating with the ML code */
+
+#define SAVE \
+  env->sp = Val_int(sp), \
+  env->state = Val_int(state), \
+  env->errflag = Val_int(errflag)
+
+#define RESTORE \
+  sp = Int_val(env->sp), \
+  state = Int_val(env->state), \
+  errflag = Int_val(env->errflag)
 
 /* The pushdown automata */
 
@@ -80,6 +99,7 @@ value parse_engine(tables, env, cmd, arg) /* ML */
 {
   int state;
   mlsize_t sp;
+  int errflag;
   int n, n1, n2, m, state1;
 
   switch(Int_val(cmd)) {
@@ -87,20 +107,19 @@ value parse_engine(tables, env, cmd, arg) /* ML */
   case START:
     state = 0;
     sp = Int_val(env->sp);
+    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;
-    env->sp = Val_int(sp);
-    env->state = Val_int(state);
+    SAVE;
     return READ_TOKEN;
                                 /* The ML code calls the lexer and updates */
                                 /* symb_start and symb_end */
   case TOKEN_READ:
-    sp = Int_val(env->sp);
-    state = Int_val(env->state);
+    RESTORE;
     if (Is_block(arg)) {
       env->curr_char = Field(tables->transl_block, Tag_val(arg));
       modify(&env->lval, Field(arg, 0));
@@ -122,28 +141,59 @@ value parse_engine(tables, env, cmd, arg) /* ML */
       n = Short(tables->table, n2);
       goto reduce;
     }
-    env->sp = Val_int(sp);
-    env->state = Val_int(state);
-    return RAISE_PARSE_ERROR;
-                                /* The ML code raises the Parse_error exn */
+    if (errflag > 0) goto recover;
+    SAVE;
+    return CALL_ERROR_FUNCTION;
+                                /* The ML code calls the error function */
+  case ERROR_DETECTED:
+    RESTORE;
+  recover:
+    if (errflag < 3) {
+      errflag = 3;
+      while (1) {
+        state1 = Int_val(Field(env->s_stack, sp));
+        n1 = Short(tables->sindex, state1);
+        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));
+          goto shift_recover;
+        } else {
+          Trace(printf("Discarding state %d\n", state1));
+          if (sp <= Int_val(env->stackbase)) {
+            Trace(printf("Fallen off bottom\n"));
+            return RAISE_PARSE_ERROR; /* The ML code raises Parse_error */
+          }
+          sp--;
+        }
+      }
+    } 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));
+      env->curr_char = Val_int(-1);
+      goto loop;
+    }
+    
   shift:
+    env->curr_char = Val_int(-1);
+    if (errflag > 0) errflag--;
+  shift_recover:
     state = Short(tables->table, n2);
     Trace(printf("Shift %d\n", state));
     sp++;
     if (sp < Long_val(env->stacksize)) goto push;
-    env->sp = Val_int(sp);
-    env->state = Val_int(state);
+    SAVE;
     return GROW_STACKS_1;
-                                /* The ML code resizes the stacks */
+                                 /* The ML code resizes the stacks */
   case STACKS_GROWN_1:
-    sp = Int_val(env->sp);
-    state = Int_val(env->state);
+    RESTORE;
   push:
     Field(env->s_stack, sp) = Val_int(state);
     modify(&Field(env->v_stack, sp), env->lval);
     Field(env->symb_start_stack, sp) = env->symb_start;
     Field(env->symb_end_stack, sp) = env->symb_end;
-    env->curr_char = Val_int(-1);
     goto loop;
 
   reduce:
@@ -164,25 +214,26 @@ value parse_engine(tables, env, cmd, arg) /* ML */
       state = Short(tables->dgoto, m);
     }
     if (sp < Long_val(env->stacksize)) goto semantic_action;
-    env->sp = Val_int(sp);
-    env->state = Val_int(state);
+    SAVE;
     return GROW_STACKS_2;
                                 /* The ML code resizes the stacks */
   case STACKS_GROWN_2:
-    sp = Int_val(env->sp);
-    state = Int_val(env->state);
+    RESTORE;
   semantic_action:
-    env->sp = Val_int(sp);
-    env->state = Val_int(state);
+    SAVE;
     return COMPUTE_SEMANTIC_ACTION;
                                 /* The ML code calls the semantic action */
   case SEMANTIC_ACTION_COMPUTED:
-    sp = Int_val(env->sp);
-    state = Int_val(env->state);
+    RESTORE;
     Field(env->s_stack, sp) = Val_int(state);
     modify(&Field(env->v_stack, sp), arg);
     Field(env->symb_end_stack, sp) =
       Field(env->symb_end_stack, Int_val(env->asp));
     goto loop;
+
+  default:                      /* Should not happen */
+    Assert(0);
+    return RAISE_PARSE_ERROR;   /* Keeps gcc -Wall happy */
   }
+  
 }
diff --git a/otherlibs/graph/Makefile b/otherlibs/graph/Makefile
index f9ab18633..5c167079f 100644
--- a/otherlibs/graph/Makefile
+++ b/otherlibs/graph/Makefile
@@ -2,7 +2,8 @@
 
 include ../../Makefile.config
 
-CFLAGS=$(CCCOMPOPTS) -I../../byterun -O
+CC=$(BYTECC)
+CFLAGS=-I../../byterun -O $(BYTECCCOMPOPTS)
 
 CAMLC=../../boot/camlrun ../../boot/camlc -I ../../boot
 
diff --git a/stdlib/filename.mli b/stdlib/filename.mli
index bf75f61c5..4e45d3553 100644
--- a/stdlib/filename.mli
+++ b/stdlib/filename.mli
@@ -22,6 +22,6 @@ val dirname : string -> string
         (* Split a file name into directory name / base file name.
            [concat (dirname name) (basename name)] returns a file name
            which is equivalent to [name]. Moreover, after setting the
-           current directory to [dirname name] (with [sys__chdir]),
+           current directory to [dirname name] (with [Sys.chdir]),
            references to [basename name] (which is a relative file name)
 	   designate the same file as [name] before the call to [chdir]. *)
diff --git a/stdlib/parsing.ml b/stdlib/parsing.ml
index 04ee6164f..446ee2665 100644
--- a/stdlib/parsing.ml
+++ b/stdlib/parsing.ml
@@ -10,6 +10,7 @@ type parser_env =
     mutable symb_start_stack : int array; (* Start positions *)
     mutable symb_end_stack : int array;   (* End positions *)
     mutable stacksize : int;            (* Size of the stacks *)
+    mutable stackbase : int;            (* Base sp for current parse *)
     mutable curr_char : int;            (* Last token read *)
     mutable lval : Obj.t;               (* Its semantic attribute *)
     mutable symb_start : int;           (* Start pos. of the current symbol*)
@@ -18,7 +19,8 @@ type parser_env =
     mutable rule_len : int;             (* Number of rhs items in the rule *)
     mutable rule_number : int;          (* Rule number to reduce by *)
     mutable sp : int;                   (* Saved sp for parse_engine *)
-    mutable state : int }               (* Saved state for parse_engine *)
+    mutable state : int;                (* Saved state for parse_engine *)
+    mutable errflag : int }             (* Saved error flag for parse_engine *)
 
 type parse_tables =
   { actions : (parser_env -> Obj.t) array;
@@ -33,7 +35,8 @@ type parse_tables =
     gindex : string;
     tablesize : int;
     table : string;
-    check : string }
+    check : string;
+    error_function : string -> unit }
 
 exception YYexit of Obj.t
 exception Parse_error
@@ -44,6 +47,7 @@ type parser_input =
   | Stacks_grown_1
   | Stacks_grown_2
   | Semantic_action_computed
+  | Error_detected
 
 type parser_output =
     Read_token
@@ -51,6 +55,7 @@ type parser_output =
   | Grow_stacks_1
   | Grow_stacks_2
   | Compute_semantic_action
+  | Call_error_function
 
 external parse_engine :
     parse_tables -> parser_env -> parser_input -> Obj.t -> parser_output
@@ -62,6 +67,7 @@ let env =
     symb_start_stack = Array.new 100 0;
     symb_end_stack = Array.new 100 0;
     stacksize = 100;
+    stackbase = 0;
     curr_char = 0;
     lval = Obj.repr ();
     symb_start = 0;
@@ -70,7 +76,8 @@ let env =
     rule_len = 0;
     rule_number = 0;
     sp = 0;
-    state = 0 }
+    state = 0;
+    errflag = 0 }
 
 let grow_stacks() =
   let oldsize = env.stacksize in
@@ -106,15 +113,24 @@ let yyparse tables start lexer lexbuf =
     | Raise_parse_error ->
         raise Parse_error
     | Compute_semantic_action ->
-        loop Semantic_action_computed (tables.actions.(env.rule_number) env)
+        let (action, value) =
+          try
+            (Semantic_action_computed, tables.actions.(env.rule_number) env)
+          with Parse_error ->
+            (Error_detected, Obj.repr ()) in
+        loop action value
     | Grow_stacks_1 ->
         grow_stacks(); loop Stacks_grown_1 (Obj.repr ())
     | Grow_stacks_2 ->
-        grow_stacks(); loop Stacks_grown_2 (Obj.repr ()) in
+        grow_stacks(); loop Stacks_grown_2 (Obj.repr ())
+    | Call_error_function ->
+        tables.error_function "syntax error";
+        loop Error_detected (Obj.repr ()) in
   let init_asp = env.asp
   and init_sp = env.sp
   and init_state = env.state
   and init_curr_char = env.curr_char in
+  env.stackbase <- env.sp + 1;
   env.curr_char <- start;
   try
     loop Start (Obj.repr ())
@@ -150,3 +166,6 @@ let rhs_end n =
 
 let is_current_lookahead tok =
   (!current_lookahead_fun)(Obj.repr tok)
+
+let parse_error (msg: string) =
+  raise Parse_error
diff --git a/stdlib/parsing.mli b/stdlib/parsing.mli
index 99e891ce1..c1c1fedad 100644
--- a/stdlib/parsing.mli
+++ b/stdlib/parsing.mli
@@ -44,11 +44,13 @@ type parse_tables =
     gindex : string;
     tablesize : int;
     table : string;
-    check : string }
+    check : string;
+    error_function : string -> unit }
 
 exception YYexit of Obj.t
 
 val yyparse :
       parse_tables -> int -> (Lexing.lexbuf -> 'a) -> Lexing.lexbuf -> 'b
 val peek_val : parser_env -> int -> 'a
-val is_current_lookahead: 'a -> bool
+val is_current_lookahead : 'a -> bool
+val parse_error : string -> unit
diff --git a/yacc/skeleton.c b/yacc/skeleton.c
index 4dd090485..cbd7ae6c9 100644
--- a/yacc/skeleton.c
+++ b/yacc/skeleton.c
@@ -21,7 +21,8 @@ char *define_tables[] =
   "    gindex=yygindex;",
   "    tablesize=yytablesize;",
   "    table=yytable;",
-  "    check=yycheck }",
+  "    check=yycheck;",
+  "    error_function=parse_error }",
   0
 };