Commit fbcde588 authored by Martijn Vervoort's avatar Martijn Vervoort
Browse files

- bug fix: error for abstract datatypes in dynamic types.

parent c3bf38cd
......@@ -2291,7 +2291,7 @@ check_module1 {mod_type,mod_name,mod_imports,mod_imported_objects,mod_defs = cde
main_dcl_module_n = if (dcl_module_n_in_cache<>NoIndex) dcl_module_n_in_cache nr_of_cached_modules
cs = { cs_symbol_table = symbol_table, cs_predef_symbols = predef_symbols, cs_error = error, cs_x= {x_needed_modules=0,x_main_dcl_module_n=main_dcl_module_n}}
cs = { cs_symbol_table = symbol_table, cs_predef_symbols = predef_symbols, cs_error = error, cs_x= {x_needed_modules=0,x_main_dcl_module_n=main_dcl_module_n, x_check_dynamic_types = False}}
(scanned_modules,macro_defs,cs) = add_dcl_module_predef_module_and_modules_to_symbol_table optional_dcl_mod optional_pre_def_mod scanned_modules nr_of_cached_modules cs
macro_defs = make_macro_def_array cached_dcl_macros macro_defs
......
......@@ -29,7 +29,7 @@ cNeedStdStrictLists :== 16
:: CheckState = { cs_symbol_table :: !.SymbolTable, cs_predef_symbols :: !.PredefinedSymbols, cs_error :: !.ErrorAdmin,cs_x :: !CheckStateX }
:: CheckStateX = {x_needed_modules :: !BITVECT,x_main_dcl_module_n :: !Int }
:: CheckStateX = {x_needed_modules :: !BITVECT,x_main_dcl_module_n :: !Int, x_check_dynamic_types :: !Bool }
// SymbolTable :== {# SymbolTableEntry}
......
......@@ -33,7 +33,7 @@ cNeedStdStrictLists :== 16
:: CheckState = { cs_symbol_table :: !.SymbolTable, cs_predef_symbols :: !.PredefinedSymbols, cs_error :: !.ErrorAdmin, cs_x :: !CheckStateX }
:: CheckStateX = {x_needed_modules :: !BITVECT,x_main_dcl_module_n :: !Int}
:: CheckStateX = {x_needed_modules :: !BITVECT,x_main_dcl_module_n :: !Int, x_check_dynamic_types :: !Bool }
:: ConversionTable :== {# .{# Int }}
......
......@@ -432,6 +432,10 @@ checkArityOfType act_arity form_arity (SynType _)
checkArityOfType act_arity form_arity _
= form_arity >= act_arity
checkAbstractType (AbstractType _) = True
checkAbstractType (AbstractSynType _ _) = True
checkAbstractType _ = False
getClassDef :: !Index !Index !Index !u:{# ClassDef} !v:{# DclModule} -> (!ClassDef, !Index , !u:{# ClassDef}, !v:{# DclModule})
getClassDef class_index type_module module_index class_defs modules
| type_module == module_index
......@@ -573,19 +577,22 @@ where
= (var, global_vars, var_heap, { entry & ste_previous = ste_previous })
//
checkOpenAType mod_index scope dem_attr_kind type=:{ at_type=TA type_cons=:{type_name=type_name=:{id_name,id_info}} types, at_attribute}
(ots=:{ots_type_defs,ots_modules}, oti, cs=:{cs_symbol_table})
(ots=:{ots_type_defs,ots_modules}, oti, cs=:{cs_symbol_table,cs_x={x_check_dynamic_types}})
# (entry, cs_symbol_table) = readPtr id_info cs_symbol_table
cs = { cs & cs_symbol_table = cs_symbol_table }
(type_index, type_module) = retrieveGlobalDefinition entry STE_Type mod_index
| type_index <> NotFound
# ({td_arity,td_args,td_attribute,td_rhs},type_index,ots_type_defs,ots_modules) = getTypeDef type_index type_module mod_index ots_type_defs ots_modules
ots = { ots & ots_type_defs = ots_type_defs, ots_modules = ots_modules }
| checkArityOfType type_cons.type_arity td_arity td_rhs
# type_cons = { type_cons & type_index = { glob_object = type_index, glob_module = type_module }}
(types, (ots, oti, cs)) = check_args_of_type_cons mod_index scope dem_attr_kind types td_args (ots, oti, cs)
(new_attr, oti, cs) = newAttribute (new_demanded_attribute dem_attr_kind td_attribute) id_name at_attribute oti cs
= ({ type & at_type = TA type_cons types, at_attribute = new_attr } , (ots, oti, cs))
= (type, (ots, oti, {cs & cs_error = checkError type_name "used with wrong arity" cs.cs_error}))
| x_check_dynamic_types && checkAbstractType td_rhs
= (type, (ots, oti, {cs & cs_error = checkError type_name "(abstract type) not permitted in a dynamic type" cs.cs_error}))
| checkArityOfType type_cons.type_arity td_arity td_rhs
# type_cons = { type_cons & type_index = { glob_object = type_index, glob_module = type_module }}
(types, (ots, oti, cs)) = check_args_of_type_cons mod_index scope dem_attr_kind types td_args (ots, oti, cs)
(new_attr, oti, cs) = newAttribute (new_demanded_attribute dem_attr_kind td_attribute) id_name at_attribute oti cs
= ({ type & at_type = TA type_cons types, at_attribute = new_attr } , (ots, oti, cs))
= (type, (ots, oti, {cs & cs_error = checkError type_name "used with wrong arity" cs.cs_error}))
= (type, (ots, oti, {cs & cs_error = checkError type_name "undefined" cs.cs_error}))
checkOpenAType mod_index scope dem_attr type=:{ at_type=TAS type_cons=:{type_name=type_name=:{id_name,id_info}} types strictness, at_attribute}
(ots=:{ots_type_defs,ots_modules}, oti, cs=:{cs_symbol_table})
......@@ -1029,7 +1036,8 @@ where
ots = { ots_type_defs = type_defs, ots_modules = modules }
oti = { oti_heaps = { type_heaps & th_vars = th_vars }, oti_all_vars = [], oti_all_attrs = [], oti_global_vars = [] }
(dt_type, ( {ots_type_defs, ots_modules}, {oti_heaps,oti_all_vars,oti_all_attrs, oti_global_vars}, cs))
= checkOpenAType mod_index scope DAK_Ignore dt_type (ots, oti, cs)
= checkOpenAType mod_index scope DAK_Ignore dt_type (ots, oti, { cs & cs_x = {cs.cs_x & x_check_dynamic_types = True} })
# cs = { cs & cs_x = {cs.cs_x & x_check_dynamic_types = False} }
th_vars = foldSt (\{tv_info_ptr} -> writePtr tv_info_ptr TVI_Empty) oti_global_vars oti_heaps.th_vars
cs_symbol_table = removeAttributedTypeVarsFromSymbolTable scope dt_uni_vars cs.cs_symbol_table
| isEmpty oti_all_attrs
......
......@@ -11,7 +11,7 @@ import frontend
from type_io import openTclFile, closeTclFile
// ... MV
write_tcl_file yes no :== no;
write_tcl_file yes no :== yes;
Start world
# (std_io, world) = stdio world
......@@ -27,14 +27,16 @@ Start world
= fclose ms_out world
CommandLoop symbol_heap ms=:{ms_io}
# (answer, ms_io) = freadline (ms_io <<< "> ")
// # (answer, ms_io) = freadline (ms_io <<< "> ")
# (answer, ms_io) = ("c abstract",ms_io)
(command, argument) = SplitAtLayoutChar (dropWhile isSpace (fromString answer))
| command == []
= CommandLoop symbol_heap { ms & ms_io = ms_io}
# (ready, symbol_heap, ms) = DoCommand command argument symbol_heap { ms & ms_io = ms_io}
| ready
= ms
= CommandLoop symbol_heap ms
= ms
// = CommandLoop symbol_heap ms
:: MainStateDefs funs funtypes types conses classes instances members selectors =
{ msd_funs :: !funs
......@@ -101,7 +103,7 @@ addModule _ mod NoModules
empty_cache :: *SymbolTable -> *DclCache
empty_cache symbol_heap
# heaps = {hp_var_heap = newHeap, hp_expression_heap = newHeap, hp_type_heaps = {th_vars = newHeap, th_attrs = newHeap}}
# heaps = {hp_var_heap = newHeap, hp_expression_heap = newHeap, hp_type_heaps = {th_vars = newHeap, th_attrs = newHeap}, hp_generic_heap = newHeap}
# (predef_symbols, hash_table) = buildPredefinedSymbols (newHashTable symbol_heap)
= {dcl_modules={},cached_macros={},predef_symbols=predef_symbols,hash_table=hash_table,heaps=heaps}
......@@ -183,7 +185,7 @@ loadModule mod_ident {dcl_modules,cached_macros,predef_symbols,hash_table,heaps}
= write_tcl_file (WrapopenTclFile ms) (No,ms);
// ... MV
# (optional_syntax_tree,cached_cached_macros,cached_dcl_mods,_,main_dcl_module_n,predef_symbols, hash_table, ms_files, ms_error, ms_io, ms_out,tcl_file,heaps)
= frontEndInterface { feo_up_to_phase = FrontEndPhaseAll, feo_generics = False, feo_fusion = False} mod_ident {sp_locations = [], sp_paths = ms_paths} dcl_modules cached_macros No predef_symbols hash_table dummyModTime ms_files ms_error ms_io ms_out tcl_file heaps
= frontEndInterface { feo_dump_core = False, feo_strip_unused = False,feo_up_to_phase = FrontEndPhaseAll, feo_generics = False, feo_fusion = False} mod_ident {sp_locations = [], sp_paths = ms_paths} dcl_modules cached_macros No predef_symbols hash_table dummyModTime ms_files ms_error ms_io ms_out tcl_file heaps
// MV ...
# (_,ms_files)
= closeTclFile tcl_file ms_files
......
......@@ -119,7 +119,11 @@ overloadingError op_symb err
Yes (str, line_nr)
-> str+++" [line "+++toString line_nr+++"]"
= { err & ea_file = err.ea_file <<< " internal overloading of \"" <<< str <<< "\" could not be solved\n" }
abstractTypeInDynamicError td_name err=:{ea_ok}
# err = errorHeading "Implementation restriction" err
= { err & ea_file = err.ea_file <<< (" derived abstract type '" +++ toString td_name +++ "' not permitted in a dynamic") <<< '\n' }
typeCodeInDynamicError err=:{ea_ok}
# err = errorHeading "Overloading error (warning for now)" err
err = {err & ea_ok=ea_ok}
......@@ -177,8 +181,8 @@ where
reduce_any_context tc=:{tc_class=class_symb=:(TCClass {glob_object={ds_index},glob_module}),tc_types} defs instance_info new_contexts
special_instances type_pattern_vars (var_heap, type_heaps) coercion_env predef_symbols error
| is_predefined_symbol glob_module ds_index PD_TypeCodeClass predef_symbols
# (red_context, (new_contexts, special_instances, type_pattern_vars, var_heap, type_heaps))
= reduce_TC_context class_symb (hd tc_types) new_contexts special_instances type_pattern_vars var_heap type_heaps
# (red_context, (new_contexts, special_instances, type_pattern_vars, var_heap, type_heaps,error))
= reduce_TC_context class_symb (hd tc_types) new_contexts special_instances type_pattern_vars var_heap type_heaps error
= (red_context, new_contexts, special_instances, type_pattern_vars, (var_heap, type_heaps), coercion_env, predef_symbols, error)
# (class_appls, new_contexts, special_instances, type_pattern_vars, heaps, coercion_env, predef_symbols, error)
= reduce_context tc defs instance_info new_contexts special_instances type_pattern_vars
......@@ -535,48 +539,61 @@ where
= { ai_members = { { class_member & ds_index = next_inst_index } \\ class_member <-: members & next_inst_index <- [next_member_index .. ]},
ai_record = record }
disallow_abstract_types_in_dynamics type_index=:{glob_module,glob_object} error
#! ({td_name,td_rhs})
= defs.[glob_module].com_type_defs.[glob_object]
= case td_rhs of
AbstractType _ -> abstractTypeInDynamicError td_name error
AbstractSynType _ _ -> abstractTypeInDynamicError td_name error
_ -> error
reduce_TC_context type_code_class tc_type new_contexts special_instances type_pattern_vars var_heap type_heaps
= reduce_tc_context type_code_class tc_type (new_contexts, special_instances, type_pattern_vars, var_heap, type_heaps)
reduce_TC_context type_code_class tc_type new_contexts special_instances type_pattern_vars var_heap type_heaps error
= reduce_tc_context type_code_class tc_type (new_contexts, special_instances, type_pattern_vars, var_heap, type_heaps, error)
where
reduce_tc_context type_code_class type=:(TA cons_id=:{type_index} cons_args) (new_contexts, special_instances=:{si_next_TC_member_index, si_TC_instances}, type_pattern_vars, var_heap, type_heaps)
reduce_tc_context type_code_class type=:(TA cons_id=:{type_index} cons_args) (new_contexts, special_instances=:{si_next_TC_member_index, si_TC_instances}, type_pattern_vars, var_heap, type_heaps, error)
# error
= disallow_abstract_types_in_dynamics type_index error
# (expanded, type, type_heaps)
= tryToExpandTypeSyn defs type cons_id cons_args type_heaps
| expanded
= reduce_tc_context type_code_class type (new_contexts, special_instances, type_pattern_vars, var_heap, type_heaps)
= reduce_tc_context type_code_class type (new_contexts, special_instances, type_pattern_vars, var_heap, type_heaps, error)
# type_constructor = toTypeCodeConstructor type_index defs
# (inst_index, (si_next_TC_member_index, si_TC_instances))
= addGlobalTCInstance type_constructor (si_next_TC_member_index, si_TC_instances)
(rc_red_contexts, instances) = reduce_TC_contexts type_code_class cons_args
(new_contexts, { special_instances & si_next_TC_member_index = si_next_TC_member_index, si_TC_instances = si_TC_instances }, type_pattern_vars, var_heap, type_heaps)
(new_contexts, { special_instances & si_next_TC_member_index = si_next_TC_member_index, si_TC_instances = si_TC_instances }, type_pattern_vars, var_heap, type_heaps, error)
= (CA_GlobalTypeCode { tci_index = inst_index, tci_constructor = type_constructor, tci_contexts = rc_red_contexts }, instances)
reduce_tc_context type_code_class (TAS cons_id=:{type_index} cons_args _) (new_contexts, special_instances=:{si_next_TC_member_index, si_TC_instances}, type_pattern_vars, var_heap, type_heaps)
reduce_tc_context type_code_class (TAS cons_id=:{type_index} cons_args _) (new_contexts, special_instances=:{si_next_TC_member_index, si_TC_instances}, type_pattern_vars, var_heap, type_heaps, error)
# error
= disallow_abstract_types_in_dynamics type_index error
# type_constructor = toTypeCodeConstructor type_index defs
# (inst_index, (si_next_TC_member_index, si_TC_instances))
= addGlobalTCInstance type_constructor (si_next_TC_member_index, si_TC_instances)
(rc_red_contexts, instances) = reduce_TC_contexts type_code_class cons_args
(new_contexts, { special_instances & si_next_TC_member_index = si_next_TC_member_index, si_TC_instances = si_TC_instances }, type_pattern_vars, var_heap, type_heaps)
(new_contexts, { special_instances & si_next_TC_member_index = si_next_TC_member_index, si_TC_instances = si_TC_instances }, type_pattern_vars, var_heap, type_heaps, error)
= (CA_GlobalTypeCode { tci_index = inst_index, tci_constructor = type_constructor, tci_contexts = rc_red_contexts }, instances)
reduce_tc_context type_code_class (TB basic_type) (new_contexts, special_instances=:{si_next_TC_member_index, si_TC_instances}, type_pattern_vars, var_heap, type_heaps)
reduce_tc_context type_code_class (TB basic_type) (new_contexts, special_instances=:{si_next_TC_member_index, si_TC_instances}, type_pattern_vars, var_heap, type_heaps, error)
# (inst_index, (si_next_TC_member_index, si_TC_instances))
= addGlobalTCInstance (GTT_Basic basic_type) (si_next_TC_member_index, si_TC_instances)
= (CA_GlobalTypeCode { tci_index = inst_index, tci_constructor = GTT_Basic basic_type, tci_contexts = [] },
(new_contexts, { special_instances & si_next_TC_member_index = si_next_TC_member_index, si_TC_instances = si_TC_instances }, type_pattern_vars, var_heap, type_heaps))
reduce_tc_context type_code_class (arg_type --> result_type) (new_contexts, special_instances=:{si_next_TC_member_index, si_TC_instances}, type_pattern_vars, var_heap, type_heaps)
(new_contexts, { special_instances & si_next_TC_member_index = si_next_TC_member_index, si_TC_instances = si_TC_instances }, type_pattern_vars, var_heap, type_heaps, error))
reduce_tc_context type_code_class (arg_type --> result_type) (new_contexts, special_instances=:{si_next_TC_member_index, si_TC_instances}, type_pattern_vars, var_heap, type_heaps, error)
# (inst_index, (si_next_TC_member_index, si_TC_instances))
= addGlobalTCInstance GTT_Function (si_next_TC_member_index, si_TC_instances)
(rc_red_contexts, instances) = reduce_TC_contexts type_code_class [arg_type, result_type]
(new_contexts, { special_instances & si_next_TC_member_index = si_next_TC_member_index, si_TC_instances = si_TC_instances }, type_pattern_vars, var_heap, type_heaps)
(new_contexts, { special_instances & si_next_TC_member_index = si_next_TC_member_index, si_TC_instances = si_TC_instances }, type_pattern_vars, var_heap, type_heaps, error)
= (CA_GlobalTypeCode { tci_index = inst_index, tci_constructor = GTT_Function, tci_contexts = rc_red_contexts }, instances)
reduce_tc_context type_code_class (TempQV var_number) (new_contexts, special_instances, type_pattern_vars, var_heap, type_heaps)
reduce_tc_context type_code_class (TempQV var_number) (new_contexts, special_instances, type_pattern_vars, var_heap, type_heaps, error)
# (inst_var, (type_pattern_vars, var_heap)) = addLocalTCInstance var_number (type_pattern_vars, var_heap)
= (CA_LocalTypeCode inst_var, (new_contexts, special_instances, type_pattern_vars, var_heap, type_heaps))
reduce_tc_context type_code_class (TempV var_number) (new_contexts, special_instances, type_pattern_vars, var_heap, type_heaps)
= (CA_LocalTypeCode inst_var, (new_contexts, special_instances, type_pattern_vars, var_heap, type_heaps, error))
reduce_tc_context type_code_class (TempV var_number) (new_contexts, special_instances, type_pattern_vars, var_heap, type_heaps, error)
# (tc_var, var_heap) = newPtr VI_Empty var_heap
tc = { tc_class = type_code_class, tc_types = [TempV var_number], tc_var = tc_var }
| containsContext tc new_contexts
= (CA_Context tc, (new_contexts, special_instances, type_pattern_vars, var_heap, type_heaps))
= (CA_Context tc, ([tc : new_contexts], special_instances, type_pattern_vars, var_heap, type_heaps))
= (CA_Context tc, (new_contexts, special_instances, type_pattern_vars, var_heap, type_heaps, error))
= (CA_Context tc, ([tc : new_contexts], special_instances, type_pattern_vars, var_heap, type_heaps, error))
reduce_TC_contexts type_code_class cons_args instances
= mapSt (\{at_type} -> reduce_tc_context type_code_class at_type) cons_args instances
......
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment