## unpickler-junk.pkg
#
# See comments in src/lib/compiler/front/semantic/pickle/unpickler-junk.api# Compiled by:
# src/lib/compiler/core.sublibstipulate
package acf = anormcode_form; # anormcode_form is from src/lib/compiler/back/top/anormcode/anormcode-form.pkg package cos = compile_statistics; # compile_statistics is from src/lib/compiler/front/basics/stats/compile-statistics.pkg package cty = ctypes; # ctypes is from src/lib/compiler/back/low/ccalls/ctypes.pkg package di = debruijn_index; # debruijn_index is from src/lib/compiler/front/typer/basics/debruijn-index.pkg package ed = stamppath::module_stamp_map; # stamppath is from src/lib/compiler/front/typer-stuff/modules/stamppath.pkg package hbo = highcode_baseops; # highcode_baseops is from src/lib/compiler/back/top/highcode/highcode-baseops.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 hct = highcode_type; # highcode_type is from src/lib/compiler/back/top/highcode/highcode-type.pkg package im = inlining_mapstack; # inlining_mapstack is from src/lib/compiler/toplevel/compiler-state/inlining-mapstack.pkg package ip = inverse_path; # inverse_path is from src/lib/compiler/front/typer-stuff/basics/symbol-path.pkg package ij = inlining_junk; # inlining_junk is from src/lib/compiler/front/semantic/basics/inlining-junk.pkg package mld = module_level_declarations; # module_level_declarations is from src/lib/compiler/front/typer-stuff/modules/module-level-declarations.pkg package ph = picklehash; # picklehash is from src/lib/compiler/front/basics/map/picklehash.pkg package sp = symbol_path; # symbol_path is from src/lib/compiler/front/typer-stuff/basics/symbol-path.pkg package sta = stamp; # stamp is form src/lib/compiler/front/typer-stuff/basics/stamp.pkg package stx = stampmapstack; # stampmapstack is from src/lib/compiler/front/typer-stuff/modules/stampmapstack.pkg package syx = symbolmapstack; # symbolmapstack is from src/lib/compiler/front/typer-stuff/symbolmapstack/symbolmapstack.pkg package sxe = symbolmapstack_entry; # symbolmapstack_entry is from src/lib/compiler/front/typer-stuff/symbolmapstack/symbolmapstack-entry.pkg package sy = symbol; # symbol is from src/lib/compiler/front/basics/map/symbol.pkg package ty = types; # types is from src/lib/compiler/front/typer-stuff/types/types.pkg package upr = unpickler; # unpickler is from src/lib/compiler/src/library/unpickler.pkg package vac = variables_and_constructors; # variables_and_constructors is from src/lib/compiler/front/typer-stuff/deep-syntax/variables-and-constructors.pkg package vh = varhome; # varhome is from src/lib/compiler/front/typer-stuff/basics/varhome.pkgherein
package unpickler_junk
: (weak) Unpickler_Junk # Unpickler_Junk is from src/lib/compiler/front/semantic/pickle/unpickler-junk.api {
Unpickling_Context
=
Null_Or( (Int, sy::Symbol) ) -> stx::Stampmapstack;
exception FORMAT = upr::FORMAT;
# The order of the entries in the following
# tables must be coordinated with
#
# src/lib/compiler/front/semantic/pickle/pickler-junk.pkg #
baseop_table
=
#[ hbo::MAKE_EXCEPTION_TAG,
#
hbo::WRAP,
hbo::UNWRAP,
#
hbo::GET_RW_VECSLOT_CONTENTS,
hbo::GET_RO_VECSLOT_CONTENTS,
hbo::GET_RW_VECSLOT_CONTENTS_AFTER_BOUNDS_CHECK,
hbo::GET_RO_VECSLOT_CONTENTS_AFTER_BOUNDS_CHECK,
hbo::MAKE_RW_VECTOR_MACRO,
hbo::POINTER_EQL,
hbo::POINTER_NEQ,
hbo::POLY_EQL,
hbo::POLY_NEQ,
hbo::IS_BOXED,
hbo::IS_UNBOXED,
hbo::VECTOR_LENGTH_IN_SLOTS,
hbo::HEAPCHUNK_LENGTH_IN_WORDS,
hbo::CAST,
hbo::GET_RUNTIME_ASM_PACKAGE_RECORD,
hbo::MARK_EXCEPTION_WITH_STRING,
hbo::GET_EXCEPTION_HANDLER_REGISTER,
hbo::SET_EXCEPTION_HANDLER_REGISTER,
hbo::GET_CURRENT_THREAD_REGISTER,
hbo::SET_CURRENT_THREAD_REGISTER,
hbo::PSEUDOREG_GET,
hbo::PSEUDOREG_SET,
hbo::SETMARK,
hbo::DISPOSE,
hbo::MAKE_REFCELL,
hbo::CALLCC,
hbo::CALL_WITH_CURRENT_CONTROL_FATE,
hbo::THROW,
hbo::GET_REFCELL_CONTENTS,
hbo::SET_REFCELL,
hbo::SET_VECSLOT,
hbo::SET_VECSLOT_AFTER_BOUNDS_CHECK,
hbo::SET_VECSLOT_TO_BOXED_VALUE,
hbo::SET_VECSLOT_TO_TAGGED_INT_VALUE,
hbo::GET_BATAG_FROM_TAGWORD,
hbo::MAKE_WEAK_POINTER_OR_SUSPENSION,
hbo::SET_STATE_OF_WEAK_POINTER_OR_SUSPENSION,
hbo::GET_STATE_OF_WEAK_POINTER_OR_SUSPENSION,
hbo::USELVAR,
hbo::DEFLVAR,
hbo::NOT_MACRO,
hbo::COMPOSE_MACRO,
hbo::BEFORE_MACRO,
hbo::ALLOCATE_RW_VECTOR_MACRO,
hbo::ALLOCATE_RO_VECTOR_MACRO,
hbo::MAKE_ISOLATED_FATE,
hbo::WCAST,
hbo::MAKE_ZERO_LENGTH_VECTOR,
hbo::GET_VECTOR_DATACHUNK,
hbo::GET_RECSLOT_CONTENTS,
hbo::GET_RAW64SLOT_CONTENTS,
hbo::SET_REFCELL_TO_TAGGED_INT_VALUE,
hbo::RAW_CCALL NULL,
hbo::IGNORE_MACRO,
hbo::IDENTITY_MACRO,
hbo::CVT64
];
compare_op_table
=
#[hbo::GT, hbo::GE, hbo::LT, hbo::LE, hbo::LEU, hbo::LTU, hbo::GEU, hbo::GTU, hbo::EQL, hbo::NEQ];
math_op_table
=
#[hbo::ADD, hbo::SUBTRACT, hbo::MULTIPLY, hbo::DIVIDE, hbo::NEGATE, hbo::ABS, hbo::LSHIFT, hbo::RSHIFT, hbo::RSHIFTL,
hbo::BITWISE_AND, hbo::BITWISE_OR, hbo::BITWISE_XOR, hbo::BITWISE_NOT, hbo::FSQRT, hbo::FSIN, hbo::FCOS, hbo::FTAN,
hbo::REM, hbo::DIV, hbo::MOD];
equality_property_table
=
#[ ty::eq_type::YES,
ty::eq_type::NO,
ty::eq_type::INDETERMINATE,
ty::eq_type::CHUNK,
ty::eq_type::DATA,
ty::eq_type::EQ_ABSTRACT,
ty::eq_type::UNDEF
];
c_type_table
=
#[cty::VOID,
cty::FLOAT,
cty::DOUBLE,
cty::LONG_DOUBLE,
cty::UNSIGNED cty::CHAR,
cty::UNSIGNED cty::SHORT,
cty::UNSIGNED cty::INT,
cty::UNSIGNED cty::LONG,
cty::UNSIGNED cty::LONG_LONG,
cty::SIGNED cty::CHAR,
cty::SIGNED cty::SHORT,
cty::SIGNED cty::INT,
cty::SIGNED cty::LONG,
cty::SIGNED cty::LONG_LONG,
cty::PTR];
#
fun &&& c (x, t)
=
(c x, t);
#
fun modtree_branch l
=
loop (l, [])
where
fun loop ([], [x]) => x;
loop ([], result) => mld::MODTREE_BRANCH result;
#
loop (mld::MODTREE_BRANCH [] ! rest, result) => loop (rest, result);
loop (mld::MODTREE_BRANCH [x] ! rest, result) => loop (rest, x ! result); # Cannot happen.
loop ( x ! rest, result) => loop (rest, x ! result);
end;
end;
no_modtree = mld::MODTREE_BRANCH [];
#
fun make_shared_stuff (unpickler, highcode_variable)
=
{ read_picklehash,
read_string,
read_symbol,
read_varhome,
read_valcon_form,
read_constructor_signature,
read_baseop,
read_list_of_bools,
read_null_or_int,
read_type_kind,
read_list_of_typekinds
}
where
fun read_sharable_value sharemap read_value
=
upr::read_sharable_value unpickler sharemap read_value;
#
fun read_unsharable_value f
=
upr::read_unsharable_value unpickler f;
read_int = upr::read_int unpickler;
read_bool = upr::read_bool unpickler;
#
fun read_list m r = upr::read_list unpickler m r;
fun read_null_or m r = upr::read_null_or unpickler m r;
read_string = upr::read_string unpickler;
read_symbol = symbol_and_picklehash_unpickling::read_symbol (unpickler, read_string);
# These maps will all acquire different
# types by being used in different contexts...
varhome_sharemap = upr::make_sharemap ();
valcon_sharemap = upr::make_sharemap ();
constructor_signature_sharemap = upr::make_sharemap ();
number_kind_and_bitsize_sharemap = upr::make_sharemap ();
baseop_sharemap = upr::make_sharemap ();
list_of_bools_sharemap = upr::make_sharemap ();
null_or_bool_sharemap = upr::make_sharemap ();
type_kind_sharemap = upr::make_sharemap ();
list_of_typekinds_sharemap = upr::make_sharemap ();
ctype_sharemap = upr::make_sharemap ();
c_type_list_sharemap = upr::make_sharemap ();
ccall_type_list_sharemap = upr::make_sharemap ();
null_or_c_call_type_sharemap = upr::make_sharemap ();
ccall_info_sharemap = upr::make_sharemap ();
io_m = upr::make_sharemap ();
read_list_of_bools = read_list list_of_bools_sharemap read_bool;
# read_null_or_bool = read_null_or null_or_bool_sharemap read_bool;
read_null_or_int = read_null_or io_m read_int;
read_picklehash = symbol_and_picklehash_unpickling::read_picklehash (unpickler, read_string);
#
fun read_varhome ()
=
read_sharable_value varhome_sharemap read_varhome'
where
fun read_varhome' 'A' => highcode_variable (read_int ());
read_varhome' 'B' => vh::EXTERN (read_picklehash ());
read_varhome' 'C' => vh::PATH (read_varhome (), read_int ());
read_varhome' 'D' => vh::NO_VARHOME;
read_varhome' _ => raise exception FORMAT;
end;
end;
#
fun read_valcon_form ()
=
read_sharable_value valcon_sharemap cr
where
fun cr 'A' => vh::UNTAGGED;
cr 'B' => vh::TAGGED (read_int ());
cr 'C' => vh::TRANSPARENT;
cr 'D' => vh::CONSTANT (read_int ());
cr 'E' => vh::REFCELL_REP;
cr 'F' => vh::EXCEPTION (read_varhome ());
cr 'G' => vh::LISTCONS;
cr 'H' => vh::LISTNIL;
cr 'I' => vh::SUSPENSION NULL;
cr 'J' => vh::SUSPENSION (THE (read_varhome (), read_varhome ()));
#
cr _ => raise exception FORMAT;
end;
end;
#
fun read_constructor_signature ()
=
read_sharable_value constructor_signature_sharemap cs
where
fun cs 'S' => vh::CONSTRUCTOR_SIGNATURE (read_int (), read_int ());
cs 'N' => vh::NULLARY_CONSTRUCTOR;
cs _ => raise exception FORMAT;
end;
end;
#
fun read_type_kind ()
=
read_sharable_value type_kind_sharemap tk
where
fun tk 'A' => hct::plaintype_uniqkind;
tk 'B' => hct::boxedtype_uniqkind;
tk 'C' => hct::make_kindseq_uniqkind (read_list_of_typekinds ());
tk 'D' => hct::make_kindfun_uniqkind (read_list_of_typekinds (), read_type_kind ());
tk _ => raise exception FORMAT;
end;
end
also
fun read_list_of_typekinds ()
=
read_list list_of_typekinds_sharemap read_type_kind ();
#
fun read_number_kind_and_bitsize ()
=
read_sharable_value number_kind_and_bitsize_sharemap nk
where
fun nk 'A' => hbo::INT (read_int ());
nk 'B' => hbo::UNT (read_int ());
nk 'C' => hbo::FLOAT (read_int ());
nk _ => raise exception FORMAT;
end;
end;
#
fun read_math_op ()
=
read_unsharable_value ao
where
fun ao c
=
vector::get (math_op_table, char::to_int c)
except
(exceptions::SUBSCRIPT|exceptions::INDEX_OUT_OF_BOUNDS) = raise exception FORMAT;
end;
#
fun read_compare_op ()
=
{ fun co c
=
vector::get (compare_op_table, char::to_int c)
except
(exceptions::SUBSCRIPT|exceptions::INDEX_OUT_OF_BOUNDS) = raise exception FORMAT;
read_unsharable_value co;
};
#
fun read_c_type ()
=
read_sharable_value ctype_sharemap ct
where
fun ct '\020' => cty::ARRAY (read_c_type (), read_int ());
ct '\021' => cty::STRUCT (read_c_type_list ());
ct '\022' => cty::UNION (read_c_type_list ());
ct c => vector::get (c_type_table, char::to_int c)
except
(exceptions::SUBSCRIPT|exceptions::INDEX_OUT_OF_BOUNDS) = raise exception FORMAT;
end;
end
also
fun read_c_type_list ()
=
read_list c_type_list_sharemap read_c_type ();
#
fun read_c_call_type ()
=
read_unsharable_value ct
where
fun ct '\000' => hbo::CCI32;
ct '\001' => hbo::CCI64;
ct '\002' => hbo::CCR64;
ct '\003' => hbo::CCML;
#
ct _ => raise exception FORMAT;
end;
end
also
fun read_c_call_type_list ()
=
read_list ccall_type_list_sharemap read_c_call_type ()
also
fun read_null_or_c_call_type ()
=
read_null_or null_or_c_call_type_sharemap read_c_call_type ();
#
fun read_c_call_info ()
=
read_sharable_value ccall_info_sharemap cp
where
fun cp 'C'
=>
{ c_prototype => { calling_convention => read_string (),
return_type => read_c_type (),
parameter_types => read_c_type_list ()
},
ml_argument_representations => read_c_call_type_list (),
ml_result_representation => read_null_or_c_call_type (),
is_reentrant => read_bool ()
};
cp _ => raise exception FORMAT;
end;
end;
#
fun read_baseop ()
=
read_sharable_value baseop_sharemap po
where
fun po '\100' => hbo::MATH { op => read_math_op (), overflow => read_bool (), kindbits => read_number_kind_and_bitsize () };
po '\101' => hbo::CMP { op => read_compare_op (), kindbits => read_number_kind_and_bitsize () };
po '\102' => hbo::SHRINK_INT (read_int (), read_int ());
po '\103' => hbo::SHRINK_UNT (read_int (), read_int ());
po '\104' => hbo::CHOP (read_int (), read_int ());
po '\105' => hbo::STRETCH (read_int (), read_int ());
po '\106' => hbo::COPY (read_int (), read_int ());
po '\107' => hbo::LSHIFT_MACRO (read_number_kind_and_bitsize ());
po '\108' => hbo::RSHIFT_MACRO (read_number_kind_and_bitsize ());
po '\109' => hbo::RSHIFTL_MACRO (read_number_kind_and_bitsize ());
po '\110' => hbo::ROUND { floor => read_bool (), from => read_number_kind_and_bitsize (), to => read_number_kind_and_bitsize () };
po '\111' => hbo::CONVERT_FLOAT { from => read_number_kind_and_bitsize (), to => read_number_kind_and_bitsize () };
po '\112' => hbo::GET_VECSLOT_NUMERIC_CONTENTS { kindbits => read_number_kind_and_bitsize (), checked => read_bool (), immutable => read_bool () };
po '\113' => hbo::SET_VECSLOT_TO_NUMERIC_VALUE { kindbits => read_number_kind_and_bitsize (), checked => read_bool () };
po '\114' => hbo::ALLOCATE_NUMERIC_RW_VECTOR_MACRO (read_number_kind_and_bitsize ());
po '\115' => hbo::ALLOCATE_NUMERIC_RO_VECTOR_MACRO (read_number_kind_and_bitsize ());
po '\116' => hbo::GET_FROM_NONHEAP_RAM (read_number_kind_and_bitsize ());
po '\117' => hbo::SET_NONHEAP_RAM (read_number_kind_and_bitsize ());
po '\118' => hbo::RAW_CCALL (THE (read_c_call_info ()));
po '\119' => hbo::RAW_ALLOCATE_C_RECORD { fblock => read_bool () };
po '\120' => hbo::MIN_MACRO (read_number_kind_and_bitsize ());
po '\121' => hbo::MAX_MACRO (read_number_kind_and_bitsize ());
po '\122' => hbo::ABS_MACRO (read_number_kind_and_bitsize ());
po '\123' => hbo::SHRINK_INTEGER (read_int ());
po '\124' => hbo::CHOP_INTEGER (read_int ());
po '\125' => hbo::STRETCH_TO_INTEGER (read_int ());
po '\126' => hbo::COPY_TO_INTEGER (read_int ());
po c => vector::get (baseop_table, char::to_int c)
except
(exceptions::SUBSCRIPT|exceptions::INDEX_OUT_OF_BOUNDS) = raise exception FORMAT;
end;
end;
end; # fun make_shared_stuff
#
fun make_symbolmapstack_unpickler
#
extra_info
unpickler_info
unpickling_context
=
read_symbolmapstack
where
extra_info -> { get_global_picklehash, shared_stuff, is_lib };
unpickler_info -> { unpickler, read_list_of_strings };
stipulate
fun get find (m, i)
=
case (find (unpickling_context m, i))
#
THE x => x;
#
NULL =>
{ error_message::impossible "unpickler_junk: stub lookup failed";
raise exception FORMAT;
};
esac;
herein
find_plain_typ_record_by_typestamp = get stx::find_plain_typ_record_by_typestamp;
find_api_record_by_apistamp = get stx::find_api_record_by_apistamp;
find_typechecked_package_by_packagestamp = get stx::find_typechecked_package_by_packagestamp;
find_typechecked_generic_by_genericstamp = get stx::find_typechecked_generic_by_genericstamp;
find_typerstore_record_by_typerstorestamp = get stx::find_typerstore_record_by_typerstorestamp;
end;
#
fun read_list sharemap read_value = upr::read_list unpickler sharemap read_value;
fun read_null_or sharemap read_value = upr::read_null_or unpickler sharemap read_value;
read_bool = upr::read_bool unpickler;
read_int = upr::read_int unpickler;
#
fun read_pair sharemap read_a read_b
=
upr::read_pair unpickler sharemap read_a read_b;
#
fun read_sharable_value sharemap read_value = upr::read_sharable_value unpickler sharemap read_value;
fun read_unsharable_value read_value = upr::read_unsharable_value unpickler read_value;
# The following maps acquire different types
# by being used in different contexts:
#
stamp_sharemap = upr::make_sharemap ();
packagestamp_sharemap = upr::make_sharemap ();
genericstamp_sharemap = upr::make_sharemap ();
null_or_stamp_sharemap = upr::make_sharemap ();
list_stamp_sharemap = upr::make_sharemap ();
null_or_symbol_sharemap = upr::make_sharemap ();
list_of_symbols_sharemap = upr::make_sharemap ();
list_symbol_path_sharemap = upr::make_sharemap ();
list_list_symbol_path_sharemap = upr::make_sharemap ();
valcon_sharemap = upr::make_sharemap ();
typ_kind_sharemap = upr::make_sharemap ();
datatype_info_sharemap = upr::make_sharemap ();
datatype_family_sharemap = upr::make_sharemap ();
datatype_member_sharemap = upr::make_sharemap ();
list_datatype_member_sharemap = upr::make_sharemap ();
name_form_domain_sharemap = upr::make_sharemap ();
list_name_form_domain_sharemap = upr::make_sharemap ();
typ_sharemap = upr::make_sharemap ();
typ_list_sharemap = upr::make_sharemap ();
type_sharemap = upr::make_sharemap ();
null_or_type_sharemap = upr::make_sharemap ();
list_type_sharemap = upr::make_sharemap ();
inlining_info_sharemap = upr::make_sharemap ();
var_sharemap = upr::make_sharemap ();
package_definition_sharemap = upr::make_sharemap ();
api_sharemap = upr::make_sharemap ();
generic_api_sharemap = upr::make_sharemap ();
spec_sharemap = upr::make_sharemap ();
typerstore_sharemap = upr::make_sharemap ();
generic_closure_sharemap = upr::make_sharemap ();
package_sharemap = upr::make_sharemap ();
generic_sharemap = upr::make_sharemap ();
stamp_expression_sharemap = upr::make_sharemap ();
typ_expression_sharemap = upr::make_sharemap ();
package_expression_sharemap = upr::make_sharemap ();
generic_expression_sharemap = upr::make_sharemap ();
module_expression_sharemap = upr::make_sharemap ();
module_declaration_sharemap = upr::make_sharemap ();
typechecked_package_dictionary_sharemap = upr::make_sharemap ();
typechecked_package_sharemap = upr::make_sharemap ();
typechecked_generic_sharemap = upr::make_sharemap ();
fixity_sharemap = upr::make_sharemap ();
naming_sharemap = upr::make_sharemap ();
elements_sharemap = upr::make_sharemap ();
list_of_bound_generic_evaluation_paths_sharemap = upr::make_sharemap ();
null_or_bound_generic_evaluation_paths_sharemap = upr::make_sharemap ();
spec_def_sharemap = upr::make_sharemap ();
list_inlining_info_sharemap = upr::make_sharemap ();
overload_sharemap = upr::make_sharemap ();
list_overload_sharemap = upr::make_sharemap ();
list_typechecked_package_declaration_sharemap = upr::make_sharemap ();
typechecked_package_dictionary_sharemap' = upr::make_sharemap ();
symbolmapstack_sharemap = upr::make_sharemap ();
symbol_path_sharemap = upr::make_sharemap ();
inverse_path_sharemap = upr::make_sharemap ();
pair_symbol_spec_sharemap = upr::make_sharemap ();
pair__stamppath__type_kind__sharemap = upr::make_sharemap ();
pair__package_definition__int__sharemap = upr::make_sharemap ();
pair__module_stamp__typerstore_entry__sharemap = upr::make_sharemap ();
pair_symbol_naming_sharemap = upr::make_sharemap ();
null_or_picklehash_sharemap = upr::make_sharemap ();
null_or_lib_mod_spec_sharemap = upr::make_sharemap ();
pair_int_symbol_sharemap = upr::make_sharemap ();
shared_stuff
->
{ read_picklehash,
read_string,
read_symbol,
read_varhome,
read_valcon_form,
read_constructor_signature,
read_null_or_int,
read_baseop,
read_list_of_bools,
read_type_kind,
read_list_of_typekinds
};
#
fun read_lib_mod_spec ()
=
read_null_or null_or_lib_mod_spec_sharemap (read_pair pair_int_symbol_sharemap (read_int, read_symbol)) ();
#
fun read_stamp ()
=
read_sharable_value stamp_sharemap st
where
fun st 'A' => sta::make_global_stamp
{
picklehash => get_global_picklehash (),
count => read_int ()
};
st 'B' => sta::make_global_stamp
{
picklehash => read_picklehash (),
count => read_int ()
};
st 'C' => sta::make_stale_stamp (read_string ());
st _ => raise exception FORMAT;
end;
end;
read_typestamp = read_stamp;
read_apistamp = read_stamp;
#
fun read_packagestamp ()
=
read_sharable_value packagestamp_sharemap si
where
fun si 'D' => { an_api => read_stamp (),
typechecked_package => read_stamp ()
};
si _ => raise exception FORMAT;
end;
end;
#
fun read_genericstamp ()
=
read_sharable_value genericstamp_sharemap fifi
where
#
fun fifi 'E' => { parameter_api => read_stamp (),
body_api => read_stamp (),
typechecked_generic => read_stamp ()
};
fifi _ => raise exception FORMAT;
end;
end;
read_typerstorestamp = read_stamp;
read_list_of_stamps = read_list list_stamp_sharemap read_stamp;
read_null_or_stamp = read_null_or null_or_stamp_sharemap read_stamp;
read_null_or_picklehash = read_null_or null_or_picklehash_sharemap read_picklehash;
read_module_stamp = read_stamp;
read_null_or_typechecked_package_var = read_null_or_stamp;
read_stamppath = read_list_of_stamps;
read_list_of_symbols = read_list list_of_symbols_sharemap read_symbol;
read_null_or_symbol = read_null_or null_or_symbol_sharemap read_symbol;
#
fun read_symbol_path ()
=
read_sharable_value symbol_path_sharemap sp
where
fun sp 's' => sp::SYMBOL_PATH (read_list_of_symbols ());
sp _ => raise exception FORMAT;
end;
end;
#
fun read_inverse_path ()
=
read_sharable_value inverse_path_sharemap ip
where
fun ip 'i' => ip::INVERSE_PATH (read_list_of_symbols ());
ip _ => raise exception FORMAT;
end;
end;
read_list_of_symbolpaths = read_list list_symbol_path_sharemap read_symbol_path;
read_list_of_lists_of_symbolpaths = read_list list_list_symbol_path_sharemap read_list_of_symbolpaths;
read_label = read_symbol;
read_list_of_labels = read_list_of_symbols;
#
fun read_equality_property ()
=
read_unsharable_value eqp
where
fun eqp c
=
vector::get (equality_property_table, char::to_int c)
except
(exceptions::SUBSCRIPT|exceptions::INDEX_OUT_OF_BOUNDS) = raise exception FORMAT;
end;
#
fun read_datatyp' ()
=
read_sharable_value valcon_sharemap d
where
fun d 'c'
=>
{ name = read_symbol ();
is_constant = read_bool ();
(read_type' ()) -> (type, ttr);
form = read_valcon_form ();
signature = read_constructor_signature ();
is_lazy = read_bool ();
( ty::VALCON
{
name,
is_constant,
type,
form,
signature,
is_lazy
},
ttr
);
};
d _ => raise exception FORMAT;
end;
end
also
fun read_typ_kind ()
=
read_sharable_value typ_kind_sharemap tk
where
fun tk 'a'
=>
ty::BASE (read_int ());
tk 'b'
=>
{ index = read_int ();
root = read_null_or_typechecked_package_var ();
my (stamps, family, free_typs)
=
read_datatype_info ();
ty::DATATYPE
{
index,
root,
stamps,
family,
free_typs
};
};
tk 'c' => ty::ABSTRACT (read_typ ());
tk 'd' => ty::FORMAL;
tk 'e' => ty::TEMP;
tk _ => raise exception FORMAT;
end;
end
also
fun read_datatype_info ()
=
read_sharable_value datatype_info_sharemap dti
where
fun dti 'a'
=>
(vector::from_list (read_list_of_stamps ()), read_datatype_family (), read_list_typ ());
dti _
=>
raise exception FORMAT;
end;
end
also
fun read_datatype_family ()
=
read_sharable_value datatype_family_sharemap dtf
where
fun dtf 'b'
=>
{ mkey => read_stamp (),
members => vector::from_list (read_list_datatype_member ()),
property_list => property_list::make_property_list ()
};
dtf _ => raise exception FORMAT;
end;
end
also
fun read_datatype_member ()
=
read_sharable_value datatype_member_sharemap d
where
fun d 'c'
=>
{ typ_name => read_symbol (),
constructor_list => read_list_name_form_domain (),
arity => read_int (),
eqtype_info => REF (read_equality_property ()),
is_lazy => read_bool (),
an_api => read_constructor_signature ()
};
d _ => raise exception FORMAT;
end;
end
also
fun read_list_datatype_member ()
=
read_list list_datatype_member_sharemap read_datatype_member ()
also
fun read_name_form_domain ()
=
read_sharable_value name_form_domain_sharemap n
where
fun n 'd'
=>
{ name => read_symbol (),
form => read_valcon_form (),
domain => read_null_or_type ()
};
n _ => raise exception FORMAT;
end;
end
also
fun read_list_name_form_domain ()
=
read_list list_name_form_domain_sharemap read_name_form_domain ()
also
fun read_typ ()
=
read_sharable_value typ_sharemap typeconstructor
where
fun typeconstructor 'A'
=>
ty::PLAIN_TYP
(find_plain_typ_record_by_typestamp
( read_lib_mod_spec (),
read_typestamp ()
)
);
typeconstructor 'B'
=>
ty::PLAIN_TYP
{
stamp => read_stamp (),
arity => read_int (),
eqtype_info => REF (read_equality_property ()),
kind => read_typ_kind (),
path => read_inverse_path (),
stub => THE { owner => if is_lib read_picklehash ();
else get_global_picklehash ();
fi,
is_lib
}
};
typeconstructor 'C'
=>
ty::DEFINED_TYP
{
stamp => read_stamp (),
type_scheme => ty::TYPE_SCHEME { arity => read_int (),
body => read_type ()
},
strict => read_list_of_bools (),
path => read_inverse_path ()
};
typeconstructor 'D'
=>
ty::TYP_BY_STAMPPATH
{
arity => read_int (),
stamppath => read_stamppath (),
path => read_inverse_path ()
};
typeconstructor 'E' => ty::RECORD_TYP (read_list_of_labels ());
typeconstructor 'F' => ty::RECURSIVE_TYPE (read_int ());
typeconstructor 'G' => ty::FREE_TYPE (read_int ());
typeconstructor 'H' => ty::ERRONEOUS_TYP;
typeconstructor _ => raise exception FORMAT;
end;
end
also
fun read_typ' ()
=
(typ, modtree)
where
typ = read_typ ();
modtree = case typ
#
ty::PLAIN_TYP plain_typ_record => mld::PLAIN_TYP_MODTREE_NODE plain_typ_record;
_ => no_modtree;
esac;
end
also
fun read_list_typ ()
=
read_list typ_list_sharemap read_typ ()
also
fun read_type' ()
=
read_sharable_value type_sharemap read_type''
where
#
fun read_type'' 'a' # TYPCON_TYPE
=>
{ (read_typ' ()) -> (typ, typ_modtree);
(read_list_type' ()) -> (typelist, typelist_modtrees);
( ty::TYPCON_TYPE (typ, typelist),
modtree_branch [typ_modtree, typelist_modtrees]
);
};
read_type'' 'b' => (ty::TYPE_SCHEME_ARG_I (read_int ()), no_modtree); # TYPE_SCHEME_ARG_I
read_type'' 'c' => (ty::WILDCARD_TYPE, no_modtree); # WILDCARE_TYPE
read_type'' 'd' # TYPE_SCHEME_TYPE
=>
{ (read_list_of_bools ()) -> eqprops;
(read_int ()) -> arity;
(read_type' ()) -> (body, body_modtree);
( ty::TYPE_SCHEME_TYPE
{
type_scheme_arg_eq_properties => eqprops,
type_scheme => ty::TYPE_SCHEME { arity, body }
},
#
body_modtree
);
};
read_type'' 'e' => (ty::UNDEFINED_TYPE, no_modtree); # UNDEFINED_TYPE
read_type'' _ => raise exception FORMAT;
end;
end
also
fun read_type ()
=
#1 (read_type' ())
also
fun read_null_or_type ()
=
read_null_or null_or_type_sharemap read_type ()
# paired_lists is from src/lib/std/src/paired-lists.pkg also
fun read_list_type' ()
=
{ my (types, type_modtrees)
=
paired_lists::unzip # [(a,a'), (b,b'), (c,c')] -> ([a, b, c], [a', b', c'])
(read_list list_type_sharemap read_type' ());
(types, modtree_branch type_modtrees);
}
also
fun read_inlining_data ()
=
read_sharable_value inlining_info_sharemap ii
where
fun ii 'A' => ij::make_baseop_inlining_data (read_baseop (), read_type ());
ii 'B' => ij::make_package_inlining_data (read_list_inlining_data ());
ii 'C' => ij::null_inlining_data;
ii _ => raise exception FORMAT;
end;
end
also
fun read_list_inlining_data ()
=
read_list list_inlining_info_sharemap read_inlining_data ()
also
fun read_var' ()
=
read_sharable_value var_sharemap read_var''
where
fun read_var'' '1' => # ORDINARY_VARIABLE
{ varhome = read_varhome ();
inlining_data = read_inlining_data ();
path = read_symbol_path ();
(read_type' ()) -> (var_type, type_modtree);
( vac::ORDINARY_VARIABLE { varhome, inlining_data, path, var_type => REF var_type },
type_modtree
);
};
read_var'' '2' => # OVERLOADED_IDENTIFIER
{ (read_symbol ()) -> name;
(read_list_overloaded_identifier' ()) -> (alternatives, alternatives_modtrees);
(read_int ()) -> arity;
(read_type' ()) -> (body, body_modtree);
( vac::OVERLOADED_IDENTIFIER
{ name,
alternatives => REF alternatives,
type_scheme => ty::TYPE_SCHEME { arity, body }
},
modtree_branch [alternatives_modtrees, body_modtree]
);
};
read_var'' '3' => (vac::ERRORVAR, no_modtree);
read_var'' _ => raise exception FORMAT;
end;
end
also
fun read_overld' ()
=
read_sharable_value overload_sharemap read_overld''
where
fun read_overld'' 'o'
=>
{ (read_type' ()) -> (indicator, type_modtree);
(read_var' ()) -> (variant, var_modtree);
( { indicator, variant },
modtree_branch [type_modtree, var_modtree]
);
};
read_overld'' _
=>
raise exception FORMAT;
end;
end
also
fun read_list_overloaded_identifier' ()
=
{ my (overloaded_identifiers, modtrees)
=
paired_lists::unzip
(read_list list_overload_sharemap read_overld' ());
( overloaded_identifiers, # : List { indicator, variant }
modtree_branch modtrees
);
};
fun read_package_definition ()
=
read_sharable_value package_definition_sharemap sd
where
fun sd 'C' => mld::CONSTANT_PACKAGE_DEFINITION (read_a_package ());
sd 'V' => mld::VARIABLE_PACKAGE_DEFINITION (read_an_api (), read_stamppath ());
sd _ => raise exception FORMAT;
end;
end
also
fun read_an_api' ()
=
read_sharable_value api_sharemap read_an_api''
where
#
fun read_an_api'' 'A' => (mld::ERRONEOUS_API, no_modtree);
read_an_api'' 'B'
=>
{ api_record
=
find_api_record_by_apistamp (read_lib_mod_spec (), read_apistamp ());
( mld::API api_record,
mld::API_MODTREE_NODE api_record
);
};
read_an_api'' 'C'
=>
{ stamp = read_stamp ();
name = read_null_or_symbol ();
closed = read_bool ();
contains_generic = read_bool ();
symbols = read_list_of_symbols ();
my (api_elements, element_modtrees)
=
paired_lists::unzip
(map (fn (symbol, (sp, tr)) = ((symbol, sp), tr))
(read_list elements_sharemap
(read_pair pair_symbol_spec_sharemap (read_symbol, read_spec')) ()));
bound_generic_evaluation_paths
=
read_null_or null_or_bound_generic_evaluation_paths_sharemap
#
(read_list list_of_bound_generic_evaluation_paths_sharemap
#
(read_pair pair__stamppath__type_kind__sharemap
#
(read_stamppath, read_type_kind)
) )
();
type_sharing = read_list_of_lists_of_symbolpaths ();
package_sharing = read_list_of_lists_of_symbolpaths ();
api_record
=
{ stamp,
name,
closed,
contains_generic,
symbols,
api_elements,
#
property_list => property_list::make_property_list (),
#
# Boundeps = REF beps,
# lambdaty = REF NULL,
#
type_sharing,
package_sharing,
#
stub => THE { modtree => modtree_branch element_modtrees,
is_lib,
owner => if is_lib read_picklehash ();
else get_global_picklehash ();
fi
}
};
package_property_lists::set_api_bound_generic_evaluation_paths
(
api_record,
bound_generic_evaluation_paths
);
( mld::API api_record,
mld::API_MODTREE_NODE api_record
);
};
read_an_api'' _
=>
raise exception FORMAT;
end;
end
also
fun read_an_api ()
=
#1 (read_an_api' ())
also
fun read_generic_api' ()
=
read_sharable_value generic_api_sharemap read_generic_api''
where
fun read_generic_api'' 'a' => (mld::ERRONEOUS_GENERIC_API, no_modtree);
#
read_generic_api'' 'c' =>
{ (read_null_or_symbol ()) -> kind;
(read_an_api' ()) -> (parameter_api, parameter_api_modtree);
(read_module_stamp ()) -> parameter_variable;
(read_null_or_symbol ()) -> parameter_symbol;
(read_an_api' ()) -> (body_api, body_api_modtree);
( mld::GENERIC_API { kind,
parameter_api,
parameter_variable,
parameter_symbol,
body_api
},
#
modtree_branch [parameter_api_modtree, body_api_modtree]
);
};
read_generic_api'' _
=>
raise exception FORMAT;
end;
end
also
fun read_spec' () # "spec" generally means anything in an API.
=
read_sharable_value spec_sharemap read_spec''
where
fun read_spec'' '1'
=>
{ (read_typ' ()) -> (typ, typ_modtree);
#
( mld::TYP_IN_API { typ,
module_stamp => read_module_stamp (),
is_a_replica => read_bool (),
scope => read_int ()
},
typ_modtree
);
};
read_spec'' '2'
=>
{ (read_an_api' ()) -> (an_api, api_modtree);
#
( mld::PACKAGE_IN_API { an_api,
slot => read_int (),
definition => read_null_or spec_def_sharemap (read_pair pair__package_definition__int__sharemap (read_package_definition, read_int)) (),
module_stamp => read_module_stamp ()
},
api_modtree
);
};
read_spec'' '3'
=>
{ (read_generic_api' ()) -> (a_generic_api, generic_api_modtree);
#
( mld::GENERIC_IN_API { a_generic_api,
slot => read_int (),
module_stamp => read_module_stamp ()
},
generic_api_modtree
);
};
read_spec'' '4'
=>
{ (read_type' ()) -> (type, type_modtree);
#
( mld::VALUE_IN_API { type, slot => read_int () },
type_modtree
);
};
read_spec'' '5'
=>
{ (read_datatyp' ()) -> (datatype, datatype_modtree);
#
( mld::VALCON_IN_API { datatype,
slot => read_null_or_int ()
},
datatype_modtree
);
};
read_spec'' _ => raise exception FORMAT;
end;
end
also
fun read_typerstore_entry' ()
=
read_sharable_value typerstore_sharemap read_typerstore_entry''
where
fun read_typerstore_entry'' 'A' => &&& mld::TYP_ENTRY (read_typechecked_typ' ());
read_typerstore_entry'' 'B' => &&& mld::PACKAGE_ENTRY (read_typechecked_package' ());
read_typerstore_entry'' 'C' => &&& mld::GENERIC_ENTRY (read_typechecked_generic' ());
read_typerstore_entry'' 'D' => (mld::ERRONEOUS_ENTRY, no_modtree);
read_typerstore_entry'' _ => raise exception FORMAT;
end;
end
also
fun read_generic_closure' ()
=
read_sharable_value generic_closure_sharemap f
where
fun f 'f'
=>
{ (read_module_stamp ()) -> parameter_module_stamp;
(read_package_expression' ()) -> (body_package_expression, body_modtree);
(read_typerstore' ()) -> (typerstore, typerstore_modtree);
( mld::GENERIC_CLOSURE { parameter_module_stamp,
body_package_expression,
typerstore
},
modtree_branch [body_modtree, typerstore_modtree]
);
};
f _ => raise exception FORMAT;
end;
end
# The construction of the PACKAGE_MODTREE_NODE in the Modtree deserves some
# comment: Even though it contains the whole Package_Record, it does
# _not_ take care of the an_api contained therein. The reason
# why PACKAGE_MODTREE_NODE has the whole Package_Record and not just the Typechecked_Package that
# it really guards is that the identity of the Typechecked_Package is not
# fully recoverable without also having access to the an_api.
# The same situation occurs in the case of GENERIC_MODTREE_NODE.
also
fun read_a_package' ()
=
read_sharable_value package_sharemap read_a_package''
where
fun read_a_package'' 'A'
=>
{ (read_an_api' ()) -> (an_api, api_modtree);
#
( mld::PACKAGE_API { an_api, stamppath => read_stamppath () },
api_modtree
);
};
read_a_package'' 'B' => (mld::ERRONEOUS_PACKAGE, no_modtree);
read_a_package'' 'C'
=>
{ (read_an_api' ()) -> (an_api, api_modtree);
#
package_record
=
{ an_api,
typechecked_package => find_typechecked_package_by_packagestamp (read_lib_mod_spec (), read_packagestamp ()),
varhome => read_varhome (),
inlining_data => read_inlining_data ()
};
( mld::A_PACKAGE package_record,
modtree_branch [api_modtree, mld::PACKAGE_MODTREE_NODE package_record]
);
};
read_a_package'' 'D'
=>
{ (read_an_api' ()) -> (an_api, api_modtree);
#
package_record
=
{ an_api,
typechecked_package => read_typechecked_package (),
varhome => read_varhome (),
inlining_data => read_inlining_data ()
};
( mld::A_PACKAGE package_record,
modtree_branch [api_modtree, mld::PACKAGE_MODTREE_NODE package_record]
);
};
read_a_package'' _ => raise exception FORMAT;
end;
end
also
fun read_a_package ()
=
#1 (read_a_package' ())
also
fun read_a_generic' ()
=
read_sharable_value generic_sharemap read_a_generic''
where
# See the comment about PACKAGE_MODTREE_NODE, Package_Record,
# an_api, and Typechecked_Package in front of a_package'.
# The situation for GENERIC_MODTREE_NODE, Generic_Record,
# generic_api, and Typechecked_Generic is analogous.
#
fun read_a_generic'' 'E' => (mld::ERRONEOUS_GENERIC, no_modtree);
read_a_generic'' 'F'
=>
{ (read_generic_api' ()) -> (a_generic_api, api_modtree) ;
#
generic_record
=
{ a_generic_api,
typechecked_generic => find_typechecked_generic_by_genericstamp (read_lib_mod_spec (), read_genericstamp ()),
varhome => read_varhome (),
inlining_data => read_inlining_data ()
};
( mld::GENERIC generic_record,
modtree_branch [api_modtree, mld::GENERIC_MODTREE_NODE generic_record]
);
};
read_a_generic'' 'G'
=>
{ (read_generic_api' ()) -> (a_generic_api, api_modtree);
#
generic_record
=
{ a_generic_api,
typechecked_generic => read_typechecked_generic (),
varhome => read_varhome (),
inlining_data => read_inlining_data ()
};
( mld::GENERIC generic_record,
modtree_branch [api_modtree, mld::GENERIC_MODTREE_NODE generic_record]
);
};
read_a_generic'' _ => raise exception FORMAT;
end;
end
also
fun read_stamp_expression ()
=
read_sharable_value stamp_expression_sharemap sxe
where
fun sxe 'b' => mld::GET_STAMP (read_package_expression ());
sxe 'c' => mld::MAKE_STAMP;
sxe _ => raise exception FORMAT;
end;
end
also
fun read_typ_expression' ()
=
read_sharable_value typ_expression_sharemap tce
where
fun tce 'd' => &&& mld::CONSTANT_TYP (read_typ' ());
tce 'e' => (mld::FORMAL_TYP (read_typ ()), no_modtree); # ?
tce 'f' => (mld::TYPE_VARIABLE_TYP (read_stamppath ()), no_modtree);
tce _ => raise exception FORMAT;
end;
end
also
fun read_typ_expression () = #1 (read_typ_expression' ())
also
fun read_package_expression' ()
=
read_sharable_value package_expression_sharemap pkg_exp
where
fun pkg_exp 'g' => (mld::VARIABLE_PACKAGE (read_stamppath ()), no_modtree);
pkg_exp 'h' => &&& mld::CONSTANT_PACKAGE (read_typechecked_package' ());
pkg_exp 'i'
=>
{ (read_stamp_expression ()) -> stamp;
(read_module_declaration' ()) -> (module_declaration, declaration_modtree);
#
( mld::PACKAGE { stamp, module_declaration },
declaration_modtree
);
};
pkg_exp 'j'
=>
{ (read_generic_expression' ()) -> (generic_expression, generic_modtree);
(read_package_expression' ()) -> (package_expression, package_modtree);
#
( mld::APPLY (generic_expression, package_expression),
modtree_branch [generic_modtree, package_modtree]
);
};
pkg_exp 'k'
=>
{ (read_module_declaration' ()) -> (declaration, declaration_modtree);
(read_package_expression' ()) -> (expression, expression_modtree);
#
( mld::PACKAGE_LET { declaration, expression },
modtree_branch [declaration_modtree, expression_modtree]
);
};
pkg_exp 'l'
=>
{ (read_an_api' ()) -> (an_api, api_modtree);
(read_package_expression' ()) -> (expression, expression_modtree);
#
( mld::ABSTRACT_PACKAGE (an_api, expression),
modtree_branch [api_modtree, expression_modtree]
);
};
pkg_exp 'm'
=>
{ (read_module_stamp ()) -> boundvar;
(read_package_expression' ()) -> (raw, raw_modtree);
(read_package_expression' ()) -> (coercion, coercion_modtree);
( mld::COERCED_PACKAGE { boundvar, raw, coercion },
modtree_branch [raw_modtree, coercion_modtree]
);
};
pkg_exp 'n' => &&& mld::FORMAL_PACKAGE (read_generic_api' ());
pkg_exp _ => raise exception FORMAT;
end;
end
also
fun read_package_expression ()
=
#1 (read_package_expression' ())
also
fun read_generic_expression' ()
=
read_sharable_value generic_expression_sharemap fe
where
fun fe 'o' => (mld::VARIABLE_GENERIC (read_stamppath ()), no_modtree);
fe 'p' => &&& mld::CONSTANT_GENERIC (read_typechecked_generic' ());
fe 'q'
=>
{ (read_module_stamp ()) -> parameter;
(read_package_expression' ()) -> (body, body_modtree);
( mld::LAMBDA { parameter, body },
body_modtree
);
};
fe 'r'
=>
{ (read_module_stamp ()) -> parameter;
(read_package_expression' ()) -> (body, body_modtree);
(read_generic_api' ()) -> (an_api, api_modtree);
(mld::LAMBDA_TP { parameter, body, an_api },
modtree_branch [body_modtree, api_modtree]);
};
fe 's'
=>
{ (read_module_declaration' ()) -> (module_declaration, declaration_modtree);
(read_generic_expression' ()) -> (generic_expression, generic_modtree );
#
( mld::LET_GENERIC (module_declaration, generic_expression),
modtree_branch [declaration_modtree, generic_modtree]
);
};
fe _ => raise exception FORMAT;
end;
end
also
fun read_generic_expression () = #1 (read_generic_expression' ())
also
fun read_module_expression ()
=
read_sharable_value module_expression_sharemap ee
where
fun ee 't' => mld::TYP_EXPRESSION (read_typ_expression ());
ee 'u' => mld::PACKAGE_EXPRESSION (read_package_expression ());
ee 'v' => mld::GENERIC_EXPRESSION (read_generic_expression ());
ee 'w' => mld::ERRONEOUS_ENTRY_EXPRESSION;
ee 'x' => mld::DUMMY_GENERIC_EVALUATION_EXPRESSION;
ee _ => raise exception FORMAT;
end;
end
also
fun read_module_declaration' ()
=
read_sharable_value module_declaration_sharemap ed
where
fun ed 'A'
=>
{ (read_module_stamp ()) -> stamp;
(read_typ_expression' ()) -> (typ_expression, expression_modtree);
#
( mld::TYP_DECLARATION (stamp, typ_expression),
expression_modtree
);
};
ed 'B'
=>
{ (read_module_stamp ()) -> stamp;
(read_package_expression' ()) -> (package_expression, package_expression_modtree);
(read_symbol ()) -> symbol;
#
( mld::PACKAGE_DECLARATION (stamp, package_expression, symbol),
package_expression_modtree
);
};
ed 'C'
=>
{ (read_module_stamp ()) -> stamp;
(read_generic_expression' ()) -> (generic_expression, generic_expression_modtree);
#
( mld::GENERIC_DECLARATION (stamp, generic_expression),
generic_expression_modtree
);
};
ed 'D' => &&& mld::SEQUENTIAL_DECLARATIONS (read_typechecked_package_dec_list' ());
ed 'E' =>
{ (read_module_declaration' ()) -> (declaration1, modtree1);
(read_module_declaration' ()) -> (declaration2, modtree2);
#
( mld::LOCAL_DECLARATION (declaration1, declaration2),
modtree_branch [modtree1, modtree2]
);
};
ed 'F' => (mld::ERRONEOUS_ENTRY_DECLARATION, no_modtree);
ed 'G' => (mld::EMPTY_GENERIC_EVALUATION_DECLARATION, no_modtree);
ed _ => raise exception FORMAT;
end;
end
also
fun read_typechecked_package_dec_list' ()
=
{ my (l, trl)
=
paired_lists::unzip (read_list list_typechecked_package_declaration_sharemap read_module_declaration' ());
(l, modtree_branch trl);
}
also
fun read_typerstore' ()
=
read_sharable_value typechecked_package_dictionary_sharemap eenv
where
fun eenv 'A'
=>
{ l = read_list typechecked_package_dictionary_sharemap'
(read_pair pair__module_stamp__typerstore_entry__sharemap
(read_module_stamp, read_typerstore_entry')
)
();
l' = map (fn (v, (e, tr)) = ((v, e), tr)) l;
(paired_lists::unzip l') -> (l'', modtrees);
#
fun set ((v, e), z)
=
ed::set (z, v, e);
typerstore_entry_map
=
fold_backward set ed::empty l'';
(read_typerstore' ()) -> (typerstore, typerstore_modtree);
( mld::NAMED_TYPERSTORE (typerstore_entry_map, typerstore),
#
modtree_branch (typerstore_modtree ! modtrees)
);
};
eenv 'B' => (mld::NULL_TYPERSTORE, no_modtree);
eenv 'C' => (mld::ERRONEOUS_ENTRY_DICTIONARY, no_modtree);
eenv 'D'
=>
{ typerstore_record
=
find_typerstore_record_by_typerstorestamp (read_lib_mod_spec (), read_typerstorestamp ());
#
( mld::MARKED_TYPERSTORE typerstore_record,
mld::TYPERSTORE_MODTREE_NODE typerstore_record
);
};
eenv 'E'
=>
{ (read_stamp ()) -> stamp;
(read_typerstore' ()) -> (typerstore, modtree);
typerstore_record
=
{ stamp,
typerstore,
stub => THE { modtree,
is_lib,
owner => if is_lib read_picklehash ();
else get_global_picklehash ();
fi
}
};
( mld::MARKED_TYPERSTORE typerstore_record,
mld::TYPERSTORE_MODTREE_NODE typerstore_record
);
};
eenv _ => raise exception FORMAT;
end;
end
also
fun read_typechecked_package' ()
=
read_sharable_value typechecked_package_sharemap read_typechecked_package''
where
fun read_typechecked_package'' 's'
=>
{ (read_stamp ()) -> stamp;
(read_typerstore' ()) -> (typerstore, modtree);
typechecked_package
=
{ stamp,
typerstore,
inverse_path => read_inverse_path (),
property_list => property_list::make_property_list (),
#
stub => THE { modtree,
is_lib,
owner => if is_lib read_picklehash ();
else get_global_picklehash ();
fi
}
};
( typechecked_package,
modtree
);
};
read_typechecked_package'' _
=>
raise exception FORMAT;
end;
end
also
fun read_typechecked_package ()
=
#1 (read_typechecked_package' ())
also
fun read_typechecked_generic' ()
=
read_sharable_value typechecked_generic_sharemap read_typechecked_generic''
where
fun read_typechecked_generic'' 'f'
=>
{ (read_stamp ()) -> stamp;
(read_generic_closure' ()) -> (generic_closure, generic_closure_modtree);
typechecked_generic
=
{ stamp,
generic_closure,
inverse_path => read_inverse_path (),
property_list => property_list::make_property_list (),
# lambdaty = REF NULL,
typ_path => NULL,
#
stub => THE { modtree => generic_closure_modtree,
is_lib,
owner => if is_lib read_picklehash ();
else get_global_picklehash ();
fi
}
};
( typechecked_generic,
generic_closure_modtree
);
};
read_typechecked_generic'' _
=>
raise exception FORMAT;
end;
end
also
fun read_typechecked_generic ()
=
#1 (read_typechecked_generic' ())
also
fun read_typechecked_typ' () = read_typ' ();
#
fun read_fixity ()
=
read_sharable_value fixity_sharemap read_fixity''
where
fun read_fixity'' 'N' => fixity::NONFIX;
read_fixity'' 'I' => fixity::INFIX (read_int (), read_int ());
read_fixity'' _ => raise exception FORMAT;
end;
end;
#
fun read_symbolmapstack_entry' () # symbol table entry.
=
read_sharable_value naming_sharemap read_symbolmapstack_entry''
where
fun read_symbolmapstack_entry'' '1' => &&& sxe::NAMED_VARIABLE (read_var' ());
read_symbolmapstack_entry'' '2' => &&& sxe::NAMED_CONSTRUCTOR (read_datatyp' ());
read_symbolmapstack_entry'' '3' => &&& sxe::NAMED_TYPE (read_typ' ());
read_symbolmapstack_entry'' '4' => &&& sxe::NAMED_API (read_an_api' ());
read_symbolmapstack_entry'' '5' => &&& sxe::NAMED_PACKAGE (read_a_package' ());
read_symbolmapstack_entry'' '6' => &&& sxe::NAMED_GENERIC_API (read_generic_api' ());
read_symbolmapstack_entry'' '7' => &&& sxe::NAMED_GENERIC (read_a_generic' ());
#
read_symbolmapstack_entry'' '8' => (sxe::NAMED_FIXITY (read_fixity ()), no_modtree);
#
read_symbolmapstack_entry'' _ => raise exception FORMAT;
end;
end;
#
fun read_symbolmapstack ()
=
syx::consolidate (fold_forward bind syx::empty bindlist)
where
bindlist = read_list symbolmapstack_sharemap (read_pair pair_symbol_naming_sharemap (read_symbol, read_symbolmapstack_entry')) ();
#
fun bind ((symbol, (entry, modtree)), symbolmapstack)
=
syx::bind_full_entry (symbol, { entry, modtree => THE modtree }, symbolmapstack);
end;
end; # fun make_symbolmapstack_unpickler
#
fun unpickle_symbolmapstack
#
(unpickling_context: Null_Or((Int, sy::Symbol)) -> stx::Stampmapstack) # Contains modtree info from combined symbol tables of all .compiled files our sourcefile depends upon.
#
( picklehash: ph::Picklehash, # Hash (message digest) of 'pickle'.
pickle: vector_of_one_byte_unts::Vector # Pickled form of symbol table containing (only) info produced by compiling our particular sourcefile.
)
=
{ unpickler
=
upr::make_unpickler
(upr::make_charstream_for_string
(byte::bytes_to_string pickle));
#
fun an_import i
=
vh::PATH (vh::EXTERN picklehash, i);
list_string_sharemap = upr::make_sharemap ();
list_of_symbols_sharemap = upr::make_sharemap ();
shared_stuff = make_shared_stuff (unpickler, an_import);
read_list_of_strings = upr::read_list unpickler list_string_sharemap shared_stuff.read_string;
extra_info = { get_global_picklehash => fn () = picklehash,
shared_stuff,
is_lib => FALSE
};
unpickler_info = { unpickler, read_list_of_strings };
unpickle = make_symbolmapstack_unpickler
extra_info
unpickler_info
unpickling_context;
unpickle ();
};
#
fun make_highcode_unpickler (unpickler, shared_stuff)
=
function_declaration
where
fun read_sharable_value sharemap read_value = upr::read_sharable_value unpickler sharemap read_value;
fun read_list sharemap read_value = upr::read_list unpickler sharemap read_value;
fun read_null_or sharemap read_value = upr::read_null_or unpickler sharemap read_value;
#
fun read_pair sharemap fp p
=
upr::read_pair unpickler sharemap fp p;
read_int = upr::read_int unpickler;
read_int1 = upr::read_int1 unpickler;
read_unt = upr::read_unt unpickler;
read_unt1 = upr::read_unt1 unpickler;
read_bool = upr::read_bool unpickler;
shared_stuff
->
{ read_picklehash,
read_string,
read_symbol,
read_varhome,
read_valcon_form,
read_constructor_signature,
read_baseop,
read_list_of_bools,
read_type_kind,
read_list_of_typekinds,
read_null_or_int
};
lambda_type_sharemap = upr::make_sharemap ();
lambda_type_list_sharemap = upr::make_sharemap ();
typ_sharemap = upr::make_sharemap ();
typ_list_sharemap = upr::make_sharemap ();
value_sharemap = upr::make_sharemap ();
con_sharemap = upr::make_sharemap ();
dcon_sharemap = upr::make_sharemap ();
dictionary_sharemap = upr::make_sharemap ();
fprim_sharemap = upr::make_sharemap ();
lambda_expression_sharemap = upr::make_sharemap ();
function_kind_sharemap = upr::make_sharemap ();
record_kind_sharemap = upr::make_sharemap ();
ltylo_m = upr::make_sharemap ();
dictionary_table_sharemap = upr::make_sharemap ();
null_or_dictionary_sharemap = upr::make_sharemap ();
list_value_sharemap = upr::make_sharemap ();
list_lvar_sharemap = upr::make_sharemap ();
fundec_list_sharemap = upr::make_sharemap ();
con_list_sharemap = upr::make_sharemap ();
lexp_option_m = upr::make_sharemap ();
function_declaration_sharemap = upr::make_sharemap ();
tfundec_sharemap = upr::make_sharemap ();
lv_lt_pm = upr::make_sharemap ();
lv_lt_pl_sharemap = upr::make_sharemap ();
lv_tk_pm = upr::make_sharemap ();
lv_tk_pl_sharemap = upr::make_sharemap ();
tyc_lv_pm = upr::make_sharemap ();
#
fun read_lambdatype ()
=
read_sharable_value lambda_type_sharemap read_lambdatype''
where
fun read_lambdatype'' 'A' => hct::make_typ_uniqtype (read_typ ());
read_lambdatype'' 'B' => hct::make_package_uniqtype (read_list_of_lambdatypes ());
read_lambdatype'' 'C' => hct::make_generic_package_uniqtype (read_list_of_lambdatypes (), read_list_of_lambdatypes ());
read_lambdatype'' 'D' => hct::make_typeagnostic_uniqtype (read_list_of_typekinds (), read_list_of_lambdatypes ());
#
read_lambdatype'' _ => raise exception FORMAT;
end;
end
also
fun read_list_of_lambdatypes ()
=
read_list lambda_type_list_sharemap read_lambdatype ()
also
fun read_typ ()
=
read_sharable_value typ_sharemap read_typ''
where
fun read_typ'' 'A' => hct::make_debruijn_typevar_uniqtyp (di::di_fromint (read_int ()), read_int ());
read_typ'' 'B' => hct::make_named_typevar_uniqtyp (read_int ());
read_typ'' 'C' => hct::make_basetype_uniqtyp (hbt::basetype_from_int (read_int ()));
read_typ'' 'D' => hct::make_typefun_uniqtyp (read_list_of_typekinds (), read_typ ());
read_typ'' 'E' => hct::make_apply_typefun_uniqtyp (read_typ (), read_list_of_typs ());
read_typ'' 'F' => hct::make_typeseq_uniqtyp (read_list_of_typs ());
read_typ'' 'G' => hct::make_ith_in_typeseq_uniqtyp (read_typ (), read_int ());
read_typ'' 'H' => hct::make_sum_uniqtyp (read_list_of_typs ());
read_typ'' 'I' => hct::make_recursive_uniqtyp ((read_int (), read_typ (), read_list_of_typs ()), read_int ());
read_typ'' 'J' => hct::make_abstract_uniqtyp (read_typ ());
read_typ'' 'K' => hct::make_boxed_uniqtyp (read_typ ());
read_typ'' 'L' => hct::make_tuple_uniqtyp (read_list_of_typs ());
read_typ'' 'M' => hct::make_arrow_uniqtyp (hct::make_variable_calling_convention { arg_is_raw => read_bool (), body_is_raw => read_bool () }, read_list_of_typs (), read_list_of_typs ());
read_typ'' 'N' => hct::make_arrow_uniqtyp (hct::fixed_calling_convention, read_list_of_typs (), read_list_of_typs ());
read_typ'' 'O' => hut::typ_to_uniqtyp (hut::typ::EXTENSIBLE_TOKEN (hut::token_key (read_int ()), read_typ ()));
#
read_typ'' _ => raise exception FORMAT;
end;
end
also
fun read_list_of_typs () = read_list typ_list_sharemap read_typ ();
read_highcode_variable = read_int;
read_list_lvar = read_list list_lvar_sharemap read_highcode_variable;
#
fun read_value ()
=
read_sharable_value value_sharemap read_value''
where
fun read_value'' 'a' => acf::VAR (read_highcode_variable ());
read_value'' 'b' => acf::INT (read_int ());
read_value'' 'c' => acf::INT1 (read_int1 ());
read_value'' 'd' => acf::UNT (read_unt ());
read_value'' 'e' => acf::UNT1 (read_unt1 ());
read_value'' 'f' => acf::FLOAT64 (read_string ());
read_value'' 'g' => acf::STRING (read_string ());
#
read_value'' _ => raise exception FORMAT;
end;
end;
read_list_value
=
read_list list_value_sharemap read_value;
#
fun con ()
=
read_sharable_value con_sharemap c
where
fun c '1'
=>
{ (dcon ()) -> (dc, ts);
( acf::VAL_CASETAG (dc, ts, read_highcode_variable ()),
lambda_expression ()
);
};
c '2' => (acf::INT_CASETAG (read_int ()), lambda_expression ());
c '3' => (acf::INT1_CASETAG (read_int1 ()), lambda_expression ());
c '4' => (acf::UNT_CASETAG (read_unt ()), lambda_expression ());
c '5' => (acf::UNT1_CASETAG (read_unt1 ()), lambda_expression ());
c '6' => (acf::FLOAT64_CASETAG (read_string()), lambda_expression ());
c '7' => (acf::STRING_CASETAG (read_string()), lambda_expression ());
c '8' => (acf::VLEN_CASETAG (read_int ()), lambda_expression ());
#
c _ => raise exception FORMAT;
end;
end
also
fun conlist ()
=
read_list con_list_sharemap con ()
also
fun dcon ()
=
read_sharable_value dcon_sharemap d
where
fun d 'x' => ((read_symbol (), read_valcon_form (), read_lambdatype ()), read_list_of_typs ());
d _ => raise exception FORMAT;
end;
end
also
fun dictionary ()
=
read_sharable_value dictionary_sharemap d
where
fun d 'y'
=>
{ default => read_highcode_variable (),
table => read_list dictionary_table_sharemap (read_pair tyc_lv_pm (read_list_of_typs, read_highcode_variable)) ()
};
d _ => raise exception FORMAT;
end;
end
also
fun fprim ()
=
read_sharable_value fprim_sharemap f
where
fun f 'z' => ( read_null_or null_or_dictionary_sharemap dictionary (),
read_baseop (),
read_lambdatype (),
read_list_of_typs ()
);
f _ => raise exception FORMAT;
end;
end
also
fun lambda_expression ()
=
read_sharable_value lambda_expression_sharemap e
where
#
fun e 'j' => acf::RET (read_list_value ());
e 'k' => acf::LET (read_list_lvar (), lambda_expression (), lambda_expression ());
e 'l' => acf::MUTUALLY_RECURSIVE_FNS (fundeclist (), lambda_expression ());
e 'm' => acf::APPLY (read_value (), read_list_value ());
e 'n' => acf::TYPEFUN (tfundec (), lambda_expression ());
e 'o' => acf::APPLY_TYPEFUN (read_value (), read_list_of_typs ());
e 'p' => acf::SWITCH (read_value (), read_constructor_signature (), conlist (), lexpoption ());
e 'q' => { (dcon ()) -> (dc, ts);
#
acf::CONSTRUCTOR (dc, ts, read_value (), read_highcode_variable (), lambda_expression ());
};
e 'r' => acf::RECORD (record_kind (), read_list_value (), read_highcode_variable (), lambda_expression ());
e 's' => acf::GET_FIELD (read_value (), read_int (), read_highcode_variable (), lambda_expression ());
e 't' => acf::RAISE (read_value (), read_list_of_lambdatypes ());
e 'u' => acf::EXCEPT (lambda_expression (), read_value ());
e 'v' => acf::BRANCH (fprim (), read_list_value (), lambda_expression (), lambda_expression ());
e 'w' => acf::BASEOP (fprim (), read_list_value (), read_highcode_variable (), lambda_expression ());
e _ => raise exception FORMAT;
end;
end
also
fun lexpoption ()
=
read_null_or lexp_option_m lambda_expression ()
also
fun function_declaration ()
=
read_sharable_value function_declaration_sharemap f
where
fun f 'a'
=>
(fkind (), read_highcode_variable (),
read_list lv_lt_pl_sharemap (read_pair lv_lt_pm (read_highcode_variable, read_lambdatype)) (),
lambda_expression ());
f _ => raise exception FORMAT;
end;
end
also
fun fundeclist ()
=
read_list fundec_list_sharemap function_declaration ()
also
fun tfundec ()
=
read_sharable_value tfundec_sharemap t
where
fun t 'b'
=>
( { inlining_hint => acf::INLINE_IF_SIZE_SAFE },
read_highcode_variable (),
read_list lv_tk_pl_sharemap (read_pair lv_tk_pm (read_highcode_variable, read_type_kind)) (),
lambda_expression ()
);
t _ => raise exception FORMAT;
end;
end
also
fun fkind ()
=
read_sharable_value function_kind_sharemap fk
where
fun aug_unknown x
=
(x, acf::OTHER_LOOP);
#
fun inlflag TRUE => acf::INLINE_WHENEVER_POSSIBLE;
inlflag FALSE => acf::INLINE_IF_SIZE_SAFE;
end;
#
fun fk '2' => { loop_info => NULL,
call_as => acf::CALL_AS_GENERIC_PACKAGE,
private => FALSE,
inlining_hint => acf::INLINE_IF_SIZE_SAFE
};
fk '3' => { loop_info => null_or::map aug_unknown (ltylistoption ()),
call_as => acf::CALL_AS_FUNCTION (hct::make_variable_calling_convention { arg_is_raw => read_bool (), body_is_raw => read_bool () }),
private => read_bool (),
inlining_hint => inlflag (read_bool ())
};
fk '4' => { loop_info => null_or::map aug_unknown (ltylistoption ()),
call_as => acf::CALL_AS_FUNCTION hct::fixed_calling_convention,
private => read_bool (),
inlining_hint => inlflag (read_bool ())
};
fk _ => raise exception FORMAT;
end;
end
also
fun ltylistoption ()
=
read_null_or ltylo_m read_list_of_lambdatypes ()
also
fun record_kind ()
=
read_sharable_value record_kind_sharemap rk
where
fun rk '5' => acf::RK_VECTOR (read_typ ());
rk '6' => acf::RK_PACKAGE;
rk '7' => anormcode_junk::rk_tuple;
#
rk _ => raise exception FORMAT;
end;
end;
end;
#
fun unpickle_highcode pickle
=
{ unpickler = upr::make_unpickler (upr::make_charstream_for_string (byte::bytes_to_string pickle));
shared_stuff = make_shared_stuff (unpickler, vh::HIGHCODE_VARIABLE);
highcode = make_highcode_unpickler (unpickler, shared_stuff);
fo_m = upr::make_sharemap ();
upr::read_null_or unpickler fo_m highcode ();
};
#
fun make_unpicklers unpickler_info unpickling_context
=
# We get called (only) from:
#
# src/app/makelib/freezefile/freezefile-g.pkg #
{ unpickler_info -> { unpickler, read_list_of_strings };
shared_stuff = make_shared_stuff (unpickler, vh::HIGHCODE_VARIABLE);
shared_stuff -> { read_symbol,
read_picklehash,
...
};
list_of_symbols_sharemap = upr::make_sharemap ();
read_list_of_symbols = upr::read_list unpickler list_of_symbols_sharemap read_symbol;
extra_info = { get_global_picklehash => fn () = raise exception FORMAT,
shared_stuff,
is_lib => TRUE
};
read_symbolmapstack
=
make_symbolmapstack_unpickler
extra_info
unpickler_info
unpickling_context;
highcode = make_highcode_unpickler (unpickler, shared_stuff);
picklehash_highcode_pm = upr::make_sharemap ();
symbind = upr::read_pair unpickler picklehash_highcode_pm (read_picklehash, highcode);
sbl_m = upr::make_sharemap ();
sbl = upr::read_list unpickler sbl_m symbind;
#
fun read_inlining_mapstack ()
=
im::from_listi (sbl ());
{ read_inlining_mapstack,
read_symbolmapstack,
read_symbol,
read_list_of_symbols
};
};
unpickle_symbolmapstack
=
fn c = cos::do_compiler_phase
(cos::make_compiler_phase "Compiler 087 unpickle_symbolmapstack")
(unpickle_symbolmapstack c);
};
end;