Commit 58ace5ad authored by Pietro Abate's avatar Pietro Abate

[r2002-11-01 12:53:44 by cvscast] Empty log message

Original author: cvscast
Date: 2002-11-01 12:53:45+00:00
parent 97b4a244
......@@ -8,16 +8,18 @@ PARSER = parser/lexer.cmo parser/location.cmo parser/ast.cmo parser/parser.cmo
TYPING = typing/typed.cmo typing/typer.cmo
TYPES = types/recursive.cmo types/recursive_share.cmo types/recursive_noshare.cmo \
types/sortedList.cmo \
types/sortedMap.cmo types/boolean.cmo \
TYPES = types/recursive.cmo \
types/recursive_share.cmo types/recursive_noshare.cmo \
types/sortedList.cmo types/sortedMap.cmo types/boolean.cmo \
types/intervals.cmo types/chars.cmo types/atoms.cmo \
types/types.cmo \
types/patterns.cmo \
types/sequence.cmo \
types/builtin.cmo
RUNTIME = runtime/value.cmo
RUNTIME = runtime/value.cmo \
runtime/load_xml.cmo runtime/run_dispatch.cmo \
runtime/eval.cmo
DRIVER = driver/cduce.cmo
......
......@@ -44,28 +44,38 @@ types/sortedList.cmo: types/sortedList.cmi
types/sortedList.cmx: types/sortedList.cmi
types/sortedMap.cmo: types/sortedMap.cmi
types/sortedMap.cmx: types/sortedMap.cmi
types/strings.cmo: types/boolean.cmi types/intervals.cmi types/recursive.cmo \
types/strings.cmi
types/strings.cmx: types/boolean.cmx types/intervals.cmx types/recursive.cmx \
types/strings.cmi
types/type_bool.cmo: types/boolean.cmi types/recursive.cmo
types/type_bool.cmx: types/boolean.cmx types/recursive.cmx
types/types.cmo: types/atoms.cmi types/boolean.cmi types/chars.cmi \
types/intervals.cmi types/recursive.cmo types/recursive_share.cmo \
types/intervals.cmi types/recursive.cmo types/recursive_noshare.cmo \
types/sortedList.cmi types/sortedMap.cmi types/types.cmi
types/types.cmx: types/atoms.cmx types/boolean.cmx types/chars.cmx \
types/intervals.cmx types/recursive.cmx types/recursive_share.cmx \
types/intervals.cmx types/recursive.cmx types/recursive_noshare.cmx \
types/sortedList.cmx types/sortedMap.cmx types/types.cmi
runtime/value.cmo: types/chars.cmi types/patterns.cmi types/sequence.cmi \
types/sortedMap.cmi typing/typed.cmo types/types.cmi runtime/value.cmi
runtime/value.cmx: types/chars.cmx types/patterns.cmx types/sequence.cmx \
types/sortedMap.cmx typing/typed.cmx types/types.cmx runtime/value.cmi
driver/cduce.cmo: parser/ast.cmo types/builtin.cmo parser/location.cmi \
parser/parser.cmi types/patterns.cmi typing/typer.cmi types/types.cmi \
runtime/value.cmi
driver/cduce.cmx: parser/ast.cmx types/builtin.cmx parser/location.cmx \
parser/parser.cmx types/patterns.cmx typing/typer.cmx types/types.cmx \
runtime/value.cmx
runtime/eval.cmo: types/chars.cmi runtime/load_xml.cmi \
runtime/run_dispatch.cmi typing/typed.cmo types/types.cmi \
runtime/value.cmi runtime/eval.cmi
runtime/eval.cmx: types/chars.cmx runtime/load_xml.cmx \
runtime/run_dispatch.cmx typing/typed.cmx types/types.cmx \
runtime/value.cmx runtime/eval.cmi
runtime/load_xml.cmo: types/sortedMap.cmi types/types.cmi runtime/value.cmi \
runtime/load_xml.cmi
runtime/load_xml.cmx: types/sortedMap.cmx types/types.cmx runtime/value.cmx \
runtime/load_xml.cmi
runtime/run_dispatch.cmo: types/patterns.cmi types/types.cmi \
runtime/run_dispatch.cmi
runtime/run_dispatch.cmx: types/patterns.cmx types/types.cmx \
runtime/run_dispatch.cmi
runtime/value.cmo: types/chars.cmi types/sequence.cmi types/sortedMap.cmi \
types/types.cmi runtime/value.cmi
runtime/value.cmx: types/chars.cmx types/sequence.cmx types/sortedMap.cmx \
types/types.cmx runtime/value.cmi
driver/cduce.cmo: parser/ast.cmo types/builtin.cmo runtime/eval.cmi \
parser/location.cmi parser/parser.cmi types/patterns.cmi typing/typer.cmi \
types/types.cmi runtime/value.cmi
driver/cduce.cmx: parser/ast.cmx types/builtin.cmx runtime/eval.cmx \
parser/location.cmx parser/parser.cmx types/patterns.cmx typing/typer.cmx \
types/types.cmx runtime/value.cmx
parser/parser.cmi: parser/ast.cmo
typing/typer.cmi: parser/ast.cmo typing/typed.cmo types/types.cmi
types/boolean.cmi: types/sortedList.cmi
......@@ -75,4 +85,7 @@ types/sortedMap.cmi: types/sortedList.cmi
types/syntax.cmi: types/patterns.cmi types/types.cmi
types/types.cmi: types/atoms.cmi types/chars.cmi types/intervals.cmi \
types/sortedMap.cmi
runtime/value.cmi: types/patterns.cmi typing/typed.cmo
runtime/eval.cmi: typing/typed.cmo runtime/value.cmi
runtime/load_xml.cmi: runtime/value.cmi
runtime/run_dispatch.cmi: types/patterns.cmi runtime/value.cmi
runtime/value.cmi: types/chars.cmi types/sortedMap.cmi types/types.cmi
......@@ -88,7 +88,7 @@ let debug = function
| _ -> Format.fprintf ppf "Unknown or ill-formed debugging directive !! @\n"
let typing_env = ref Typer.Env.empty
let eval_env = ref Value.Env.empty
let eval_env = ref Eval.Env.empty
let insert_type_bindings =
List.iter (fun (x,t) ->
......@@ -99,10 +99,10 @@ let type_decl decl =
insert_type_bindings (Typer.type_let_decl !typing_env decl)
let eval_decl decl =
let bindings = Value.eval_let_decl !eval_env decl in
let bindings = Eval.eval_let_decl !eval_env decl in
List.iter
(fun (x,v) ->
eval_env := Value.Env.add x v !eval_env;
Eval.enter_global x v;
Format.fprintf ppf "=> %s : @[%a@]@\n" x Value.print v
) bindings
......@@ -112,7 +112,7 @@ let phrase ph =
let (fv,e) = Typer.expr e in
let t = Typer.type_check !typing_env e Types.any true in
Format.fprintf ppf "|- %a@\n" print_norm t;
let v = Value.eval !eval_env e in
let v = Eval.eval !eval_env e in
Format.fprintf ppf "=> @[%a@]@\n" Value.print v
| Ast.LetDecl (p,{descr=Ast.Abstraction _}) -> ()
| Ast.LetDecl (p,e) ->
......
open Value
open Run_dispatch
module Env = Map.Make (struct type t = string let compare = compare end)
type env = t Env.t
let global_env = ref Env.empty
let enter_global x v = global_env := Env.add x v !global_env
let exn_int_of = CDuceExn (Pair (Atom (Types.mk_atom "Invalid_argument"),
string "int_of"))
(* 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.Apply (f,arg) -> eval_apply (eval env f) (eval env arg)
| Typed.Abstraction a ->
let env =
List.fold_left
(fun accu x ->
try Env.add x (Env.find x env) accu
with Not_found -> accu (* global *))
Env.empty a.Typed.fun_fv in
let env_ref = ref env in
let rec 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
(* Optimizations:
- for the non-recursive case, use eval_branches
- for the recursive case, could cheat bt pathing self afterwards:
(Obj.magic self).(1) <- ....
*)
| Typed.RecordLitt r -> Record (List.map (fun (l,e) -> (l, eval env e)) r)
| Typed.Pair (e1,e2) -> Pair (eval env e1, eval env e2)
| Typed.Cst c -> const c
| Typed.Match (arg,brs) -> eval_branches env brs (eval env arg)
| Typed.Map (arg,brs) -> eval_map env brs (eval env arg)
| Typed.Op ("raise", [e]) -> raise (CDuceExn (eval env e))
| Typed.Try (arg,brs) ->
(try eval env arg with CDuceExn v -> eval_branches env brs v)
| Typed.Op ("flatten", [e]) -> eval_flatten (eval env e)
| Typed.Op ("@", [e1; e2]) -> eval_concat (eval env e1) (eval env e2)
| Typed.Op ("+", [e1; e2]) -> eval_add (eval env e1) (eval env e2)
| Typed.Op ("*", [e1; e2]) -> eval_mul (eval env e1) (eval env e2)
| Typed.Op ("-", [e1; e2]) -> eval_sub (eval env e1) (eval env e2)
| Typed.Op ("/", [e1; e2]) -> eval_div (eval env e1) (eval env e2)
| Typed.Op ("load_xml", [e]) -> eval_load_xml (eval env e)
| Typed.Op ("int_of", [e]) -> eval_int_of (eval env e)
| Typed.Dot (e, l) -> eval_dot l (eval env e)
| Typed.DebugTyper t -> failwith "Evaluating a ! expression"
| Typed.Op (o,_) -> failwith ("Unknown operator " ^ o)
and eval_apply f arg = match f with
| Abstraction (_,clos) -> clos arg
| _ -> assert false
and eval_branches' env_ref brs arg =
eval_branches !env_ref brs arg
and eval_branches env brs arg =
let (disp, rhs) = Typed.dispatcher brs in
let (code, bindings) = run_dispatcher disp arg in
let (bind, e) = rhs.(code) in
let env =
List.fold_left (fun env (x,i) ->
if (i = -1) then Env.add x arg env
else Env.add x bindings.(i) env) env bind in
eval env e
and eval_let_decl env l =
let v = eval env l.Typed.let_body in
let (disp,bind) = Typed.dispatcher_let_decl l in
let (_,bindings) = run_dispatcher disp v in
List.map (fun (x,i) -> (x, if (i = -1) then v else bindings.(i))) bind
and eval_map env brs = function
| Pair (x,y) -> Pair (eval_branches env brs x, eval_map env brs y)
| String (_,_,_,_) as v -> eval_map env brs (normalize v)
| q -> q
and eval_flatten = function
| Pair (x,y) -> eval_concat x (eval_flatten y)
| q -> q
and eval_concat l1 l2 = match l1 with
| Pair (x,y) -> Pair (x, eval_concat y l2)
| String (s,i,j,q) -> String (s,i,j, eval_concat q l2)
| q -> l2
and eval_dot l = function
| Record r -> List.assoc l r
| _ -> assert false
and eval_add x y = match (x,y) with
| (Integer x, Integer y) -> Integer (Big_int.add_big_int x y)
| _ -> assert false
and eval_mul x y = match (x,y) with
| (Integer x, Integer y) -> Integer (Big_int.mult_big_int x y)
| _ -> assert false
and eval_sub x y = match (x,y) with
| (Integer x, Integer y) -> Integer (Big_int.sub_big_int x y)
| _ -> assert false
and eval_div x y = match (x,y) with
| (Integer x, Integer y) -> Integer (Big_int.div_big_int x y)
| _ -> assert false
and eval_load_xml e =
Load_xml.run (get_string e)
and eval_int_of e =
let s = get_string e in
try Integer (Big_int.big_int_of_string s)
with Failure _ -> raise exn_int_of
and get_string e =
let rec compute_len accu = function
| Pair (_,y) -> compute_len (accu + 1) y
| String (i,j,_,y) -> compute_len (accu + j - i) y
| _ -> accu in
let rec fill pos s = function
| Pair (Char x,y) -> s.[pos] <- Chars.Unichar.to_char x; fill (pos + 1) s y
| String (i,j,src,y) ->
String.blit src i s pos (j - i); fill (pos + j - i) s y
| _ -> s in
fill 0 (String.create (compute_len 0 e)) e
open Value
module Env : Map.S with type key = string
type env = t Env.t
val enter_global : string -> t -> unit
val eval: env -> Typed.texpr -> t
val eval_let_decl: env -> Typed.let_decl -> (string * t) list
(* Loading XML documents *)
(*TODO: close the file ! *)
open Pxp_yacc
open Pxp_lexer_types
open Pxp_types
open Value
let string s q =
let rec check_ws i = (i < 0) ||
(match s.[i] with
| ' ' | '\t' | '\n' | '\r' -> check_ws (i - 1)
| _ -> false) in
if check_ws (String.length s - 1) then q
else String (0,String.length s,s,q)
let run s =
let config = { default_config with
store_element_positions = false;
drop_ignorable_whitespace = true
}
in
let mgr = create_entity_manager config (from_file s) in
let next_event =
create_pull_parser config (`Entry_document[]) mgr in
let curr = ref E_end_of_stream in
let get () =
match next_event () with
| Some x -> curr := x
| None -> () in
let rec parse_elt name att =
let att = List.map (fun (l,v) -> Types.label l, string v nil) att in
let att = SortedMap.from_list (fun _ _ -> assert false) att in
let child = parse_seq () in
let elt = Pair
(Atom (Types.mk_atom name),
Pair (Record att, child)
) in
(match !curr with
| E_end_tag (_,_) -> get ()
| _ -> failwith "Expect end_tag");
elt
and parse_seq () =
match !curr with
| E_start_tag (name,att,_) ->
get ();
let e1 = parse_elt name att in
let rest = parse_seq () in
Pair (e1, rest)
| E_char_data data ->
get ();
let rest = parse_seq () in
string data rest
| E_end_tag (_,_) ->
nil
| _ -> failwith "Expect start_tag, char_data, or end_tag"
and parse_doc () =
match !curr with
| E_start_tag (name,att,_) -> get (); parse_elt name att
| _ -> get (); parse_doc ()
in
get ();
parse_doc ()
val run: string -> Value.t
(* Running dispatchers *)
open Value
let make_result_prod v1 r1 v2 r2 v (code,r) =
let ret = Array.map
(function
| `Catch -> v
| `Const c -> const c
| `Left i -> if (i < 0) then v1 else r1.(i)
| `Right j -> if (j < 0) then v2 else r2.(j)
| `Recompose (i,j) ->
Pair ((if (i < 0) then v1 else r1.(i)),
(if (j < 0) then v2 else r2.(j)))
| _ -> assert false
) r in
(code,ret)
let make_result_record fields v bindings (code,r) =
let ret = Array.map
(function
| `Catch -> v
| `Const c -> const c
| `Field (l,i) ->
if (i < 0) then List.assoc l fields
else (List.assoc l bindings).(i)
| _ -> assert false
) r in
(code,ret)
let make_result_basic v (code,r) =
let ret = Array.map
(function
| `Catch -> v
| `Const c -> const c
| _ -> assert false
) r in
(code,ret)
let dummy_r = [||]
let rec run_dispatcher d v =
let actions = Patterns.Compile.actions d in
match actions with
| `Ignore r -> make_result_basic v r
| `Kind k -> run_disp_kind k v
and run_disp_kind actions v = match v with
| Pair (v1,v2) -> run_disp_prod v v1 v2 actions.Patterns.Compile.prod
| Record r -> run_disp_record r v [] r actions.Patterns.Compile.record
| Atom a ->
run_disp_basic v (fun t -> Types.Atom.has_atom t a)
actions.Patterns.Compile.basic
| Char c ->
run_disp_basic v (fun t -> Types.Char.has_char t c)
actions.Patterns.Compile.basic
| Integer i ->
run_disp_basic v (fun t -> Types.Int.has_int t i)
actions.Patterns.Compile.basic
| Abstraction (iface,_) ->
run_disp_basic v (fun t -> Types.Arrow.check_iface iface t)
actions.Patterns.Compile.basic
| v ->
run_disp_kind actions (normalize v)
and run_disp_basic v f = function
| [(_,r)] -> make_result_basic v r
| (t,r)::rem -> if f t then make_result_basic v r else run_disp_basic v f rem
| _ -> assert false
and run_disp_prod v v1 v2 = function
| `None -> assert false
| `TailCall d1 -> run_dispatcher d1 v1
| `Ignore d2 -> run_disp_prod2 v1 dummy_r v v2 d2
| `Dispatch (d1,b1) ->
let (code1,r1) = run_dispatcher d1 v1 in
run_disp_prod2 v1 r1 v v2 b1.(code1)
and run_disp_prod2 v1 r1 v v2 = function
| `None -> assert false
| `Ignore r -> make_result_prod v1 r1 v2 dummy_r v r
| `TailCall d2 -> run_dispatcher d2 v2
| `Dispatch (d2,b2) ->
let (code2,r2) = run_dispatcher d2 v2 in
make_result_prod v1 r1 v2 r2 v b2.(code2)
and run_disp_record f v bindings fields = function
| None -> assert false
| Some record -> run_disp_record' f v bindings fields record
and run_disp_record' f v bindings fields = function
| `Result r -> make_result_record f v bindings r
| `Label (l, present, absent) ->
let rec aux = function
| (l1,_) :: rem when l1 < l -> aux rem
| (l1,vl) :: rem when l1 = l ->
run_disp_field f v bindings rem l vl present
| _ -> run_disp_record f v bindings fields absent
in
aux fields
and run_disp_field f v bindings fields l vl = function
| `None -> assert false
| `Ignore r -> run_disp_record' f v bindings fields r
| `TailCall d -> run_dispatcher d vl
| `Dispatch (dl,bl) ->
let (codel,rl) = run_dispatcher dl vl in
run_disp_record' f v ((l,rl)::bindings) fields bl.(codel)
open Value
val run_dispatcher: Patterns.Compile.dispatcher -> t -> int * t array
This diff is collapsed.
type t
type t =
(* Canonical representation *)
| Pair of t * t
| Record of (Types.label,t) SortedMap.t
| Atom of Types.atom
| Integer of Big_int.big_int
| Char of Chars.Unichar.t
| Abstraction of (Types.descr * Types.descr) list * (t -> t)
(* Derived forms *)
| String of int * int * string * t
module Env : Map.S with type key = string
type env = t Env.t
exception CDuceExn of t
val print: Format.formatter -> t -> unit
val run_dispatcher: Patterns.Compile.dispatcher -> t -> int * t array
val normalize: t -> t
(* Transform a derived form to its canonical equivalent *)
val eval: env -> Typed.texpr -> t
val eval_let_decl: env -> Typed.let_decl -> (string * t) list
val const : Types.const -> t
val string : string -> t
val nil : t
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment