Commit 4b3d0739 authored by Pietro Abate's avatar Pietro Abate
Browse files

[r2002-11-01 03:37:28 by cvscast] Empty log message

Original author: cvscast
Date: 2002-11-01 03:37:28+00:00
parent 0ade6a62
......@@ -6,14 +6,10 @@ type t =
| Atom of Types.atom
| Integer of Big_int.big_int
| Char of Chars.Unichar.t
| Fun of abstr
| Abstraction of (Types.descr * Types.descr) list * (t -> t)
| String of int * int * string * t
and env = t Env.t
and abstr = {
fun_iface : (Types.descr * Types.descr) list;
mutable fun_env : env;
fun_body : Typed.branches;
}
type env = t Env.t
exception CDuceExn of t
......@@ -47,7 +43,7 @@ let rec print ppf v =
| Atom a -> Format.fprintf ppf "`%s" (Types.atom_name a)
| Integer i -> Format.fprintf ppf "%s" (Big_int.string_of_big_int i)
| Char c -> Chars.Unichar.print ppf c
| Fun c -> Format.fprintf ppf "<fun>"
| Abstraction _ -> Format.fprintf ppf "<fun>"
| String (i,j,s,q) ->
Format.fprintf ppf "<string:%i-%i,%S,%a>" i j s print q
and print_quoted_str ppf = function
......@@ -246,8 +242,8 @@ and run_disp_kind actions v = match v with
| Integer i ->
run_disp_basic v (fun t -> Types.Int.has_int t i)
actions.Patterns.Compile.basic
| Fun f ->
run_disp_basic v (fun t -> Types.Arrow.check_iface f.fun_iface t)
| 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)
......@@ -257,7 +253,7 @@ and normalize = function
if i = j then q else
Pair (Char (Chars.Unichar.from_char s.[i]),
String (succ i,j,s,q))
| x -> x
| _ -> assert false
and run_disp_basic v f = function
| [(_,r)] -> make_result_basic v r
......@@ -313,16 +309,23 @@ let rec eval env e0 =
| Typed.Var s -> Env.find s env
| Typed.Apply (f,arg) -> eval_apply (eval env f) (eval env arg)
| Typed.Abstraction a ->
let a' = {
fun_env = env;
fun_iface = a.Typed.fun_iface;
fun_body = a.Typed.fun_body
} in
let self = Fun a' in
let env =
List.fold_left
(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 rec self = Abstraction (a.Typed.fun_iface,
eval_branches' env_ref a.Typed.fun_body) in
(match a.Typed.fun_name with
| Some f -> a'.fun_env <- Env.add f self a'.fun_env
| None -> ());
| 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
......@@ -345,9 +348,12 @@ let rec eval env e0 =
and eval_apply f arg = match f with
| Fun a -> eval_branches a.fun_env a.fun_body arg
| 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
......
......@@ -16,14 +16,13 @@ type Mix = <h1>[Mix*]
| <ul>[ <li>[Mix*] +]
| Char;;
let fun do_authors ([Author+] -> [Mix*])
| [ <author>a ] -> a
| [ <author>a <author>b ] -> a @ " and, " @ b
| [ <author>a; x] -> a @ ", " @ do_authors x
in
let fun do_paper (Paper -> <li>[Mix*])
<paper>[ x::(_*) <title>t <conference>c <file>f ] ->
<paper>[ x::(_* ) <title>t <conference>c <file>f ] ->
(* Here, type inference says: x : [Author+] ... *)
let authors = do_authors x in
<li>([ <a href=f>t ] @ authors @ "; in " @ [ <em>c ] @ "." )
......@@ -36,7 +35,7 @@ let fun do_biblio (Biblio -> Html)
in
<html>[ <head>[ <title>h ] <body>body ]
in
let bib : Biblio =
let bib =
<bibliography>[
<heading>"Alain Frisch's bibliography"
<paper>[
......
......@@ -11,7 +11,8 @@ let may_remove (p1,n1) (p2,n2) =
let cup t s =
if t == s then t
else if (t == full) || (s == full) then full
else if t = empty then s else if s = empty then t
else if (t = full) || (s = full) then full
else
let s=
List.filter (fun (p,n) -> not (List.exists (may_remove (p,n)) t)) s in
......
......@@ -51,7 +51,7 @@ module I = struct
let any_record = { empty with record = any.record }
let cup x y =
if x == y then x else {
if x = y then x else {
times = Boolean.cup x.times y.times;
arrow = Boolean.cup x.arrow y.arrow;
record= Boolean.cup x.record y.record;
......@@ -61,7 +61,7 @@ module I = struct
}
let cap x y =
if x == y then x else {
if x = y then x else {
times = Boolean.cap x.times y.times;
record= Boolean.cap x.record y.record;
arrow = Boolean.cap x.arrow y.arrow;
......@@ -71,7 +71,7 @@ module I = struct
}
let diff x y =
if x == y then empty else {
if x = y then empty else {
times = Boolean.diff x.times y.times;
arrow = Boolean.diff x.arrow y.arrow;
record= Boolean.diff x.record y.record;
......@@ -83,9 +83,9 @@ module I = struct
let neg x = diff any x
let equal e a b =
if not (Intervals.equal a.ints b.ints) then raise NotEqual;
if a.atoms <> b.atoms then raise NotEqual;
if a.chars <> b.chars then raise NotEqual;
if a.ints <> b.ints then raise NotEqual;
Boolean.equal (fun (x1,x2) (y1,y2) -> e x1 y1; e x2 y2) a.times b.times;
Boolean.equal (fun (x1,x2) (y1,y2) -> e x1 y1; e x2 y2) a.arrow b.arrow;
Boolean.equal (fun (l1,o1,x1) (l2,o2,x2) ->
......@@ -102,8 +102,11 @@ module I = struct
}
let hash h a =
Hashtbl.hash (map h a)
(*
(Hashtbl.hash { (map h a) with ints = Intervals.empty })
+ (Intervals.hash a.ints)
*)
let iter f a =
ignore (map f a)
......
......@@ -327,7 +327,7 @@ let rec expr { loc = loc; descr = d } =
Typed.fun_iface = iface;
Typed.fun_body = body;
Typed.fun_typ = t;
Typed.fun_fv = Fv.elements fv0
Typed.fun_fv = Fv.elements fv
}
)
| Cst c -> (Fv.empty, Typed.Cst c)
......@@ -380,8 +380,9 @@ let rec expr { loc = loc; descr = d } =
let b = List.map
(fun (p,e) ->
let (fv2,e) = expr e in
fv := Fv.union !fv fv2;
let p = pat p in
let fv2 = List.fold_right Fv.remove (Patterns.fv p) fv2 in
fv := Fv.union !fv fv2;
accept := Types.cup !accept (Types.descr (Patterns.accept p));
{ Typed.br_used = false;
Typed.br_pat = p;
......
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