| 1 |
(* Typed abstract syntax *)
|
| 2 |
|
| 3 |
(* Some sub-expression may have to be type-checked several times.
|
| 4 |
We first build the ``skeleton'' of the typed ast
|
| 5 |
(basically the parsed ast with types and patterns replaced with there
|
| 6 |
internal representation), then type check it.
|
| 7 |
|
| 8 |
The exp_typ and br_typ fields are updated to capture all the possible
|
| 9 |
values than can result from the expression or flow to the branch
|
| 10 |
*)
|
| 11 |
|
| 12 |
open Location
|
| 13 |
open Ident
|
| 14 |
|
| 15 |
type tpat = Patterns.node
|
| 16 |
type ttyp = Types.node
|
| 17 |
|
| 18 |
type texpr =
|
| 19 |
{ exp_loc : loc;
|
| 20 |
mutable exp_typ : Types.descr;
|
| 21 |
exp_descr : texpr';
|
| 22 |
}
|
| 23 |
and texpr' =
|
| 24 |
| Forget of texpr * ttyp
|
| 25 |
(* CDuce is a Lambda-calculus ... *)
|
| 26 |
| Var of id
|
| 27 |
| Apply of texpr * texpr
|
| 28 |
| Abstraction of abstr
|
| 29 |
|
| 30 |
(* Data constructors *)
|
| 31 |
| Cst of Types.const
|
| 32 |
| Pair of texpr * texpr
|
| 33 |
| Xml of texpr * texpr
|
| 34 |
| RecordLitt of texpr label_map
|
| 35 |
|
| 36 |
(* Data destructors *)
|
| 37 |
| Match of texpr * branches
|
| 38 |
| Map of texpr * branches
|
| 39 |
| Transform of texpr * branches
|
| 40 |
| Xtrans of texpr * branches
|
| 41 |
| RemoveField of texpr * label
|
| 42 |
| Dot of texpr * label
|
| 43 |
|
| 44 |
(* Exception *)
|
| 45 |
| Try of texpr * branches
|
| 46 |
|
| 47 |
| UnaryOp of unary_op * texpr
|
| 48 |
| BinaryOp of binary_op * texpr * texpr
|
| 49 |
|
| 50 |
and unary_op = {
|
| 51 |
un_op_typer : loc -> typ_fun -> typ_fun;
|
| 52 |
un_op_eval : Value.t -> Value.t
|
| 53 |
}
|
| 54 |
and binary_op = {
|
| 55 |
bin_op_typer : loc -> typ_fun -> typ_fun -> typ_fun;
|
| 56 |
bin_op_eval : Value.t -> Value.t -> Value.t
|
| 57 |
}
|
| 58 |
and typ_fun = Types.descr -> bool -> Types.descr
|
| 59 |
|
| 60 |
and abstr = {
|
| 61 |
fun_name : id option;
|
| 62 |
fun_iface : (Types.descr * Types.descr) list;
|
| 63 |
fun_body : branches;
|
| 64 |
fun_typ : Types.descr;
|
| 65 |
fun_fv : fv
|
| 66 |
}
|
| 67 |
|
| 68 |
and let_decl = {
|
| 69 |
let_pat : tpat;
|
| 70 |
let_body : texpr;
|
| 71 |
mutable let_compiled :
|
| 72 |
(Patterns.Compile.dispatcher * int id_map) option
|
| 73 |
}
|
| 74 |
|
| 75 |
and branches = {
|
| 76 |
mutable br_typ : Types.descr; (* Type of values that can flow to branches *)
|
| 77 |
br_accept : Types.descr; (* Type accepted by all branches *)
|
| 78 |
br_branches: branch list;
|
| 79 |
|
| 80 |
mutable br_compiled : compiled_branches option;
|
| 81 |
}
|
| 82 |
and branch = {
|
| 83 |
br_loc : loc;
|
| 84 |
mutable br_used : bool;
|
| 85 |
br_pat : tpat;
|
| 86 |
br_body : texpr
|
| 87 |
}
|
| 88 |
and compiled_branches =
|
| 89 |
Patterns.Compile.dispatcher * texpr Patterns.Compile.rhs array
|
| 90 |
|
| 91 |
|
| 92 |
let dispatcher brs =
|
| 93 |
match brs.br_compiled with
|
| 94 |
| Some d -> d
|
| 95 |
| None ->
|
| 96 |
let aux b = b.br_pat, b.br_body in
|
| 97 |
let x = Patterns.Compile.make_branches
|
| 98 |
brs.br_typ
|
| 99 |
(List.map aux brs.br_branches) in
|
| 100 |
brs.br_compiled <- Some x;
|
| 101 |
x
|
| 102 |
|
| 103 |
let dispatcher_let_decl l =
|
| 104 |
match l.let_compiled with
|
| 105 |
| Some d -> d
|
| 106 |
| None ->
|
| 107 |
let comp = Patterns.Compile.make_branches
|
| 108 |
(Types.descr (Patterns.accept l.let_pat))
|
| 109 |
[ l.let_pat, () ] in
|
| 110 |
let x = match comp with
|
| 111 |
| (disp, [| Patterns.Compile.Match (l, ()) |]) -> (disp,l)
|
| 112 |
| _ -> assert false
|
| 113 |
in
|
| 114 |
l.let_compiled <- Some x;
|
| 115 |
x
|
| 116 |
|
| 117 |
type op = [ `Unary of unary_op | `Binary of binary_op ]
|
| 118 |
let op_table : (string,op) Hashtbl.t = Hashtbl.create 31
|
| 119 |
let register_op s f = Hashtbl.add op_table s f
|
| 120 |
let find_op s = Hashtbl.find op_table s
|
Parent Directory
| 
Revision Log