5.11. Print module

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