#
# prettyprint.pkg - Some simple pretty-printing infrastructure for the c-glue-maker
# program.
#
# (C) 2001, Lucent Technologies, Bell Labs
#
# author: Matthias Blume (blume@research.bell-labs.com)
# Compiled by:
# src/app/c-glue-maker/c-glue-maker.libpackage prettyprint {
package pp
=
prettyprint_stream_g ( # prettyprint_stream_g is from src/lib/prettyprint/big/src/prettyprint-stream-g.pkg package token = string_token; # string_token is from src/lib/prettyprint/big/devices/string-token.pkg package device = cpifdev; # cpifdev is from src/app/c-glue-maker/cpif-dev.pkg );
Mltype = ARROW (Mltype, Mltype )
| TUPLE List( Mltype )
| TYP (String, List( Mltype ))
| RECORD List ((String, Mltype));
void = TUPLE [];
fun typ constructor_name # "typ" == "type constructor": Convenience fn for constructors which take no arguments.
=
TYP (constructor_name, []);
# Prefixes "incomplete_struct_"/"incomplete_union_"/"incomplete_enum_" indicate incomplete
# struct/union/enum types, respectively.
# (Complete types use prefixes "struct_"/"union_"/"enum_".)
# These are apparently never called:
# fun incomplete_struct tag = typ (cat ["incomplete_struct_", tag, "::Tag"]);
# fun incomplete_union tag = typ (cat ["incomplete_union_", tag, "::Tag"]);
# fun incomplete_enum tag = typ (cat ["incomplete_enum_", tag, "::Tag"]);
Tcontext = C_STAR | C_ARROW | C_COMMA | C_CON;
fun simplify (TYP ("Void", []))
=>
void;
simplify (TUPLE [t])
=>
simplify t;
simplify (TYP ( chunk as ("chunk" | "chunk'"),
[ TYP ( k as ( "schar" | "uchar"
| "sint" | "uint"
| "sshort" | "ushort"
| "slong" | "ulong"
| "float" | "double"
| "voidptr"
),
[]
),
c
]
) )
=>
TYP (cat [k, "_", chunk], [simplify c]);
simplify (TYP (chunk as ("chunk" | "chunk'"),
[TYP ("fptr", [f]), c]))
=>
TYP ("fptr_" + chunk, [simplify f, simplify c]);
simplify (TYP (chunk as ("chunk" | "chunk'"),
[TYP ("su", [s]), c]))
=>
TYP ("su_" + chunk, [simplify s, simplify c]);
simplify (TYP ("dim::dim", [n, TYP (("dim::nonzero" | "nonzero"), [])]))
=>
TYP ("dim", [simplify n]);
simplify (TYP ("dim::dec", []))
=>
TYP ("dec", []);
simplify (TYP (k as ("dim::dg0" | "dim::dg1" | "dim::dg2" | "dim::dg3" |
"dim::dg4" | "dim::dg5" | "dim::dg6" | "dim::dg7" |
"dim::dg8" | "dim::dg9"), [n]))
=>
TYP (string::extract (k, 4, NULL), [simplify n]);
simplify (ARROW (t1, t2)) => ARROW (simplify t1, simplify t2);
simplify (TUPLE tl) => TUPLE (map simplify tl);
simplify (RECORD ml) => RECORD (map' ml (fn (n, t) = (n, simplify t)));
simplify (TYP (k, tl)) => TYP (k, map simplify tl);
end;
fun unparse_type0 s (t as ARROW _, c)
=>
{ fun loop (ARROW (x, y))
=>
{ unparse_type0 s (x, C_ARROW);
pp::string s " ->";
pp::space s 1;
loop y;
};
loop t
=>
unparse_type0 s (t, C_ARROW);
end;
parenthesize = c != C_COMMA;
indent = if parenthesize 5;
else 4; fi;
pp::begin_indented_wrap_box s (pp::CURSOR_RELATIVE indent);
if parenthesize pp::string s "("; fi;
loop t;
if parenthesize pp::string s ")"; fi;
pp::end_box s;
};
unparse_type0 s (TUPLE [], _) => pp::string s "Void";
unparse_type0 s (TUPLE [t], c) => unparse_type0 s (t, c);
unparse_type0 s (TUPLE type_list, c)
=>
{ fun loop [] => (); # Cannot happen
loop [type] => unparse_type0 s (type, C_STAR);
loop (type ! type_list)
=>
{ unparse_type0 s (type, C_STAR);
pp::string s ",";
pp::space s 1;
loop type_list;
};
end;
# parenthesize
# =
# case c (C_STAR | C_CON) => TRUE;
# (C_ARROW | C_COMMA) => FALSE;
# esac;
parenthesize = TRUE; # Now that we do "(type1, type2, ...") instead of "type1 * type2 * ..."
indent = if parenthesize 1;
else 0; fi;
pp::begin_indented_horizontal_else_vertical_box s (pp::CURSOR_RELATIVE indent);
if parenthesize pp::string s "("; fi;
loop type_list;
if parenthesize pp::string s ")"; fi;
pp::end_box s;
};
unparse_type0 s (RECORD [], _)
=>
pp::string s "{}";
unparse_type0 s (RECORD field_list, _)
=>
{ fun loop [] => (); # Cannot happen
loop [(nam, type)]
=>
{ pp::string s (nam + " : ");
unparse_type0 s (type, C_COMMA);
};
loop ((field_name, field_type) ! field_list)
=>
{ pp::string s (field_name + " : ");
unparse_type0 s (field_type, C_COMMA);
pp::string s ", ";
pp::space s 1;
loop field_list;
};
end;
pp::begin_indented_horizontal_else_vertical_box s (pp::CURSOR_RELATIVE 2);
pp::string s "{ ";
loop field_list;
pp::string s " }";
pp::end_box s;
};
unparse_type0 s (TYP (constructor, []), _) # Constructor which takes no args, print like "TRUE".
=>
pp::string s constructor;
unparse_type0 s (TYP (constructor, [type]), _) # Constructor taking exactly one argument, print like "FOO String".
=>
{ pp::begin_horizontal_box s;
pp::string s constructor;
pp::space s 1;
unparse_type0 s (type, C_CON);
pp::end_box s;
};
unparse_type0 s (TYP (constructor, type_list), _) # Constructor taking two or more arguments, print like "FOO (String, Int)".
=>
{ fun loop []
=>
(); # Cannot happen
loop [type]
=>
unparse_type0 s (type, C_COMMA);
loop (type ! type_list)
=>
{ unparse_type0 s (type, C_COMMA);
pp::string s ",";
pp::space s 1;
loop type_list;
};
end;
pp::begin_horizontal_box s;
pp::begin_indented_horizontal_else_vertical_box s (pp::CURSOR_RELATIVE 1);
pp::string s constructor;
pp::space s 1;
pp::string s "(";
loop type_list;
pp::string s ")";
pp::end_box s;
pp::end_box s;
};
end;
# Start with comma context
fun unparse_type s t = unparse_type0 s (simplify t, C_COMMA);
fun unparse_type' s (t, c) = unparse_type0 s (simplify t, c);
Mlexp = ETUPLE List Mlexp
| ERECORD List ((String, Mlexp))
| EVAR String
| EAPP (Mlexp, Mlexp)
| ECONSTR (Mlexp, Mltype)
| ESEQ (Mlexp, Mlexp);
Econtext # "Econtext" == "expression context", likely. Ditto "EC" == "Expression Context".
=
EC_APP | EC_COMMA;
fun unparse_expression0 s (ETUPLE [], _) => pp::string s "()";
unparse_expression0 s (ETUPLE [x], c) => unparse_expression0 s (x, c);
unparse_expression0 s (ETUPLE xl, _)
=>
{ fun loop [] => ();
loop [x] => unparse_expression0 s (x, EC_COMMA);
loop (x ! xl)
=>
{ unparse_expression0 s (x, EC_COMMA);
pp::string s ", ";
pp::space s 1;
loop xl;
};
end;
pp::begin_indented_horizontal_else_vertical_box s (pp::CURSOR_RELATIVE 1);
pp::string s "(";
loop xl;
pp::string s ")";
pp::end_box s;
};
unparse_expression0 s (ERECORD [], _)
=>
pp::string s "{}";
unparse_expression0 s (ERECORD xl, _)
=>
{ fun loop [] => ();
loop [(n, x)]
=>
{ pp::string s (n + " =");
pp::space s 1;
unparse_expression0 s (x, EC_COMMA);
};
loop ((n, x) ! xl)
=>
{ pp::string s (n + " =");
pp::space s 1;
unparse_expression0 s (x, EC_COMMA);
pp::string s ", ";
pp::space s 1;
loop xl;
};
end;
pp::begin_indented_horizontal_else_vertical_box s (pp::CURSOR_RELATIVE 2);
pp::string s "{ ";
loop xl;
pp::string s " }";
pp::end_box s;
};
unparse_expression0 s (EVAR v, _)
=>
pp::string s v;
unparse_expression0 s (EAPP (x, y), c)
=>
{ fun loop (EAPP (x, y))
=>
{ loop x;
unparse_expression0 s (y, EC_APP);
pp::space s 1;
};
loop x
=>
{ unparse_expression0 s (x, EC_APP);
pp::space s 1;
pp::begin_wrap_box s;
};
end;
parenthesize = c == EC_APP;
pp::begin_indented_wrap_box s (pp::BOX_RELATIVE 4);
if parenthesize pp::string s "("; fi;
loop x;
unparse_expression0 s (y, EC_APP);
if parenthesize pp::string s ")"; fi;
pp::end_box s;
pp::end_box s;
};
unparse_expression0 s (ECONSTR (x, t), c)
=>
{ parenthesize = c == EC_APP;
indent = if parenthesize 5; else 4; fi;
tc = if parenthesize C_CON; else C_COMMA; fi;
pp::begin_indented_wrap_box s (pp::CURSOR_RELATIVE indent);
if parenthesize pp::string s "("; fi;
unparse_expression0 s (x, c);
pp::nonbreakable_spaces s 1;
pp::string s ":";
pp::space s 1;
unparse_type' s (t, tc);
if parenthesize pp::string s ")"; fi;
pp::end_box s;
};
unparse_expression0 s (ESEQ (x, y), c)
=>
{ pp::string s "(";
pp::begin_horizontal_else_vertical_box s;
unparse_expression0 s (x, EC_COMMA);
pp::string s ";";
pp::space s 1;
unparse_expression0 s (y, EC_COMMA);
pp::string s ")";
pp::end_box s;
};
end;
fun unparse_expression s x = unparse_expression0 s (x, EC_COMMA);
fun unparse_expression' s x = unparse_expression0 s (x, EC_APP);
fun unparse_fun s (name, args, body)
=
{ pp::begin_indented_wrap_box s (pp::CURSOR_RELATIVE 4);
pp::string s ("fun " + name);
pp::nonbreakable_spaces s 1;
apply
(fn a = { unparse_expression' s a; pp::space s 1; })
args;
pp::string s "= ";
pp::nonbreakable_spaces s 1;
pp::begin_wrap'_box s;
unparse_expression s body;
pp::end_box s;
pp::end_box s;
};
};