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