## prettyprint-anormcode.pkg -- Pretty printer for A-Normal intermediate code format.
# Compiled by:
# src/lib/compiler/core.sublib# 2007-09-17CrT note:
# The original code here wrote text exclusively to 'control_print::say',
# clashing with the frontend convention of writing to a prettyprint stream
# (and incidentally forcing use of yet another primitive prettyprint library).
#
# As initial clean-up, I created duplicates of the 'say'-based functions
# which instead write to a prettyprint stream via a Prettyprinter.
# (Only) these new functions all have names starting with "prettyprint_";
# the matching older functions have names starting with "print_" or "p_".
#
# Eventually, of course, I'd like to eliminate the older forms completely. XXX BUGGO FIXME.
stipulate
package acf = anormcode_form; # anormcode_form is from src/lib/compiler/back/top/anormcode/anormcode-form.pkg package acj = anormcode_junk; # anormcode_junk is from src/lib/compiler/back/top/anormcode/anormcode-junk.pkg package ctrl = global_controls::highcode; # global_controls is from src/lib/compiler/toplevel/main/global-controls.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 pp = standard_prettyprinter; # standard_prettyprinter is from src/lib/prettyprint/big/src/standard-prettyprinter.pkg package ppr = standard_prettyprinter; # standard_prettyprinter is from src/lib/prettyprint/big/src/standard-prettyprinter.pkg package pj = 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.pkgherein
package prettyprint_anormcode
: Prettyprint_Anormcode # Prettyprint_Anormcode is from src/lib/compiler/back/top/anormcode/prettyprint-anormcode.api {
# Some print utilities:
say = control_print::say;
margin = REF 0;
exception UNDENT;
fun indent n
=
margin := *margin + n;
fun undent n
=
{ margin := *margin - n;
if (*margin < 0)
raise exception UNDENT;
fi;
};
fun dent ()
=
pj::tab *margin;
newline = pj::newline;
infix my & ;
fun (&) (f1, f2) ()
=
{ f1 ();
f2 ();
};
fun calling_convention_to_string calling_convention
=
{ fun h b
=
if b "r"; # Raw.
else "c"; # Cooked.
fi;
hcf::if_calling_convention_is_variable ( calling_convention,
\\ { arg_is_raw, body_is_raw } = (h arg_is_raw) + (h body_is_raw),
\\ _ = "f"
);
};
fun to_string_fkind ( { loop_info, call_as, inlining_hint, ... }: acf::Function_Notes)
=
case inlining_hint
#
acf::INLINE_WHENEVER_POSSIBLE => "(i)";
acf::INLINE_ONCE_WITHIN_ITSELF => "(u)";
acf::INLINE_MAYBE (s, ws) => "(i:" + (int::to_string s) + ")";
acf::INLINE_IF_SIZE_SAFE => "";
esac
+
case loop_info
#
THE (_, acf::OTHER_LOOP) => "R";
THE (_, acf::PREHEADER_WRAPPED_LOOP) => "LR";
THE (_, acf::TAIL_RECURSIVE_LOOP) => "TR";
NULL => "";
esac
+
case call_as
#
acf::CALL_AS_GENERIC_PACKAGE => "GENERIC";
acf::CALL_AS_FUNCTION fixed => ("FUN " + (calling_convention_to_string fixed));
esac;
# fun toStringFKind acf::FK_ESCAPE = "FK_ESCAPE"
# | toStringFKind acf::FK_KNOWN = "FK_KNOWN"
# | toStringFKind acf::FK_KREC = "FK_KREC"
# | toStringFKind acf::FK_KTAIL = "FK_KTAIL"
# | toStringFKind acf::FK_NOINL = "FK_NOINL"
# | toStringFKind acf::FK_HANDLER = "FK_HANDLER"
print_fkind = say o to_string_fkind;
# Classifications of various kinds of records:
fun to_string_rkind (acf::RK_VECTOR typ) => "VECTOR[" + hcf::uniqtype_to_string typ + "]";
to_string_rkind acf::RK_PACKAGE => "STRUCT";
to_string_rkind (acf::RK_TUPLE _) => "RECORD";
end;
print_rkind
=
say o to_string_rkind;
# Con: Used to specify all possible switching statements:
#
fun case_constant_to_string (acf::VAL_CASETAG((symbol, _, _), _, _)) => sy::name symbol;
#
case_constant_to_string (acf::INT_CASETAG i) => "(I)" + (int::to_string i);
case_constant_to_string (acf::INT1_CASETAG i) => "(I32)" + (one_word_int::to_string i);
case_constant_to_string (acf::UNT_CASETAG i) => "(W)" + (unt::to_string i);
case_constant_to_string (acf::UNT1_CASETAG i) => "(W32)" + (one_word_unt::to_string i);
case_constant_to_string (acf::FLOAT64_CASETAG r) => r;
case_constant_to_string (acf::STRING_CASETAG s) => pj::heap_string s;
case_constant_to_string (acf::VLEN_CASETAG n) => int::to_string n;
end;
print_case_constant
=
say o case_constant_to_string;
# Simple values, including variables and static constants:
fun to_string_value (acf::VAR v) => tmp::name_of_highcode_codetemp v;
#
to_string_value (acf::INT i) => "(I)" + int::to_string i;
to_string_value (acf::INT1 i) => "(I32)" + one_word_int::to_string i;
to_string_value (acf::UNT i) => "(W)" + unt::to_string i;
to_string_value (acf::UNT1 i) => "(W32)" + one_word_unt::to_string i;
#
to_string_value (acf::FLOAT64 r) => r;
to_string_value (acf::STRING s) => pj::heap_string s;
end;
print_sval
=
say o to_string_value;
lvar_string
=
REF tmp::name_of_highcode_codetemp;
fun print_variable v
=
say (*lvar_string v);
print_typ
=
say o hcf::uniqtype_to_string;
print_lty
=
say o hcf::uniqtypoid_to_string;
fun print_tv_tk (tv: tmp::Codetemp, tk)
=
say ( (tmp::name_of_highcode_codetemp tv)
+
":"
+
(hcf::uniqkind_to_string tk)
);
paren_comma_sep = ("(", ", ", ")");
print_val_list = pj::print_closed_sequence ("[", ", ", "]") print_sval;
print_var_list = pj::print_closed_sequence ("[", ", ", "]") print_variable;
print_type_list = pj::print_closed_sequence ("[", ", ", "]") print_typ;
print_lty_list = pj::print_closed_sequence ("[", ", ", "]") print_lty;
print_tv_tk_list = pj::print_closed_sequence ("[", ", ", "]") print_tv_tk;
fun print_decon (acf::VAL_CASETAG((_, varhome::CONSTANT _, _), _, _))
=>
();
# WARNING: a hack, but then what about constant exceptions ? XXX BUGGO FIXME
print_decon (acf::VAL_CASETAG((symbol, pick_valcon_form, lambda_type), types, highcode_variable))
=>
# <highcode_variable> = DECON(<symbol>,<sumtypeConstructorRepresentation>,<lambdaType>,[<types>])
{ print_variable highcode_variable;
say " = DECON(";
say (sy::name symbol);
say ", ";
say (varhome::print_representation pick_valcon_form);
say ", ";
print_lty lambda_type;
say ", ";
print_type_list types;
say ")";
newline();
dent();
};
print_decon _
=>
();
end;
fun apply_print prfun sepfun []
=>
();
apply_print prfun sepfun (x ! xs)
=>
{ prfun x;
apply
(\\ y = { sepfun(); prfun y;})
xs;
};
end;
# Definitions of the lambda expressions:
fun complex (acf::LET _) => TRUE;
complex (acf::MUTUALLY_RECURSIVE_FNS _) => TRUE;
complex (acf::TYPEFUN _) => TRUE;
complex (acf::SWITCH _) => TRUE;
complex (acf::CONSTRUCTOR _) => TRUE;
complex (acf::EXCEPT _) => TRUE;
complex _ => FALSE;
end;
fun p_lexp (acf::RET values)
=>
# RETURN [values]
{ say "RETURN ";
print_val_list values;
};
p_lexp (acf::APPLY (f, args))
=>
# APPLY (f, [args])
{ say "APPLY(";
print_sval f;
say ", ";
print_val_list args;
say ")";
};
p_lexp (acf::APPLY_TYPEFUN (tf, types))
=>
# APPLY_TYPEFUN (tf, [types])
{ say "APPLY_TYPEFUN(";
print_sval tf;
say ", ";
print_type_list types;
say ")";
};
p_lexp (acf::LET (vars, lambda_expression, body))
=>
# [vars] = lambda_expression OR
# [vars] =
# body lambda_expression
# body
{ print_var_list vars;
say " = ";
if (complex lambda_expression)
indent 2;
newline();
dent();
p_lexp lambda_expression;
undent 2;
else
len = (3 # for the " = "
+ 2 # for the "[]"
+ (length vars) # for each comma
+ (fold_forward # sum of varname lengths
(\\ (v, n) = n + (size (*lvar_string v)))
0 vars));
indent len;
p_lexp lambda_expression;
undent len;
fi;
newline ();
dent ();
p_lexp body;
};
p_lexp (acf::MUTUALLY_RECURSIVE_FNS (fundecs, body))
=>
# MUTUALLY_RECURSIVE_FNS(<fundec1>,
# <fundec2>,
# <fundec3>)
# <body>
{ say "MUTUALLY_RECURSIVE_FNS(";
indent 4;
apply_print print_fundec (newline & dent) fundecs;
undent 4;
say ")";
newline();
dent();
p_lexp body;
};
p_lexp (acf::TYPEFUN ((tfk as { inlining_hint, ... }, highcode_variable, tv_tk_list, tfnbody), body))
=>
# v =
# TYPEFUN([tk], lambdaType,
# <tfnbody>)
# <body>
{ print_variable highcode_variable;
say " = ";
newline();
indent 2;
dent();
if (inlining_hint != acf::INLINE_IF_SIZE_SAFE)
say "i";
fi;
say "TYPEFUN(";
print_tv_tk_list tv_tk_list;
say ", ";
# ** printLty lambdaType; say ", "; *** lambdaType no longer available **
newline();
indent 2;
dent();
p_lexp tfnbody;
undent 4;
say ")";
newline();
dent();
p_lexp body;
};
# NOTE: I'm ignoring the Valcon_Signature here:
p_lexp (acf::SWITCH (value, constructor_api, con_lexp_list, lexp_option))
=>
# SWITCH <value>
# <con> =>
# <Lambda_Expression>
# <con> =>
# <Lambda_Expression>
{ say "SWITCH ";
print_sval value;
newline();
indent 2;
dent();
apply_print
print_case (newline & dent) con_lexp_list;
case lexp_option
NULL => ();
THE lambda_expression # Default case
=>
{ newline ();
dent ();
say "_ => ";
indent 4;
newline ();
dent ();
p_lexp lambda_expression;
undent 4;
};
esac;
undent 2;
};
p_lexp (acf::CONSTRUCTOR ((symbol, _, _), types, value, highcode_variable, body))
=>
# <highcode_variable> = CON(<symbol>, <types>, <value>)
# <body>
{ print_variable highcode_variable;
say " = CON(";
say (sy::name symbol);
say ", ";
print_type_list types;
say ", ";
print_sval value;
say ")";
newline();
dent();
p_lexp body;
};
p_lexp (acf::RECORD (record_kind, values, highcode_variable, body))
=>
# <highcode_variable> = RECORD(<recordKind>, <values>)
# <body>
{ print_variable highcode_variable;
say " = ";
print_rkind record_kind;
say " ";
print_val_list values;
newline ();
dent ();
p_lexp body;
};
p_lexp (acf::GET_FIELD (value, int, highcode_variable, body))
=>
# <highcode_variable> = SELECT(<value>, <int>)
# <body>
{ print_variable highcode_variable;
say " = SELECT(";
print_sval value;
say ", ";
say (int::to_string int);
say ")";
newline();
dent();
p_lexp body;
};
p_lexp (acf::RAISE (value, ltys))
=>
# NOTE: I'm ignoring the Uniqtypoid list here. It is the return type
# of the raise exception expression. (ltys temporarily being printed --v)
# RAISE(<value>)
{ say "RAISE(";
print_sval value;
say ") : ";
print_lty_list ltys;
};
p_lexp (acf::EXCEPT (body, value))
=>
# <body>
# EXCEPT(<value>)
{ p_lexp body;
newline();
dent();
say "EXCEPT(";
print_sval value;
say ")";
};
p_lexp (acf::BRANCH ((d, baseop, lambda_type, types), values, body1, body2))
=>
# IF PRIM(<baseop>, <lambdaType>, [<types>]) [<values>]
# THEN
# <body1>
# ELSE
# <body2>
{ case d
NULL => say "IF BASEOP(";
_ => say "IF GENOP(";
esac;
say (hbo::baseop_to_string baseop);
say ", ";
print_lty lambda_type;
say ", ";
print_type_list types;
say ") ";
print_val_list values;
newline();
dent();
apply_print print_branch (newline & dent)
[("THEN", body1), ("ELSE", body2)];
};
p_lexp (acf::BASEOP (p as (_, hbo::MAKE_EXCEPTION_TAG, _, _), [value], highcode_variable, body))
=>
# <highcode_variable> = EXCEPTION_TAG(<value>[<typ>])
# <body>
{ print_variable highcode_variable;
say " = EXCEPTION_TAG(";
print_sval value;
say "[";
print_typ (acj::get_etag_type p);
say "])";
newline();
dent();
p_lexp body;
};
p_lexp (acf::BASEOP (p as (_, hbo::WRAP, _, _), [value], highcode_variable, body))
=>
# <highcode_variable> = WRAP(<typ>, <value>)
# <body>
{ print_variable highcode_variable;
say " = WRAP(";
print_typ (acj::get_wrap_type p);
say ", ";
print_sval value;
say ")";
newline();
dent();
p_lexp body;
};
p_lexp (acf::BASEOP (p as (_, hbo::UNWRAP, _, []), [value], highcode_variable, body))
=>
# <highcode_variable> = UNWRAP(<typ>, <value>)
# <body>
{ print_variable highcode_variable;
say " = UNWRAP(";
print_typ (acj::get_un_wrap_type p);
say ", ";
print_sval value;
say ")";
newline();
dent();
p_lexp body;
};
p_lexp (acf::BASEOP ((d, baseop, lambda_type, types), values, highcode_variable, body))
=>
# <highcode_variable> = PRIM(<baseop>, <lambdaType>, [<types>]) [<values>]
# <body>
{ print_variable highcode_variable;
case d
NULL => say " = BASEOP(";
_ => say " = GENOP(";
esac;
say (hbo::baseop_to_string baseop);
say ", ";
print_lty lambda_type;
say ", ";
print_type_list types;
say ") ";
print_val_list values;
newline();
dent();
p_lexp body;
};
end
also
fun print_fundec (fkind as { call_as, ... }, highcode_variable, lvar_lty_list, body)
=
# <highcode_variable> : (<fkind>) <lambdaType> =
# FN([v1: lambdaType1,
# v2: lambdaType2],
# <body>)
{ print_variable highcode_variable;
say " : ";
say "(";
print_fkind fkind;
say ") ";
# ** the return-result lambdaType no longer available ---- printLty lambdaType; *
say " = ";
newline();
indent 2;
dent();
say "FN([";
indent 4;
case lvar_lty_list
[] => ();
((highcode_variable, lambda_type) ! lll)
=>
{ print_variable highcode_variable;
say " : ";
if (*ctrl::print_function_types
or
call_as != acf::CALL_AS_GENERIC_PACKAGE
)
print_lty lambda_type;
else
say "???";
fi;
apply
(\\ (highcode_variable, lambda_type)
=
{ say ", ";
newline ();
dent ();
print_variable highcode_variable;
say " : ";
print_lty lambda_type;
})
lll;
};
esac;
say "], ";
newline();
undent 2;
dent();
p_lexp body;
say ")";
undent 4;
}
also
fun print_case (case_constant, lambda_expression)
=
{ print_case_constant case_constant;
say " => ";
indent 4;
newline();
dent();
print_decon case_constant;
p_lexp lambda_expression;
undent 4;
}
also
fun print_branch (s, lambda_expression)
=
{ say s;
indent 4;
newline ();
dent ();
p_lexp lambda_expression;
undent 4;
};
fun print_lexp lambda_expression
=
p_lexp lambda_expression
then
{ newline();
newline();
};
fun print_prog program
=
{ print_fundec program;
newline();
};
# Here's the new function which
# writes to a Prettyprinter
# instead of 'control_print::say'.
# It duplicates much of the above
# logic :-/
fun prettyprint_prog pp program
=
{ { prettyprint_function_declaration pp program;
pp.txt "\n";
}
where
fun prettyprint_sequence (separator: String) pr elements
=
prettyprint_elements elements
where
fun prettyprint_elements [el] => pr el;
prettyprint_elements (el ! rest) => { pr el; pp.txt separator; prettyprint_elements rest;};
prettyprint_elements [] => ();
end;
end;
fun prettyprint_closed_sequence (front: String, sep, back: String) pr elements
=
{ pp.txt front;
prettyprint_sequence sep pr elements;
pp.txt back;
};
fun prettyprint_fkind (pp: ppr::Prettyprinter) fkind
=
pp.txt (to_string_fkind fkind);
fun prettyprint_rkind (pp: ppr::Prettyprinter) rkind
=
pp.txt (to_string_rkind rkind);
fun prettyprint_case_constant (pp: ppr::Prettyprinter) case_constant
=
pp.txt (case_constant_to_string case_constant);
fun prettyprint_sval (pp: ppr::Prettyprinter) sval
=
pp.txt (to_string_value sval);
fun prettyprint_variable (pp: ppr::Prettyprinter) v
=
pp.txt (*lvar_string v);
fun prettyprint_type (pp: ppr::Prettyprinter) t
=
pp.txt (hcf::uniqtype_to_string t);
fun prettyprint_lty (pp: ppr::Prettyprinter) lty
=
pp.txt (hcf::uniqtypoid_to_string lty);
fun prettyprint_lty (pp: ppr::Prettyprinter) lty
=
pp.txt (hcf::uniqtypoid_to_string lty);
fun prettyprint_tv_tk (pp: ppr::Prettyprinter) (tv: tmp::Codetemp, tk)
=
pp.txt ( (tmp::name_of_highcode_codetemp tv)
+
":"
+
(hcf::uniqkind_to_string tk)
);
fun prettyprint_val_list (pp: ppr::Prettyprinter) = { pr = prettyprint_sval pp; prettyprint_closed_sequence ("[", ", ", "]") pr; };
fun prettyprint_var_list (pp: ppr::Prettyprinter) = { pr = prettyprint_variable pp; prettyprint_closed_sequence ("[", ", ", "]") pr; };
fun prettyprint_type_list (pp: ppr::Prettyprinter) = { pr = prettyprint_type pp; prettyprint_closed_sequence ("[", ", ", "]") pr; };
fun prettyprint_lty_list (pp: ppr::Prettyprinter) = { pr = prettyprint_lty pp; prettyprint_closed_sequence ("[", ", ", "]") pr; };
fun prettyprint_tv_tk_list (pp: ppr::Prettyprinter) = { pr = prettyprint_tv_tk pp; prettyprint_closed_sequence ("[", ", ", "]") pr; };
fun prettyprint_decon (pp: ppr::Prettyprinter) (acf::VAL_CASETAG((_, varhome::CONSTANT _, _), _, _))
=>
();
# WARNING: a hack, but then what about constant exceptions ? XXX BUGGO FIXME
prettyprint_decon pp (acf::VAL_CASETAG((symbol, pick_valcon_form, lambda_type), types, highcode_variable))
=>
# <highcode_variable> = DECON(<symbol>,<sumtypeConstructorRepresentation>,<lambdaType>,[<types>])
{ prettyprint_variable pp highcode_variable;
pp.txt " = DECON(";
pp.txt (sy::name symbol);
pp.txt ", ";
pp.txt (varhome::print_representation pick_valcon_form);
pp.txt ", ";
prettyprint_lty pp lambda_type;
pp.txt ", ";
prettyprint_type_list pp types;
pp.txt ")\n";
};
prettyprint_decon _ _
=>
();
end;
fun prettyprint_function_declaration pp (fkind as { call_as, ... }, highcode_variable, lvar_lty_list, body)
=
# <highcode_variable> : (<fkind>) <lambdaType> =
# FN([v1: lambdaType1,
# v2: lambdaType2],
# <body>)
{ prettyprint_variable pp highcode_variable;
pp.txt " : (";
prettyprint_fkind pp fkind;
pp.txt ") =\n"; # ** the return-result lambdaType no longer available ---- printLty lambdaType; *
pp.txt " FN( [ ";
pp.wrap' 4 0 {. pp.rulename "ppacw1";
#
case lvar_lty_list
#
[] => ();
((highcode_variable, lambda_type) ! lll)
=>
{ prettyprint_variable pp highcode_variable;
pp.txt " : ";
if ( *ctrl::print_function_types
or
call_as != acf::CALL_AS_GENERIC_PACKAGE
)
prettyprint_lty pp lambda_type;
else
pp.txt "???";
fi;
apply
(\\ (highcode_variable, lambda_type)
=
{ pp.box' 0 0 {. pp.rulename "ac1";
pp.txt ", "; prettyprint_variable pp highcode_variable;
pp.txt " : "; prettyprint_lty pp lambda_type;
};
})
lll;
};
esac;
pp.txt "],\n";
prettyprint_lambda_expression pp body;
pp.txt ")";
};
}
also
fun prettyprint_lambda_expression pp (acf::RET values)
=>
# RETURN [values]
{ pp.txt "RETURN ";
prettyprint_val_list pp values;
};
prettyprint_lambda_expression pp (acf::APPLY (f, args))
=>
# APPLY (f, [args])
{ pp.txt "APPLY(";
prettyprint_sval pp f;
pp.txt ", ";
prettyprint_val_list pp args;
pp.txt ")";
};
prettyprint_lambda_expression pp (acf::APPLY_TYPEFUN (tf, types))
=>
# APPLY_TYPEFUN (tf, [types])
{ pp.txt "APPLY_TYPEFUN(";
prettyprint_sval pp tf;
pp.txt ", ";
prettyprint_type_list pp types;
pp.txt ")";
};
prettyprint_lambda_expression pp (acf::LET (vars, lambda_expression, body))
=>
# [vars] = lambda_expression OR
# [vars] =
# body lambda_expression
# body
{ prettyprint_var_list pp vars;
pp.txt " = ";
if (complex lambda_expression)
#
pp.wrap' 4 0 {. pp.rulename "ppacw2";
pp.txt "\n";
prettyprint_lambda_expression pp lambda_expression;
};
else
len = (3 # for the " = "
+ 2 # for the "[]"
+ (length vars) # for each comma
+ (fold_forward # sum of varname lengths
(\\ (v, n) = n + (size (*lvar_string v)))
0 vars));
pp.wrap' len 0 {. pp.rulename "ppacw3";
prettyprint_lambda_expression pp lambda_expression;
};
fi;
pp.txt "\n";
prettyprint_lambda_expression pp body;
};
prettyprint_lambda_expression pp (acf::MUTUALLY_RECURSIVE_FNS (fundecs, body))
=>
# MUTUALLY_RECURSIVE_FNS(<fundec1>,
# <fundec2>,
# <fundec3>)
# <body>
{ pp.txt "MUTUALLY_RECURSIVE_FNS(";
pp.wrap' 4 0 {. pp.rulename "ppacw4";
apply_print
(prettyprint_function_declaration pp)
{. pp.txt "\n";}
fundecs;
};
pp.txt ")\n";
prettyprint_lambda_expression pp body;
};
prettyprint_lambda_expression pp (acf::TYPEFUN ((tfk as { inlining_hint, ... }, highcode_variable, tv_tk_list, tfnbody), body))
=>
# v =
# TYPEFUN([tk], lambdaType,
# <tfnbody>)
# <body>
{ prettyprint_variable pp highcode_variable;
pp.txt " = \n";
pp.wrap' 0 2 {. pp.rulename "ppacw5";
if (inlining_hint != acf::INLINE_IF_SIZE_SAFE)
#
pp.txt "i";
fi;
pp.txt "TYPEFUN(";
prettyprint_tv_tk_list pp tv_tk_list;
pp.txt ", \n"; # ** printLty lambdaType; say ", "; *** lambdaType no longer available **
pp.wrap' 0 2 {. pp.rulename "ppacw6";
prettyprint_lambda_expression pp tfnbody;
};
};
pp.txt ")\n";
prettyprint_lambda_expression pp body;
};
# NOTE: I'm ignoring the Valcon_Signature here:
prettyprint_lambda_expression pp (acf::SWITCH (value, constructor_api, con_lexp_list, lexp_option))
=>
# SWITCH <value>
# <con> =>
# <Lambda_Expression>
# <con> =>
# <Lambda_Expression>
{ pp.txt "SWITCH ";
prettyprint_sval pp value;
pp.txt "\n";
#
pp.wrap' 0 2 {. pp.rulename "ppacw7";
apply_print
(prettyprint_case pp)
{. pp.txt "\n"; }
con_lexp_list;
case lexp_option
#
NULL => ();
THE lambda_expression # Default case
=>
{ pp.txt "\n_ => ";
pp.wrap' 4 0 {. pp.rulename "ppacw8";
pp.txt "\n";
prettyprint_lambda_expression pp lambda_expression;
};
};
esac;
};
};
prettyprint_lambda_expression pp (acf::CONSTRUCTOR ((symbol, _, _), types, value, highcode_variable, body))
=>
# <highcode_variable> = CONSTRUCTOR(<symbol>, <types>, <value>)
# <body>
#
{ prettyprint_variable pp highcode_variable;
pp.txt " = CONSTRUCTOR(";
pp.txt (sy::name symbol);
pp.txt ", ";
prettyprint_type_list pp types;
pp.txt ", ";
prettyprint_sval pp value;
pp.txt ")\n";
prettyprint_lambda_expression pp body;
};
prettyprint_lambda_expression pp (acf::RECORD (record_kind, values, highcode_variable, body))
=>
# <highcode_variable> = RECORD(<recordKind>, <values>)
# <body>
{ prettyprint_variable pp highcode_variable;
pp.txt " = ";
prettyprint_rkind pp record_kind;
pp.txt " ";
prettyprint_val_list pp values;
pp.txt "\n";
prettyprint_lambda_expression pp body;
};
prettyprint_lambda_expression pp (acf::GET_FIELD (value, int, highcode_variable, body))
=>
# <highcode_variable> = SELECT(<value>, <int>)
# <body>
{ prettyprint_variable pp highcode_variable;
pp.txt " = SELECT(";
prettyprint_sval pp value;
pp.txt ", ";
pp.txt (int::to_string int);
pp.txt ")\n";
prettyprint_lambda_expression pp body;
};
prettyprint_lambda_expression pp (acf::RAISE (value, ltys))
=>
# NOTE: I'm ignoring the Uniqtypoid list here. It is the return type
# of the raise exception expression. (ltys temporarily being printed --v)
# RAISE(<value>)
{ pp.txt "RAISE(";
prettyprint_sval pp value;
pp.txt ") : ";
prettyprint_lty_list pp ltys;
};
prettyprint_lambda_expression pp (acf::EXCEPT (body, value))
=>
# <body>
# EXCEPT(<value>)
{ prettyprint_lambda_expression pp body;
pp.txt "\n";
pp.txt "EXCEPT(";
prettyprint_sval pp value;
pp.txt ")";
};
prettyprint_lambda_expression pp (acf::BRANCH ((d, baseop, lambda_type, types), values, body1, body2))
=>
# IF PRIM(<baseop>, <lambdaType>, [<types>]) [<values>]
# THEN
# <body1>
# ELSE
# <body2>
{ case d
NULL => pp.txt "IF BASEOP(";
_ => pp.txt "IF GENOP(";
esac;
pp.txt (hbo::baseop_to_string baseop);
pp.txt ", ";
prettyprint_lty pp lambda_type;
pp.txt ", ";
prettyprint_type_list pp types;
pp.txt ") ";
prettyprint_val_list pp values;
pp.txt "\n";
apply_print
(prettyprint_branch pp)
{. pp.txt "\n";}
[("THEN", body1), ("ELSE", body2)];
};
prettyprint_lambda_expression pp (acf::BASEOP (p as (_, hbo::MAKE_EXCEPTION_TAG, _, _), [value], highcode_variable, body))
=>
# <highcode_variable> = EXCEPTION_TAG(<value>[<typ>])
# <body>
{ prettyprint_variable pp highcode_variable;
pp.txt " = EXCEPTION_TAG(";
prettyprint_sval pp value;
pp.txt "[";
prettyprint_type pp (acj::get_etag_type p);
pp.txt "])\n";
prettyprint_lambda_expression pp body;
};
prettyprint_lambda_expression pp (acf::BASEOP (p as (_, hbo::WRAP, _, _), [value], highcode_variable, body))
=>
# <highcode_variable> = WRAP(<typ>, <value>)
# <body>
{ prettyprint_variable pp highcode_variable;
pp.txt " = WRAP(";
prettyprint_type pp (acj::get_wrap_type p);
pp.txt ", ";
prettyprint_sval pp value;
pp.txt ")\n";
prettyprint_lambda_expression pp body;
};
prettyprint_lambda_expression pp (acf::BASEOP (p as (_, hbo::UNWRAP, _, []), [value], highcode_variable, body))
=>
# <highcode_variable> = UNWRAP(<typ>, <value>)
# <body>
{ prettyprint_variable pp highcode_variable;
pp.txt " = UNWRAP(";
prettyprint_type pp (acj::get_un_wrap_type p);
pp.txt ", ";
prettyprint_sval pp value;
pp.txt ")\n";
prettyprint_lambda_expression pp body;
};
prettyprint_lambda_expression pp (acf::BASEOP ((d, baseop, lambda_type, types), values, highcode_variable, body))
=>
# <highcode_variable> = PRIM(<baseop>, <lambdaType>, [<types>]) [<values>]
# <body>
{ prettyprint_variable pp highcode_variable;
case d
NULL => pp.txt " = BASEOP(";
_ => pp.txt " = GENOP(";
esac;
pp.txt (hbo::baseop_to_string baseop);
pp.txt ", ";
prettyprint_lty pp lambda_type;
pp.txt ", ";
prettyprint_type_list pp types;
pp.txt ") ";
prettyprint_val_list pp values;
pp.txt "\n";
prettyprint_lambda_expression pp body;
};
end
also
fun prettyprint_case pp (case_constant, lambda_expression)
=
{ prettyprint_case_constant pp case_constant;
pp.txt " => ";
pp.wrap' 4 0 {. pp.rulename "ppacw9";
pp.txt "\n";
prettyprint_decon pp case_constant;
prettyprint_lambda_expression pp lambda_expression;
};
}
also
fun prettyprint_branch (pp: ppr::Prettyprinter) (s, lambda_expression)
=
{ pp.txt s;
pp.wrap' 4 0 {. pp.rulename "ppacw10";
pp.txt "\n";
prettyprint_lambda_expression pp lambda_expression;
};
};
end;
}; # fun prettyprint_prog
}; # package prettyprint_anormcode
end; # stipulate