1: # 48 "./lpsrc/flx_egen.ipk"
2: open Flx_util
3: open Flx_ast
4: open Flx_types
5: open Flx_mtypes1
6: open Flx_mtypes2
7: open Flx_print
8: open Flx_typing
9: open Flx_name
10: open Flx_tgen
11: open Flx_unify
12: open Flx_csubst
13: open Flx_exceptions
14: open Flx_display
15: open List
16: open Flx_generic
17: open Flx_label
18: open Flx_unravel
19: open Flx_ogen
20: open Flx_ctypes
21: open Flx_cexpr
22: open Flx_maps
23: open Flx_pgen
24: open Flx_beta
25: open Flx_srcref
26:
27: let string_of_string = Flx_string.c_quote_of_string
28:
29: (* HACKERY: this assumes library dependent things:
30: but we can't add literals in the library code :-(
31: *)
32: let csuffix_of_type s = match s with
33: | "tiny" -> ""
34: | "short" -> ""
35: | "int" -> ""
36: | "long" -> "l"
37: | "vlong" -> "ll"
38: | "utiny" -> "u"
39: | "ushort" -> "u"
40: | "uint" -> "u"
41: | "ulong" -> "ul"
42: | "uvlong" -> "ull"
43: | "int8" -> ""
44: | "int16" -> ""
45: | "int32" -> "l"
46: | "int64" -> "ll"
47: | "uint8" -> "u"
48: | "uint16" -> "u"
49: | "uint32" -> "ul"
50: | "uint64" -> "ull"
51: | "double" -> ""
52: | "float" -> "f"
53: | "ldouble" -> "l"
54: | _ -> failwith ("[csuffix_of_type]: Unexpected Type " ^ s)
55:
56: let cstring_of_literal e = match e with
57: | `AST_int (s,i) -> (Big_int.string_of_big_int i)^csuffix_of_type s
58: | `AST_float (s,x) -> x ^ csuffix_of_type s
59: | `AST_string s -> string_of_string s
60: | `AST_cstring s -> string_of_string s
61: | `AST_wstring s -> "L" ^ string_of_string s
62: | `AST_ustring s -> "L" ^ string_of_string s
63:
64: (* a native literal is one not needing a cast to get the type right *)
65: let is_native_literal e = match e with
66: | `AST_int ("int",_)
67: | `AST_int ("long",_)
68: | `AST_int ("uint",_)
69: | `AST_int ("ulong",_)
70: | `AST_int ("vlong",_)
71: | `AST_int ("uvlong",_)
72: | `AST_float ("double",_) -> true
73: | _ -> false
74:
75: let get_var_frame syms bbdfns this index ts : string =
76: match
77: try Hashtbl.find bbdfns index
78: with Not_found -> failwith ("[get_var_frame(1)] Can't find index " ^ si index)
79: with (id,parent,sr,entry) ->
80: match entry with
81: | `BBDCL_val (vs,t)
82: | `BBDCL_var (vs,t)
83: | `BBDCL_ref (vs,t) ->
84: begin match parent with
85: | None -> "ptf"
86: | Some i ->
87: if i <> this
88: then "ptr" ^ cpp_instance_name syms bbdfns i ts
89: else "this"
90: end
91: | `BBDCL_tmp (vs,t) ->
92: failwith ("[get_var_frame] temporaries aren't framed: " ^ id)
93:
94: | _ -> failwith ("[get_var_frame] Expected name "^id^" to be variable or value")
95:
96: let get_var_ref syms bbdfns this index ts : string =
97: match
98: try Hashtbl.find bbdfns index
99: with Not_found -> failwith ("[get_var_ref] Can't find index " ^ si index)
100: with (id,parent,sr,entry) ->
101: (*
102: print_endline ("get var ref for " ^ id ^ "<" ^ si index ^ ">["^catmap "," (string_of_btypecode syms.dfns) ts^"]");
103: *)
104: match entry with
105: | `BBDCL_val (vs,t)
106: | `BBDCL_var (vs,t) ->
107: begin match parent with
108: | None -> (* print_endline "No parent ...?"; *)
109: "PTF " ^ cpp_instance_name syms bbdfns index ts
110: | Some i ->
111: (*
112: print_endline ("Parent " ^ si i);
113: *)
114: (
115: if i <> this
116: then "ptr" ^ cpp_instance_name syms bbdfns i ts ^ "->"
117: else ""
118: ) ^
119: cpp_instance_name syms bbdfns index ts
120: end
121:
122: | `BBDCL_ref (vs,t) ->
123: "(*(" ^
124: begin match parent with
125: | None -> (* print_endline "No parent ...?"; *)
126: "PTF " ^ cpp_instance_name syms bbdfns index ts
127: | Some i ->
128: (*
129: print_endline ("Parent " ^ si i);
130: *)
131: (
132: if i <> this
133: then "ptr" ^ cpp_instance_name syms bbdfns i ts ^ "->"
134: else ""
135: ) ^
136: cpp_instance_name syms bbdfns index ts
137: end
138: ^"))"
139:
140:
141: | `BBDCL_tmp (vs,t) ->
142: cpp_instance_name syms bbdfns index ts
143:
144: | _ -> failwith ("[get_var_ref(3)] Expected name "^id^" to be variable, value or temporary")
145:
146: let get_ref_ref syms bbdfns this index ts : string =
147: match
148: try Hashtbl.find bbdfns index
149: with Not_found -> failwith ("[get_var_ref] Can't find index " ^ si index)
150: with (id,parent,sr,entry) ->
151: (*
152: print_endline ("get var ref for " ^ id ^ "<" ^ si index ^ ">["^catmap "," (string_of_btypecode syms.dfns) ts^"]");
153: *)
154: match entry with
155: | `BBDCL_val (vs,t)
156: | `BBDCL_var (vs,t)
157: | `BBDCL_ref (vs,t) ->
158: begin match parent with
159: | None -> (* print_endline "No parent ...?"; *)
160: "PTF " ^ cpp_instance_name syms bbdfns index ts
161: | Some i ->
162: (*
163: print_endline ("Parent " ^ si i);
164: *)
165: (
166: if i <> this
167: then "ptr" ^ cpp_instance_name syms bbdfns i ts ^ "->"
168: else ""
169: ) ^
170: cpp_instance_name syms bbdfns index ts
171: end
172:
173: | `BBDCL_tmp (vs,t) ->
174: cpp_instance_name syms bbdfns index ts
175:
176: | _ -> failwith ("[get_var_ref(3)] Expected name "^id^" to be variable, value or temporary")
177:
178: let nth_type ts i =
179: try match ts with
180: | `BTYP_tuple ts -> nth ts i
181: | `BTYP_array (t,`BTYP_unitsum n) -> assert (i<n); t
182: | _ -> assert false
183: with Not_found ->
184: failwith ("Can't find component " ^ si i ^ " of type!")
185:
186: let isclass bbdfns t : bool =
187: match t with
188: | `BTYP_inst (i,_) ->
189: begin let _,_,_,entry = Hashtbl.find bbdfns i in
190: match entry with
191: | `BBDCL_class _ -> true
192: | _ -> false
193: end
194: | _ -> false
195:
196: let rec gen_expr' syms bbdfns this (e,t) vs ts sr : cexpr_t =
197: (*
198: print_endline ("Generating expression " ^ string_of_bound_expression_with_type syms.dfns (e,t));
199: print_endline ("Location " ^ short_string_of_src sr);
200: *)
201: let ge' e = gen_expr' syms bbdfns this e vs ts sr in
202: let ge e = gen_expr syms bbdfns this e vs ts sr in
203: let ge'' sr e = gen_expr' syms bbdfns this e vs ts sr in
204: if length ts <> length vs then
205: failwith
206: (
207: "[gen_expr} wrong number of args, expected vs = " ^
208: si (length vs) ^
209: ", got ts=" ^
210: si (length ts)
211: );
212: let tsub t = reduce_type (beta_reduce syms sr (tsubst vs ts t)) in
213: let tn t = cpp_typename syms (tsub (lower t)) in
214:
215: (* NOTE this function does not do a reduce_type *)
216: let raw_typename t = cpp_typename syms (beta_reduce syms sr (tsubst vs ts t)) in
217: let gen_case_index e =
218: let _,t = e in
219: let t = lstrip syms.dfns t in
220: begin match t with
221: | `BTYP_sum _
222: | `BTYP_unitsum _
223: | `BTYP_variant _ ->
224: if is_unitsum t then ge' e
225: else ce_dot (ge' e) "variant"
226: | `BTYP_inst (i,ts) ->
227: let ts = map tsub ts in
228: let id,_,_,entry =
229: try Hashtbl.find bbdfns i
230: with Not_found -> failwith ("[gen_expr: case_index] Can't find index " ^ si i)
231: in
232: begin match entry with
233: | `BBDCL_union (bvs,cts) ->
234: let tsub' t = reduce_type (beta_reduce syms sr (tsubst bvs ts t)) in
235: let cts = map (fun (_,_,t) -> tsub' t) cts in
236: if all_voids cts then ge' e
237: else ce_dot (ge' e) "variant"
238: | _ -> failwith ("Woops expected union, got " ^ id)
239: end
240: | _ -> failwith ("Woops expected union or sum, got " ^ sbt syms.dfns t)
241: end
242:
243: in
244: let ge_arg ((x,t) as a) =
245: let t = tsub t in
246: match t with
247: | `BTYP_tuple [] -> ""
248: | _ -> ge a
249: in
250: let id,parent,_,entry =
251: try Hashtbl.find bbdfns this
252: with Not_found -> failwith ("[gen_expr] Can't find this = " ^ si this)
253: in
254: let our_display = get_display_list syms bbdfns this in
255: let our_level = length our_display in
256: let rt t = reduce_type (beta_reduce syms sr (lstrip syms.dfns (tsubst vs ts t))) in
257: let t = rt t in
258: match t with
259: | `BTYP_tuple [] ->
260: clierr sr
261: ("[egen] In "^sbe syms.dfns (e,t)^":\nunit value required, should have been eliminated")
262:
263: (* ce_atom ("UNIT_ERROR") *)
264: | _ ->
265: match e with
266: | `BEXPR_parse ((_,t')as e,ii) ->
267: let pn =
268: try Hashtbl.find syms.parsers (this,t',ii)
269: with Not_found -> failwith ("[gen_expr] parse can't find parser")
270: in
271: let ln =
272: try Hashtbl.find syms.lexers (this,e)
273: with Not_found -> failwith ("[gen_expr] parse can't find lexer")
274: in
275: let the_display =
276: "this"::
277: map (fun (i,vslen)-> "ptr"^ cpp_instance_name syms bbdfns i (list_prefix ts vslen))
278: our_display
279: in
280:
281: (* HACK PROPERTIES *)
282: let pdisplay = strd the_display [`Requires_ptf] in
283: let ldisplay = strd (the_display @[ge e]) [`Requires_ptf] in
284: let callstr =
285: "(Elk_" ^ si pn ^ pdisplay ^
286: ".apply((new ElkLex_" ^ si ln^ldisplay^")->init()))"
287: in
288: (*
289: print_endline ("Parse call : " ^ callstr);
290: *)
291: ce_atom callstr
292:
293: | `BEXPR_expr (s,_) -> ce_top s
294:
295: | `BEXPR_case_index e -> gen_case_index e
296:
297: | `BEXPR_range_check (e1,e2,e3) ->
298: let f,sl,sc,el,ec = sr in
299: let f = ce_atom ("\""^ f ^"\"") in
300: let sl = ce_atom (si sl) in
301: let sc = ce_atom (si sc) in
302: let el = ce_atom (si el) in
303: let ec = ce_atom (si ec) in
304: let sref = ce_call (ce_atom "flx::rtl::flx_range_srcref_t") [f;sl;sc;el;ec] in
305: let cf = ce_atom "__FILE__" in
306: let cl = ce_atom "__LINE__" in
307: let args : cexpr_t list =
308: [ ge' e1 ; ge' e2; ge' e3; sref; cf; cl]
309: in
310: ce_call (ce_atom "flx::rtl::range_check") args
311:
312: | `BEXPR_get_n (n,(e',t as e)) ->
313: begin match rt t with
314: | `BTYP_array (_,`BTYP_unitsum _) ->
315: ce_dot (ge' e) ("data["^si n^"]")
316: | `BTYP_record es ->
317: let field_name,_ =
318: try nth es n
319: with Not_found ->
320: failwith "Woops, index of non-existent struct field"
321: in
322: ce_dot (ge' e) field_name
323:
324: | `BTYP_inst (i,_) ->
325: begin match Hashtbl.find bbdfns i with
326: | _,_,_,`BBDCL_struct (_,ls)
327: | _,_,_,`BBDCL_cstruct (_,ls) ->
328: let name,_ =
329: try nth ls n
330: with _ ->
331: failwith "Woops, index of non-existent struct field"
332: in
333: ce_dot (ge' e) name
334:
335: | _ -> failwith "Instance expected to be (c)struct"
336: end
337:
338: | _ -> ce_dot (ge' e) ("mem_" ^ si n)
339: end
340:
341: | `BEXPR_get_named (n,(e',t as e)) ->
342: (*
343: print_endline "Handling get_named expression";
344: *)
345: begin match rt t with
346: | `BTYP_inst (i,ts) ->
347: let cname = cpp_instance_name syms bbdfns n ts in
348: ce_arrow (ge' e) cname
349: (*
350: begin match
351: try Hashtbl.find syms.dfns i
352: with Not_found -> assert false
353: with { id=class_name; symdef=symdef } ->
354: match symdef with
355: | `SYMDEF_class ->
356: begin match
357: try Hashtbl.find syms.dfns n
358: with Not_found -> failwith ("Can't find class "^class_name^"member " ^ si n);
359: with { id = name } ->
360: let cname = cpp_instance_name syms bbdfns n ts in
361: ce_arrow (ge' e) cname
362: end
363: | _ -> clierr sr ("[gen_expr'] Expecting "^si i^" to be class, got " ^ string_of_bbdcl syms.dfns entry i)
364: end
365: *)
366: | _ -> assert false
367: end
368:
369: | `BEXPR_match_case (n,((e',t') as e)) ->
370: let t' = reduce_type (beta_reduce syms sr (lstrip syms.dfns t')) in
371: let x = gen_case_index e in
372: ce_infix "==" x (ce_atom (si n))
373:
374: (*
375: if is_unitsum t' then
376: ce_infix "==" (ge' e) (ce_atom (si n))
377: else
378: ce_infix "=="
379: (ce_dot (ge' e) "variant")
380: (ce_atom (si n))
381: *)
382:
383: | `BEXPR_case_arg (n,e) ->
384: (*
385: print_endline ("Decoding nonconst ctor type " ^ sbt syms.dfns t);
386: *)
387: begin match t with (* t is the result of the whole expression *)
388: | `BTYP_function _ ->
389: let cast = tn t in
390: ce_cast cast (ce_dot (ge' e) "data")
391: | _ when isclass bbdfns t ->
392: let cast = tn t in
393: ce_cast cast (ce_dot (ge' e) "data")
394:
395: | _ ->
396: let cast = tn t ^ "*" in
397: ce_prefix "*" (ce_cast cast (ce_dot (ge' e) "data"))
398: end
399:
400: | `BEXPR_deref ((`BEXPR_ref (index,ts)),`BTYP_pointer t) ->
401: ge' (`BEXPR_name (index,ts),t)
402:
403: | `BEXPR_deref e ->
404: let cast = tn t ^ "*" in
405: ce_prefix "*" (ce_cast cast (ce_dot (ge' e) "get_data()"))
406:
407: | `BEXPR_new e ->
408: let ref_type = tn t in
409: let _,t' = e in
410: let pname = shape_of syms bbdfns tn t' in
411: let typ = tn t' in
412: let frame_ptr =
413: "new(*PTF gc,"^pname^") " ^
414: typ ^ "("^ge e ^")"
415: in
416: let reference = ref_type ^ "(" ^ frame_ptr ^ ")" in
417: ce_atom reference
418:
419:
420: | `BEXPR_literal v ->
421: if is_native_literal v
422: then ce_atom (cstring_of_literal v)
423: else
424: let t = tn t in
425: ce_atom (t ^ "(" ^ cstring_of_literal v ^ ")")
426:
427: | `BEXPR_case (v,t') ->
428: begin match unfold syms.dfns t' with
429: | `BTYP_unitsum n ->
430: if v < 0 or v >= n
431: then
432: failwith
433: (
434: "Invalid case index " ^ si v ^
435: " of " ^ si n ^ " cases in unitsum"
436: )
437: else ce_atom (si v)
438:
439: | `BTYP_sum ls ->
440: let s =
441: let n = length ls in
442: if v < 0 or v >= n
443: then
444: failwith
445: (
446: "Invalid case index " ^ si v ^
447: " of " ^ si n ^ " cases"
448: )
449: else let t' = nth ls v in
450: if t' = `BTYP_tuple []
451: then (* closure of const ctor is just the const value ???? *)
452: if is_unitsum t then
453: si v
454: else
455: "_uctor_(" ^ si v ^ ",0)"
456: else
457: failwith
458: (
459: "Can't handle closure of case " ^
460: si v ^
461: " of " ^
462: string_of_btypecode syms.dfns t
463: )
464: in ce_atom s
465:
466: | _ -> failwith "Case tag must have sum type"
467: end
468:
469: | `BEXPR_name (index,ts') ->
470: let id,parent,sr2,entry =
471: try Hashtbl.find bbdfns index
472: with _ ->
473: match
474: try Hashtbl.find syms.dfns index
475: with Not_found -> assert false
476: with
477: {id=id; sr=sr} -> syserr sr
478: ("[gen_expr(name)] Can't find "^ id ^ "<" ^ si index ^ ">")
479: in
480: let ts = map tsub ts' in
481: begin match entry with
482: | `BBDCL_val (_,`BTYP_function (`BTYP_void,_)) ->
483: let ptr = (get_var_ref syms bbdfns this index ts) in
484: ce_call (ce_arrow (ce_atom ptr) "apply") []
485:
486: | `BBDCL_var (_,t)
487: | `BBDCL_val (_,t)
488: | `BBDCL_ref (_,t)
489: | `BBDCL_tmp (_,t)
490: ->
491: ce_atom (get_var_ref syms bbdfns this index ts)
492:
493: | `BBDCL_const (_,_,ct,_) ->
494: begin match ct with
495: | `Identity -> syserr sr ("Nonsense Idendity const" ^ id)
496: | `Virtual -> clierr2 sr sr2 ("Instantiate virtual const" ^ id)
497: | `Str c
498: | `StrTemplate c when c = "#srcloc" ->
499: let filename, startline, startcol, endline, endcol = sr in
500: ce_atom ("flx::rtl::flx_range_srcref_t(" ^
501: string_of_string filename ^ "," ^
502: si startline ^ "," ^
503: si startcol ^ "," ^
504: si endline ^ "," ^
505: si endcol ^ ")"
506: )
507:
508: | `Str c when c = "#this" ->
509: begin match parent with
510: | None -> clierr sr "Use 'this' outside class"
511: | Some p ->
512: let name = cpp_instance_name syms bbdfns p ts in
513: (*
514: print_endline ("class = " ^ si p ^ ", instance name = " ^ name);
515: *)
516: ce_atom("ptr"^name)
517: end
518:
519: | `Str c
520: | `StrTemplate c when c = "#memcount" ->
521: let ts = map (lstrip syms.dfns) ts in
522: begin match ts with
523: | [`BTYP_void] -> ce_atom "0"
524: | [`BTYP_unitsum n]
525: | [`BTYP_array (_,`BTYP_unitsum n)] -> ce_atom (si n)
526: | [`BTYP_sum ls]
527: | [`BTYP_tuple ls] -> let n = length ls in ce_atom (si n)
528: | [`BTYP_inst (i,_)] ->
529: let _,_,_,entry = Hashtbl.find bbdfns i in
530: begin match entry with
531: | `BBDCL_struct (_,ls) -> let n = length ls in ce_atom (si n)
532: | `BBDCL_cstruct (_,ls) -> let n = length ls in ce_atom (si n)
533: | `BBDCL_union (_,ls) -> let n = length ls in ce_atom (si n)
534: | `BBDCL_class (_,ls) -> let n = length ls in ce_atom (si n)
535: | _ ->
536: clierr sr (
537: "#memcount function requires type with members to count, got: " ^
538: sbt syms.dfns (hd ts)
539: )
540: end
541: | _ ->
542: clierr sr (
543: "#memcount function requires type with members to count, got : " ^
544: sbt syms.dfns (hd ts)
545: )
546: end
547: | `Str c -> ce_expr "expr" c
548: | `StrTemplate c ->
549: let ts = map tn ts in
550: csubst sr sr2 c (ce_atom "Error") [] [] "Error" "Error" ts "expr" "Error" ["Error"] ["Error"] ["Error"]
551: end
552:
553: (* | `BBDCL_function (_,_,([s,(_,`BTYP_void)],_),_,[`BEXE_fun_return e]) -> *)
554: | `BBDCL_function (_,_,([],_),_,[`BEXE_fun_return (_,e)]) ->
555: ge' e
556:
557: | `BBDCL_cstruct _
558: | `BBDCL_struct _
559: | `BBDCL_reglex _
560: | `BBDCL_regmatch _
561: | `BBDCL_function _
562: | `BBDCL_procedure _
563: | `BBDCL_fun _
564: | `BBDCL_proc _ ->
565: syserr sr
566: (
567: "[gen_expr: name] Open function '" ^
568: id ^ "'<"^si index^
569: "> in expression (closure required)"
570: )
571: | _ ->
572: syserr sr
573: (
574: "[gen_expr: name] Cannot use this kind of name '"^
575: id^"' in expression"
576: )
577: end
578:
579: | `BEXPR_closure (index,ts') ->
580: (*
581: print_endline ("Generating closure of " ^ si index);
582: *)
583: let id,parent,sr,entry =
584: try Hashtbl.find bbdfns index
585: with _ -> failwith ("[gen_expr(name)] Can't find index " ^ si index)
586: in
587: (*
588: Should not be needed now ..
589: let ts = adjust_ts syms index ts' in
590: *)
591: let ts = map tsub ts' in
592: begin match entry with
593: | `BBDCL_function (props,_,_,_,_)
594: | `BBDCL_procedure (props,_,_,_) ->
595: let the_display =
596: let d' =
597: map (fun (i,vslen) -> "ptr"^ cpp_instance_name syms bbdfns i (list_prefix ts vslen))
598: (get_display_list syms bbdfns index)
599: in
600: if length d' > our_level
601: then "this" :: tl d'
602: else d'
603: in
604: let name = cpp_instance_name syms bbdfns index ts in
605: if mem `Cfun props then ce_atom name
606: else
607: ce_atom (
608: "(FLX_NEWP("^name^")" ^ strd the_display props ^")"
609: )
610:
611: | `BBDCL_callback _ ->
612: print_endline "Mapping closure of callback to C function pointer";
613: ce_atom id
614:
615: | `BBDCL_cstruct _
616: | `BBDCL_struct _
617: | `BBDCL_fun _
618: | `BBDCL_proc _ ->
619: failwith ("[gen_expr: closure] Can't wrap primitive proc, fun, or struct '"^id^"' yet")
620: | _ -> failwith ("[gen_expr: closure] Cannot use this kind of name '"^id^"' in expression")
621: end
622:
623: | `BEXPR_apply_method_stack (obj,meth,ts',a) ->
624: let id,parent,sr2,entry =
625: try Hashtbl.find bbdfns meth
626: with _ -> failwith ("[gen_expr(apply instance)] Can't find index " ^ si meth)
627: in
628: begin
629: (*
630: print_endline ("apply method closure of "^ id );
631: print_endline (" .. argument is " ^ string_of_bound_expression syms.dfns a);
632: *)
633: match entry with
634: | `BBDCL_function (props,_,_,_,_) ->
635: (*
636: print_endline ("Generating closure[apply method stack] of " ^ si meth);
637: *)
638: let ts = map tsub ts' in
639: let the_display =
640: let d' =
641: map (fun (i,vslen)-> "ptr"^ cpp_instance_name syms bbdfns i (list_prefix ts vslen))
642: (get_display_list syms bbdfns meth)
643: in
644: let d' = tl d' in (* throw out class pointer *)
645: if length d' > our_level
646: then "this" :: tl d'
647: else d'
648: in
649: let class_frame = ge obj in
650: let the_display = class_frame :: the_display in
651: let name = cpp_instance_name syms bbdfns meth ts in
652: ce_atom (
653: name ^ strd the_display props ^
654: "\n .apply(" ^ ge_arg a ^ ")"
655: )
656: | _ ->
657: failwith
658: (
659: "[gen_expr: apply_method_stack] Expected '"^id^"' to be generic function instance, got:\n" ^
660: string_of_bbdcl syms.dfns entry meth
661: )
662: end
663:
664: | `BEXPR_apply_method_direct (obj,meth,ts',a) ->
665: let id,parent,sr2,entry =
666: try Hashtbl.find bbdfns meth
667: with _ -> failwith ("[gen_expr(apply instance)] Can't find index " ^ si meth)
668: in
669: begin
670: (*
671: print_endline ("apply method closure of "^ id );
672: print_endline (" .. argument is " ^ string_of_bound_expression syms.dfns a);
673: *)
674: match entry with
675: | `BBDCL_function (props,_,_,_,_) ->
676: (*
677: print_endline ("Generating closure[apply method direct] of " ^ si meth);
678: *)
679: let ts = map tsub ts' in
680: let the_display =
681: let d' =
682: map (fun (i,vslen)-> "ptr"^ cpp_instance_name syms bbdfns i (list_prefix ts vslen))
683: (get_display_list syms bbdfns meth)
684: in
685: let d' = tl d' in (* throw out class pointer *)
686: if length d' > our_level
687: then "this" :: tl d'
688: else d'
689: in
690: let class_frame = ge obj in
691: let the_display = class_frame :: the_display in
692: let name = cpp_instance_name syms bbdfns meth ts in
693: if mem `Cfun props then failwith "Not expecting `Cfun for apply_method_direct" else
694: ce_atom (
695: "(FLX_NEWP("^name^")"^ strd the_display props ^")"^
696: "\n ->apply(" ^ ge_arg a ^ ")"
697: )
698:
699: | _ ->
700: failwith
701: (
702: "[gen_expr: apply_method_direct] Expected '"^id^"' to be generic function instance, got:\n" ^
703: string_of_bbdcl syms.dfns entry meth
704: )
705: end
706:
707: | `BEXPR_method_closure (e,index,ts') ->
708: (*
709: print_endline ("Generating method closure of " ^ si index);
710: *)
711: let id,parent,sr,entry =
712: try Hashtbl.find bbdfns index
713: with _ -> failwith ("[gen_expr(name)] Can't find index " ^ si index)
714: in
715: (*
716: Should not be needed now ..
717: let ts = adjust_ts syms index ts' in
718: *)
719: let ts = map tsub ts' in
720: begin match entry with
721: | `BBDCL_function (props,_,_,_,_)
722: | `BBDCL_procedure (props,_,_,_) ->
723: (*
724: print_endline ("Method " ^ id ^ (
725: if mem `Requires_ptf props then
726: " REQUIRES PTF" else " DOES NOT REQUIRE PTF"
727: )
728: );
729: *)
730: let the_display =
731: let d' =
732: map (fun (i,vslen) -> "ptr"^ cpp_instance_name syms bbdfns i (list_prefix ts vslen))
733: (get_display_list syms bbdfns index)
734: in
735: let d' = tl d' in (* throw out class pointer *)
736:
737: (*
738: print_endline ("Generated display is " ^ cat ", " d');
739: print_endline ("Display length = " ^ si (length d') ^ " .. our level = " ^ si our_level);
740: *)
741:
742: assert (length d' >= our_level);
743: if length d' > our_level
744: then "this" :: tl d'
745: else d'
746: in
747: (* A method closure requires the last entry in the display
748: to be the class. If we're cross calling from one
749: method to another, we should automatically get the
750: parent class environment, but I'm not sure ..
751: *)
752: let class_frame = ge e in
753: let the_display = class_frame :: the_display in
754: let name = cpp_instance_name syms bbdfns index ts in
755: if mem `Cfun props then failwith "Not expecting `Cfun for apply_method_direct" else
756: ce_atom (
757: "(FLX_NEWP("^name^")" ^ strd the_display props ^")"
758: )
759:
760: | `BBDCL_cstruct _
761: | `BBDCL_struct _
762: | `BBDCL_fun _
763: | `BBDCL_proc _ ->
764: failwith ("[gen_expr: closure] Can't wrap primitive proc, fun, or struct '"^id^"' yet")
765: | _ -> failwith ("[gen_expr: closure] Cannot use this kind of name '"^id^"' in expression")
766: end
767:
768: | `BEXPR_ref (index,ts') ->
769: let ts = map tsub ts' in
770: let t = lower t in
771: let ref_type = tn (lower t) in
772: let frame_ptr, var_ptr =
773: match t with
774: | `BTYP_tuple [] -> "NULL","0"
775: | _ ->
776: let parent = match Hashtbl.find bbdfns index with _,parent,sr,_ -> parent in
777: if Some this = parent &&
778: (
779: let props = match entry with
780: | `BBDCL_procedure (props,_,_,_)
781: | `BBDCL_function (props,_,_,_,_) -> props
782: | _ -> assert false
783: in
784: mem `Pure props && not (mem `Heap_closure props)
785: )
786: then
787: "NULL","&"^get_var_ref syms bbdfns this index ts ^"-NULL"
788: else
789: get_var_frame syms bbdfns this index ts,
790: "&" ^ get_var_ref syms bbdfns this index ts
791: in
792: let reference = ref_type ^
793: "(" ^ frame_ptr ^ ", " ^ var_ptr ^ ")"
794: in
795: ce_atom reference
796:
797: (* Hackery -- we allow a constructor with no
798: arguments to be applied to a unit anyhow
799: *)
800:
801: | `BEXPR_variant (s,((_,t') as e)) ->
802: print_endline ("Variant " ^ s);
803: print_endline ("Type " ^ sbt syms.dfns t);
804: let
805: arg_typename = tn t' and
806: union_typename = tn t
807: in
808: let aval =
809: if isclass bbdfns t' then ge_arg e else
810: "new (*PTF gc, "^arg_typename^"_ptr_map) " ^
811: arg_typename ^ "(" ^ ge_arg e ^ ")"
812: in
813: let ls = match t with
814: | `BTYP_variant ls -> ls
815: | _ -> failwith "[egen] Woops variant doesn't have variant type"
816: in
817: let vidx = match list_assoc_index ls s with
818: | Some i -> i
819: | None -> failwith "[egen] Woops, variant field not in type"
820: in
821: print_endline ("Index " ^ si vidx);
822: let uval = "_uctor_("^si vidx^"," ^ aval ^")" in
823: ce_atom uval
824:
825: | `BEXPR_coerce ((srcx,srct) as srce,dstt) ->
826: let srct = lstrip syms.dfns srct in
827: let vts =
828: match dstt with
829: | `BTYP_variant ls -> ls
830: | _ -> syserr sr "Coerce non-variant"
831: in
832: begin match srcx with
833: | `BEXPR_variant (s,argt) ->
834: print_endline "Coerce known variant!";
835: ge' (`BEXPR_variant (s,argt),t)
836: | _ ->
837: let i =
838: begin try
839: Hashtbl.find syms.variant_map (srct,dstt)
840: with Not_found ->
841: let i = !(syms.counter) in incr (syms.counter);
842: Hashtbl.add syms.variant_map (srct,dstt) i;
843: i
844: end
845: in
846: ce_atom ("_uctor_(vmap_"^si i^","^ge srce^")")
847: end
848:
849: | `BEXPR_apply
850: (
851: (`BEXPR_case (v,t),t'),
852: (a,t'')
853: ) ->
854: (* t is the type of the sum,
855: t' is the function type of the constructor,
856: t'' is the type of the argument
857: *)
858: let
859: arg_typename = tn (lower t'')
860: and
861: union_typename = tn (lower t)
862: in
863: let aval =
864: if isclass bbdfns t'' then ge_arg (a,t'') else
865: "new (*PTF gc, "^arg_typename^"_ptr_map) " ^
866: arg_typename ^ "(" ^ ge_arg (a,t'') ^ ")"
867: in
868: let uval =
869: if is_unitsum t then
870: si v
871: else
872: "_uctor_(" ^ si v ^ ", " ^ aval ^")"
873: in
874: let s = "(" ^ union_typename ^ ")" ^ uval in
875: ce_atom s
876:
877: (*
878: failwith
879: (
880: "Trapped application, case " ^
881: si v ^
882: " of " ^ string_of_btypecode syms.dfns t ^
883: "\ntype " ^ string_of_btypecode syms.dfns t' ^
884: "\nargument=" ^
885: string_of_bound_expression syms.dfns (a,t'') ^
886: "\ntype " ^ string_of_btypecode syms.dfns t''
887: )
888: *)
889:
890:
891: | `BEXPR_apply_prim (index,ts,(arg,argt as a)) ->
892: (*
893: print_endline ("Prim apply, arg=" ^ sbe syms.dfns a);
894: *)
895: let argt = tsub argt in
896: let id,parent,sr2,entry =
897: try Hashtbl.find bbdfns index
898: with _ -> failwith ("[gen_expr(apply instance)] Can't find index " ^ si index)
899: in
900: begin
901: match entry with
902: | `BBDCL_fun (props,vs,ps,retyp,ct,_,prec) ->
903: if length vs <> length ts then
904: failwith
905: (
906: "[get_expr:apply closure of fun] function " ^
907: id ^ "<" ^ si index ^">" ^
908: ", wrong number of args, expected vs = " ^
909: si (length vs) ^
910: ", got ts=" ^
911: si (length ts)
912: );
913: begin match ct with
914: | `Identity -> ge' a
915:
916: | `Virtual ->
917: let ts = map tsub ts in
918: let index', ts' = Flx_typeclass.fixup_typeclass_instance syms bbdfns index ts in
919: if index <> index' then
920: clierr sr ("Virtual call of " ^ si index ^ " dispatches to " ^ si index')
921: ;
922: if index = index' then
923: begin
924: let entries =
925: try Hashtbl.find syms.typeclass_to_instance index
926: with Not_found -> (* print_endline ("Symbol " ^ si index ^ " Not instantiated?"); *) []
927: in
928: iter
929: (fun (bvs,t,ts,j) -> print_endline ("Candidate Instance " ^ si j ^ "[" ^ catmap "," (sbt syms.dfns) ts ^ "]"))
930: entries
931: ;
932:
933: clierr2 sr sr2 ("Instantiate virtual function(2) " ^ id ^ "<" ^si index ^
934: ">, no instance for ts="^ catmap "," (sbt syms.dfns) ts
935: )
936: end;
937: begin let _,_,sr3,entry =
938: try Hashtbl.find bbdfns index'
939: with Not_found -> syserr sr ("MISSING INSTANCE BBDCL " ^ si index')
940: in
941: match entry with
942: | `BBDCL_fun _ -> ge' (`BEXPR_apply_prim (index',ts',a),t)
943: | `BBDCL_function _ -> ge' (`BEXPR_apply_direct (index',ts',a),t)
944: | _ ->
945: clierr2 sr sr3 ("expected instance to be function " ^ id)
946: end
947:
948: | `Str s -> ce_expr prec s
949: | `StrTemplate s ->
950: let ts = map tsub ts in
951: let retyp = reduce_type (beta_reduce syms sr (lstrip syms.dfns (tsubst vs ts retyp))) in
952: let retyp = tn retyp in
953: gen_prim_call syms bbdfns tsub ge'' s ts (arg,argt) retyp sr sr2 prec
954: end
955:
956: | `BBDCL_callback (props,vs,ps_cf,ps_c,_,retyp,_,_) ->
957: assert (retyp <> `BTYP_void);
958: if length vs <> length ts then
959: clierr sr "[gen_prim_call] Wrong number of type arguments"
960: ;
961: let ts = map tsub ts in
962: let s = id ^ "($a)" in
963: let retyp = reduce_type (beta_reduce syms sr (lstrip syms.dfns (tsubst vs ts retyp))) in
964: let retyp = tn retyp in
965: gen_prim_call syms bbdfns tsub ge'' s ts (arg,argt) retyp sr sr2 "atom"
966:
967: (* but can't be a Felix function *)
968: | _ ->
969: failwith
970: (
971: "[gen_expr: apply prim] Expected '"^id^"' to be primitive function instance, got:\n" ^
972: string_of_bbdcl syms.dfns entry index
973: )
974: end
975:
976: | `BEXPR_apply_struct (index,ts,a) ->
977: let id,parent,sr2,entry =
978: try Hashtbl.find bbdfns index
979: with _ -> failwith ("[gen_expr(apply instance)] Can't find index " ^ si index)
980: in
981: let ts = map tsub ts in
982: begin match entry with
983: | `BBDCL_cstruct (vs,_) ->
984: let name = tn (`BTYP_inst (index,ts)) in
985: ce_atom ("reinterpret<"^ name ^">(" ^ ge a ^ ")")
986:
987: | `BBDCL_struct (vs,cts) ->
988: let name = tn (`BTYP_inst (index,ts)) in
989: if length cts > 1 then
990: (* argument must be an lvalue *)
991: ce_atom ("reinterpret<"^ name ^">(" ^ ge a ^ ")")
992: else if length cts = 0 then
993: ce_atom (name ^ "()")
994: else
995: ce_atom (name ^ "(" ^ ge a ^ ")")
996:
997: | `BBDCL_nonconst_ctor (vs,uidx,udt,cidx,ct,evs, etraint) ->
998: (* due to some hackery .. the argument of a non-const
999: ctor can STILL be a unit .. prolly cause the stupid
1000: compiler is checking for voids for these pests,
1001: but units for sums .. hmm .. inconsistent!
1002: *)
1003: let ts = map tsub ts in
1004: let ct = reduce_type (beta_reduce syms sr (tsubst vs ts ct)) in
1005: let _,t = a in
1006: let t = reduce_type (beta_reduce syms sr (tsubst vs ts t)) in
1007: begin match ct with
1008: | `BTYP_tuple [] ->
1009: ce_atom ( "_uctor_(" ^ si cidx ^ ", NULL)")
1010:
1011: (* function types are already pointers .. any use of this
1012: should do a clone .. class types are also pointers ..
1013: *)
1014: | `BTYP_function _ ->
1015: ce_atom (
1016: "_uctor_(" ^ si cidx ^ ", " ^ ge a ^")"
1017: )
1018:
1019: | _ when isclass bbdfns ct ->
1020: ce_atom (
1021: "_uctor_(" ^ si cidx ^ ", " ^ ge a ^")"
1022: )
1023:
1024: | _ ->
1025: let ctt = tn ct in
1026: let ptrmap = shape_of syms bbdfns tn ct in
1027: let txt =
1028: "_uctor_(" ^ si cidx ^ ", new(*PTF gc,"^ ptrmap^")"^
1029: ctt ^"("^ ge a ^"))"
1030: in
1031: ce_atom txt
1032: end
1033: | _ -> assert false
1034: end
1035:
1036: | `BEXPR_apply_direct (index,ts,a) ->
1037: let ts = map tsub ts in
1038: let index', ts' = Flx_typeclass.fixup_typeclass_instance syms bbdfns index ts in
1039: if index <> index' then
1040: clierr sr ("Virtual call of " ^ si index ^ " dispatches to " ^ si index')
1041: ;
1042: if index <> index' then
1043: begin
1044: let _,_,sr3,entry =
1045: try Hashtbl.find bbdfns index'
1046: with Not_found -> syserr sr ("MISSING INSTANCE BBDCL " ^ si index')
1047: in
1048: match entry with
1049: | `BBDCL_fun _ -> ge' (`BEXPR_apply_prim (index',ts',a),t)
1050: | `BBDCL_function _ -> ge' (`BEXPR_apply_direct (index',ts',a),t)
1051: | _ ->
1052: clierr2 sr sr3 ("expected instance to be function " ^ id)
1053: end else
1054:
1055: let id,parent,sr2,entry =
1056: try Hashtbl.find bbdfns index
1057: with _ -> failwith ("[gen_expr(apply instance)] Can't find index " ^ si index)
1058: in
1059: begin
1060: (*
1061: print_endline ("apply closure of "^ id );
1062: print_endline (" .. argument is " ^ string_of_bound_expression syms.dfns a);
1063: *)
1064: match entry with
1065: | `BBDCL_regmatch (props,_,_,_,_)
1066: | `BBDCL_reglex (props,_,_,_,_,_)
1067: | `BBDCL_function (props,_,_,_,_) ->
1068: (*
1069: print_endline ("Generating closure[apply direct] of " ^ si index);
1070: *)
1071: let the_display =
1072: let d' =
1073: map (fun (i,vslen)-> "ptr"^ cpp_instance_name syms bbdfns i (list_prefix ts vslen))
1074: (get_display_list syms bbdfns index)
1075: in
1076: if length d' > our_level
1077: then "this" :: tl d'
1078: else d'
1079: in
1080: let name = cpp_instance_name syms bbdfns index ts in
1081: if mem `Cfun props
1082: then (* this is probably wrong because it doesn't split arguments up *)
1083: ce_call (ce_atom name) [ce_atom (ge_arg a)]
1084: else
1085: ce_atom (
1086: "(FLX_NEWP("^name^")"^ strd the_display props ^")"^
1087: "\n ->apply(" ^ ge_arg a ^ ")"
1088: )
1089:
1090: | `BBDCL_fun _ -> assert false
1091: (*
1092: ge' (`BEXPR_apply_prim (index,ts,a),t)
1093: *)
1094:
1095: | _ ->
1096: failwith
1097: (
1098: "[gen_expr: apply_direct] Expected '"^id^"' to be generic function instance, got:\n" ^
1099: string_of_bbdcl syms.dfns entry index
1100: )
1101: end
1102:
1103: | `BEXPR_apply_stack (index,ts,a) ->
1104: let ts = map tsub ts in
1105: let index', ts' = Flx_typeclass.fixup_typeclass_instance syms bbdfns index ts in
1106: if index <> index' then
1107: clierr sr ("Virtual call of " ^ si index ^ " dispatches to " ^ si index')
1108: ;
1109: if index <> index' then
1110: begin
1111: let _,_,sr3,entry =
1112: try Hashtbl.find bbdfns index'
1113: with Not_found -> syserr sr ("MISSING INSTANCE BBDCL " ^ si index')
1114: in
1115: match entry with
1116: | `BBDCL_fun _ -> ge' (`BEXPR_apply_prim (index',ts',a),t)
1117: | `BBDCL_function _ -> ge' (`BEXPR_apply_direct (index',ts',a),t)
1118: | _ ->
1119: clierr2 sr sr3 ("expected instance to be function " ^ id)
1120: end else
1121:
1122: let id,parent,sr2,entry =
1123: try Hashtbl.find bbdfns index
1124: with _ -> failwith ("[gen_expr(apply instance)] Can't find index " ^ si index)
1125: in
1126: begin
1127: (*
1128: print_endline ("apply closure of "^ id );
1129: print_endline (" .. argument is " ^ string_of_bound_expression syms.dfns a);
1130: *)
1131: match entry with
1132: | `BBDCL_function (props,vs,(ps,traint),retyp,_) ->
1133: let display = get_display_list syms bbdfns index in
1134: let name = cpp_instance_name syms bbdfns index ts in
1135:
1136: (* C FUNCTION CALL *)
1137: if mem `Pure props && not (mem `Heap_closure props) then
1138: let s =
1139: assert (length display = 0);
1140: match ps with
1141: | [] -> ""
1142: | [{pindex=ix; ptyp=t}] ->
1143: if Hashtbl.mem syms.instances (ix,ts)
1144: then ge_arg a
1145: else ""
1146:
1147: | _ ->
1148: begin match a with
1149: | `BEXPR_tuple xs,_ ->
1150: (*
1151: print_endline ("Arg to C function is tuple " ^ sbe syms.dfns a);
1152: *)
1153: fold_left2
1154: (fun s ((x,t) as xt) {pindex=ix} ->
1155: let x =
1156: if Hashtbl.mem syms.instances (ix,ts)
1157: then ge_arg xt
1158: else ""
1159: in
1160: if String.length x = 0 then s else
1161: s ^
1162: (if String.length s > 0 then ", " else "") ^ (* append a comma if needed *)
1163: x
1164: )
1165: ""
1166: xs ps
1167:
1168: | _,tt ->
1169: let tt = reduce_type (beta_reduce syms sr (lstrip syms.dfns (tsubst vs ts tt))) in
1170: (* NASTY, EVALUATES EXPR MANY TIMES .. *)
1171: let n = ref 0 in
1172: fold_left
1173: (fun s i ->
1174: (*
1175: print_endline ( "ps = " ^ catmap "," (fun (id,(p,t)) -> id) ps);
1176: print_endline ("tt=" ^ sbt syms.dfns tt);
1177: *)
1178: let t = nth_type tt i in
1179: let a' = `BEXPR_get_n (i,a),t in
1180: let x = ge_arg a' in
1181: incr n;
1182: if String.length x = 0 then s else
1183: s ^ (if String.length s > 0 then ", " else "") ^ x
1184: )
1185: ""
1186: (nlist (length ps))
1187: end
1188: in
1189: let s =
1190: if mem `Requires_ptf props then
1191: if String.length s > 0 then "FLX_FPAR_PASS " ^ s
1192: else "FLX_FPAR_PASS_ONLY"
1193: else s
1194: in
1195: ce_atom (name ^ "(" ^ s ^ ")")
1196: else
1197: let the_display =
1198: let d' =
1199: map (fun (i,vslen)-> "ptr"^ cpp_instance_name syms bbdfns i (list_prefix ts vslen))
1200: display
1201: in
1202: if length d' > our_level
1203: then "this" :: tl d'
1204: else d'
1205: in
1206: let s =
1207: name^ strd the_display props
1208: ^
1209: "\n .apply(" ^ ge_arg a ^ ")"
1210: in ce_atom s
1211:
1212: | _ ->
1213: failwith
1214: (
1215: "[gen_expr: apply_stack] Expected '"^id^"' to be generic function instance, got:\n" ^
1216: string_of_bbdcl syms.dfns entry index
1217: )
1218: end
1219:
1220: | `BEXPR_apply ((`BEXPR_closure (index,ts),_),a) ->
1221: assert false (* should have been factored out *)
1222:
1223: (* application of C function pointer, type
1224: f: a --> b
1225: *)
1226: | `BEXPR_apply ( (_,`BTYP_lvalue(`BTYP_cfunction _)) as f,a)
1227: | `BEXPR_apply ( (_,`BTYP_cfunction _) as f,a) ->
1228: ce_atom (
1229: (ge f) ^"(" ^ ge_arg a ^ ")"
1230: )
1231:
1232: (* General application*)
1233: | `BEXPR_apply (f,a) ->
1234: ce_atom (
1235: "("^(ge f) ^ ")->clone()\n ->apply(" ^ ge_arg a ^ ")"
1236: )
1237:
1238: | `BEXPR_record es ->
1239: let rcmp (s1,_) (s2,_) = compare s1 s2 in
1240: let es = sort rcmp es in
1241: let es = map snd es in
1242: let ctyp = tn (lower t) in
1243: ce_atom (
1244: ctyp ^ "(" ^
1245: fold_left
1246: (fun s e ->
1247: let x = ge_arg e in
1248: if String.length x = 0 then s else
1249: s ^
1250: (if String.length s > 0 then ", " else "") ^
1251: x
1252: )
1253: ""
1254: es
1255: ^
1256: ")"
1257: )
1258:
1259: | `BEXPR_tuple es ->
1260: (*
1261: print_endline ("Eval tuple " ^ sbe syms.dfns (e,t));
1262: *)
1263: (* just apply the tuple type ctor to the arguments *)
1264: begin match t with
1265: | `BTYP_array (t',`BTYP_unitsum n) ->
1266: let tuple =
1267: let t'' = `BTYP_tuple (map (fun _ -> t') (nlist n)) in
1268: let ctyp = raw_typename t'' in
1269: ce_atom (
1270: ctyp ^ "(" ^
1271: fold_left
1272: (fun s e ->
1273: let x = ge_arg e in
1274: if String.length x = 0 then s else
1275: s ^
1276: (if String.length s > 0 then ", " else "") ^
1277: x
1278: )
1279: ""
1280: es
1281: ^
1282: ")"
1283: )
1284: in
1285: (* cast a tuple which is an array type to an array *)
1286: let atyp = tn (lower t) in
1287: ce_call
1288: (ce_atom ("reinterpret<" ^ atyp ^">"))
1289: [tuple]
1290:
1291: | `BTYP_tuple _ ->
1292: let ctyp = tn (lower t) in
1293: ce_atom (
1294: ctyp ^ "(" ^
1295: fold_left
1296: (fun s e ->
1297: let x = ge_arg e in
1298: if String.length x = 0 then s else
1299: s ^
1300: (if String.length s > 0 then ", " else "") ^
1301: x
1302: )
1303: ""
1304: es
1305: ^
1306: ")"
1307: )
1308: | _ -> assert false
1309: end
1310:
1311: and gen_expr syms bbdfns this e vs ts sr =
1312: let e = Flx_maps.reduce_tbexpr bbdfns e in
1313: let s =
1314: try gen_expr' syms bbdfns this e vs ts sr
1315: with Unknown_prec p -> clierr sr
1316: ("[gen_expr] Unknown precedence name '"^p^"' in " ^ sbe syms.dfns e)
1317: in
1318: string_of_cexpr s
1319:
1320:
1: # 36 "./lpsrc/flx_elkgen.ipk"
2: open Flx_util
3: open Flx_ast
4: open Flx_types
5: open Flx_mtypes1
6: open Flx_mtypes2
7: open Flx_print
8: open Flx_typing
9: open Flx_name
10: open Flx_tgen
11: open Flx_unify
12: open Flx_csubst
13: open Flx_exceptions
14: open Flx_display
15: open List
16: open Flx_generic
17: open Flx_label
18: open Flx_unravel
19: open Flx_ogen
20: open Flx_ctypes
21: open Flx_cexpr
22: open Flx_maps
23: open Flx_egen
24: open Flx_pgen
25: open Flx_ctorgen
26:
27: let gen_elk_lexer filebase module_name syms bbdfns this sr ((_,t') as e) n =
28: let lexer_name = "ElkLex_"^si n in
29: let ge e = gen_expr syms bbdfns this e [] [] sr in
30: let tn t = cpp_typename syms t in
31: let get_token_fun_type = tn t' in
32:
33: let display = cal_display syms bbdfns (Some this) in
34: let frame_dcls =
35: " FLX_FMEM_DECL\n"
36: in
37: let display_string =
38: cat ""
39: (
40: map
41: (fun (i, vslen) ->
42: try
43: let instname = cpp_instance_name syms bbdfns i [] in
44: " " ^ instname ^ " *ptr" ^ instname ^ ";\n"
45: with _ -> failwith "Can't cal display name"
46: )
47: display
48: )
49: and ctor_dcl =
50: " "^lexer_name ^ "(\n" ^
51: " FLX_FPAR_DECL\n" ^
52: cat ""
53: (
54: map
55: (
56: fun (i,vslen) ->
57: let instname = cpp_instance_name syms bbdfns i [] in
58: " " ^ instname ^ "*,\n"
59: )
60: display
61: )^
62: " "^get_token_fun_type ^"\n );\n"
63: in
64: let filename = filebase ^ "_lexer_" ^ si n ^ ".hpp" in
65: if syms.compiler_options.print_flag then
66: print_endline ("Generating Elkhound lexer " ^ lexer_name ^ " in " ^ filename);
67:
68: let f = open_out filename in
69: let pe s = output_string f (s ^ "\n") in
70:
71: let token_type, token_type_name, token_id, cts =
72: match t' with
73: | `BTYP_function (`BTYP_tuple [],`BTYP_inst(i,[])) ->
74: let id,parent,sr',entry = Hashtbl.find bbdfns i in
75: let token_type = `BTYP_inst(i,[]) in
76: let token_type_name = tn token_type in
77: begin match entry with
78: | `BBDCL_union ([],cts) -> token_type, token_type_name, id, cts
79: | _ -> assert false
80: end
81: | _ -> assert false
82: in
83: pe ("#ifndef ELKLEX_"^si n);
84: pe ("#define ELKLEX_"^si n);
85: pe "#include \"elk_lexerint.h\"";
86: pe "";
87: pe ("struct "^lexer_name^": public LexerInterface {");
88: pe (" //frame");
89: pe frame_dcls;
90: pe (" //display");
91: pe display_string;
92: pe (" // constructor");
93: pe ctor_dcl;
94: pe (" " ^ get_token_fun_type ^ " get_token; // client token generator");
95: pe (" collector_t &gc; // Felix garbage collector");
96: pe " void setToken(); //fetch next token ";
97: pe (" "^lexer_name^" *init(); //prime the lexer");
98: pe "";
99: pe " //Elkhound API";
100: pe " static void nextToken(LexerInterface *lex);";
101: pe " NextTokenFunc getTokenFunc() const { return &nextToken; }";
102: pe " sm_string tokenDesc() const;";
103: pe " sm_string tokenKindDesc(int kind) const;";
104: pe "};";
105: pe "#endif";
106: close_out f;
107:
108: let filename = filebase ^ "_lexer_" ^ si n ^ ".cpp" in
109: let f = open_out filename in
110: let pe s = output_string f (s ^ "\n") in
111: pe ("#include \""^module_name^"_lexer_"^si n^".hpp\"");
112: pe ("//token type = " ^ token_type_name);
113: pe ("static char *"^token_id^"_desc["^si (length cts)^"]={");
114: iter (fun (nm,_,_) -> pe (" \""^nm^"\",")) cts;
115: pe ("};");
116: pe "";
117: (* FUDGE PROPERTY LIST *)
118: let props : property_t list = [`Uses_gc; `Requires_ptf] in
119: pe (gen_ctor syms bbdfns lexer_name display [] [get_token_fun_type,"get_token"] ["gc(*PTF gc)"] [] props);
120: pe ("sm_string " ^ lexer_name ^ "::tokenDesc() const { return tokenKindDesc(type); }");
121: pe "";
122: pe ("sm_string " ^ lexer_name ^ "::tokenKindDesc(int kind) const {");
123: pe (" return "^token_id^"_desc[kind];");
124: pe ("}");
125: pe "";
126: pe ("void " ^ lexer_name ^ "::setToken() {");
127: pe (" _uctor_ token = get_token->apply();");
128: pe (" type = token.variant;");
129: pe (" sval = (SemanticValue)token.data;");
130: pe ("}");
131: pe "";
132: pe ("void " ^ lexer_name ^ "::nextToken(LexerInterface *lex) {");
133: pe (" (("^lexer_name^"*)lex)->setToken();");
134: pe ("}");
135: pe "";
136: pe (lexer_name^" *"^lexer_name^"::init(){");
137: pe (" nextToken(this);");
138: pe (" return this;");
139: pe ("}");
140:
141: close_out f
142:
143: let gen_elk_parser filebase module_name syms bbdfns this sr t' n ii =
144: let filename = filebase ^ "_parser_" ^ si n ^ ".gr" in
145: let parser_name = "_" ^ si n in
146: if syms.compiler_options.print_flag then
147: print_endline ("Generating Elkhound parser " ^ filename)
148: ;
149: let f = open_out filename in
150: let pe s = output_string f (s ^ "\n") in
151: let ps s = output_string f s in
152: let ge_arg this ((x,t) as e) =
153: match t with
154: | `BTYP_tuple [] -> ""
155: | _ -> gen_expr syms bbdfns this e [] [] sr
156: in
157: let tn t = cpp_typename syms (reduce_type t) in
158: let string_of_bprod (n,g) =
159: (match n with | None -> "" | Some n -> cid_of_flxid n ^ ":") ^
160: (match g with
161: | `Term k ->
162: (match Hashtbl.find syms.dfns k with {id=id}->cid_of_flxid id)
163: | `Nonterm (k::_) ->
164: (match Hashtbl.find syms.dfns k with {id=id}->cid_of_flxid id)
165: | _ -> assert false
166: )
167: in
168: let print_production (this,p,xs) =
169: match xs with
170: | [`BEXE_fun_return (_,((_,t) as e))] ->
171: let t = tn t in
172: ps (" -> ");
173: ps (catmap " " string_of_bprod p);
174: pe "";
175: pe " {";
176: pe (" "^t^" *_x = new "^t^"(" ^ ge_arg this e ^ ");");
177: iter
178: (function
179: | Some n, `Nonterm _ -> pe (" delete " ^ n^";")
180: | _ -> ()
181: )
182: p;
183: pe (" return _x;");
184: pe " }";
185: | _ -> assert false
186: in
187: let set_of_list ii : IntSet.t = fold_left (fun s elt ->IntSet.add elt s) IntSet.empty ii in
188: let nts_of_prod p : IntSetSet.t =
189: fold_left
190: (fun x (_,k) -> match k with
191: | `Nonterm ii -> IntSetSet.add (set_of_list ii) x
192: | `Term _ -> x
193: )
194: IntSetSet.empty
195: p
196: in
197: let prod_of_glr i =
198: try
199: match Hashtbl.find bbdfns i with
200: | _,_,_,`BBDCL_glr (_,_,_,(p,_)) -> p
201: | id,_,_,entry -> failwith
202: ("Expected "^si i^"->BBDCL_glr, got " ^ string_of_bbdcl syms.dfns entry i)
203:
204: with Not_found -> failwith ("Can't find BBDCL_glr " ^ si i)
205: in
206: let nts_of_glr i : IntSetSet.t = nts_of_prod (prod_of_glr i) in
207: let nt_uses x : IntSetSet.t =
208: IntSet.fold
209: (fun i nts ->
210: IntSetSet.union nts (nts_of_glr i)
211: )
212: x
213: IntSetSet.empty
214: in
215: let make_closure ii =
216: let been_done = ref (IntSetSet.singleton (set_of_list ii)) in
217: let to_do = ref (nt_uses (set_of_list ii)) in
218: while not (IntSetSet.is_empty !to_do) do
219: let x = IntSetSet.choose !to_do in
220: to_do := IntSetSet.remove x !to_do;
221: if not (IntSetSet.mem x !been_done) then begin
222: been_done := IntSetSet.add x !been_done;
223: to_do := IntSetSet.union !to_do (nt_uses x)
224: end
225: done;
226: !been_done
227: in
228: let print_nonterm x =
229: let j = IntSet.choose x in
230: let id,parent,sr'',entry = Hashtbl.find bbdfns j in
231: begin match entry with
232: | `BBDCL_glr (_,_,t,(p,xs)) ->
233: let tt = tn t in
234: pe ("nonterm("^tt^"*) "^cid_of_flxid id^" {");
235: pe (" fun dup(x) { return new " ^ tt ^ "(*x); }");
236: pe (" fun del(x) { delete x; }");
237: IntSet.iter (fun i ->
238: let id,parent,sr'',entry = Hashtbl.find bbdfns i in
239: match entry with
240: | `BBDCL_glr (_,_,t,(p,xs)) -> print_production (i,p,xs)
241: | _ -> assert false
242: )
243: x;
244: pe "}";
245: | _ -> assert false
246: end
247: in
248: let display = cal_display syms bbdfns (Some this) in
249: let frame_dcls =
250: " FLX_FMEM_DECL"
251: in
252: let display_string =
253: cat ""
254: (
255: map
256: (fun (i,vslen) ->
257: try
258: let instname = cpp_instance_name syms bbdfns i [] in
259: " " ^ instname ^ " *ptr" ^ instname ^ ";\n"
260: with _ -> failwith "Can't cal display name"
261: )
262: display
263: )
264: and ctor_dcl =
265: " Elk" ^parser_name^
266: (if length display = 0
267: then "(FLX_FPAR_DECL_ONLY);\n"
268: else (
269: " (\n" ^
270: " FLX_FPAR_DECL\n " ^
271: cat ",\n"
272: (
273: map
274: (
275: fun (i,vslen) ->
276: let instname = cpp_instance_name syms bbdfns i [] in
277: " " ^ instname ^ "*"
278: )
279: display
280: )^
281: "\n );\n"
282: ))
283: in
284: begin match t' with
285: | `BTYP_function (`BTYP_tuple [],`BTYP_inst(i,[])) ->
286: let token_id,parent,sr',entry = Hashtbl.find bbdfns i in
287: let token_type = `BTYP_inst(i,[]) in
288: let token_type_name = tn token_type in
289: begin match entry with
290: | `BBDCL_union ([],cts) ->
291: let j = hd ii in
292: let id,parent,sr'',entry = Hashtbl.find bbdfns j in
293: begin match entry with
294: | `BBDCL_glr (props,_,t,(p,xs)) ->
295: let result_type = tn t in
296: pe ("//Elkhound parser Elk" ^ parser_name ^ " -> " ^ result_type);
297: pe ("//Token type " ^ token_id ^ " -> " ^ token_type_name);
298: pe "terminals {";
299: let i = ref 0 in
300: iter (fun (id,j,t) ->
301: pe (" " ^ si j^" : "^ cid_of_flxid id ^ ";")
302: )
303: cts;
304:
305: pe "";
306: iter (fun (id,_,t) ->
307: if t <> `BTYP_void then begin
308: pe (" token("^tn t^"*) " ^ cid_of_flxid id ^ "{");
309: pe (" fun dup(x) { return x; }");
310: pe (" fun del(x) {}");
311: pe ("}");
312: end
313: )
314: cts;
315:
316: pe "}";
317: pe "";
318: pe ("context_class Elk"^parser_name^": public UserActions {");
319: pe ("public:");
320: pe frame_dcls;
321: ps display_string;
322: pe ctor_dcl;
323: pe (" collector_t &gc;");
324: pe
325: (
326: (if t = `BTYP_tuple [] then "int" else "_uctor_") ^
327: " apply(LexerInterface *lex);"
328: );
329: pe "};";
330: pe "";
331: pe "impl_verbatim {";
332: pe (gen_ctor syms bbdfns ("Elk"^parser_name) display [] [] ["gc(*PTF gc)"] [] props);
333: pe "}";
334: pe "";
335: pe "impl_verbatim {";
336: pe "// Felix function to apply the parser to a lexer";
337: pe "// This returns a polymorphic option";
338: pe "// case 0- Parse failed";
339: pe "// case 1- Argument contains parser result";
340: pe ("// Type of parser result is " ^ sbt syms.dfns t);
341:
342: pe
343: (
344: (if t = `BTYP_tuple [] then "int" else "_uctor_") ^
345: " Elk"^parser_name^"::apply(LexerInterface *lex) {"
346: );
347: pe " _uctor_ result(0,0);";
348: pe " SemanticValue p=(SemanticValue)(void*)0;";
349: pe " GLR glr(this,this->makeTables());";
350: pe " glr.noisyFailedParse = true;";
351: pe " result.variant = glr.glrParse(*lex,p);";
352: pe "";
353: pe " if(result.variant==1)";
354:
355: if t = `BTYP_tuple [] then begin
356: pe " delete (void*)p;";
357: pe " return result.variant;";
358: end else begin
359: pe (" result.data =");
360: pe (" new(gc,"^shape_of syms bbdfns tn t^")");
361: pe (" "^result_type^"(*("^result_type^"*)(void*)p)");
362: pe (" ;");
363: pe (" delete ("^result_type^"*)(void*)p;");
364: pe " return result;";
365: end;
366: pe "}";
367: pe "}";
368: pe "";
369:
370: pe ("nonterm("^result_type^"*) elk"^parser_name^" {");
371: print_production (j,p,xs);
372: iter (fun i ->
373: let id,parent,sr'',entry = Hashtbl.find bbdfns i in
374: match entry with
375: | `BBDCL_glr (_,vs,t,(p,xs)) -> print_production (i,p,xs)
376: | _ -> assert false
377: )
378: (tl ii)
379: ;
380: pe "}";
381: let cls = make_closure ii in
382: IntSetSet.iter print_nonterm cls;
383: pe "//End grammar"
384:
385: | _ -> assert false (* must be glr *)
386: end
387:
388: | _ ->
389: clierr sr
390: "Parser function must have unit domain and return a non-polymorphic union"
391: end
392: | _ ->
393: clierr sr
394: "Parser function must have unit domain and return a non-polymorphic union"
395: end
396: ;
397: close_out f
398: ;
399: let elkhound = syms.compiler_options.elkhound in
400: let retval = Unix.system(elkhound ^ " -tr nolines " ^ filename) in
401: begin match retval with
402: | Unix.WEXITED 0 -> ()
403: | _ -> failwith "Error executing flx_elkhound"
404: end
405:
406: