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: (* special names in thread frame *)
20: "argc","_argc";
21: "argv","_argv";
22: "flx_stdin","_flx_stdin";
23: "flx_stdout","_flx_stdout";
24: "flx_stderr","_flx_stderr";
25: "gc","_gc";
26: # 67 "./lpsrc/flx_name.ipk"
27: "asm","_asm";
28: # 67 "./lpsrc/flx_name.ipk"
29: "auto","_auto";
30: # 67 "./lpsrc/flx_name.ipk"
31: "bool","_bool";
32: # 67 "./lpsrc/flx_name.ipk"
33: "break","_break";
34: # 67 "./lpsrc/flx_name.ipk"
35: "case","_case";
36: # 67 "./lpsrc/flx_name.ipk"
37: "catch","_catch";
38: # 67 "./lpsrc/flx_name.ipk"
39: "charclass","_charclass";
40: # 67 "./lpsrc/flx_name.ipk"
41: "const","_const";
42: # 67 "./lpsrc/flx_name.ipk"
43: "const_cast","_const_cast";
44: # 67 "./lpsrc/flx_name.ipk"
45: "continue","_continue";
46: # 67 "./lpsrc/flx_name.ipk"
47: "default","_default";
48: # 67 "./lpsrc/flx_name.ipk"
49: "delete","_delete";
50: # 67 "./lpsrc/flx_name.ipk"
51: "do","_do";
52: # 67 "./lpsrc/flx_name.ipk"
53: "double","_double";
54: # 67 "./lpsrc/flx_name.ipk"
55: "dynamic_cast","_dynamic_cast";
56: # 67 "./lpsrc/flx_name.ipk"
57: "else","_else";
58: # 67 "./lpsrc/flx_name.ipk"
59: "enum","_enum";
60: # 67 "./lpsrc/flx_name.ipk"
61: "explicit","_explicit";
62: # 67 "./lpsrc/flx_name.ipk"
63: "extern","_extern";
64: # 67 "./lpsrc/flx_name.ipk"
65: "false","_false";
66: # 67 "./lpsrc/flx_name.ipk"
67: "float","_float";
68: # 67 "./lpsrc/flx_name.ipk"
69: "for","_for";
70: # 67 "./lpsrc/flx_name.ipk"
71: "friend","_friend";
72: # 67 "./lpsrc/flx_name.ipk"
73: "goto","_goto";
74: # 67 "./lpsrc/flx_name.ipk"
75: "if","_if";
76: # 67 "./lpsrc/flx_name.ipk"
77: "inline","_inline";
78: # 67 "./lpsrc/flx_name.ipk"
79: "int","_int";
80: # 67 "./lpsrc/flx_name.ipk"
81: "long","_long";
82: # 67 "./lpsrc/flx_name.ipk"
83: "mutable","_mutable";
84: # 67 "./lpsrc/flx_name.ipk"
85: "namespace","_namespace";
86: # 67 "./lpsrc/flx_name.ipk"
87: "new","_new";
88: # 67 "./lpsrc/flx_name.ipk"
89: "operator","_operator";
90: # 67 "./lpsrc/flx_name.ipk"
91: "private","_private";
92: # 67 "./lpsrc/flx_name.ipk"
93: "protected","_protected";
94: # 67 "./lpsrc/flx_name.ipk"
95: "public","_public";
96: # 67 "./lpsrc/flx_name.ipk"
97: "register","_register";
98: # 67 "./lpsrc/flx_name.ipk"
99: "reinterpret_cast","_reinterpret_cast";
100: # 67 "./lpsrc/flx_name.ipk"
101: "return","_return";
102: # 67 "./lpsrc/flx_name.ipk"
103: "short","_short";
104: # 67 "./lpsrc/flx_name.ipk"
105: "signed","_signed";
106: # 67 "./lpsrc/flx_name.ipk"
107: "sizeof","_sizeof";
108: # 67 "./lpsrc/flx_name.ipk"
109: "static","_static";
110: # 67 "./lpsrc/flx_name.ipk"
111: "static_cast","_static_cast";
112: # 67 "./lpsrc/flx_name.ipk"
113: "struct","_struct";
114: # 67 "./lpsrc/flx_name.ipk"
115: "switch","_switch";
116: # 67 "./lpsrc/flx_name.ipk"
117: "template","_template";
118: # 67 "./lpsrc/flx_name.ipk"
119: "this","_this";
120: # 67 "./lpsrc/flx_name.ipk"
121: "throw","_throw";
122: # 67 "./lpsrc/flx_name.ipk"
123: "true","_true";
124: # 67 "./lpsrc/flx_name.ipk"
125: "try","_try";
126: # 67 "./lpsrc/flx_name.ipk"
127: "typedef","_typedef";
128: # 67 "./lpsrc/flx_name.ipk"
129: "typeid","_typeid";
130: # 67 "./lpsrc/flx_name.ipk"
131: "typename","_typename";
132: # 67 "./lpsrc/flx_name.ipk"
133: "union","_union";
134: # 67 "./lpsrc/flx_name.ipk"
135: "unsigned","_unsigned";
136: # 67 "./lpsrc/flx_name.ipk"
137: "using","_using";
138: # 67 "./lpsrc/flx_name.ipk"
139: "virtual","_virtual";
140: # 67 "./lpsrc/flx_name.ipk"
141: "void","_void";
142: # 67 "./lpsrc/flx_name.ipk"
143: "volatile","_volatile";
144: # 67 "./lpsrc/flx_name.ipk"
145: "wchar_t","_wchar_t";
146: # 67 "./lpsrc/flx_name.ipk"
147: "while","_while";
148: ]
149:
150: let cid_of_flxid s =
151: let n = String.length s in
152: let id = Buffer.create (n+10) in
153: for i=0 to n - 1 do
154: (* from http://www.w3.org/TR/html4/sgml/entities.html *)
155: match s.[i] with
156: | ' ' -> Buffer.add_string id "__sp_"
157: | '!' -> Buffer.add_string id "__excl_"
158: | '"' -> Buffer.add_string id "__quot_"
159: | '#' -> Buffer.add_string id "__num_"
160: | '$' -> Buffer.add_string id "__dollar_"
161: | '%' -> Buffer.add_string id "__percnt_"
162: | '&' -> Buffer.add_string id "__amp_"
163: | '\'' -> Buffer.add_string id "__apos_"
164: | '(' -> Buffer.add_string id "__lpar_"
165: | ')' -> Buffer.add_string id "__rpar_"
166: | '*' -> Buffer.add_string id "__ast_"
167: | '+' -> Buffer.add_string id "__plus_"
168: | ',' -> Buffer.add_string id "__comma_"
169: | '-' -> Buffer.add_string id "__hyphen_"
170: | '.' -> Buffer.add_string id "__period_"
171: | '/' -> Buffer.add_string id "__sol_"
172: | ':' -> Buffer.add_string id "__colon_"
173: | ';' -> Buffer.add_string id "__semi_"
174: | '<' -> Buffer.add_string id "__lt_"
175: | '=' -> Buffer.add_string id "__equals_"
176: | '>' -> Buffer.add_string id "__gt_"
177: | '?' -> Buffer.add_string id "__quest_"
178: | '@' -> Buffer.add_string id "__commat_"
179: | '[' -> Buffer.add_string id "__lsqb_"
180: | '\\' -> Buffer.add_string id "__bsol_"
181: | ']' -> Buffer.add_string id "__rsqb_"
182: | '^' -> Buffer.add_string id "__caret_"
183: (* | '_' -> Buffer.add_string id "__lowbar_" *)
184: | '`' -> Buffer.add_string id "__grave_"
185: | '{' -> Buffer.add_string id "__lcub_"
186: | '|' -> Buffer.add_string id "__verbar_"
187: | '}' -> Buffer.add_string id "__rcub_"
188: | '~' -> Buffer.add_string id "__tilde_"
189: | x -> Buffer.add_char id x
190: done;
191: let name = Buffer.contents id in
192: try assoc name fixups with Not_found -> name
193:
194: (* basic name mangler *)
195: let cpp_name bbdfns index =
196: let id,parent,sr,entry =
197: try Hashtbl.find bbdfns index
198: with _ -> failwith ("[cpp_name] Can't find index " ^ si index)
199: in
200: (match entry with
201: | `BBDCL_function _ -> "_f"
202: | `BBDCL_callback _ -> "_cf"
203: | `BBDCL_procedure _ -> "_p"
204: | `BBDCL_regmatch _ -> "_rm"
205: | `BBDCL_reglex _ -> "_rl"
206: | `BBDCL_var _ -> "_v"
207: | `BBDCL_val _ -> "_v"
208: | `BBDCL_ref _ -> "_v"
209: | `BBDCL_tmp _ -> "_tmp"
210: | `BBDCL_class _ -> "_cl"
211: | _ -> syserr sr "cpp_name expected func,proc,var,val,class,reglex or regmatch"
212: ) ^ si index ^ "_" ^ cid_of_flxid id
213:
214: let cpp_instance_name' syms bbdfns index ts =
215: let inst =
216: try Hashtbl.find syms.instances (index,ts)
217: with Not_found ->
218: let id =
219: try
220: let id,parent,sr,entry = Hashtbl.find bbdfns index in id
221: with Not_found ->
222: try
223: match Hashtbl.find syms.dfns index with
224: {id=id} -> id ^ "[unbound]"
225: with Not_found ->
226: "unknown"
227: in
228: let has_variables =
229: fold_left
230: (fun truth t -> truth || var_occurs t)
231: false
232: ts
233: in
234: failwith
235: (
236: "[cpp_instance_name] unable to find instance " ^ id ^
237: "<" ^ si index ^ ">[" ^catmap ", " (string_of_btypecode syms.dfns) ts ^ "]"
238: ^ (if has_variables then " .. a subscript contains a type variable" else "")
239: )
240: in
241: "_i" ^ si inst ^ cpp_name bbdfns index
242:
243: let is_export syms id =
244: let bifaces = syms.bifaces in
245: try
246: iter
247: (function
248: | `BIFACE_export_fun (_,_,s)
249: | `BIFACE_export_type (_,_,s) ->
250: if id = s then raise Not_found
251: )
252: bifaces;
253: false
254: with Not_found -> true
255:
256: let cpp_instance_name syms bbdfns index ts =
257: let long_name = cpp_instance_name' syms bbdfns index ts in
258: if syms.compiler_options.mangle_names then long_name else
259: let id,parent,sr,entry =
260: try Hashtbl.find bbdfns index
261: with _ -> failwith ("[cpp_name] Can't find index " ^ si index)
262: in
263: let id' = cid_of_flxid id in
264: if id = id' then
265: begin
266: let inst =
267: try Hashtbl.find syms.quick_names id
268: with Not_found ->
269: Hashtbl.add syms.quick_names id (index,ts);
270: index,ts
271: in
272: if (index,ts) <> inst then long_name else
273: if is_export syms id then long_name else id
274: end
275: else long_name
276:
277: let tix syms t =
278: let t =
279: match t with
280: | `BTYP_function (`BTYP_void,cod) -> `BTYP_function (`BTYP_tuple [],cod)
281: | x -> x
282: in
283: try Hashtbl.find syms.registry t
284: with Not_found ->
285: failwith ("Cannot find type " ^sbt syms.dfns t ^" in registry")
286:
287: let rec cpp_type_classname syms t =
288: let tix t = tix syms t in
289: let t = fold syms.dfns (lstrip syms.dfns t) in
290: try match unfold syms.dfns t with
291: | `BTYP_var (i,mt) -> failwith ("[cpp_type_classname] Can't name type variable " ^ si i ^":"^ sbt syms.dfns mt)
292: | `BTYP_fix i -> failwith "[cpp_type_classname] Can't name type fixpoint"
293: | `BTYP_void -> "void" (* failwith "void doesn't have a classname" *)
294: | `BTYP_tuple [] -> "unit"
295:
296: | `BTYP_pointer t' ->
297: "_rt" ^ cpp_type_classname syms t'
298:
299: | `BTYP_function (_,`BTYP_void) ->
300: "_pt" ^ si (tix t)
301:
302: | `BTYP_function _ ->
303: "_ft" ^ si (tix t)
304:
305: | `BTYP_cfunction _ ->
306: "_cft" ^ si (tix t)
307:
308: | `BTYP_array _ ->
309: "_at" ^ si (tix t)
310:
311: | `BTYP_tuple _ ->
312: "_tt" ^ si (tix t)
313:
314: | `BTYP_record _ ->
315: "_art" ^ si (tix t)
316:
317: | `BTYP_variant _ ->
318: "_avt" ^ si (tix t)
319:
320: | `BTYP_sum _ ->
321: "_st" ^ si (tix t)
322:
323: | `BTYP_unitsum k ->
324: "_us" ^ si k
325:
326:
327: | `BTYP_inst (i,ts) ->
328: let cal_prefix = function
329: | `SYMDEF_struct _ -> "_s"
330: | `SYMDEF_union _ -> "_u"
331: | `SYMDEF_abs _ -> "_a"
332: | `SYMDEF_class -> "_cl"
333: | `SYMDEF_newtype _ -> "_abstr_"
334: | _ -> "_unk_"
335: in
336: if ts = [] then
337: match
338: try
339: match Hashtbl.find syms.dfns i with
340: { id=id; symdef=symdef } -> Some (id,symdef )
341: with Not_found -> None
342: with
343: | Some (id,`SYMDEF_cstruct _) -> id
344: | Some (id,`SYMDEF_cclass _) -> id^"*"
345: | Some (_,`SYMDEF_abs (_,`Str "char",_)) -> "char" (* hack .. *)
346: | Some (_,`SYMDEF_abs (_,`Str "int",_)) -> "int" (* hack .. *)
347: | Some (_,`SYMDEF_abs (_,`Str "short",_)) -> "short" (* hack .. *)
348: | Some (_,`SYMDEF_abs (_,`Str "long",_)) -> "long" (* hack .. *)
349: | Some (_,`SYMDEF_abs (_,`Str "float",_)) -> "float" (* hack .. *)
350: | Some (_,`SYMDEF_abs (_,`Str "double",_)) -> "double" (* hack .. *)
351: | Some (_,`SYMDEF_abs (_,`StrTemplate "char",_)) -> "char" (* hack .. *)
352: | Some (_,`SYMDEF_abs (_,`StrTemplate "int",_)) -> "int" (* hack .. *)
353: | Some (_,`SYMDEF_abs (_,`StrTemplate "short",_)) -> "short" (* hack .. *)
354: | Some (_,`SYMDEF_abs (_,`StrTemplate "long",_)) -> "long" (* hack .. *)
355: | Some (_,`SYMDEF_abs (_,`StrTemplate "float",_)) -> "float" (* hack .. *)
356: | Some (_,`SYMDEF_abs (_,`StrTemplate "double",_)) -> "double" (* hack .. *)
357: | Some (_,data) ->
358: let prefix = cal_prefix data in
359: prefix ^ si i ^ "t_" ^ si (tix t)
360: | None ->
361: "_unk_" ^ si i ^ "t_" ^ si (tix t)
362: else
363: "_poly_" ^ si i ^ "t_" ^ si (tix t)
364:
365: | _ ->
366: failwith
367: (
368: "[cpp_type_classname] Unexpected " ^
369: string_of_btypecode syms.dfns t
370: )
371: with Not_found ->
372: failwith
373: (
374: "[cpp_type_classname] Expected type "^
375: string_of_btypecode syms.dfns t ^
376: " to be in registry"
377: )
378:
379:
380: let cpp_typename syms t =
381: match unfold syms.dfns (lstrip syms.dfns t) with
382: | `BTYP_function _ -> cpp_type_classname syms t ^ "*"
383: | `BTYP_cfunction _ -> cpp_type_classname syms t ^ "*"
384: (*
385: | `BTYP_inst (i,ts) ->
386: begin match
387: try
388: match Hashtbl.find syms.dfns i with
389: { symdef=symdef } -> Some ( symdef )
390: with Not_found -> None
391: with
392: | Some (`SYMDEF_class ) -> cpp_type_classname syms t ^ "*"
393: | _ -> cpp_type_classname syms t
394: end
395: *)
396: | _ -> cpp_type_classname syms t
397:
398: let cpp_ltypename syms t =
399: cpp_typename syms t ^
400: (
401: match t with
402: | `BTYP_lvalue _ -> "&"
403: | _ -> ""
404: )
405:
406:
407: