+++ /dev/null
-(* $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.
- *
- *
- *)
projects / helm.git / blobdiff