Skip to content

GitLab

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
Hide whitespace changes
Inline Side-by-side
driver/cduce.ml
View file @ c0b5d1aa
......@@ -5,8 +5,10 @@ let quiet = ref false
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 =
Eval.enter_global x v;
eval_env := Env.add x v !eval_env;
typing_env := Env.add x t !typing_env
let rec is_abstraction = function
......@@ -38,7 +40,7 @@ let dump_env ppf =
print_norm t
print_value v
)
!Eval.global_env
!eval_env
let rec print_exn 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 run ppf ppf_err input =
let insert_type_bindings =
List.iter (fun (x,t) ->
typing_env := Env.add x t !typing_env;
if not !quiet then
Format.fprintf ppf "|- %a : %a@\n@." U.print (Id.value x) print_norm t)
in
let insert_eval_bindings ppf =
List.iter
(fun (x,v) ->
eval_env := Env.add x v !eval_env;
if not !quiet then
Format.fprintf ppf "=> %a : @[%a@]@."
U.print (Id.value x) print_value v
)
let type_decl decl =
insert_type_bindings (Typer.type_let_decl !typing_env decl);
Typer.report_unused_branches ()
in
let eval_decl decl =
let bindings = Eval.eval_let_decl Env.empty decl in
List.iter
(fun (x,v) ->
Eval.enter_global x v;
if not !quiet then
Format.fprintf ppf "=> %a : @[%a@]@\n@." U.print (Id.value x) print_value v
) bindings
in
let phrase ph =
match ph.descr with
| Ast.EvalStatement e ->
let (fv,e) = Typer.expr e in
let t = Typer.type_check !typing_env e Types.any true in
Typer.report_unused_branches ();
Location.dump_loc ppf e.Typed.exp_loc;
if not !quiet then
Format.fprintf ppf "|- %a@\n@." print_norm t;
let v = Eval.eval Env.empty e in
if not !quiet then
Format.fprintf ppf "=> @[%a@]@\n@." print_value v
| Ast.LetDecl (p,e) when is_abstraction e -> ()
| Ast.LetDecl (p,e) ->
let decl = Typer.let_decl p e in
type_decl decl;
Typer.report_unused_branches ();
eval_decl decl
| Ast.TypeDecl _ -> ()
| Ast.Debug l -> debug ppf l
| _ -> assert false
in
let do_fun_decls decls =
let decls = List.map (fun (p,e) -> Typer.let_decl p e) decls in
insert_type_bindings (Typer.type_rec_funs !typing_env decls);
Typer.report_unused_branches ();
List.iter eval_decl decls
in
let rec phrases funs = function
| { descr = Ast.LetDecl (p,e) } :: phs when is_abstraction e ->
phrases ((p,e)::funs) phs
| ph :: phs ->
do_fun_decls funs;
phrase ph;
phrases [] phs
| _ ->
do_fun_decls funs
in
let rec collect_funs ppf accu = function
| { descr = Ast.FunDecl e } :: rest ->
let (_,e) = Typer.expr e in
collect_funs ppf (e::accu) rest
| rest ->
insert_type_bindings ppf (Typer.type_rec_funs !typing_env accu);
Typer.report_unused_branches ();
insert_eval_bindings ppf (Eval.eval_rec_funs !eval_env accu);
rest
let rec collect_types ppf accu = function
| { descr = Ast.TypeDecl (x,t) } :: rest ->
collect_types ppf ((x,t) :: accu) rest
| rest ->
Typer.register_global_types accu;
rest
let rec phrases ppf phs = match phs with
| { descr = Ast.FunDecl _ } :: _ ->
phrases ppf (collect_funs ppf [] phs)
| { descr = Ast.TypeDecl (_,_) } :: _ ->
phrases ppf (collect_types ppf [] phs)
| { descr = Ast.EvalStatement e } :: rest ->
let (fv,e) = Typer.expr e in
let t = Typer.type_check !typing_env e Types.any true in
Typer.report_unused_branches ();
if not !quiet then
Location.dump_loc ppf e.Typed.exp_loc;
if not !quiet then
Format.fprintf ppf "|- %a@." print_norm t;
let v = Eval.eval !eval_env e in
if not !quiet then
Format.fprintf ppf "=> @[%a@]@." print_value v;
phrases ppf rest
| { descr = Ast.LetDecl (p,e) } :: rest ->
let decl = Typer.let_decl p e in
insert_type_bindings ppf (Typer.type_let_decl !typing_env decl);
Typer.report_unused_branches ();
insert_eval_bindings ppf (Eval.eval_let_decl !eval_env decl);
phrases ppf rest
| { descr = Ast.Debug l } :: rest ->
debug ppf l;
phrases ppf rest
| [] -> ()
| _ -> assert false
let run rule ppf ppf_err input =
try
let p =
try Parser.prog input
try rule input
with
| Stdpp.Exc_located (_, (Location _ as e)) -> raise e
| Stdpp.Exc_located ((i,j), e) -> raise_loc i j e
| Stdpp.Exc_located (_, (Location _ as e)) ->
Parser.sync input; raise e
| Stdpp.Exc_located ((i,j), e) ->
Parser.sync input; raise_loc i j e
in
let (type_decls,fun_decls) =
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;
phrases ppf p;
true
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 *)
| 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
driver/cduce.mli
View file @ c0b5d1aa
val quiet: bool ref
val print_exn: Format.formatter -> exn -> unit
val enter_global_value : Ident.id -> Value.t -> Types.descr -> unit
val run : Format.formatter -> Format.formatter -> char Stream.t -> bool
(* Returns true if everything is ok (no error) *)
val script : Format.formatter -> Format.formatter -> char Stream.t -> bool
val toplevel : Format.formatter -> Format.formatter -> char Stream.t -> bool
val dump_env : Format.formatter -> unit
driver/run.ml
View file @ c0b5d1aa
......@@ -43,10 +43,36 @@ let ppf =
else Format.std_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 (src, chan) =
if s = "" then (`Stream, stdin) else (`File s, open_in s) in
Location.push_source src;
let chan = open_in s in
Location.push_source (`File s);
let input = Stream.of_channel chan in
if Stream.peek input = Some '#' then
(
......@@ -55,10 +81,10 @@ let do_file s =
| '\n' -> n
| _ -> count (n + 1) in
Wlexer.set_delta_loc (count 1)
);
let ok = Cduce.run ppf ppf_err input in
if s <> "" then close_in chan;
if not ok then (Format.fprintf ppf_err "@."; exit 1)
);
let ok = Cduce.script ppf ppf_err input in
close_in chan;
if not ok then exit 1
......@@ -83,9 +109,9 @@ let main () =
(match !src with
| [] ->
Format.fprintf ppf
"CDuce version %s\nNo script specified; using stdin ...@."
" CDuce version %s\n@."
Cduce_config.version;
do_file ""
toploop ()
| l -> List.iter do_file l);
(match !dump with
| Some f ->
......
driver/webiface.ml
View file @ c0b5d1aa
......@@ -259,7 +259,7 @@ let main (cgi : Netcgi.std_activation) =
Location.set_protected true;
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";
let res = Format.flush_str_formatter () in
p "<div class=\"box\"><h2>Results</h2><pre>";
......
parser/ast.ml
View file @ c0b5d1aa
......@@ -9,8 +9,8 @@ and pmodule_item = pmodule_item' located
and pmodule_item' =
| TypeDecl of string * ppat
| PatDecl of string * ppat
| FunDecl of abstr
| LetDecl of ppat * pexpr
| FunDecl of pexpr
| EvalStatement of pexpr
| Debug of debug_directive
and debug_directive =
......
parser/parser.ml
View file @ c0b5d1aa
......@@ -21,6 +21,7 @@ let label s = LabelPool.mk (parse_ident s)
let ident s = ident (parse_ident s)
let prog = Grammar.Entry.create gram "prog"
let top_phrases = Grammar.Entry.create gram "toplevel phrases"
let expr = Grammar.Entry.create gram "expression"
let pat = Grammar.Entry.create gram "type/pattern expression"
let regexp = Grammar.Entry.create gram "type/pattern regexp"
......@@ -93,20 +94,26 @@ let char_list loc s =
let include_stack = ref []
EXTEND
GLOBAL: prog expr pat regexp const;
GLOBAL: top_phrases prog expr pat regexp const;
top_phrases: [
[ l = LIST0 phrase; ";;" -> List.flatten l ]
];
prog: [
[ l = LIST0 [ p = phrase; ";;" -> p ]; EOI -> List.flatten l ]
[ l = LIST0 [ p = phrase ; OPT ";;" -> p ]; EOI -> List.flatten l ]
];
phrase: [
[ (p,e) = let_binding -> [ mk loc (LetDecl (p,e)) ]
| (p,e1) = let_binding; "in"; e2 = expr LEVEL "top"->
[ (f,p,e) = let_binding ->
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])))) ]
| LIDENT "type"; x = UIDENT; "="; t = pat -> [ mk loc (TypeDecl (x,t)) ]
| LIDENT "type"; x = LIDENT -> [ error loc "Type identifiers must be capitalized" ]
| LIDENT "debug"; d = debug_directive -> [ mk loc (Debug d) ]
| LIDENT "include"; s = STRING2 ->
| "type"; x = UIDENT; "="; t = pat -> [ mk loc (TypeDecl (x,t)) ]
| "type"; x = LIDENT -> error loc "Type identifiers must be capitalized"
| "debug"; d = debug_directive -> [ mk loc (Debug d) ]
| "include"; s = STRING2 ->
let s = get_string s in
protect_op "File inclusion";
(* avoid looping; should issue an error ? *)
......@@ -141,7 +148,7 @@ EXTEND
[ "map" | "match" | "with" | "try" | "xtransform"
| "if" | "then" | "else"
| "transform" | "fun" | "in"
| "let"
| "let" | "type" | "debug" | "include"
]
-> a
]
......@@ -165,7 +172,7 @@ EXTEND
exp loc (Transform (e,b))
| "fun"; (f,a,b) = fun_decl ->
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]))
| e = expr; ":"; p = pat ->
exp loc (Forget (e,p))
......@@ -259,8 +266,8 @@ EXTEND
];
let_binding: [
[ "let"; p = pat; "="; e = expr -> (p,e)
| "let"; p = pat; ":"; t = pat; "="; e = expr -> (p, Forget (e,t))
[ "let"; p = pat; "="; e = expr -> (false,p,e)
| "let"; p = pat; ":"; t = pat; "="; e = expr -> (false,p, Forget (e,t))
| "let"; "fun"; (f,a,b) = fun_decl ->
let p = match f with
| Some x -> mk loc (Capture x)
......@@ -268,7 +275,7 @@ EXTEND
in
let abst = { fun_name = f; fun_iface = a; fun_body = b } in
let e = exp loc (Abstraction abst) in
(p,e);
(true,p,e)
]
];
......@@ -462,10 +469,12 @@ END
let pat = Grammar.Entry.parse pat
and expr = Grammar.Entry.parse expr
and prog = Grammar.Entry.parse prog
module From_string = struct
let pat s = Grammar.Entry.parse pat' (Stream.of_string s)
let expr s = expr (Stream.of_string s)
end
and top_phrases = Grammar.Entry.parse top_phrases
let rec sync s =
match Stream.next s with
| ';' ->
(match Stream.next s with
| ';' -> ()
| _ -> sync s)
| _ -> sync s
parser/parser.mli
View file @ c0b5d1aa
......@@ -3,8 +3,6 @@ exception Error of string
val expr : char Stream.t -> Ast.pexpr
val pat : char Stream.t -> Ast.ppat
val prog : char Stream.t -> Ast.pmodule_item list
val top_phrases : char Stream.t -> Ast.pmodule_item list
module From_string : sig
val pat : string -> Ast.ppat
val expr : string -> Ast.pexpr
end
val sync : char Stream.t -> unit
parser/wlexer.ml
View file @ c0b5d1aa
......@@ -5,72 +5,74 @@ let blank = 3
let lowercase = 4
let uppercase = 5
let ascii_digit = 6
let char_5f = 7
let char_3c = 8
let char_3e = 9
let char_3d = 10
let char_2e = 11
let char_2c = 12
let char_3a = 13
let char_3b = 14
let char_2b = 15
let char_2d = 16
let char_2a = 17
let char_2f = 18
let char_40 = 19
let char_26 = 20
let char_7b = 21
let char_7d = 22
let char_5b = 23
let char_5d = 24
let char_28 = 25
let char_29 = 26
let char_7c = 27
let char_3f = 28
let char_60 = 29
let char_22 = 30
let char_5c = 31
let char_27 = 32
let char_21 = 33
let unicode_base_char = 34
let unicode_ideographic = 35
let unicode_combining_char = 36
let unicode_digit = 37
let unicode_extender = 38
let char_23 = 7
let char_5f = 8
let char_3c = 9
let char_3e = 10
let char_3d = 11
let char_2e = 12
let char_2c = 13
let char_3a = 14
let char_3b = 15
let char_2b = 16
let char_2d = 17
let char_2a = 18
let char_2f = 19
let char_40 = 20
let char_26 = 21
let char_7b = 22
let char_7d = 23
let char_5b = 24
let char_5d = 25
let char_28 = 26
let char_29 = 27
let char_7c = 28
let char_3f = 29
let char_60 = 30
let char_22 = 31
let char_5c = 32
let char_27 = 33
let char_21 = 34
let unicode_base_char = 35
let unicode_ideographic = 36
let unicode_combining_char = 37
let unicode_digit = 38
let unicode_extender = 39
let one_char_classes = [
(0x5f, 07);
(0x3c, 08);
(0x3e, 09);
(0x3d, 10);
(0x2e, 11);
(0x2c, 12);
(0x3a, 13);
(0x3b, 14);
(0x2b, 15);
(0x2d, 16);
(0x2a, 17);
(0x2f, 18);
(0x40, 19);
(0x26, 20);
(0x7b, 21);
(0x7d, 22);
(0x5b, 23);
(0x5d, 24);
(0x28, 25);
(0x29, 26);
(0x7c, 27);
(0x3f, 28);
(0x60, 29);
(0x22, 30);
(0x5c, 31);
(0x27, 32);
(0x21, 33);
(0x23, 07);
(0x5f, 08);
(0x3c, 09);
(0x3e, 10);
(0x3d, 11);
(0x2e, 12);
(0x2c, 13);
(0x3a, 14);
(0x3b, 15);
(0x2b, 16);
(0x2d, 17);
(0x2a, 18);
(0x2f, 19);
(0x40, 20);
(0x26, 21);
(0x7b, 22);
(0x7d, 23);
(0x5b, 24);
(0x5d, 25);
(0x28, 26);
(0x29, 27);
(0x7c, 28);
(0x3f, 29);
(0x60, 30);
(0x22, 31);
(0x5c, 32);
(0x27, 33);
(0x21, 34);
]
let nb_classes = 39
let nb_classes = 40
# 18 "parser/wlexer.mll"
# 17 "parser/wlexer.mll"
let keywords = Hashtbl.create 17
......@@ -132,12 +134,12 @@ let nb_classes = 39
let lex_tables = {
Lexing.lex_base =
"\000\000\022\000\010\000\014\000\254\255\039\000\042\000\255\255\
\250\255\249\255\255\255\027\000\253\255\005\000\252\255\252\255\
\251\255\000\000\006\000\253\255\249\255\248\255\009\000\056\000\
\018\000\041\000\055\000\252\255\058\000\015\000\051\000\064\000\
\016\000\023\000\038\000\052\000\251\255\250\255\069\000\091\000\
\077\000\126\000\073\000";
"\000\000\023\000\011\000\015\000\254\255\042\000\046\000\255\255\
\250\255\249\255\255\255\041\000\253\255\019\000\252\255\252\255\
\251\255\000\000\002\000\253\255\249\255\248\255\009\000\054\000\
\007\000\021\000\053\000\252\255\056\000\009\000\024\000\059\000\
\022\000\027\000\057\000\054\000\251\255\250\255\072\000\090\000\
\075\000\126\000\078\000";
Lexing.lex_backtrk =
"\255\255\255\255\255\255\255\255\255\255\001\000\255\255\255\255\
\255\255\255\255\255\255\004\000\255\255\255\255\255\255\255\255\
......@@ -153,58 +155,58 @@ let lex_tables = {
\255\255\255\255\255\255\255\255\000\000\000\000\255\255\255\255\
\255\255\255\255\255\255";
Lexing.lex_trans =
"\020\000\021\000\021\000\022\000\023\000\023\000\024\000\023\000\
\025\000\026\000\008\000\013\000\042\000\028\000\029\000\030\000\
\031\000\032\000\005\000\014\000\005\000\033\000\015\000\007\000\
\038\000\034\000\004\000\035\000\032\000\014\000\036\000\012\000\
\036\000\013\000\023\000\023\000\021\000\021\000\021\000\017\000\
\010\000\011\000\010\000\006\000\014\000\006\000\006\000\018\000\
\006\000\014\000\014\000\014\000\019\000\007\000\019\000\037\000\
\007\000\004\000\004\000\004\000\039\000\039\000\039\000\039\000\
\014\000\014\000\014\000\039\000\014\000\040\000\038\000\014\000\
\039\000\014\000\014\000\038\000\042\000\000\000\000\000\014\000\
\014\000\041\000\041\000\000\000\041\000\000\000\000\000\000\000\
\000\000\000\000\039\000\039\000\039\000\039\000\039\000\039\000\
\039\000\039\000\039\000\000\000\000\000\000\000\039\000\000\000\
\040\000\000\000\000\000\039\000\000\000\000\000\000\000\041\000\
\041\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
"\020\000\021\000\021\000\022\000\023\000\023\000\024\000\021\000\
\023\000\025\000\026\000\008\000\042\000\038\000\028\000\029\000\
\030\000\031\000\032\000\005\000\007\000\005\000\033\000\015\000\
\014\000\013\000\034\000\004\000\035\000\032\000\014\000\036\000\
\014\000\036\000\014\000\023\000\023\000\021\000\021\000\021\000\
\014\000\017\000\010\000\011\000\010\000\012\000\006\000\013\000\
\006\000\018\000\006\000\014\000\006\000\014\000\019\000\014\000\
\019\000\007\000\039\000\039\000\039\000\007\000\039\000\014\000\
\014\000\038\000\039\000\014\000\040\000\014\000\014\000\039\000\
\004\000\004\000\004\000\037\000\014\000\014\000\038\000\041\000\
\041\000\042\000\000\000\041\000\000\000\000\000\000\000\000\000\
\000\000\039\000\039\000\039\000\039\000\039\000\039\000\039\000\
\039\000\000\000\039\000\000\000\000\000\000\000\039\000\000\000\
\040\000\000\000\000\000\039\000\000\000\000\000\041\000\041\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\039\000\039\000\039\000\
\039\000\039\000\041\000\041\000\041\000\041\000\000\000\000\000\
\000\000\041\000\000\000\000\000\000\000\000\000\041\000\000\000\
\039\000\039\000\041\000\041\000\041\000\000\000\041\000\000\000\
\000\000\000\000\041\000\000\000\000\000\000\000\000\000\041\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\041\000\041\000\041\000\041\000\041\000";
\000\000\041\000\041\000\041\000\041\000\041\000";
Lexing.lex_check =
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\002\000\013\000\022\000\000\000\000\000\000\000\
\000\000\000\000\003\000\013\000\003\000\000\000\001\000\018\000\
\024\000\000\000\017\000\000\000\000\000\029\000\000\000\011\000\
\000\000\011\000\000\000\000\000\000\000\000\000\000\000\001\000\
\002\000\002\000\002\000\005\000\032\000\005\000\006\000\001\000\
\006\000\025\000\033\000\025\000\001\000\005\000\001\000\034\000\