]> matita.cs.unibo.it Git - helm.git/blob - helm/DEVEL/pxp/pxp/m2parsergen/generator.ml
mathQL modified, stderr corrected to stdout im mathql_interpreter,
[helm.git] / helm / DEVEL / pxp / pxp / m2parsergen / generator.ml
1 (* $Id$
2  * ----------------------------------------------------------------------
3  *
4  *)
5
6 open Parser
7 open Ast
8
9 (* Overall scheme:
10  *
11  * The rules are translated to:
12  *
13  * let rec parse_<rule1> ... = ...
14  *     and parse_<rule2> ... = ...
15  *     and ...
16  *     and parse_<ruleN> ... = ...
17  * in
18  *
19  * Every rule has at least two arguments: 'current' and 'get_next'.
20  * 'current()' is the token that should match the first symbol of the
21  * rule. 'get_next()' returns the next token.
22  *
23  * The rules may have further user arguments; these are the next arguments
24  * in turn.
25  *
26  * The rules return the user value. After they have returned to the caller 
27  * the current token is the token that follows the sequence of tokens 
28  * matching the rule.
29  *
30  * The rules will raise:
31  *  - Not_found if the first token does not match
32  *  - Parsing.Parse_error if the rest does not match.
33  *
34  * Rule scheme:
35  *
36  * rule(arg1,arg2,...):
37  *   (l1:x1)
38  *   {{ let-CODE }}
39  *   (l2:y2(name1,...)) y3 ... 
40  *   {{ CODE }}
41  *   ? {{ ?-CODE }}
42  * | x2 ...
43  * | ...
44  * | xN
45  *
46  * let parse_<rule> current get_next arg1 arg2 ... =
47  *   match current() with
48  *     S(x1) -> ...
49  *   | S(x2) -> ...
50  *   | ...
51  *   | S(xN) -> ...
52 *    | _ -> raise Not_found
53  *
54  * Here, S(xi) denotes the set of tokens matched by xi without all tokens
55  * already matched by x1 to x(i-1). (If S(xi) = empty, a warning is printed,
56  * and this branch of the rule is omitted.)
57  *
58  * S(xi) may be a set because xi may be a reference to another rule. In this
59  * case, S(xi) bases on the set of tokens that match the first symbol of 
60  * the other rule. (In general, S(xi) must be computed recursively.)
61  *
62  * If the "?" clause is present, every branch is embraced by the following:
63  *
64  * let position = ref "<Label of x1>" in
65  * ( try ... 
66  *   with Parsing.Parse_error -> ( <<?-CODE>> )
67  * )
68  * 
69  * Next: The "..." is
70  *
71  * OPTIONAL: let <l1> = parse_<rule(x1)> in
72  * <<let-CODE>>
73  * M(y1)
74  * M(y2)
75  * ...
76  * M(yN)
77  * <<CODE>>
78  *
79  * If x1 is a rule invocation, it is now parsed, and the result is bound
80  * to a variable.
81  *
82  * Note: After x1 has matched, the Caml variable <l1> must be either
83  * bound to the result of the sub parsing, or to the value associated
84  * with the token (if any). The latter is already done in the main
85  * "match" statement, i.e. "match ... with S(x1) -> ..." is actually
86  * "match ... with Token1 <l1> -> ...".
87  *
88  * Note: After calling parse_<rule(x1)> the exception Not_found is NEVER
89  * converted to Parsing.Parse_error. It is simply not possible that this
90  * happens.
91
92  * For every remaining symbol yi of the rule, a matching statement M(yi)
93  * is produced. These statements have the form:
94  *
95  * OPTIONAL: position := "<Label of yi>";
96  * CASE: yi is a token without associated value
97  *     let yy_i = get_next()  OR  current() in
98  *     if yy_i <> Token(yi) then raise Parsing.Parse_error;
99  * CASE: yi is a token with value
100  *     let yy_i = get_next()  OR  current() in
101  *     let <li> = match yy_i with Token x -> x | _ -> raise Parsing.Parse_error 
102  *     in
103  * CASE: yi is a rule invocation
104  *     OPTIONAL: let _ = get_next() in
105  *     let <li> = try parse_<rule(yi)> 
106  *                with Not_found -> raise Parsing.Parse_error in
107  *
108  * yy_i is get_next() if y(i-1) was a token, and yy_i is current() if
109  * y(i-1) was a rule invocation.
110  *
111  * Repetitions:
112  *
113  * If yi = (yi')*:
114  *
115  * CASE no label given:
116  *
117  * ( try 
118  *     while true do 
119  *       M(yi') with the modification that top-level mismatches raise
120  *              Not_found instead of Parsing.Parse_error
121  *     done
122  *   with Not_found -> ()
123  * )
124  *
125  * CASE a label <li> is given: The list of results must be bound to <li>!
126  *
127  * let yy_list = ref [] in
128  * ( try 
129  *     while true do
130  *       let yy_first = M(yi') (with some modifications) in
131  *       yy_list := yy_first :: !yy_list;
132  *     done
133  *   with Not_found -> ()
134  * );
135  * let <li> = List.rev !yy_list in
136  *
137  * Note that this scheme minimizes stack and heap allocations.
138  *
139  * Options:
140  *
141  * If yi = (yi')?:
142  *
143  * CASE no label given:
144  *
145  * ( try 
146  *     M(yi') with the modification that top-level mismatches raise
147  *            Not_found instead of Parsing.Parse_error
148  *   with Not_found -> ()
149  * )
150  *
151  * CASE a label <li> is given: The optional result must be bound to <li>!
152  *
153  * let <li> =
154  *   try 
155  *     Some( M(yi') (with some modifications) )
156  *   with Not_found -> None
157  * );
158  *)
159
160
161 let lookup_rule tree name =
162   try
163     List.find (fun r -> r.rule_name = name) tree.text_rules
164   with
165       Not_found ->
166         failwith ("Rule `" ^ name ^ "' not found")
167 ;;
168
169
170 let is_typed tree name =
171   (* Find out whether the token 'name' is typed or not *)
172   let decl =
173     try
174       List.find (fun d -> match d with
175                      D_token n -> n = name
176                    | D_typed_token n -> n = name
177                 )
178         tree.text_decls
179     with
180         Not_found -> 
181           failwith ("Token `" ^ name ^ "' not found")
182   in
183   match decl with
184       D_token _ -> false
185     | D_typed_token _ -> true
186 ;;
187
188
189 let label_of_symbol tree sym =
190   match sym with
191       U_symbol (tok, lab) -> 
192         (* if is_typed tree tok then lab else None *)
193         lab
194     | L_symbol (_, _, lab) -> lab
195     | L_indirect (_, _, lab) -> lab
196 ;;
197
198
199 let is_untyped_U_symbol tree sym =
200   match sym with
201       U_symbol (tok, _) -> 
202         not(is_typed tree tok)
203     | L_symbol (_, _, _) -> false
204     | L_indirect (_, _, _) -> false
205 ;;
206
207
208
209 let rec set_of_list l =
210   (* Removes duplicate members of l *)
211   match l with
212       [] -> []
213     | x :: l' -> if List.mem x l' then set_of_list l' else x :: (set_of_list l')
214 ;;
215
216
217 let selector_set_of_rule tree name =
218   (* Determines the set of tokens that match the first symbol of a rule *)
219   
220   let rec collect visited_rules name =
221     if List.mem name visited_rules then
222       []
223     else
224       let r = lookup_rule tree name in
225       List.flatten
226         (List.map
227            (fun branch ->
228               match branch.branch_selector with
229                   U_symbol (tok_name,_) ->
230                     [ tok_name ]
231                 | L_symbol (rule_name, _, _) ->
232                     collect (name :: visited_rules) rule_name
233                 | L_indirect (_, _, _) ->
234                     failwith("The first symbol in rule `" ^ name ^ 
235                              "' is an indirect call; this is not allowed")
236            )
237            r.rule_branches
238         )
239   in
240   set_of_list (collect [] name)
241 ;;
242
243
244 let output_code_location b file_name (_, line, column) = 
245   Buffer.add_string b "\n";
246   Buffer.add_string b ("# " ^ string_of_int line ^ " \"" ^
247                        file_name ^ "\"\n");
248   Buffer.add_string b (String.make column ' ')
249 ;;
250
251
252 let phantasy_line = ref 100000;;
253
254 let output_code b file_name ((code, line, column) as triple) = 
255   if code <> "" then begin
256     output_code_location b file_name triple;
257     Buffer.add_string b code;
258     Buffer.add_string b ("\n# " ^ string_of_int !phantasy_line ^ " \"<Generated Code>\"\n");
259     phantasy_line := !phantasy_line + 10000;
260   end
261 ;;
262
263
264 let process_branch b file_name tree branch =
265
266   let make_rule_invocation called_rule args lab allow_not_found =
267     (* Produces: let <label> = parse_<called_rule> ... args in 
268      * If not allow_not_found, the exception Not_found is caught and
269      * changed into Parsing.Parse_error.
270      *)
271     let r = lookup_rule tree called_rule in
272     if List.length r.rule_arguments <> List.length args then
273       failwith("Calling rule `" ^ called_rule ^ "' with the wrong number of arguments!");
274
275     Buffer.add_string b "let ";
276     begin match lab with
277         None   -> Buffer.add_string b "_"
278       | Some l -> Buffer.add_string b l
279     end;
280     Buffer.add_string b " = ";
281     if not allow_not_found then
282       Buffer.add_string b "try ";
283     Buffer.add_string b "parse_";
284     Buffer.add_string b called_rule;
285     Buffer.add_string b " yy_current yy_get_next";
286     List.iter
287       (fun a -> Buffer.add_string b " ";
288                 Buffer.add_string b a;
289       )
290       args;
291     if not allow_not_found then
292       Buffer.add_string b " with Not_found -> raise Parsing.Parse_error";
293     Buffer.add_string b " in\n"
294   in
295
296   let make_indirect_rule_invocation ml_name args lab allow_not_found =
297     (* Produces: let <label> = ml_name ... args in 
298      * If not allow_not_found, the exception Not_found is caught and
299      * changed into Parsing.Parse_error.
300      *)
301     Buffer.add_string b "let ";
302     begin match lab with
303         None   -> Buffer.add_string b "_"
304       | Some l -> Buffer.add_string b l
305     end;
306     Buffer.add_string b " = ";
307     if not allow_not_found then
308       Buffer.add_string b "try ";
309     Buffer.add_string b ml_name;
310     Buffer.add_string b " yy_current yy_get_next";
311     List.iter
312       (fun a -> Buffer.add_string b " ";
313                 Buffer.add_string b a;
314       )
315       args;
316     if not allow_not_found then
317       Buffer.add_string b " with Not_found -> raise Parsing.Parse_error";
318     Buffer.add_string b " in\n"
319   in
320
321   let process_symbol sym previous_was_token allow_not_found =
322     match sym with
323         U_symbol(tok, lab) ->
324           (* Distinguish between simple tokens and typed tokens *)
325           if is_typed tree tok then begin
326             (* Typed token *)
327             Buffer.add_string b "let ";
328             begin match lab with
329                 None   -> Buffer.add_string b "_"
330               | Some l -> Buffer.add_string b l
331             end;
332             Buffer.add_string b " = match ";
333             if previous_was_token then
334               Buffer.add_string b "yy_get_next()"
335             else
336               Buffer.add_string b "yy_current()";
337             Buffer.add_string b " with ";
338             Buffer.add_string b tok;
339             Buffer.add_string b " x -> x | _ -> raise ";
340             if allow_not_found then
341               Buffer.add_string b "Not_found"
342             else
343               Buffer.add_string b "Parsing.Parse_error";
344             Buffer.add_string b " in\n";
345           end
346           else begin
347             (* Simple token *)
348             Buffer.add_string b "if (";
349             if previous_was_token then
350               Buffer.add_string b "yy_get_next()"
351             else
352               Buffer.add_string b "yy_current()";
353             Buffer.add_string b ") <> ";
354             Buffer.add_string b tok;
355             Buffer.add_string b " then raise ";
356             if allow_not_found then
357               Buffer.add_string b "Not_found;\n"
358             else
359               Buffer.add_string b "Parsing.Parse_error;\n"
360           end
361       | L_symbol(called_rule, args, lab) ->
362           if previous_was_token then
363             Buffer.add_string b "ignore(yy_get_next());\n";
364           make_rule_invocation called_rule args lab allow_not_found
365       | L_indirect(ml_name, args, lab) ->
366           if previous_was_token then
367             Buffer.add_string b "ignore(yy_get_next());\n";
368           make_indirect_rule_invocation ml_name args lab allow_not_found
369   in
370
371   let process_pattern (current_position, previous_was_token) pat =
372     (* Assign "position" if necessary. *)
373     let new_position =
374       if branch.branch_error_code <> None then begin
375         match pat.pat_symbol with
376             U_symbol(_,Some l)   -> l
377           | L_symbol(_,_,Some l) -> l
378           | L_indirect(_,_,Some l) -> l
379           | _ -> ""
380       end
381       else ""
382     in
383     if new_position <> current_position then begin
384       Buffer.add_string b "yy_position := \"";
385       Buffer.add_string b new_position;
386       Buffer.add_string b "\";\n";
387     end;
388
389     let this_is_token =
390       match pat.pat_symbol with
391           U_symbol(_,_)   -> pat.pat_modifier = Exact
392         | L_symbol(_,_,_) -> false
393         | L_indirect(_,_,_) -> false
394     in
395
396     (* First distinguish between Exact, Option, and Repetition: *)
397     begin match pat.pat_modifier with
398         Exact ->
399           process_symbol pat.pat_symbol previous_was_token false
400       | Option ->
401           begin match label_of_symbol tree pat.pat_symbol with
402               None ->
403                 (* CASE: optional symbol without label *)
404                 (* OPTIMIZATION: If the symbol is
405                  * a token, the loop becomes very simple.
406                  *)
407                 if (match pat.pat_symbol with 
408                         U_symbol(t,_) -> not (is_typed tree t) | _ -> false) 
409                 then begin
410                   let tok = match pat.pat_symbol with 
411                                U_symbol(t,_) -> t | _ -> assert false in
412                   (* Optimized case *)
413                   Buffer.add_string b "if ";
414                   if previous_was_token then
415                     Buffer.add_string b "yy_get_next()"
416                   else
417                     Buffer.add_string b "yy_current()";
418                   Buffer.add_string b " = ";
419                   Buffer.add_string b tok;
420                   Buffer.add_string b " then ignore(yy_get_next());\n";
421                 end
422                 else begin
423                   (* General, non-optimized case: *)
424                   Buffer.add_string b "( try (";
425                   process_symbol pat.pat_symbol previous_was_token true;
426                   Buffer.add_string b "ignore(yy_get_next());\n";
427                   Buffer.add_string b ") with Not_found -> ());\n";
428                 end
429             | Some l ->
430                 (* CASE: optional symbol with label *)
431                 if is_untyped_U_symbol tree pat.pat_symbol then begin
432                   (* SUBCASE: The label becomes a boolean variable *)
433                   Buffer.add_string b "let ";
434                   Buffer.add_string b l;
435                   Buffer.add_string b " = try (";
436                   process_symbol pat.pat_symbol previous_was_token true;
437                   Buffer.add_string b ");\n";
438                   Buffer.add_string b "ignore(yy_get_next());\n";
439                   Buffer.add_string b "true with Not_found -> false in\n";
440                 end
441                 else begin
442                   (* SUBCASE: the symbol has a value *)
443                   Buffer.add_string b "let ";
444                   Buffer.add_string b l;
445                   Buffer.add_string b " = try let yy_tok = Some(";
446                   process_symbol pat.pat_symbol previous_was_token true;
447                   Buffer.add_string b l;
448                   Buffer.add_string b ") in\n";
449                   
450                   if (match pat.pat_symbol with
451                           U_symbol(_,_) -> true | _ -> false) then
452                     Buffer.add_string b "ignore(yy_get_next());\n";
453                   
454                   Buffer.add_string b "yy_tok with Not_found -> None in\n";
455                 end
456           end
457       | Repetition ->
458           begin match label_of_symbol tree pat.pat_symbol with
459               None ->
460                 (* CASE: repeated symbol without label *)
461                 (* OPTIMIZATION: If the symbol is
462                  * a token, the loop becomes very simple.
463                  *)
464                 if (match pat.pat_symbol with 
465                         U_symbol(t,_) -> not (is_typed tree t) | _ -> false) 
466                 then begin
467                   let tok = match pat.pat_symbol with 
468                                U_symbol(t,_) -> t | _ -> assert false in
469                   if previous_was_token then begin
470                     (* Optimized case I *)
471                     Buffer.add_string b "while yy_get_next() = ";
472                     Buffer.add_string b tok;
473                     Buffer.add_string b " do () done;\n";
474                   end
475                   else begin
476                     (* Optimized case II *)
477                     Buffer.add_string b "if yy_current() = ";
478                     Buffer.add_string b tok;
479                     Buffer.add_string b " then (";
480                     Buffer.add_string b "while yy_get_next() = ";
481                     Buffer.add_string b tok;
482                     Buffer.add_string b " do () done);\n";
483                   end
484                 end
485                 else begin
486                   (* General, non-optimized case: *)
487                   if previous_was_token then
488                     Buffer.add_string b "ignore(yy_get_next());\n";
489                   Buffer.add_string b "( try while true do (";
490                   process_symbol pat.pat_symbol false true;
491
492                   if (match pat.pat_symbol with
493                          U_symbol(_,_) -> true | _ -> false) then
494                     Buffer.add_string b "ignore(yy_get_next());\n"
495                   else
496                     Buffer.add_string b "();\n";
497
498                   Buffer.add_string b ") done with Not_found -> ());\n";
499                 end
500             | Some l ->
501                 (* CASE: repeated symbol with label *)
502                 if is_untyped_U_symbol tree pat.pat_symbol then begin
503                   (* SUBCASE: The label becomes an integer variable *)
504                   if previous_was_token then
505                     Buffer.add_string b "ignore(yy_get_next());\n";
506                   Buffer.add_string b "let yy_counter = ref 0 in\n";
507                   Buffer.add_string b "( try while true do \n";
508                   process_symbol pat.pat_symbol false true;
509                   Buffer.add_string b "incr yy_counter;\n";
510                   
511                   if (match pat.pat_symbol with
512                           U_symbol(_,_) -> true | _ -> false) then
513                     Buffer.add_string b "ignore(yy_get_next());\n";
514                   
515                   Buffer.add_string b "done with Not_found -> ());\n";
516                   Buffer.add_string b "let ";
517                   Buffer.add_string b l;
518                   Buffer.add_string b " = !yy_counter in\n";
519                 end
520                 else begin
521                   (* SUBCASE: the symbol has a value *)
522                   if previous_was_token then
523                     Buffer.add_string b "ignore(yy_get_next());\n";
524                   Buffer.add_string b "let yy_list = ref [] in\n";
525                   Buffer.add_string b "( try while true do \n";
526                   process_symbol pat.pat_symbol false true;
527                   Buffer.add_string b "yy_list := ";
528                   Buffer.add_string b l;
529                   Buffer.add_string b " :: !yy_list;\n";
530                   
531                   if (match pat.pat_symbol with
532                           U_symbol(_,_) -> true | _ -> false) then
533                     Buffer.add_string b "ignore(yy_get_next());\n";
534                   
535                   Buffer.add_string b "done with Not_found -> ());\n";
536                   Buffer.add_string b "let ";
537                   Buffer.add_string b l;
538                   Buffer.add_string b " = List.rev !yy_list in\n";
539                 end
540           end
541     end;
542
543     (* Continue: *)
544     (new_position, this_is_token)
545   in
546
547
548   let process_inner_branch current_position =
549     (* If there is "early code", run this now: *)
550     output_code b file_name branch.branch_early_code;
551     Buffer.add_string b "\n";
552
553     (* If the first symbol is a rule invocation, call the corresponding
554      * parser function now.
555      *)
556     let previous_was_token =
557       begin match branch.branch_selector with
558           U_symbol(_,_) -> 
559             true
560         | L_symbol(called_rule, args, lab) ->
561             make_rule_invocation called_rule args lab true;
562             false
563         | L_indirect(_,_,_) -> 
564             failwith("The first symbol in some rule is an indirect call; this is not allowed")
565       end
566     in
567
568     (* Now output the "let-CODE". *)
569     output_code b file_name branch.branch_binding_code;
570     Buffer.add_string b "\n";
571
572     (* Process the other symbols in turn: *)
573     let (_, previous_was_token') =
574       (List.fold_left
575          process_pattern
576          (current_position, previous_was_token)
577          branch.branch_pattern
578       )
579     in
580
581     (* Special case: 
582      *
583      * If previous_was_token', we must invoke yy_get_next one more time.
584      * This is deferred until "CODE" is executed to give this code 
585      * the chance to make the next token available (in XML, the next token
586      * might come from a different entity, and "CODE" must switch to this
587      * entity).
588      *)
589
590     (* Now output "CODE": *)
591     Buffer.add_string b "let result = \n";
592     output_code b file_name branch.branch_result_code;
593     Buffer.add_string b "\nin\n";
594
595     if previous_was_token' then
596       Buffer.add_string b "ignore(yy_get_next());\nresult\n"
597     else
598       Buffer.add_string b "result\n"
599   in
600
601   (* If we have a ? clause, generate now the "try" statement *)
602   match branch.branch_error_code with
603       None ->
604         Buffer.add_string b "( ";
605         process_inner_branch "";
606         Buffer.add_string b " )";
607     | Some code ->
608
609         (* let position = ref "<label>" in *)
610
611         Buffer.add_string b "let yy_position = ref \"";
612         let current_position =
613           match branch.branch_selector with
614               U_symbol(_,_) -> ""
615             | L_symbol(_,_,None) -> ""
616             | L_symbol(_,_,Some l) -> l
617             | L_indirect(_,_,None) -> ""
618             | L_indirect(_,_,Some l) -> l
619         in
620         Buffer.add_string b current_position;
621         Buffer.add_string b "\" in\n";
622         
623         (* The "try" statement: *)
624
625         Buffer.add_string b "( try (\n";
626
627         process_inner_branch current_position;
628
629         Buffer.add_string b "\n) with Parsing.Parse_error -> (\n";
630         output_code b file_name code;
631         Buffer.add_string b "\n))\n"
632 ;;
633
634
635 let process b file_name tree =
636   (* Iterate over the rules and output the parser functions: *)
637   let is_first = ref true in
638   List.iter
639     (fun r ->
640
641        (* Generate the function header: *)
642
643        if !is_first then
644          Buffer.add_string b "let rec "
645        else
646          Buffer.add_string b "and ";
647        is_first := false;
648        Buffer.add_string b "parse_";
649        Buffer.add_string b r.rule_name;
650        Buffer.add_string b " yy_current yy_get_next";
651        List.iter
652          (fun arg -> Buffer.add_string b " ";
653                      Buffer.add_string b arg)
654          r.rule_arguments;
655        Buffer.add_string b " =\n";
656
657        (* Generate the "match" statement: *)
658
659        Buffer.add_string b "match yy_current() with\n";
660        let s_done = ref [] in
661        (* s_done: The set of already matched tokens *)
662
663        List.iter
664          (fun branch ->
665             match branch.branch_selector with
666                 U_symbol(tok, lab) ->
667                   (* A simple token *)
668                   if List.mem tok !s_done then begin
669                     prerr_endline("WARNING: In rule `" ^ r.rule_name ^ 
670                                   "': Match for token `" ^
671                                   tok ^ "' hidden by previous match");
672                   end
673                   else
674                     if is_typed tree tok then begin
675                       match lab with
676                           None ->
677                             Buffer.add_string b "| ";
678                             Buffer.add_string b tok;
679                             Buffer.add_string b " _ -> ";
680                             process_branch b file_name tree branch;
681                             Buffer.add_string b "\n";
682                             s_done := tok :: !s_done;
683                         | Some l ->
684                             Buffer.add_string b "| ";
685                             Buffer.add_string b tok;
686                             Buffer.add_string b " ";
687                             Buffer.add_string b l;
688                             Buffer.add_string b " -> ";
689                             process_branch b file_name tree branch;
690                             Buffer.add_string b "\n";
691                             s_done := tok :: !s_done;
692                   end
693                   else begin
694                     Buffer.add_string b "| ";
695                     Buffer.add_string b tok;
696                     Buffer.add_string b " -> ";
697                     process_branch b file_name tree branch;
698                     Buffer.add_string b "\n";
699                     s_done := tok :: !s_done;
700                   end
701               | L_symbol(called_rule, args, lab) ->
702                   (* An invocation of a rule *)
703                   let s_rule = selector_set_of_rule tree called_rule in
704                   let s_rule' =
705                     List.filter
706                       (fun tok ->
707                          if List.mem tok !s_done then begin
708                            prerr_endline("WARNING: In rule `" ^ r.rule_name ^ 
709                                          "': Match for token `" ^
710                                          tok ^ "' hidden by previous match");
711                            false
712                          end
713                          else true)
714                       s_rule in
715                   if s_rule' <> [] then begin
716                     Buffer.add_string b "| ( ";
717                     let is_first = ref true in
718                     List.iter
719                       (fun tok ->
720                          if not !is_first then
721                            Buffer.add_string b " | ";
722                          is_first := false;
723                          Buffer.add_string b tok;
724                          if is_typed tree tok then
725                            Buffer.add_string b " _";
726                       )
727                       s_rule';
728                     Buffer.add_string b ") -> ";
729                     process_branch b file_name tree branch;
730                     Buffer.add_string b "\n";
731                     s_done := s_rule' @ !s_done;
732                   end
733               | L_indirect(ml_name, args, lab) ->
734                   (* An invocation of an indirect rule *)
735                   failwith("The first symbol in rule `" ^ r.rule_name ^ 
736                            "' is an indirect call; this is not allowed")
737          )
738          r.rule_branches;
739
740        Buffer.add_string b "\n| _ -> raise Not_found\n";
741     )
742     tree.text_rules;
743
744   Buffer.add_string b " in\n"
745 ;;
746
747
748 let count_lines s =
749   (* returns number of lines in s, number of columns of the last line *)
750   let l = String.length s in
751
752   let rec count n k no_cr no_lf =
753     let next_cr = 
754       if no_cr then
755         (-1)
756       else
757         try String.index_from s k '\013' with Not_found -> (-1) in
758     let next_lf = 
759       if no_lf then
760         (-1)
761       else
762         try String.index_from s k '\010' with Not_found -> (-1) in
763     if next_cr >= 0 & (next_lf < 0 or next_cr < next_lf) then begin
764       if next_cr+1 < l & s.[next_cr+1] = '\010' then
765         count (n+1) (next_cr+2) false (next_lf < 0)
766       else
767         count (n+1) (next_cr+1) false (next_lf < 0)
768     end
769     else if next_lf >= 0 then begin
770       count (n+1) (next_lf+1) (next_cr < 0) false
771     end
772     else
773       n, (l - k)
774
775   in
776   count 0 0 false false
777 ;;
778
779
780 type scan_context =
781     { mutable old_line : int;
782       mutable old_column : int;
783       mutable line : int;
784       mutable column : int;
785     }
786 ;;
787
788
789 let rec next_token context lexbuf =
790   let t = Lexer.scan_file lexbuf in
791   let line = context.line in
792   let column = context.column in
793   context.old_line <- line;
794   context.old_column <- column;
795   let n_lines, n_columns = count_lines (Lexing.lexeme lexbuf) in
796   if n_lines > 0 then begin
797     context.line <- line + n_lines;
798     context.column <- n_columns;
799   end 
800   else 
801     context.column <- column + n_columns;
802   match t with
803       Space -> next_token context lexbuf
804     | Code(s,_,_) -> Code(s,line,column + 2)
805     | Eof   -> failwith "Unexpected end of file"
806     | _     -> t
807 ;;
808
809
810 let parse_and_generate ch =
811   let b = Buffer.create 20000 in
812
813   let rec find_sep context lexbuf =
814     let t = Lexer.scan_header lexbuf in
815     let line = context.line in
816     let column = context.column in
817     context.old_line <- line;
818     context.old_column <- column;
819     let n_lines, n_columns = count_lines (Lexing.lexeme lexbuf) in
820     if n_lines > 0 then begin
821       context.line <- line + n_lines;
822       context.column <- n_columns;
823     end 
824     else 
825       context.column <- column + n_columns;
826     match t with
827         Code(s,_,_) -> 
828           Buffer.add_string b s;
829           find_sep context lexbuf
830       | Eof    -> failwith "Unexpected end of file"
831       | Separator -> ()
832       | _         -> assert false
833   in
834
835   let rec find_rest context lexbuf =
836     let t = Lexer.scan_header lexbuf in
837     let line = context.line in
838     let column = context.column in
839     context.old_line <- line;
840     context.old_column <- column;
841     let n_lines, n_columns = count_lines (Lexing.lexeme lexbuf) in
842     if n_lines > 0 then begin
843       context.line <- line + n_lines;
844       context.column <- n_columns;
845     end 
846     else 
847       context.column <- column + n_columns;
848     match t with
849         Code(s,_,_) -> 
850           Buffer.add_string b s;
851           find_rest context lexbuf
852       | Eof    -> ()
853       | _      -> assert false
854   in
855
856   (* First read until '%%' *)
857   let lexbuf = Lexing.from_channel ch in
858   let context = { old_line = 0; old_column = 0; line = 1; column = 0 } in
859   let file_name = "stdin" in
860   try
861     output_code_location b file_name ("", 1, 0);
862     find_sep context lexbuf;
863     (* Parse the following text *)
864     let text = (Parser.text (next_token context) lexbuf : Ast.text) in
865     (* Process it: *)
866     process b file_name text;
867     (* Read rest *)
868     output_code_location b file_name ("", context.line, context.column);
869     find_rest context lexbuf;
870     (* Output everything: *)
871     print_string (Buffer.contents b)
872   with
873       any ->
874         Printf.eprintf 
875           "Error at line %d column %d: %s\n"
876           context.old_line
877           context.old_column
878           (Printexc.to_string any);
879         exit 1
880 ;;
881
882
883 parse_and_generate stdin;;
884 exit 0;;
885
886 (* ======================================================================
887  * History:
888  * 
889  * $Log$
890  * Revision 1.1  2000/11/17 09:57:32  lpadovan
891  * Initial revision
892  *
893  * Revision 1.7  2000/08/17 00:33:02  gerd
894  *      Bugfix: tok* and tok? work now if tok is an untyped token
895  * without label.
896  *
897  * Revision 1.6  2000/05/14 20:59:24  gerd
898  *      Added "phantasy line numbers" to help finding errorneous locations.
899  *
900  * Revision 1.5  2000/05/14 20:41:58  gerd
901  *      x: Token?   means: if Token is detected x=true else x=false.
902  *      x: Token*   means: x becomes the number of ocurrences of Token.
903  *
904  * Revision 1.4  2000/05/09 00:03:22  gerd
905  *      Added [ ml_name ] symbols, where ml_name is an arbitrary
906  * OCaml identifier.
907  *
908  * Revision 1.3  2000/05/08 22:03:01  gerd
909  *      It is now possible to have a $ {{ }} sequence right BEFORE
910  * the first token. This code is executed just after the first token
911  * has been recognized.
912  *
913  * Revision 1.2  2000/05/06 21:51:08  gerd
914  *      Numerous bugfixes.
915  *
916  * Revision 1.1  2000/05/06 17:36:17  gerd
917  *      Initial revision.
918  *
919  * 
920  *)