(* Time-stamp: <modified the 08/03/2016 (at 15:01) by Erwan Jahier> *)
(*-----------------------------------------------------------------------
** This file may only be copied under the terms of the GNU Library General
** Public License
**-----------------------------------------------------------------------
**
** File: rifIO.ml
** Author: jahier@imag.fr
*)
open List
let lexer = LocalGenlex.make_lexer ["q"; "nil"; "?"; "ERROR";"Error";"error"; "#";
"x"; "load_luc"; "#@"; "@#";"end"]
(* xxx Which pragmas should be defined ? *)
let rif_pragmas = ["inputs"]
(* let rif_pragmas = ["outs";"outputs";"program";"inputs";"step";"reset"] *)
type stream = LocalGenlex.token Stream.t
let rec (parse_string_list : stream -> string list -> string list) =
fun stream sl ->
try (
match (Stream.next stream) with
(LocalGenlex.String(str)) -> parse_string_list stream (str::sl)
| _ -> failwith ("### rif parse error. A \"string\" (wrapped with double" ^
"quotes) was expected. \n")
)
with Stream.Failure ->
sl
open Data
(*------------------------------------------------------------------------*)
exception Bye
let read_line debug label ic oc =
let str = input_line ic in
let _ =
if debug then (
prerr_string ("["^label^"] RifIO.read_line:'"^str^"'\n"); flush stderr)
in
let str = Str.global_replace (Str.regexp "\013") "" str in
(match oc with
| Some oc -> output_string oc str; flush oc
| None -> ());
str
let get_stream debug label ic oc =
try
let str = read_line debug label ic oc in
str, lexer (Stream.of_string str)
with e ->
print_string ("*** Error when parsing RIF: " ^ (Printexc.to_string e) ^ "\n");
flush stdout;
exit 2
let (rm_blank : string -> string) =
fun s ->
let buff = ref "" in
for i = 0 to String.length s - 1 do
match s.[i] with
| ' ' | '\t' | '\n' | '\"' -> ()
| c -> buff:=!buff^(String.make 1 c)
done;
!buff
let (to_pair : string -> string * Data.t) =
fun s ->
match Str.split (Str.regexp ":") s with
| [n;t] -> rm_blank n, Data.type_of_string (rm_blank t)
| _ -> failwith ("Rif parse error: Cannot split '"^s^
"'. I expect a string of the form <ident>:<ident>")
let _ = assert (to_pair "T:bool" = ("T",Data.Bool))
let strsub str i j =
try String.sub str i j
with _ ->
Printf.printf "invalid arg in 'String.sub %s %i %i'\n" str i j;
flush stdout;
exit 2
let rec (read_until_pragma_end :?debug:(bool) -> in_channel -> out_channel option ->
string -> string) =
fun ?(debug=false) ic oc str ->
let line = read_line debug "" ic oc in
try
let i = Str.search_forward (Str.regexp "#@") line 0 in
(String.sub line 0 i) ^ str
with Not_found ->
read_until_pragma_end ~debug:debug ic oc (str^" "^line)
(* exported *)
let rec (read_interface : ?debug:(bool) -> ?label:(string) -> in_channel ->
out_channel option -> vntl * vntl) =
fun ?(debug=false) ?(label="") ic oc ->
let rec loop ins outs =
if ins <> [] && outs <> [] then ins, outs else
let line = read_line debug label ic oc in
try
if (Str.string_match (Str.regexp "#end") line 0) || line = "q" || line = "bye"
then (
Printf.printf "\n*** RifIO.read_interface: The process %s died before " label;
Printf.printf "sending its interface declarations.\n*** Hara-Kiring!\n" ;
flush stdout;
raise Bye
)
else if Str.string_match (Str.regexp "#inputs") line 0 then
let str = strsub line 7 (String.length line - 7) in
let l = Str.split (Str.regexp " ") str in
let l = List.filter (fun str -> str <> "") l in
loop (List.map to_pair l) outs
else if Str.string_match (Str.regexp "@#inputs") line 0 then
let str = strsub line 8 (String.length line - 8) in
let str = read_until_pragma_end ~debug:debug ic oc str in
let l = Str.split (Str.regexp " ") str in
let l = List.filter (fun str -> str <> "") l in
loop (List.map to_pair l) outs
else if Str.string_match (Str.regexp "#outputs") line 0 then
let str = strsub line 8 (String.length line - 8) in
let l = Str.split (Str.regexp " ") str in
let l = List.filter (fun str -> str <> "") l in
loop ins (List.map to_pair l)
else if Str.string_match (Str.regexp "@#outputs") line 0 then
let str = strsub line 9 (String.length line - 9) in
let str = read_until_pragma_end ~debug:debug ic oc str in
let l = Str.split (Str.regexp " ") str in
let l = List.filter (fun str -> str <> "") l in
loop ins (List.map to_pair l)
else
loop ins outs
with e ->
print_string ("#" ^line ^"\n");
flush stdout;
raise e
in
loop [] []
(* exported *)
let rec (read : ?debug:(bool) -> ?label:(string) -> ?pragma:(string list) ->
in_channel -> out_channel option -> vntl -> subst list) =
fun ?(debug=false) ?(label="") ?(pragma = []) ic oc vntl ->
(** Reads input values on ic. It should follow the rif format. *)
let tbl = [] in
if vntl = [] then tbl else
let str,stream = get_stream debug label ic oc in
parse_rif_stream ~debug:debug label ic oc vntl (str,stream) tbl pragma
and (parse_rif_stream :
?debug:(bool) -> string -> in_channel -> out_channel option -> vntl ->
string * stream -> subst list -> string list -> subst list) =
fun ?(debug=false) label ic oc vntl (str,stream) tbl pragma ->
if vntl = [] then tbl else
let tok_list = Stream.npeek 2 stream in
match tok_list with
| [LocalGenlex.Kwd ("#"); LocalGenlex.Ident (id)] ->
if List.mem id pragma then (
Stream.junk stream ;
Stream.junk stream ;
parse_rif_stream label ic oc vntl (str,stream) tbl pragma
) else (
(* We skip everything that occurs after a [#], until the next eol. *)
Stream.junk stream ;
(* prerr_endline (">>" ^str); print the ignored string on stderr *)
parse_rif_stream label ic oc
vntl (get_stream debug label ic oc) tbl pragma
)
| (LocalGenlex.Kwd ("#"))::(LocalGenlex.Kwd ("ERROR"|"Error"|"end"))::_ ->
print_string (str^"\n"); raise Bye
| (LocalGenlex.Kwd ("#"))::_ ->
Stream.junk stream ;
(* prerr_endline (">>>" ^str); print the ignored string on stderr *)
parse_rif_stream label ic oc vntl (get_stream debug label ic oc) tbl pragma
| (LocalGenlex.Kwd ("ERROR"|"Error"|"error"))::_ ->
print_string ("#ERROR value read. bye! ("^str^")\n");
flush stdout;
raise Bye
| (LocalGenlex.Kwd ("q"))::_ -> print_string "# bye!\n"; raise Bye
| (LocalGenlex.Kwd ("#@"))::_ ->
(* Beginning of multi-line comment. Note that here,
unlike the rif format, we ignore multi line pragmas;
namely, we handle them as a multi-line comment. *)
(
Stream.junk stream ;
ignore_toks_until_end_of_pragmas
debug label ic oc vntl (str,stream) tbl pragma
)
| (LocalGenlex.Kwd ("nil"))::_
| (LocalGenlex.Kwd ("?"))::_ ->
Stream.junk stream ;
let tbl = tbl @[fst (hd vntl), U] in
parse_rif_stream label ic oc (tl vntl) (str,stream) tbl pragma
| (LocalGenlex.Float (f))::_ ->
(
Stream.junk stream ;
(* Hashtbl.add tbl (Var.name (hd vntl)) (N(F(f))) ; *)
let v =
match snd (hd vntl) with
| Data.Bool -> B(f<>0.0)
| Data.Real -> F(f)
| Data.Int ->
let i = int_of_float f in
print_string ("\n*** Warning: type error, " ^ (string_of_float f)
^" is an real, but an int is expected. I convert it to '"^
(string_of_int i)^"'\n");
I(i)
| e ->
print_string ("\n*** Type Error: float found, "^
(Data.type_to_string e) ^ "expected\n");
assert false
in
let tbl = tbl@ [fst (hd vntl), v] in
parse_rif_stream label ic oc (tl vntl) (str,stream) tbl pragma
)
| (LocalGenlex.Int (i))::_ -> (
Stream.junk stream ;
let v =
match snd (hd vntl) with
| Data.Bool -> B(i<>0)
| Data.Int -> I(i)
| Data.Real ->
let f = float_of_int i in
print_string "\n*** Warning: type error, ";
print_string ((string_of_int i)
^ " is an int, but a real is expected. I convert it to '"^
(string_of_float f)^"'\n");
F(f)
| e ->
print_string ("\n*** Type Error: int found, "^ (Data.type_to_string e)
^ "expected \n");
assert false
in
let tbl = tbl @[fst (hd vntl), v] in
parse_rif_stream label ic oc (tl vntl) (str,stream) tbl pragma
)
| (LocalGenlex.Ident (b))::_ -> (
Stream.junk stream ;
let v = if mem b ["f"; "F";"false"] then B(false)
else if mem b ["t"; "T";"true"] then B(true)
else if mem b ["nil";"?";" ?"] then assert false
else failwith ("### rif parse error: `" ^ b ^
"' read, where a bool was expected ("^str^").\n")
in
let tbl = tbl @ [fst (hd vntl), v] in
parse_rif_stream label ic oc (tl vntl) (str,stream) tbl pragma
)
| [] ->
(* Eol is is reached; proceed with the next one *)
parse_rif_stream label ic oc vntl (get_stream debug label ic oc)
tbl pragma
| _ -> failwith ("### rif parse error: not in RIF format ("^str^").\n")
and (ignore_toks_until_end_of_pragmas : bool -> string ->
in_channel -> out_channel option-> vntl -> string * stream -> subst list ->
string list -> subst list) =
fun debug label ic oc vntl (str,stream) tbl pragma ->
(* ignore all tokens until "@#" is reached *)
let tok_opt = Stream.peek stream in
match tok_opt with
| Some(LocalGenlex.Kwd ("@#")) ->
(
Stream.junk stream ;
parse_rif_stream label ic oc vntl (str,stream) tbl pragma
)
| Some(_) ->
(
Stream.junk stream ;
ignore_toks_until_end_of_pragmas debug label ic oc vntl (str,stream) tbl pragma
)
| None ->
(* Eol is is reached; proceed with the next one *)
(ignore_toks_until_end_of_pragmas debug label ic oc vntl
(get_stream debug label ic oc) tbl pragma)
(*------------------------------------------------------------------------*)
(* exported *)
let (write : out_channel -> string -> unit) =
fun oc str ->
output_string oc str
let (flush : out_channel -> unit) =
fun oc ->
flush oc
(*------------------------------------------------------------------------*)
(* exported *)
let (write_interface :
out_channel -> vntl -> vntl -> vntl option -> vntl list option -> unit) =
fun oc in_vars out_vars loc_vars_opt oracle_vars_opt ->
let str =
(List.fold_left
(fun acc (vn,vt) ->
acc ^ "\"" ^ vn ^ "\":" ^ (Data.type_to_string vt) ^ " ")
"#inputs "
in_vars) ^
"\n#outputs " ^
(List.fold_left
(fun acc (vn,vt) ->
acc ^ "\"" ^ vn ^ "\":" ^ (Data.type_to_string vt) ^ " ")
""
out_vars) ^
(match loc_vars_opt with
| None -> "\n"
| Some loc_vars ->
((List.fold_left
(fun acc (vn,vt) ->
acc^"\"" ^ vn ^ "\":" ^ (Data.type_to_string vt) ^ " ")
"\n#locals "
loc_vars
) ^ "\n")
)
^
(match oracle_vars_opt with
| None -> ""
| Some vars_l ->
(List.fold_left
(fun acc vars ->
((List.fold_left
(fun acc (vn,vt) ->
acc^"\"" ^ vn ^ "\":" ^ (Data.type_to_string vt) ^ " ")
"#oracle_outputs "
vars
) ^ "\n" ^ acc)
)
""
vars_l
)
)
in
write oc str
(*------------------------------------------------------------------------*)
(* exported *)
let (write_outputs : out_channel -> (float -> string) -> vntl -> subst list -> unit) =
fun oc s2f vntl sl ->
let str =
List.fold_left
(fun acc (vn,vt) ->
acc^ (try Data.val_to_string s2f (List.assoc vn sl)
with
| Not_found ->
print_string ("*** " ^ vn ^ " not found in ");
print_string (String.concat "," (List.map (fun (n,_) -> n) sl));
flush stdout;
assert false
) ^ " "
)
""
vntl
in
output_string oc str