1: # 183 "./lpsrc/flx_ctypes.ipk"
2: open Flx_ctypes
3: exception Unknown_prec of string
4:
5: let iter = List.iter
6: let map = List.map
7: let find = Hashtbl.find
8: let strcat = String.concat
9: let add = Hashtbl.add
10:
11: let precedence = [
12: "atom";
13: "primary";
14: "postfix";
15: "unary";
16: "cast";
17: "pm";
18: "mult";
19: "add";
20: "shift";
21: "rel";
22: "eq";
23: "band";
24: "bxor";
25: "bor";
26: "and";
27: "xor";
28: "or";
29: "cond";
30: "assign";
31: "comma";
32: "expr"
33: ]
34:
35: let postfix_cops = [
36: "++","postfix";
37: "--","postfix";
38: ]
39:
40: let prefix_cops = [
41: "~","primary";
42: "+","unary";
43: "-","unary";
44: "!","unary";
45: "&","unary";
46: "*","unary";
47: "++","unary";
48: "--","unary";
49: "sizeof","unary";
50: ]
51:
52: let infix_cops = [
53: "+","add";
54: "-","add";
55: "*","mult";
56: "/","mult";
57: "%","mult";
58: "<<","shift";
59: ">>","shift";
60:
61: "&","band";
62: "|","bor";
63: "^","bxor";
64:
65: "&&","and";
66: "||","or";
67:
68: "+=","assign";
69: "-=","assign";
70: "*=","assign";
71: "/=","assign";
72: "%=","assign";
73: "<<=","assign";
74: ">>=","assign";
75: "&=","assign";
76: "|=","assign";
77: "^=","assign";
78:
79: "<","rel";
80: ">","rel";
81: ">=","rel";
82: "<=","rel";
83: "==","eq";
84: "!=","eq";
85:
86: ".","postfix";
87: "->","postfix";
88: ".*","pm";
89: "->*","pm";
90: ",","comma";
91: ]
92: ;;
93:
94: let remaps = [
95: "$1++",("$1:postfix ++ ","postfix");
96: "$1--",("$1:postfix -- ","postfix");
97:
98: "~$1",("~$1:unary","unary");
99: "+$1",("+ $1:unary","unary");
100: "-$1",("- $1:unary","unary");
101: "!$1",("!$1:unary","unary");
102: "&$1",("& $1:unary","unary");
103: "*$1",("*$1:unary","unary");
104: "++$1",("++ $1:unary","unary");
105: "--$1",("-- $1:unary","unary");
106: "$1+$2",("$1:add + $2:mult","add");
107: "$1-$2",("$1:add - $2:mult","add");
108: "$1*$2",("$1:mult * $2:pm","mult");
109: "$1/$2",("$1:mult / $2:pm","mult");
110: "$1%$2",("$1:mult % $2:pm","mult");
111:
112: "$1<<$2",("$1:shift << $2:band","shift");
113: "$1>>$2",("$1:shift >> $2:band","shift");
114: "$1&$2",("$1:band & $2:bor","band");
115: "$1|$2",("$1:bor | $2:bxor","bor");
116: "$1^$2",("$1:bxor ^ $2:and","bxor");
117: "$1&&$2",("$1:and && $2:or","and");
118: "$1||$2",("$1:or || $2:cond","or");
119:
120: "$1+=$2",("$1:cond += $2:assign","assign");
121: "$1-=$2",("$1:cond -= $2:assign","assign");
122: "$1*=$2",("$1:cond *= $2:assign","assign");
123: "$1/=$2",("$1:cond /= $2:assign","assign");
124: "$1%=$2",("$1:cond %= $2:assign","assign");
125: "$1<<=$2",("$1:cond <<= $2:assign","assign");
126: "$1>>=$2",("$1:cond >>= $2:assign","assign");
127: "$1&=$2",("$1:cond &= $2:assign","assign");
128: "$1|=$2",("$1:cond |= $2:assign","assign");
129: "$1^=$2",("$1:cond ^= $2:assign","assign");
130:
131: "$1<$2",("$1:rel < $2:shift","rel");
132: "$1>$2",("$1:rel > $2:shift","rel");
133: "$1>=$2",("$1:rel >= $2:shift","rel");
134: "$1<=$2",("$1:rel <= $2:shift","rel");
135: "$1==$2",("$1:eq == $2:rel","eq");
136: "$1!=$2",("$1:eq != $2:rel","eq");
137:
138: "$1($2)",("$1:postfix($2:assign)","postfix");
139: "$1[$2]",("$1:postfix[$2:expr]","postfix");
140: "$1->$2",("$1:postfix->$2:atom","postfix");
141: "$1.*$2",("$1:pm.*$2:cast","pm");
142: "$1->*$2",("$1:pm->*$2:cast","pm");
143: "$1:comma,$2:comma",("$1,$2","comma");
144: ]
145: ;;
146:
147: let prec = Hashtbl.create 17
148: let infix = Hashtbl.create 31
149: let prefix = Hashtbl.create 17
150: let postfix = Hashtbl.create 17
151: let prec_remap = Hashtbl.create 31
152: let seq = ref 0
153: ;;
154: let find_prec p =
155: try Hashtbl.find prec p
156: with Not_found ->
157: raise (Unknown_prec p)
158: ;;
159:
160: iter (fun x -> add prec x !seq; incr seq; incr seq) precedence;
161: iter (fun (n,p) -> add infix n (find_prec p)) infix_cops;
162: iter (fun (n,p) -> add prefix n (find_prec p)) prefix_cops;
163: iter (fun (n,p) -> add postfix n (find_prec p)) postfix_cops;
164: iter (fun (k,v) -> add prec_remap k v) remaps
165: ;;
166:
167: let pr cop =
168: match cop with
169: | `Ce_atom _ -> 0
170: | `Ce_postfix (s,_) -> find postfix s
171: | `Ce_prefix (s,_) -> find prefix s
172: | `Ce_infix (s,_,_) -> find infix s
173:
174: | `Ce_call _
175: | `Ce_array _ -> find_prec "postfix"
176:
177: | `Ce_new _ -> find_prec "unary"
178: | `Ce_cast _ -> find_prec "cast"
179: | `Ce_cond _ -> find_prec "cond"
180: | `Ce_expr (p,_) -> find_prec p
181:
182: let commaprec = find_prec "comma"
183: let rec comma es = "(" ^ strcat ", " (map (cep commaprec) es) ^ ")"
184: and comma_opt = function | [] -> "" | ps -> comma ps
185:
186: (* we need brackets if the binding looseness is higher
187: than or equal to the context.
188:
189: But due associativity, (x+y)+z = x+y+z, and we make that
190: happen by making the context of the LHS subexpression
191: slightly higher.
192: *)
193: and cep cp e =
194: let ep = pr e in
195: let rce e = cep ep e and lce e = cep (ep+1) e in
196: let need_brackets = ep > cp in
197: (if need_brackets then "(" else "")
198: ^
199: begin match e with
200: | `Ce_atom s -> s
201: | `Ce_postfix (s,e) -> rce e ^ s
202: | `Ce_prefix (s,e) -> s ^ rce e
203: | `Ce_infix (s,e1,e2) -> lce e1 ^ s ^ rce e2
204:
205: | `Ce_call (f,es) -> rce f ^comma es
206: | `Ce_array (f,e) -> rce f ^ "["^lce e^"]"
207: | `Ce_new (ps,cls,args) ->
208: "new" ^ comma_opt ps ^ " " ^ cls ^ " " ^ comma_opt args
209: | `Ce_cast (cast,e) -> "("^cast^")" ^ rce e
210: | `Ce_cond (e,e1,e2) -> lce e ^ "?" ^ rce e1 ^ ":" ^ rce e2
211: | `Ce_expr (_, s) -> s
212: end
213: ^
214: (if need_brackets then ")" else "")
215:
216: let ce_atom s = `Ce_atom s
217: let ce_postfix o e = `Ce_postfix (o,e)
218: let ce_prefix o e = `Ce_prefix (o,e)
219: let ce_infix o a b = `Ce_infix (o,a,b)
220: let ce_call a b = `Ce_call (a,b)
221: let ce_array a b = `Ce_array (a,b)
222: let ce_new p c a = `Ce_new (p,c,a)
223: let ce_cast s e = `Ce_cast (s,e)
224: let ce_cond c a b = `Ce_cond (c,a,b)
225: let ce_expr p s = `Ce_expr (p,s)
226: let ce_top s = ce_expr "expr" s
227: let ce_dot e s = ce_infix "." e (ce_atom s)
228: let ce_arrow e s = ce_infix "->" e (ce_atom s)
229:
230: let string_of_cexpr e = cep 1000 e
231: let sc p e = cep (find_prec p) e
232: let ce p s = ce_expr p s
233:
234: let genprec ct prec =
235: try Hashtbl.find prec_remap ct
236: with Not_found -> ct,prec
237: