1: # 2172 "./lpsrc/flx_types.ipk"
2: open Flx_util
3: open Flx_ast
4: open Flx_types
5: open Flx_srcref
6: open Big_int
7: open Flx_typing
8: open List
9:
10: let rec string_of_string s = Flx_string.c_quote_of_string s
11:
12: let string_of_char c =
13: if c = -1 then "<<EOF>>" else
14: if c < 32 || c > 126
15: then "\\x" ^ Flx_string.hex2 c
16: else String.make 1 (Char.chr c)
17:
18:
19: let suffix_of_type s = match s with
20: | "tiny" -> "t"
21: | "short" -> "s"
22: | "int" -> ""
23: | "long" -> "l"
24: | "vlong" -> "v"
25: | "utiny" -> "tu"
26: | "ushort" -> "su"
27: | "uint" -> ""
28: | "ulong" -> "lu"
29: | "uvlong" -> "vu"
30: | "int8" -> "i8"
31: | "int16" -> "i16"
32: | "int32" -> "i32"
33: | "int64" -> "i64"
34: | "uint8" -> "u8"
35: | "uint16" -> "u16"
36: | "uint32" -> "u32"
37: | "uint64" -> "u64"
38: | "float" -> "f"
39: | "double" -> ""
40: | "ldouble" -> "l"
41: | _ -> failwith ("[suffix_of_type] Unexpected Type " ^ s)
42:
43: let string_of_bigint x = string_of_big_int x
44:
45: let string_of_literal e = match e with
46: | `AST_int (s,i) -> (string_of_bigint i)^suffix_of_type s
47: | `AST_float (t,v) -> v ^ suffix_of_type t
48: | `AST_string s -> string_of_string s
49: | `AST_cstring s -> "c"^string_of_string s
50: | `AST_wstring s -> "w"^string_of_string s
51: | `AST_ustring s -> "u"^string_of_string s
52:
53: let rec string_of_qualified_name (n:qualified_name_t) =
54: let se e = string_of_expr e in
55: match n with
56: | `AST_the (sr,q) -> "the " ^ string_of_qualified_name q
57: | `AST_index (sr,name,idx) -> name ^ "<" ^ si idx ^ ">"
58: | `AST_void _ -> "void"
59: | `AST_name (_,name,ts) -> name ^
60: (
61: if List.length ts = 0 then ""
62: else "[" ^ catmap ", " string_of_typecode ts ^ "]"
63: )
64: | `AST_case_tag (_,v) -> "case " ^ si v
65: | `AST_typed_case (_,v,t) ->
66: "(case " ^ si v ^
67: " of " ^ string_of_typecode t ^ ")"
68:
69: | `AST_lookup (_,(e,name, ts)) -> "("^se e ^")::" ^ name ^
70: (if length ts = 0 then "" else
71: "[" ^ catmap ", " string_of_typecode ts ^ "]"
72: )
73: | `AST_callback (_,name) -> "callback " ^string_of_qualified_name name
74:
75: and string_of_suffixed_name (n:suffixed_name_t) =
76: match n with
77: | #qualified_name_t as n -> string_of_qualified_name n
78: | `AST_suffix (_,(name,suf)) ->
79: string_of_qualified_name name ^ " of (" ^ string_of_typecode suf ^ ")"
80:
81: and string_of_re re =
82: match re with
83: | REGEXP_seq (r1,r2) -> string_of_re r1 ^ " " ^ string_of_re r2
84: | REGEXP_alt (r1,r2) -> string_of_re r1 ^ " | " ^ string_of_re r2
85: | REGEXP_aster r -> "(" ^ string_of_re r ^ ")*"
86: | REGEXP_name s -> string_of_qualified_name s
87: | REGEXP_string s ->
88: let ss=Buffer.create (String.length s) in
89: Buffer.add_char ss '"';
90: for i = 0 to String.length s - 1 do
91: Buffer.add_string ss (string_of_char (Char.code s.[i]))
92: done;
93: Buffer.add_char ss '"';
94: Buffer.contents ss
95:
96:
97: | REGEXP_epsilon -> "epsilon"
98: | REGEXP_sentinel -> "sentinel"
99: | REGEXP_code e -> "<CODE " ^ string_of_expr e ^ ">"
100: | REGEXP_group (n,r) -> "(" ^ string_of_re r ^ " as " ^ n ^ ")"
101:
102: and string_of_expr (e:expr_t) =
103: let se e = string_of_expr e
104: and sme e = string_of_expr e
105: and sqn e = string_of_qualified_name e
106: in
107: match e with
108: | #suffixed_name_t as n -> string_of_suffixed_name n
109: | `AST_vsprintf (sr,s) -> "f"^string_of_string s
110: | `AST_ellipsis _ -> "..."
111: | `AST_noexpand (sr,e) -> "noexpand(" ^ string_of_expr e ^ ")"
112:
113: | `AST_letin (sr,(pat,e1, e2)) ->
114: "let " ^ string_of_letpat pat ^ " = " ^ se e1 ^ " in " ^ se e2
115: | `AST_coercion (_,(e,t)) ->
116: "(" ^ sme e ^ ":" ^
117: string_of_typecode t ^ ")"
118:
119: | `AST_expr (_,s,t) ->
120: "code ["^string_of_typecode t^"]" ^
121: "'" ^ s ^ "'"
122:
123: | `AST_cond (_,(e,b1,b2)) ->
124: "if " ^ se e ^
125: " then " ^ se b1 ^
126: " else " ^ se b2 ^
127: " endif"
128:
129: | `AST_typeof (_,e) -> "typeof("^se e^")"
130: | `AST_as (_,(e1, name)) -> "(" ^ se e1 ^ ") as " ^ name
131: | `AST_get_n (_,(n,e)) -> "get (" ^ si n ^ ", " ^se e^")"
132: | `AST_get_named_variable (_,(n,e)) -> "get (" ^ n ^ ", " ^se e^")"
133: | `AST_get_named_method (_,(n,mix,ts,e)) ->
134: "get (" ^ n ^ "<" ^ si mix ^">"^"["^catmap "," string_of_typecode ts^"], " ^
135: se e ^")"
136: | `AST_map (_,f,e) -> "map (" ^ se f ^ ") (" ^ se e ^ ")"
137: | `AST_deref (_,e) -> "*(" ^ se e ^ ")"
138: | `AST_lvalue (_,e) -> "lvalue" ^ "(" ^ se e ^ ")"
139: | `AST_ref (_,e) -> "&" ^ "(" ^ se e ^ ")"
140: | `AST_literal (_,e) -> string_of_literal e
141: | `AST_apply (_,(fn, arg)) -> "(" ^
142: sme fn ^ " " ^
143: sme arg ^
144: ")"
145:
146: | `AST_product (_,ts) ->
147: cat "*" (map se ts)
148:
149: | `AST_sum (_,ts) ->
150: cat "+" (map se ts)
151:
152: | `AST_setunion (_,ts) ->
153: cat "||" (map se ts)
154:
155: | `AST_setintersection (_,ts) ->
156: cat "&&" (map se ts)
157:
158: | `AST_orlist (_,ts) ->
159: cat " or " (map se ts)
160:
161: | `AST_andlist (_,ts) ->
162: cat " and " (map se ts)
163:
164: | `AST_arrow (_,(a,b)) ->
165: "(" ^ se a ^ " -> " ^ se b ^ ")"
166:
167: | `AST_longarrow (_,(a,b)) ->
168: "(" ^ se a ^ " --> " ^ se b ^ ")"
169:
170: | `AST_superscript (_,(a,b)) ->
171: "(" ^ se a ^ " ^ " ^ se b ^ ")"
172:
173: | `AST_method_apply (_,(fn, arg,ts)) -> "(" ^ fn ^
174: (match ts with
175: | [] -> ""
176: | _ -> "[" ^catmap "," string_of_typecode ts^ "]"
177: ) ^
178: " " ^
179: se arg ^
180: ")"
181:
182: | `AST_tuple (_,t) -> "(" ^ catmap ", " sme t ^ ")"
183:
184: | `AST_record (_,ts) -> "struct {" ^
185: catmap "; " (fun (s,e) -> s ^ "="^ sme e ^";") ts ^
186: "}"
187:
188: | `AST_record_type (_,ts) -> "struct {" ^
189: catmap "; " (fun (s,t) -> s ^ ":"^ string_of_typecode t ^";") ts ^
190: "}"
191:
192: | `AST_variant (_,(s,e)) -> "case " ^ s ^ " of (" ^ se e ^ ")"
193:
194: | `AST_variant_type (_,ts) -> "union {" ^
195: catmap "; " (fun (s,t) -> s ^ " of "^ string_of_typecode t ^";") ts ^
196: "}"
197:
198: | `AST_arrayof (_,t) -> "[|" ^ catmap ", " sme t ^ "|]"
199: | `AST_dot (_,(e,n,ts)) ->
200: "get_" ^ n ^
201: (match ts with | [] -> "" | _ -> "[" ^ catmap "," string_of_typecode ts^ "]")^
202: "(" ^ se e ^ ")"
203:
204: | `AST_lambda (_,(paramss,ret, sts)) ->
205: "(fun " ^
206: catmap " "
207: (fun ps -> "(" ^ string_of_parameters ps ^ ")") paramss
208: ^
209: (match ret with
210: | `TYP_none -> ""
211: | _ -> ": " ^string_of_typecode ret) ^
212: " = " ^
213: string_of_compound 0 sts ^ ")"
214:
215: | `AST_ctor_arg (_,(cn,e)) ->
216: "ctor_arg " ^ sqn cn ^ "(" ^
217: se e ^ ")"
218:
219: | `AST_case_arg (_,(n,e)) ->
220: "case_arg " ^ si n ^ "(" ^
221: se e ^ ")"
222:
223: | `AST_case_index (_,e) ->
224: "caseno (" ^ se e ^ ")"
225:
226: | `AST_match_ctor (_,(cn,e)) ->
227: "match_ctor " ^ sqn cn ^ "(" ^
228: se e ^ ")"
229:
230: | `AST_match_case (_,(v,e)) ->
231: "match_case " ^ si v ^ "(" ^
232: se e ^ ")"
233:
234: | `AST_sparse (_,e, nt,iis) ->
235: "parse " ^ se e ^ " with " ^ nt ^ " endmatch"
236:
237: | `AST_parse (_,e, ms) ->
238: "parse " ^ se e ^ " with\n" ^
239: catmap ""
240: (fun (_,p,e')->
241: " | " ^
242: string_of_production p ^
243: " => " ^
244: string_of_expr e' ^
245: "\n"
246: )
247: ms
248: ^ "endmatch"
249:
250: | `AST_match (_,(e, ps)) ->
251: "match " ^ se e ^ " with\n" ^
252: catmap "\n"
253: (fun (p,e')->
254: " | " ^
255: string_of_pattern p ^
256: " => " ^
257: string_of_expr e'
258: )
259: ps
260: ^
261: " endmatch"
262:
263: | `AST_type_match (_,(e, ps)) ->
264: "typematch " ^ string_of_typecode e ^ " with " ^
265: catmap "\n"
266: (fun (p,e')->
267: " | " ^
268: string_of_tpattern p ^
269: " => " ^
270: string_of_typecode e'
271: )
272: ps
273: ^
274: " endmatch"
275:
276: | `AST_macro_ctor (_,(s,e)) ->
277: "macro ctor " ^ s ^ string_of_expr e
278:
279: | `AST_macro_statements (_,ss) ->
280: "macro statements begin\n" ^
281: catmap "\n" (string_of_statement 1) ss ^ "\nend"
282:
283: | `AST_regmatch (_,(p1,p2, ps)) ->
284: "regmatch " ^ se p1 ^ " to " ^ se p2 ^ " with " ^
285: catmap "\n"
286: (fun (p,e')->
287: " | " ^
288: string_of_re p ^
289: " => " ^
290: string_of_expr e'
291: )
292: ps
293: ^
294: " endmatch"
295:
296: | `AST_string_regmatch (_,(s, ps)) ->
297: "regmatch " ^ se s ^ " with " ^
298: catmap "\n"
299: (fun (p,e')->
300: " | " ^
301: string_of_re p ^
302: " => " ^
303: string_of_expr e'
304: )
305: ps
306: ^
307: " endmatch"
308:
309: | `AST_reglex (_,(p1, p2, ps)) ->
310: "reglex " ^ se p1 ^ " to " ^ se p2 ^ " with " ^
311: catmap "\n"
312: (fun (p,e')->
313: " | " ^
314: string_of_re p ^
315: " => " ^
316: string_of_expr e'
317: )
318: ps
319: ^
320: " endmatch"
321:
322: (* precedences for type operators ..
323: 0 -- atomic
324: 0.5 -- indexing t[i]
325: 1 -- pointer
326: 2 -- application
327: 3 -- ^
328: 4 -- *
329: 5 -- +
330: 6 -- isin
331: 7 .. and
332: 8 .. or
333: 9 -- ->
334: 10 -- =>
335: 11 as, all
336: *)
337:
338:
339: and st prec tc : string =
340: let iprec,txt =
341: match tc with
342: | #suffixed_name_t as t -> 0,string_of_suffixed_name t
343: | `TYP_none -> 0,"<none>"
344: | `TYP_ellipsis-> 0,"..."
345: | `TYP_type_match (e,ps) -> 0,
346: "typematch " ^ string_of_typecode e ^ " with " ^
347: catmap ""
348: (fun (p,t) ->
349: "| " ^ string_of_tpattern p ^ " => " ^ string_of_typecode t
350: )
351: ps
352: ^
353: " endmatch"
354:
355: | `TYP_var i -> 0,"<var " ^ si i ^ ">"
356: | `TYP_unitsum k ->
357: 0,
358: begin match k with
359: | 0 -> "void"
360: | 1 -> "unit"
361: | 2 -> "bool"
362: | _ -> si k
363: end
364:
365: | `TYP_tuple ls ->
366: begin match ls with
367: | [] -> 0,"unit"
368: | _ -> 4, cat " * " (map (st 4) ls)
369: end
370:
371: | `TYP_record ls ->
372: begin match ls with
373: | [] -> 0,"unit"
374: | _ -> 0, "struct {" ^ catmap "" (fun (s,t)->s^":"^st 0 t ^"; ") ls ^ "}"
375: end
376:
377: | `TYP_variant ls ->
378: begin match ls with
379: | [] -> 0,"void"
380: | _ -> 0, "union {" ^ catmap "" (fun (s,t)->s^" of "^st 0 t ^"; ") ls ^ "}"
381: end
382:
383: | `TYP_sum ls ->
384: begin match ls with
385: | [] -> 0,"void"
386: | [`TYP_tuple[];`TYP_tuple[]] -> 0,"bool"
387: | _ -> 5,cat " + " (map (st 5) ls)
388: end
389:
390: | `TYP_typeset ls ->
391: begin match ls with
392: | [] -> 0,"void"
393: | _ -> 0,"{" ^ cat ", " (map (st 0) ls) ^ "}"
394: end
395:
396: | `TYP_intersect ls ->
397: begin match ls with
398: | [] -> 0,"unit"
399: | _ -> 9,cat " & " (map (st 9) ls)
400: end
401:
402: | `TYP_setintersection ls ->
403: begin match ls with
404: | [] -> 0,"void"
405: | _ -> 9,cat " && " (map (st 9) ls)
406: end
407:
408: | `TYP_setunion ls ->
409: begin match ls with
410: | [] -> 0,"unit"
411: | _ -> 9,cat " || " (map (st 9) ls)
412: end
413:
414: | `TYP_function (args, result) ->
415: 9,st 9 args ^ " -> " ^ st 9 result
416:
417: | `TYP_cfunction (args, result) ->
418: 9,st 9 args ^ " --> " ^ st 9 result
419:
420: | `TYP_array (vt,it) -> 3, st 1 vt ^ "^" ^ st 3 it
421:
422: | `TYP_pointer t -> 1,"&" ^ st 1 t
423: | `TYP_lvalue t -> 0,"lvalue[" ^ st 1 t ^"]"
424:
425: | `TYP_typeof e -> 0,"typeof(" ^ string_of_expr e ^ ")"
426: | `TYP_as (t,s) -> 11,st 11 t ^ " as " ^ s
427:
428: | `TYP_proj (i,t) -> 2,"proj_"^si i^" "^ st 2 t
429: | `TYP_dual t -> 2,"~"^ st 2 t
430: | `TYP_dom t -> 2,"dom "^ st 2 t
431: | `TYP_cod t -> 2,"cod "^st 2 t
432: | `TYP_case_arg (i,t) -> 2,"case_arg_"^si i^" "^st 2 t
433:
434: | `TYP_isin (t1,t2) -> 6,st 2 t1 ^ " isin " ^ st 6 t2
435:
436: | `TYP_apply (t1,t2) -> 2,st 2 t1 ^ " " ^ st 2 t2
437: | `TYP_type -> 0,"TYPE"
438: | `TYP_type_tuple ls ->
439: 4, cat ", " (map (st 4) ls)
440:
441: | `TYP_glr_attr_type qn ->
442: 0,"glr_attr_type(" ^string_of_qualified_name qn^ ")"
443:
444: | `TYP_typefun (args,ret,body) ->
445: 10,
446: (
447: "fun(" ^ cat ", "
448: (
449: map
450: (fun (n,t)-> n ^ ": " ^ st 10 t)
451: args
452: ) ^
453: "): " ^ st 0 ret ^ "=" ^ st 10 body
454: )
455: in
456: if iprec >= prec
457: then "(" ^ txt ^ ")"
458: else txt
459:
460: and string_of_typecode tc = st 99 tc
461:
462: and qualified_name_of_index_with_vs dfns index =
463: match Hashtbl.find dfns index with
464: | { id=id; vs=vs; parent=parent} ->
465: match parent with
466: | Some index' ->
467: qualified_name_of_index_with_vs dfns index' ^
468: id ^
469: print_ivs vs ^
470: "::"
471: | None -> ""
472: (* If this entity has no parent, its the root module,
473: and we don't bother to print its name as a prefix
474: *)
475:
476: and qualified_name_of_index' dfns index =
477: match Hashtbl.find dfns index with
478: | { id=id; parent=parent } ->
479: begin match parent with
480: | Some index' -> qualified_name_of_index_with_vs dfns index'
481: | None -> ""
482: end ^
483: id
484:
485: and qualified_name_of_index dfns index =
486: try qualified_name_of_index' dfns index ^ "<"^si index ^">"
487: with Not_found -> "index_"^ si index
488:
489:
490: (* fixppoint labeller .. very sloppy, ignores precedence .. *)
491: and get_label i =
492: if i = 0 then ""
493: else
494: let ch = Char.chr (i mod 26 + Char.code('a')-1) in
495: get_label (i/26) ^ String.make 1 ch
496:
497: and print_fixpoints depth fixlist =
498: match fixlist with
499: | (d,lab) :: t when d = depth ->
500: let txt,lst = print_fixpoints depth t in
501: " as " ^ lab ^ " " ^ txt, lst
502: | _ -> "", fixlist
503:
504: and sb dfns depth fixlist counter prec tc =
505: let sbt prec t = sb dfns (depth+1) fixlist counter prec t in
506: let iprec, term =
507: match tc with
508: | `BTYP_type_match (t,ps) ->
509: 0,
510: (
511: "typematch " ^
512: sbt 99 t ^
513: " with" ^
514: catmap ""
515: (fun ({pattern=p},t) ->
516: " | " ^ sbt 99 p ^ " => " ^ sbt 99 t
517: )
518: ps
519: ^
520: " endmatch"
521: )
522:
523: | `BTYP_fix i ->
524: 0,
525: (
526: try assoc (depth+i) !fixlist
527: with Not_found ->
528: incr counter; (* 'a is 1 anyhow .. *)
529: let lab = "fix" ^ si i ^ "_"^get_label !counter in
530: fixlist := (depth+i,lab) :: !fixlist;
531: lab
532: )
533:
534: | `BTYP_var (i,mt) -> 0,"<T" ^ si i ^ ":"^sbt 0 mt^">"
535: | `BTYP_inst (i,ts) ->
536: 0,qualified_name_of_index dfns i ^
537: (if List.length ts = 0 then "" else
538: "[" ^cat ", " (map (sbt 9) ts) ^ "]"
539: )
540:
541: | `BTYP_tuple ls ->
542: begin match ls with
543: | [] -> 0,"unit"
544: | [x] -> failwith ("UNEXPECTED TUPLE OF ONE ARGUMENT " ^ sbt 9 x)
545: | _ -> 4,cat " * " (map (sbt 4) ls)
546: end
547:
548: | `BTYP_record ls ->
549: begin match ls with
550: | [] -> 0,"unit"
551: | _ -> 0,"struct {"^catmap "" (fun (s,t)->s^":"^sbt 0 t^";") ls ^"}"
552: end
553:
554: | `BTYP_variant ls ->
555: begin match ls with
556: | [] -> 0,"void"
557: | _ -> 0,"union {"^catmap "" (fun (s,t)->s^" of "^sbt 0 t^";") ls ^"}"
558: end
559:
560: | `BTYP_unitsum k ->
561: begin match k with
562: | 0 -> 0,"/*unitsum*/void"
563: | 2 -> 0,"bool"
564: | _ -> 0,si k
565: end
566:
567: | `BTYP_sum ls ->
568: begin match ls with
569: | [] -> 9,"UNEXPECTED EMPTY SUM = void"
570: | [`BTYP_tuple[]; `BTYP_tuple[]] -> 0,"unexpected bool"
571: | [x] -> (* failwith *) (9,"UNEXPECTED SUM OF ONE ARGUMENT " ^ sbt 9 x)
572: | _ ->
573: if (all_units ls)
574: then
575: 0,si (length ls)
576: else
577: 5,cat " + " (map (sbt 5) ls)
578: end
579:
580: | `BTYP_typeset ls ->
581: begin match ls with
582: | [] -> 9,"UNEXPECTED EMPTY TYPESET = void"
583: | _ ->
584: 0,"{" ^ cat "," (map (sbt 0) ls) ^ "}"
585: end
586:
587: | `BTYP_intersect ls ->
588: begin match ls with
589: | [] -> 9,"/*intersect*/void"
590: | _ ->
591: 4,cat " and " (map (sbt 5) ls)
592: end
593:
594: | `BTYP_typesetintersection ls ->
595: begin match ls with
596: | [] -> 9,"/*typesetintersect*/void"
597: | _ ->
598: 4,cat " && " (map (sbt 5) ls)
599: end
600:
601: | `BTYP_typesetunion ls ->
602: begin match ls with
603: | [] -> 9,"/*typesetunion*/unit"
604: | _ ->
605: 4,cat " || " (map (sbt 5) ls)
606: end
607:
608: | `BTYP_function (args, result) ->
609: 6,(sbt 6 args) ^ " -> " ^ (sbt 6 result)
610:
611: | `BTYP_cfunction (args, result) ->
612: 6,(sbt 6 args) ^ " --> " ^ (sbt 6 result)
613:
614: | `BTYP_array (t1,t2) ->
615: begin match t2 with
616: | `BTYP_unitsum k -> 3, sbt 3 t1 ^"^"^si k
617: | _ -> 3, sbt 3 t1 ^"^"^sbt 3 t2
618: end
619:
620: | `BTYP_lvalue t -> 0,"lvalue[" ^ sbt 0 t ^"]"
621: | `BTYP_pointer t -> 1,"&" ^ sbt 1 t
622: | `BTYP_void -> 0,"void"
623:
624: | `BTYP_apply (t1,t2) -> 2,sbt 2 t1 ^ " " ^ sbt 2 t2
625: | `BTYP_type -> 0,"TYPE"
626: | `BTYP_type_tuple ls ->
627: 4, cat ", " (map (sbt 4) ls)
628:
629: | `BTYP_typefun (args,ret,body) ->
630: 8,
631: (
632: "fun (" ^ cat ", "
633: (
634: map
635: (fun (i,t)-> "T"^si i ^ ": " ^ sbt 8 t)
636: args
637: ) ^
638: "): " ^ sbt 0 ret ^ "=" ^ sbt 8 body
639: )
640: in
641: let txt,lst = print_fixpoints depth !fixlist in
642: fixlist := lst;
643: if txt = "" then
644: if iprec >= prec then "(" ^ term ^ ")"
645: else term
646: else
647: "(" ^ term ^ txt ^ ")"
648:
649: and string_of_btypecode (dfns:symbol_table_t) tc =
650: let fixlist = ref [] in
651: let term = sb dfns 0 fixlist (ref 0) 99 tc in
652: let bad = ref "" in
653: while List.length !fixlist > 0 do
654: match !fixlist with
655: | (d,v)::t ->
656: bad := !bad ^ " [Free Fixpoint " ^ si d ^ " " ^ v ^"]";
657: fixlist := t
658: | [] -> assert false
659: done;
660: term ^ !bad
661:
662: and sbt a b = string_of_btypecode a b
663:
664: and string_of_basic_parameters (ps: parameter_t list) =
665: cat
666: ", "
667: (map (fun (x,y)-> x ^ ": "^(string_of_typecode y)) ps)
668:
669: and string_of_parameters (ps:params_t) =
670: let ps, traint = ps in
671: cat
672: ", "
673: (map (fun (x,y)-> x ^ ": "^(string_of_typecode y)) ps)
674: ^
675: (match traint with
676: | Some x -> " where " ^ string_of_expr x
677: | None -> ""
678: )
679:
680: (*
681: and string_of_iparameters dfns ps =
682: let ps,traint = ps in
683: cat
684: ", "
685: (map (fun (x,(i,y))-> x ^ "["^si i^"]: "^(string_of_typecode y)) ps)
686: ^
687: (match traint with
688: | Some x -> " where " ^ sbe dfns x
689: | None -> ""
690: )
691: *)
692:
693: and string_of_basic_bparameters dfns ps : string =
694: catmap ","
695: (fun (x,(i,y))->
696: x ^ "["^si i^"]: "^(string_of_btypecode dfns y)
697: )
698: ps
699:
700: and string_of_bparameters dfns ps : string =
701: let ps, traint = ps in
702: string_of_basic_bparameters dfns ps
703: ^
704: (match traint with
705: | Some x -> " where " ^ sbe dfns x
706: | None -> ""
707: )
708:
709: and string_of_arguments ass =
710: catmap ", " string_of_expr ass
711:
712:
713: and string_of_component level (name, typ) =
714: spaces level ^ name ^ ": " ^ (string_of_typecode typ)
715:
716: and string_of_float_pat = function
717: | Float_plus (t,v) -> v ^ t
718: | Float_minus (t,v) -> "-" ^ v ^ t
719: | Float_inf -> "inf"
720: | Float_minus_inf -> "-inf"
721:
722: and string_of_tpattern p =
723: let sp p = string_of_tpattern p in
724: match p with
725: | `TPAT_function (p1,p2) -> sp p1 ^ " -> " ^ sp p2
726: | `TPAT_sum ps -> catmap " + " sp ps
727: | `TPAT_tuple ps -> catmap " * " sp ps
728: | `TPAT_pointer p -> "&" ^ sp p
729: | `TPAT_void -> "0"
730: | `TPAT_var s -> "?" ^ s
731: | `TPAT_name (s,ps) ->
732: s ^
733: (
734: match ps with
735: | [] -> ""
736: | ps -> "[" ^ catmap "," sp ps ^ "]"
737: )
738:
739: | `TPAT_as (p,s) -> sp p ^ " as " ^ s
740: | `TPAT_any -> "_"
741: | `TPAT_unitsum j -> si j
742: | `TPAT_type_tuple ps -> catmap ", " sp ps
743:
744: and string_of_pattern p =
745: let se e = string_of_expr e in
746: match p with
747: | `PAT_coercion (_,p,t) -> "(" ^ string_of_pattern p ^ ":" ^ string_of_typecode t ^ ")"
748: | `PAT_none _ -> "<none>"
749: | `PAT_nan _ -> "NaN"
750: | `PAT_int (_,t,i) -> string_of_bigint i ^ suffix_of_type t
751: | `PAT_int_range (_,t1,i1,t2,i2) ->
752: string_of_bigint i1 ^ suffix_of_type t1 ^
753: " .. " ^
754: string_of_bigint i2 ^ suffix_of_type t2
755:
756: | `PAT_string (_,s) -> string_of_string s
757: | `PAT_string_range (_,s1, s2) ->
758: string_of_string s1 ^ " .. " ^ string_of_string s2
759: | `PAT_float_range (_,x1, x2) ->
760: string_of_float_pat x1 ^ " .. " ^ string_of_float_pat x2
761: | `PAT_name (_,s) -> s
762: | `PAT_tuple (_,ps) -> "(" ^ catmap ", " string_of_pattern ps ^ ")"
763: | `PAT_any _ -> "any"
764: | `PAT_regexp (_,r,b) ->
765: "regexp " ^ string_of_string r ^
766: "(" ^ cat ", " b ^ ")"
767: | `PAT_const_ctor (_,s) -> "|" ^ string_of_qualified_name s
768: | `PAT_nonconst_ctor (_,s,p)-> "|" ^ string_of_qualified_name s ^ " " ^ string_of_pattern p
769: | `PAT_as (_,p,n) ->
770: begin match p with
771: | `PAT_any _ -> n
772: | _ ->
773: "(" ^ string_of_pattern p ^ " as " ^ n ^ ")"
774: end
775: | `PAT_when (_,p,e) -> "(" ^ string_of_pattern p ^ " when " ^ se e ^ ")"
776: | `PAT_record (_,ps) ->
777: "struct { " ^ catmap "; " (fun (s,p) -> s ^ "="^string_of_pattern p) ps ^"; }"
778:
779: and string_of_letpat p =
780: match p with
781: | `PAT_name (_,s) -> s
782: | `PAT_tuple (_,ps) -> "(" ^ catmap ", " string_of_letpat ps ^ ")"
783: | `PAT_any _ -> "_"
784: | `PAT_const_ctor (_,s) -> "|" ^ string_of_qualified_name s
785: | `PAT_nonconst_ctor (_,s,p)-> "|" ^ string_of_qualified_name s ^ " " ^ string_of_letpat p
786: | `PAT_as (_,p,n) -> "(" ^ string_of_pattern p ^ " as " ^ n ^ ")"
787: | `PAT_record (_,ps) ->
788: "struct { " ^ catmap "; " (fun (s,p) -> s ^ "="^string_of_pattern p) ps ^"; }"
789:
790: | _ -> failwith "unexpected pattern kind in let/in pattern"
791:
792: and string_of_compound level ss =
793: spaces level ^ "{\n" ^
794: catmap "\n" (string_of_statement (level+1)) ss ^ "\n" ^
795: spaces level ^ "}"
796:
797: and short_string_of_compound level ss =
798: match ss with
799: | [] -> "{}"
800: | _ -> "\n"^ string_of_compound level ss
801:
802: and string_of_asm_compound level ss =
803: spaces level ^ "{\n" ^
804: catmap "\n" (string_of_asm (level+1)) ss ^ "\n" ^
805: spaces level ^ "}"
806:
807: and short_string_of_asm_compound level ss =
808: match ss with
809: | [] -> "{}"
810: | _ -> "\n"^ string_of_asm_compound level ss
811:
812: and special_string_of_typecode ty = (* used for constructors *)
813: match ty with
814: | `TYP_tuple [] -> ""
815: | _ -> " of " ^ string_of_typecode ty
816:
817: and special_string_of_btypecode dfns ty = (* used for constructors *)
818: match ty with
819: | `BTYP_tuple [] -> ""
820: | _ -> " of " ^ string_of_btypecode dfns ty
821:
822: and string_of_macro_parameter_type = function
823: | Expr -> "fun"
824: | Ident -> "ident"
825: | Stmt -> "proc"
826:
827: and print_ixs = function
828: | [] -> ""
829: | ixs -> "[" ^ cat ", " ixs ^ "]"
830:
831: and string_of_maybe_tpattern = function
832: | `TPAT_any -> ""
833: | t -> ": " ^ string_of_tpattern t
834:
835: and print_ivs = function
836: | [] -> ""
837: | vs -> "[" ^ cat ", " (map (fun (name,ix,tpat) -> name ^ string_of_maybe_tpattern tpat) vs) ^ "]"
838:
839: and print_ivs_with_index = function
840: | [] -> ""
841: | vs -> "[" ^ cat ", " (map (fun (name,ix,tpat) -> name ^ "<"^si ix^">"^string_of_maybe_tpattern tpat) vs) ^ "]"
842:
843: and print_vs = function
844: | [] -> ""
845: | vs -> "[" ^ cat ", " (map (fun (name,tpat) -> name ^ string_of_maybe_tpattern tpat) vs) ^ "]"
846:
847: and print_bvs = function
848: | [] -> ""
849: | vs ->
850: "[" ^
851: cat ", "
852: (
853: map
854: (fun (s,i)-> s^"<"^si i^">" )
855: vs
856: ) ^
857: "]"
858:
859: and print_inst dfns = function
860: | [] -> ""
861: | ts ->
862: "[" ^
863: cat ", "
864: (
865: map (string_of_btypecode dfns) ts
866: ) ^
867: "]"
868:
869: and sl x = string_of_lvalue x
870: and string_of_lvalue (x,t) =
871: begin match x with
872: | `Val (sr,x) -> "val " ^ x
873: | `Var (sr,x) -> "var " ^ x
874: | `Name (sr,x) -> x
875: | `Skip (sr) -> "_"
876: | `List ls -> "(" ^ catmap ", " sl ls ^ ")"
877: | `Expr (sr,e) -> string_of_expr e
878: end ^
879: begin match t with
880: | Some t -> ":" ^ string_of_typecode t
881: | None -> ""
882: end
883:
884: and string_of_property = function
885: | `Recursive -> "recursive"
886: | `Inline -> "inline"
887: | `Generated s -> "generated " ^ s
888: | `NoInline -> "noinline"
889: | `Inlining_started -> "inlining_started"
890: | `Inlining_complete -> "inlining_complete"
891: | `Explicit_closure -> "explicit_closure_expression"
892: | `Stackable -> "stackable"
893: | `Unstackable -> "unstackable"
894: | `Heap_closure -> "heap_closure"
895: | `Stack_closure -> "stack_closure"
896: | `Pure -> "pure"
897: | `Uses_global_var-> "uses_global_var"
898: | `Requires_ptf -> "requires_thread_frame"
899: | `Not_requires_ptf -> "does_not_require_thread_frame"
900: | `Uses_gc -> "uses_gc"
901: | `Ctor -> "ctor"
902:
903: and string_of_properties ps =
904: match ps with
905: | [] -> ""
906: | ps -> catmap " " string_of_property ps
907:
908: and string_of_code_spec = function
909: | `StrTemplate s -> "\"" ^ s ^ "\""
910: | `Str s -> "c\"" ^ s ^ "\""
911:
912: and string_of_long_code_spec c =
913: let triple_quote = "\"\"\"" in
914: match c with
915: | `StrTemplate s -> triple_quote ^ s ^ triple_quote
916: | `Str s -> "c" ^ triple_quote ^ s ^ triple_quote
917:
918: and string_of_raw_req = function
919: | `Named_req s -> string_of_qualified_name s
920: | `Body_req c -> "body " ^ string_of_code_spec c
921: | `Header_req c -> "header " ^ string_of_code_spec c
922: | `Property_req s -> "property \"" ^ s ^ "\""
923: | `Package_req c -> "package " ^ string_of_code_spec c
924:
925: (* fairly lame excess brackets here *)
926: and string_of_raw_req_expr = function
927: | `RREQ_atom r -> string_of_raw_req r
928: | `RREQ_and (a,b) -> "(" ^ string_of_raw_req_expr a ^ ") and (" ^ string_of_raw_req_expr b ^")"
929: | `RREQ_or (a,b) -> "(" ^ string_of_raw_req_expr a ^ ") or (" ^ string_of_raw_req_expr b ^")"
930: | `RREQ_true -> "(true)"
931: | `RREQ_false -> "(false)"
932:
933: (* fairly lame excess brackets here *)
934: and string_of_named_req_expr = function
935: | `NREQ_atom r -> string_of_qualified_name r
936: | `NREQ_and (a,b) -> "(" ^ string_of_named_req_expr a ^ ") and (" ^ string_of_named_req_expr b ^")"
937: | `NREQ_or (a,b) -> "(" ^ string_of_named_req_expr a ^ ") or (" ^ string_of_named_req_expr b ^")"
938: | `NREQ_true -> "(true)"
939: | `NREQ_false -> "(false)"
940:
941: and string_of_raw_reqs x = match x with
942: | `RREQ_true -> "" (* required nothing *)
943: | x -> " requires " ^ string_of_raw_req_expr x
944:
945: and string_of_named_reqs x = match x with
946: | `NREQ_true -> "" (* requires nothing *)
947: | x -> " requires " ^ string_of_named_req_expr x
948:
949: and string_of_base_qual = function
950: | `Incomplete -> "incomplete"
951: | `Pod -> "pod"
952: | `GC_pointer -> "GC_pointer"
953:
954: and string_of_qual = function
955: | #base_type_qual_t as x -> string_of_base_qual x
956: | `Raw_needs_shape t -> "needs_shape(" ^ string_of_typecode t ^ ")"
957:
958: and string_of_bqual dfns = function
959: | #base_type_qual_t as x -> string_of_base_qual x
960: | `Bound_needs_shape t -> "needs_shape(" ^ string_of_btypecode dfns t ^ ")"
961:
962: and string_of_quals qs = catmap " " string_of_qual qs
963: and string_of_bquals dfns qs = catmap " " (string_of_bqual dfns) qs
964:
965: and string_of_ast_term level (term:ast_term_t) =
966: let sast level x = string_of_ast_term level x in
967: match term with
968: | `Statement_term s -> string_of_statement (level+1) s
969: | `Statements_term ss -> catmap "\n" (string_of_statement (level+1)) ss
970: | `Expression_term e -> string_of_expr e
971: | `Identifier_term s -> s
972: | `Keyword_term s -> s
973: | `Apply_term (t,ts) -> "apply("^ sast 0 t ^ ",(" ^ catmap ", " (sast 0) ts ^ "))"
974:
975: and string_of_class_component level mem =
976: let kind, name, mix,vs,ty,cc = match mem with
977: | `MemberVar (name,typ,cc) -> "var",name,None,[],typ,cc
978: | `MemberVal (name,typ,cc) -> "val",name,None,[],typ,cc
979: | `MemberFun (name,mix,vs,typ,cc) -> "fun",name,mix,vs,typ,cc
980: | `MemberProc (name,mix,vs,typ,cc) -> "proc",name,mix,vs,typ,cc
981: | `MemberCtor (name,mix,typ,cc) -> "ctor",name,mix,[],typ,cc
982: in
983: (spaces (level+1)) ^
984: kind ^ " " ^ name ^ print_vs vs ^ ": " ^ string_of_typecode ty ^
985: (match cc with None -> "" | Some cc -> string_of_code_spec cc) ^
986: ";"
987:
988: and string_of_typeclass_component level mem =
989: match mem with
990: | `TypeClassMemberFun (name,typ) ->
991: spaces level ^ "fun " ^ name ^ ": " ^
992: string_of_typecode typ ^ ";\n"
993:
994: | `TypeClassMemberProc (name,typ) ->
995: spaces level ^ "proc " ^ name ^ ": " ^
996: string_of_typecode typ ^ ";\n"
997:
998: and string_of_statement level s =
999: let se e = string_of_expr e in
1000: let sqn n = string_of_qualified_name n in
1001: match s with
1002: | `AST_seq (_,sts) -> catmap "" (string_of_statement level) sts
1003: (*
1004: | `AST_public (_,s,st) ->
1005: "\n" ^
1006: spaces level ^ "public '" ^ s ^ "'\n" ^
1007: string_of_statement (level+1) st
1008: *)
1009:
1010: | `AST_private (_,st) ->
1011: spaces level ^ "private " ^
1012: string_of_statement 0 st
1013:
1014: | `AST_export_fun (_,flx_name,cpp_name) ->
1015: spaces level ^
1016: "export fun " ^
1017: string_of_suffixed_name flx_name ^
1018: " as \"" ^ cpp_name ^ "\";"
1019:
1020: | `AST_export_type (_,flx_type,cpp_name) ->
1021: spaces level ^
1022: "export type (" ^
1023: string_of_typecode flx_type ^
1024: ") as \"" ^ cpp_name ^ "\";"
1025:
1026: | `AST_label (_,s) -> s ^ ":"
1027: | `AST_goto (_,s) -> spaces level ^ "goto " ^ s ^ ";"
1028:
1029: | `AST_assert (_,e) -> spaces level ^ "assert " ^ se e ^ ";"
1030:
1031: | `AST_apply_ctor (_,i1,f,a) ->
1032: spaces level ^ i1 ^ " <- new " ^ se f ^ "(" ^ se a ^ ");"
1033:
1034: | `AST_init (_,v,e) ->
1035: spaces level ^ v ^ " := " ^ se e ^ ";"
1036:
1037: | `AST_comment s -> spaces level ^ "// " ^ s
1038:
1039: | `AST_open (_,n) ->
1040: spaces level ^ "open " ^ sqn n ^ ";"
1041:
1042: | `AST_inject_module (_,n) ->
1043: spaces level ^ "include " ^ sqn n ^ ";"
1044:
1045: | `AST_include (_,s) ->
1046: spaces level ^ "include " ^ s ^ ";"
1047:
1048: | `AST_use (_,n,qn) ->
1049: spaces level ^ "use " ^ n ^ " = " ^ sqn qn ^ ";"
1050:
1051: | `AST_regdef (_,n,r) ->
1052: spaces level ^ "regdef " ^ n ^ " = " ^string_of_re r^";"
1053:
1054: | `AST_glr (_,n,t,ps) ->
1055: spaces level ^ "nonterm " ^ n ^ " : " ^string_of_typecode t ^
1056: catmap ""
1057: (fun (_,p,e')->
1058: spaces (level + 1) ^ " | " ^
1059: string_of_production p ^
1060: " => " ^
1061: string_of_expr e' ^
1062: "\n"
1063: )
1064: ps
1065: ^
1066: spaces level ^ ";"
1067:
1068:
1069: | `AST_type_alias (_,t1,vs,t2) ->
1070: spaces level ^ "type " ^ t1 ^ print_vs vs ^
1071: " = " ^
1072: string_of_typecode t2 ^ ";"
1073:
1074: | `AST_inherit (_,name,vs,qn) ->
1075: spaces level ^ "inherit " ^ name ^ print_vs vs ^
1076: " = " ^
1077: string_of_qualified_name qn ^ ";"
1078:
1079: | `AST_inherit_fun (_,name,vs,qn) ->
1080: spaces level ^ "inherit fun " ^ name ^ print_vs vs ^
1081: " = " ^
1082: string_of_qualified_name qn ^ ";"
1083:
1084: | `AST_untyped_module (_,name, vs,sts) ->
1085: spaces level ^ "module " ^ name ^
1086: " = " ^
1087: "\n" ^
1088: string_of_compound level sts
1089:
1090: | `AST_struct (_,name, vs, cs) ->
1091: let string_of_struct_component (name,ty) =
1092: (spaces (level+1)) ^ name ^ ": " ^ string_of_typecode ty ^ ";"
1093: in
1094: spaces level ^ "struct " ^ name ^ print_vs vs ^ " = " ^
1095: spaces level ^ "{\n" ^
1096: catmap "\n" string_of_struct_component cs ^ "\n" ^
1097: spaces level ^ "}"
1098:
1099: | `AST_cstruct (_,name, vs, cs) ->
1100: let string_of_struct_component (name,ty) =
1101: (spaces (level+1)) ^ name ^ ": " ^ string_of_typecode ty ^ ";"
1102: in
1103: spaces level ^ "cstruct " ^ name ^ print_vs vs ^ " = " ^
1104: spaces level ^ "{\n" ^
1105: catmap "\n" string_of_struct_component cs ^ "\n" ^
1106: spaces level ^ "}"
1107:
1108: | `AST_cclass (_,name, vs, cs) ->
1109: spaces level ^ "cclass " ^ name ^ print_vs vs ^ " = " ^
1110: spaces level ^ "{\n" ^
1111: catmap "\n" (string_of_class_component level) cs ^ "\n" ^
1112: spaces level ^ "}"
1113:
1114: | `AST_class (_,name, vs, sts) ->
1115: spaces level ^ "class " ^ name ^ print_vs vs ^ " = " ^
1116: string_of_compound level sts
1117:
1118: | `AST_union (_,name, vs,cs) ->
1119: let string_of_union_component (name,cval, ty) =
1120: (spaces (level+1)) ^ "|" ^ name ^
1121: (match cval with None -> "" | Some i -> "="^ si i) ^
1122: special_string_of_typecode ty
1123: in
1124: spaces level ^ "union " ^ name ^ print_vs vs ^ " = " ^
1125: spaces level ^ "{\n" ^
1126: catmap ";\n" string_of_union_component cs ^ "\n" ^
1127: spaces level ^ "}"
1128:
1129: | `AST_ctypes (_,names, quals, reqs) -> spaces level ^
1130: (match quals with [] ->"" | _ -> string_of_quals quals ^ " ") ^
1131: "ctypes " ^ catmap "," snd names ^
1132: string_of_raw_reqs reqs ^
1133: ";"
1134:
1135: | `AST_abs_decl (_,t,vs, quals, ct, reqs) -> spaces level ^
1136: (match quals with [] ->"" | _ -> string_of_quals quals ^ " ") ^
1137: "type " ^ t ^ print_vs vs ^
1138: " = " ^ string_of_code_spec ct ^
1139: string_of_raw_reqs reqs ^
1140: ";"
1141:
1142: | `AST_callback_decl (_,name,args,result, reqs) -> spaces level ^
1143: "callback " ^ name ^ ": " ^
1144: (string_of_typecode (`TYP_tuple args)) ^ " -> " ^
1145: (string_of_typecode result) ^
1146: string_of_raw_reqs reqs ^
1147: ";"
1148:
1149: | `AST_fun_decl (_,name,vs,args, result, code, reqs,prec) ->
1150: spaces level ^
1151: "fun " ^ name ^ print_vs vs ^
1152: ": " ^
1153: (string_of_typecode (`TYP_tuple args)) ^ " -> " ^
1154: (string_of_typecode result) ^
1155: " = " ^ string_of_code_spec code ^
1156: (if prec = "" then "" else ":"^prec^" ")^
1157: string_of_raw_reqs reqs ^
1158: ";"
1159:
1160: | `AST_const_decl (_,name,vs,typ, code, reqs) ->
1161: spaces level ^
1162: "const " ^ name ^
1163: ": " ^ string_of_typecode typ ^
1164: " = "^string_of_code_spec code^
1165: string_of_raw_reqs reqs ^
1166: ";"
1167:
1168: | `AST_insert (_,n,vs,s, ikind, reqs) ->
1169: spaces level ^
1170: (match ikind with
1171: | `Header -> "header "
1172: | `Body -> "body "
1173: | `Package -> "package "
1174: )
1175: ^n^print_vs vs^
1176: "\n" ^ string_of_code_spec s ^ " " ^
1177: string_of_raw_reqs reqs ^
1178: ";\n"
1179:
1180: | `AST_code (_,s) ->
1181: "code \n" ^ string_of_long_code_spec s ^ ";\n"
1182:
1183: | `AST_noreturn_code (_,s) ->
1184: "noreturn_code \n" ^ string_of_long_code_spec s ^ ";\n"
1185:
1186: | `AST_reduce (_,name, vs, ps, rsrc, rdst) ->
1187: spaces level ^
1188: "reduce " ^ name ^ print_vs vs ^
1189: "("^string_of_basic_parameters ps^"): "^
1190: string_of_expr rsrc ^ " => " ^ string_of_expr rdst ^
1191: ";\n"
1192:
1193: | `AST_axiom (_,name, vs, ps, rsrc) ->
1194: spaces level ^
1195: "axiom " ^ name ^ print_vs vs ^
1196: "("^string_of_basic_parameters ps^"): "^
1197: string_of_expr rsrc ^
1198: ";\n"
1199:
1200: | `AST_function (_,name, vs, ps, (res,post), props, ss) ->
1201: spaces level ^
1202: string_of_properties props ^
1203: "fun " ^ name ^ print_vs vs ^
1204: "("^string_of_parameters ps^"): "^string_of_typecode res^
1205: (match post with
1206: | None -> ""
1207: | Some x -> " when " ^ string_of_expr x
1208: )^
1209: "\n" ^
1210: string_of_compound level ss
1211:
1212: | `AST_curry (_,name, vs, pss, (res,traint) , kind, ss) ->
1213: spaces level ^
1214: (match kind with
1215: | `Function -> "fun "
1216: | `Object -> "obj "
1217: | `InlineFunction -> "inline fun "
1218: | `NoInlineFunction -> "noinline fun "
1219: | `Ctor -> "ctor "
1220: )
1221: ^
1222: name ^ print_vs vs ^
1223: catmap " "
1224: (fun ps ->
1225: "("^string_of_parameters ps^")"
1226: )
1227: pss
1228: ^
1229: ": "^string_of_typecode res^
1230: (match traint with
1231: | None -> ""
1232: | Some x -> " when " ^ string_of_expr x
1233: )^
1234: "\n" ^
1235: string_of_compound level ss
1236:
1237: | `AST_object (_,name, vs, ps, ss) ->
1238: spaces level ^
1239: "object " ^ name ^ print_vs vs ^
1240: "("^string_of_parameters ps^")\n" ^
1241: string_of_compound level ss
1242:
1243: | `AST_macro_val (_,names, e) ->
1244: spaces level ^
1245: "macro val " ^ String.concat ", " names ^ " = " ^
1246: se e ^
1247: ";"
1248:
1249: | `AST_macro_vals (_,name, es) ->
1250: spaces level ^
1251: "macro val " ^ name ^ " = " ^
1252: catmap ", " se es ^
1253: ";"
1254:
1255: | `AST_macro_var (_,names, e) ->
1256: spaces level ^
1257: "macro var " ^ String.concat ", " names ^ " = " ^
1258: se e ^
1259: ";"
1260:
1261: | `AST_macro_assign (_,names, e) ->
1262: spaces level ^
1263: "macro " ^ String.concat ", " names ^ " = " ^
1264: se e ^
1265: ";\n"
1266:
1267: | `AST_macro_name (_,lname, rname) ->
1268: spaces level ^
1269: "macro ident " ^ lname ^ " = " ^
1270: (match rname with | "" -> "new" | _ -> rname) ^
1271: ";"
1272:
1273: | `AST_macro_names (_,lname, rnames) ->
1274: spaces level ^
1275: "macro ident " ^ lname ^ " = " ^
1276: cat ", " rnames ^
1277: ";"
1278:
1279:
1280: | `AST_expr_macro (_,name, ps, e) ->
1281: let sps =
1282: map
1283: (fun (p,t) -> p ^ ":" ^ string_of_macro_parameter_type t)
1284: ps
1285: in
1286: spaces level ^
1287: "macro fun " ^ name ^
1288: "("^ cat ", " sps ^") = " ^
1289: se e ^
1290: ";"
1291:
1292: | `AST_stmt_macro (_,name, ps, ss) ->
1293: let sps =
1294: map
1295: (fun (p,t) -> p ^ ":" ^ string_of_macro_parameter_type t)
1296: ps
1297: in
1298: spaces level ^
1299: "macro proc " ^ name ^
1300: "("^ cat ", " sps ^") " ^
1301: short_string_of_compound level ss
1302:
1303: | `AST_macro_block (_,ss) ->
1304: spaces level ^
1305: "macro " ^
1306: short_string_of_compound level ss ^
1307: "}"
1308:
1309: | `AST_macro_forget (_,names) ->
1310: spaces level ^
1311: "macro forget" ^
1312: (
1313: match names with
1314: | [] -> ""
1315: | _ -> " "
1316: ) ^
1317: cat ", " names ^
1318: ";"
1319:
1320: | `AST_macro_label (_,id) ->
1321: "macro " ^ id ^ ":>\n"
1322:
1323: | `AST_macro_goto (_,id) ->
1324: "macro goto " ^ id ^ ";\n"
1325:
1326: | `AST_macro_ifgoto (_,e,id) ->
1327: "macro if "^se e^" goto " ^ id ^ ";\n"
1328:
1329: | `AST_macro_proc_return (_) ->
1330: "macro return;\n"
1331:
1332: | `AST_val_decl (_,name, vs,ty, value) ->
1333: spaces level ^
1334: "val " ^ name ^
1335: (
1336: match ty with
1337: | Some t -> ": " ^ string_of_typecode t
1338: | None -> ""
1339: )
1340: ^
1341: (
1342: match value with
1343: | Some e -> " = " ^ (se e)
1344: | None -> ""
1345: )
1346: ^ ";"
1347:
1348: | `AST_lazy_decl (_,name, vs,ty, value) ->
1349: spaces level ^
1350: "fun " ^ name ^
1351: (
1352: match ty with
1353: | Some t -> ": " ^ string_of_typecode t
1354: | None -> ""
1355: )
1356: ^
1357: (
1358: match value with
1359: | Some e -> " = " ^ (se e)
1360: | None -> ""
1361: )
1362: ^ ";"
1363:
1364: | `AST_var_decl (_,name, vs,ty, value) ->
1365: spaces level ^
1366: "var " ^ name ^
1367: (
1368: match ty with
1369: | Some t -> ": " ^ string_of_typecode t
1370: | None -> ""
1371: )
1372: ^
1373: (
1374: match value with
1375: | Some e -> " = " ^ (se e)
1376: | None -> ""
1377: )
1378: ^ ";"
1379:
1380: | `AST_macro_ifor (_,v,ids,sts) ->
1381: spaces level
1382: ^ "macro for ident " ^ v ^ " in " ^ cat "," ids ^ " do\n" ^
1383: catmap "\n" (string_of_statement (level +2)) sts ^
1384: spaces level ^ "done;"
1385:
1386: | `AST_macro_vfor (_,v,e,sts) ->
1387: let se e = string_of_expr e in
1388: spaces level
1389: ^ "macro for val " ^ String.concat ", " v ^ " in " ^ se e ^ " do\n" ^
1390: catmap "\n" (string_of_statement (level +2)) sts ^
1391: spaces level ^ "done;"
1392:
1393: | `AST_call (_,pr, args) ->
1394: spaces level
1395: ^ "call " ^ se pr ^ " " ^ se args ^ ";"
1396:
1397: | `AST_assign (_,name,l,r) ->
1398: spaces level
1399: ^ "call " ^ name ^ "(" ^ sl l ^ "," ^se r^");"
1400:
1401: | `AST_cassign (_,l,r) ->
1402: spaces level ^
1403: se l ^ " = " ^ se r ^ ";"
1404:
1405: | `AST_jump (_,pr, args) ->
1406: spaces level
1407: ^ "jump " ^ se pr ^ " " ^ se args ^ ";"
1408:
1409: | `AST_loop (_,pr, args) ->
1410: spaces level
1411: ^ "call " ^ pr ^ " " ^ se args ^ ";"
1412:
1413: | `AST_nop (_,s) -> spaces level ^ "{/*"^s^"*/;}"
1414:
1415: | `AST_ifgoto (_,e,lab) ->
1416: spaces level ^
1417: "if("^string_of_expr e^")goto " ^ lab ^ ";"
1418:
1419: (*
1420: | `AST_whilst (_,e,sts) ->
1421: spaces level ^
1422: "whilst "^string_of_expr e^" do\n" ^
1423: catmap "\n" (string_of_statement (level+1)) sts ^
1424: spaces level ^ "done;"
1425:
1426: | `AST_until (_,e,sts) ->
1427: spaces level ^
1428: "until "^string_of_expr e^" do\n" ^
1429: catmap "\n" (string_of_statement (level+1)) sts ^
1430: spaces level ^ "done;"
1431: *)
1432:
1433: | `AST_ifreturn (_,e) ->
1434: spaces level ^
1435: "if("^string_of_expr e^")return;"
1436:
1437: | `AST_ifdo (_,e,ss1,ss2) ->
1438: spaces level ^
1439: "if("^string_of_expr e^")do\n" ^
1440: catmap "\n" (string_of_statement (level+1)) ss1 ^
1441: spaces level ^ "else\n" ^
1442: catmap "\n" (string_of_statement (level+1)) ss2 ^
1443: spaces level ^ "done;"
1444:
1445: | `AST_ifnotgoto (_,e,lab) ->
1446: spaces level ^
1447: "if not("^string_of_expr e^")goto " ^ lab
1448:
1449: | `AST_fun_return (_,e) ->
1450: spaces level ^ "return " ^ (se e) ^ ";"
1451:
1452: | `AST_proc_return _ ->
1453: spaces level ^ "return;"
1454:
1455: | `AST_svc (_,name) ->
1456: spaces level ^ "read " ^ name ^ ";"
1457:
1458: | `AST_user_statement (_,name,term) ->
1459: let body = string_of_ast_term level term in
1460: spaces level ^ "User statement " ^ name ^ "\n" ^ body
1461:
1462: and string_of_compilation_unit stats =
1463: catmap "\n" (string_of_statement 0) stats
1464:
1465: and string_of_desugared stats =
1466: catmap "\n" (string_of_asm 0) stats
1467:
1468: and string_of_iface level s =
1469: let spc = spaces level in
1470: match s with
1471: | `IFACE_export_fun (flx_name,cpp_name) ->
1472: spc ^ "export fun " ^ string_of_suffixed_name flx_name ^
1473: " as \"" ^ cpp_name ^ "\";"
1474:
1475: | `IFACE_export_type (flx_type,cpp_name) ->
1476: spc ^ "export type (" ^ string_of_typecode flx_type ^
1477: ") as \"" ^ cpp_name ^ "\";"
1478:
1479: and string_of_symdef (entry:symbol_definition_t) name (vs:ivs_list_t) =
1480: let se e = string_of_expr e in
1481: let st t = string_of_typecode t in
1482: match entry with
1483: | `SYMDEF_regdef re ->
1484: "regexp " ^ name ^ " = " ^ string_of_re re ^ ";\n"
1485:
1486: | `SYMDEF_regmatch (ps,cls) ->
1487: "regmatch " ^ name ^ " with " ^
1488: catmap "" (fun (re,e) -> "| " ^ string_of_re re ^ " => " ^se e) cls ^
1489: "endmatch;\n"
1490:
1491: | `SYMDEF_reglex (ps,i,cls) ->
1492: "regmatch " ^ name ^ " with " ^
1493: catmap "" (fun (re,e) -> "| " ^ string_of_re re ^ " => " ^se e) cls ^
1494: "endmatch;\n"
1495:
1496:
1497: | `SYMDEF_glr(t,(p,sexes)) ->
1498: "nonterm " ^ name ^ " : " ^st t ^ " = | " ^
1499: string_of_reduced_production p ^
1500: " => " ^ " <exes> " ^
1501: ";"
1502:
1503: | `SYMDEF_const_ctor (uidx,ut,idx) ->
1504: st ut ^ " " ^
1505: name ^ print_ivs vs ^
1506: ";"
1507:
1508: | `SYMDEF_nonconst_ctor (uidx,ut,idx,argt) ->
1509: st ut ^ " " ^
1510: name ^ print_ivs vs ^
1511: " of " ^ st argt ^
1512: ";"
1513:
1514: | `SYMDEF_type_alias t ->
1515: "typedef " ^ name ^ print_ivs vs ^" = " ^ st t ^ ";"
1516:
1517: | `SYMDEF_inherit qn ->
1518: "inherit " ^ name ^ print_ivs vs ^" = " ^ string_of_qualified_name qn ^ ";"
1519:
1520: | `SYMDEF_inherit_fun qn ->
1521: "inherit fun " ^ name ^ print_ivs vs ^" = " ^ string_of_qualified_name qn ^ ";"
1522:
1523: | `SYMDEF_abs (quals,code, reqs) ->
1524: (match quals with [] ->"" | _ -> string_of_quals quals ^ " ") ^
1525: "type " ^ name ^ print_ivs vs ^
1526: " = " ^ string_of_code_spec code ^
1527: string_of_named_reqs reqs ^
1528: ";"
1529:
1530: | `SYMDEF_var (t) ->
1531: "var " ^ name ^ print_ivs vs ^":"^ st t ^ ";"
1532:
1533: | `SYMDEF_val (t) ->
1534: "val " ^ name ^ print_ivs vs ^":"^ st t ^ ";"
1535:
1536: | `SYMDEF_lazy (t,e) ->
1537: "fun " ^ name ^ print_ivs vs ^
1538: ": "^ st t ^
1539: "= " ^ se e ^
1540: ";"
1541:
1542: | `SYMDEF_parameter (t) ->
1543: "parameter " ^ name ^ print_ivs vs ^":"^ st t ^ ";"
1544:
1545: | `SYMDEF_typevar (t) ->
1546: "typevar " ^ name ^ print_ivs vs ^":"^ st t ^ ";"
1547:
1548: | `SYMDEF_const (t,ct, reqs) ->
1549: "const " ^ name ^ print_ivs vs ^":"^
1550: st t ^ " = " ^string_of_code_spec ct^
1551: string_of_named_reqs reqs ^
1552: ";"
1553:
1554: | `SYMDEF_union (cts) ->
1555: "union " ^ name ^ print_ivs vs ^ ";"
1556:
1557: | `SYMDEF_struct (cts) ->
1558: "struct " ^ name ^ print_ivs vs ^ ";"
1559:
1560: | `SYMDEF_cstruct (cts) ->
1561: "cstruct " ^ name ^ print_ivs vs ^ ";"
1562:
1563: | `SYMDEF_cclass (cts) ->
1564: "cclass " ^ name ^ print_ivs vs ^ ";"
1565:
1566: | `SYMDEF_typeclass (cts) ->
1567: "typeclass " ^ name ^ print_ivs vs ^ ";"
1568:
1569: | `SYMDEF_fun (props, pts,res,cts, reqs,prec) ->
1570: string_of_properties props ^
1571: "fun " ^ name ^ print_ivs vs ^
1572: ": " ^ st
1573: (
1574: `TYP_function
1575: (
1576: (
1577: match pts with
1578: | [x] -> x
1579: | x -> `TYP_tuple x
1580: )
1581: ,
1582: res
1583: )
1584: ) ^
1585: (if prec = "" then "" else ":"^prec^" ")^
1586: string_of_named_reqs reqs ^
1587: ";"
1588:
1589: | `SYMDEF_callback (props, pts,res,reqs) ->
1590: string_of_properties props ^
1591: "callback fun " ^ name ^ print_ivs vs ^
1592: ": " ^ st
1593: (
1594: `TYP_cfunction
1595: (
1596: (
1597: match pts with
1598: | [x] -> x
1599: | x -> `TYP_tuple x
1600: )
1601: ,
1602: res
1603: )
1604: ) ^
1605: string_of_named_reqs reqs ^
1606: ";"
1607:
1608: | `SYMDEF_insert (s,ikind, reqs) ->
1609: (match ikind with
1610: | `Header -> "header "
1611: | `Body -> "body "
1612: | `Package -> "package "
1613: ) ^
1614: name ^ print_ivs vs ^
1615: " "^ string_of_code_spec s ^
1616: string_of_named_reqs reqs ^
1617: ";\n"
1618:
1619: | `SYMDEF_reduce (ps,e1,e2) ->
1620: "reduce " ^ name ^ print_ivs vs ^ ";"
1621:
1622: | `SYMDEF_axiom (ps,e1) ->
1623: "axiom " ^ name ^ print_ivs vs ^ ";"
1624:
1625: | `SYMDEF_function (ps,res,props, es) ->
1626: let ps,traint = ps in
1627: string_of_properties props ^
1628: "fun " ^ name ^ print_ivs vs ^
1629: ": " ^ st
1630: (
1631: `TYP_function
1632: (
1633: (
1634: match map snd ps with
1635: | [x] -> x
1636: | x -> `TYP_tuple x
1637: )
1638: ,
1639: res
1640: )
1641: ) ^
1642: ";"
1643:
1644: | `SYMDEF_match_check (pat,(mvname,i))->
1645: "match_check " ^ name ^ " for " ^ string_of_pattern pat ^ ";"
1646:
1647: | `SYMDEF_module ->
1648: "module " ^ name ^ ";"
1649:
1650: | `SYMDEF_class ->
1651: "class " ^ name ^ ";"
1652:
1653: and string_of_exe level s =
1654: let spc = spaces level
1655: and se e = string_of_expr e
1656: in
1657: match s with
1658:
1659: | `EXE_goto s -> spc ^ "goto " ^ s ^ ";"
1660: | `EXE_assert e -> spc ^ "assert " ^ se e ^ ";"
1661: | `EXE_apply_ctor (i1,f,e) ->
1662: spc ^ i1 ^ " <- new " ^ se f ^
1663: "(" ^ se e ^ ");"
1664:
1665:
1666: | `EXE_ifgoto (e,s) -> spc ^
1667: "if(" ^ se e ^ ")goto " ^ s ^ ";"
1668:
1669: | `EXE_ifnotgoto (e,s) -> spc ^
1670: "if(not(" ^ se e ^ "))goto " ^ s ^ ";"
1671:
1672: | `EXE_label s -> s ^ ":"
1673:
1674: | `EXE_comment s -> spc ^
1675: "// " ^ s
1676:
1677: | `EXE_call (p,a) -> spc ^
1678: "call " ^
1679: se p ^ " " ^
1680: se a ^ ";"
1681:
1682: | `EXE_jump (p,a) -> spc ^
1683: "jump " ^
1684: se p ^ " " ^
1685: se a ^ ";"
1686:
1687: | `EXE_loop (p,a) -> spc ^
1688: "loop " ^
1689: p ^ " " ^
1690: se a ^ ";"
1691:
1692: | `EXE_svc v -> spc ^
1693: "_svc " ^ v
1694:
1695: | `EXE_fun_return x -> spc ^
1696: "return " ^ se x ^ ";"
1697:
1698: | `EXE_proc_return -> spc ^
1699: "return;"
1700:
1701: | `EXE_nop s -> spc ^
1702: "/*" ^ s ^ "*/"
1703:
1704: | `EXE_code s -> spc ^
1705: "code " ^ string_of_code_spec s
1706:
1707: | `EXE_noreturn_code s -> spc ^
1708: "noreturn_code " ^ string_of_code_spec s
1709:
1710: | `EXE_init (l,r) -> spc ^
1711: l ^ " := " ^ se r ^ ";"
1712:
1713: | `EXE_iinit ((l,i),r) -> spc ^
1714: l ^ "<"^si i^"> := " ^ se r ^ ";"
1715:
1716: | `EXE_assign (l,r) -> spc ^
1717: se l ^ " = " ^ se r ^ ";"
1718:
1719: and sbe dfns e = string_of_bound_expression dfns e
1720: and tsbe dfns e = string_of_bound_expression_with_type dfns e
1721:
1722: and string_of_bound_expression_with_type dfns ((e',t) as e) =
1723: string_of_bound_expression' dfns (tsbe dfns) e ^ ":" ^
1724: sbt dfns t
1725:
1726: and string_of_bound_expression dfns e =
1727: string_of_bound_expression' dfns (sbe dfns) e
1728:
1729: and string_of_bound_expression' dfns se e =
1730: let sid n = qualified_name_of_index dfns n in
1731: match fst e with
1732:
1733: | `BEXPR_parse (e,ii) -> "parse " ^ se e ^ " with <nt> endmatch"
1734:
1735: | `BEXPR_get_n (n,e') -> "(" ^ se e' ^ ").mem_" ^ si n
1736: | `BEXPR_get_named (i,e') -> "(" ^ se e' ^ ")." ^ sid i
1737:
1738: | `BEXPR_deref e -> "*("^ se e ^ ")"
1739: | `BEXPR_name (i,ts) -> sid i ^ print_inst dfns ts
1740: | `BEXPR_closure (i,ts) -> sid i ^ print_inst dfns ts
1741: | `BEXPR_method_closure (e,i,ts) -> se e ^ "." ^ sid i ^ print_inst dfns ts
1742: | `BEXPR_ref (i,ts) -> "&" ^ sid i ^ print_inst dfns ts
1743:
1744: | `BEXPR_literal e -> string_of_literal e
1745: | `BEXPR_apply (fn, arg) -> "(" ^
1746: se fn ^ " " ^
1747: se arg ^
1748: ")"
1749:
1750: | `BEXPR_apply_prim (i,ts, arg) -> "(" ^
1751: sid i ^ print_inst dfns ts ^ " " ^
1752: se arg ^
1753: ")"
1754:
1755: | `BEXPR_apply_direct (i,ts, arg) -> "(" ^
1756: sid i ^ print_inst dfns ts ^ " " ^
1757: se arg ^
1758: ")"
1759:
1760: | `BEXPR_apply_method_direct (obj,i,ts, arg) -> "(" ^
1761: se obj ^ " -> " ^ sid i ^ print_inst dfns ts ^ " " ^
1762: se arg ^
1763: ")"
1764:
1765:
1766: | `BEXPR_apply_struct (i,ts, arg) -> "(" ^
1767: sid i ^ print_inst dfns ts ^ " " ^
1768: se arg ^
1769: ")"
1770:
1771: | `BEXPR_apply_stack (i,ts, arg) -> "(" ^
1772: sid i ^ print_inst dfns ts ^ " " ^
1773: se arg ^
1774: ")"
1775:
1776: | `BEXPR_apply_method_stack (obj,i,ts, arg) -> "(" ^
1777: se obj ^ " -> " ^ sid i ^ print_inst dfns ts ^ " " ^
1778: se arg ^
1779: ")"
1780:
1781: | `BEXPR_tuple t -> "(" ^ catmap ", " se t ^ ")"
1782:
1783: | `BEXPR_record ts -> "struct { " ^
1784: catmap "" (fun (s,e)-> s^":"^ se e ^"; ") ts ^ "}"
1785:
1786: | `BEXPR_variant (s,e) -> "case " ^ s ^ " of (" ^ se e ^ ")"
1787:
1788: | `BEXPR_case (v,t) ->
1789: "case " ^ si v ^ " of " ^ string_of_btypecode dfns t
1790:
1791: | `BEXPR_match_case (v,e) ->
1792: "(match case " ^ si v ^ ")(" ^ se e ^ ")"
1793:
1794: | `BEXPR_case_arg (v,e) ->
1795: "(arg of case " ^ si v ^ " of " ^ se e ^ ")"
1796:
1797: | `BEXPR_case_index e ->
1798: "caseno (" ^ se e ^ ")"
1799:
1800: | `BEXPR_expr (s,t) ->
1801: "code ["^string_of_btypecode dfns t^"]" ^ "'" ^ s ^ "'"
1802:
1803: | `BEXPR_range_check (e1,e2,e3) ->
1804: "range_check(" ^ se e1 ^"," ^ se e2 ^"," ^se e3 ^ ")"
1805:
1806: | `BEXPR_coerce (e,t) -> se e ^ " : " ^ string_of_btypecode dfns t
1807:
1808: and string_of_biface dfns level s =
1809: let spc = spaces level in
1810: let se e = string_of_bound_expression dfns e in
1811: let sid n = qualified_name_of_index dfns n in
1812: match s with
1813: | `BIFACE_export_fun (_,index,cpp_name) ->
1814: spc ^ "export fun " ^ qualified_name_of_index dfns index ^
1815: " as \"" ^ cpp_name ^ "\";"
1816:
1817: | `BIFACE_export_type (_,btyp,cpp_name) ->
1818: spc ^ "export type (" ^ string_of_btypecode dfns btyp ^
1819: ") as \"" ^ cpp_name ^ "\";"
1820:
1821: and sbx dfns s = string_of_bexe dfns 0 s
1822:
1823: and string_of_bexe dfns level s =
1824: let spc = spaces level in
1825: let se e = string_of_bound_expression dfns e in
1826: let sid n = qualified_name_of_index dfns n in
1827: match s with
1828: | `BEXE_goto (_,s) -> spc ^ "goto " ^ s ^ ";"
1829:
1830: | `BEXE_assert (_,e) -> spc ^ "assert " ^ se e ^ ";"
1831: | `BEXE_assert2 (_,_,e) -> spc ^ "assert2 " ^ se e ^ ";"
1832:
1833: | `BEXE_axiom_check (_,e) -> spc ^ "axiom_check " ^ se e ^ ";"
1834:
1835: | `BEXE_halt (_,s) -> spc ^ "halt " ^ s ^ ";"
1836:
1837: | `BEXE_ifgoto (_,e,s) -> spc ^
1838: "if(" ^ se e ^ ")goto " ^ s ^ ";"
1839:
1840: | `BEXE_ifnotgoto (_,e,s) -> spc ^
1841: "if(not(" ^ se e ^ "))goto " ^ s ^ ";"
1842:
1843: | `BEXE_label (_,s) -> s ^ ":"
1844:
1845: | `BEXE_comment (_,s) -> spc ^
1846: "// " ^ s
1847:
1848: | `BEXE_call (_,p,a) -> spc ^
1849: "call " ^
1850: se p ^ " " ^
1851: se a ^ ";"
1852:
1853: | `BEXE_call_direct (_,i,ts,a) -> spc ^
1854: "directcall " ^
1855: sid i ^ print_inst dfns ts ^ " " ^
1856: se a ^ ";"
1857:
1858: | `BEXE_call_method_direct (_,obj,i,ts,a) -> spc ^
1859: "direct_method_call " ^
1860: se obj ^ "->" ^ sid i ^ print_inst dfns ts ^ " " ^
1861: se a ^ ";"
1862:
1863: | `BEXE_call_method_stack (_,obj,i,ts,a) -> spc ^
1864: "stack_method_call " ^
1865: se obj ^ "->" ^ sid i ^ print_inst dfns ts ^ " " ^
1866: se a ^ ";"
1867:
1868: | `BEXE_jump_direct (_,i,ts,a) -> spc ^
1869: "direct tail call " ^
1870: sid i ^ print_inst dfns ts ^ " " ^
1871: se a ^ ";"
1872:
1873: | `BEXE_call_stack (_,i,ts,a) -> spc ^
1874: "stackcall " ^
1875: sid i ^ print_inst dfns ts ^ " " ^
1876: se a ^ ";"
1877:
1878: | `BEXE_call_prim (_,i,ts,a) -> spc ^
1879: "primcall " ^
1880: sid i ^ print_inst dfns ts ^ " " ^
1881: se a ^ ";"
1882:
1883: | `BEXE_jump (_,p,a) -> spc ^
1884: "tail call " ^
1885: se p ^ " " ^
1886: se a ^ ";"
1887:
1888: | `BEXE_loop (_,p,a) -> spc ^
1889: "loop<" ^
1890: si p ^ "> " ^
1891: se a ^ ";"
1892:
1893: | `BEXE_svc (_,v) -> spc ^
1894: "_svc " ^ sid v
1895:
1896: | `BEXE_fun_return (_,x) -> spc ^
1897: "return " ^ se x ^ ";"
1898:
1899: | `BEXE_proc_return _ -> spc ^
1900: "return;"
1901:
1902: | `BEXE_nop (_,s) -> spc ^
1903: "/*" ^ s ^ "*/"
1904:
1905: | `BEXE_code (_,s) -> spc ^
1906: "code " ^ string_of_code_spec s
1907:
1908: | `BEXE_nonreturn_code (_,s) -> spc ^
1909: "non_return_code " ^ string_of_code_spec s
1910:
1911: | `BEXE_assign (_,l,r) -> spc ^
1912: se l ^ " = " ^ se r ^ ";"
1913:
1914: | `BEXE_init (_,l,r) -> spc ^
1915: sid l ^ " := " ^ se r ^ ";"
1916:
1917: | `BEXE_begin -> "{//begin"
1918:
1919: | `BEXE_end -> "}//end"
1920:
1921: | `BEXE_apply_ctor (sr,i0,i1,ts, i2, arg) -> spc ^
1922: sid i0 ^ " = new " ^ sid i1 ^ print_inst dfns ts ^ " " ^
1923: sid i2 ^ " (" ^ se arg ^ ");"
1924:
1925: | `BEXE_apply_ctor_stack (sr,i0,i1,ts, i2, arg) -> spc ^
1926: sid i0 ^ " = new " ^ sid i1 ^ print_inst dfns ts ^ " " ^
1927: sid i2 ^ " (" ^ se arg ^ ");/*stacked*/"
1928:
1929:
1930: and string_of_dcl level name seq vs (s:dcl_t) =
1931: let se e = string_of_expr e in
1932: let st t = string_of_typecode t in
1933: let sl = spaces level in
1934: let seq = match seq with Some i -> "<" ^ si i ^ ">" | None -> "" in
1935: match s with
1936: | `DCL_regdef re ->
1937: sl ^ "regexp " ^ name^seq ^ " = " ^ string_of_re re ^ ";\n"
1938:
1939: | `DCL_regmatch cls ->
1940: sl ^ "regmatch " ^ name^seq ^ " with " ^
1941: catmap "" (fun (re,e) -> "| " ^ string_of_re re ^ " => " ^string_of_expr e) cls ^
1942: "endmatch;\n"
1943:
1944: | `DCL_reglex cls ->
1945: sl ^ "reglex " ^ name^seq ^ " with " ^
1946: catmap "" (fun (re,e) -> "| " ^ string_of_re re ^ " => " ^string_of_expr e) cls ^
1947: "endmatch;\n"
1948:
1949:
1950: | `DCL_type_alias (t2) ->
1951: sl ^ "typedef " ^ name^seq ^ print_vs vs ^
1952: " = " ^ st t2 ^ ";"
1953:
1954: | `DCL_inherit qn ->
1955: sl ^ "inherit " ^ name^seq ^ print_vs vs ^
1956: " = " ^ string_of_qualified_name qn ^ ";"
1957:
1958: | `DCL_inherit_fun qn ->
1959: sl ^ "inherit fun " ^ name^seq ^ print_vs vs ^
1960: " = " ^ string_of_qualified_name qn ^ ";"
1961:
1962: | `DCL_module (asms) ->
1963: sl ^ "module " ^ name^seq ^ print_vs vs ^ " = " ^
1964: "\n" ^
1965: string_of_asm_compound level asms
1966:
1967: | `DCL_class (asms) ->
1968: sl ^ "class " ^ name^seq ^ print_vs vs ^ " = " ^
1969: "\n" ^
1970: string_of_asm_compound level asms
1971:
1972: | `DCL_struct (cs) ->
1973: let string_of_struct_component (name,ty) =
1974: (spaces (level+1)) ^ name^ ": " ^ st ty ^ ";"
1975: in
1976: sl ^ "struct " ^ name^seq ^ print_vs vs ^ " = " ^
1977: sl ^ "{\n" ^
1978: catmap "\n" string_of_struct_component cs ^ "\n" ^
1979: sl ^ "}"
1980:
1981: | `DCL_cstruct (cs) ->
1982: let string_of_struct_component (name,ty) =
1983: (spaces (level+1)) ^ name^ ": " ^ st ty ^ ";"
1984: in
1985: sl ^ "cstruct " ^ name^seq ^ print_vs vs ^ " = " ^
1986: sl ^ "{\n" ^
1987: catmap "\n" string_of_struct_component cs ^ "\n" ^
1988: sl ^ "}"
1989:
1990: | `DCL_cclass (cs) ->
1991: sl ^ "cclass " ^ name^seq ^ print_vs vs ^ " = " ^
1992: sl ^ "{\n" ^
1993: catmap "\n" (string_of_class_component level) cs ^ "\n" ^
1994: sl ^ "}"
1995:
1996: | `DCL_typeclass (cs) ->
1997: sl ^ "type class " ^ name^seq ^ print_vs vs ^ " = " ^
1998: sl ^ "{\n" ^
1999: catmap "" (string_of_typeclass_component level) cs ^
2000: sl ^ "}"
2001:
2002: | `DCL_union (cs) ->
2003: let string_of_union_component (name,v,ty) =
2004: (spaces (level+1)) ^
2005: "|" ^name^
2006: (match v with | None -> "" | Some i -> "="^si i) ^
2007: special_string_of_typecode ty
2008: in
2009: sl ^ "union " ^ name^seq ^ print_vs vs ^
2010: " = " ^
2011: sl ^ "{\n" ^
2012: catmap ";\n" string_of_union_component cs ^ "\n" ^
2013: sl ^ "}"
2014:
2015: | `DCL_abs (quals, code, reqs) -> sl ^
2016: (match quals with [] ->"" | _ -> string_of_quals quals ^ " ") ^
2017: "type " ^ name^seq ^ print_vs vs ^
2018: " = " ^ string_of_code_spec code ^
2019: string_of_named_reqs reqs ^
2020: ";"
2021:
2022: | `DCL_fun (props, args, result, code, reqs,prec) ->
2023: let argtype:typecode_t = type_of_argtypes args in
2024: let t:typecode_t = `TYP_function (argtype,result) in
2025: sl ^
2026: string_of_properties props ^
2027: "fun " ^ name^seq ^ print_vs vs ^
2028: ": " ^ st t ^
2029: " = " ^ string_of_code_spec code ^
2030: (if prec = "" then "" else ":"^prec^" ")^
2031: string_of_named_reqs reqs ^
2032: ";"
2033:
2034: | `DCL_callback (props, args, result, reqs) ->
2035: let argtype:typecode_t = type_of_argtypes args in
2036: let t:typecode_t = `TYP_cfunction (argtype,result) in
2037: sl ^
2038: string_of_properties props ^
2039: "callback fun " ^ name^seq ^ print_vs vs ^
2040: ": " ^ st t ^
2041: string_of_named_reqs reqs ^
2042: ";"
2043:
2044: | `DCL_insert (s,ikind, reqs) ->
2045: sl ^
2046: (match ikind with
2047: | `Header -> "header "
2048: | `Body -> "body "
2049: | `Package -> "package "
2050: ) ^
2051: name^seq ^ print_vs vs ^
2052: " = "^ string_of_code_spec s ^
2053: string_of_named_reqs reqs ^ ";"
2054:
2055: | `DCL_const (typ, code, reqs) ->
2056: sl ^
2057: "const " ^ name^seq ^print_vs vs ^
2058: ": " ^ st typ ^
2059: " = "^string_of_code_spec code^
2060: string_of_named_reqs reqs ^
2061: ";"
2062:
2063: | `DCL_reduce (ps, e1,e2) ->
2064: sl ^
2065: "reduce " ^ name^seq ^ print_vs vs ^
2066: "("^ string_of_basic_parameters ps ^"): " ^
2067: string_of_expr e1 ^ " => " ^ string_of_expr e2 ^ ";"
2068:
2069: | `DCL_axiom (ps, e1) ->
2070: sl ^
2071: "axiom " ^ name^seq ^ print_vs vs ^
2072: "("^ string_of_basic_parameters ps ^"): " ^
2073: string_of_expr e1 ^ ";"
2074:
2075: | `DCL_function (ps, res, props, ss) ->
2076: sl ^
2077: string_of_properties props ^
2078: "fun " ^ name^seq ^ print_vs vs ^
2079: "("^ (string_of_parameters ps)^"): "^(st res)^"\n" ^
2080: string_of_asm_compound level ss
2081:
2082:
2083: | `DCL_match_check (pat,(s,i)) ->
2084: sl ^
2085: "function " ^ name^seq ^ "() { " ^
2086: s ^ "<"^si i^"> matches " ^ string_of_pattern pat ^
2087: " }"
2088:
2089: | `DCL_match_handler (pat,(varname, i), sts) ->
2090: sl ^
2091: "match_handler " ^ name^seq ^
2092: "(" ^ string_of_pattern pat ^ ")" ^
2093: string_of_asm_compound level sts
2094:
2095: | `DCL_glr (t,(p,e')) ->
2096: sl ^ "nonterm " ^ name^seq ^ " : " ^st t ^
2097: spaces (level + 1) ^ " | " ^
2098: string_of_reduced_production p ^
2099: " => " ^
2100: string_of_expr e' ^
2101: ";"
2102:
2103: | `DCL_val (ty) ->
2104: sl ^
2105: "val " ^ name^seq ^ print_vs vs ^ ": " ^ st ty ^ ";"
2106:
2107: | `DCL_var (ty) ->
2108: sl ^
2109: "var " ^ name^seq ^ print_vs vs ^ ": " ^ st ty ^ ";"
2110:
2111: | `DCL_lazy (ty,e) ->
2112: sl ^
2113: "fun " ^ name^seq ^ print_vs vs ^
2114: ": " ^ st ty ^
2115: "= " ^ se e ^
2116: ";"
2117:
2118:
2119: and string_of_asm level s =
2120: match s with
2121: | Dcl (sr,name,seq,access,vs, d) ->
2122: (match access with
2123: | `Private -> "private "
2124: | `Public -> ""
2125: ) ^
2126: string_of_dcl level name seq vs d
2127: | Exe (sr,s) -> string_of_exe level s
2128: | Iface (sr,s) -> string_of_iface level s
2129: | Dir (sr,s) -> string_of_dir level s
2130:
2131: and string_of_dir level s =
2132: let sqn n = string_of_qualified_name n in
2133: match s with
2134: | DIR_open qn ->
2135: spaces level ^ "open " ^ sqn qn ^ ";"
2136:
2137: | DIR_use (n,qn) ->
2138: spaces level ^ "use " ^ n ^ " = " ^ sqn qn ^ ";"
2139:
2140: | DIR_inject_module qn ->
2141: spaces level ^ "include " ^ sqn qn ^ ";"
2142:
2143: and string_of_breq dfns (i,ts) = "rq<"^si i^">" ^ print_inst dfns ts
2144: and string_of_breqs dfns reqs = catmap ", " (string_of_breq dfns) reqs
2145: and string_of_production p = catmap " " string_of_glr_entry p
2146: and string_of_reduced_production p = catmap " " string_of_reduced_glr_entry p
2147: and string_of_bproduction dfns p = catmap " " (string_of_bglr_entry dfns) p
2148:
2149: and string_of_glr_term t = match t with
2150: | `GLR_name qn -> string_of_qualified_name qn
2151: | `GLR_opt t -> "[" ^ string_of_glr_term t ^ "]"
2152: | `GLR_ast t -> "{" ^ string_of_glr_term t ^ "}"
2153: | `GLR_plus t -> "(" ^ string_of_glr_term t ^ ")+"
2154: | `GLR_alt ts -> catmap " | " string_of_glr_term ts
2155: | `GLR_seq ts -> catmap " " string_of_glr_term ts
2156:
2157: and string_of_glr_entry (name,t) =
2158: (match name with
2159: | Some n -> n ^ ":"
2160: | None -> ""
2161: )^
2162: string_of_glr_term t
2163:
2164: and string_of_reduced_glr_entry (name,t) =
2165: (match name with
2166: | Some n -> n ^ ":"
2167: | None -> ""
2168: )^
2169: string_of_qualified_name t
2170:
2171: and string_of_bglr_entry dfns (name,symbol) =
2172: (match name with
2173: | Some n -> n ^ ":"
2174: | None -> ""
2175: )^
2176: (match symbol with
2177: | `Nonterm (i::_)
2178: | `Term i -> qualified_name_of_index dfns i
2179: | `Nonterm [] -> "<Undefined nonterminal>"
2180: )
2181:
2182: and string_of_bbdcl dfns (bbdcl:bbdcl_t) index : string =
2183: let name = qualified_name_of_index dfns index in
2184: let sobt t = string_of_btypecode dfns t in
2185: let se e = string_of_bound_expression dfns e in
2186: let un = `BTYP_tuple [] in
2187: match bbdcl with
2188: | `BBDCL_function (props,vs,ps,res,es) ->
2189: string_of_properties props ^
2190: "fun " ^ name ^ print_bvs vs ^
2191: "("^ (string_of_bparameters dfns ps)^"): "^(sobt res) ^
2192: "{\n" ^
2193: cat "\n" (map (string_of_bexe dfns 1) es) ^
2194: "}"
2195:
2196:
2197: | `BBDCL_procedure (props,vs,ps,es) ->
2198: string_of_properties props ^
2199: "proc " ^ name ^ print_bvs vs ^
2200: "("^ (string_of_bparameters dfns ps)^")" ^
2201: "{\n" ^
2202: cat "\n" (map (string_of_bexe dfns 1) es) ^
2203: "}"
2204:
2205: | `BBDCL_val (vs,ty) ->
2206: "val " ^ name ^ print_bvs vs ^ ": " ^ sobt ty ^ ";"
2207:
2208: | `BBDCL_var (vs,ty) ->
2209: "var " ^ name ^ print_bvs vs ^ ": " ^ sobt ty ^ ";"
2210:
2211: | `BBDCL_tmp (vs,ty) ->
2212: "tmp " ^ name ^ print_bvs vs ^ ": " ^ sobt ty ^ ";"
2213:
2214: (* binding structures [prolog] *)
2215: | `BBDCL_abs (vs,quals,code,reqs) ->
2216: (match quals with [] ->"" | _ -> string_of_bquals dfns quals ^ " ") ^
2217: "type " ^ name ^ print_bvs vs ^
2218: " = " ^ string_of_code_spec code ^ ";"
2219:
2220: | `BBDCL_const (vs,ty,code,reqs) ->
2221: "const " ^ name ^ print_bvs vs ^
2222: ": " ^ sobt ty ^
2223: " = "^string_of_code_spec code^
2224: string_of_breqs dfns reqs ^
2225: ";"
2226:
2227: | `BBDCL_fun (props,vs,ps,rt,code,reqs,prec) ->
2228: string_of_properties props ^
2229: "fun " ^ name ^ print_bvs vs ^
2230: ": " ^
2231: (sobt (typeoflist ps)) ^ " -> " ^
2232: (sobt rt) ^
2233: " = " ^ string_of_code_spec code ^
2234: (if prec = "" then "" else ":"^prec^" ")^
2235: string_of_breqs dfns reqs ^
2236: ";"
2237:
2238: | `BBDCL_callback (props,vs,ps_cf,ps_c,k,rt,reqs,prec) ->
2239: string_of_properties props ^
2240: "callback fun " ^ name ^ print_bvs vs ^
2241: ": " ^
2242: (sobt (typeoflist ps_cf)) ^ " -> " ^
2243: (sobt rt) ^
2244: " : " ^
2245: (if prec = "" then "" else ":"^prec^" ")^
2246: string_of_breqs dfns reqs ^
2247: ";"
2248:
2249: | `BBDCL_proc (props,vs, ps,code,reqs) ->
2250: string_of_properties props ^
2251: "proc " ^ name ^ print_bvs vs ^
2252: ": " ^
2253: (sobt (typeoflist ps)) ^
2254: " = " ^ string_of_code_spec code ^
2255: string_of_breqs dfns reqs ^
2256: ";"
2257:
2258: | `BBDCL_insert (vs,s,ikind,reqs) ->
2259: (match ikind with
2260: | `Header -> "header "
2261: | `Body -> "body "
2262: | `Package -> "package "
2263: ) ^
2264: name^ print_bvs vs ^
2265: " "^ string_of_code_spec s ^
2266: string_of_breqs dfns reqs
2267:
2268: | `BBDCL_union (vs,cs) ->
2269: let string_of_union_component (name,v,ty) =
2270: " " ^ "|" ^name ^
2271: "="^si v^
2272: special_string_of_btypecode dfns ty
2273: in
2274: "union " ^ name ^ print_bvs vs ^ " = " ^
2275: "{\n" ^
2276: catmap ";\n" string_of_union_component cs ^ "\n" ^
2277: "}"
2278:
2279: | `BBDCL_struct (vs,cs) ->
2280: let string_of_struct_component (name,ty) =
2281: " " ^ name ^ ": " ^ sobt ty ^ ";"
2282: in
2283: "struct " ^ name ^ print_bvs vs ^ " = " ^
2284: "{\n" ^
2285: catmap "\n" string_of_struct_component cs ^ "\n" ^
2286: "}"
2287:
2288: | `BBDCL_cstruct (vs,cs) ->
2289: let string_of_struct_component (name,ty) =
2290: " " ^ name ^ ": " ^ sobt ty ^ ";"
2291: in
2292: "cstruct " ^ name ^ print_bvs vs ^ " = " ^
2293: "{\n" ^
2294: catmap "\n" string_of_struct_component cs ^ "\n" ^
2295: "}"
2296:
2297: | `BBDCL_cclass (vs,cs) ->
2298: let string_of_class_component mem =
2299: let kind, name,bvs,ty =
2300: match mem with
2301: | `BMemberVal (name,ty) -> "val",name,[],ty
2302: | `BMemberVar (name,ty) -> "var",name,[],ty
2303: | `BMemberFun (name,bvs,ty) -> "fun",name,bvs,ty
2304: | `BMemberProc (name,bvs,ty) -> "proc",name,bvs,ty
2305: | `BMemberCtor (name,ty) -> "ctor",name,[],ty
2306: in
2307: kind ^ " " ^ name ^ print_bvs bvs ^ ": " ^ sobt ty ^ ";"
2308: in
2309: "cclass " ^ name ^ print_bvs vs ^ " = " ^
2310: "{\n" ^
2311: catmap "\n" string_of_class_component cs ^ "\n" ^
2312: "}"
2313:
2314: | `BBDCL_class (props,vs) ->
2315: string_of_properties props ^
2316: "class " ^ name ^ print_bvs vs ^ ";"
2317:
2318: | `BBDCL_glr (props,vs,t,(p,bexes)) ->
2319: " " ^ "nonterm " ^ name ^ print_bvs vs ^ " : " ^sobt t ^
2320: " | " ^
2321: string_of_bproduction dfns p ^
2322: " => " ^
2323: cat "\n" (map (string_of_bexe dfns 1) bexes) ^
2324: ";"
2325:
2326: | `BBDCL_regmatch (props,vs,ps,t,regargs) -> "regmatch.."
2327: | `BBDCL_reglex (props,vs,ps,i,t,regargs) -> "reglex.."
2328:
2329: | `BBDCL_nonconst_ctor (vs,uidx,ut,ctor_idx, ctor_argt) ->
2330: " uctor<" ^ name ^ ">"^ print_bvs vs ^
2331: " : " ^ sobt ut ^
2332: " of " ^ sobt ctor_argt ^
2333: ";"
2334:
2335:
2336: let string_of_dfn dfns i =
2337: match Hashtbl.find dfns i with
2338: | { id=id; sr=sr; vs=vs; symdef=entry } ->
2339: string_of_symdef entry id vs
2340: ^ " defined at " ^ short_string_of_src sr
2341:
2342: let full_string_of_entry_kind dfns i =
2343: string_of_dfn dfns i
2344:
2345: let string_of_entry_kind i = si i
2346:
2347: let string_of_entry_set = function
2348: | NonFunctionEntry x -> string_of_entry_kind x
2349: | FunctionEntry ls ->
2350: "{" ^
2351: catmap "," string_of_entry_kind ls ^
2352: "}"
2353:
2354: let full_string_of_entry_set dfns = function
2355: | NonFunctionEntry x -> full_string_of_entry_kind dfns x
2356: | FunctionEntry ls -> if length ls = 0 then "{}" else
2357: "{\n" ^
2358: catmap "\n" (full_string_of_entry_kind dfns) ls ^
2359: "\n}"
2360:
2361: let string_of_varlist dfns varlist =
2362: catmap ", " (fun (i,t)-> si i ^ "->" ^ sbt dfns t) varlist
2363:
2364: let print_env e =
2365: let print_entry k v =
2366: print_endline
2367: (
2368: " " ^ k ^ " " ^
2369: (
2370: match v with
2371: | (NonFunctionEntry (i)) -> string_of_int i
2372: | _ -> ""
2373: )
2374: )
2375: in
2376: let print_table htab =
2377: print_endline "--"; Hashtbl.iter print_entry htab
2378:
2379: in
2380: let print_level (index,id,htab,htabs) =
2381: print_string (id^"<"^si index^">");
2382: print_table htab;
2383: print_endline "OPENS:";
2384: List.iter print_table htabs;
2385: print_endline "ENDOFOPENS"
2386: in
2387:
2388: List.iter print_level e
2389:
2390: let print_env_short e =
2391: let print_level (index,id,htab,htabs) =
2392: print_endline (id^"<"^si index^">")
2393: in
2394: List.iter print_level e
2395:
2396: let print_function_body dfns id i exes =
2397: print_endline "";
2398: print_endline ("BODY OF " ^ id ^ "<" ^ si i ^ ">");
2399: iter
2400: (fun exe -> print_endline (string_of_bexe dfns 1 exe))
2401: exes
2402:
2403: let print_function dfns bbdfns i =
2404: match Hashtbl.find bbdfns i with (id,_,_,entry) ->
2405: match entry with
2406: | `BBDCL_function (_,_,_,_,exes)
2407: | `BBDCL_procedure (_,_,_,exes) ->
2408: print_function_body dfns id i exes
2409: | _ -> ()
2410:
2411: let print_functions dfns bbdfns =
2412: Hashtbl.iter
2413: (fun i (id,_,_,entry) -> match entry with
2414: | `BBDCL_function (_,_,_,_,exes)
2415: | `BBDCL_procedure (_,_,_,exes) ->
2416: print_function_body dfns id i exes
2417:
2418: | _ -> ()
2419: )
2420: bbdfns
2421: