## prettyprint-lambdacode-expression.pkg
# Compiled by:
# src/lib/compiler/core.sublib# "We do not stop playing because we grow old.
# We grow old because we stop playing."
stipulate
package ds = deep_syntax; # deep_syntax is from src/lib/compiler/front/typer-stuff/deep-syntax/deep-syntax.pkg package lcf = lambdacode_form; # lambdacode_form is from src/lib/compiler/back/top/lambdacode/lambdacode-form.pkg package pp = standard_prettyprinter; # standard_prettyprinter is from src/lib/prettyprint/big/src/standard-prettyprinter.pkg package syx = symbolmapstack; # symbolmapstack is from src/lib/compiler/front/typer-stuff/symbolmapstack/symbolmapstack.pkg package tmp = highcode_codetemp; # highcode_codetemp is from src/lib/compiler/back/top/highcode/highcode-codetemp.pkgherein
api Prettyprint_Lambdacode_Expression {
#
print_casetag: pp::Prettyprinter -> lcf::Casetag -> Void;
prettyprint_lambdacode_expression: pp::Prettyprinter -> lcf::Lambdacode_Expression -> Void;
print_match: pp::Prettyprinter -> syx::Symbolmapstack -> List( (ds::Case_Pattern, lcf::Lambdacode_Expression) ) -> Void;
print_fun: pp::Prettyprinter -> lcf::Lambdacode_Expression -> tmp::Codetemp -> Void;
string_tag: lcf::Lambdacode_Expression -> String;
};
end;
stipulate
package err = error_message; # error_message is from src/lib/compiler/front/basics/errormsg/error-message.pkg package hbo = highcode_baseops; # highcode_baseops is from src/lib/compiler/back/top/highcode/highcode-baseops.pkg package hcf = highcode_form; # highcode_form is from src/lib/compiler/back/top/highcode/highcode-form.pkg package lcf = lambdacode_form; # lambdacode_form is from src/lib/compiler/back/top/lambdacode/lambdacode-form.pkg package pp = standard_prettyprinter; # standard_prettyprinter is from src/lib/prettyprint/big/src/standard-prettyprinter.pkg package pu = print_junk; # print_junk is from src/lib/compiler/front/basics/print/print-junk.pkg package sy = symbol; # symbol is from src/lib/compiler/front/basics/map/symbol.pkg package tmp = highcode_codetemp; # highcode_codetemp is from src/lib/compiler/back/top/highcode/highcode-codetemp.pkg package uds = unparse_deep_syntax; # unparse_deep_syntax is from src/lib/compiler/front/typer/print/unparse-deep-syntax.pkg package vh = varhome; # varhome is from src/lib/compiler/front/typer-stuff/basics/varhome.pkg #
Pp = pp::Pp;
#
include package print_junk;
herein
package prettyprint_lambdacode_expression
: (weak) Prettyprint_Lambdacode_Expression
{
#
say = global_controls::print::say;
# fun sayrep representation
# =
# say (vh::print_representation representation);
name_of_highcode_codetemp = tmp::name_of_highcode_codetemp;
fun bug s
=
err::impossible ("prettyprint_lambdacode_expression: " + s);
fun app2 (f, [], []) => ();
app2 (f, a ! r, b ! z) => { f (a, b);
app2 (f, r, z);
};
app2 (f, _, _) => bug "unexpected list arguments in function app2";
end;
margin = REF 0;
fun indent i
=
margin := *margin + i;
exception UNDENT;
fun undent i
=
{ margin := *margin - i;
#
if (*margin < 0) raise exception UNDENT; fi;
};
fun dent ()
=
tab *margin;
fun whitespace ()
=
cat (ws *margin)
where
fun ws (n)
=
{ if (n < 0) raise exception UNDENT; fi;
#
if (n >= 8)
#
"\t" ! ws (n - 8);
else
str = case n 0 => "";
1 => " ";
2 => " ";
3 => " ";
4 => " ";
5 => " ";
6 => " ";
_ => " ";
esac;
[str];
fi;
};
end;
fun print_casetag (pp:Pp) x
=
pp.lit (print_casetag' x)
where
fun print_casetag' (lcf::VAL_CASETAG ((symbol, _, _), _, v)) => ((sy::name symbol) + " " + (name_of_highcode_codetemp v));
#
print_casetag' (lcf::INT_CASETAG i) => int::to_string i;
print_casetag' (lcf::INT1_CASETAG i) => "(I32)" + (one_word_int::to_string i);
print_casetag' (lcf::INTEGER_CASETAG i) => "II" + multiword_int::to_string i;
print_casetag' (lcf::UNT_CASETAG i) => "(W)" + (unt::to_string i);
print_casetag' (lcf::UNT1_CASETAG i) => "(W32)" + (one_word_unt::to_string i);
print_casetag' (lcf::FLOAT64_CASETAG r) => r;
print_casetag' (lcf::STRING_CASETAG s) => pu::heap_string s; # was pu::print_heap_string s
print_casetag' (lcf::VLEN_CASETAG n) => int::to_string n;
end;
end;
# Use of complex in printLexp may
# lead to stupid n^2 behavior:
#
# fun complex le
# =
# g le
# where
# fun h [] => FALSE;
# h (a ! r) => g a or h r;
# end
#
# also
# fun g (lcf::FN(_, _, b)) => g b;
# g (lcf::MUTUALLY_RECURSIVE_FNS (vl, _, ll, b)) => TRUE;
# g (lcf::APPLY (lcf::FN _, _)) => TRUE;
# g (lcf::APPLY (l, r)) => g l or g r;
#
# g (lcf::LET _) => TRUE;
# g (lcf::TYPEFUN(_, b)) => g b;
# g (lcf::APPLY_TYPEFUN (l, [])) => g l;
# g (lcf::APPLY_TYPEFUN (l, _)) => TRUE;
# g (lcf::GENOP(_, _, _, _)) => TRUE;
# g (lcf::PACK(_, _, _, l)) => g l;
#
# g (lcf::RECORD l) => h l;
# g (lcf::PACKAGE_RECORD l) => h l;
# g (lcf::VECTOR (l, _)) => h l;
# g (lcf::GET_FIELD(_, l)) => g l;
#
# g (lcf::SWITCH _) => TRUE;
# g (lcf::CONSTRUCTOR(_, _, l)) => TRUE;
# # g (DECON(_, _, l)) = TRUE
#
# g (lcf::EXCEPT _) => TRUE;
# g (lcf::RAISE (l, _)) => g l;
# g (lcf::EXCEPTION_TAG (l, _)) => g l;
#
# g (lcf::BOX(_, _, l)) => g l;
# g (lcf::UNBOX(_, _, l)) => g l;
# g _ => FALSE;
# end;
# end;
fun prettyprint_lambdacode_expression (pp:Pp) l
=
do l
where
fun pr_lty t = pp.lit (hcf::uniqtypoid_to_string t);
fun pr_typ t = pp.lit (hcf::uniqtype_to_string t);
fun pr_knd k = pp.lit (hcf::uniqkind_to_string k);
fun plist (p, [], sep) => ();
#
plist (p, a ! r, sep) => { p a;
#
apply f r
where
fun f x
=
{ pp.lit sep;
p x;
};
end;
};
end;
fun do (lcf::VAR v) => pp.lit (name_of_highcode_codetemp v);
do (lcf::INT i) => pp.lit (int::to_string i);
do (lcf::UNT i) => { pp.lit "(U)"; pp.lit (unt::to_string i); };
do (lcf::INT1 i) => { pp.lit "(I32)"; pp.lit (one_word_int::to_string i); };
do (lcf::UNT1 i) => { pp.lit "(U32)"; pp.lit (one_word_unt::to_string i); };
do (lcf::FLOAT64 s) => pp.lit s;
do (lcf::STRING s) => pp.lit (heap_string s);
do (lcf::EXCEPTION_TAG (l, _)) => do l;
do (r as lcf::RECORD l)
=>
pp.box' 0 0 {.
pp.lit "lcf::RECORD {";
pp.ind 4;
pp.txt " ";
pp::seqx {. pp.txt ", "; } do l;
pp.ind 0;
pp.txt " ";
pp.lit "}";
};
do (r as lcf::PACKAGE_RECORD l)
=>
pp.box' 0 0 {.
pp.lit "lcf::PACKAGE_RECORD {";
pp.ind 4;
pp.txt " ";
pp::seqx {. pp.txt ", "; } do l;
pp.ind 0;
pp.txt " ";
pp.lit "}";
};
do (r as lcf::VECTOR (l, _))
=>
pp.box' 0 0 {.
pp.lit "lcf::VECTOR [";
pp.ind 4;
pp.txt " ";
pp::seqx {. pp.txt ", "; } do l;
pp.ind 0;
pp.txt " ";
pp.lit "]";
};
do (lcf::BASEOP (p, t, ts))
=>
pp.box' 0 0 {.
pp.lit "lcf::BASEOP (";
pp.ind 4;
pp.txt " ";
pp.lit (hbo::baseop_to_string p);
pp.txt ", ";
hcf::prettyprint_uniqtypoid pp t;
pp.endlit ",";
pp.txt " ";
pp.box' 0 0 {.
pp.lit "[";
pp.ind 4;
pp.txt " ";
pp::seqx {. pp.txt ", "; } (hcf::prettyprint_uniqtype pp) ts;
pp.ind 0;
pp.txt " ";
pp.lit "]";
};
pp.ind 0;
pp.cut ();
pp.lit ")";
};
do (l as lcf::GET_FIELD (i, _))
=>
{ fun gather (lcf::GET_FIELD (i, l))
=>
{ (gather l) -> (more, root);
#
(i ! more, root);
};
gather l => (NIL, l);
end;
(gather l) -> (path, root);
fun ipr (i: Int)
=
pp.lit (int::to_string i);
do root;
pp.box' 0 0 {.
pp.lit "lcf::BASEOP (";
pp.ind 4;
pp.txt " ";
pp::seqx {. pp.txt ", "; } ipr (reverse path);
pp.ind 0;
pp.cut ();
pp.lit ")";
};
};
do (lcf::FN (v, t, l))
=>
pp.box' 0 0 {.
pp.lit "lcf::FN (";
pp.ind 4;
pp.txt " ";
pp.lit (name_of_highcode_codetemp v);
pp.box' 0 0 {.
pp.lit ":";
pp.ind 4;
pp.txt " ";
hcf::prettyprint_uniqtypoid pp t;
};
pp.endlit ",";
pp.txt " ";
do l;
pp.ind 0;
pp.cut ();
pp.lit ")";
};
do (lcf::CONSTRUCTOR((s, c, lt), ts, l))
=>
pp.box' 0 0 {.
pp.lit "lcf::CONSTRUCTOR (";
pp.ind 4;
pp.txt " ";
pp.box' 0 0 {.
pp.lit "(";
pp.ind 4;
pp.txt " ";
pp.lit (sy::name s);
pp.txt ", ";
pp.lit (vh::print_representation c);
pp.endlit ",";
pp.txt " ";
hcf::prettyprint_uniqtypoid pp lt;
pp.ind 0;
pp.cut ();
pp.lit ")";
};
pp.endlit ",";
pp.txt " ";
pp.box' 0 0 {.
pp.lit "[";
pp.ind 4;
pp.txt " ";
pp::seqx {. pp.txt ", "; } (hcf::prettyprint_uniqtype pp) ts;
pp.ind 0;
pp.txt " ";
pp.lit "]";
};
pp.endlit ",";
pp.txt " ";
do l;
pp.ind 0;
pp.cut ();
pp.lit ")";
};
/*
| do (DECON((s, c, lt), ts, l)) =
(pp.lit "DECON(("; pp.lit (sy::name s); pp.txt ", "; sayrep c; pp.lit ", ";
prLty lt; pp.lit "), ["; plist (prTypeConstructor, ts, ", "); pp.lit "], ";
if complex l then (indent 4; do l; pp.lit ")"; undent 4)
else (do l; pp.lit ")"))
*/
do (lcf::APPLY (lcf::FN (v, _, l), r))
=>
pp.box' 0 0 {.
pp.lit "(lcf::APPLY(lcf::FN...))";
pp.txt " ";
do (lcf::LET (v, r, l));
};
do (lcf::LET (v, r, l))
=>
pp.box' 0 0 {.
pp.lit "lcf::LET";
pp.ind 4;
pp.txt " ";
lv = name_of_highcode_codetemp v;
len = size lv + 3;
pp.box' 0 0 {.
pp.lit lv;
pp.lit " =";
pp.ind 4;
pp.txt " ";
do r;
};
pp.ind 0;
pp.txt " IN ";
# pp.ind 4; # This turns out to be a poor idea because long lists of declarations turn into deeply nested sets of LET expressions, producing lines hundreds of chars long -- not easy or enjoyable to read.
do l;
# pp.ind 0; # " "
# pp.cut (); # " "
pp.lit "END";
};
do (lcf::APPLY (l, r))
=>
pp.box' 0 0 {.
pp.lit "lcf::APPLY(";
pp.ind 4;
pp.txt " ";
do l;
pp.txt " ";
do r;
pp.ind 0;
pp.cut ();
pp.lit ")";
};
do (lcf::TYPEFUN (ks, b))
=>
pp.box' 0 0 {.
pp.lit "lcf::TYPEFUN(";
pp.ind 4;
pp.txt " ";
pp::seqx {. pp.txt ", "; } (hcf::prettyprint_uniqkind pp) ks;
pp.txt " ";
do b;
pp.ind 0;
pp.cut ();
pp.lit ")";
};
do (lcf::APPLY_TYPEFUN (l, ts))
=>
pp.box' 0 0 {.
pp.lit "lcf::APPLY_TYPEFUN(";
pp.ind 4;
pp.txt " ";
do l;
pp.endlit ",";
pp.txt " ";
pp.box' 0 0 {.
pp.lit "[";
pp.ind 4;
pp.txt " ";
pp::seqx {. pp.txt ", "; } (hcf::prettyprint_uniqtype pp) ts;
pp.ind 0;
pp.txt " ";
pp.lit "]";
};
pp.ind 0;
pp.cut ();
pp.lit ")";
};
do (lcf::GENOP (dictionary, p, t, ts))
=>
pp.box' 0 0 {.
pp.lit "lcf::GENOP (";
pp.ind 4;
pp.txt " ";
pp.lit (hbo::baseop_to_string p);
pp.endlit ",";
pp.txt " ";
hcf::prettyprint_uniqtypoid pp t;
pp.endlit ",";
pp.txt " ";
pp.box' 0 0 {.
pp.lit "[";
pp.ind 4;
pp.txt " ";
pp::seqx {. pp.txt ", "; } (hcf::prettyprint_uniqtype pp) ts;
pp.ind 0;
pp.txt " ";
pp.lit "]";
};
pp.ind 0;
pp.cut ();
pp.lit ")";
};
do (lcf::PACK (lt, ts, nts, l))
=>
pp.box' 0 0 {.
pp.lit "lcf::PACK(";
pp.ind 4;
pp.txt " ";
app2 ( \\ (tc, ntc)
=
{ pp.box' 0 0 {.
pp.lit "<";
hcf::prettyprint_uniqtype pp tc;
pp.txt ", ";
hcf::prettyprint_uniqtype pp ntc;
pp.lit ">";
};
pp.endlit ",";
pp.txt ", ";
},
ts,
nts
);
pp.txt " ";
hcf::prettyprint_uniqtypoid pp lt;
pp.endlit ",";
pp.txt " ";
do l;
pp.ind 0;
pp.cut ();
pp.lit ")";
};
do (lcf::SWITCH (l, _, llist, default))
=>
{ fun switch [(c, l)]
=>
pp.box' 0 0 {.
print_casetag pp c;
pp.lit " =>";
pp.ind 4;
pp.txt " ";
do l;
};
switch ((c, l) ! more)
=>
{
pp.box' 0 0 {.
print_casetag pp c;
pp.lit " =>";
pp.ind 4;
pp.txt " ";
do l;
};
switch more;
};
switch []
=>
bug "unexpected case in switch";
end;
pp.box' 0 0 {.
#
pp.lit "lcf::SWITCH";
pp.ind 4;
pp.txt " (";
do l;
pp.txt ") ";
pp.box' 1 0 {.
#
switch llist;
case default
#
NULL => ();
THE l => pp.box' 0 0 {.
pp.lit "_ =>";
pp.ind 4;
pp.txt " ";
do l;
};
esac;
};
};
};
do (lcf::MUTUALLY_RECURSIVE_FNS (varlist, ltylist, lexplist, lambda_expression))
=>
{ fun flist ([v],[t],[l])
=>
pp.box' 0 0 {.
lv = name_of_highcode_codetemp v;
pp.lit lv;
pp.endlit ":";
pp.ind 4;
pp.txt " ";
hcf::prettyprint_uniqtypoid pp t;
pp.txt " ";
do l;
};
flist (v ! vs, t ! ts, l ! ls)
=>
{
pp.box' 0 0 {.
lv = name_of_highcode_codetemp v;
pp.lit lv;
pp.endlit ":";
pp.ind 4;
pp.txt " ";
hcf::prettyprint_uniqtypoid pp t;
pp.txt " ";
do l;
};
flist (vs, ts, ls);
};
flist (NIL, NIL, NIL)
=> ();
flist _ => bug "unexpected cases in flist";
end;
pp.box' 0 0 {.
pp.lit "lcf::MUTUALLY_RECURSIVE_FNS(";
pp.ind 4;
pp.txt " ";
flist (varlist, ltylist, lexplist);
pp.txt " IN ";
do lambda_expression;
pp.ind 0;
pp.cut ();
pp.lit ")";
};
};
do (lcf::RAISE (l, t))
=>
pp.box' 0 0 {.
#
pp.lit "lcf::RAISE(";
pp.ind 4;
pp.txt " ";
hcf::prettyprint_uniqtypoid pp t;
pp.endlit ",";
pp.txt " ";
do l;
pp.ind 0;
pp.cut ();
pp.lit ")";
};
do (lcf::EXCEPT (lambda_expression, withlexp))
=>
pp.box' 0 0 {.
pp.lit "lcf::EXCEPT ";
pp.ind 4;
pp.txt " ";
do lambda_expression;
pp.txt " WITH ";
do withlexp;
};
do (lcf::BOX (t, _, l))
=>
pp.box' 0 0 {.
pp.lit "lcf::BOX(";
pp.ind 4;
pp.txt " ";
hcf::prettyprint_uniqtype pp t;
pp.endlit ",";
pp.txt " ";
do l;
pp.ind 0;
pp.cut ();
pp.lit ")";
};
do (lcf::UNBOX (t, _, l))
=>
pp.box' 0 0 {.
pp.lit "lcf::UNBOX(";
pp.ind 4;
pp.txt " ";
hcf::prettyprint_uniqtype pp t;
pp.endlit ",";
pp.txt " ";
do l;
pp.ind 0;
pp.cut ();
pp.lit ")";
};
end;
end;
fun print_match (pp:Pp) dictionary ((pattern, expression) ! rest)
=>
{ pp.box' 0 0 {.
#
uds::unparse_pattern
dictionary
pp
(pattern, *global_controls::print::print_depth);
pp.ind 4;
pp.lit " =>";
pp.txt " ";
prettyprint_lambdacode_expression pp expression;
};
print_match pp dictionary rest;
};
print_match pp _ []
=>
();
end;
fun print_fun (pp:Pp) l v
=
find l
where
fun last (vh::HIGHCODE_VARIABLE x) => x;
last (vh::PATH (r, _)) => last r;
last _ => bug "unexpected varhome in last";
end;
recursive my find
=
\\ lcf::VAR w
=>
if (v==w)
pp.lit ("lcf::VAR " + name_of_highcode_codetemp v + " is free in <lambda_expression>\n");
();
fi;
l as lcf::FN (w, _, b)
=>
if (v == w) prettyprint_lambdacode_expression pp l;
else find b;
fi;
l as lcf::MUTUALLY_RECURSIVE_FNS (vl, _, ll, b)
=>
if (list::exists (\\ w = v==w) vl)
#
prettyprint_lambdacode_expression pp l;
else
apply find ll;
find b;
fi;
lcf::APPLY (l, r) => { find l;
find r;
};
lcf::LET (w, l, r) => { if (v==w) prettyprint_lambdacode_expression pp l;
else find l;
fi;
find r;
};
lcf::PACK (_, _, _, r) => find r;
lcf::TYPEFUN (_, r) => find r;
lcf::APPLY_TYPEFUN (l, _) => find l;
lcf::SWITCH (l, _, ls, d)
=>
{ find l;
#
apply (\\ (_, l) = find l)
ls;
case d NULL => ();
THE l => find l;
esac;
};
lcf::RECORD l => apply find l;
lcf::PACKAGE_RECORD l => apply find l;
lcf::VECTOR (l, t) => apply find l;
lcf::GET_FIELD(_, l) => find l;
lcf::CONSTRUCTOR((_, vh::EXCEPTION p, _), _, e)
=>
{ find (lcf::VAR (last p));
find e;
};
lcf::CONSTRUCTOR(_, _, e) => find e;
# DECON((_, vh::EXCEPTION p, _), _, e) => (find (lcf::VAR (last p)); find e);
# DECON(_, _, e) => find e ;
lcf::EXCEPT (e, h) => { find e; find h;};
lcf::RAISE (l, _) => find l;
lcf::INT _ => ();
lcf::UNT _ => ();
lcf::INT1 _ => ();
lcf::UNT1 _ => ();
lcf::STRING _ => ();
lcf::FLOAT64 _ => ();
lcf::EXCEPTION_TAG (e, _) => find e;
lcf::BASEOP _ => ();
lcf::GENOP ( { default=>e1, table=>es }, _, _, _)
=>
{ find e1;
apply (\\ (_, x) = find x) es;
};
lcf::BOX (_, _, e) => find e;
lcf::UNBOX(_, _, e) => find e;
end;
end;
fun string_tag (lcf::VAR _) => "lcf::VAR";
string_tag (lcf::INT _) => "lcf::INT";
string_tag (lcf::INT1 _) => "lcf::INT1";
string_tag (lcf::UNT _) => "lcf::UNT";
string_tag (lcf::UNT1 _) => "lcf::UNT1";
string_tag (lcf::FLOAT64 _) => "lcf::FLOAT64";
string_tag (lcf::STRING _) => "lcf::STRING";
string_tag (lcf::BASEOP _) => "lcf::BASEOP";
string_tag (lcf::GENOP _) => "lcf::GENOP";
#
string_tag (lcf::FN _) => "lcf::FN";
string_tag (lcf::MUTUALLY_RECURSIVE_FNS _) => "lcf::MUTUALLY_RECURSIVE_FNS";
string_tag (lcf::APPLY _) => "lcf::APPLY";
string_tag (lcf::LET _) => "STIPULATE";
string_tag (lcf::TYPEFUN _) => "lcf::TYPEFUN";
string_tag (lcf::APPLY_TYPEFUN _) => "lcf::APPLY_TYPEFUN";
string_tag (lcf::EXCEPTION_TAG _) => "lcf::EXCEPTION_TAG";
string_tag (lcf::RAISE _) => "lcf::RAISE";
string_tag (lcf::EXCEPT _) => "lcf::EXCEPT";
string_tag (lcf::CONSTRUCTOR _) => "lcf::CONSTRUCTOR";
string_tag (lcf::SWITCH _) => "lcf::SWITCH";
string_tag (lcf::VECTOR _) => "lcf::VECTOR";
string_tag (lcf::RECORD _) => "lcf::RECORD";
string_tag (lcf::PACKAGE_RECORD _) => "lcf::PACKAGE_RECORD";
string_tag (lcf::GET_FIELD _) => "lcf::GET_FIELD";
string_tag (lcf::PACK _) => "lcf::PACK";
string_tag (lcf::BOX _) => "lcf::BOX";
string_tag (lcf::UNBOX _) => "lcf::UNBOX";
end;
}; # package prettyprint_lambdacode_expression
end; # toplevel stipulate