Commit c0b5d1aa authored by Pietro Abate's avatar Pietro Abate
Browse files

[r2003-05-25 16:53:21 by cvscast] toplevel

Original author: cvscast
Date: 2003-05-25 16:53:22+00:00
parent 8e30aa31
...@@ -5,8 +5,10 @@ let quiet = ref false ...@@ -5,8 +5,10 @@ let quiet = ref false
let typing_env = State.ref "Cduce.typing_env" Env.empty let typing_env = State.ref "Cduce.typing_env" Env.empty
let eval_env = State.ref "Cduce.eval_env" Env.empty
let enter_global_value x v t = let enter_global_value x v t =
Eval.enter_global x v; eval_env := Env.add x v !eval_env;
typing_env := Env.add x t !typing_env typing_env := Env.add x t !typing_env
let rec is_abstraction = function let rec is_abstraction = function
...@@ -38,7 +40,7 @@ let dump_env ppf = ...@@ -38,7 +40,7 @@ let dump_env ppf =
print_norm t print_norm t
print_value v print_value v
) )
!Eval.global_env !eval_env
let rec print_exn ppf = function let rec print_exn ppf = function
...@@ -130,91 +132,88 @@ let debug ppf = function ...@@ -130,91 +132,88 @@ let debug ppf = function
let insert_type_bindings ppf =
List.iter
(fun (x,t) ->
typing_env := Env.add x t !typing_env;
if not !quiet then
Format.fprintf ppf "|- %a : %a@."
U.print (Id.value x) print_norm t)
let insert_eval_bindings ppf =
let run ppf ppf_err input = List.iter
let insert_type_bindings = (fun (x,v) ->
List.iter (fun (x,t) -> eval_env := Env.add x v !eval_env;
typing_env := Env.add x t !typing_env; if not !quiet then
if not !quiet then Format.fprintf ppf "=> %a : @[%a@]@."
Format.fprintf ppf "|- %a : %a@\n@." U.print (Id.value x) print_norm t) U.print (Id.value x) print_value v
in )
let type_decl decl = let rec collect_funs ppf accu = function
insert_type_bindings (Typer.type_let_decl !typing_env decl); | { descr = Ast.FunDecl e } :: rest ->
Typer.report_unused_branches () let (_,e) = Typer.expr e in
in collect_funs ppf (e::accu) rest
| rest ->
let eval_decl decl = insert_type_bindings ppf (Typer.type_rec_funs !typing_env accu);
let bindings = Eval.eval_let_decl Env.empty decl in Typer.report_unused_branches ();
List.iter insert_eval_bindings ppf (Eval.eval_rec_funs !eval_env accu);
(fun (x,v) -> rest
Eval.enter_global x v;
if not !quiet then let rec collect_types ppf accu = function
Format.fprintf ppf "=> %a : @[%a@]@\n@." U.print (Id.value x) print_value v | { descr = Ast.TypeDecl (x,t) } :: rest ->
) bindings collect_types ppf ((x,t) :: accu) rest
in | rest ->
Typer.register_global_types accu;
let phrase ph = rest
match ph.descr with
| Ast.EvalStatement e -> let rec phrases ppf phs = match phs with
let (fv,e) = Typer.expr e in | { descr = Ast.FunDecl _ } :: _ ->
let t = Typer.type_check !typing_env e Types.any true in phrases ppf (collect_funs ppf [] phs)
Typer.report_unused_branches (); | { descr = Ast.TypeDecl (_,_) } :: _ ->
Location.dump_loc ppf e.Typed.exp_loc; phrases ppf (collect_types ppf [] phs)
if not !quiet then | { descr = Ast.EvalStatement e } :: rest ->
Format.fprintf ppf "|- %a@\n@." print_norm t; let (fv,e) = Typer.expr e in
let v = Eval.eval Env.empty e in let t = Typer.type_check !typing_env e Types.any true in
if not !quiet then Typer.report_unused_branches ();
Format.fprintf ppf "=> @[%a@]@\n@." print_value v if not !quiet then
| Ast.LetDecl (p,e) when is_abstraction e -> () Location.dump_loc ppf e.Typed.exp_loc;
| Ast.LetDecl (p,e) -> if not !quiet then
let decl = Typer.let_decl p e in Format.fprintf ppf "|- %a@." print_norm t;
type_decl decl; let v = Eval.eval !eval_env e in
Typer.report_unused_branches (); if not !quiet then
eval_decl decl Format.fprintf ppf "=> @[%a@]@." print_value v;
| Ast.TypeDecl _ -> () phrases ppf rest
| Ast.Debug l -> debug ppf l | { descr = Ast.LetDecl (p,e) } :: rest ->
| _ -> assert false let decl = Typer.let_decl p e in
in insert_type_bindings ppf (Typer.type_let_decl !typing_env decl);
Typer.report_unused_branches ();
let do_fun_decls decls = insert_eval_bindings ppf (Eval.eval_let_decl !eval_env decl);
let decls = List.map (fun (p,e) -> Typer.let_decl p e) decls in phrases ppf rest
insert_type_bindings (Typer.type_rec_funs !typing_env decls); | { descr = Ast.Debug l } :: rest ->
Typer.report_unused_branches (); debug ppf l;
List.iter eval_decl decls phrases ppf rest
in | [] -> ()
let rec phrases funs = function | _ -> assert false
| { descr = Ast.LetDecl (p,e) } :: phs when is_abstraction e ->
phrases ((p,e)::funs) phs let run rule ppf ppf_err input =
| ph :: phs ->
do_fun_decls funs;
phrase ph;
phrases [] phs
| _ ->
do_fun_decls funs
in
try try
let p = let p =
try Parser.prog input try rule input
with with
| Stdpp.Exc_located (_, (Location _ as e)) -> raise e | Stdpp.Exc_located (_, (Location _ as e)) ->
| Stdpp.Exc_located ((i,j), e) -> raise_loc i j e Parser.sync input; raise e
| Stdpp.Exc_located ((i,j), e) ->
Parser.sync input; raise_loc i j e
in in
let (type_decls,fun_decls) = phrases ppf p;
List.fold_left
(fun ((typs,funs) as accu) ph -> match ph.descr with
| Ast.TypeDecl (x,t) -> ((x,t) :: typs,funs)
| Ast.LetDecl (p,e) when is_abstraction e ->
(typs, (p,e)::funs)
| _ -> accu
) ([],[]) p in
Typer.register_global_types type_decls;
phrases [] p;
true true
with with
| (Failure _ | Not_found | Invalid_argument _) as e -> | (End_of_file | Failure _ | Not_found | Invalid_argument _) as e ->
raise e (* To get ocamlrun stack trace *) raise e (* To get ocamlrun stack trace *)
| exn -> print_exn ppf_err exn; false | exn ->
print_exn ppf_err exn;
Format.fprintf ppf_err "@.";
false
let script = run Parser.prog
let toplevel = run Parser.top_phrases
val quiet: bool ref val quiet: bool ref
val print_exn: Format.formatter -> exn -> unit
val enter_global_value : Ident.id -> Value.t -> Types.descr -> unit val enter_global_value : Ident.id -> Value.t -> Types.descr -> unit
val run : Format.formatter -> Format.formatter -> char Stream.t -> bool val script : Format.formatter -> Format.formatter -> char Stream.t -> bool
(* Returns true if everything is ok (no error) *) val toplevel : Format.formatter -> Format.formatter -> char Stream.t -> bool
val dump_env : Format.formatter -> unit val dump_env : Format.formatter -> unit
...@@ -43,10 +43,36 @@ let ppf = ...@@ -43,10 +43,36 @@ let ppf =
else Format.std_formatter else Format.std_formatter
let ppf_err = Format.err_formatter let ppf_err = Format.err_formatter
let first_line = ref true
let bol = ref true
let read i =
let first = !first_line in
if first
then output_string stdout "* "
else if !bol then output_string stdout "> ";
flush stdout;
first_line := false;
let c = input_char stdin in
flush stderr;
bol := (not first) && c = '\n';
Some c
let toploop () =
Location.push_source `Stream;
let input = Stream.from read in
let rec loop () =
first_line := true; bol := false;
ignore (Cduce.toplevel ppf ppf_err input);
loop () in
try loop ()
with End_of_file -> exit 0
let do_file s = let do_file s =
let (src, chan) = let chan = open_in s in
if s = "" then (`Stream, stdin) else (`File s, open_in s) in Location.push_source (`File s);
Location.push_source src;
let input = Stream.of_channel chan in let input = Stream.of_channel chan in
if Stream.peek input = Some '#' then if Stream.peek input = Some '#' then
( (
...@@ -55,10 +81,10 @@ let do_file s = ...@@ -55,10 +81,10 @@ let do_file s =
| '\n' -> n | '\n' -> n
| _ -> count (n + 1) in | _ -> count (n + 1) in
Wlexer.set_delta_loc (count 1) Wlexer.set_delta_loc (count 1)
); );
let ok = Cduce.run ppf ppf_err input in let ok = Cduce.script ppf ppf_err input in
if s <> "" then close_in chan; close_in chan;
if not ok then (Format.fprintf ppf_err "@."; exit 1) if not ok then exit 1
...@@ -83,9 +109,9 @@ let main () = ...@@ -83,9 +109,9 @@ let main () =
(match !src with (match !src with
| [] -> | [] ->
Format.fprintf ppf Format.fprintf ppf
"CDuce version %s\nNo script specified; using stdin ...@." " CDuce version %s\n@."
Cduce_config.version; Cduce_config.version;
do_file "" toploop ()
| l -> List.iter do_file l); | l -> List.iter do_file l);
(match !dump with (match !dump with
| Some f -> | Some f ->
......
...@@ -259,7 +259,7 @@ let main (cgi : Netcgi.std_activation) = ...@@ -259,7 +259,7 @@ let main (cgi : Netcgi.std_activation) =
Location.set_protected true; Location.set_protected true;
Location.warning_ppf := ppf; Location.warning_ppf := ppf;
let ok = Cduce.run ppf ppf input in let ok = Cduce.script ppf ppf input in
if ok then Format.fprintf ppf "@\nOk.@\n"; if ok then Format.fprintf ppf "@\nOk.@\n";
let res = Format.flush_str_formatter () in let res = Format.flush_str_formatter () in
p "<div class=\"box\"><h2>Results</h2><pre>"; p "<div class=\"box\"><h2>Results</h2><pre>";
......
...@@ -9,8 +9,8 @@ and pmodule_item = pmodule_item' located ...@@ -9,8 +9,8 @@ and pmodule_item = pmodule_item' located
and pmodule_item' = and pmodule_item' =
| TypeDecl of string * ppat | TypeDecl of string * ppat
| PatDecl of string * ppat | PatDecl of string * ppat
| FunDecl of abstr
| LetDecl of ppat * pexpr | LetDecl of ppat * pexpr
| FunDecl of pexpr
| EvalStatement of pexpr | EvalStatement of pexpr
| Debug of debug_directive | Debug of debug_directive
and debug_directive = and debug_directive =
......
...@@ -21,6 +21,7 @@ let label s = LabelPool.mk (parse_ident s) ...@@ -21,6 +21,7 @@ let label s = LabelPool.mk (parse_ident s)
let ident s = ident (parse_ident s) let ident s = ident (parse_ident s)
let prog = Grammar.Entry.create gram "prog" let prog = Grammar.Entry.create gram "prog"
let top_phrases = Grammar.Entry.create gram "toplevel phrases"
let expr = Grammar.Entry.create gram "expression" let expr = Grammar.Entry.create gram "expression"
let pat = Grammar.Entry.create gram "type/pattern expression" let pat = Grammar.Entry.create gram "type/pattern expression"
let regexp = Grammar.Entry.create gram "type/pattern regexp" let regexp = Grammar.Entry.create gram "type/pattern regexp"
...@@ -93,20 +94,26 @@ let char_list loc s = ...@@ -93,20 +94,26 @@ let char_list loc s =
let include_stack = ref [] let include_stack = ref []
EXTEND EXTEND
GLOBAL: prog expr pat regexp const; GLOBAL: top_phrases prog expr pat regexp const;
top_phrases: [
[ l = LIST0 phrase; ";;" -> List.flatten l ]
];
prog: [ prog: [
[ l = LIST0 [ p = phrase; ";;" -> p ]; EOI -> List.flatten l ] [ l = LIST0 [ p = phrase ; OPT ";;" -> p ]; EOI -> List.flatten l ]
]; ];
phrase: [ phrase: [
[ (p,e) = let_binding -> [ mk loc (LetDecl (p,e)) ] [ (f,p,e) = let_binding ->
| (p,e1) = let_binding; "in"; e2 = expr LEVEL "top"-> if f then [ mk loc (FunDecl e) ] else
[ mk loc (LetDecl (p,e)) ]
| (_,p,e1) = let_binding; "in"; e2 = expr LEVEL "top"->
[ mk loc (EvalStatement (exp loc (Match (e1,[p,e2])))) ] [ mk loc (EvalStatement (exp loc (Match (e1,[p,e2])))) ]
| LIDENT "type"; x = UIDENT; "="; t = pat -> [ mk loc (TypeDecl (x,t)) ] | "type"; x = UIDENT; "="; t = pat -> [ mk loc (TypeDecl (x,t)) ]
| LIDENT "type"; x = LIDENT -> [ error loc "Type identifiers must be capitalized" ] | "type"; x = LIDENT -> error loc "Type identifiers must be capitalized"
| LIDENT "debug"; d = debug_directive -> [ mk loc (Debug d) ] | "debug"; d = debug_directive -> [ mk loc (Debug d) ]
| LIDENT "include"; s = STRING2 -> | "include"; s = STRING2 ->
let s = get_string s in let s = get_string s in
protect_op "File inclusion"; protect_op "File inclusion";
(* avoid looping; should issue an error ? *) (* avoid looping; should issue an error ? *)
...@@ -141,7 +148,7 @@ EXTEND ...@@ -141,7 +148,7 @@ EXTEND
[ "map" | "match" | "with" | "try" | "xtransform" [ "map" | "match" | "with" | "try" | "xtransform"
| "if" | "then" | "else" | "if" | "then" | "else"
| "transform" | "fun" | "in" | "transform" | "fun" | "in"
| "let" | "let" | "type" | "debug" | "include"
] ]
-> a -> a
] ]
...@@ -165,7 +172,7 @@ EXTEND ...@@ -165,7 +172,7 @@ EXTEND
exp loc (Transform (e,b)) exp loc (Transform (e,b))
| "fun"; (f,a,b) = fun_decl -> | "fun"; (f,a,b) = fun_decl ->
exp loc (Abstraction { fun_name = f; fun_iface = a; fun_body = b }) exp loc (Abstraction { fun_name = f; fun_iface = a; fun_body = b })
| (p,e1) = let_binding; "in"; e2 = expr LEVEL "top"-> | (_,p,e1) = let_binding; "in"; e2 = expr LEVEL "top"->
exp loc (Match (e1,[p,e2])) exp loc (Match (e1,[p,e2]))
| e = expr; ":"; p = pat -> | e = expr; ":"; p = pat ->
exp loc (Forget (e,p)) exp loc (Forget (e,p))
...@@ -259,8 +266,8 @@ EXTEND ...@@ -259,8 +266,8 @@ EXTEND
]; ];
let_binding: [ let_binding: [
[ "let"; p = pat; "="; e = expr -> (p,e) [ "let"; p = pat; "="; e = expr -> (false,p,e)
| "let"; p = pat; ":"; t = pat; "="; e = expr -> (p, Forget (e,t)) | "let"; p = pat; ":"; t = pat; "="; e = expr -> (false,p, Forget (e,t))
| "let"; "fun"; (f,a,b) = fun_decl -> | "let"; "fun"; (f,a,b) = fun_decl ->
let p = match f with let p = match f with
| Some x -> mk loc (Capture x) | Some x -> mk loc (Capture x)
...@@ -268,7 +275,7 @@ EXTEND ...@@ -268,7 +275,7 @@ EXTEND
in in
let abst = { fun_name = f; fun_iface = a; fun_body = b } in let abst = { fun_name = f; fun_iface = a; fun_body = b } in
let e = exp loc (Abstraction abst) in let e = exp loc (Abstraction abst) in
(p,e); (true,p,e)
] ]
]; ];
...@@ -462,10 +469,12 @@ END ...@@ -462,10 +469,12 @@ END
let pat = Grammar.Entry.parse pat let pat = Grammar.Entry.parse pat
and expr = Grammar.Entry.parse expr and expr = Grammar.Entry.parse expr
and prog = Grammar.Entry.parse prog and prog = Grammar.Entry.parse prog
and top_phrases = Grammar.Entry.parse top_phrases
module From_string = struct let rec sync s =
let pat s = Grammar.Entry.parse pat' (Stream.of_string s) match Stream.next s with
let expr s = expr (Stream.of_string s) | ';' ->
end (match Stream.next s with
| ';' -> ()
| _ -> sync s)
| _ -> sync s
...@@ -3,8 +3,6 @@ exception Error of string ...@@ -3,8 +3,6 @@ exception Error of string
val expr : char Stream.t -> Ast.pexpr val expr : char Stream.t -> Ast.pexpr
val pat : char Stream.t -> Ast.ppat val pat : char Stream.t -> Ast.ppat
val prog : char Stream.t -> Ast.pmodule_item list val prog : char Stream.t -> Ast.pmodule_item list
val top_phrases : char Stream.t -> Ast.pmodule_item list
module From_string : sig val sync : char Stream.t -> unit
val pat : string -> Ast.ppat
val expr : string -> Ast.pexpr
end
...@@ -5,72 +5,74 @@ let blank = 3 ...@@ -5,72 +5,74 @@ let blank = 3
let lowercase = 4 let lowercase = 4
let uppercase = 5 let uppercase = 5
let ascii_digit = 6 let ascii_digit = 6
let char_5f = 7 let char_23 = 7
let char_3c = 8 let char_5f = 8
let char_3e = 9 let char_3c = 9
let char_3d = 10 let char_3e = 10
let char_2e = 11 let char_3d = 11
let char_2c = 12 let char_2e = 12
let char_3a = 13 let char_2c = 13
let char_3b = 14 let char_3a = 14
let char_2b = 15 let char_3b = 15
let char_2d = 16 let char_2b = 16
let char_2a = 17 let char_2d = 17
let char_2f = 18 let char_2a = 18
let char_40 = 19 let char_2f = 19
let char_26 = 20 let char_40 = 20
let char_7b = 21 let char_26 = 21
let char_7d = 22 let char_7b = 22
let char_5b = 23 let char_7d = 23
let char_5d = 24 let char_5b = 24
let char_28 = 25 let char_5d = 25
let char_29 = 26 let char_28 = 26
let char_7c = 27 let char_29 = 27
let char_3f = 28 let char_7c = 28
let char_60 = 29 let char_3f = 29
let char_22 = 30 let char_60 = 30
let char_5c = 31 let char_22 = 31
let char_27 = 32 let char_5c = 32
let char_21 = 33 let char_27 = 33
let unicode_base_char = 34 let char_21 = 34
let unicode_ideographic = 35 let unicode_base_char = 35
let unicode_combining_char = 36 let unicode_ideographic = 36
let unicode_digit = 37 let unicode_combining_char = 37
let unicode_extender = 38 let unicode_digit = 38
let unicode_extender = 39
let one_char_classes = [ let one_char_classes = [
(0x5f, 07); (0x23, 07);
(0x3c, 08); (0x5f, 08);
(0x3e, 09); (0x3c, 09);
(0x3d, 10); (0x3e, 10);
(0x2e, 11); (0x3d, 11);
(0x2c, 12); (0x2e, 12);
(0x3a, 13); (0x2c, 13);
(0x3b, 14); (0x3a, 14);
(0x2b, 15); (0x3b, 15);
(0x2d, 16); (0x2b, 16);
(0x2a, 17); (0x2d, 17);
(0x2f, 18); (0x2a, 18);
(0x40, 19); (0x2f, 19);
(0x26, 20); (0x40, 20);
(0x7b, 21); (0x26, 21);
(0x7d, 22); (0x7b, 22);
(0x5b, 23); (0x7d, 23);
(0x5d, 24); (0x5b, 24);
(0x28, 25); (0x5d, 25);
(0x29, 26); (0x28, 26);
(0x7c, 27); (0x29, 27);
(0x3f, 28); (0x7c, 28);
(0x60, 29); (0x3f, 29);
(0x22, 30); (0x60, 30);
(0x5c, 31); (0x22, 31);
(0x27, 32); (0x5c, 32);
(0x21, 33); (0x27, 33);
(0x21, 34);
] ]