5.11. Print module

Routines to print various terms.
Start ocaml section to src/flx_print.mli[1 /1 ]
     1: # 2319 "./lpsrc/flx_types.ipk"
     2: open Flx_ast
     3: open Flx_types
     4: val string_of_typecode : typecode_t -> string
     5: val string_of_btypecode : symbol_table_t -> btypecode_t -> string
     6: val sbt: symbol_table_t -> btypecode_t -> string
     7: val special_string_of_typecode : typecode_t -> string
     8: val string_of_expr : expr_t -> string
     9: val string_of_bound_expression :
    10:   symbol_table_t ->
    11:   tbexpr_t ->
    12:   string
    13: val string_of_bound_expression_with_type :
    14:   symbol_table_t ->
    15:   tbexpr_t ->
    16:   string
    17: val sbe:
    18:   symbol_table_t ->
    19:   tbexpr_t ->
    20:   string
    21: val tsbe:
    22:   symbol_table_t ->
    23:   tbexpr_t ->
    24:   string
    25: 
    26: val string_of_properties : property_t list -> string
    27: 
    28: val string_of_pattern : pattern_t -> string
    29: val string_of_tpattern : tpattern_t -> string
    30: val string_of_literal : literal_t -> string
    31: val string_of_parameters : params_t -> string
    32: val string_of_arguments : expr_t list -> string
    33: val string_of_statement : int -> statement_t -> string
    34: val string_of_compilation_unit : compilation_unit_t -> string
    35: val string_of_desugared : asm_t list -> string
    36: val string_of_suffixed_name : suffixed_name_t -> string
    37: val string_of_qualified_name : qualified_name_t -> string
    38: val string_of_dcl : int -> id_t -> int option -> vs_list_t -> dcl_t -> string
    39: val string_of_bexe : symbol_table_t -> int -> bexe_t -> string
    40: val sbx: symbol_table_t -> bexe_t -> string
    41: val string_of_exe : int -> exe_t -> string
    42: val qualified_name_of_index : symbol_table_t -> int -> string
    43: val string_of_bbdcl :
    44:   symbol_table_t ->
    45:   bbdcl_t ->
    46:   int ->
    47:   string
    48: 
    49: val string_of_symdef :
    50:   symbol_definition_t -> string -> ivs_list_t ->
    51:   string
    52: 
    53: val string_of_entry_kind:
    54:   entry_kind_t -> string
    55: 
    56: val full_string_of_entry_kind:
    57:   symbol_table_t -> entry_kind_t -> string
    58: 
    59: val string_of_entry_set:
    60:   entry_set_t -> string
    61: 
    62: val full_string_of_entry_set:
    63:   symbol_table_t -> entry_set_t -> string
    64: 
    65: val print_name_table:
    66:   symbol_table_t -> name_map_t -> unit
    67: 
    68: val string_of_myentry:
    69:   symbol_table_t -> entry_kind_t -> string
    70: 
    71: val string_of_varlist:
    72:   symbol_table_t ->
    73:   (int * btypecode_t) list ->
    74:   string
    75: 
    76: val string_of_bigint: bigint -> string
    77: 
    78: val print_env: env_t -> unit
    79: val print_env_short: env_t -> unit
    80: 
    81: val print_functions:
    82:   symbol_table_t ->
    83:   fully_bound_symbol_table_t ->
    84:   unit
    85: 
    86: val print_function_body:
    87:   symbol_table_t ->
    88:   string -> int -> bvs_t -> bexe_t list -> int option ->
    89:   unit
    90: 
    91: val print_function:
    92:   symbol_table_t ->
    93:   fully_bound_symbol_table_t ->
    94:   int ->
    95:   unit
    96: 
    97: val print_vs: vs_list_t -> string
    98: val print_ivs: ivs_list_t -> string
    99: val print_ivs_with_index: ivs_list_t -> string
   100: 
   101: val string_of_ast_term: int -> ast_term_t -> string
   102: val string_of_string: string -> string
   103: val string_of_bquals: symbol_table_t -> btype_qual_t list -> string
   104: val print_bvs: bvs_t -> string
   105: 
   106: type felix_term_t = [
   107:   | qualified_name_t
   108:   | regexp_t
   109:   | typecode_t
   110:   | tpattern_t
   111:   | literal_t
   112:   | expr_t
   113:   | pattern_t
   114:   | statement_t
   115:   | exe_t
   116:   | btypecode_t
   117: 
   118:   (* hack .. the type because tbexpr_t is a pair not a variant *)
   119:   | bexpr_t
   120:   | bexe_t
   121:   | ast_term_t
   122: 
   123:   (* hack cause we don't know the name *)
   124:   | symbol_definition_t
   125: 
   126:   | bbdcl_t
   127:   | param_kind_t
   128:   | property_t
   129:   | c_t
   130:   | dcl_t
   131:   | asm_t
   132:   | iface_t
   133:   | access_t
   134:   | biface_t
   135:   | btype_qual_t
   136:   | type_qual_t
   137:   | requirement_t
   138:   | ikind_t
   139:   | named_req_expr_t
   140:   | raw_req_expr_t
   141:   | glr_term_t
   142:   ]
   143: 
   144: 
   145: val st: symbol_table_t -> felix_term_t -> string
   146: 
End ocaml section to src/flx_print.mli[1]
Start ocaml section to src/flx_print.ml[1 /1 ]
     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: 
End ocaml section to src/flx_print.ml[1]
Start ocaml section to src/flx_mtypes1.ml[1 /1 ]
     1: # 5224 "./lpsrc/flx_types.ipk"
     2: module IntHashtbl = Hashtbl.Make(
     3:   struct
     4:     type t = int
     5:     let equal = fun x y -> x = y
     6:     let hash = fun x -> x
     7:   end
     8: )
     9: ;;
    10: 
    11: module StringMap = Map.Make(
    12:   struct
    13:     type t = string
    14:     let compare = compare
    15:   end
    16: )
    17: ;;
    18: 
    19: type string_string_map_t = string StringMap.t
    20: 
    21: module StringSet = Set.Make (
    22:   struct
    23:     type t = string
    24:     let compare=compare
    25:   end
    26: );;
    27: 
    28: module IntSet = Set.Make (
    29:   struct
    30:     type t = int
    31:     let compare=compare
    32:   end
    33: );;
    34: 
    35: (* set of IntSet's *)
    36: module IntSetSet = Set.Make (
    37:   struct
    38:     type t = IntSet.t
    39:     let compare=compare
    40:   end
    41: );;
    42: 
    43: let stringset_map f s =
    44:   let d = ref StringSet.empty in
    45:   StringSet.iter
    46:   (fun x -> d := StringSet.add (f x) !d)
    47:   s
    48:   ;
    49:   !d
    50: 
    51: let list_of_intset ii =
    52:   IntSet.fold (fun i lst -> i :: lst) ii []
    53: 
    54: let string_of_intset ii =
    55:   "{"^
    56:   String.concat ","
    57:   (
    58:     List.map string_of_int
    59:     (
    60:       list_of_intset ii
    61:     )
    62:   )
    63:   ^"}"
    64: 
    65: let intset_of_list ii =
    66:   List.fold_left (fun ii i -> IntSet.add i ii) IntSet.empty ii
    67: 
End ocaml section to src/flx_mtypes1.ml[1]
Start ocaml section to src/flx_mtypes1.mli[1 /1 ]
     1: # 5292 "./lpsrc/flx_types.ipk"
     2: module IntHashtbl : Hashtbl.S with type key = int
     3: module StringMap : Map.S with type key = string
     4: 
     5: type string_string_map_t = string StringMap.t
     6: module StringSet : Set.S with type elt = string
     7: 
     8: val stringset_map: (string -> string) -> StringSet.t -> StringSet.t
     9: 
    10: module IntSet : Set.S with type elt = int
    11: module IntSetSet : Set.S with type elt = IntSet.t
    12: 
    13: val string_of_intset : IntSet.t -> string
    14: val intset_of_list : int list -> IntSet.t
    15: 
End ocaml section to src/flx_mtypes1.mli[1]
Start ocaml section to src/flx_mtypes2.ml[1 /1 ]
     1: # 5308 "./lpsrc/flx_types.ipk"
     2: open Flx_mtypes1
     3: open Flx_types
     4: open List
     5: 
     6: (* generic entity instances: functions, variables *)
     7: type instance_registry_t = (int * btypecode_t list, int) Hashtbl.t
     8: 
     9: type felix_compiler_options_t =
    10: {
    11:   print_flag: bool;
    12:   debug : bool;
    13:   optimise : bool;
    14:   trace : bool;
    15:   include_dirs : string list;
    16:   files : string list;
    17:   raw_options: (string * string) list;
    18:   reverse_return_parity: bool;
    19:   max_inline_length : int;
    20:   compile_only : bool;
    21:   force_recompile : bool;
    22:   with_comments : bool;
    23:   mangle_names : bool;
    24:   elkhound : string;
    25:   generate_axiom_checks : bool;
    26:   hash_include : string list;
    27: }
    28: 
    29: 
    30: type sym_state_t =
    31: {
    32:   dfns : symbol_table_t;
    33:   counter : int ref;
    34:   varmap : typevarmap_t;
    35:   ticache : (int, btypecode_t) Hashtbl.t;
    36:   glr_cache : (int, btypecode_t) Hashtbl.t;
    37:   env_cache : (int, env_t) Hashtbl.t;
    38:   registry : type_registry_t;
    39:   compiler_options : felix_compiler_options_t;
    40:   instances : instance_registry_t;
    41:   include_files : string list ref;
    42:   roots : IntSet.t ref;
    43:   wrappers : (int, int) Hashtbl.t;
    44:   lexers : (int * tbexpr_t, int) Hashtbl.t;
    45:   parsers : (int * btypecode_t * int list, int) Hashtbl.t;
    46:   quick_names : (string, (int * btypecode_t list)) Hashtbl.t;
    47:   mutable bifaces : biface_t list;
    48:   mutable reductions : reduction_t list;
    49:   mutable axioms: axiom_t list;
    50:   variant_map: (btypecode_t * btypecode_t,int) Hashtbl.t;
    51:   typeclass_to_instance: (int, (bvs_t * btypecode_t * btypecode_t list * int) list) Hashtbl.t;
    52:   instances_of_typeclass: (int, (int * (bvs_t * btypecode_t * btypecode_t list)) list) Hashtbl.t;
    53:   transient_specialisation_cache: (int * btypecode_t list, int * btypecode_t list) Hashtbl.t;
    54: }
    55: 
    56: module VarMap = StringMap
    57: type varmap_t = string_string_map_t
    58: 
    59: module TypecodeSet = Set.Make(
    60:   struct type t = Flx_ast.typecode_t let compare = compare end
    61: )
    62: type typecodeset_t = TypecodeSet.t
    63: 
    64: let typecodeset_of_list x =
    65:   let rec tsol x = match x with
    66:   | h :: t -> TypecodeSet.add h (tsol t)
    67:   | [] -> TypecodeSet.empty
    68:   in tsol x
    69: 
    70: let typecodeset_map f x = typecodeset_of_list (map f (TypecodeSet.elements x))
    71: 
    72: (* for regular expressions *)
    73: 
    74: (* PosSet -- set of positions in regular expression, used for followpos *)
    75: module PosSet = IntSet
    76: module PosSetSet = IntSetSet
    77: module CharSet = IntSet
    78: 
End ocaml section to src/flx_mtypes2.ml[1]
Start ocaml section to src/flx_mtypes2.mli[1 /1 ]
     1: # 5387 "./lpsrc/flx_types.ipk"
     2: open Flx_types
     3: open Flx_mtypes1
     4: 
     5: module VarMap : Map.S with type key = string
     6: 
     7: type varmap_t = string VarMap.t
     8: 
     9: module TypecodeSet : Set.S with type elt = Flx_ast.typecode_t
    10: 
    11: type typecodeset_t = TypecodeSet.t
    12: val typecodeset_of_list : TypecodeSet.elt list -> TypecodeSet.t
    13: val typecodeset_map :
    14:   (TypecodeSet.elt -> TypecodeSet.elt) -> TypecodeSet.t -> TypecodeSet.t
    15: 
    16: module PosSet : Set.S with type elt = int
    17: module PosSetSet : Set.S with type elt = PosSet.t
    18: module CharSet : Set.S with type elt = int
    19: 
    20: (* generic entity instances: functions, variables *)
    21: type instance_registry_t = (int * btypecode_t list, int) Hashtbl.t
    22: 
    23: type felix_compiler_options_t =
    24: {
    25:   print_flag: bool;
    26:   debug : bool;
    27:   optimise : bool;
    28:   trace : bool;
    29:   include_dirs : string list;
    30:   files : string list;
    31:   raw_options: (string * string) list;
    32:   reverse_return_parity: bool;
    33:   max_inline_length : int;
    34:   compile_only : bool;
    35:   force_recompile : bool;
    36:   with_comments : bool;
    37:   mangle_names : bool;
    38:   elkhound : string;
    39:   generate_axiom_checks : bool;
    40:   hash_include : string list;
    41: }
    42: 
    43: 
    44: type sym_state_t =
    45: {
    46:   dfns : symbol_table_t;
    47:   counter : int ref;
    48:   varmap : typevarmap_t;
    49:   ticache : (int, btypecode_t) Hashtbl.t;
    50:   glr_cache : (int, btypecode_t) Hashtbl.t;
    51:   env_cache : (int, env_t) Hashtbl.t;
    52:   registry : type_registry_t;
    53:   compiler_options : felix_compiler_options_t;
    54:   instances : instance_registry_t;
    55:   include_files : string list ref;
    56:   roots : IntSet.t ref;
    57:   wrappers : (int, int) Hashtbl.t;
    58:   lexers : (int * tbexpr_t, int) Hashtbl.t;
    59:   parsers : (int * btypecode_t * int list, int) Hashtbl.t;
    60:   quick_names : (string, (int * btypecode_t list)) Hashtbl.t;
    61:   mutable bifaces : biface_t list;
    62:   mutable reductions : reduction_t list;
    63:   mutable axioms : axiom_t list;
    64:   variant_map: (btypecode_t * btypecode_t,int) Hashtbl.t;
    65:   typeclass_to_instance: (int, (bvs_t * btypecode_t * btypecode_t list * int) list) Hashtbl.t;
    66:   instances_of_typeclass: (int, (int * (bvs_t * btypecode_t * btypecode_t list)) list) Hashtbl.t;
    67:   transient_specialisation_cache: (int * btypecode_t list, int * btypecode_t list) Hashtbl.t;
    68: }
    69: 
    70: 
End ocaml section to src/flx_mtypes2.mli[1]