1: # 18 "./lpsrc/flx_strabs.ipk"
2: open Flx_util
3: open Flx_ast
4: open Flx_types
5: open Flx_print
6: open Flx_mtypes1
7: open Flx_mtypes2
8: open Flx_typing
9: open Flx_mbind
10: open Flx_srcref
11: open List
12: open Flx_unify
13: open Flx_treg
14: open Flx_generic
15: open Flx_maps
16: open Flx_exceptions
17:
18: let check_inst bbdfns i ts =
19: let id,_,_,entry = Hashtbl.find bbdfns i in
20: match entry with
21: | `BBDCL_newtype (vs,t) -> tsubst vs ts t
22: | _ -> `BTYP_inst (i,ts)
23:
24: let fixtype bbdfns t =
25: let chk i ts = check_inst bbdfns i ts in
26: let rec aux t = match map_btype aux t with
27: | `BTYP_inst (i,ts) ->
28: let ts = map aux ts in
29: chk i ts
30: | x -> x
31: in aux t
32:
33: let id x = x
34:
35: let isident bbdfns i = match Hashtbl.find bbdfns i with
36: | _,_,_,`BBDCL_fun (_,_,_,_,`Identity,_,_) -> true
37: | _ -> false
38:
39: let fixexpr bbdfns e : tbexpr_t =
40: let rec aux e =
41: match map_tbexpr id aux (fixtype bbdfns) e with
42: | `BEXPR_apply ( (`BEXPR_closure(i,_),_),a),_
43: | `BEXPR_apply_direct (i,_,a),_
44: | `BEXPR_apply_prim (i,_,a),_
45: when isident bbdfns i -> a
46: | x -> x
47: in aux e
48:
49: let fixbexe bbdfns x =
50: map_bexe id (fixexpr bbdfns) (fixtype bbdfns) id id x
51:
52: let fixbexes bbdfns bexes = map (fixbexe bbdfns) bexes
53:
54: let fixps bbdfns (ps,traint) =
55: map
56: (fun {pkind=i;pid=s; pindex=j; ptyp=t} ->
57: {pkind=i; pid=s; pindex=j; ptyp=fixtype bbdfns t}
58: )
59: ps,
60: (
61: match traint with
62: | None -> None
63: | Some t -> Some (fixexpr bbdfns t)
64: )
65:
66: let fixupmember bbdfns mem =
67: let ft t = fixtype bbdfns t in
68: match mem with
69: | `BMemberVal (id,t) -> `BMemberVal (id, ft t)
70: | `BMemberVar (id,t) -> `BMemberVar (id, ft t)
71: | `BMemberFun (id,vs,t) -> `BMemberFun (id, vs, ft t)
72: | `BMemberProc (id,vs,t) -> `BMemberProc (id, vs, ft t)
73: | `BMemberCtor (id,t) -> `BMemberCtor (id, ft t)
74:
75: let strabs syms (bbdfns: fully_bound_symbol_table_t) =
76: let ft t = fixtype bbdfns t in
77: let fts ts = map (fixtype bbdfns) ts in
78: let fe e = fixexpr bbdfns e in
79: let fxs xs = fixbexes bbdfns xs in
80: let fp bps = fixps bbdfns bps in
81: let fkm m = fixupmember bbdfns m in
82: let fkms ms = map (fixupmember bbdfns) ms in
83:
84: let nutab = Hashtbl.create 97 in
85: Hashtbl.iter
86: (fun i (id,parent,sr,entry) ->
87: let h x = Hashtbl.add nutab i (id,parent,sr,x) in
88: match entry with
89: | `BBDCL_function ( props, bvs, bps, ret, bexes) ->
90: h (`BBDCL_function ( props, bvs, fp bps, ft ret, fxs bexes) )
91:
92: | `BBDCL_procedure ( props, bvs, bps, bexes) ->
93: h (`BBDCL_procedure ( props, bvs, fp bps, fxs bexes) )
94:
95: | `BBDCL_val ( bvs, t) ->
96: h (`BBDCL_val ( bvs, ft t) )
97:
98: | `BBDCL_var ( bvs, t) ->
99: h (`BBDCL_var ( bvs, ft t) )
100:
101: | `BBDCL_ref ( bvs, t) ->
102: h (`BBDCL_ref ( bvs, ft t) )
103:
104: | `BBDCL_tmp ( bvs, t) ->
105: h (`BBDCL_tmp ( bvs, ft t) )
106:
107: | `BBDCL_glr ( props, bvs, t, (bprod, bexes)) ->
108: let bexes = fxs bexes in
109: h (`BBDCL_glr ( props, bvs, ft t, (bprod, bexes)) )
110:
111: | `BBDCL_regmatch ( props, bvs, bps , t, regular_args) ->
112: let alpha,cnt, sem, tr = regular_args in
113: let nusem = Hashtbl.create 97 in
114: Hashtbl.iter
115: (fun k e -> Hashtbl.add nusem k (fe e))
116: sem
117: ;
118: let regular_args = alpha,cnt,nusem,tr in
119: h (`BBDCL_regmatch ( props, bvs, fp bps, ft t, regular_args) )
120:
121: | `BBDCL_reglex ( props, bvs, bps, j, t, regular_args) ->
122: let alpha,cnt, sem, tr = regular_args in
123: let nusem = Hashtbl.create 97 in
124: Hashtbl.iter
125: (fun k e -> Hashtbl.add nusem k (fe e))
126: sem
127: ;
128: let regular_args = alpha,cnt,nusem,tr in
129: h (`BBDCL_reglex ( props, bvs, fp bps, j, ft t, regular_args) )
130:
131: | `BBDCL_newtype ( bvs, t) -> ()
132:
133: | `BBDCL_abs ( bvs, btqs, c, breqs) ->
134: h (`BBDCL_abs ( bvs, btqs, c, breqs) )
135:
136: | `BBDCL_const ( bvs, t, c, breqs) ->
137: h (`BBDCL_const ( bvs, ft t, c, breqs) )
138:
139: | `BBDCL_fun ( props, bvs, ts, t, c, breqs, prec) ->
140: if c = `Identity then () else
141: h (`BBDCL_fun ( props, bvs, fts ts, ft t, c, breqs, prec) )
142:
143: | `BBDCL_callback ( props, bvs, ts1, ts2, j, t, breqs, prec) ->
144: h (`BBDCL_callback ( props, bvs, fts ts1, fts ts2, j, ft t, breqs, prec) )
145:
146: | `BBDCL_proc ( props, bvs, ts, c, breqs) ->
147: h (`BBDCL_proc ( props, bvs, fts ts, c, breqs) )
148:
149: | `BBDCL_insert ( bvs, c, ikind, breqs) ->
150: h (`BBDCL_insert ( bvs, c, ikind, breqs) )
151:
152: | `BBDCL_union ( bvs, cts) ->
153: let cts = map (fun (s,j,t) -> s,j,ft t) cts in
154: h (`BBDCL_union ( bvs, cts) )
155:
156: | `BBDCL_struct ( bvs, cts) ->
157: let cts = map (fun (s,t) -> s,ft t) cts in
158: h (`BBDCL_struct ( bvs, cts) )
159:
160: | `BBDCL_cstruct ( bvs, cts) ->
161: let cts = map (fun (s,t) -> s,ft t) cts in
162: h (`BBDCL_cstruct ( bvs, cts) )
163:
164: | `BBDCL_cclass ( bvs, bclass_members) ->
165: h (`BBDCL_cclass ( bvs, fkms bclass_members) )
166:
167: | `BBDCL_class ( props, bvs) ->
168: h (`BBDCL_class ( props, bvs) )
169:
170: | `BBDCL_typeclass ( props, bvs) ->
171: h (`BBDCL_typeclass ( props, bvs) )
172:
173: | `BBDCL_instance ( props, bvs, t, j, ts) ->
174: h (`BBDCL_instance ( props, bvs, ft t, j, fts ts) )
175:
176: | `BBDCL_nonconst_ctor ( bvs, j, t1, k,t2, evs, etraint) ->
177: h (`BBDCL_nonconst_ctor ( bvs, j, ft t1, k, ft t2, evs, ft etraint) )
178: )
179: bbdfns
180: ;
181: nutab