20: # 41 "./lpsrc/flx_tgen.ipk"
21: let gen_tuple name tn typs =
22: let n = length typs in
23: "struct " ^ name ^ " {\n" ^
24: catmap ""
25: (fun (t,i) ->
26: if t = `BTYP_tuple []
27: then " // elided mem_" ^ si i ^ "(type unit)\n"
28: else " "^tn t^ " mem_" ^ si i ^ ";\n"
29: )
30: (combine typs (nlist n))
31: ^
32: " " ^ name ^ "(){}\n" (* default constructor *)
33: ^
34: (
35: if fold_left (fun r t -> r && t = `BTYP_tuple []) true typs
36: then ""
37: else
38: " " ^ name ^ "(" ^
39: fold_left
40: (fun s (t,i) ->
41: if t = `BTYP_tuple [] then s
42: else
43: s ^
44: (if String.length s > 0 then ", " else "") ^
45: tn t^" a" ^ si i
46: )
47: ""
48: (combine typs (nlist n))
49: ^
50: "):\n "
51: ^
52: fold_left
53: (fun s (t,i) ->
54: if t = `BTYP_tuple [] then s
55: else
56: s ^
57: (if String.length s > 0 then ", " else "") ^
58: "mem_"^si i ^ "(a" ^ si i^")"
59: )
60: ""
61: (combine typs (nlist n))
62: ^
63: "{}\n"
64: )
65: ^
66: "};\n"
67:
68: let gen_record name tn typs =
69: let n = length typs in
70: "struct " ^ name ^ " {\n" ^
71: catmap ""
72: (fun (n,t) ->
73: if t = `BTYP_tuple []
74: then " // elided " ^ n ^ "(type unit)\n"
75: else " "^tn t^ " " ^ n ^ ";\n"
76: )
77: typs
78: ^
79: " " ^ name ^ "(){}\n" (* default constructor *)
80: ^
81: (
82: if fold_left (fun r (n,t) -> r && t = `BTYP_tuple []) true typs
83: then ""
84: else
85: " " ^ name ^ "(" ^
86: fold_left
87: (fun s (n,t) ->
88: if t = `BTYP_tuple [] then s
89: else
90: s ^
91: (if String.length s > 0 then ", " else "") ^
92: tn t^" _" ^ n ^ "_a"
93: )
94: ""
95: typs
96: ^
97: "):\n "
98: ^
99: fold_left
100: (fun s (n,t) ->
101: if t = `BTYP_tuple [] then s
102: else
103: s ^
104: (if String.length s > 0 then ", " else "") ^
105: n ^ "(_" ^ n ^"_a)"
106: )
107: ""
108: typs
109: ^
110: "{}\n"
111: )
112: ^
113: "};\n"
114:
115: (* copy ctor, assignment, and destructor are generated;
116: we have to supply the pointer constructor and default
117: constructor though. Note that it matters not if this
118: type is sliced, since it's nothing more than a type
119: correct wrapper for its base
120: *)
121: let gen_ref name typ =
122: "struct " ^ name ^ ": _ref_ {\n" ^
123: " "^name^"(){}\n" ^
124: " "^name^"(void *f, " ^typ^" *d): _ref_(f,d){}\n" ^
125: " "^name^"(" ^typ^" *f): _ref_(f,std::ptrdiff_t(0)){}\n" ^
126: " "^typ^" *operator->()const { return ("^typ^"*)get_data(); }\n" ^
127: " "^typ^" &operator*() const { return *("^typ^"*)get_data(); }\n" ^
128: "};\n"
129:
130: (* this routine generates a typedef (for primitives)
131: or struct declaration which names the type.
132: *)
133:
134: let gen_type_name syms bbdfns (index,typ) =
135: (*
136: print_endline (
137: "GENERATING TYPE NAME " ^
138: si index^": " ^
139: sbt syms.dfns typ
140: );
141: *)
142: let cn t = cpp_type_classname syms t in
143: let tn t = cpp_typename syms t in
144: let descr =
145: "\n//TYPE "^si index^": " ^ sbt syms.dfns typ ^ "\n"
146: in
147: let t = unfold syms.dfns typ in
148: match t with
149: | `BTYP_fix i -> ""
150: | `BTYP_var i -> failwith "[gen_type_name] Can't gen name of type variable"
151:
152: | `BTYP_tuple [] -> "" (* unit *)
153:
154: | `BTYP_pointer _
155: | `BTYP_tuple _
156: | `BTYP_record _
157: | `BTYP_array _
158: | `BTYP_function _ ->
159: descr ^
160: let name = cn typ in
161: "struct " ^ name ^ ";\n"
162:
163: | `BTYP_cfunction (d,c) ->
164: descr ^
165: let name = cn typ in
166: let ds = match d with
167: | `BTYP_tuple ls -> ls
168: | x -> [x]
169: in
170: let ctn t = `Ct_base (cpp_typename syms t) in
171: let t = `Ct_fun (ctn c,map ctn ds) in
172: let cdt = `Cdt_value t in
173: "typedef " ^ string_of_cdecl_type name cdt ^ ";\n"
174:
175: | `BTYP_unitsum k ->
176: "typedef int " ^ tn typ ^ ";\n"
177:
178: | `BTYP_sum ts ->
179: descr ^
180: if is_unitsum typ
181: then
182: "typedef int " ^ tn typ ^ ";\n"
183: else
184: "typedef _uctor_ " ^ tn typ ^ ";\n"
185:
186: | `BTYP_variant ts ->
187: "typedef _uctor_ " ^ tn typ ^ ";\n"
188:
189: | `BTYP_void -> ""
190:
191: | `BTYP_inst (i,ts) ->
192: let id,parent,sr,entry =
193: try Hashtbl.find bbdfns i
194: with _ -> failwith ("[gen_type_name] can't find type" ^ si i)
195: in
196: begin match entry with
197: | `BBDCL_abs (vs,quals,ct,_) ->
198: let complete = not (mem `Incomplete quals) in
199: let descr =
200: "\n//"^(if complete then "" else "INCOMPLETE ")^
201: "PRIMITIVE "^si i ^" INSTANCE " ^
202: si index^": " ^
203: sbt syms.dfns typ ^
204: "\n"
205: in
206: let instance_name = cn typ in
207: let tss = map tn ts in
208: let instance =
209: match ct with
210: | `Virtual -> clierr sr "Instantiate virtual type!"
211: | `Identity -> syserr sr "Idendity type is nonsense!"
212: | `Str c -> c
213: | `StrTemplate c ->
214: try sc "expr" (csubst sr sr c (Flx_cexpr.ce_atom "Error") [] [] "Error" "Error" tss "atom" "Error" ["Error"] ["Error"] ["Error"])
215: with Not_found -> failwith "[gen_type_name] Unexpected error in csubst"
216: in
217:
218: (* special hack to avoid 'typedef int int' when we decide
219: to use the native typename in generated code instead of
220: an alias
221: *)
222: (if instance = instance_name
223: then descr ^ "//"
224: else descr
225: )
226: ^
227: "typedef " ^ instance ^ " " ^ instance_name ^ ";\n"
228:
229: | `BBDCL_newtype (_,t') -> ""
230:
231: | `BBDCL_cstruct _ -> if ts = [] then "" else
232: let descr =
233: "\n//CSTRUCT "^si i ^" INSTANCE " ^
234: si index^": " ^
235: sbt syms.dfns typ ^
236: "\n"
237: in
238: let instance_name = cn typ in
239: let instance = id ^ "<" ^ catmap "," cn ts ^"> " in
240: descr ^
241: "typedef " ^ instance ^ " " ^ instance_name ^ ";\n"
242:
243:
244: | `BBDCL_class _ ->
245: begin
246: (*
247: print_endline "[gen_type_name] CLASS TYPE INSTANCE";
248: *)
249: let type_instance_name = cn typ in
250: let class_name = cpp_instance_name syms bbdfns i ts in
251: let class_instance =
252: try Hashtbl.find syms.instances (i,ts)
253: with Not_found -> assert false
254: in
255: let descr =
256: "\n//CLASS "^si i ^" TYPE INSTANCE " ^
257: si index^": " ^
258: sbt syms.dfns typ ^
259: ", CLASS INSTANCE " ^ si class_instance ^
260: "\n"
261: in
262: descr ^
263: "struct " ^ class_name ^"; // class instance \n" ^
264: "typedef " ^ class_name ^" *"^type_instance_name^"; // type instance\n"
265: end
266:
267: | `BBDCL_cclass _ -> if ts = [] then "" else
268: let descr =
269: "\n//CCLASS "^si i ^" INSTANCE " ^
270: si index^": " ^
271: sbt syms.dfns typ ^
272: "\n"
273: in
274: let instance_name = cn typ in
275: let instance = id ^ "<" ^ catmap "," cn ts ^"> " in
276: descr ^
277: "typedef " ^ instance ^ " *" ^ instance_name ^ ";\n"
278:
279: | `BBDCL_struct _ ->
280: let descr =
281: "\n//STRUCT "^si i ^" INSTANCE " ^
282: si index^": " ^
283: sbt syms.dfns typ ^
284: "\n"
285: in
286: let name = cn typ in
287: descr ^ "struct " ^ name ^ ";\n"
288:
289: | `BBDCL_union (vs,ls) ->
290: let descr =
291: "\n//UNION "^si i ^" INSTANCE " ^
292: si index^": " ^
293: sbt syms.dfns typ ^
294: "\n"
295: in
296: let name = cn typ in
297: descr ^
298: let lss = map (fun (_,_,t)->t) ls in
299: let lss = map (tsubst vs ts) lss in
300: let len = si (length lss) in
301: if all_voids lss
302: then
303: "typedef int " ^ name ^ "; //ncases="^len^"\n"
304: else
305: "typedef _uctor_ " ^ name ^ "; //ncases="^len^"\n"
306:
307:
308: | _ ->
309: failwith
310: (
311: "[gen_type_name] Expected definition "^si i^" to be generic primitive, got " ^
312: string_of_bbdcl syms.dfns entry i ^
313: " instance types [" ^
314: catmap ", " tn ts ^
315: "]"
316: )
317: end
318:
319: | _ -> failwith ("Unexpected metatype "^ sbt syms.dfns t ^ " in gen_type_name")
320:
321: let mk_listwise_ctor syms i name typ cts ctss =
322: if length cts = 1 then
323: let ctn,ctt = hd ctss in
324: " " ^ name ^ "("^ ctt ^ " const & _a): " ^
325: ctn^"(_a){}\n"
326: else ""
327:
328:
329: (* This routine generates complete types when needed *)
330: let gen_type syms bbdfns (index,typ) =
331: (*
332: print_endline (
333: "GENERATING TYPE " ^
334: si index^": " ^
335: sbt syms.dfns typ
336: );
337: *)
338: let tn t = cpp_typename syms t in
339: let cn t = cpp_type_classname syms t in
340: let descr =
341: "\n//TYPE "^ si index^ ": " ^
342: sbt syms.dfns typ ^
343: "\n"
344: in
345: let t = unfold syms.dfns typ in
346: match t with
347: | `BTYP_var _ -> failwith "[gen_type] can't gen type variable"
348: | `BTYP_fix _ -> failwith "[gen_type] can't gen type fixpoint"
349:
350: (* PROCEDURE *)
351: | `BTYP_cfunction _ -> ""
352:
353: | `BTYP_function (a,`BTYP_void) ->
354: descr ^
355: let name = cn typ
356: and argtype = tn a
357: and unitproc = a = `BTYP_tuple[] or a = `BTYP_void
358: in
359: "struct " ^ name ^
360: ": con_t {\n" ^
361: " typedef void rettype;\n" ^
362: " typedef " ^ (if unitproc then "void" else argtype) ^ " argtype;\n" ^
363: (if unitproc
364: then
365: " virtual con_t *call(con_t *)=0;\n"
366: else
367: " virtual con_t *call(con_t *, "^argtype^" const &)=0;\n"
368: ) ^
369: " virtual "^name^" *clone()=0;\n" ^
370: " virtual con_t *resume()=0;\n" ^
371: "};\n"
372:
373: (* FUNCTION *)
374: | `BTYP_function (a,r) ->
375: descr ^
376: let name = cn typ
377: and argtype = tn a
378: and rettype = tn r
379: and unitfun = a = `BTYP_tuple[] or a = `BTYP_void
380: in
381: "struct " ^ name ^ " {\n" ^
382: " typedef " ^ rettype ^ " rettype;\n" ^
383: " typedef " ^ (if unitfun then "void" else argtype) ^ " argtype;\n" ^
384: " virtual "^rettype^" apply("^
385: (if unitfun then "" else argtype^" const &") ^
386: ")=0;\n" ^
387: " virtual "^name^" *clone()=0;\n" ^
388: " virtual ~"^name^"(){};\n" ^
389: "};\n"
390:
391: | `BTYP_unitsum _ -> "" (* union typedef *)
392: | `BTYP_sum _ -> "" (* union typedef *)
393: | `BTYP_variant _ -> ""
394:
395: | `BTYP_tuple [] -> ""
396: | `BTYP_tuple ts ->
397: descr ^
398: gen_tuple (cn typ) tn ts
399:
400: | `BTYP_record ts ->
401: descr ^
402: gen_record (cn typ) tn ts
403:
404: | `BTYP_void -> ""
405: | `BTYP_pointer t ->
406: let name = tn typ in
407: let t = tn t in
408: descr ^ gen_ref name t
409:
410: | `BTYP_array (v,i) ->
411: let name = tn typ in
412: let v = tn v in
413: let n = int_of_unitsum i in
414: if n < 2 then failwith "[flx_tgen] unexpected array length < 2";
415: descr ^
416: "struct " ^ name ^ " {\n" ^
417: " static size_t const len = " ^ si n ^ ";\n" ^
418: " typedef " ^ v ^ " element_type;\n" ^
419: " " ^ v ^ " data[" ^ si n ^ "];\n" ^
420: "};\n"
421:
422:
423: | `BTYP_inst (i,ts) ->
424: let id,parent,sr,entry =
425: try Hashtbl.find bbdfns i
426: with _ -> failwith ("[gen_type_name] can't find type" ^ si i)
427: in
428: begin match entry with
429: | `BBDCL_newtype (vs,t') ->
430: let t' = reduce_type t' in
431: let descr =
432: "\n//NEWTYPE "^si i ^" INSTANCE " ^
433: si index^": " ^
434: sbt syms.dfns typ ^
435: "\n"
436: in
437: let instance_name = cn typ in
438: let instance = cn t' in
439: descr ^
440: "typedef " ^ instance ^ " " ^ instance_name ^ ";\n"
441:
442: | `BBDCL_abs (vs,quals,ct,_) -> ""
443: | `BBDCL_cstruct (vs,cts) -> ""
444: | `BBDCL_cclass (vs,cts) -> ""
445: | `BBDCL_class vs ->
446: (*
447: print_endline "[gen_type] FOUND CLASS TYPE INSTANCE (doing nothing)";
448: *)
449: ""
450:
451: (*
452: let name = cn typ in
453: let descr =
454: "\n//GENERIC CLASS "^si i ^" INSTANCE TYPE " ^
455: si index^": " ^
456: sbt syms.dfns typ ^
457: "\n"
458: in
459: descr ^ "//see " ^ name ^ ";\n"
460: *)
461:
462: | `BBDCL_struct (vs,cts) ->
463: let cts = map (fun (name,typ) -> name, tsubst vs ts typ) cts in
464: let ctss = map (fun (name,typ) -> name, tn typ) cts in
465: let name = cn typ in
466: let listwise_ctor = mk_listwise_ctor syms i name typ cts ctss in
467: let descr =
468: "\n//GENERIC STRUCT "^si i ^" INSTANCE " ^
469: si index^": " ^
470: sbt syms.dfns typ ^
471: "\n"
472: in
473: descr ^ "struct " ^ name ^ " {\n"
474: ^
475: catmap ""
476: (fun (name,typ) -> " " ^ typ ^ " " ^ name ^ ";\n")
477: ctss
478: ^
479: " " ^ name ^ "(){}\n" ^
480: listwise_ctor
481: ^
482: "};\n"
483:
484:
485: | `BBDCL_union _ -> ""
486:
487: | _ ->
488: failwith
489: (
490: "[gen_type] Expected definition "^si i^" to be generic primitive, got " ^
491: string_of_bbdcl syms.dfns entry i ^
492: " instance types [" ^
493: catmap ", " tn ts ^
494: "]"
495: )
496: end
497:
498: | _ -> failwith ("[gen_type] Unexpected metatype " ^ sbt syms.dfns t)
499:
500: (* NOTE: distinct types can have the same name if they have the
501: same simple representation, two types t1,t2 both represented by "int".
502: This is due to special code that allows Felix to generate "int" etc
503: for a type mapped to "int" to make the code more readable.
504: So we have to check the name at this point, because this special
505: trick is based on the representation.
506: *)
507:
508: let gen_type_names syms bbdfns ts =
509: (* print_endline "GENERATING TYPE NAMES"; *)
510: let s = Buffer.create 100 in
511: let handled = ref [] in
512: iter
513: (fun (i,t) ->
514: try
515: let name = cpp_typename syms t in
516: if mem name !handled then
517: () (* print_endline ("WOOPS ALREADY HANDLED " ^ name) *)
518: else (
519: handled := name :: !handled;
520: Buffer.add_string s (gen_type_name syms bbdfns (i,t))
521: )
522: with Not_found ->
523: failwith ("Can't gen type name " ^ si i ^ "=" ^ sbt syms.dfns t)
524: )
525: ts;
526: Buffer.contents s
527:
528: let gen_types syms bbdfns ts =
529: (* print_endline "GENERATING TYPES"; *)
530: let handled = ref [] in
531: let s = Buffer.create 100 in
532: iter
533: (fun ((i,t) as t') ->
534: let name = cpp_typename syms t in
535: if mem name !handled then
536: () (* print_endline ("WOOPS ALREADY HANDLED " ^ name) *)
537: else (
538: handled := name :: !handled;
539: Buffer.add_string s (gen_type syms bbdfns t')
540: )
541: )
542: ts;
543: Buffer.contents s
544: