1: # 31 "./lpsrc/flx_prop.ipk"
2: open Flx_util
3: open Flx_ast
4: open Flx_types
5: open Flx_mtypes1
6: open Flx_mtypes2
7: open Flx_print
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_exceptions
15: open Flx_use
16:
17: let add_prop bbdfns p i =
18: let id,parent,sr,entry = Hashtbl.find bbdfns i in
19: match entry with
20: | `BBDCL_function (props,vs,ps,ret,exes) ->
21: let entry = `BBDCL_function (p :: props,vs,ps,ret,exes) in
22: Hashtbl.replace bbdfns i (id,parent,sr,entry);
23:
24: (* because of type classes .. *)
25: | `BBDCL_fun (props,vs,ps,ret,ct,reqs,prec) ->
26: let entry = `BBDCL_fun (p :: props,vs,ps,ret,ct,reqs,prec) in
27: Hashtbl.replace bbdfns i (id,parent,sr,entry);
28:
29: | `BBDCL_procedure (props,vs,ps,exes) ->
30: let entry = `BBDCL_procedure (p :: props,vs,ps,exes) in
31: Hashtbl.replace bbdfns i (id,parent,sr,entry)
32:
33: (* because of type classes .. *)
34: | `BBDCL_proc (props,vs,ps,ct,reqs) ->
35: let entry = `BBDCL_proc (p :: props,vs,ps,ct,reqs) in
36: Hashtbl.replace bbdfns i (id,parent,sr,entry);
37:
38: | `BBDCL_regmatch (props,vs,ps,t,x) ->
39: let entry = `BBDCL_regmatch (p :: props, vs, ps, t, x) in
40: Hashtbl.replace bbdfns i (id,parent,sr,entry)
41:
42: | `BBDCL_reglex (props,vs,ps,le,t,x) ->
43: let entry = `BBDCL_reglex (p :: props, vs, ps, le, t, x) in
44: Hashtbl.replace bbdfns i (id,parent,sr,entry)
45:
46: | `BBDCL_glr (props, vs, t, x) ->
47: let entry = `BBDCL_glr (p :: props, vs, t, x) in
48: Hashtbl.replace bbdfns i (id,parent,sr,entry)
49:
50: | _ -> ()
51:
52: let rem_prop bbdfns p i =
53: let id,parent,sr,entry = Hashtbl.find bbdfns i in
54: match entry with
55: | `BBDCL_function (props,vs,ps,ret,exes) ->
56: let props = List.filter (fun k -> p <> k) props in
57: let entry = `BBDCL_function (props,vs,ps,ret,exes) in
58: Hashtbl.replace bbdfns i (id,parent,sr,entry);
59:
60: (* because of type classes .. *)
61: | `BBDCL_fun (props,vs,ps,ret,ct,reqs,prec) ->
62: let props = List.filter (fun k -> p <> k) props in
63: let entry = `BBDCL_fun (props,vs,ps,ret,ct,reqs,prec) in
64: Hashtbl.replace bbdfns i (id,parent,sr,entry);
65:
66: | `BBDCL_procedure (props,vs,ps,exes) ->
67: let props = List.filter (fun k -> p <> k) props in
68: let entry = `BBDCL_procedure (props,vs,ps,exes) in
69: Hashtbl.replace bbdfns i (id,parent,sr,entry)
70:
71: (* because of type classes .. *)
72: | `BBDCL_proc (props,vs,ps,ct,reqs) ->
73: let props = List.filter (fun k -> p <> k) props in
74: let entry = `BBDCL_proc (props,vs,ps,ct,reqs) in
75: Hashtbl.replace bbdfns i (id,parent,sr,entry);
76:
77: | `BBDCL_regmatch (props,vs,ps,t,x) ->
78: let props = List.filter (fun k -> p <> k) props in
79: let entry = `BBDCL_regmatch (props, vs, ps, t, x) in
80: Hashtbl.replace bbdfns i (id,parent,sr,entry)
81:
82: | `BBDCL_reglex (props,vs,ps,le,t,x) ->
83: let props = List.filter (fun k -> p <> k) props in
84: let entry = `BBDCL_reglex (props, vs, ps, le, t, x) in
85: Hashtbl.replace bbdfns i (id,parent,sr,entry)
86:
87: | `BBDCL_glr (props, vs, t, x) ->
88: let props = List.filter (fun k -> p <> k) props in
89: let entry = `BBDCL_glr (props, vs, t, x) in
90: Hashtbl.replace bbdfns i (id,parent,sr,entry)
91:
92: | _ -> ()
93:
94: let get_vs bbdfns i =
95: let _,_,_,entry = Hashtbl.find bbdfns i in
96: match entry with
97: | `BBDCL_function (props,vs,(ps,traint),ret,exes) -> vs
98: | `BBDCL_procedure (props,vs,(ps,traint), exes) -> vs
99: | `BBDCL_val (vs,t) -> vs
100: | `BBDCL_var (vs,t) -> vs
101: | `BBDCL_ref (vs,t) -> vs
102: | `BBDCL_tmp (vs,t) -> vs
103: | `BBDCL_glr (props,vs,ret, (p,exes)) -> vs
104: | `BBDCL_regmatch (props,vs,(ps,traint),ret,(alpha,states,h,mx)) -> vs
105: | `BBDCL_reglex (props,vs,(ps,traint),le,ret,(alpha,states,h,mx)) -> vs
106: | `BBDCL_class (props,vs) -> vs
107: | `BBDCL_union (vs,ps) -> vs
108: | `BBDCL_struct (vs,ps) -> vs
109: | `BBDCL_cstruct (vs,ps) -> vs
110: | `BBDCL_newtype (vs,t) -> vs
111: | `BBDCL_cclass (vs,ps) -> vs
112: | `BBDCL_const (vs,t,ct,reqs) -> vs
113: | `BBDCL_insert (vs,s,ikind,reqs) -> vs
114: | `BBDCL_fun (props,vs,argtypes,ret,ct,reqs,prec) -> vs
115: | `BBDCL_callback (props,vs,argtypes_cf,argtypes_c,k,ret,reqs,prec) -> vs
116: | `BBDCL_proc (props,vs,argtypes,ct,reqs) -> vs
117: | `BBDCL_abs (vs,tqual,ct,reqs) -> vs
118: | `BBDCL_nonconst_ctor (vs,uidx,udt, ctor_idx, ctor_argt, evs, etraint) -> vs
119: | `BBDCL_typeclass (props,vs) -> vs
120: | `BBDCL_instance (props,vs,con,tc,ts) -> vs
121:
122:
123: