(* $Id$
 * ----------------------------------------------------------------------
 *
 *)

open Parser
open Ast

(* Overall scheme:
 *
 * The rules are translated to:
 *
 * let rec parse_<rule1> ... = ...
 *     and parse_<rule2> ... = ...
 *     and ...
 *     and parse_<ruleN> ... = ...
 * in
 *
 * Every rule has at least two arguments: 'current' and 'get_next'.
 * 'current()' is the token that should match the first symbol of the
 * rule. 'get_next()' returns the next token.
 *
 * The rules may have further user arguments; these are the next arguments
 * in turn.
 *
 * The rules return the user value. After they have returned to the caller 
 * the current token is the token that follows the sequence of tokens 
 * matching the rule.
 *
 * The rules will raise:
 *  - Not_found if the first token does not match
 *  - Parsing.Parse_error if the rest does not match.
 *
 * Rule scheme:
 *
 * rule(arg1,arg2,...):
 *   (l1:x1)
 *   {{ let-CODE }}
 *   (l2:y2(name1,...)) y3 ... 
 *   {{ CODE }}
 *   ? {{ ?-CODE }}
 * | x2 ...
 * | ...
 * | xN
 *
 * let parse_<rule> current get_next arg1 arg2 ... =
 *   match current() with
 *     S(x1) -> ...
 *   | S(x2) -> ...
 *   | ...
 *   | S(xN) -> ...
*    | _ -> raise Not_found
 *
 * Here, S(xi) denotes the set of tokens matched by xi without all tokens
 * already matched by x1 to x(i-1). (If S(xi) = empty, a warning is printed,
 * and this branch of the rule is omitted.)
 *
 * S(xi) may be a set because xi may be a reference to another rule. In this
 * case, S(xi) bases on the set of tokens that match the first symbol of 
 * the other rule. (In general, S(xi) must be computed recursively.)
 *
 * If the "?" clause is present, every branch is embraced by the following:
 *
 * let position = ref "<Label of x1>" in
 * ( try ... 
 *   with Parsing.Parse_error -> ( <<?-CODE>> )
 * )
 * 
 * Next: The "..." is
 *
 * OPTIONAL: let <l1> = parse_<rule(x1)> in
 * <<let-CODE>>
 * M(y1)
 * M(y2)
 * ...
 * M(yN)
 * <<CODE>>
 *
 * If x1 is a rule invocation, it is now parsed, and the result is bound
 * to a variable.
 *
 * Note: After x1 has matched, the Caml variable <l1> must be either
 * bound to the result of the sub parsing, or to the value associated
 * with the token (if any). The latter is already done in the main
 * "match" statement, i.e. "match ... with S(x1) -> ..." is actually
 * "match ... with Token1 <l1> -> ...".
 *
 * Note: After calling parse_<rule(x1)> the exception Not_found is NEVER
 * converted to Parsing.Parse_error. It is simply not possible that this
 * happens.

 * For every remaining symbol yi of the rule, a matching statement M(yi)
 * is produced. These statements have the form:
 *
 * OPTIONAL: position := "<Label of yi>";
 * CASE: yi is a token without associated value
 *     let yy_i = get_next()  OR  current() in
 *     if yy_i <> Token(yi) then raise Parsing.Parse_error;
 * CASE: yi is a token with value
 *     let yy_i = get_next()  OR  current() in
 *     let <li> = match yy_i with Token x -> x | _ -> raise Parsing.Parse_error 
 *     in
 * CASE: yi is a rule invocation
 *     OPTIONAL: let _ = get_next() in
 *     let <li> = try parse_<rule(yi)> 
 *                with Not_found -> raise Parsing.Parse_error in
 *
 * yy_i is get_next() if y(i-1) was a token, and yy_i is current() if
 * y(i-1) was a rule invocation.
 *
 * Repetitions:
 *
 * If yi = (yi')*:
 *
 * CASE no label given:
 *
 * ( try 
 *     while true do 
 *       M(yi') with the modification that top-level mismatches raise
 *              Not_found instead of Parsing.Parse_error
 *     done
 *   with Not_found -> ()
 * )
 *
 * CASE a label <li> is given: The list of results must be bound to <li>!
 *
 * let yy_list = ref [] in
 * ( try 
 *     while true do
 *       let yy_first = M(yi') (with some modifications) in
 *       yy_list := yy_first :: !yy_list;
 *     done
 *   with Not_found -> ()
 * );
 * let <li> = List.rev !yy_list in
 *
 * Note that this scheme minimizes stack and heap allocations.
 *
 * Options:
 *
 * If yi = (yi')?:
 *
 * CASE no label given:
 *
 * ( try 
 *     M(yi') with the modification that top-level mismatches raise
 *            Not_found instead of Parsing.Parse_error
 *   with Not_found -> ()
 * )
 *
 * CASE a label <li> is given: The optional result must be bound to <li>!
 *
 * let <li> =
 *   try 
 *     Some( M(yi') (with some modifications) )
 *   with Not_found -> None
 * );
 *)


let lookup_rule tree name =
  try
    List.find (fun r -> r.rule_name = name) tree.text_rules
  with
      Not_found ->
	failwith ("Rule `" ^ name ^ "' not found")
;;


let is_typed tree name =
  (* Find out whether the token 'name' is typed or not *)
  let decl =
    try
      List.find (fun d -> match d with
		     D_token n -> n = name
		   | D_typed_token n -> n = name
		)
	tree.text_decls
    with
	Not_found -> 
	  failwith ("Token `" ^ name ^ "' not found")
  in
  match decl with
      D_token _ -> false
    | D_typed_token _ -> true
;;


let label_of_symbol tree sym =
  match sym with
      U_symbol (tok, lab) -> 
	(* if is_typed tree tok then lab else None *)
	lab
    | L_symbol (_, _, lab) -> lab
    | L_indirect (_, _, lab) -> lab
;;


let is_untyped_U_symbol tree sym =
  match sym with
      U_symbol (tok, _) -> 
	not(is_typed tree tok)
    | L_symbol (_, _, _) -> false
    | L_indirect (_, _, _) -> false
;;



let rec set_of_list l =
  (* Removes duplicate members of l *)
  match l with
      [] -> []
    | x :: l' -> if List.mem x l' then set_of_list l' else x :: (set_of_list l')
;;


let selector_set_of_rule tree name =
  (* Determines the set of tokens that match the first symbol of a rule *)
  
  let rec collect visited_rules name =
    if List.mem name visited_rules then
      []
    else
      let r = lookup_rule tree name in
      List.flatten
	(List.map
	   (fun branch ->
	      match branch.branch_selector with
		  U_symbol (tok_name,_) ->
		    [ tok_name ]
		| L_symbol (rule_name, _, _) ->
		    collect (name :: visited_rules) rule_name
		| L_indirect (_, _, _) ->
		    failwith("The first symbol in rule `" ^ name ^ 
			     "' is an indirect call; this is not allowed")
	   )
	   r.rule_branches
	)
  in
  set_of_list (collect [] name)
;;


let output_code_location b file_name (_, line, column) = 
  Buffer.add_string b "\n";
  Buffer.add_string b ("# " ^ string_of_int line ^ " \"" ^
		       file_name ^ "\"\n");
  Buffer.add_string b (String.make column ' ')
;;


let phantasy_line = ref 100000;;

let output_code b file_name ((code, line, column) as triple) = 
  if code <> "" then begin
    output_code_location b file_name triple;
    Buffer.add_string b code;
    Buffer.add_string b ("\n# " ^ string_of_int !phantasy_line ^ " \"<Generated Code>\"\n");
    phantasy_line := !phantasy_line + 10000;
  end
;;


let process_branch b file_name tree branch =

  let make_rule_invocation called_rule args lab allow_not_found =
    (* Produces: let <label> = parse_<called_rule> ... args in 
     * If not allow_not_found, the exception Not_found is caught and
     * changed into Parsing.Parse_error.
     *)
    let r = lookup_rule tree called_rule in
    if List.length r.rule_arguments <> List.length args then
      failwith("Calling rule `" ^ called_rule ^ "' with the wrong number of arguments!");

    Buffer.add_string b "let ";
    begin match lab with
	None   -> Buffer.add_string b "_"
      | Some l -> Buffer.add_string b l
    end;
    Buffer.add_string b " = ";
    if not allow_not_found then
      Buffer.add_string b "try ";
    Buffer.add_string b "parse_";
    Buffer.add_string b called_rule;
    Buffer.add_string b " yy_current yy_get_next";
    List.iter
      (fun a -> Buffer.add_string b " ";
	        Buffer.add_string b a;
      )
      args;
    if not allow_not_found then
      Buffer.add_string b " with Not_found -> raise Parsing.Parse_error";
    Buffer.add_string b " in\n"
  in

  let make_indirect_rule_invocation ml_name args lab allow_not_found =
    (* Produces: let <label> = ml_name ... args in 
     * If not allow_not_found, the exception Not_found is caught and
     * changed into Parsing.Parse_error.
     *)
    Buffer.add_string b "let ";
    begin match lab with
	None   -> Buffer.add_string b "_"
      | Some l -> Buffer.add_string b l
    end;
    Buffer.add_string b " = ";
    if not allow_not_found then
      Buffer.add_string b "try ";
    Buffer.add_string b ml_name;
    Buffer.add_string b " yy_current yy_get_next";
    List.iter
      (fun a -> Buffer.add_string b " ";
	        Buffer.add_string b a;
      )
      args;
    if not allow_not_found then
      Buffer.add_string b " with Not_found -> raise Parsing.Parse_error";
    Buffer.add_string b " in\n"
  in

  let process_symbol sym previous_was_token allow_not_found =
    match sym with
	U_symbol(tok, lab) ->
	  (* Distinguish between simple tokens and typed tokens *)
	  if is_typed tree tok then begin
	    (* Typed token *)
	    Buffer.add_string b "let ";
	    begin match lab with
		None   -> Buffer.add_string b "_"
	      | Some l -> Buffer.add_string b l
	    end;
	    Buffer.add_string b " = match ";
	    if previous_was_token then
	      Buffer.add_string b "yy_get_next()"
	    else
	      Buffer.add_string b "yy_current()";
	    Buffer.add_string b " with ";
	    Buffer.add_string b tok;
	    Buffer.add_string b " x -> x | _ -> raise ";
	    if allow_not_found then
	      Buffer.add_string b "Not_found"
	    else
	      Buffer.add_string b "Parsing.Parse_error";
	    Buffer.add_string b " in\n";
	  end
	  else begin
	    (* Simple token *)
	    Buffer.add_string b "if (";
	    if previous_was_token then
	      Buffer.add_string b "yy_get_next()"
	    else
	      Buffer.add_string b "yy_current()";
	    Buffer.add_string b ") <> ";
	    Buffer.add_string b tok;
	    Buffer.add_string b " then raise ";
	    if allow_not_found then
	      Buffer.add_string b "Not_found;\n"
	    else
	      Buffer.add_string b "Parsing.Parse_error;\n"
	  end
      | L_symbol(called_rule, args, lab) ->
	  if previous_was_token then
	    Buffer.add_string b "ignore(yy_get_next());\n";
	  make_rule_invocation called_rule args lab allow_not_found
      | L_indirect(ml_name, args, lab) ->
	  if previous_was_token then
	    Buffer.add_string b "ignore(yy_get_next());\n";
	  make_indirect_rule_invocation ml_name args lab allow_not_found
  in

  let process_pattern (current_position, previous_was_token) pat =
    (* Assign "position" if necessary. *)
    let new_position =
      if branch.branch_error_code <> None then begin
	match pat.pat_symbol with
	    U_symbol(_,Some l)   -> l
	  | L_symbol(_,_,Some l) -> l
	  | L_indirect(_,_,Some l) -> l
	  | _ -> ""
      end
      else ""
    in
    if new_position <> current_position then begin
      Buffer.add_string b "yy_position := \"";
      Buffer.add_string b new_position;
      Buffer.add_string b "\";\n";
    end;

    let this_is_token =
      match pat.pat_symbol with
	  U_symbol(_,_)   -> pat.pat_modifier = Exact
	| L_symbol(_,_,_) -> false
	| L_indirect(_,_,_) -> false
    in

    (* First distinguish between Exact, Option, and Repetition: *)
    begin match pat.pat_modifier with
	Exact ->
	  process_symbol pat.pat_symbol previous_was_token false
      | Option ->
	  begin match label_of_symbol tree pat.pat_symbol with
	      None ->
		(* CASE: optional symbol without label *)
		(* OPTIMIZATION: If the symbol is
		 * a token, the loop becomes very simple.
		 *)
		if (match pat.pat_symbol with 
			U_symbol(t,_) -> not (is_typed tree t) | _ -> false) 
		then begin
		  let tok = match pat.pat_symbol with 
		               U_symbol(t,_) -> t | _ -> assert false in
		  (* Optimized case *)
		  Buffer.add_string b "if ";
		  if previous_was_token then
		    Buffer.add_string b "yy_get_next()"
		  else
		    Buffer.add_string b "yy_current()";
		  Buffer.add_string b " = ";
		  Buffer.add_string b tok;
		  Buffer.add_string b " then ignore(yy_get_next());\n";
		end
		else begin
		  (* General, non-optimized case: *)
		  Buffer.add_string b "( try (";
		  process_symbol pat.pat_symbol previous_was_token true;
		  Buffer.add_string b "ignore(yy_get_next());\n";
		  Buffer.add_string b ") with Not_found -> ());\n";
		end
	    | Some l ->
		(* CASE: optional symbol with label *)
		if is_untyped_U_symbol tree pat.pat_symbol then begin
		  (* SUBCASE: The label becomes a boolean variable *)
		  Buffer.add_string b "let ";
		  Buffer.add_string b l;
		  Buffer.add_string b " = try (";
		  process_symbol pat.pat_symbol previous_was_token true;
		  Buffer.add_string b ");\n";
		  Buffer.add_string b "ignore(yy_get_next());\n";
		  Buffer.add_string b "true with Not_found -> false in\n";
		end
		else begin
		  (* SUBCASE: the symbol has a value *)
		  Buffer.add_string b "let ";
		  Buffer.add_string b l;
		  Buffer.add_string b " = try let yy_tok = Some(";
		  process_symbol pat.pat_symbol previous_was_token true;
		  Buffer.add_string b l;
		  Buffer.add_string b ") in\n";
		  
		  if (match pat.pat_symbol with
			  U_symbol(_,_) -> true | _ -> false) then
		    Buffer.add_string b "ignore(yy_get_next());\n";
		  
		  Buffer.add_string b "yy_tok with Not_found -> None in\n";
		end
	  end
      | Repetition ->
	  begin match label_of_symbol tree pat.pat_symbol with
	      None ->
		(* CASE: repeated symbol without label *)
		(* OPTIMIZATION: If the symbol is
		 * a token, the loop becomes very simple.
		 *)
		if (match pat.pat_symbol with 
			U_symbol(t,_) -> not (is_typed tree t) | _ -> false) 
		then begin
		  let tok = match pat.pat_symbol with 
		               U_symbol(t,_) -> t | _ -> assert false in
		  if previous_was_token then begin
		    (* Optimized case I *)
		    Buffer.add_string b "while yy_get_next() = ";
		    Buffer.add_string b tok;
		    Buffer.add_string b " do () done;\n";
		  end
		  else begin
		    (* Optimized case II *)
		    Buffer.add_string b "if yy_current() = ";
		    Buffer.add_string b tok;
		    Buffer.add_string b " then (";
		    Buffer.add_string b "while yy_get_next() = ";
		    Buffer.add_string b tok;
		    Buffer.add_string b " do () done);\n";
		  end
		end
		else begin
		  (* General, non-optimized case: *)
		  if previous_was_token then
		    Buffer.add_string b "ignore(yy_get_next());\n";
		  Buffer.add_string b "( try while true do (";
		  process_symbol pat.pat_symbol false true;

		  if (match pat.pat_symbol with
			 U_symbol(_,_) -> true | _ -> false) then
		    Buffer.add_string b "ignore(yy_get_next());\n"
		  else
		    Buffer.add_string b "();\n";

		  Buffer.add_string b ") done with Not_found -> ());\n";
		end
	    | Some l ->
		(* CASE: repeated symbol with label *)
		if is_untyped_U_symbol tree pat.pat_symbol then begin
		  (* SUBCASE: The label becomes an integer variable *)
		  if previous_was_token then
		    Buffer.add_string b "ignore(yy_get_next());\n";
		  Buffer.add_string b "let yy_counter = ref 0 in\n";
		  Buffer.add_string b "( try while true do \n";
		  process_symbol pat.pat_symbol false true;
		  Buffer.add_string b "incr yy_counter;\n";
		  
		  if (match pat.pat_symbol with
			  U_symbol(_,_) -> true | _ -> false) then
		    Buffer.add_string b "ignore(yy_get_next());\n";
		  
		  Buffer.add_string b "done with Not_found -> ());\n";
		  Buffer.add_string b "let ";
		  Buffer.add_string b l;
		  Buffer.add_string b " = !yy_counter in\n";
		end
		else begin
		  (* SUBCASE: the symbol has a value *)
		  if previous_was_token then
		    Buffer.add_string b "ignore(yy_get_next());\n";
		  Buffer.add_string b "let yy_list = ref [] in\n";
		  Buffer.add_string b "( try while true do \n";
		  process_symbol pat.pat_symbol false true;
		  Buffer.add_string b "yy_list := ";
		  Buffer.add_string b l;
		  Buffer.add_string b " :: !yy_list;\n";
		  
		  if (match pat.pat_symbol with
			  U_symbol(_,_) -> true | _ -> false) then
		    Buffer.add_string b "ignore(yy_get_next());\n";
		  
		  Buffer.add_string b "done with Not_found -> ());\n";
		  Buffer.add_string b "let ";
		  Buffer.add_string b l;
		  Buffer.add_string b " = List.rev !yy_list in\n";
		end
	  end
    end;

    (* Continue: *)
    (new_position, this_is_token)
  in


  let process_inner_branch current_position =
    (* If there is "early code", run this now: *)
    output_code b file_name branch.branch_early_code;
    Buffer.add_string b "\n";

    (* If the first symbol is a rule invocation, call the corresponding
     * parser function now.
     *)
    let previous_was_token =
      begin match branch.branch_selector with
	  U_symbol(_,_) -> 
	    true
	| L_symbol(called_rule, args, lab) ->
	    make_rule_invocation called_rule args lab true;
	    false
	| L_indirect(_,_,_) -> 
	    failwith("The first symbol in some rule is an indirect call; this is not allowed")
      end
    in

    (* Now output the "let-CODE". *)
    output_code b file_name branch.branch_binding_code;
    Buffer.add_string b "\n";

    (* Process the other symbols in turn: *)
    let (_, previous_was_token') =
      (List.fold_left
	 process_pattern
	 (current_position, previous_was_token)
	 branch.branch_pattern
      )
    in

    (* Special case: 
     *
     * If previous_was_token', we must invoke yy_get_next one more time.
     * This is deferred until "CODE" is executed to give this code 
     * the chance to make the next token available (in XML, the next token
     * might come from a different entity, and "CODE" must switch to this
     * entity).
     *)

    (* Now output "CODE": *)
    Buffer.add_string b "let result = \n";
    output_code b file_name branch.branch_result_code;
    Buffer.add_string b "\nin\n";

    if previous_was_token' then
      Buffer.add_string b "ignore(yy_get_next());\nresult\n"
    else
      Buffer.add_string b "result\n"
  in

  (* If we have a ? clause, generate now the "try" statement *)
  match branch.branch_error_code with
      None ->
	Buffer.add_string b "( ";
	process_inner_branch "";
	Buffer.add_string b " )";
    | Some code ->

	(* let position = ref "<label>" in *)

	Buffer.add_string b "let yy_position = ref \"";
	let current_position =
	  match branch.branch_selector with
	      U_symbol(_,_) -> ""
	    | L_symbol(_,_,None) -> ""
	    | L_symbol(_,_,Some l) -> l
	    | L_indirect(_,_,None) -> ""
	    | L_indirect(_,_,Some l) -> l
	in
	Buffer.add_string b current_position;
	Buffer.add_string b "\" in\n";
	
	(* The "try" statement: *)

	Buffer.add_string b "( try (\n";

	process_inner_branch current_position;

	Buffer.add_string b "\n) with Parsing.Parse_error -> (\n";
	output_code b file_name code;
	Buffer.add_string b "\n))\n"
;;


let process b file_name tree =
  (* Iterate over the rules and output the parser functions: *)
  let is_first = ref true in
  List.iter
    (fun r ->

       (* Generate the function header: *)

       if !is_first then
	 Buffer.add_string b "let rec "
       else
	 Buffer.add_string b "and ";
       is_first := false;
       Buffer.add_string b "parse_";
       Buffer.add_string b r.rule_name;
       Buffer.add_string b " yy_current yy_get_next";
       List.iter
	 (fun arg -> Buffer.add_string b " ";
	             Buffer.add_string b arg)
	 r.rule_arguments;
       Buffer.add_string b " =\n";

       (* Generate the "match" statement: *)

       Buffer.add_string b "match yy_current() with\n";
       let s_done = ref [] in
       (* s_done: The set of already matched tokens *)

       List.iter
	 (fun branch ->
	    match branch.branch_selector with
		U_symbol(tok, lab) ->
		  (* A simple token *)
		  if List.mem tok !s_done then begin
		    prerr_endline("WARNING: In rule `" ^ r.rule_name ^ 
				  "': Match for token `" ^
				  tok ^ "' hidden by previous match");
		  end
		  else
		    if is_typed tree tok then begin
		      match lab with
			  None ->
			    Buffer.add_string b "| ";
			    Buffer.add_string b tok;
			    Buffer.add_string b " _ -> ";
			    process_branch b file_name tree branch;
			    Buffer.add_string b "\n";
			    s_done := tok :: !s_done;
			| Some l ->
			    Buffer.add_string b "| ";
			    Buffer.add_string b tok;
			    Buffer.add_string b " ";
			    Buffer.add_string b l;
			    Buffer.add_string b " -> ";
			    process_branch b file_name tree branch;
			    Buffer.add_string b "\n";
			    s_done := tok :: !s_done;
		  end
		  else begin
		    Buffer.add_string b "| ";
		    Buffer.add_string b tok;
		    Buffer.add_string b " -> ";
		    process_branch b file_name tree branch;
		    Buffer.add_string b "\n";
		    s_done := tok :: !s_done;
		  end
	      | L_symbol(called_rule, args, lab) ->
		  (* An invocation of a rule *)
		  let s_rule = selector_set_of_rule tree called_rule in
		  let s_rule' =
		    List.filter
		      (fun tok ->
			 if List.mem tok !s_done then begin
			   prerr_endline("WARNING: In rule `" ^ r.rule_name ^ 
					 "': Match for token `" ^
					 tok ^ "' hidden by previous match");
			   false
			 end
			 else true)
		      s_rule in
		  if s_rule' <> [] then begin
		    Buffer.add_string b "| ( ";
		    let is_first = ref true in
		    List.iter
		      (fun tok ->
			 if not !is_first then
			   Buffer.add_string b " | ";
			 is_first := false;
			 Buffer.add_string b tok;
			 if is_typed tree tok then
			   Buffer.add_string b " _";
		      )
		      s_rule';
		    Buffer.add_string b ") -> ";
		    process_branch b file_name tree branch;
		    Buffer.add_string b "\n";
		    s_done := s_rule' @ !s_done;
		  end
	      | L_indirect(ml_name, args, lab) ->
		  (* An invocation of an indirect rule *)
		  failwith("The first symbol in rule `" ^ r.rule_name ^ 
			   "' is an indirect call; this is not allowed")
	 )
	 r.rule_branches;

       Buffer.add_string b "\n| _ -> raise Not_found\n";
    )
    tree.text_rules;

  Buffer.add_string b " in\n"
;;


let count_lines s =
  (* returns number of lines in s, number of columns of the last line *)
  let l = String.length s in

  let rec count n k no_cr no_lf =
    let next_cr = 
      if no_cr then
        (-1)
      else
        try String.index_from s k '\013' with Not_found -> (-1) in
    let next_lf = 
      if no_lf then
        (-1)
      else
        try String.index_from s k '\010' with Not_found -> (-1) in
    if next_cr >= 0 & (next_lf < 0 or next_cr < next_lf) then begin
      if next_cr+1 < l & s.[next_cr+1] = '\010' then
        count (n+1) (next_cr+2) false (next_lf < 0)
      else
        count (n+1) (next_cr+1) false (next_lf < 0)
    end
    else if next_lf >= 0 then begin
      count (n+1) (next_lf+1) (next_cr < 0) false
    end
    else
      n, (l - k)

  in
  count 0 0 false false
;;


type scan_context =
    { mutable old_line : int;
      mutable old_column : int;
      mutable line : int;
      mutable column : int;
    }
;;


let rec next_token context lexbuf =
  let t = Lexer.scan_file lexbuf in
  let line = context.line in
  let column = context.column in
  context.old_line <- line;
  context.old_column <- column;
  let n_lines, n_columns = count_lines (Lexing.lexeme lexbuf) in
  if n_lines > 0 then begin
    context.line <- line + n_lines;
    context.column <- n_columns;
  end 
  else 
    context.column <- column + n_columns;
  match t with
      Space -> next_token context lexbuf
    | Code(s,_,_) -> Code(s,line,column + 2)
    | Eof   -> failwith "Unexpected end of file"
    | _     -> t
;;


let parse_and_generate ch =
  let b = Buffer.create 20000 in

  let rec find_sep context lexbuf =
    let t = Lexer.scan_header lexbuf in
    let line = context.line in
    let column = context.column in
    context.old_line <- line;
    context.old_column <- column;
    let n_lines, n_columns = count_lines (Lexing.lexeme lexbuf) in
    if n_lines > 0 then begin
      context.line <- line + n_lines;
      context.column <- n_columns;
    end 
    else 
      context.column <- column + n_columns;
    match t with
	Code(s,_,_) -> 
	  Buffer.add_string b s;
          find_sep context lexbuf
      | Eof    -> failwith "Unexpected end of file"
      | Separator -> ()
      | _         -> assert false
  in

  let rec find_rest context lexbuf =
    let t = Lexer.scan_header lexbuf in
    let line = context.line in
    let column = context.column in
    context.old_line <- line;
    context.old_column <- column;
    let n_lines, n_columns = count_lines (Lexing.lexeme lexbuf) in
    if n_lines > 0 then begin
      context.line <- line + n_lines;
      context.column <- n_columns;
    end 
    else 
      context.column <- column + n_columns;
    match t with
	Code(s,_,_) -> 
	  Buffer.add_string b s;
          find_rest context lexbuf
      | Eof    -> ()
      | _      -> assert false
  in

  (* First read until '%%' *)
  let lexbuf = Lexing.from_channel ch in
  let context = { old_line = 0; old_column = 0; line = 1; column = 0 } in
  let file_name = "stdin" in
  try
    output_code_location b file_name ("", 1, 0);
    find_sep context lexbuf;
    (* Parse the following text *)
    let text = (Parser.text (next_token context) lexbuf : Ast.text) in
    (* Process it: *)
    process b file_name text;
    (* Read rest *)
    output_code_location b file_name ("", context.line, context.column);
    find_rest context lexbuf;
    (* Output everything: *)
    print_string (Buffer.contents b)
  with
      any ->
	Printf.eprintf 
	  "Error at line %d column %d: %s\n"
	  context.old_line
	  context.old_column
	  (Printexc.to_string any);
	exit 1
;;


parse_and_generate stdin;;
exit 0;;

(* ======================================================================
 * History:
 * 
 * $Log$
 * Revision 1.1  2000/11/17 09:57:32  lpadovan
 * Initial revision
 *
 * Revision 1.7  2000/08/17 00:33:02  gerd
 * 	Bugfix: tok* and tok? work now if tok is an untyped token
 * without label.
 *
 * Revision 1.6  2000/05/14 20:59:24  gerd
 * 	Added "phantasy line numbers" to help finding errorneous locations.
 *
 * Revision 1.5  2000/05/14 20:41:58  gerd
 * 	x: Token?   means: if Token is detected x=true else x=false.
 * 	x: Token*   means: x becomes the number of ocurrences of Token.
 *
 * Revision 1.4  2000/05/09 00:03:22  gerd
 * 	Added [ ml_name ] symbols, where ml_name is an arbitrary
 * OCaml identifier.
 *
 * Revision 1.3  2000/05/08 22:03:01  gerd
 * 	It is now possible to have a $ {{ }} sequence right BEFORE
 * the first token. This code is executed just after the first token
 * has been recognized.
 *
 * Revision 1.2  2000/05/06 21:51:08  gerd
 * 	Numerous bugfixes.
 *
 * Revision 1.1  2000/05/06 17:36:17  gerd
 * 	Initial revision.
 *
 * 
 *)