## more-type-types.pkg
#
# Types for core predefined stuff: void, bools, chars, ints, strings, lists, tuples, records,
# plus somewhat more exotic stuff like exceptions, fates, suspensions and spinlocks.
#
# Used pervasively, but especially in package base_types, constructed by
#
# src/lib/compiler/front/semantic/symbolmapstack/base-types-and-ops.pkg# Compiled by:
# src/lib/compiler/front/typer/typer.sublibstipulate
#
package ctt = core_type_types; # core_type_types is from src/lib/compiler/front/typer-stuff/types/core-type-types.pkg package err = error_message; # error_message is from src/lib/compiler/front/basics/errormsg/error-message.pkg package ip = inverse_path; # inverse_path is from src/lib/compiler/front/typer-stuff/basics/symbol-path.pkg package btn = basetype_numbers; # basetype_numbers is from src/lib/compiler/front/typer/basics/basetype-numbers.pkg package sta = stamp; # stamp is from src/lib/compiler/front/typer-stuff/basics/stamp.pkg package sy = symbol; # symbol is from src/lib/compiler/front/basics/map/symbol.pkg package tdt = type_declaration_types; # type_declaration_types is from src/lib/compiler/front/typer-stuff/types/type-declaration-types.pkg package vh = varhome; # varhome is from src/lib/compiler/front/typer-stuff/basics/varhome.pkg fun bug msg
=
error_message::impossible("more_type_types: " + msg);
herein
package more_type_types
: (weak) More_Type_Types # More_Type_Types is from src/lib/compiler/front/typer/types/more-type-types.api {
# Type and valconstructor symbols:
#
bool_symbol = sy::make_type_symbol "Bool";
list_symbol = sy::make_type_symbol "List";
susp_symbol = sy::make_type_symbol "Susp"; # LAZY Support for 'lazy' functions and datastructures.
#
true_symbol = sy::make_value_symbol "TRUE";
false_symbol = sy::make_value_symbol "FALSE";
nil_symbol = sy::make_value_symbol "NIL";
antiquote_symbol = sy::make_value_symbol "ANTIQUOTE"; # An SML/NJ language extension which we don't currently support.
quote_symbol = sy::make_value_symbol "QUOTE"; # " "
frag_symbol = sy::make_type_symbol "Frag"; # " "
cons_symbol = sy::make_value_symbol "!"; # This is the only valcon which is not uppercase alphabetic.
#
dollar_symbol = sy::make_value_symbol "@@@"; # LAZY
#
void_symbol = /* sy::make_type_symbol "Void" */ ctt::void_symbol;
ref_con_symbol = /* sy::make_value_symbol "REF" */ ctt::ref_con_symbol;
#
ref_type_symbol = /* sy::make_type_symbol "Ref" */ ctt::ref_type_symbol;
# Base type constructors and types:
# Function type constructor:
#
infix my --> ;
#
arrow_stamp = /* sta::make_static_stamp "->" */ ctt::arrow_stamp;
arrow_type = ctt::arrow_type;
my (-->) = ctt::(-->);
# arrowTyp
# =
# tdt::SUM_TYPE { stamp = arrowStamp, path = ip::INVERSE_PATH [sy::make_type_symbol "->"],
# arity = 2, eq = REF tdt::NO,
# kind = tdt::BASE btn::basetype_number_arrow,
# stub = NULL }
# fun t1 --> t2 = tdt::TYPCON_TYPOID (arrowTyp,[t1, t2])
fun is_arrow_type (tdt::TYPCON_TYPOID (tdt::SUM_TYPE { stamp, ... }, _))
=>
sta::same_stamp (stamp, arrow_stamp);
is_arrow_type (tdt::TYPEVAR_REF { id, ref_typevar => REF (tdt::RESOLVED_TYPEVAR type) } )
=>
is_arrow_type type;
is_arrow_type _
=>
FALSE;
end;
fun domain (tdt::TYPCON_TYPOID(_,[type, _]))
=>
type;
domain _
=>
bug "domain";
end;
fun range (tdt::TYPCON_TYPOID(_,[_, type]))
=>
type;
range _
=>
bug "range";
end;
# ** Base types **
fun make_base_type (symbol, arity, equality_property, ptn)
=
tdt::SUM_TYPE {
#
stamp => sta::make_static_stamp symbol,
namepath => ip::INVERSE_PATH [sy::make_type_symbol symbol],
arity,
#
is_eqtype => REF equality_property,
kind => tdt::BASE ptn,
stub => NULL
};
# The Type/Typoid distinction below is purely technical.
# Essentially, 'Type' covers what one usually thinks of as types,
# while 'Typoid' contains 'Type' plus stuff like wildcard types,
# type variables and type schemes. Depending on code context,
# sometimes we need one and sometimes the other, so we provide both.
# For details see:
#
# src/lib/compiler/front/typer-stuff/types/type-declaration-types.pkg unt1_type = make_base_type ("one_word_unt", 0, tdt::e::YES, btn::basetype_number_int1);
unt1_typoid = tdt::TYPCON_TYPOID (unt1_type, NIL);
w32pair_type = tdt::NAMED_TYPE
{
stamp => sta::make_static_stamp "w32pair",
#
typescheme => tdt::TYPESCHEME { arity => 0,
body => ctt::tuple_typoid [unt1_typoid, unt1_typoid]
},
#
namepath => ip::INVERSE_PATH [sy::make_type_symbol "W32pair"],
strict => []
};
fun make64 symbol
=
tdt::SUM_TYPE
{
stamp => sta::make_static_stamp symbol,
namepath => ip::INVERSE_PATH [sy::make_type_symbol symbol],
arity => 0,
#
is_eqtype => REF tdt::e::YES,
kind => tdt::ABSTRACT w32pair_type,
stub => NULL
};
int_type = /* make_base_type ("Int", 0, tdt::e::YES, btn::basetype_number_tagged_int) */ ctt::int_type;
int_typoid = /* tdt::TYPCON_TYPOID (int_type, NIL) */ ctt::int_typoid;
int1_type = make_base_type ("Int1", 0, tdt::e::YES, btn::basetype_number_int1);
int1_typoid = tdt::TYPCON_TYPOID (int1_type, NIL);
int2_type = make64 "Int2";
int2_typoid = tdt::TYPCON_TYPOID (int2_type, []);
multiword_int_type = make_base_type ("multiword_int", 0, tdt::e::YES, btn::basetype_number_integer);
multiword_int_typoid = tdt::TYPCON_TYPOID (multiword_int_type, NIL);
float64_type = /* make_base_type("Float64", 0, tdt::e::NO, btn::basetype_number_float64) */ ctt::float64_type;
float64_typoid = /* tdt::TYPCON_TYPOID (float64_type, NIL) */ ctt::float64_typoid;
unt_type = make_base_type("word", 0, tdt::e::YES, btn::basetype_number_tagged_int);
unt_typoid = tdt::TYPCON_TYPOID (unt_type, NIL);
unt8_type = make_base_type("word8", 0, tdt::e::YES, btn::basetype_number_tagged_int);
unt8_typoid = tdt::TYPCON_TYPOID (unt8_type, NIL);
unt2_type = make64 "word64";
unt2_typoid = tdt::TYPCON_TYPOID (unt2_type, []);
string_type = /* make_base_type("String", 0, tdt::e::YES, btn::basetype_number_string) */ ctt::string_type;
string_typoid = /* tdt::TYPCON_TYPOID (string_type, NIL) */ ctt::string_typoid;
char_type = /* make_base_type("char", 0, tdt::e::YES, btn::basetype_number_tagged_int) */ ctt::char_type;
char_typoid = /* tdt::TYPCON_TYPOID (char_type, NIL) */ ctt::char_typoid;
exception_type = /* make_pimitive_type("Exception", 0, tdt::NO, btn::basetype_number_exception) */ ctt::exception_type;
exception_typoid = /* tdt::TYPCON_TYPOID (exnTyp, NIL) */ ctt::exception_typoid;
fate_type = make_base_type("Fate", 1, tdt::e::NO, btn::basetype_number_fate);
control_fate_type = make_base_type("Control_Fate", 1, tdt::e::NO, btn::basetype_number_control_fate);
rw_vector_type = /* make_base_type("Rw_Vector", 1, tdt::e::CHUNK, btn::basetype_number_rw_vector) */ ctt::rw_vector_type;
ro_vector_type = /* make_base_type( "Vector", 1, tdt::e::YES, btn::basetype_number_ro_vector) */ ctt::ro_vector_type;
chunk_type = make_base_type( "Chunk", 0, tdt::e::NO, btn::basetype_number_chunk);
c_function_type = make_base_type( "c_function", 0, tdt::e::NO, btn::basetype_number_cfun);
un8_rw_vector_type = make_base_type( "word8array", 0, tdt::e::CHUNK, btn::basetype_number_barray);
float64_rw_vector_type = make_base_type( "Float64_Rw_Vector", 0, tdt::e::CHUNK, btn::basetype_number_rarray);
spinlock_type = make_base_type( "Spin_Lock", 0, tdt::e::NO, btn::basetype_number_slock);
# ** building record and product types **
record_typoid = ctt::record_typoid;
tuple_typoid = ctt::tuple_typoid;
void_type = ctt::void_type;
void_typoid = ctt::void_typoid;
#
# Technically this is a 'unit' (not 'void')
# type since it has one (not zero) values.
# Since we use it the way C etc use 'void',
# we go with the more familiar nomenclature.
# Predefined sumtypes:
#
alpha = tdt::TYPESCHEME_ARG 0;
# Base sumtypes
# Bool
bool_stamp = /* sta::make_static_stamp "bool" */ ctt::bool_stamp;
bool_signature = /* CSIG (0, 2) */ ctt::bool_signature;
bool_type = ctt::bool_type;
bool_typoid = ctt::bool_typoid;
false_valcon = ctt::false_valcon; # "valcon" == "value constructor"
true_valcon = ctt::true_valcon;
ref_type = ctt::ref_type;
ref_pattern_typoid= ctt::ref_pattern_typoid;
ref_valcon = ctt::ref_valcon;
fun get_fields (tdt::TYPCON_TYPOID (tdt::RECORD_TYPE _, fl))
=>
THE fl;
get_fields (tdt::TYPEVAR_REF { id, ref_typevar => REF (tdt::RESOLVED_TYPEVAR type) } )
=>
get_fields type;
get_fields _
=>
NULL;
end;
# Lists:
list_stamp = sta::make_static_stamp "list";
cons_dom = tuple_typoid [alpha, tdt::TYPCON_TYPOID (tdt::RECURSIVE_TYPE 0,[alpha])];
list_signature = vh::CONSTRUCTOR_SIGNATURE (1, 1); /* [UNTAGGED, CONSTANT 0], [LISTCONS, LISTNIL] */
list_eq = REF tdt::e::YES; # List is an "equality type".
list_kind = tdt::SUMTYPE
{
index => 0,
stamps => #[ list_stamp ],
free_types => [],
root => NULL,
#
family => { property_list => property_list::make_property_list (),
mkey => list_stamp,
#
members => #[ { name_symbol => list_symbol,
is_eqtype => list_eq,
is_lazy => FALSE,
arity => 1,
an_api => list_signature,
#
valcons => [ # Two constructors -- ! and NIL.
{ name => cons_symbol,
form => vh::UNTAGGED,
domain => THE cons_dom
},
{ name => nil_symbol,
form => vh::CONSTANT 0,
domain => NULL
}
]
}
]
}
};
list_type = tdt::SUM_TYPE
{ stamp => list_stamp,
namepath => ip::INVERSE_PATH [list_symbol],
arity => 1,
#
is_eqtype => list_eq, # Records whether this is an "equality type" -- should maybe be renamed "is_eqtype".
kind => list_kind,
stub => NULL
};
cons_valcon # The '!' list constructor.
=
tdt::VALCON
{
name => cons_symbol,
is_constant => FALSE,
is_lazy => FALSE,
#
form => vh::UNTAGGED, # was LISTCONS
signature => list_signature,
#
typoid
=>
tdt::TYPESCHEME_TYPOID
{
typescheme_eqflags => [FALSE],
#
typescheme => tdt::TYPESCHEME
{ arity => 1,
body => tdt::TYPCON_TYPOID
( arrow_type,
[tuple_typoid [alpha, tdt::TYPCON_TYPOID (list_type,[alpha])],
tdt::TYPCON_TYPOID (list_type,[alpha])]
)
}
}
};
nil_valcon
=
tdt::VALCON
{
name => nil_symbol,
is_constant => TRUE,
is_lazy => FALSE,
form => vh::CONSTANT 0, # was LISTNIL
signature => list_signature,
typoid
=>
tdt::TYPESCHEME_TYPOID { typescheme_eqflags => [FALSE],
typescheme => tdt::TYPESCHEME { arity=>1, body=>tdt::TYPCON_TYPOID (list_type,[alpha]) }
}
};
# unrolled lists
stipulate
# should this type have a different stamp from list?
#
ulist_stamp = sta::make_static_stamp "ulist";
ulistsign = vh::CONSTRUCTOR_SIGNATURE (1, 1); # [LISTCONS, LISTNIL]
ulist_eq = REF tdt::e::YES; # Probably records that unrolled-list is an "equality type".
ulist_kind = tdt::SUMTYPE {
index => 0,
stamps => #[ulist_stamp],
free_types => [],
root => NULL,
family => { property_list => property_list::make_property_list (),
mkey => ulist_stamp,
members => #[ { name_symbol => list_symbol,
is_eqtype => ulist_eq,
is_lazy => FALSE,
arity => 1,
an_api => ulistsign,
valcons => [ { name => cons_symbol,
form => vh::LISTCONS,
domain => THE cons_dom
},
{ name => nil_symbol,
form => vh::LISTNIL,
domain => NULL
}
]
}
]
}
};
herein
unrolled_list_type
=
tdt::SUM_TYPE
{
stamp => ulist_stamp,
namepath => ip::INVERSE_PATH [ list_symbol ],
arity => 1,
#
is_eqtype => ulist_eq,
kind => ulist_kind,
stub => NULL
};
unrolled_list_cons_valcon
=
tdt::VALCON
{
name => cons_symbol,
is_constant => FALSE,
is_lazy => FALSE,
form => vh::LISTCONS,
signature => ulistsign,
typoid
=>
tdt::TYPESCHEME_TYPOID {
typescheme_eqflags => [FALSE],
typescheme => tdt::TYPESCHEME {
arity => 1,
body => tdt::TYPCON_TYPOID (
arrow_type,
[ tuple_typoid [ alpha, tdt::TYPCON_TYPOID (unrolled_list_type, [alpha] ) ],
tdt::TYPCON_TYPOID (unrolled_list_type, [alpha])
]
)
}
}
};
unrolled_list_nil_valcon
=
tdt::VALCON
{
name => nil_symbol,
is_constant => TRUE,
is_lazy => FALSE,
form => vh::LISTNIL,
signature => ulistsign,
#
typoid
=>
tdt::TYPESCHEME_TYPOID {
typescheme_eqflags => [FALSE],
typescheme => tdt::TYPESCHEME {
arity => 1,
body => tdt::TYPCON_TYPOID (unrolled_list_type, [ alpha ] )
}
}
};
end; # stipulate
# Support for a nonstandard and undocumented antiquote mechanism:
#
stipulate
antiquote_dom = alpha;
quote_dom = string_typoid;
frag_stamp = sta::make_static_stamp "frag";
fragsign = vh::CONSTRUCTOR_SIGNATURE (2, 0); # [TAGGED 0, TAGGED 1]
frageq = REF tdt::e::YES;
frag_kind
=
tdt::SUMTYPE {
index => 0,
stamps => #[ frag_stamp ],
free_types => [],
root => NULL,
family => { property_list => property_list::make_property_list (),
mkey => frag_stamp,
members => #[ { name_symbol => frag_symbol,
is_eqtype => frageq,
is_lazy => FALSE,
#
arity => 1,
an_api => fragsign,
valcons => [ { name => antiquote_symbol,
form => vh::TAGGED 0,
domain => THE antiquote_dom
},
{ name => quote_symbol,
form => vh::TAGGED 1,
domain => THE quote_dom
}
]
}
]
}
};
herein
antiquote_fragment_type
=
tdt::SUM_TYPE
{
stamp => frag_stamp,
namepath => ip::INVERSE_PATH [frag_symbol, sy::make_package_symbol "Lib7"],
arity => 1,
#
is_eqtype => frageq,
kind => frag_kind,
stub => NULL
};
antiquote_valcon
=
tdt::VALCON
{
name => antiquote_symbol,
is_constant => FALSE,
is_lazy => FALSE,
signature => fragsign,
form => vh::TAGGED 0,
typoid
=>
tdt::TYPESCHEME_TYPOID { typescheme_eqflags => [FALSE],
typescheme => tdt::TYPESCHEME { arity => 1,
body => tdt::TYPCON_TYPOID ( arrow_type,
[ alpha,
tdt::TYPCON_TYPOID (
antiquote_fragment_type,
[alpha]
)
]
)
}
}
};
quote_valcon
=
tdt::VALCON
{
name => quote_symbol,
is_constant => FALSE,
is_lazy => FALSE,
signature => fragsign,
form => vh::TAGGED 1,
typoid
=>
tdt::TYPESCHEME_TYPOID { typescheme_eqflags => [FALSE],
typescheme => tdt::TYPESCHEME { arity => 1,
body => tdt::TYPCON_TYPOID ( arrow_type,
[ string_typoid,
tdt::TYPCON_TYPOID (
antiquote_fragment_type,
[alpha]
)
]
)
}
}
};
end; # stipulate
# LAZY: suspensions for supporting lazy evaluation -- another nonstandard and undocumented extension.
#
stipulate
dollar_dom = alpha;
suspension_stamp = sta::make_static_stamp "suspension";
#
susp_signature = vh::CONSTRUCTOR_SIGNATURE (1, 0);
susp_eq = REF tdt::e::NO;
susp_kind = tdt::SUMTYPE
{
index => 0,
stamps => #[suspension_stamp],
free_types => [],
root => NULL,
family => { property_list => property_list::make_property_list (),
mkey => suspension_stamp,
members => #[ { name_symbol => dollar_symbol,
is_eqtype => susp_eq,
is_lazy => FALSE,
arity => 1,
an_api => susp_signature,
valcons => [ { name => dollar_symbol,
form => vh::SUSPENSION NULL,
domain => THE dollar_dom
}
]
}
]
}
};
herein
suspension_type
=
tdt::SUM_TYPE
{
stamp => suspension_stamp,
namepath => ip::INVERSE_PATH [susp_symbol],
arity => 1,
is_eqtype => susp_eq,
kind => susp_kind,
stub => NULL
};
suspension_typescheme
=
tdt::TYPESCHEME { arity => 1, body => dollar_dom --> tdt::TYPCON_TYPOID (suspension_type, [alpha]) };
dollar_valcon
=
tdt::VALCON
{
name => dollar_symbol,
is_constant => FALSE,
is_lazy => FALSE,
#
signature => susp_signature,
form => vh::SUSPENSION NULL,
typoid
=>
tdt::TYPESCHEME_TYPOID { typescheme_eqflags => [FALSE],
typescheme => suspension_typescheme
}
};
suspension_pattern_typoid
=
tdt::TYPESCHEME_TYPOID {
typescheme_eqflags => [FALSE],
typescheme => suspension_typescheme
};
end; # stipulate
}; # package more_type_types
end; # stipulate