1: # 41 "./lpsrc/flx_name.ipk"
2: open Flx_types
3: open Flx_mtypes2
4: open Flx_unify
5: open Flx_print
6: open Flx_util
7: open Flx_exceptions
8: open List
9:
10: (* these words are either keywords or peculiar to the
11: compiler code generator, so we have to avoid a clash.
12: This list has been constructed by trial and error ..
13:
14: note the RHS value is irrelevant, it just has to be different
15: to the LHS value ..
16: *)
17:
18: let fixups = [
19: (* C++ keywords *)
20: "true","_true";
21: "false","_false";
22:
23: (* special names in thread frame *)
24: "argc","_argc";
25: "argv","_argv";
26: "flx_stdin","_flx_stdin";
27: "flx_stdout","_flx_stdout";
28: "flx_stderr","_flx_stderr";
29: "gc","_gc";
30:
31: (*
32: "read","_read";
33: "write","_write";
34: *)
35:
36: (* C keywords shouldnt occur because they should all be Felix keywords *)
37: "while","_while";
38: "continue","_continue";
39: "break","_break";
40: "for","_for";
41: "return","_return";
42: ]
43:
44: let cvt s =
45: let n = String.length s in
46: let id = Buffer.create (n+10) in
47: for i=0 to n - 1 do
48: match s.[i] with
49: | '\'' -> Buffer.add_string id "__p"
50: | '\\' -> Buffer.add_string id "__"
51: | x -> Buffer.add_char id x
52: done;
53: let name = Buffer.contents id in
54: try assoc name fixups with Not_found -> name
55:
56: let cid_of_flxid s = cvt s
57:
58: (* mangle a C++ type name into an identifier *)
59: let mangle_cpp_typename ct =
60: let n = String.length ct in
61: let buf = Buffer.create (n+20) in
62: let tack_ch ch = Buffer.add_char buf ch in
63: let tack_str str = Buffer.add_string buf str in
64: for i=0 to n - 1 do
65: match ct.[i] with
66: | '*' -> tack_str "_p"
67: | ':'
68: | '<'
69: | '>'
70: | ' '
71: | '?'
72: | '$'
73: | '@'
74: | '#'
75: | '`'
76: -> tack_ch '_'
77: | x -> tack_ch x
78: done;
79: Buffer.contents buf
80:
81: (* basic name mangler *)
82: let cpp_name bbdfns index =
83: let id,parent,sr,entry =
84: try Hashtbl.find bbdfns index
85: with _ -> failwith ("[cpp_name] Can't find index " ^ si index)
86: in
87: (match entry with
88: | `BBDCL_function _ -> "_f"
89: | `BBDCL_callback _ -> "_cf"
90: | `BBDCL_procedure _ -> "_p"
91: | `BBDCL_regmatch _ -> "_rm"
92: | `BBDCL_reglex _ -> "_rl"
93: | `BBDCL_var _ -> "_v"
94: | `BBDCL_val _ -> "_v"
95: | `BBDCL_tmp _ -> "_tmp"
96: | `BBDCL_class _ -> "_cl"
97: | _ -> syserr sr "cpp_name expected func,proc,var,val,class,reglex or regmatch"
98: ) ^ si index ^ "_" ^ cvt id
99:
100: let cpp_instance_name' syms bbdfns index ts =
101: let inst =
102: try Hashtbl.find syms.instances (index,ts)
103: with Not_found ->
104: let id =
105: try
106: let id,parent,sr,entry = Hashtbl.find bbdfns index in id
107: with Not_found ->
108: try
109: match Hashtbl.find syms.dfns index with
110: {id=id} -> id ^ "[unbound]"
111: with Not_found ->
112: "unknown"
113: in
114: let has_variables =
115: fold_left
116: (fun truth t -> truth || var_occurs t)
117: false
118: ts
119: in
120: failwith
121: (
122: "[cpp_instance_name] unable to find instance " ^ id ^
123: "<" ^ si index ^ ">[" ^catmap ", " (string_of_btypecode syms.dfns) ts ^ "]"
124: ^ (if has_variables then " .. a subscript contains a type variable" else "")
125: )
126: in
127: "_i" ^ si inst ^ cpp_name bbdfns index
128:
129: let is_export syms id =
130: let bifaces = syms.bifaces in
131: try
132: iter
133: (function
134: | `BIFACE_export_fun (_,_,s)
135: | `BIFACE_export_type (_,_,s) ->
136: if id = s then raise Not_found
137: )
138: bifaces;
139: false
140: with Not_found -> true
141:
142: let cpp_instance_name syms bbdfns index ts =
143: let long_name = cpp_instance_name' syms bbdfns index ts in
144: if syms.compiler_options.mangle_names then long_name else
145: let id,parent,sr,entry =
146: try Hashtbl.find bbdfns index
147: with _ -> failwith ("[cpp_name] Can't find index " ^ si index)
148: in
149: let id' = cvt id in
150: if id = id' then
151: begin
152: let inst =
153: try Hashtbl.find syms.quick_names id
154: with Not_found ->
155: Hashtbl.add syms.quick_names id (index,ts);
156: index,ts
157: in
158: if (index,ts) <> inst then long_name else
159: if is_export syms id then long_name else id
160: end
161: else long_name
162:
163: let tix syms t =
164: try Hashtbl.find syms.registry t
165: with Not_found ->
166: failwith ("Cannot find type " ^sbt syms.dfns t ^" in registry")
167:
168: let rec cpp_type_classname syms t =
169: let tix t = tix syms t in
170: let t = fold syms.dfns (lstrip syms.dfns t) in
171: try match unfold syms.dfns t with
172: | `BTYP_var (i,mt) -> failwith ("[cpp_type_classname] Can't name type variable " ^ si i ^":"^ sbt syms.dfns mt)
173: | `BTYP_fix i -> failwith "[cpp_type_classname] Can't name type fixpoint"
174: | `BTYP_void -> "void" (* failwith "void doesn't have a classname" *)
175: | `BTYP_tuple [] -> "unit"
176:
177: | `BTYP_pointer t' ->
178: "_rt" ^ cpp_type_classname syms t'
179:
180: | `BTYP_function (_,`BTYP_void) ->
181: "_pt" ^ si (tix t)
182:
183: | `BTYP_function _ ->
184: "_ft" ^ si (tix t)
185:
186: | `BTYP_cfunction _ ->
187: "_cft" ^ si (tix t)
188:
189: | `BTYP_array _ ->
190: "_at" ^ si (tix t)
191:
192: | `BTYP_tuple _ ->
193: "_tt" ^ si (tix t)
194:
195: | `BTYP_record _ ->
196: "_art" ^ si (tix t)
197:
198: | `BTYP_variant _ ->
199: "_avt" ^ si (tix t)
200:
201: | `BTYP_sum _ ->
202: "_st" ^ si (tix t)
203:
204: | `BTYP_unitsum k ->
205: "_us" ^ si k
206:
207:
208: | `BTYP_inst (i,ts) ->
209: let cal_prefix = function
210: | `SYMDEF_struct _ -> "_s"
211: | `SYMDEF_union _ -> "_u"
212: | `SYMDEF_abs _ -> "_a"
213: | `SYMDEF_class -> "_cl"
214: | _ -> "_unk_"
215: in
216: if ts = [] then
217: match
218: try
219: match Hashtbl.find syms.dfns i with
220: { id=id; symdef=symdef } -> Some (id,symdef )
221: with Not_found -> None
222: with
223: | Some (id,`SYMDEF_cstruct _) -> id
224: | Some (id,`SYMDEF_cclass _) -> id^"*"
225: | Some (_,`SYMDEF_abs (_,`Str "char",_)) -> "char" (* hack .. *)
226: | Some (_,`SYMDEF_abs (_,`Str "int",_)) -> "int" (* hack .. *)
227: | Some (_,`SYMDEF_abs (_,`Str "short",_)) -> "short" (* hack .. *)
228: | Some (_,`SYMDEF_abs (_,`Str "long",_)) -> "long" (* hack .. *)
229: | Some (_,`SYMDEF_abs (_,`Str "float",_)) -> "float" (* hack .. *)
230: | Some (_,`SYMDEF_abs (_,`Str "double",_)) -> "double" (* hack .. *)
231: | Some (_,`SYMDEF_abs (_,`StrTemplate "char",_)) -> "char" (* hack .. *)
232: | Some (_,`SYMDEF_abs (_,`StrTemplate "int",_)) -> "int" (* hack .. *)
233: | Some (_,`SYMDEF_abs (_,`StrTemplate "short",_)) -> "short" (* hack .. *)
234: | Some (_,`SYMDEF_abs (_,`StrTemplate "long",_)) -> "long" (* hack .. *)
235: | Some (_,`SYMDEF_abs (_,`StrTemplate "float",_)) -> "float" (* hack .. *)
236: | Some (_,`SYMDEF_abs (_,`StrTemplate "double",_)) -> "double" (* hack .. *)
237: | Some (_,data) ->
238: let prefix = cal_prefix data in
239: prefix ^ si i ^ "t_" ^ si (tix t)
240: | None ->
241: "_unk_" ^ si i ^ "t_" ^ si (tix t)
242: else
243: "_poly_" ^ si i ^ "t_" ^ si (tix t)
244:
245: | _ ->
246: failwith
247: (
248: "[cpp_type_classname] Unexpected " ^
249: string_of_btypecode syms.dfns t
250: )
251: with Not_found ->
252: failwith
253: (
254: "[cpp_type_classname] Expected type "^
255: string_of_btypecode syms.dfns t ^
256: " to be in registry"
257: )
258:
259:
260: let cpp_typename syms t =
261: match unfold syms.dfns (lstrip syms.dfns t) with
262: | `BTYP_function _ -> cpp_type_classname syms t ^ "*"
263: | `BTYP_cfunction _ -> cpp_type_classname syms t ^ "*"
264: (*
265: | `BTYP_inst (i,ts) ->
266: begin match
267: try
268: match Hashtbl.find syms.dfns i with
269: { symdef=symdef } -> Some ( symdef )
270: with Not_found -> None
271: with
272: | Some (`SYMDEF_class ) -> cpp_type_classname syms t ^ "*"
273: | _ -> cpp_type_classname syms t
274: end
275: *)
276: | _ -> cpp_type_classname syms t
277:
278: let cpp_ltypename syms t =
279: cpp_typename syms t ^
280: (
281: match t with
282: | `BTYP_lvalue _ -> "&"
283: | _ -> ""
284: )
285:
286:
287: