## prettyprint-highcode-types.pkg
# Compiled by:
# src/lib/compiler/core.sublib# modified to use Lib7 Lib pp. [dbm, 7/30/03])
stipulate
package hut = highcode_uniq_types; # highcode_uniq_types is from src/lib/compiler/back/top/highcode/highcode-uniq-types.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 tdt = type_declaration_types; # type_declaration_types is from src/lib/compiler/front/typer-stuff/types/type-declaration-types.pkgherein
api Prettyprint_Highcode_Types {
#
prettyprint_calling_convention
:
syx::Symbolmapstack
-> pp::Prettyprinter
-> hut::Calling_Convention
-> Void;
prettyprint_kind
:
syx::Symbolmapstack
-> pp::Prettyprinter
-> hut::kind::Kind
-> Void;
prettyprint_type
:
syx::Symbolmapstack
-> pp::Prettyprinter
-> hut::Type
-> Void;
prettyprint_typoid
:
syx::Symbolmapstack
-> pp::Prettyprinter
-> hut::Typoid
-> Void;
prettyprint_uniqkind
:
syx::Symbolmapstack
-> pp::Prettyprinter
-> hut::Uniqkind
-> Void;
prettyprint_uniqtype
:
syx::Symbolmapstack
-> pp::Prettyprinter
-> hut::Uniqtype
-> Void;
prettyprint_uniqtypoid
:
syx::Symbolmapstack
-> pp::Prettyprinter
-> hut::Uniqtypoid
-> Void;
};
end;
stipulate
package di = debruijn_index; # debruijn_index is from src/lib/compiler/front/typer/basics/debruijn-index.pkg package fis = find_in_symbolmapstack; # find_in_symbolmapstack is from src/lib/compiler/front/typer-stuff/symbolmapstack/find-in-symbolmapstack.pkg package hbt = highcode_basetypes; # highcode_basetypes is from src/lib/compiler/back/top/highcode/highcode-basetypes.pkg package hut = highcode_uniq_types; # highcode_uniq_types is from src/lib/compiler/back/top/highcode/highcode-uniq-types.pkg package ip = inverse_path; # inverse_path is from src/lib/compiler/front/typer-stuff/basics/symbol-path.pkg package mtt = more_type_types; # more_type_types is from src/lib/compiler/front/typer/types/more-type-types.pkg package pp = standard_prettyprinter; # standard_prettyprinter is from src/lib/prettyprint/big/src/standard-prettyprinter.pkg package sta = stamp; # stamp is from src/lib/compiler/front/typer-stuff/basics/stamp.pkg package syp = symbol_path; # symbol_path is from src/lib/compiler/front/typer-stuff/basics/symbol-path.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.pkg package ts = type_junk; # type_junk is from src/lib/compiler/front/typer-stuff/types/type-junk.pkg package tdt = type_declaration_types; # type_declaration_types is from src/lib/compiler/front/typer-stuff/types/type-declaration-types.pkg package uj = unparse_junk; # unparse_junk is from src/lib/compiler/front/typer/print/unparse-junk.pkg #
Pp = pp::Pp;
herein
package prettyprint_highcode_types
: (weak) Prettyprint_Highcode_Types
{
# package kind: api {
# Kind
# = PLAINTYPE # Ground typelocked type.
# | BOXEDTYPE # Boxed/tagged type.
# | KINDSEQ List(Uniqkind) # Sequence of kinds.
# | KINDFUN (List(Uniqkind), Uniqkind) # Kind function.
# ;
# };
# Kind = kind::Kind;
#
#
#
# # Definitions of Typ and Type-dictionary:
# #
#
# Calling_Convention # Calling conventions
# #
# = FIXED_CALLING_CONVENTION # Used after representation analysis.
# #
# | VARIABLE_CALLING_CONVENTION # Used prior to representation analsys.
# { arg_is_raw: Bool,
# body_is_raw: Bool
# }
# ;
#
# Useless_Recordflag = USELESS_RECORDFLAG; # tuple kind: a template. (Appears to be something someone started but didn't finish -- CrT)
#
# package type: api { # SML/NJ calls this "tycon" ("type constructor").
# #
# # Note that a TYPEFUN is a type -> type compiletime function,
# # whereas an ARROW_TYPE represents a value -> value runtime function.
# #
# Type
# = DEBRUIJN_TYPEVAR (di::Debruijn_Index, Int) # Type variable.
# | NAMED_TYPEVAR tmp::Codetemp # Named type variable.
# | BASETYPE hbt::Basetype # Base type -- Int, String etc.
# #
# | TYPEFUN (List(Uniqkind), Uniqtype) # Type abstraction.
# | APPLY_TYPEFUN (Uniqtype, List(Uniqtype)) # Type application.
# #
# | TYPESEQ List( Uniqtype ) # Type sequence.
# | ITH_IN_TYPESEQ (Uniqtype, Int) # Type projection.
# #
# | SUM List(Uniqtype) # Sum type.
# | RECURSIVE ((Int, Uniqtype, List(Uniqtype)), Int) # Recursive type.
# #
# | TUPLE (Useless_Recordflag, List(Uniqtype)) # Standard record Type
# | ARROW (Calling_Convention, List(Uniqtype), List(Uniqtype)) # Standard function Type
# | PARROW (Uniqtype, Uniqtype) # Special fun Type, not used
# #
# | BOXED Uniqtype # Boxed Type
# | ABSTRACT Uniqtype # Abstract Type -- not used.
# | EXTENSIBLE_TOKEN (Token, Uniqtype) # extensible token Type
# | FATE List(Uniqtype) # Standard fate Type
# | INDIRECT_TYPE_THUNK (Uniqtype, Type) # Indirect Type thunk
# | TYPE_CLOSURE (Uniqtype, Int, Int, Uniqtype_Dictionary) # Type closure
# ;
# };
# Type = type::Type;
#
# # Definition of Uniqtypoid:
# #
# package typoid: api {
# Typoid
# = TYPE Uniqtype # Typelocked type.
# | PACKAGE List(Uniqtypoid) # Package type.
# | GENERIC_PACKAGE (List(Uniqtypoid), List(Uniqtypoid)) # Generic-package type.
# | TYPEAGNOSTIC (List(Uniqkind), List(Uniqtypoid)) # Typeagnostic type.
# | FATE List(Uniqtypoid) # Internal fate type.
# | INDIRECT_TYPE_THUNK (Uniqtypoid, Typoid) # A Uniqtypoid thunk and its api.
# | TYPE_CLOSURE (Uniqtypoid, Int, Int, Uniqtype_Dictionary) # Type closure.
# ;
# };
# Typoid = typoid::Typoid;
fun prettyprint_calling_convention
(symbolmapstack: syx::Symbolmapstack)
(pp: pp::Pp)
(calling_convention: hut::Calling_Convention)
:
Void
=
case calling_convention
#
hut::FIXED_CALLING_CONVENTION
=>
pp.txt "hut::FIXED_CALLING_CONVENTION ";
hut::VARIABLE_CALLING_CONVENTION { arg_is_raw: Bool, body_is_raw: Bool }
=>
pp.txt (sprintf "hut::VARIABLE_CALLING_CONVENTION { arg_is_raw=>%B, body_is_raw=>%B } " arg_is_raw body_is_raw);
esac
also
fun prettyprint_kind
(symbolmapstack: syx::Symbolmapstack)
pp
(kind: hut::Kind)
:
Void
=
case kind
#
hut::kind::PLAINTYPE => pp.lit "hut::kind::PLAINTYPE ";
hut::kind::BOXEDTYPE => pp.lit "hut::kind::BOXEDTYPE ";
hut::kind::KINDSEQ (uniqkinds: List(hut::Uniqkind))
=>
{
pp.wrap {. pp.rulename "pphctw1";
#
pp.txt "hut::kind::KINDSEQ [";
apply pp_uniqkind uniqkinds
where
fun pp_uniqkind uniqkind
=
{ prettyprint_uniqkind symbolmapstack pp uniqkind;
pp.txt ", "; # This prints a ',' at end of list -- ick.
};
end;
pp.lit "]hut::kind::KINDSEQ";
};
};
hut::kind::KINDFUN (uniqkinds: List(hut::Uniqkind), uniqkind: hut::Uniqkind)
=>
{
pp.wrap {. pp.rulename "pphctw2";
#
pp.txt "hut::kind::KINDFUN ([";
apply pp_uniqkind uniqkinds
where
fun pp_uniqkind uniqkind
=
{ prettyprint_uniqkind symbolmapstack pp uniqkind;
pp.txt ", "; # This prints a ',' at end of list -- ick.
};
end;
pp.txt "], ";
prettyprint_uniqkind symbolmapstack pp uniqkind;
pp.lit ")";
};
};
esac
also
fun prettyprint_type
(symbolmapstack: syx::Symbolmapstack)
pp
(type: hut::Type)
:
Void
=
case type
#
hut::type::DEBRUIJN_TYPEVAR (debruijn_index: di::Debruijn_Index, int)
=>
pp.txt (sprintf "hut::type::DEBRUIJN_TYPEVAR(index==%d, i==%d) " (di::di_toint debruijn_index) int);
hut::type::NAMED_TYPEVAR (tmp: tmp::Codetemp)
=>
pp.txt (sprintf "hut::type::NAMED_TYPEVAR(%s) " (tmp::to_string tmp));
hut::type::BASETYPE (basetype: hbt::Basetype)
=>
pp.txt (sprintf "hut::type::BASETYPE(%s) " (hbt::basetype_to_string basetype));
hut::type::TYPEFUN (uniqkinds: List(hut::Uniqkind), uniqtype: hut::Uniqtype)
=>
{
pp.box' 0 0 {. pp.rulename "pphctw3";
#
pp.txt "hut::kind::TYPEFUN (";
pp.box' 0 2 {.
pp.txt "[ ";
pp.ind 2;
pp::seqx{. pp.endlit ","; pp.txt " "; } # Print separator.
{. prettyprint_uniqkind symbolmapstack pp #uniqkind; } # Print element.
uniqkinds; # List of elements.
# apply pp_uniqkind uniqkinds
# where
# fun pp_uniqkind uniqkind
# =
# { prettyprint_uniqkind symbolmapstack pp uniqkind;
# pp.txt ", "; # This prints a ',' at end of list -- ick.
# };
# end;
pp.ind -2;
pp.txt " ";
pp.txt "], ";
};
prettyprint_uniqtype symbolmapstack pp uniqtype;
pp.ind 0;
pp.txt " ";
pp.lit ")";
};
};
hut::type::APPLY_TYPEFUN (uniqtype: hut::Uniqtype, uniqtypes: List(hut::Uniqtype))
=>
{
pp.txt "hut::type::APPLY_TYPEFUN( ";
prettyprint_uniqtype symbolmapstack pp uniqtype;
pp.txt ", [";
apply pp_uniqtype uniqtypes
where
fun pp_uniqtype uniqtype
=
{ prettyprint_uniqtype symbolmapstack pp uniqtype;
pp.txt ", "; # This prints a ',' at end of list -- ick.
};
end;
pp.txt "]) ";
};
hut::type::TYPESEQ (uniqtypes: List(hut::Uniqtype))
=>
{
pp.txt "hut::type::TYPESEQ[ ";
apply pp_uniqtype uniqtypes
where
fun pp_uniqtype uniqtype
=
{ prettyprint_uniqtype symbolmapstack pp uniqtype;
pp.txt ", "; # This prints a ',' at end of list -- ick.
};
end;
pp.txt "]hut::type::TYPESEQ ";
};
hut::type::ITH_IN_TYPESEQ (uniqtype: hut::Uniqtype, i: Int)
=>
{
pp.txt "hut::type::ITH_IN_TYPESEQ( ";
prettyprint_uniqtype symbolmapstack pp uniqtype;
pp.txt ", ";
pp.txt (sprintf "%d)" i);
};
hut::type::SUM (uniqtypes: List(hut::Uniqtype))
=>
{
pp.wrap {. pp.rulename "pphctw4";
pp.txt "hut::type::SUM[ ";
apply pp_uniqtype uniqtypes
where
fun pp_uniqtype uniqtype
=
{ prettyprint_uniqtype symbolmapstack pp uniqtype;
pp.txt ", "; # This prints a ',' at end of list -- ick.
};
end;
pp.txt "]hut::type::SUM ";
};
};
hut::type::RECURSIVE ((i: Int, uniqtype: hut::Uniqtype, uniqtypes: List(hut::Uniqtype)), j: Int)
=>
{
pp.wrap {. pp.rulename "pphctw5";
pp.txt "hut::type::RECURSIVE( ";
pp.txt (sprintf "%d, " i);
prettyprint_uniqtype symbolmapstack pp uniqtype;
pp.txt ", [";
apply pp_uniqtype uniqtypes
where
fun pp_uniqtype uniqtype
=
{ prettyprint_uniqtype symbolmapstack pp uniqtype;
pp.txt ", "; # This prints a ',' at end of list -- ick.
};
end;
pp.txt (sprintf "], %d)" j);
pp.txt ")hut::type::RECURSIVE ";
};
};
hut::type::TUPLE (useless_recordflag, uniqtypes: List(hut::Uniqtype))
=>
{
pp.wrap {. pp.rulename "pphctw6";
pp.txt "hut::type::TUPLE( ";
apply pp_uniqtype uniqtypes
where
fun pp_uniqtype uniqtype
=
{ prettyprint_uniqtype symbolmapstack pp uniqtype;
pp.txt ", "; # This prints a ',' at end of list -- ick.
};
end;
pp.txt ")hut::type::TYPLE ";
};
};
hut::type::ARROW
(
calling_convention: hut::Calling_Convention,
uniqtypes1: List(hut::Uniqtype),
uniqtypes2: List(hut::Uniqtype)
)
=>
{
fun pp_uniqtype uniqtype
=
{ prettyprint_uniqtype symbolmapstack pp uniqtype;
pp.txt ", "; # This prints a ',' at end of list -- ick.
};
pp.wrap {. pp.rulename "pphctw7";
pp.txt "hut::type::ARROW( ";
prettyprint_calling_convention symbolmapstack pp calling_convention;
pp.txt ", [ ";
apply pp_uniqtype uniqtypes1;
pp.txt "], [ ";
apply pp_uniqtype uniqtypes2;
pp.txt "] )hut::type::ARROW ";
};
};
hut::type::PARROW
(
uniqtype1: hut::Uniqtype,
uniqtype2: hut::Uniqtype
)
=>
{
pp.wrap {. pp.rulename "pphctw8";
pp.txt "hut::type::PARROW( ";
prettyprint_uniqtype symbolmapstack pp uniqtype1;
pp.txt ", ";
prettyprint_uniqtype symbolmapstack pp uniqtype2;
pp.txt "] )hut::type::PARROW ";
};
};
hut::type::BOXED
(
uniqtype: hut::Uniqtype
)
=>
{
pp.wrap {. pp.rulename "pphctw9";
pp.txt "hut::type::BOXED( ";
prettyprint_uniqtype symbolmapstack pp uniqtype;
pp.txt " )hut::type::BOXED ";
};
};
hut::type::ABSTRACT
(
uniqtype: hut::Uniqtype
)
=>
{
pp.wrap {. pp.rulename "pphctw10";
pp.txt "hut::type::ABSTRACT( ";
prettyprint_uniqtype symbolmapstack pp uniqtype;
pp.txt " )hut::type::ABSTRACT ";
};
};
hut::type::EXTENSIBLE_TOKEN
(
token: hut::Token,
uniqtype: hut::Uniqtype
)
=>
{
pp.wrap {. pp.rulename "pphctw11";
pp.txt "hut::type::EXTENSIBLE_TOKEN( ";
pp.txt (sprintf "%s(%x), " (hut::token_name token) (hut::token_int token));
prettyprint_uniqtype symbolmapstack pp uniqtype;
pp.txt " )hut::type::EXTENSIBLE_TOKEN ";
};
};
hut::type::FATE (uniqtypes: List(hut::Uniqtype))
=>
{
pp.txt "hut::type::FATE[ ";
apply pp_uniqtype uniqtypes
where
fun pp_uniqtype uniqtype
=
{ prettyprint_uniqtype symbolmapstack pp uniqtype;
pp.txt ", "; # This prints a ',' at end of list -- ick.
};
end;
pp.txt "]hut::type::FATE ";
};
hut::type::INDIRECT_TYPE_THUNK (uniqtype: hut::Uniqtype, type: hut::Type)
=>
{
pp.txt "hut::type::INDIRECT_TYPE_THUNK( ";
prettyprint_uniqtype symbolmapstack pp uniqtype;
pp.txt ", ";
prettyprint_type symbolmapstack pp type;
pp.txt "]hut::type::INDIRECT_TYPE_THUNK ";
};
hut::type::TYPE_CLOSURE (uniqtype: hut::Uniqtype, i: Int, j: Int, uniqtype_dictionary: hut::Uniqtype_Dictionary)
=>
{ pp.txt "hut::type::TYPE_CLOSURE( ";
#
prettyprint_uniqtype symbolmapstack pp uniqtype;
pp.txt (sprintf ", %d, %d, uniqtype_dictionary=> " i j);
prettyprint_uniqtype symbolmapstack pp (hut::uniqtype_dictionary__to__uniqtype uniqtype_dictionary);
pp.txt "]hut::type::TYPE_CLOSURE ";
};
esac
also
fun prettyprint_typoid
(symbolmapstack: syx::Symbolmapstack)
pp
(type: hut::Typoid)
:
Void
=
raise exception DIE "prettyprint_typoid unimplemented -- prettyprint-highcode-uniq-types.pkg"
also
fun prettyprint_uniqkind symbolmapstack pp uniqkind
=
prettyprint_kind symbolmapstack pp (hut::uniqkind_to_kind uniqkind)
also
fun prettyprint_uniqtype symbolmapstack pp uniqtype
=
prettyprint_type symbolmapstack pp (hut::uniqtype_to_type uniqtype)
also
fun prettyprint_uniqtypoid
(symbolmapstack: syx::Symbolmapstack)
pp
(uniqtypoid: hut::Uniqtypoid)
:
Void
=
prettyprint_typoid symbolmapstack pp (hut::uniqtypoid_to_typoid uniqtypoid);
}; # package prettyprint_type
end; # toplevel "stipulate"