viewcvs.cgi/typing/typed.ml

(* Typed abstract syntax *) 

(*  Some sub-expression may have to be type-checked several times.
    We first build the ``skeleton'' of the typed ast
    (basically the parsed ast with types and patterns replaced with there
    internal representation), then type check it.

    The exp_typ and br_typ fields are updated to capture all the possible
    values than can result from the expression or flow to the branch
*)

open Location

type tpat = Patterns.node
type ttyp = Types.node

type texpr  = { exp_loc : loc; 
                mutable exp_typ : Types.descr; 
                exp_descr : texpr';
              }
and  texpr' = 
  | DebugTyper of ttyp

  | Forget of texpr * ttyp
  (* CDuce is a Lambda-calculus ... *)
  | Var of string
  | Apply of texpr * texpr
  | Abstraction of abstr
      
  (* Data constructors *)
  | Cst of Types.const
  | Pair of texpr * texpr
  | RecordLitt of (Types.label, texpr) SortedMap.t
      
  (* Data destructors *)
  | Op of string * texpr list
  | Match of texpr * branches
  | Map of texpr * branches
  | Dot of (texpr * Types.label)
      
  (* Exception *)
  | Try of texpr * branches

and abstr = { 
  fun_name : string option; 
  fun_iface : (Types.descr * Types.descr) list;
  fun_body : branches;
  fun_typ  : Types.descr;
  fun_fv   : string list;
}

and let_decl = {
  let_pat : tpat;
  let_body : texpr;
  mutable let_compiled : 
    (Patterns.Compile.dispatcher * (string * int) list) option
}

and branches = { 
  mutable br_typ : Types.descr;
  br_accept : Types.descr;
  br_branches: branch list;

  mutable br_compiled : compiled_branches option;
}
and branch = { 
  mutable br_used : bool; 
  br_pat : tpat; 
  br_body :  texpr 
}
and compiled_branches =  
    Patterns.Compile.dispatcher * ((string * int) list * texpr) array


let dispatcher brs =
  match brs.br_compiled with
    | Some d -> d
    | None ->
        let aux b = Patterns.descr b.br_pat, b.br_body in
        let x = Patterns.Compile.make_branches
                  brs.br_typ
                  (List.map aux brs.br_branches) in
        brs.br_compiled <- Some x;
        x
                     
let dispatcher_let_decl l =
  match l.let_compiled with
    | Some d -> d
    | None ->
        let comp = Patterns.Compile.make_branches
                     (Types.descr (Patterns.accept l.let_pat))
                     [ Patterns.descr l.let_pat, () ]  in
        let x = match comp with
          | (disp, [| l, () |]) -> (disp,l)
          | _ -> assert false
        in
        l.let_compiled <- Some x;
        x
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
14	type tpat = Patterns.node
15	type ttyp = Types.node
16
17	type texpr = { exp_loc : loc;
18	mutable exp_typ : Types.descr;
19	exp_descr : texpr';
20	}
21	and texpr' =
22	\| DebugTyper of ttyp
23
24	\| Forget of texpr * ttyp
25	(* CDuce is a Lambda-calculus ... *)
26	\| Var of string
27	\| Apply of texpr * texpr
28	\| Abstraction of abstr
29
30	(* Data constructors *)
31	\| Cst of Types.const
32	\| Pair of texpr * texpr
33	\| RecordLitt of (Types.label, texpr) SortedMap.t
34
35	(* Data destructors *)
36	\| Op of string * texpr list
37	\| Match of texpr * branches
38	\| Map of texpr * branches
39	\| Dot of (texpr * Types.label)
40
41	(* Exception *)
42	\| Try of texpr * branches
43
44	and abstr = {
45	fun_name : string option;
46	fun_iface : (Types.descr * Types.descr) list;
47	fun_body : branches;
48	fun_typ : Types.descr;
49	fun_fv : string list;
50	}
51
52	and let_decl = {
53	let_pat : tpat;
54	let_body : texpr;
55	mutable let_compiled :
56	(Patterns.Compile.dispatcher * (string * int) list) option
57	}
58
59	and branches = {
60	mutable br_typ : Types.descr;
61	br_accept : Types.descr;
62	br_branches: branch list;
63
64	mutable br_compiled : compiled_branches option;
65	}
66	and branch = {
67	mutable br_used : bool;
68	br_pat : tpat;
69	br_body : texpr
70	}
71	and compiled_branches =
72	Patterns.Compile.dispatcher * ((string * int) list * texpr) array
73
74
75	let dispatcher brs =
76	match brs.br_compiled with
77	\| Some d -> d
78	\| None ->
79	let aux b = Patterns.descr b.br_pat, b.br_body in
80	let x = Patterns.Compile.make_branches
81	brs.br_typ
82	(List.map aux brs.br_branches) in
83	brs.br_compiled <- Some x;
84	x
85
86	let dispatcher_let_decl l =
87	match l.let_compiled with
88	\| Some d -> d
89	\| None ->
90	let comp = Patterns.Compile.make_branches
91	(Types.descr (Patterns.accept l.let_pat))
92	[ Patterns.descr l.let_pat, () ] in
93	let x = match comp with
94	\| (disp, [\| l, () \|]) -> (disp,l)
95	\| _ -> assert false
96	in
97	l.let_compiled <- Some x;
98	x