## 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 from 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 tdt = type_declaration_types; # type_declaration_types is from src/lib/compiler/front/typer-stuff/types/type-declaration-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::RW_VECTOR_GET,
hbo::RO_VECTOR_GET,
hbo::RW_VECTOR_GET_WITH_BOUNDSCHECK,
hbo::RO_VECTOR_GET_WITH_BOUNDSCHECK,
hbo::MAKE_NONEMPTY_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_MICROTHREAD_REGISTER,
hbo::SET_CURRENT_MICROTHREAD_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::RW_VECTOR_SET,
hbo::RW_VECTOR_SET_WITH_BOUNDSCHECK,
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::THEN_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::RECORD_GET,
hbo::RAW64_GET,
hbo::SET_REFCELL_TO_TAGGED_INT_VALUE,
hbo::RAW_CCALL NULL,
hbo::IGNORE_MACRO,
hbo::IDENTITY_MACRO,
hbo::CVT64,
hbo::RW_MATRIX_GET_MACRO,
hbo::RO_MATRIX_GET_MACRO,
hbo::RW_MATRIX_GET_WITH_BOUNDSCHECK_MACRO,
hbo::RO_MATRIX_GET_WITH_BOUNDSCHECK_MACRO,
hbo::RW_MATRIX_SET_MACRO,
hbo::RW_MATRIX_SET_WITH_BOUNDSCHECK_MACRO
];
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
=
#[ tdt::e::YES,
tdt::e::NO,
tdt::e::INDETERMINATE,
tdt::e::CHUNK,
tdt::e::DATA,
tdt::e::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_typoid_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_sizeize_sharemap = upr::make_sharemap ();
baseop_sharemap = upr::make_sharemap ();
list_of_bools_sharemap = upr::make_sharemap ();
null_or_bool_sharemap = upr::make_sharemap ();
typoid_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_typoid_kind ()
=
read_sharable_value typoid_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_typoid_kind ());
tk _ => raise exception FORMAT;
end;
end
also
fun read_list_of_typekinds ()
=
read_list list_of_typekinds_sharemap read_typoid_kind ();
#
fun read_number_kind_and_sizeize ()
=
read_sharable_value number_kind_and_sizeize_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::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::INDEX_OUT_OF_BOUNDS = raise exception FORMAT;
read_unsharable_value co;
};
#
fun read_c_type ()
=
read_sharable_value ctype_sharemap ct
where
fun ct '\x14' => cty::ARRAY (read_c_type (), read_int ());
ct '\x15' => cty::STRUCT (read_c_type_list ());
ct '\x16' => cty::UNION (read_c_type_list ());
ct c => vector::get (c_type_table, char::to_int c)
except
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 '\x00' => hbo::CCI32;
ct '\x01' => hbo::CCI64;
ct '\x02' => hbo::CCR64;
ct '\x03' => 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 '\x64' => hbo::ARITH { op => read_math_op (), overflow => read_bool (), kind_and_size => read_number_kind_and_sizeize () };
po '\x65' => hbo::COMPARE { op => read_compare_op (), kind_and_size => read_number_kind_and_sizeize () };
po '\x66' => hbo::SHRINK_INT (read_int (), read_int ());
po '\x67' => hbo::SHRINK_UNT (read_int (), read_int ());
po '\x68' => hbo::CHOP (read_int (), read_int ());
po '\x69' => hbo::STRETCH (read_int (), read_int ());
po '\x6a' => hbo::COPY (read_int (), read_int ());
po '\x6b' => hbo::LSHIFT_MACRO (read_number_kind_and_sizeize ());
po '\x6c' => hbo::RSHIFT_MACRO (read_number_kind_and_sizeize ());
po '\x6d' => hbo::RSHIFTL_MACRO (read_number_kind_and_sizeize ());
po '\x6e' => hbo::ROUND { floor => read_bool (), from => read_number_kind_and_sizeize (), to => read_number_kind_and_sizeize () };
po '\x6f' => hbo::CONVERT_FLOAT { from => read_number_kind_and_sizeize (), to => read_number_kind_and_sizeize () };
po '\x70' => hbo::GET_VECSLOT_NUMERIC_CONTENTS { kind_and_size => read_number_kind_and_sizeize (), checkbounds => read_bool (), immutable => read_bool () };
po '\x71' => hbo::SET_VECSLOT_TO_NUMERIC_VALUE { kind_and_size => read_number_kind_and_sizeize (), checkbounds => read_bool () };
po '\x72' => hbo::ALLOCATE_NUMERIC_RW_VECTOR_MACRO (read_number_kind_and_sizeize ());
po '\x73' => hbo::ALLOCATE_NUMERIC_RO_VECTOR_MACRO (read_number_kind_and_sizeize ());
po '\x74' => hbo::GET_FROM_NONHEAP_RAM (read_number_kind_and_sizeize ());
po '\x75' => hbo::SET_NONHEAP_RAM (read_number_kind_and_sizeize ());
po '\x76' => hbo::RAW_CCALL (THE (read_c_call_info ()));
po '\x77' => hbo::RAW_ALLOCATE_C_RECORD { fblock => read_bool () };
po '\x78' => hbo::MIN_MACRO (read_number_kind_and_sizeize ());
po '\x79' => hbo::MAX_MACRO (read_number_kind_and_sizeize ());
po '\x7a' => hbo::ABS_MACRO (read_number_kind_and_sizeize ());
po '\x7b' => hbo::SHRINK_INTEGER (read_int ());
po '\x7c' => hbo::CHOP_INTEGER (read_int ());
po '\x7d' => hbo::STRETCH_TO_INTEGER (read_int ());
po '\x7e' => hbo::COPY_TO_INTEGER (read_int ());
po c => vector::get (baseop_table, char::to_int c)
except
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_sumtype_record_by_typestamp = get stx::find_sumtype_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 ();
typekind_sharemap = upr::make_sharemap ();
sumtype_info_sharemap = upr::make_sharemap ();
sumtype_family_sharemap = upr::make_sharemap ();
sumtype_member_sharemap = upr::make_sharemap ();
list_sumtype_member_sharemap = upr::make_sharemap ();
name_form_domain_sharemap = upr::make_sharemap ();
list_name_form_domain_sharemap = upr::make_sharemap ();
type_sharemap = upr::make_sharemap ();
type_list_sharemap = upr::make_sharemap ();
typoid_sharemap = upr::make_sharemap ();
null_or_typoid_sharemap = upr::make_sharemap ();
list_typoid_sharemap = upr::make_sharemap ();
inlining_data_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 ();
type_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_data_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__typekind__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_typoid_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_static_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::INDEX_OUT_OF_BOUNDS = raise exception FORMAT;
end;
#
fun read_sumtype' ()
=
read_sharable_value valcon_sharemap d
where
fun d 'c'
=>
{ name = read_symbol ();
is_constant = read_bool ();
(read_typoid' ()) -> (typoid, ttr);
form = read_valcon_form ();
signature = read_constructor_signature ();
is_lazy = read_bool ();
( tdt::VALCON { name,
is_constant,
typoid,
form,
signature,
is_lazy
},
ttr
);
};
d _ => raise exception FORMAT;
end;
end
also
fun read_typekind ()
=
read_sharable_value typekind_sharemap tk
where
fun tk 'a'
=>
tdt::BASE (read_int ());
tk 'b'
=>
{ index = read_int ();
root = read_null_or_typechecked_package_var ();
my (stamps, family, free_types)
=
read_sumtype_info ();
tdt::SUMTYPE
{
index,
root,
stamps,
family,
free_types
};
};
tk 'c' => tdt::ABSTRACT (read_type ());
tk 'd' => tdt::FORMAL;
tk 'e' => tdt::TEMP;
tk _ => raise exception FORMAT;
end;
end
also
fun read_sumtype_info ()
=
read_sharable_value sumtype_info_sharemap dti
where
fun dti 'a'
=>
(vector::from_list (read_list_of_stamps ()), read_sumtype_family (), read_list_type ());
dti _
=>
raise exception FORMAT;
end;
end
also
fun read_sumtype_family ()
=
read_sharable_value sumtype_family_sharemap dtf
where
fun dtf 'b'
=>
{ mkey => read_stamp (),
members => vector::from_list (read_list_sumtype_member ()),
property_list => property_list::make_property_list ()
};
dtf _ => raise exception FORMAT;
end;
end
also
fun read_sumtype_member ()
=
read_sharable_value sumtype_member_sharemap d
where
fun d 'c'
=>
{ name_symbol => read_symbol (),
valcons => read_list_name_form_domain (),
arity => read_int (),
is_eqtype => REF (read_equality_property ()),
is_lazy => read_bool (),
an_api => read_constructor_signature ()
};
d _ => raise exception FORMAT;
end;
end
also
fun read_list_sumtype_member ()
=
read_list list_sumtype_member_sharemap read_sumtype_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_type ()
=
read_sharable_value type_sharemap typeconstructor
where
fun typeconstructor 'A'
=>
tdt::SUM_TYPE
(find_sumtype_record_by_typestamp
( read_lib_mod_spec (),
read_typestamp ()
)
);
typeconstructor 'B'
=>
tdt::SUM_TYPE
{
stamp => read_stamp (),
arity => read_int (),
is_eqtype => REF (read_equality_property ()),
kind => read_typekind (),
namepath => read_inverse_path (),
stub => THE { owner => if is_lib read_picklehash ();
else get_global_picklehash ();
fi,
is_lib
}
};
typeconstructor 'C'
=>
tdt::NAMED_TYPE
{
stamp => read_stamp (),
typescheme => tdt::TYPESCHEME { arity => read_int (),
body => read_typoid ()
},
strict => read_list_of_bools (),
namepath => read_inverse_path ()
};
typeconstructor 'D'
=>
tdt::TYPE_BY_STAMPPATH
{
arity => read_int (),
stamppath => read_stamppath (),
namepath => read_inverse_path ()
};
typeconstructor 'E' => tdt::RECORD_TYPE (read_list_of_labels ());
typeconstructor 'F' => tdt::RECURSIVE_TYPE (read_int ());
typeconstructor 'G' => tdt::FREE_TYPE (read_int ());
typeconstructor 'H' => tdt::ERRONEOUS_TYPE;
typeconstructor _ => raise exception FORMAT;
end;
end
also
fun read_type' ()
=
(type, modtree)
where
type = read_type ();
modtree = case type
#
tdt::SUM_TYPE sumtype_record => mld::SUMTYPE_MODTREE_NODE sumtype_record;
_ => no_modtree;
esac;
end
also
fun read_list_type ()
=
read_list type_list_sharemap read_type ()
also
fun read_typoid' ()
=
read_sharable_value typoid_sharemap read_typoid''
where
#
fun read_typoid'' 'a' # TYPCON_TYPE
=>
{ (read_type' ()) -> (type, type_modtree);
(read_list_typoid' ()) -> (typelist, typelist_modtrees);
( tdt::TYPCON_TYPOID (type, typelist),
modtree_branch [type_modtree, typelist_modtrees]
);
};
read_typoid'' 'b' => (tdt::TYPESCHEME_ARG (read_int ()), no_modtree); # TYPESCHEME_ARG
read_typoid'' 'c' => (tdt::WILDCARD_TYPOID, no_modtree); # WILDCARE_TYPE
read_typoid'' 'd' # TYPESCHEME_TYPE
=>
{ (read_list_of_bools ()) -> eqprops;
(read_int ()) -> arity;
(read_typoid' ()) -> (body, body_modtree);
( tdt::TYPESCHEME_TYPOID
{
typescheme_eqflags => eqprops,
typescheme => tdt::TYPESCHEME { arity, body }
},
#
body_modtree
);
};
read_typoid'' 'e' => (tdt::UNDEFINED_TYPOID, no_modtree); # UNDEFINED_TYPE
read_typoid'' _ => raise exception FORMAT;
end;
end
also
fun read_typoid ()
=
#1 (read_typoid' ())
also
fun read_null_or_type ()
=
read_null_or null_or_typoid_sharemap read_typoid ()
# paired_lists is from src/lib/std/src/paired-lists.pkg also
fun read_list_typoid' ()
=
{ my (typoids, type_modtrees)
=
paired_lists::unzip # [(a,a'), (b,b'), (c,c')] -> ([a, b, c], [a', b', c'])
(read_list list_typoid_sharemap read_typoid' ());
(typoids, modtree_branch type_modtrees);
}
also
fun read_inlining_data ()
=
read_sharable_value inlining_data_sharemap ii
where
fun ii 'A' => ij::make_baseop_inlining_data (read_baseop (), read_typoid ());
ii 'B' => ij::make_inlining_data_list (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_data_sharemap read_inlining_data ()
also
fun read_var' ()
=
read_sharable_value var_sharemap read_var''
where
fun read_var'' '1' # PLAIN_VARIABLE
=>
{ varhome = read_varhome ();
inlining_data = read_inlining_data ();
path = read_symbol_path ();
(read_typoid' ()) -> (vartypoid, type_modtree);
( vac::PLAIN_VARIABLE { varhome, inlining_data, path, vartypoid_ref => REF vartypoid },
type_modtree
);
};
read_var'' '2' # OVERLOADED_VARIABLE
=>
{ (read_symbol ()) -> name;
(read_list_overloaded_identifier' ()) -> (alternatives, alternatives_modtrees);
(read_int ()) -> arity;
(read_typoid' ()) -> (body, body_modtree);
( vac::OVERLOADED_VARIABLE
{ name,
alternatives => REF alternatives,
typescheme => tdt::TYPESCHEME { arity, body }
},
modtree_branch [alternatives_modtrees, body_modtree]
);
};
read_var'' '3' => (vac::ERROR_VARIABLE, 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_typoid' ()) -> (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 (\\ (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__typekind__sharemap
#
(read_stamppath, read_typoid_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_type' ()) -> (type, type_modtree);
#
( mld::TYPE_IN_API { type,
module_stamp => read_module_stamp (),
is_a_replica => read_bool (),
scope => read_int ()
},
type_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_typoid' ()) -> (typoid, type_modtree);
#
( mld::VALUE_IN_API { typoid, slot => read_int () },
type_modtree
);
};
read_spec'' '5'
=>
{ (read_sumtype' ()) -> (sumtype, sumtype_modtree);
#
( mld::VALCON_IN_API { sumtype,
slot => read_null_or_int ()
},
sumtype_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::TYPE_ENTRY (read_typechecked_type' ());
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_type_expression' ()
=
read_sharable_value type_expression_sharemap tce
where
fun tce 'd' => &&& mld::CONSTANT_TYPE (read_type' ());
tce 'e' => (mld::FORMAL_TYPE (read_type ()), no_modtree); # ?
tce 'f' => (mld::TYPEVAR_TYPE (read_stamppath ()), no_modtree);
tce _ => raise exception FORMAT;
end;
end
also
fun read_type_expression () = #1 (read_type_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::TYPE_EXPRESSION (read_type_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_type_expression' ()) -> (type_expression, expression_modtree);
#
( mld::TYPE_DECLARATION (stamp, type_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 (\\ (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,
typepath => 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_type' () = read_type' ();
#
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_sumtype' ());
read_symbolmapstack_entry'' '3' => &&& sxe::NAMED_TYPE (read_type' ());
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 => \\ () = 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_typoid_kind,
read_list_of_typekinds,
read_null_or_int
};
lambda_typoid_sharemap = upr::make_sharemap ();
lambda_typoid_list_sharemap = upr::make_sharemap ();
type_sharemap = upr::make_sharemap ();
type_list_sharemap = upr::make_sharemap ();
value_sharemap = upr::make_sharemap ();
con_sharemap = upr::make_sharemap ();
valcon_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_typoid_sharemap read_lambdatype''
where
fun read_lambdatype'' 'A' => hct::make_type_uniqtypoid (read_type ());
read_lambdatype'' 'B' => hct::make_package_uniqtypoid (read_list_of_lambdatypes ());
read_lambdatype'' 'C' => hct::make_generic_package_uniqtypoid (read_list_of_lambdatypes (), read_list_of_lambdatypes ());
read_lambdatype'' 'D' => hct::make_typeagnostic_uniqtypoid (read_list_of_typekinds (), read_list_of_lambdatypes ());
#
read_lambdatype'' _ => raise exception FORMAT;
end;
end
also
fun read_list_of_lambdatypes ()
=
read_list lambda_typoid_list_sharemap read_lambdatype ()
also
fun read_type ()
=
read_sharable_value type_sharemap read_type''
where
fun read_type'' 'A' => hct::make_debruijn_typevar_uniqtype (di::di_fromint (read_int ()), read_int ());
read_type'' 'B' => hct::make_named_typevar_uniqtype (read_int ());
read_type'' 'C' => hct::make_basetype_uniqtype (hbt::basetype_from_int (read_int ()));
read_type'' 'D' => hct::make_typefun_uniqtype (read_list_of_typekinds (), read_type ());
read_type'' 'E' => hct::make_apply_typefun_uniqtype (read_type (), read_list_of_types ());
read_type'' 'F' => hct::make_typeseq_uniqtype (read_list_of_types ());
read_type'' 'G' => hct::make_ith_in_typeseq_uniqtype (read_type (), read_int ());
read_type'' 'H' => hct::make_sum_uniqtype (read_list_of_types ());
read_type'' 'I' => hct::make_recursive_uniqtype ((read_int (), read_type (), read_list_of_types ()), read_int ());
read_type'' 'J' => hct::make_abstract_uniqtype (read_type ());
read_type'' 'K' => hct::make_boxed_uniqtype (read_type ());
read_type'' 'L' => hct::make_tuple_uniqtype (read_list_of_types ());
read_type'' 'M' => hct::make_arrow_uniqtype (hct::make_variable_calling_convention { arg_is_raw => read_bool (), body_is_raw => read_bool () }, read_list_of_types (), read_list_of_types ());
read_type'' 'N' => hct::make_arrow_uniqtype (hct::fixed_calling_convention, read_list_of_types (), read_list_of_types ());
read_type'' 'O' => hut::type_to_uniqtype (hut::type::EXTENSIBLE_TOKEN (hut::token_key (read_int ()), read_type ()));
#
read_type'' _ => raise exception FORMAT;
end;
end
also
fun read_list_of_types () = read_list type_list_sharemap read_type ();
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'
=>
{ (valcon ()) -> (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 valcon ()
=
read_sharable_value valcon_sharemap d
where
fun d 'x' => ((read_symbol (), read_valcon_form (), read_lambdatype ()), read_list_of_types ());
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_types, 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_types ()
);
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_types ());
e 'p' => acf::SWITCH (read_value (), read_constructor_signature (), conlist (), lexpoption ());
e 'q' => { (valcon ()) -> (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_typoid_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_type ());
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 => \\ () = 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
=
\\ c = cos::do_compiler_phase
(cos::make_compiler_phase "Compiler 087 unpickle_symbolmapstack")
(unpickle_symbolmapstack c);
};
end;