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

git-svn-id: https://svn.cs.ru.nl/repos/clean-compiler/trunk@1317 1f8540f1-abd5-4d5b-9d24-4c5ce8603e2d

6 files changed, 62 insertions, 35 deletions

diff --git a/frontend/check.icl b/frontend/check.icl
index 791d665..f3ee37a 100644
--- a/frontend/check.icl
+++ b/frontend/check.icl
@@ -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
diff --git a/frontend/checksupport.dcl b/frontend/checksupport.dcl
index cefb3ee..e473b13 100644
--- a/frontend/checksupport.dcl
+++ b/frontend/checksupport.dcl
@@ -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}
 
diff --git a/frontend/checksupport.icl b/frontend/checksupport.icl
index 7bded09..2c162c7 100644
--- a/frontend/checksupport.icl
+++ b/frontend/checksupport.icl
@@ -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 }}
 
diff --git a/frontend/checktypes.icl b/frontend/checktypes.icl
index 27a1d77..7bc7072 100644
--- a/frontend/checktypes.icl
+++ b/frontend/checktypes.icl
@@ -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
diff --git a/frontend/main.icl b/frontend/main.icl
index c91fd91..9b91d14 100644
--- a/frontend/main.icl
+++ b/frontend/main.icl
@@ -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 
diff --git a/frontend/overloading.icl b/frontend/overloading.icl
index 0766b05..adf866b 100644
--- a/frontend/overloading.icl
+++ b/frontend/overloading.icl
@@ -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