Skip to content

GitLab

C
cduce
Commit c0b5d1aa authored by Pietro Abate's avatar Pietro Abate
Browse files
Options

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

Original author: cvscast
Date: 2003-05-25 16:53:22+00:00
parent 8e30aa31
Expand all Hide whitespace changes
Inline Side-by-side
Showing with 366 additions and 328 deletions
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
This diff is collapsed.
parser/wlexer.mll
View file @ c0b5d1aa
(* File to be processed by wlex, not ocamllex ! *)
(* Loosely inspired from OCaml lexer.mll *)
classes
encoding_error
xml_char
blank
blank
lowercase uppercase ascii_digit
"_<>=.,:;+-*/@&{}[]()|?`\"\\\'!"
"#_<>=.,:;+-*/@&{}[]()|?`\"\\\'!"
unicode_base_char
unicode_ideographic
......@@ -85,17 +84,6 @@ let ncname_char =
let ncname = (letter | '_' ) ncname_char*
let qname = (ncname ':')? ncname
(*
let lident = (lowercase | '_' | unicode_base_char | unicode_ideographic)
name_char*
let uident = uppercase name_char*
*)
(*
let identchar = lowercase | uppercase | ascii_digit | '_' | '\'' | '-'
let ident = identchar* ( ':' identchar+)*
*)
rule token = parse
blank+ { token engine lexbuf }
| qname
......@@ -203,6 +191,7 @@ and parse_hexa_char = parse
(Illegal_character '\\') }
{
let delta_loc = ref 0
......
runtime/eval.ml
View file @ c0b5d1aa
......@@ -5,19 +5,11 @@ open Ident
exception MultipleDeclaration of id
type env = t Env.t
let global_env = State.ref "Eval.global_env" Env.empty
let enter_global x v =
if Env.mem x !global_env then
raise (MultipleDeclaration x);
global_env := Env.add x v !global_env
(* Evaluation of expressions *)
let rec eval env e0 = match e0.Typed.exp_descr with
| Typed.Forget (e,_) -> eval env e
| Typed.Var s -> (try Env.find s env with Not_found -> Env.find s !global_env)
| Typed.Var s -> (match Env.find s env with Value.Delayed x -> !x | x -> x)
| Typed.Apply (f,arg) -> eval_apply (eval env f) (eval env arg)
| Typed.Abstraction a -> eval_abstraction env a
| Typed.RecordLitt r -> Record (LabelMap.map (eval env) r)
......@@ -44,19 +36,22 @@ and eval_try env arg brs =
| x -> x
and eval_abstraction env a =
let self = ref Value.Absent in
let env =
IdSet.fold
(fun accu x ->
try Env.add x (Env.find x env) accu with Not_found -> accu)
(fun accu x -> Env.add x (Env.find x env) accu)
Env.empty a.Typed.fun_fv in
let env_ref = ref env in
let self = Abstraction (a.Typed.fun_iface,
eval_branches' env_ref a.Typed.fun_body) in
(match a.Typed.fun_name with
| None -> ()
| Some f -> env_ref := Env.add f self env;
);
self
match a.Typed.fun_name with
| None ->
Abstraction (a.Typed.fun_iface, eval_branches env a.Typed.fun_body)
| Some f ->
let self = ref Value.Absent in
let env = Env.add f (Value.Delayed self) env in
let a =
Abstraction
(a.Typed.fun_iface, eval_branches env a.Typed.fun_body) in
self := a;
a
and eval_apply f arg = match f with
......@@ -87,6 +82,21 @@ and eval_let_decl env l =
(fun (x,i) -> (x, if (i == -1) then v else bindings.(i)))
(IdMap.get bind)
and eval_rec_funs env l =
let slots =
List.fold_left
(fun accu -> function
| { Typed.exp_descr=Typed.Abstraction
{ Typed.fun_name = Some f } } as e ->
(f, e, ref Absent) :: accu
| _ -> assert false
) [] l in
let env' =
List.fold_left
(fun env (f, _ ,s) -> Env.add f (Delayed s) env)
env slots in
List.map (fun (f, e, s) -> s := eval env' e; (f, !s)) slots
and eval_map env brs = function
| Pair (x,y) ->
let x = eval_branches env brs x in
......
runtime/eval.mli
View file @ c0b5d1aa
......@@ -4,12 +4,6 @@ open Ident
exception MultipleDeclaration of id
type env = t Env.t
val global_env : env ref
val enter_global : id -> t -> unit
val eval: env -> Typed.texpr -> t
val eval_let_decl: env -> Typed.let_decl -> (id * t) list
val eval_rec_funs: env -> Typed.texpr list -> (id * t) list
runtime/run_dispatch.ml
View file @ c0b5d1aa
......@@ -168,6 +168,7 @@ and run_disp_kind actions v =
actions.basic
| Absent ->
run_disp_basic v (fun t -> Types.Record.has_absent t) actions.basic
| Delayed _ -> assert false
and run_disp_prod v v1 v2 = function
......
runtime/value.ml
View file @ c0b5d1aa
......@@ -13,6 +13,8 @@ type t =
| String_utf8 of Utf8.uindex * Utf8.uindex * Utf8.t * t
| Absent
| Delayed of t ref
exception CDuceExn of t
......@@ -117,6 +119,8 @@ let rec print ppf v =
(Utf8.get_idx i) (Utf8.get_idx j) (Utf8.get_str s) print q
| Absent ->
Format.fprintf ppf "<[absent]>"
| Delayed x ->
Format.fprintf ppf "<[delayed]>"
and print_quoted_str ppf = function
| Pair (Char c, q) ->
Chars.print_v_in_string ppf c;
......@@ -204,7 +208,8 @@ let rec compare x y =
| Abstraction (_,_), _
| _, Abstraction (_,_) ->
raise (CDuceExn (string_latin1 "comparing functional values"))
| Absent,_ | _,Absent -> assert false
| Absent,_ | _,Absent
| Delayed _, _ | _, Delayed _ -> assert false
| String_latin1 (ix,jx,sx,qx), String_latin1 (iy,jy,sy,qy) ->
if (sx == sy) && (ix = iy) && (jx = jy) then compare qx qy
else
......
runtime/value.mli
View file @ c0b5d1aa
......@@ -18,6 +18,8 @@ type t =
(* Special value for absent record fields, and failed pattern matching *)
| Absent
(* Only in evaluation environment *)
| Delayed of t ref
exception CDuceExn of t
......
tests/overloading.cd
View file @ c0b5d1aa
type Person = FPerson | MPerson;;
type FPerson = <person gender = "F" >[ Name Children (Tel | Email)?];;
type MPerson = <person gender="M">[ Name Children (Tel | Email)?];;
type Children = <children>[Person*];;
type Name = <name>[ PCDATA ];;
type Tel = <tel kind=?"home"|"work">['0'--'9'+ '-' '0'--'9'+];;
type Email = <email>[PCDATA '@' PCDATA];;
type Man = <man name=String>[ Sons Daughters ];;
type Woman = <woman name=String>[ Sons Daughters ];;
type Sons = <sons>[ Man* ];;
type Daughters = <daughters>[ Woman* ];;
type Person = FPerson | MPerson
type FPerson = <person gender = "F" >[ Name Children (Tel | Email)?]
type MPerson = <person gender="M">[ Name Children (Tel | Email)?]
type Children = <children>[Person*]
type Name = <name>[ PCDATA ]
type Tel = <tel kind=?"home"|"work">['0'--'9'+ '-' '0'--'9'+]
type Email = <email>[PCDATA '@' PCDATA]
type Man = <man name=String>[ Sons Daughters ]
type Woman = <woman name=String>[ Sons Daughters ]
type Sons = <sons>[ Man* ]
type Daughters = <daughters>[ Woman* ]
let fun sort (MPerson -> Man ; FPerson -> Woman)
<person gender=g>[ <name>n <children>[(mc::MPerson | fc::FPerson)*]; _] ->
......@@ -17,7 +17,7 @@ let fun sort (MPerson -> Man ; FPerson -> Woman)
let s = map mc with x -> sort x in
let d = map fc with x -> sort x in
<(tag) name=n>[ <sons>s <daughters>d ]
;;
let base : Person =
<person gender="M">[
......@@ -34,8 +34,8 @@ let base : Person =
<tel> "314-1592654"
]
]
]
;;
];;
sort base;;
......
typing/typer.ml
View file @ c0b5d1aa
......@@ -492,26 +492,34 @@ and pat_node s : Patterns.node =
x
let glb = State.ref "Typer.glb_env" TypeEnv.empty
let register_global_types b =
List.iter
(fun (v,p) ->