Bug fix with array updates. Removed redundant code. Adjusted unification algorithm.

frontend/check.icl

@@ -1635,6 +1635,7 @@ remove_function_conversion_table main_dcl_module_n dcl_modules
 			# dcl_modules = {dcl_modules & [main_dcl_module_n].dcl_conversions=Yes conversion_table}
 			-> (function_conversions,dcl_modules)
 
+// add_function_conversion_table :: {#Int} Int *(a DclModule) -> *(a DclModule) | Array a DclModule
 add_function_conversion_table dcl_to_icl_function_conversions main_dcl_module_n dcl_modules
 	# (dcl_mod,dcl_modules) = dcl_modules![main_dcl_module_n]
 	= case dcl_mod.dcl_conversions of

frontend/checktypes.icl

@@ -867,7 +867,8 @@ where
 	check_context_types tc_class [] cs=:{cs_error}
 		= { cs & cs_error = checkError tc_class "type context should contain one or more type variables" cs_error}
 	check_context_types tc_class [((CV {tv_name}) :@: _):_] cs=:{cs_error}
-		= { cs & cs_error = checkError tv_name "not allowed as higher order type variable in context" cs_error}
+		= cs
+//		= { cs & cs_error = checkError tv_name "not allowed as higher order type variable in context" cs_error}
 	check_context_types tc_class [TV _ : types] cs
 		= cs
 	check_context_types tc_class [type : types] cs
@@ -1141,11 +1142,11 @@ where
 addExistentionalTypeVariablesToSymbolTable :: !TypeAttribute ![ATypeVar] !*TypeHeaps !*CheckState
 	-> (![ATypeVar], !(!*TypeHeaps, !*CheckState))
 addExistentionalTypeVariablesToSymbolTable root_attr type_vars heaps cs
-	= mapSt (add_type_variable_to_symbol_table root_attr) type_vars (heaps, cs)
+	= mapSt (add_exi_variable_to_symbol_table root_attr) type_vars (heaps, cs)
 where
-	add_type_variable_to_symbol_table :: !TypeAttribute !ATypeVar !(!*TypeHeaps, !*CheckState)
+	add_exi_variable_to_symbol_table :: !TypeAttribute !ATypeVar !(!*TypeHeaps, !*CheckState)
 		-> (!ATypeVar, !(!*TypeHeaps, !*CheckState))
-	add_type_variable_to_symbol_table root_attr atv=:{atv_variable=atv_variable=:{tv_name}, atv_attribute}
+	add_exi_variable_to_symbol_table root_attr atv=:{atv_variable=atv_variable=:{tv_name}, atv_attribute}
 		(heaps=:{th_vars,th_attrs}, cs=:{ cs_symbol_table, cs_error /* TD ... */, cs_x={x_type_var_position} /* ... TD */})
 		# tv_info = tv_name.id_info
 		  (entry, cs_symbol_table) = readPtr tv_info cs_symbol_table

frontend/generics.icl

@@ -903,7 +903,7 @@ where
 		= ([fi:fis], [fd:fds], gs) 
 
 	build_cons_info {ds_index,ds_arity} cons_num type_info_def_sym group_index common_defs gs
