src/Pure/Syntax/parser.ML

     datatype parsetree =
       Node of string * parsetree list |
       Tip of token
     val parse: gram -> string -> token list -> parsetree list
   end
+  val branching_level: int ref;
 end;
 
 functor ParserFun(structure Symtab: SYMTAB and Lexicon: LEXICON
   and SynExt: SYN_EXT): PARSER =
 struct

         (B, j, tss @ t, sa, id, i) ::
           movedot_lambda (B, j, tss, Nonterm (A, k) :: sa, id, i) ts
       else movedot_lambda (B, j, tss, Nonterm (A, k) :: sa, id, i) ts;
 
 
+val warned = ref false;  (*flag for warning message*)
+val branching_level = ref 100;  (*trigger value for warnings*)
 
 fun PROCESSS Estate i c states =
 let
 fun get_lookahead rhss_ref = token_assoc (!rhss_ref, c);
 
 fun processS used [] (Si, Sii) = (Si, Sii)
   | processS used (S :: States) (Si, Sii) =
       (case S of
         (_, _, _, Nonterm (rhss_ref, minPrec) :: _, _, _) =>
           let                                       (*predictor operation*)
-            val (used_new, States_new) =
+            val (used_new, new_states) =
               (case assoc (used, rhss_ref) of
                 Some (usedPrec, l) =>       (*nonterminal has been processed*)
                   if usedPrec <= minPrec then
                                       (*wanted precedence has been processed*)
                     (used, movedot_lambda S l)

                   let val rhss = get_lookahead rhss_ref;
                       val States' = mkStates i minPrec rhss_ref
                                       (getRHS minPrec rhss);
                   in ((rhss_ref, (minPrec, [])) :: used, States') end)
           in
-            processS used_new (States_new @ States) (S :: Si, Sii)
+            processS used_new (new_states @ States) (S :: Si, Sii)
           end
       | (_, _, _, Term a :: _, _, _) =>               (*scanner operation*)
           processS used States
             (S :: Si,
               if matching_tokens (a, c) then movedot_term S c :: Sii else Sii)
-
       | (A, prec, ts, [], id, j) =>                   (*completer operation*)
           let
+            fun check_branching len =
+              if not (!warned) andalso len > (!branching_level) then
+                (writeln "Warning: Currently parsed expression could be \
+                         \extremely ambiguous.";
+                 warned := true)
+              else ();
+
             val tt = if id = "" then ts else [Node (id, ts)]
           in
             if j = i then                             (*lambda production?*)
               let
                 val (used', O) = update_tree used (A, (tt, prec));
               in
                 (case O of
                   None =>
                     let
                       val Slist = getS A prec Si;
+                      val _ = check_branching (length Slist);
                       val States' = map (movedot_nonterm tt) Slist;
                     in
                       processS used' (States' @ States) (S :: Si, Sii)
                     end
                 | Some n =>
                     if n >= prec then
                       processS used' States (S :: Si, Sii)
                     else
                       let
                         val Slist = getS' A prec n Si;
+                        val _ = check_branching (length Slist);
                         val States' = map (movedot_nonterm tt) Slist;
                       in
-                        processS used' (States' @ States) (S :: Si, Sii)
+                       processS used' (States' @ States) (S :: Si, Sii)
                       end)
               end 
             else
-              processS used
-                (map (movedot_nonterm tt) (getStates Estate i j A prec) @ States)
-                (S :: Si, Sii)
+              let val Slist = getStates Estate i j A prec;
+                  val _ = check_branching (length Slist);
+              in processS used (map (movedot_nonterm tt) Slist @ States)
+                   (S :: Si, Sii)
+              end
           end)
-in
-  processS [] states ([], [])
-end;
-
+in processS [] states ([], []) end;
 
 
 fun syntax_error toks allowed =
   error 
   ((if toks = [] then

     val s = length indata + 1;
     val Estate = Array.array (s, []);
   in
     Array.update (Estate, 0, S0);
     let
-      val l = produce Estate 0 indata EndToken(*dummy*);
+      val l = (warned := false; produce Estate 0 indata EndToken(*dummy*));
 
       val p_trees = get_trees l;
     in p_trees end
   end;