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:
1: # 63 "./lpsrc/flxcc_util.pak"
2: open Flx_cil_cabs
3: open Flx_cil_cil
4: open Flx_ctypes
5: open List
6:
7: let ptname {tname=tname} = tname
8: and ciname {cname=cname} = cname
9: and einame {ename=ename} = ename
10: and viname {vname=vname} = vname
11:
12: let pci ci = match ci with
13: {cname=cname; cstruct=cstruct} ->
14: (if cstruct then "_struct_" else "_union_") ^ cname
15:
16: let pcci ci = match ci with
17: {cname=cname; cstruct=cstruct} ->
18: (if cstruct then "struct " else " union ") ^ cname
19:
20: let pei ei = match ei with
21: {ename=ename} -> "_enum_" ^ ename
22:
23: let pcei ei = match ei with
24: {ename=ename} -> "enum " ^ ename
25:
26: let pcomp pi = match pi with
27: {cname=name} -> name
28:
29:
30: let soi = function
31: | IBool -> "bool"
32: | IChar -> "char"
33: | ISChar -> "tiny"
34: | IUChar -> "utiny"
35: | IInt -> "int"
36: | IUInt -> "uint"
37: | IShort -> "short"
38: | IUShort -> "ushort"
39: | ILong -> "long"
40: | IULong -> "ulong"
41: | ILongLong -> "vlong"
42: | IULongLong -> "uvlong"
43:
44: let sof = function
45: | FFloat -> "float"
46: | FDouble -> "double"
47: | FLongDouble -> "ldouble"
48:
49: | IFloat -> "imaginary"
50: | IDouble -> "dimaginary"
51: | ILongDouble -> "limaginary"
52:
53: | CFloat -> "complex"
54: | CDouble -> "dcomplex"
55: | CLongDouble -> "lcomplex"
56:
57: let cvqual a =
58: let const = ref false
59: and volatile = ref false
60: in
61: List.iter
62: (fun (Attr (s,_)) ->
63: if s = "const" then const := true
64: else if s = "volatile" then volatile := true
65: )
66: a
67: ;
68: if !const && !volatile then "cv"
69: else if !const then "c"
70: else if !volatile then "v"
71: else ""
72:
73: let attrof = function
74: | TVoid a
75: | TInt (_,a)
76: | TFloat (_,a)
77: | TPtr (_,a)
78: | TArray (_,_,a)
79: | TFun (_,_,_,a)
80: | TNamed (_,a)
81: | TComp (_,a)
82: | TEnum (_,a)
83: | TBuiltin_va_list a
84: -> a
85:
86: let c_name = function
87: | GType ({tname=tname},_) -> Some tname
88: | GCompTag (ci,sr) -> Some (pcci ci)
89: | GCompTagDecl (ci,_) -> Some (pcci ci)
90: | GEnumTag (ei,_) -> Some "int"
91: | GEnumTagDecl (ei,_) -> Some "int"
92: | GVarDecl ({vname=vname},_) -> Some vname
93: | GVar ({vname=vname},_,_) -> Some vname
94: | GFun ({svar={vname=vname}},sr) -> Some vname
95: | GAsm _ -> None
96: | GPragma _ -> None
97: | GText _ -> None
98: ;;
99:
100: let achk x =
101: let a = "__anon" in
102: let n = String.length a in
103: String.length x > n &&
104: a = String.sub x 0 n
105:
106:
107: let rec isanont t = match t with
108: | TVoid _
109: | TInt _
110: | TFloat _ -> false
111: | TPtr (t,_) -> isanont t
112: | TArray (t,_,_) -> isanont t
113: | TFun (t,Some ps,_,_) ->
114: fold_left (fun b (_,t,_)-> b || isanont t ) (isanont t) ps
115:
116: | TFun (t,None,_,_) -> isanont t
117: | TNamed ({tname=tname},_) -> achk tname
118: | TComp ({cname=cname},_) -> achk cname
119: | TEnum _ -> false
120: | TBuiltin_va_list _ -> false
121:
122: let isanon = function
123: | GType ({tname=tname},_) -> achk tname
124: | GCompTag ({cname=cname},_) -> achk cname
125: | GCompTagDecl ({cname=cname},_) -> achk cname
126: | GEnumTag ({ename=ename},_) -> achk ename
127: | GEnumTagDecl ({ename=ename},_) -> achk ename
128: | GVarDecl ({vname=vname},_) -> false
129: | GVar ({vname=vname},_,_) -> false
130: | GFun (fd,sr) -> false
131: | GAsm _ -> true
132: | GPragma _ -> true
133: | GText _ -> true
134:
135:
136: (* got to be a named non function type *)
137: let is_cstruct_field t = match t with
138: | TVoid _
139: | TInt _
140: | TFloat _
141: | TNamed _
142: | TPtr _
143: | TArray _
144: | TComp _
145: | TEnum _
146: -> true
147:
148: | TFun _
149: | TBuiltin_va_list _
150: -> false
151:
152: let ispublic s =
153: String.length s < 2 || String.sub s 0 2 <> "__"
154:
155: (* pure name *)
156: let flx_name' = function
157: | GType ({tname=tname},_) -> Some tname
158: | GCompTag (ci,sr) -> Some (pci ci)
159: | GCompTagDecl (ci,_) -> Some (pci ci)
160: | GEnumTag ({ename=ename},_) -> Some ename
161: | GEnumTagDecl ({ename=ename},_) -> Some ename
162: | GVarDecl ({vname=vname},_) -> Some vname
163: | GVar ({vname=vname},_,_) -> Some vname
164: | GFun ({svar={vname=vname}},sr) -> Some vname
165: | GAsm _ -> None
166: | GPragma _ -> None
167: | GText _ -> None
168:
169: