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