140 lines
4.3 KiB
OCaml
140 lines
4.3 KiB
OCaml
(* camlp4r *)
|
|
(***********************************************************************)
|
|
(* *)
|
|
(* Camlp4 *)
|
|
(* *)
|
|
(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *)
|
|
(* *)
|
|
(* Copyright 2002 Institut National de Recherche en Informatique et *)
|
|
(* Automatique. Distributed only by permission. *)
|
|
(* *)
|
|
(***********************************************************************)
|
|
|
|
(* $Id$ *)
|
|
|
|
value buff = ref (String.create 80);
|
|
value store len x =
|
|
do {
|
|
if len >= String.length buff.val then
|
|
buff.val := buff.val ^ String.create (String.length buff.val)
|
|
else ();
|
|
buff.val.[len] := x;
|
|
succ len
|
|
}
|
|
;
|
|
value get_buff len = String.sub buff.val 0 len;
|
|
|
|
value rec copy_strip_locate cs =
|
|
match cs with parser
|
|
[ [: `'$' :] -> maybe_locate cs
|
|
| [: `c :] -> do { print_char c; copy_strip_locate cs }
|
|
| [: :] -> () ]
|
|
and maybe_locate cs =
|
|
match cs with parser
|
|
[ [: `'1'..'9' :] -> locate cs
|
|
| [: :] -> do { print_char '$'; copy_strip_locate cs } ]
|
|
and locate cs =
|
|
match cs with parser
|
|
[ [: `'0'..'9' :] -> locate cs
|
|
| [: `':' :] -> inside_locate cs
|
|
| [: :] -> raise (Stream.Error "colon char expected") ]
|
|
and inside_locate cs =
|
|
match cs with parser
|
|
[ [: `'$' :] -> copy_strip_locate cs
|
|
| [: `'\\'; `c :] -> do { print_char c; inside_locate cs }
|
|
| [: `c :] -> do { print_char c; inside_locate cs }
|
|
| [: :] -> raise (Stream.Error "end of file in locate directive") ]
|
|
;
|
|
|
|
value quot name pos str =
|
|
let exp =
|
|
try
|
|
match Quotation.find name with
|
|
[ Quotation.ExStr f -> f
|
|
| _ -> raise Not_found ]
|
|
with
|
|
[ Not_found ->
|
|
Stdpp.raise_with_loc (pos, pos + String.length str) Not_found ]
|
|
in
|
|
let new_str =
|
|
try exp True str with
|
|
[ Stdpp.Exc_located (p1, p2) exc ->
|
|
Stdpp.raise_with_loc (pos + p1, pos + p2) exc
|
|
| exc -> Stdpp.raise_with_loc (pos, pos + String.length str) exc ]
|
|
in
|
|
let cs = Stream.of_string new_str in copy_strip_locate cs
|
|
;
|
|
|
|
value rec ident len =
|
|
parser
|
|
[ [: `('A'..'Z' | 'a'..'z' | '0'..'9' | '_' | ''' as c); s :] ->
|
|
ident (store len c) s
|
|
| [: :] -> get_buff len ]
|
|
;
|
|
|
|
value rec copy cs =
|
|
match cs with parser
|
|
[ [: `'<' :] -> maybe_quot cs
|
|
| [: `'"' :] -> do { print_char '"'; inside_string cs }
|
|
| [: `c :] -> do { print_char c; copy cs }
|
|
| [: :] -> () ]
|
|
and maybe_quot cs =
|
|
match cs with parser
|
|
[ [: `'<' :] ep -> inside_quot "" ep 0 cs
|
|
| [: `':'; i = ident 0; `'<' ? "less char expected" :] ep ->
|
|
inside_quot i ep 0 cs
|
|
| [: :] -> do { print_char '<'; copy cs } ]
|
|
and inside_quot name pos len cs =
|
|
match cs with parser
|
|
[ [: `'>' :] -> maybe_end_quot name pos len cs
|
|
| [: `c :] -> inside_quot name pos (store len c) cs
|
|
| [: :] -> raise (Stream.Error "end of file in quotation") ]
|
|
and maybe_end_quot name pos len cs =
|
|
match cs with parser
|
|
[ [: `'>' :] -> do { quot name pos (get_buff len); copy cs }
|
|
| [: :] -> inside_quot name pos (store len '>') cs ]
|
|
and inside_string cs =
|
|
match cs with parser
|
|
[ [: `'"' :] -> do { print_char '"'; copy cs }
|
|
| [: `c :] -> do { print_char c; inside_string cs }
|
|
| [: :] -> raise (Stream.Error "end of file in string") ]
|
|
;
|
|
|
|
value copy_quot cs = do { copy cs; flush stdout; };
|
|
|
|
value loc_fmt =
|
|
match Sys.os_type with
|
|
[ "MacOS" ->
|
|
("File \"%s\"; line %d; characters %d to %d\n### " : format 'a 'b 'c)
|
|
| _ -> ("File \"%s\", line %d, characters %d-%d:\n" : format 'a 'b 'c) ]
|
|
;
|
|
|
|
value print_location loc file =
|
|
let (line, c1, c2) = Stdpp.line_of_loc file loc in
|
|
do { Printf.eprintf loc_fmt file line c1 c2; flush stderr; }
|
|
;
|
|
|
|
value file = ref "";
|
|
Arg.parse [] (fun x -> file.val := x) "ocpp <objects> <file>";
|
|
|
|
value main () =
|
|
try
|
|
if file.val <> "" then
|
|
copy_quot (Stream.of_channel (open_in_bin file.val))
|
|
else ()
|
|
with exc ->
|
|
do {
|
|
print_newline ();
|
|
flush stdout;
|
|
let exc =
|
|
match exc with
|
|
[ Stdpp.Exc_located loc exc -> do { print_location loc file.val; exc }
|
|
| exc -> exc ]
|
|
in
|
|
raise exc
|
|
}
|
|
;
|
|
|
|
Odyl_main.name.val := "ocpp";
|
|
Odyl_main.go.val := main;
|