Mentions légales du service

Skip to content
Snippets Groups Projects
Commit db752686 authored by POGODALLA Sylvain's avatar POGODALLA Sylvain
Browse files

It now compiles. Testing starts...

parent b992620a
No related branches found
No related tags found
No related merge requests found
Hide whitespace changes
Inline Side-by-side
src/scripting/acg.ml
+ 6
− 6
View file @ db752686
......@@ -31,9 +31,9 @@ let svg_output = ref (Some "realize.svg")
let dont_exit_on_end_of_file = ref false
module P = Script_parser.Parser
module P = Parse_functions
module F = P.F
module F = Functions
let options =
[
......@@ -101,7 +101,7 @@ let print_welcome_message () =
let anon_fun s =
let () = print_welcome_message () in
let () = resize_terminal () in
env := P.parse_file ?svg_output:!svg_output s !dirs !env
env := snd (P.parse_file ?svg_output:!svg_output s !dirs !env)
let invite () =
......@@ -120,7 +120,7 @@ let main first =
let () = resize_terminal () in
while !continue do
try
let () = env := P.parse_entry ~resize:!pp_output ?svg_output:!svg_output stdin_tmp_in_ch !dirs !env in
let () = env := snd (P.parse_entry ~resize:!pp_output ?svg_output:!svg_output stdin_tmp_in_ch !dirs !env) in
Format.print_flush ()
with
| End_of_file ->
......@@ -148,8 +148,8 @@ let _ =
*)
let () =
try main true with
| P.F.Stop -> ()
| P.F.Quit -> ()
| F.Stop -> ()
| F.Quit -> ()
| Sys.Break -> () in
Logs.app (fun m -> m "Goodbye.")
src/scripting/command_parser.mly
+ 23
− 25
View file @ db752686
%{
open Logic
open AcgData.Environment
let id = fun x -> x
let pr s = Logs.app (fun m -> m "%s" s)
module F=Functions.Functions
let echo ctx:F.context s = if ctx.echo then Logs.app (fun m -> m "%s" s) else ()
let wait ctx:F.context = if F.should_wait ctx then ignore (f () )
let svg ctx:F.context = F.svg ctx
let echo ctx s = if F.echo ctx then Logs.app (fun m -> m "%s" s) else ()
let wait ctx f = if F.should_wait ctx then ignore (f () )
let svg ctx = F.svg ctx
%}
......@@ -33,7 +30,7 @@
%token <(string*Logic.Abstract_syntax.Abstract_syntax.location*string)>SAVE
%start <Functions.Functions.context -> AcgData.Environment.Environment.t -> AcgData.Environment.Environment.t> commands
%start <Functions.Functions.context -> AcgData.Environment.Environment.t -> Functions.Functions.context * AcgData.Environment.Environment.t> commands
%%
......@@ -42,7 +39,7 @@
{
fun ctx e ->
List.fold_left
(fun acc command -> command acc)
(fun (c,e') command -> command c e')
(ctx,e)
commands
}
......@@ -51,8 +48,8 @@
| EXIT l = SEMICOLONN {
fun ctx e ->
let () = echo ctx l in
let () = F.exit in
e}
let () = F.exit () in
ctx,e}
| WAIT l = SEMICOLONN {
fun ctx e ->
......@@ -75,27 +72,28 @@
| DONT WAIT HELP l = SEMICOLONN {
fun ctx e ->
let () = echo ctx l in
let () = F.help (F.Help (Some F.Dont_Wait)) in
let () = F.help (F.Help (Some F.Dont_wait)) in
ctx,e}
| params = LOAD_DATA {
fun ctx e ->
let s,loc,l = params in
let () = echo ctx l in
let e' = F.load F.Data s (F.dirs ctx) e in
ctx,e'}
F.load F.Data s (F.dirs ctx) (ctx,e)
}
| params = LOAD_OBJECT {
fun ctx e ->
let s,loc,l = params in
let () = echo ctx l in
ctx,F.load F.Object s (F.dirs ctx) e}
F.load F.Object s (F.dirs ctx) (ctx,e)}
| params = LOAD_SCRIPT {
fun ctx e ->
let s,loc,l = params in
let () = echo ctx l in
ctx,F.load (F.Script (F.parse_script ctx)) s (F.dirs ctx) e }
let () = echo ctx l in
let parse_script_fn filename dirs (_,env) = (F.parse_script ctx) filename dirs env in
F.load (F.Script parse_script_fn) s (F.dirs ctx) (ctx,e) }
| LIST l = SEMICOLONN {fun ctx e ->
let () = echo ctx l in
......@@ -124,7 +122,7 @@
| UNSELECT l = SEMICOLONN {
fun ctx e ->
let () = echo ctx l in
ctx,F.unselect}
ctx,F.unselect e}
| UNSELECT HELP l = SEMICOLONN {
fun ctx e ->
......@@ -162,7 +160,7 @@
let () =
match name with
| None -> F.print e p
| Some (n,l) -> F.print ~name:n e loc in
| Some (n,l) -> F.print ~name:n e l in
ctx,e}
| IDENTT? PRINT HELP l = SEMICOLONN {
......@@ -259,10 +257,10 @@
| Some (n,l) -> F.idb ~name:n e l in
ctx,e}
| name = IDENTT? p = IDB HELP l = SEMICOLONN {
| IDENTT? IDB HELP l = SEMICOLONN {
fun ctx e ->
let () = echo ctx l in
let () = F.help (F.Help (Some F.IDB)) in
let () = F.help (F.Help (Some F.Idb)) in
ctx,e}
| params = ADD {
......@@ -295,7 +293,7 @@
| HELP HELP l = SEMICOLONN {
fun ctx e ->
let () = echo ctx l in
let () = F.help (F.Help (Some F.Help)) in
let () = F.help (F.Help (Some (F.Help None))) in
ctx,e}
| LOAD_HELP l = SEMICOLONN {
......@@ -367,13 +365,13 @@
fun ctx e ->
let filename,l,line = params in
let () = echo ctx line in
let e' = F.save filename e l in
ctx,e'}
let () = F.save filename e l in
ctx,e}
| names = IDENTT+ params = SAVE {
fun ctx e ->
let filename,l,line = params in
let () = echo ctx line in
let e' = F.save ~names filename e l in
ctx,e'}
let () = F.save ~names filename e l in
ctx,e}
src/scripting/functions.ml
+ 25
− 14
View file @ db752686
......@@ -74,13 +74,13 @@ sig
type file_type =
| Data
| Object
| Script of (string -> string list -> env -> env)
| Script of (string -> string list -> context * env -> context * env)
val color_output : bool -> unit
val set_config : string -> string list -> unit
val load : file_type -> string -> string list -> env -> env
val load : file_type -> string -> string list -> context * env -> context * env
val list : env -> unit
......@@ -111,6 +111,8 @@ sig
string * (Lexing.position * Lexing.position) ->
string * (Lexing.position * Lexing.position) -> env -> env
val context : wait:bool -> echo:bool -> svg:string option -> dirs:string list -> parse_fun:(?verbose:bool -> ?svg_output:string -> string -> string list -> Environment.t -> context * Environment.t) -> context
val wait : context -> context
val dont_wait : context -> context
......@@ -123,7 +125,7 @@ sig
val dirs : context -> string list
val parse_script : context -> (?verbose:bool -> ?svg_output:string option -> string -> string list -> Environment.t -> Environment.t)
val parse_script : context -> (?verbose:bool -> ?svg_output:string -> string -> string list -> Environment.t -> context * Environment.t)
val help : action -> unit
......@@ -153,7 +155,7 @@ struct
echo:bool; (* whether the command should be echoed on the output *)
dirs:string list; (* list of the included dirs *)
svg:string option; (* whether a svg output "file" (if relevant) should be produced *)
parse_function: parse_script : context -> (?verbose:bool -> ?svg_output:string option -> string -> string list -> Environment.t -> Environment.t);
parse_function: ?verbose:bool -> ?svg_output:string -> string -> string list -> Environment.t -> context * Environment.t;
}
......@@ -175,7 +177,7 @@ struct
type file_type =
| Data
| Object
| Script of (string -> string list -> env -> env)
| Script of (string -> string list -> context * env -> context * env)
module Data_parser = Grammars.Parsers
module ShowI = Show.Make(Env)
......@@ -309,19 +311,19 @@ struct
let load t filename dirs e =
let load t filename dirs (ctx,e) =
match t with
| Data ->
(match Data_parser.parse_data ~overwrite:true filename dirs e with
| None -> e
| Some e' -> e')
| None -> ctx,e
| Some e' -> ctx,e')
| Object ->
(let new_env = Env.read filename dirs in
match new_env with
| Some n_e -> Env.append e n_e
| None -> e)
| Script f -> f filename dirs e
| exception Stop -> e
| Some n_e -> ctx,Env.append e n_e
| None -> ctx,e)
| Script f -> f filename dirs (ctx,e)
| exception Stop -> ctx,e
let list e =
......@@ -772,8 +774,17 @@ struct
| Env.Lexicon lex -> Printf.fprintf outch "%s\n\n%!" (Env.Lexicon.to_string lex))
entries in
close_out outch
let context ~wait ~echo ~svg ~dirs ~parse_fun =
{
wait;
echo;
dirs;
svg;
parse_function=parse_fun;
}
let wait ctx = {ctx with wait=true}
let dont_wait ctx = {ctx with wait=false}
......
src/scripting/functions.mli
+ 5
− 3
View file @ db752686
......@@ -58,13 +58,13 @@ sig
type file_type =
| Data
| Object
| Script of (string -> string list -> env -> env)
| Script of (string -> string list -> context * env -> context * env)
val color_output : bool -> unit
val set_config : string -> string list -> unit
val load : file_type -> string -> string list -> env -> env
val load : file_type -> string -> string list -> context * env -> context * env
val list : env -> unit
......@@ -98,6 +98,8 @@ sig
string * (Lexing.position * Lexing.position) ->
string * (Lexing.position * Lexing.position) -> env -> env
val context : wait:bool -> echo:bool -> svg:string option -> dirs:string list -> parse_fun:(?verbose:bool -> ?svg_output:string -> string -> string list -> Environment.t -> context * Environment.t) -> context
val wait : context -> context
val dont_wait : context -> context
......@@ -110,7 +112,7 @@ sig
val dirs : context -> string list
val parse_script : context -> (?verbose:bool -> ?svg_output:string option -> string -> string list -> Environment.t -> Environment.t)
val parse_script : context -> (?verbose:bool -> ?svg_output:string -> string -> string list -> Environment.t -> context * Environment.t)
val help : action -> unit
......
src/scripting/parse_functions.ml 0 → 100644
+ 129
− 0
View file @ db752686
open AcgData.Environment
open Functions
module I = Command_parser.MenhirInterpreter
module Error = AcgData.Error
(* -------------------------------------------------------------------------- *)
(* The above loop is shown for explanatory purposes, but can in fact be
replaced with the following code, which exploits the functions
[lexer_lexbuf_to_supplier] and [loop_handle] offered by Menhir. *)
let succeed (data : (Functions.context -> Environment.t -> Functions.context * Environment.t)) =
(* The parser has succeeded and produced a semantic value. *)
data
let fail lexbuf (c : (Functions.context -> Environment.t -> Functions.context * Environment.t) I.checkpoint) =
(* The parser has suspended itself because of a syntax error. Stop. *)
match c with
| I.HandlingError env ->
let loc = Lexing.lexeme_start_p lexbuf,Lexing.lexeme_end_p lexbuf in
let current_state_num = I.current_state_number env in
raise Error.(Error (Parse_error (Syntax_error ((Messages.message current_state_num)),loc)))
| _ -> failwith "Should not happen. Always fails with a HandlingError"
| exception Not_found ->
let loc = Lexing.lexeme_start_p lexbuf,Lexing.lexeme_end_p lexbuf in
raise Error.(Error (Parse_error (Syntax_error (""),loc)))
let core_supplier lexbuf = I.lexer_lexbuf_to_supplier Script_lexer.lexer lexbuf
(*
let supplier lexbuf =
let sup () =
let (tok,_,_) as res = core_supplier lexbuf () in
let () = Printf.printf "Token: \"%s\"\n%!" (tok_to_string tok) in
res in
sup
*)
let supplier = core_supplier
let rec parse_file ?(verbose=true) ?svg_output filename includes env =
let ctx = Functions.context ~wait:false ~echo:verbose ~dirs:includes ~svg:svg_output ~parse_fun:parse_file in
try
let in_ch =
let fullname = UtilsLib.Utils.find_file filename includes in
open_in fullname in
let lexbuf = Lexing.from_channel in_ch in
let () = Printf.printf "Parsing script file \"%s\"...\n%!" filename in
let ctx',new_env= (I.loop_handle succeed (fail lexbuf) (supplier lexbuf) (Command_parser.Incremental.commands lexbuf.lex_curr_p)) ctx env in
let () = Printf.printf "Done.\n%!" in
ctx',new_env
with
| UtilsLib.Utils.No_file(f,msg) ->
let e = AcgData.Error.System_error (Printf.sprintf "No such file \"%s\" in %s" f msg) in
let () = Printf.fprintf stderr "Error: %s\n%!" (AcgData.Error.error_msg e filename) in
let _ = Script_lexer.reset_echo () in
ctx,env
| Sys_error s ->
let e = AcgData.Error.System_error s in
let () = Printf.fprintf stderr "Error: %s\n%!" (AcgData.Error.error_msg e filename) in
let _ = Script_lexer.reset_echo () in
ctx,env
| AcgData.Error.Error e ->
let () = Printf.fprintf stderr "Error: %s\n%!" (AcgData.Error.error_msg e filename) in
let _ = Script_lexer.reset_echo () in
ctx,env
| Scripting_errors.Error (e,p) ->
let () = Printf.fprintf stderr "Error: %s\n%!" (Scripting_errors.error_msg e p) in
let _ = Script_lexer.reset_echo () in
ctx,env
let commented_regexp = Str.regexp "^[ \t#]*#"
let is_fully_commented_line s = Str.string_match commented_regexp s 0
let read_line_from_in_ch in_ch =
let () = flush stdout in
input_line in_ch
let bufferize in_ch =
let () = Printf.printf "# " in
let buf = Buffer.create 16 in
let no_semi_colon=ref true in
let () =
while !no_semi_colon do
let input = read_line_from_in_ch in_ch in
if not (is_fully_commented_line input) then
try
let semi_colon_index=String.index input ';' in
let () = Buffer.add_string buf (String.sub input 0 (semi_colon_index+1)) in
no_semi_colon:=false
with
| Not_found ->
Buffer.add_string buf input ;
Buffer.add_char buf '\n';
Printf.printf " "
else
()
done in
Buffer.contents buf
let parse_entry ~resize ?svg_output ?(verbose=true) in_ch includes env =
let in_str = bufferize in_ch in
let lexbuf = Lexing.from_string in_str in
let () =
if resize then
let () = UtilsLib.Utils.sterm_set_size () in
UtilsLib.Utils.term_set_size ()
else
() in
let ctx = Functions.context ~wait:false ~echo:verbose ~svg:svg_output ~dirs:includes ~parse_fun:parse_file in
try
(I.loop_handle succeed (fail lexbuf) (supplier lexbuf) (Command_parser.Incremental.commands lexbuf.lex_curr_p)) ctx env
with
| Functions.Stop -> ctx,env
| Failure f when f="lexing: empty token" -> ctx,env
| AcgData.Error.Error e ->
let () = Printf.fprintf stderr "Error: %s\n%!" (AcgData.Error.error_msg e "stdin") in
let _ = Script_lexer.reset_echo () in
ctx,env
| Scripting_errors.Error (e,p) ->
let () = Printf.fprintf stderr "Error: %s\n%!" (Scripting_errors.error_msg e p) in
let _ = Script_lexer.reset_echo () in
ctx,env
src/scripting/parse_functions.mli 0 → 100644
+ 6
− 0
View file @ db752686
open AcgData.Environment
open Functions
val parse_file : ?verbose:bool -> ?svg_output:string -> string -> string list -> Environment.t -> Functions.context * Environment.t
val parse_entry : resize:bool -> ?svg_output:string -> ?verbose:bool -> in_channel -> string list -> Environment.t -> Functions.context * Environment.t
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Please register or to comment