5.12. Compile time exceptions
Start ocaml section to src/flx_exceptions.ml[1
/1
]
1: # 5480 "./lpsrc/flx_types.ipk"
2:
3: # 5480 "./lpsrc/flx_types.ipk"
4: open Flx_ast
5: # 5480 "./lpsrc/flx_types.ipk"
6: open Flx_types
7: # 5480 "./lpsrc/flx_types.ipk"
8: exception RDP_match_fail of range_srcref * range_srcref * string
9: # 5480 "./lpsrc/flx_types.ipk"
10: exception RDP_alternatives_exhausted of range_srcref * string
11: # 5480 "./lpsrc/flx_types.ipk"
12: exception SyntaxError of string
13: # 5480 "./lpsrc/flx_types.ipk"
14: exception ParseError of string
15: # 5480 "./lpsrc/flx_types.ipk"
16: exception LexError of string
17: # 5480 "./lpsrc/flx_types.ipk"
18: exception TokenError of string
19: # 5480 "./lpsrc/flx_types.ipk"
20: exception ClientErrorn of range_srcref list * string
21: # 5480 "./lpsrc/flx_types.ipk"
22: exception ClientError of range_srcref * string
23: # 5480 "./lpsrc/flx_types.ipk"
24: exception ClientError2 of range_srcref * range_srcref * string
25: # 5480 "./lpsrc/flx_types.ipk"
26: exception SystemError of range_srcref * string
27: # 5480 "./lpsrc/flx_types.ipk"
28: exception Exit of int
29: # 5480 "./lpsrc/flx_types.ipk"
30: exception Bad_recursion
31: # 5480 "./lpsrc/flx_types.ipk"
32: exception Expr_recursion of expr_t
33: # 5480 "./lpsrc/flx_types.ipk"
34: exception Free_fixpoint of btypecode_t
35: # 5480 "./lpsrc/flx_types.ipk"
36: exception Unresolved_return of range_srcref * string
37: # 5480 "./lpsrc/flx_types.ipk"
38:
39: let clierrn srs s = raise (ClientErrorn (srs,s))
40: let clierr2 sr sr2 s = raise (ClientError2 (sr,sr2,s))
41: let clierr sr s = raise (ClientError (sr,s))
42: let syserr sr s = raise (SystemError (sr,s))
43: let catch s f = try f() with _ -> failwith s
44: let rdp_match_fail sr1 sr2 s = raise (RDP_match_fail (sr1,sr2,s))
45: let rdp_alternatives_exhausted sr s = raise (RDP_alternatives_exhausted (sr,s))
46:
Start ocaml section to src/flx_exceptions.mli[1
/1
]
1: # 5491 "./lpsrc/flx_types.ipk"
2:
3: # 5491 "./lpsrc/flx_types.ipk"
4: open Flx_ast
5: # 5491 "./lpsrc/flx_types.ipk"
6: open Flx_types
7: # 5491 "./lpsrc/flx_types.ipk"
8: exception RDP_match_fail of range_srcref * range_srcref * string
9: # 5491 "./lpsrc/flx_types.ipk"
10: exception RDP_alternatives_exhausted of range_srcref * string
11: # 5491 "./lpsrc/flx_types.ipk"
12: exception SyntaxError of string
13: # 5491 "./lpsrc/flx_types.ipk"
14: exception ParseError of string
15: # 5491 "./lpsrc/flx_types.ipk"
16: exception LexError of string
17: # 5491 "./lpsrc/flx_types.ipk"
18: exception TokenError of string
19: # 5491 "./lpsrc/flx_types.ipk"
20: exception ClientErrorn of range_srcref list * string
21: # 5491 "./lpsrc/flx_types.ipk"
22: exception ClientError of range_srcref * string
23: # 5491 "./lpsrc/flx_types.ipk"
24: exception ClientError2 of range_srcref * range_srcref * string
25: # 5491 "./lpsrc/flx_types.ipk"
26: exception SystemError of range_srcref * string
27: # 5491 "./lpsrc/flx_types.ipk"
28: exception Exit of int
29: # 5491 "./lpsrc/flx_types.ipk"
30: exception Bad_recursion
31: # 5491 "./lpsrc/flx_types.ipk"
32: exception Expr_recursion of expr_t
33: # 5491 "./lpsrc/flx_types.ipk"
34: exception Free_fixpoint of btypecode_t
35: # 5491 "./lpsrc/flx_types.ipk"
36: exception Unresolved_return of range_srcref * string
37: # 5491 "./lpsrc/flx_types.ipk"
38:
39: val clierrn: range_srcref list -> string -> 'a
40: val clierr: range_srcref -> string -> 'a
41: val clierr2: range_srcref -> range_srcref -> string -> 'a
42: val syserr: range_srcref -> string -> 'a
43: val catch: string -> (unit -> 'a) -> 'a
44: val rdp_match_fail: range_srcref -> range_srcref -> string -> 'a
45: val rdp_alternatives_exhausted: range_srcref -> string -> 'a
46:
Start ocaml section to src/flx_typing.mli[1
/1
]
1: # 5502 "./lpsrc/flx_types.ipk"
2: open Flx_ast
3: open Flx_types
4: exception UnificationError of btypecode_t * btypecode_t
5: val flx_bool : typecode_t
6: val flx_bbool : btypecode_t
7:
8: val is_unitsum: btypecode_t -> bool
9: val int_of_unitsum : btypecode_t -> int
10: val all_units0 : b0typecode_t list -> bool
11: val all_units : btypecode_t list -> bool
12: val all_voids : btypecode_t list -> bool
13:
14: val cmp_literal: literal_t -> literal_t -> bool
15: val cmp_tbexpr: tbexpr_t -> tbexpr_t -> bool
16:
17: val type_of_argtypes :
18: typecode_t list ->
19: typecode_t
20:
21: val funparamtype : 'a * 'b * 't -> 't
22:
23: val typeoflist:
24: btypecode_t list ->
25: btypecode_t
26:
27: val typeofbps_traint: bparams_t -> btypecode_t list
28: val typeofbps: bparameter_t list-> btypecode_t list
29:
30: val lift:
31: btypecode_t -> btypecode_t
32:
33: val lower:
34: btypecode_t -> btypecode_t
35:
36: val qualified_name_of_expr:
37: expr_t -> qualified_name_t
38:
39: module FuntypeSet : Set.S with type elt = typecode_t
40:
41: module FunInstSet : Set.S with type elt = bid_t * btypecode_t list
42:
43: val sye: entry_kind_t -> int
44:
Start ocaml section to src/flx_typing.ml[1
/1
]
1: # 5547 "./lpsrc/flx_types.ipk"
2: open Flx_ast
3: open Flx_types
4: open Flx_srcref
5: open List
6:
7: let sye {base_sym=i} = i
8:
9: let all_voids ls =
10: fold_left
11: (fun acc t -> acc && (t = `BTYP_void))
12: true ls
13:
14: let all_units0 ls =
15: fold_left
16: (fun acc t -> acc && (t = `BTYP_tuple []))
17: true ls
18:
19: let all_units ls = all_units0 ls
20:
21: let is_unitsum (t:btypecode_t) = match t with
22: | `BTYP_unitsum _ -> true
23: | `BTYP_sum ls -> all_units ls
24: | _ -> false
25:
26:
27: let int_of_unitsum t = match t with
28: | `BTYP_void -> 0
29: | `BTYP_tuple [] -> 1
30: | `BTYP_unitsum k -> k
31: | `BTYP_sum [] -> 0
32: | `BTYP_sum ls ->
33: if all_units ls then length ls
34: else raise Not_found
35:
36: | _ -> raise Not_found
37:
38: exception UnificationError of btypecode_t * btypecode_t
39:
40: (* unbound type *)
41: let type_of_argtypes ls = match ls with
42: | [x] -> x
43: | _ -> `TYP_tuple ls
44:
45: let funparamtype (_,_,t) = t
46:
47: module FuntypeSet = Set.Make(
48: struct type t=typecode_t let compare = compare end
49: )
50:
51: module FunInstSet = Set.Make(
52: struct
53: type t= bid_t * btypecode_t list
54: let compare = compare
55: end
56: )
57:
58:
59: let typeofbps bps =
60: map
61: (fun {ptyp=t; pkind=k} ->
62: match k with
63: | `PRef -> `BTYP_pointer t
64: | `PFun -> `BTYP_function (`BTYP_tuple [],t)
65: | _ ->t
66: )
67: bps
68:
69: let typeofbps_traint (bps,_) = typeofbps bps
70:
71: (* bound type! *)
72: let typeoflist typlist = match typlist with
73: | [] -> `BTYP_tuple []
74: | [t] -> t
75: | h :: t ->
76: try
77: iter
78: (fun t -> if t <> h then raise Not_found)
79: t;
80: `BTYP_array (h,`BTYP_unitsum (length typlist))
81: with Not_found ->
82: `BTYP_tuple typlist
83:
84: let lift t = t
85: let lower t = t (* CHANGE THIS WHEN ABSTRACT TYPES IMPLEMENTED *)
86:
87: let flx_bool = `TYP_unitsum 2
88: let flx_bbool = `BTYP_unitsum 2
89:
90: let qualified_name_of_expr e =
91: match e with
92: | #qualified_name_t as x -> x
93: | _ ->
94: failwith
95: (
96: "Qualified name expected in\n" ^
97: short_string_of_src (src_of_expr e)
98: )
99:
100: (* Note floats are equal iff they're textually identical,
101: we don't make any assumptions about the target machine FP model.
102: OTOH, int comparisons are infinite precision, for the same
103: int kind, even if the underlying machine model is not
104: *)
105:
106: let cmp_literal (l:literal_t) (l':literal_t) = match l, l' with
107: | `AST_int (a,b), `AST_int (a',b') -> a = a' && Big_int.eq_big_int b b'
108: | `AST_float (a,b), `AST_float (a',b') -> a = a' && b = b'
109: | `AST_string s, `AST_string s' -> s = s'
110: | `AST_cstring s, `AST_cstring s' -> s = s'
111: | `AST_wstring s, `AST_wstring s' -> s = s'
112: | `AST_ustring s, `AST_ustring s' -> s = s'
113: | _ -> false
114:
115: (* Note that we don't bother comparing the type subterm:
116: this had better be equal for equal expressions: the value
117: is merely the cached result of a synthetic context
118: independent type calculation
119: *)
120:
121: let rec cmp_tbexpr (a,_) (b,_) =
122: let ecmp = cmp_tbexpr in match a,b with
123: | `BEXPR_parse (e,ii), `BEXPR_parse (e',ii') ->
124: ecmp e e' && ii = ii'
125:
126: | `BEXPR_coerce (e,t),`BEXPR_coerce (e',t') ->
127: (* not really right .. *)
128: ecmp e e'
129:
130: | `BEXPR_record ts,`BEXPR_record ts' ->
131: length ts = length ts' &&
132: let rcmp (s,t) (s',t') = compare s s' in
133: let ts = sort rcmp ts in
134: let ts' = sort rcmp ts' in
135: map fst ts = map fst ts' &&
136: fold_left2 (fun r a b -> r && a = b) true (map snd ts) (map snd ts')
137:
138: | `BEXPR_variant (s,e),`BEXPR_variant (s',e') ->
139: s = s' && ecmp e e'
140:
141: | `BEXPR_deref e,`BEXPR_deref e' -> ecmp e e'
142:
143: | `BEXPR_name (i,ts),`BEXPR_name (i',ts')
144: | `BEXPR_ref (i,ts),`BEXPR_ref (i',ts')
145: | `BEXPR_closure (i,ts),`BEXPR_closure (i',ts') ->
146: i = i' &&
147: fold_left2 (fun r a b -> r && a = b) true ts ts'
148:
149: (* Note any two distinct new expressions are distinct ...
150: not sure what is really needed here
151: *)
152: | `BEXPR_new e1,`BEXPR_new e2 -> false
153:
154: | `BEXPR_method_closure (e,i,ts),`BEXPR_method_closure (e',i',ts') ->
155: ecmp e e' &&
156: i = i' &&
157: fold_left2 (fun r a b -> r && a = b) true ts ts'
158:
159: | `BEXPR_literal a,`BEXPR_literal a' -> cmp_literal a a'
160:
161: | `BEXPR_apply (a,b),`BEXPR_apply (a',b') -> ecmp a a' && ecmp b b'
162:
163: | `BEXPR_apply_prim (i,ts,b),`BEXPR_apply_prim (i',ts',b')
164: | `BEXPR_apply_direct (i,ts,b),`BEXPR_apply_direct (i',ts',b')
165: | `BEXPR_apply_struct (i,ts,b),`BEXPR_apply_struct (i',ts',b')
166: | `BEXPR_apply_stack (i,ts,b),`BEXPR_apply_stack (i',ts',b') ->
167: i = i' &&
168: fold_left2 (fun r a b -> r && a = b) true ts ts' &&
169: ecmp b b'
170:
171: | `BEXPR_apply_method_direct (e,i,ts,b),`BEXPR_apply_method_direct (e',i',ts',b') ->
172: ecmp e e' &&
173: i = i' &&
174: fold_left2 (fun r a b -> r && a = b) true ts ts' &&
175: ecmp b b'
176:
177: | `BEXPR_apply_method_stack (e,i,ts,b),`BEXPR_apply_method_stack (e',i',ts',b') ->
178: ecmp e e' &&
179: i = i' &&
180: fold_left2 (fun r a b -> r && a = b) true ts ts' &&
181: ecmp b b'
182:
183: | `BEXPR_tuple ls,`BEXPR_tuple ls' ->
184: fold_left2 (fun r a b -> r && ecmp a b) true ls ls'
185:
186: | `BEXPR_case_arg (i,e),`BEXPR_case_arg (i',e')
187:
188: | `BEXPR_match_case (i,e),`BEXPR_match_case (i',e')
189: | `BEXPR_get_n (i,e),`BEXPR_get_n (i',e') ->
190: i = i' && ecmp e e'
191:
192: (* this is probably wrong: says x.y = x'.y' iff x = x && y = y',
193: however, x.y should unify with a simple value .. oh well..
194: hmm .. this should REALLY be a pointer to member, that is,
195: an actual projection function
196: *)
197: | `BEXPR_get_named (i,e),`BEXPR_get_named (i',e') ->
198: i = i' && ecmp e e'
199:
200: | `BEXPR_case_index e,`BEXPR_case_index e' -> ecmp e e'
201:
202: | `BEXPR_case (i,t),`BEXPR_case (i',t') -> i = i' && t = t'
203: | `BEXPR_expr (s,t),`BEXPR_expr (s',t') -> s = s' && t = t'
204: | `BEXPR_range_check (e1,e2,e3), `BEXPR_range_check (e1',e2',e3') ->
205: ecmp e1 e1' && ecmp e2 e2' && ecmp e3 e3'
206:
207: | _ -> false
208:
209:
Start ocaml section to src/flx_typing2.mli[1
/1
]
1: # 5757 "./lpsrc/flx_types.ipk"
2: open Flx_ast
3: val typecode_of_expr:
4: expr_t -> typecode_t
5:
6: val typeof_list:
7: typecode_t list -> typecode_t
8:
9: val paramtype:
10: (param_kind_t * string * typecode_t) list -> typecode_t
11:
12:
Start ocaml section to src/flx_typing2.ml[1
/1
]
1: # 5770 "./lpsrc/flx_types.ipk"
2: open Flx_ast
3: open Flx_types
4: open Flx_print
5: open Flx_srcref
6: open Flx_exceptions
7: open List
8:
9: let typeof_list = function
10: | [x] -> x
11: | x -> `TYP_tuple x
12:
13: let paramtype params =
14: let typlist params =
15: map
16: (fun (k,_,t) ->
17: match k with
18: | `PRef -> `TYP_pointer t
19: | `PFun -> `TYP_function (`TYP_tuple [],t)
20: | _ -> t
21: )
22: params
23: in
24: typeof_list (typlist params)
25:
26: let all_tunits ts =
27: try
28: iter
29: (fun t ->
30: if t <> `TYP_tuple []
31: then raise Not_found
32: )
33: ts;
34: true
35: with Not_found -> false
36:
37: let rec typecode_of_expr (e:expr_t) :typecode_t =
38: let te e = typecode_of_expr e in
39: match e with
40: | `AST_case (sr,e1,ls,e2) -> `TYP_case (te e1, ls, te e2)
41: | `AST_name (_,"TYPE",[]) -> `TYP_type
42: | `AST_name (sr,"_",[]) -> `AST_patany sr
43: | `AST_ellipsis _ -> `TYP_ellipsis
44: | #suffixed_name_t as x -> (x:>typecode_t)
45: | `AST_tuple (sr,ls) ->
46: `TYP_type_tuple (map te ls)
47: | `AST_record_type (sr,es) -> `TYP_record es
48: | `AST_variant_type (sr,es) -> `TYP_variant es
49:
50: | `AST_product (_,ts) -> `TYP_tuple (map te ts)
51: | `AST_setintersection (_,ts) -> `TYP_setintersection (map te ts)
52: | `AST_setunion (_,ts) -> `TYP_setunion (map te ts)
53: | `AST_arrow (_,(a,b)) -> `TYP_function (te a, te b)
54: | `AST_longarrow (_,(a,b)) -> `TYP_cfunction (te a, te b)
55: | `AST_superscript (_,(a,b)) -> `TYP_array (te a, te b)
56: | `AST_lvalue (sr,e) -> `TYP_lvalue (te e)
57: | `AST_ref (sr,e) -> `TYP_pointer (te e)
58: | `AST_sum (_,ts) ->
59: let ts = map te ts in
60: if all_tunits ts then
61: `TYP_unitsum (length ts)
62: else
63: `TYP_sum ts
64:
65: | `AST_lift (sr,e) -> `TYP_lift (te e)
66:
67: | `AST_orlist (sr,ts) ->
68: begin match ts with
69: | [] -> assert false
70: | [x] -> assert false
71: | h :: t ->
72: let llor = `AST_name (sr,"lor",[]) in
73: fold_left (fun sum t -> `TYP_apply (llor,`TYP_type_tuple[sum; te t])) (te h) t
74: end
75:
76: | `AST_andlist (sr,ts) ->
77: begin match ts with
78: | [] -> assert false
79: | [x] -> assert false
80: | h :: t ->
81: let lland = `AST_name (sr,"land",[]) in
82: fold_left (fun sum t -> `TYP_apply (lland,`TYP_type_tuple [sum; te t])) (te h) t
83: end
84:
85: | `AST_typeof (_,e) -> `TYP_typeof e
86: | `AST_as (sr,(t,x)) -> `TYP_as (te t,x)
87:
88: | `AST_literal (sr,`AST_int (enc,v)) ->
89: if enc <> "int"
90: then
91: clierr sr
92: (
93: "Only plain integer can be used as a type, code= '" ^
94: enc ^
95: "'"
96: )
97: else
98: let v = ref
99: begin try Big_int.int_of_big_int v
100: with _ -> clierr sr "Integer used as type out of range"
101: end
102: in
103: if !v <0 then clierr sr "Negative int not allowed as type"
104: else if !v = 0 then ((`AST_void sr) :> typecode_t)
105: else if !v = 1 then `TYP_tuple[]
106: else `TYP_unitsum !v
107:
108: (* NOTE SPECIAL NAME HANDLING HACKS!! *)
109: | `AST_apply(sr,(e1,e2)) ->
110: begin match e1 with
111: | `AST_name (_,name,[]) ->
112: let name' = name ^ " " (* 10 chars *) in
113: if name = "typeof" then `TYP_typeof e2
114: else let arg = typecode_of_expr e2 in
115: if name = "_isin" then
116: begin
117: match arg with
118: | `TYP_type_tuple [memt; sett] ->
119: `TYP_isin (memt, sett)
120: | _ ->
121: (* this can be fixed by taking projections but I can't be bothered atm *)
122: failwith
123: "Implementation limitation, 'isin' operator requires two explicit arguments"
124: end
125: else if name = "typesetof" then
126: begin
127: match arg with
128: | `TYP_type_tuple ls -> `TYP_typeset ls
129: | x -> `TYP_typeset [x]
130: end
131: else if name = "compl" then `TYP_dual arg
132: else if String.sub name' 0 5 = "proj_"
133: then
134: begin
135: let acc = ref 0 in
136: for i = 5 to String.length name - 1 do
137: if name.[i] <= '9' && name.[i] >='0'
138: then acc := 10 * !acc + Char.code (name.[i]) - Char.code '0'
139: else
140: clierr sr
141: (
142: "Digits expected in name '" ^ name ^ "' in\n" ^
143: short_string_of_src sr
144: )
145: done;
146: `TYP_proj (!acc, arg)
147: end
148:
149: else if String.sub name' 0 9 = "case_arg_"
150: then
151: begin
152: let acc = ref 0 in
153: for i = 9 to String.length name - 1 do
154: if name.[i] <= '9' && name.[i] >='0'
155: then acc := 10 * !acc + Char.code (name.[i]) - Char.code '0'
156: else
157: clierr sr
158: (
159: "Digits expected in name '" ^ name ^ "' in\n" ^
160: short_string_of_src sr
161: )
162: done;
163: `TYP_case_arg (!acc, arg)
164: end
165: else
166: `TYP_apply (typecode_of_expr e1,arg)
167:
168: | _ ->
169: `TYP_apply (typecode_of_expr e1,typecode_of_expr e2)
170: end
171:
172: | `AST_lambda (sr,(vs,paramss,ret,body)) ->
173: begin match paramss with
174: | [params,traint] ->
175: (* constraint is ignored for now!! *)
176: begin match body with
177: | [`AST_fun_return (_,e)] ->
178: begin
179: try
180: let t = typecode_of_expr e in
181: match paramss,ret with
182: (* special case, allows {t} to mean 1 -> t *)
183: | [[],None],`TYP_none ->
184: `TYP_function (`TYP_tuple [],t)
185: | _ ->
186: let params = map (fun (x,y,z)-> y,z) params in
187: `TYP_typefun
188: (
189: params,
190: ret,
191: t
192: )
193: with _ ->
194: clierr sr
195: "Type lambda must return type expression"
196: end
197:
198: | _ ->
199: clierr sr
200: "Type lambda must just be 'return type_expr'"
201: end
202: | _ ->
203: clierr sr
204: "Type lambda only allowed one argument (arity=1)"
205: end
206:
207: | `AST_type_match (sr,(e,ps)) ->
208: `TYP_type_match (e,ps)
209:
210: | `AST_noexpand (sr,e) -> te e
211:
212: | `AST_patvar _ as e -> e
213: | `AST_patany _ as e -> e
214: | #expr_t ->
215: let sr = src_of_expr e in
216: clierr sr ("Type expression expected, got " ^ string_of_expr e)
217: