## 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 tmp = highcode_codetemp; # highcode_codetemp is from src/lib/compiler/back/top/highcode/highcode-codetemp.pkg package lcf = lambdacode_form; # lambdacode_form is from src/lib/compiler/back/top/lambdacode/lambdacode-form.pkg package syx = symbolmapstack; # symbolmapstack is from src/lib/compiler/front/typer-stuff/symbolmapstack/symbolmapstack.pkgherein
api Prettyprint_Lambdacode_Expression {
#
print_casetag: lcf::Casetag -> Void;
print_lexp: lcf::Lambdacode_Expression -> Void;
print_match: syx::Symbolmapstack -> List( (ds::Case_Pattern, lcf::Lambdacode_Expression) ) -> Void;
print_fun: lcf::Lambdacode_Expression -> tmp::Codetemp -> Void;
string_tag: lcf::Lambdacode_Expression -> String;
};
end;
stipulate
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 tmp = highcode_codetemp; # highcode_codetemp is from src/lib/compiler/back/top/highcode/highcode-codetemp.pkg package lcf = lambdacode_form; # lambdacode_form is from src/lib/compiler/back/top/lambdacode/lambdacode-form.pkg package pp = prettyprint; # prettyprint is from src/lib/prettyprint/big/src/prettyprint.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 vh = varhome; # varhome is from src/lib/compiler/front/typer-stuff/basics/varhome.pkg #
include 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
=
error_message::impossible ("MCprint: " + 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;
else if (n >= 8)
"\t" ! ws (n - 8);
else str = case n 0 => ""; 1 => " "; 2 => " ";
3 => " "; 4 => " ";
5 => " "; 6 => " ";
_ => " ";
esac;
[str];
fi;
fi;
end;
fun print_casetag x
=
say (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 print_lexp l
=
{ fun pr_lty t = say (hcf::uniqtype_to_string t);
fun pr_typ t = say (hcf::uniqtyp_to_string t);
fun pr_knd k = say (hcf::uniqkind_to_string k);
fun plist (p, [], sep) => ();
plist (p, a ! r, sep) => { p a; apply (fn x = { say sep; p x;}) r;};
end;
fun g (lcf::VAR v) => say (name_of_highcode_codetemp v);
g (lcf::INT i) => say (int::to_string i);
g (lcf::UNT i) => { say "(U)"; say (unt::to_string i); };
g (lcf::INT1 i) => { say "(I32)"; say (one_word_int::to_string i); };
g (lcf::UNT1 i) => { say "(U32)"; say (one_word_unt::to_string i); };
g (lcf::FLOAT64 s) => say s;
g (lcf::STRING s) => say (heap_string s);
g (lcf::EXCEPTION_TAG (l, _)) => g l;
g (r as lcf::RECORD l)
=>
if (complex r)
#
say "lcf::RECORD";
indent 7;
pu::print_closed_sequence ("(", ",\n" + whitespace(), ")") g l;
undent 7;
else
say "lcf::RECORD";
pu::print_closed_sequence ("(", ", ", ")") g l;
fi;
g (r as lcf::PACKAGE_RECORD l)
=>
if (complex r)
#
say "lcf::PACKAGE_RECORD";
indent 7;
pu::print_closed_sequence ("(", ",\n" + whitespace(), ")") g l;
undent 7;
else
say "lcf::PACKAGE_RECORD";
pu::print_closed_sequence ("(", ", ", ")") g l;
fi;
g (r as lcf::VECTOR (l, _))
=>
if (complex r)
#
say "lcf::VECTOR";
indent 7;
pu::print_closed_sequence ("(", ",\n" + whitespace(), ")") g l;
undent 7;
else
say "lcf::VECTOR";
pu::print_closed_sequence ("(", ", ", ")") g l;
fi;
g (lcf::BASEOP (p, t, ts))
=>
{ say ("lcf::BASEOP (" + (hbo::baseop_to_string p) + ", ");
pr_lty t;
say ", ["; plist (pr_typ, ts, ", ");
say "])";
};
g (l as lcf::GET_FIELD (i, _))
=>
{ fun gather (lcf::GET_FIELD (i, l))
=>
{ my (more, root) = gather l;
(i ! more, root);
};
gather l
=>
(NIL, l);
end;
my (path, root)
=
gather l;
fun ipr (i: Int)
=
say (int::to_string i);
g root;
pu::print_closed_sequence ("[", ", ", "]") ipr (reverse path);
};
g (lcf::FN (v, t, l))
=>
{ say "lcf::FN(";
say (name_of_highcode_codetemp v);
say " : ";
pr_lty t;
say ", ";
if (complex l)
#
newline();
indent 3;
dent();
g l;
say ")";
undent 3;
else
g l;
say ")";
fi;
};
g (lcf::CONSTRUCTOR((s, c, lt), ts, l))
=>
{ say "lcf::CONSTRUCTOR((";
say (sy::name s);
say ", ";
sayrep c;
say ", ";
pr_lty lt;
say "), [";
plist (pr_typ, ts, ", ");
say "], ";
if (complex l)
indent 4;
g l;
say ")";
undent 4;
else
g l;
say ")";
fi;
};
/*
| g (DECON((s, c, lt), ts, l)) =
(say "DECON(("; say (sy::name s); say ", "; sayrep c; say ", ";
prLty lt; say "), ["; plist (prTypeConstructor, ts, ", "); say "], ";
if complex l then (indent 4; g l; say ")"; undent 4)
else (g l; say ")"))
*/
g (lcf::APPLY (lcf::FN (v, _, l), r))
=>
{ say "(lcf::APPLY) ";
g (lcf::LET (v, r, l));
};
g (lcf::LET (v, r, l))
=>
{ lv = name_of_highcode_codetemp v;
len = size lv + 3;
say lv; say " = ";
if (complex r)
indent 2;
newline();
dent();
g r;
undent 2;
else
indent len ;
g r;
undent len;
fi;
newline();
dent();
g l;
};
g (lcf::APPLY (l, r))
=>
{ say "lcf::APPLY(";
if (complex l or complex r)
indent 4;
g l; say ",\n"; dent();
g r; say ")"; undent 4;
else
g l; say ", ";
g r; say ")";
fi;
};
g (lcf::TYPEFUN (ks, b))
=>
{ say "lcf::TYPEFUN(";
apply (fn k = { pr_knd k; say ", ";})
ks;
if (complex b)
newline();
indent 3;
dent();
g b;
say ")";
undent 3;
else
g b;
say ")";
fi;
};
g (lcf::APPLY_TYPEFUN (l, ts))
=>
{ say "lcf::APPLY_TYPEFUN(";
if (complex l)
indent 4;
g l;
say ",\n";
dent();
say "[";
plist (pr_typ, ts, ", "); say "])";
undent 4;
else
g l;
say ", [";
plist (pr_typ, ts, ", ");
say "])";
fi;
};
g (lcf::GENOP (dictionary, p, t, ts))
=>
{ say ("lcf::GENOP (" + (hbo::baseop_to_string p) + ", ");
pr_lty t;
say ", [";
plist (pr_typ, ts, ", ");
say "])";
};
g (lcf::PACK (lt, ts, nts, l))
=>
{ say "lcf::PACK(";
app2 ( fn (tc, ntc)
=
{ say "<";
pr_typ tc;
say ", ";
pr_typ ntc;
say ">, ";
},
ts,
nts
);
say " ";
pr_lty lt;
say ", ";
if (complex l)
newline();
indent 3;
dent();
g l;
say ")";
undent 3;
else
g l;
say ")";
fi;
};
g (lcf::SWITCH (l, _, llist, default))
=>
{ fun switch [(c, l)]
=>
{ print_casetag c;
say " => ";
indent 8;
g l;
undent 8;
};
switch ((c, l) ! more)
=>
{ print_casetag c;
say " => ";
indent 8;
g l;
undent 8;
newline();
dent();
switch more;
};
switch []
=>
bug "unexpected case in switch";
end;
say "lcf::SWITCH ";
indent 7; g l; undent 6; newline(); dent();
say "of "; indent 3; switch llist;
case (default, llist)
(NULL, _) => ();
(THE l, NIL) => { say "_ => "; indent 5; g l; undent 5;};
(THE l, _) => { newline(); dent(); say "_ => ";
indent 5; g l; undent 5;};
esac;
undent 4;
};
g (lcf::MUTUALLY_RECURSIVE_FNS (varlist, ltylist, lexplist, lambda_expression))
=>
{ fun flist ([v],[t],[l])
=>
{ lv = name_of_highcode_codetemp v;
len = size lv + 2;
say lv; say " : ";pr_lty t;say " . ";
indent len ; g l; undent len;
};
flist (v ! vs, t ! ts, l ! ls)
=>
{ lv = name_of_highcode_codetemp v;
len = size lv + 2;
say lv; say " : "; pr_lty t; say " . ";
indent len ; g l; undent len;
newline(); dent(); flist (vs, ts, ls);
};
flist (NIL, NIL, NIL)
=> ();
flist _
=>
bug "unexpected cases in flist";
end;
say "lcf::MUTUALLY_RECURSIVE_FNS("; indent 4; flist (varlist, ltylist, lexplist);
undent 4; newline(); dent(); say "IN ";
indent 4; g lambda_expression; say ")"; undent 4;
};
g (lcf::RAISE (l, t))
=>
{ say "lcf::RAISE(";
pr_lty t;
say ", ";
indent 6;
g l;
say ")";
undent 6;
};
g (lcf::EXCEPT (lambda_expression, withlexp))
=>
{ say "lcf::EXCEPT "; indent 7; g lambda_expression; undent 5; newline(); dent();
say "WITH "; indent 5; g withlexp; undent 7;
};
g (lcf::BOX (t, _, l))
=>
{ say "lcf::BOX("; pr_typ t; say ", "; indent 5; newline(); dent(); g l;
say ")"; undent 5;
};
g (lcf::UNBOX (t, _, l))
=>
{ say "lcf::UNBOX("; pr_typ t; say ", "; indent 7;
newline(); dent(); g l; say ")"; undent 7;
};
end;
g l;
newline();
newline();
};
fun print_match dictionary ((p, r) ! more)
=>
{ pp::with_prettyprint_device
(error_message::default_plaint_sink ())
(fn stream
=
{ unparse_deep_syntax::unparse_pattern
dictionary
stream
(p, *global_controls::print::print_depth);
pp::newline stream;
}
);
say " => ";
print_lexp r;
print_match dictionary more;
};
print_match _ []
=>
();
end;
fun print_fun 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 val find
=
fn lcf::VAR w
=>
if (v==w)
say("lcf::VAR " + name_of_highcode_codetemp v + " is free in <lambda_expression>\n"); ();
fi;
l as lcf::FN (w, _, b)
=>
if (v == w) print_lexp l;
else find b;
fi;
l as lcf::MUTUALLY_RECURSIVE_FNS (vl, _, ll, b)
=>
if (list::exists (fn w = v==w) vl)
#
print_lexp l;
else
apply find ll;
find b;
fi;
lcf::APPLY (l, r) => { find l; find r;};
lcf::LET (w, l, r) => { if (v==w ) print_lexp 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 (fn (_, 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 (fn (_, 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