-		# {cons_symb, cons_arity, cons_pos} = common_defs.com_cons_defs.[ds_index]		
+		# {cons_symb, cons_pos} = common_defs.com_cons_defs.[ds_index]		
 		# (fun_index, gs) = newFunIndex gs		
 		# def_sym = 
 			{	ds_ident = makeIdent ("cons_info_" +++ cons_symb.id_name)
@@ -3154,7 +3154,7 @@ copyExpr expr heaps=:{hp_var_heap, hp_expression_heap}
 	= (expr, {heaps & hp_var_heap = us_var_heap, hp_expression_heap = us_symbol_heap})
 		//---> ("copy Expr")
 
-mapExprSt :: (Expression .st->(Expression, .st)) Expression .st -> (Expression, .st)
+//mapExprSt :: (Expression .st->(Expression, .st)) Expression .st -> (Expression, .st)
 mapExprSt f (App app=:{app_args}) st
 		# (app_args, st) = mapSt (mapExprSt f) app_args st
 		= f (App { app & app_args = app_args }) st

frontend/overloading.icl

@@ -506,9 +506,13 @@ where
 	match defs (TA cons_id1 cons_args1) (TA cons_id2 cons_args2) type_heaps
 		| cons_id1 == cons_id2
 			= match defs cons_args1 cons_args2 type_heaps
-//			# (succ1, type1, type_heaps) = tryToExpandTypeSyn defs cons_id1 cons_args1 type_heaps
+			# (succ1, type1, type_heaps) = tryToExpandTypeSyn defs cons_id1 cons_args1 type_heaps
 			# (succ2, type2, type_heaps) = tryToExpandTypeSyn defs cons_id2 cons_args2 type_heaps
+			| succ1 || succ2
+				= match defs type1 type2 type_heaps
+/*
 			| succ2
+			
 				= case type2 of
 					TA cons_id2 cons_args2
 						| cons_id1 == cons_id2
@@ -516,6 +520,8 @@ where
 							-> (False, type_heaps)
 					_
 							-> (False, type_heaps)
+
+*/
 				= (False, type_heaps)
 	match defs (arg_type1 --> res_type1) (arg_type2 --> res_type2) type_heaps
 		= match defs (arg_type1,res_type1) (arg_type2,res_type2) type_heaps
@@ -928,6 +934,7 @@ where
 		  {fun_body = TransformedBody {tb_args,tb_rhs},fun_info,fun_arity,fun_symb,fun_pos} = fun_def
 	
 		  (rev_variables, var_heap) = foldSt determine_class_argument st_context ([], var_heap)
+//		  										---> ("determine_class_argument", st_context)
 		  error = setErrorAdmin (newPosition fun_symb fun_pos) error
 		  (type_code_info, symbol_heap, type_pattern_vars, var_heap, error)
 		  		= convertDynamicTypes fun_info.fi_dynamics (type_code_info, symbol_heap, type_pattern_vars, var_heap, error) /* MV */ rev_variables

frontend/refmark.icl

@@ -74,7 +74,7 @@ where
 
 refMarkOfVariable free_vars sel (VI_Occurrence var_occ) var_name var_info_ptr var_expr_ptr var_heap
 	# occ_ref_count = adjustRefCount sel var_occ.occ_ref_count var_expr_ptr
-	= case var_occ.occ_bind of // ---> (var_name,var_expr_ptr,occ_ref_count,var_occ.occ_ref_count) of
+	= case var_occ.occ_bind of // ---> ("refMarkOfVariable", var_name,occ_ref_count,var_occ.occ_ref_count) of
 		OB_OpenLet let_expr
 			# var_heap = var_heap <:= (var_info_ptr, VI_Occurrence { var_occ & occ_ref_count = occ_ref_count, occ_bind = OB_LockedLet let_expr })
 			-> refMark free_vars sel let_expr var_heap
@@ -100,7 +100,6 @@ where
 		= refMark free_vars NotASelector args (refMark free_vars NotASelector fun var_heap)
 	refMark free_vars sel (Let {let_strict_binds,let_lazy_binds,let_expr}) var_heap
 		| isEmpty let_lazy_binds
-// MW0			# new_free_vars = [ [ bind_dst \\ {bind_dst} <- let_strict_binds ] : free_vars]
 			# new_free_vars = [ [ lb_dst \\ {lb_dst} <- let_strict_binds ] : free_vars]
 			# (observing, var_heap) = binds_are_observing let_strict_binds var_heap
 			| observing
@@ -110,7 +109,6 @@ where
 				  var_heap = refMark new_free_vars sel let_expr var_heap
 				= let_combine free_vars var_heap
 				= refMark new_free_vars sel let_expr (refMark new_free_vars NotASelector let_strict_binds var_heap)
-// MW0			# new_free_vars = [ [ bind_dst \\ {bind_dst} <- let_strict_binds ++ let_lazy_binds ] : free_vars]
 			# new_free_vars = [ [ lb_dst \\ {lb_dst} <- let_strict_binds ++ let_lazy_binds ] : free_vars]
 			  var_heap = foldSt bind_variable let_strict_binds var_heap
 			  var_heap = foldSt bind_variable let_lazy_binds var_heap
@@ -120,7 +118,6 @@ where
 		    binds_are_observing binds var_heap
 		    	= foldr bind_is_observing (True, var_heap) binds
 			where
-// MW0				bind_is_observing {bind_dst={fv_info_ptr}} (observe, var_heap) 
 				bind_is_observing {lb_dst={fv_info_ptr}} (observe, var_heap) 
 					# (VI_Occurrence {occ_observing}, var_heap) = readPtr fv_info_ptr var_heap
 					= (occ_observing && observe, var_heap)
@@ -134,11 +131,8 @@ where
 					  comb_ref_count = parCombineRefCount (seqCombineRefCount occ_ref_count prev_ref_count) pre_pref_recount
 					= var_heap <:= (fv_info_ptr, VI_Occurrence { old_occ & occ_ref_count = comb_ref_count, occ_previous = occ_previouses })
 
-// MW0			bind_variable {bind_src,bind_dst={fv_info_ptr}} var_heap
 			bind_variable {lb_src,lb_dst={fv_info_ptr}} var_heap
 				# (VI_Occurrence occ, var_heap) = readPtr fv_info_ptr var_heap
-//				= var_heap <:= (fv_info_ptr, VI_Occurrence { occ & occ_bind = OB_OpenLet bind_src })
-// MW0				= var_heap <:= (fv_info_ptr, VI_Occurrence { occ & occ_ref_count = RC_Unused, occ_bind = OB_OpenLet bind_src })
 				= var_heap <:= (fv_info_ptr, VI_Occurrence { occ & occ_ref_count = RC_Unused, occ_bind = OB_OpenLet lb_src })
 
 	refMark free_vars sel (Case {case_expr,case_guards,case_default}) var_heap
@@ -151,7 +145,9 @@ where
 		field_number _
 			= NotASelector	
 	refMark free_vars sel (Update expr1 selectors expr2) var_heap
-		= refMark free_vars NotASelector expr2 (refMark free_vars NotASelector expr1 var_heap)
+		# var_heap = refMark free_vars NotASelector expr1 var_heap
+		  var_heap = refMark free_vars NotASelector selectors var_heap
+		= refMark free_vars NotASelector expr2 var_heap
 	refMark free_vars sel (RecordUpdate cons_symbol expression expressions) var_heap
 		= ref_mark_of_record_expression free_vars expression expressions var_heap
 	where
@@ -203,6 +199,8 @@ instance refMark Selection
 where
 	refMark free_vars _ (ArraySelection _ _ index_expr) var_heap
 		= refMark free_vars NotASelector index_expr var_heap
+	refMark free_vars _ _ var_heap
+		= var_heap
 
 collectUsedFreeVariables free_vars var_heap
 	= foldSt collectUsedVariables free_vars ([], var_heap)
@@ -497,7 +495,6 @@ where
 	# variables = tb_args ++ fi_local_vars
 	  (subst, type_def_infos, var_heap, expr_heap) = clear_occurrences variables subst type_def_infos var_heap expr_heap
 	  var_heap = refMark [tb_args] NotASelector tb_rhs var_heap // (tb_rhs ---> ("makeSharedReferencesNonUnique", fun_symb, tb_rhs)) var_heap
-	//tb_rhs var_heap //   
 	  position = newPosition fun_symb fun_pos
 	  (coercion_env, var_heap, expr_heap, error) = make_shared_vars_non_unique variables coercion_env var_heap expr_heap
 	  		(setErrorAdmin position error)
@@ -517,6 +514,7 @@ where
 								-> (subst, type_def_infos, var_heap <:= (fv_info_ptr,
 										VI_Occurrence { occ_ref_count = RC_Unused, occ_previous = [],
 											occ_observing = is_oberving, occ_bind = OB_Empty }), expr_heap)
+//											 	---> ("initial_occurrence",fv_name, fv_info_ptr, is_oberving)
 							_
 								-> (subst, type_def_infos, var_heap <:= (fv_info_ptr,
 										VI_Occurrence { occ_ref_count = RC_Unused, occ_previous = [],
@@ -549,7 +547,7 @@ where
 					EI_Attribute sa_attr_nr
 						# (succ, coercion_env) = tryToMakeNonUnique sa_attr_nr coercion_env
 						| succ
-//								 ---> ("make_shared_occurrence_non_unique", free_var, var_expr_ptr)
+//								 ---> ("make_shared_occurrence_non_unique", free_var, var_expr_ptr, sa_attr_nr)
 							-> (coercion_env, expr_heap, error)
 							-> (coercion_env, expr_heap, uniquenessError (CP_Expression (FreeVar free_var)) " demanded attribute cannot be offered by shared object" error)
 					_

frontend/syntax.dcl

@@ -512,7 +512,7 @@ cIsALocalVar	:== False
 
 :: AP_Kind = APK_Constructor !Index | APK_Macro
 
-::	VarInfo  =	VI_Empty | VI_Type !AType !(Optional CoercionPosition) | VI_Occurrence !Occurrence | VI_UsedVar !Ident |
+::	VarInfo  =	VI_Empty | VI_Type !AType !(Optional CoercionPosition) | VI_FAType ![ATypeVar] !AType | VI_Occurrence !Occurrence | VI_UsedVar !Ident |
 				VI_Expression !Expression | VI_Variable !Ident !VarInfoPtr | VI_LiftedVariable !VarInfoPtr |
 				VI_Count !Int /* the reference count of a variable */ !Bool /* true if the variable is global, false otherwise */ |
 				VI_AccVar !ConsClass !ArgumentPosition /* used during fusion to determine accumulating parameters of functions */ |
@@ -818,7 +818,7 @@ cNonRecursiveAppl	:== False
 			|	(:@:) infixl 9 !ConsVariable ![AType]
 			|	TB !BasicType
 
-//			|	TFA [ATypeVar] Type
+			|	TFA [ATypeVar] Type				/* Universally quantified types */
 
 			| 	GTV !TypeVar
 			| 	TV !TypeVar

frontend/syntax.icl

@@ -497,7 +497,7 @@ cIsALocalVar	:== False
 
 :: AP_Kind = APK_Constructor !Index | APK_Macro
 
-::	VarInfo  =	VI_Empty |VI_Type !AType !(Optional CoercionPosition) | VI_Occurrence !Occurrence | VI_UsedVar !Ident |
+::	VarInfo  =	VI_Empty | VI_Type !AType !(Optional CoercionPosition) | VI_FAType ![ATypeVar] !AType | VI_Occurrence !Occurrence | VI_UsedVar !Ident |
 				VI_Expression !Expression | VI_Variable !Ident !VarInfoPtr | VI_LiftedVariable !VarInfoPtr |
 				VI_Count !Int /* the reference count of a variable */ !Bool /* true if the variable is global, false otherwise */ |
 				VI_AccVar !ConsClass !ArgumentPosition /* used during fusion to determine accumulating parameters of functions */ |
@@ -789,7 +789,7 @@ cNotVarNumber :== -1
 			|	(:@:) infixl 9 !ConsVariable ![AType]
 			|	TB !BasicType
 
-//			|	TFA [ATypeVar] Type
+			|	TFA [ATypeVar] Type
 
 			| 	GTV !TypeVar
 			| 	TV !TypeVar
@@ -1408,7 +1408,7 @@ where
 instance <<< BoundVar
 where
 	(<<<) file {var_name,var_info_ptr,var_expr_ptr}
-		= file <<< var_name <<< '<' <<< ptrToInt var_info_ptr <<< '>'
+		= file <<< var_name <<< "<I" <<< ptrToInt var_info_ptr <<< ", E" <<< ptrToInt var_expr_ptr <<< '>'
 
 instance <<< (Bind a b) | <<< a & <<< b 
 where

frontend/trans.icl

@@ -1352,7 +1352,7 @@ generateFunction fd=:{fun_body = TransformedBody {tb_args,tb_rhs},fun_info = {fi
 	  (_, (st_args,st_result), ti_type_heaps)
 	  		= substitute (st_args,st_result) ti_type_heaps
 	  (new_fun_args, new_arg_types_array, next_attr_nr,
-	    new_linear_bits, new_cons_args, uniqueness_requirements, subst, ti_type_heaps=:{th_vars, th_attrs},
+	    new_linear_bits, new_cons_args, uniqueness_requirements, subst, ti_type_heaps=:{th_vars},
 	    ti_symbol_heap, ti_fun_defs, ti_fun_heap, ti_var_heap)
 			= determine_args cc_linear_bits cc_args 0 prods opt_sound_function_producer_types tb_args
 							(st_args_array st_args)
@@ -1364,8 +1364,8 @@ generateFunction fd=:{fun_body = TransformedBody {tb_args,tb_rhs},fun_info = {fi
 					(createArray (inc (BITINDEX nr_of_all_type_vars)) 0, th_vars)
 //	| False--->("subst before", [el\\el<-:subst], "cons_vars", [el\\el<-:cons_vars])
 //		= undef
-	# (subst, next_attr_nr, th_vars, ti_type_def_infos)
-	  		= liftSubstitution subst ro.ro_common_defs cons_vars next_attr_nr th_vars ti_type_def_infos
+	# (subst, next_attr_nr, ti_type_heaps=:{th_attrs}, ti_type_def_infos)
+	  		= liftSubstitution subst ro.ro_common_defs cons_vars next_attr_nr { ti_type_heaps & th_vars = th_vars } ti_type_def_infos
 //	| False--->("subst after lifting", [el\\el<-:subst])
 //		= undef
 	# coer_demanded
@@ -1385,7 +1385,7 @@ generateFunction fd=:{fun_body = TransformedBody {tb_args,tb_rhs},fun_info = {fi
 		  			uniqueness_requirements coercions
 	  (subst, coercions, ti_type_def_infos, ti_type_heaps)
 	  		= foldSt (coerce_types ro.ro_common_defs cons_vars) uniqueness_requirements
-	  				(subst, coercions, ti_type_def_infos, { ti_type_heaps & th_vars = th_vars, th_attrs = th_attrs })
+	  				(subst, coercions, ti_type_def_infos, { ti_type_heaps & th_attrs = th_attrs })
 //	| False--->("cons_vars", [el\\el<-:cons_vars])
 //		= undef
 //	  expansion_state
@@ -1883,11 +1883,14 @@ where
 
 	expand_type ro_common_defs cons_vars atype (coercions, subst, ti_type_heaps, ti_type_def_infos)
 		| is_dictionary atype ti_type_def_infos
-			# (atype, subst) = arraySubst atype subst
+///* Sjaak */	# (atype, subst) = arraySubst atype subst
+			# (_, atype, subst) = arraySubst atype subst
 			= (atype, (coercions, subst, ti_type_heaps, ti_type_def_infos))
 		# es
 	  			= { es_type_heaps = ti_type_heaps, es_td_infos = ti_type_def_infos }
-		  (btype, (subst, es))
+/* Sjaak */
+		  (_, btype, (subst, es))
+//		  (btype, (subst, es))
 		  		= expandType ro_common_defs cons_vars atype (subst, es)
  		  { es_type_heaps = ti_type_heaps, es_td_infos = ti_type_def_infos }
 				= es

frontend/type.dcl

@@ -10,6 +10,8 @@ typeProgram ::!{! Group} !Int !*{# FunDef} !IndexRange  !(Optional Bool) !Common
 
 addPropagationAttributesToAType :: {#CommonDefs} !AType !*PropState -> *(!AType,Int,!*PropState);
 
+tryToExpand :: !Type !TypeAttribute !{# CommonDefs} !*TypeHeaps -> (!Bool, !Type, !*TypeHeaps)
+
 ::	PropState =
 	{	prop_type_heaps	:: !.TypeHeaps
 	,	prop_td_infos	:: !.TypeDefInfos
@@ -28,6 +30,7 @@ instance unify AType
 	,	ti_main_dcl_module_n :: !Int
 	}
 
-class arraySubst type :: !type !u:{!Type} -> (!type, !u:{! Type})
+class arraySubst type :: !type !u:{!Type} -> (!Bool,!type, !u:{! Type})
+//class arraySubst type :: !type !u:{!Type} -> (!type, !u:{! Type})
 
 instance arraySubst AType

frontend/type_io.dcl

@@ -21,7 +21,7 @@ where
 instance WriteTypeInfo CommonDefs, Char, [a] | WriteTypeInfo a
 
 /*2.0
-instance WriteTypeInfo String
+instance WriteTypeInfo {#b} | Array {#} b & WriteTypeInfo b 
 0.2*/
 
 //1.3

frontend/type_io.icl

@@ -386,18 +386,6 @@ where
 			= write_type_info type_arity tcl_file wtis
 		= (tcl_file,wtis)
 		
-/*2.0
-instance WriteTypeInfo String
-where
-        write_type_info s tcl_file wtis
-                # tcl_file
-                        = fwritei (size s) tcl_file
-                = (fwrites s tcl_file,wtis)
-        // warning:
-        // Should be identical to the code in Ident
-
-0.2*/
-
 
 // basic and structural write_type_info's
 instance WriteTypeInfo Int 
@@ -409,7 +397,7 @@ where
 instance WriteTypeInfo {#b} | select_u, size_u, WriteTypeInfo b
 //3.1
 /*2.0
-instance WriteTypeInfo {#b} | WriteTypeInfo b & Array {#} b
+instance WriteTypeInfo {#b} | Array {#} b & WriteTypeInfo b
 0.2*/
 where
 	write_type_info unboxed_array tcl_file wtis

frontend/typesupport.icl

@@ -207,10 +207,6 @@ errorHeading  error_kind err=:{ea_file,ea_loc = []}
 errorHeading  error_kind err=:{ea_file,ea_loc = [ loc : _ ]}
 	= { err & ea_file = ea_file <<< error_kind <<< ' ' <<< loc <<< ':', ea_ok = False }
 
-overloadingError class_symb err
-	# err = errorHeading "Overloading error" err
-	= { err & ea_file = err.ea_file <<< " internal overloading of class \"" <<< class_symb <<< "\" is unsolvable\n" }
-
 contextError class_symb err
 	# err = errorHeading "Overloading error" err
 	= { err & ea_file = err.ea_file <<< " unresolved class \"" <<< class_symb <<< "\" not occurring in specified type\n"}
@@ -329,7 +325,6 @@ where
 	clean_up_type_context tc=:{tc_types} (collected_contexts, env, error)
 		# (cur, tc_types, env) = cleanUpClosed tc.tc_types env
 		| checkCleanUpResult cur cUndefinedVar
-//			= ([{ tc & tc_types = tc_types } : collected_contexts], env, overloadingError tc.tc_class.glob_object.ds_ident error)
 			= (collected_contexts, env, error)
 		| checkCleanUpResult cur cLiftedVar
 			= ([{ tc & tc_types = tc_types } : collected_contexts ], env, liftedContextError tc.tc_class.glob_object.ds_ident error)

frontend/unitype.dcl

@@ -54,13 +54,15 @@ tryToMakeUnique :: !Int !*Coercions -> (!Bool, !*Coercions)
 
 uniquenessError :: !CoercionPosition !String !*ErrorAdmin -> *ErrorAdmin
 
-liftSubstitution :: !*{! Type} !{# CommonDefs }!{# BOOLVECT } !Int !*TypeVarHeap !*TypeDefInfos -> (*{! Type}, !Int, !*TypeVarHeap, !*TypeDefInfos)
+liftSubstitution :: !*{! Type} !{# CommonDefs }!{# BOOLVECT } !Int !*TypeHeaps !*TypeDefInfos -> (*{! Type}, !Int, !*TypeHeaps, !*TypeDefInfos)
 
 ::	ExpansionState = 
 	{	es_type_heaps	:: !.TypeHeaps
 	,	es_td_infos		:: !.TypeDefInfos
 	}
 
-class expandType a :: !{# CommonDefs } !{# BOOLVECT } !a !*(!u:{! Type}, !*ExpansionState) -> (!a, !*(!u:{! Type}, !*ExpansionState))
+class expandType a :: !{# CommonDefs } !{# BOOLVECT } !a !*(!u:{! Type}, !*ExpansionState) -> (!Bool, !a, !*(!u:{! Type}, !*ExpansionState))
+//class expandType a :: !{# CommonDefs } !{# BOOLVECT } !a !*(!u:{! Type}, !*ExpansionState) -> (!a, !*(!u:{! Type}, !*ExpansionState))
+
 
 instance expandType AType