add type constraints in constructors and function arguments with universal...

add type constraints in constructors and function arguments with universal quantifier (from iTask branch)

backend/backendconvert.icl

@@ -1410,6 +1410,8 @@ convertTypeNode TE
 	=	beNormalTypeNode beDontCareDefinitionSymbol beNoTypeArgs
 convertTypeNode (TFA vars type)
 	=	beAddForAllTypeVariables (convertTypeVars vars) (convertTypeNode type)
+convertTypeNode (TFAC vars type contexts)
+	=	beAddForAllTypeVariables (convertTypeVars vars) (convertTypeNode type)
 convertTypeNode (TGenericFunctionInDictionary gds type_kind generic_dict=:{gi_module,gi_index})
 	= beNormalTypeNode (beTypeSymbol gi_index gi_module) beNoTypeArgs
 convertTypeNode typeNode

frontend/analunitypes.icl

@@ -315,6 +315,8 @@ signClassOfType (arg_type --> res_type) sign use_top_sign group_nr ci scs
 
 signClassOfType (TFA vars type) sign use_top_sign group_nr ci scs
 	= signClassOfType type sign use_top_sign group_nr ci scs
+signClassOfType (TFAC vars type _) sign use_top_sign group_nr ci scs
+	= signClassOfType type sign use_top_sign group_nr ci scs
 
 signClassOfType type _ _ _ _ scs
 	= (BottomSignClass, BottomSignClass, scs)
@@ -580,6 +582,8 @@ where
 
 propClassOfType (TFA vars type) group_nr ci pcs
 	= propClassOfType type group_nr ci pcs
+propClassOfType (TFAC vars type _) group_nr ci pcs
+	= propClassOfType type group_nr ci pcs
 
 propClassOfType _ _ _ pcs
 	= (NoPropClass, NoPropClass, pcs)

frontend/check.icl

@@ -383,6 +383,10 @@ where
 		# (fresh_type_vars, type_heaps) = foldSt build_avar_subst type_vars ([], type_heaps)
 		  (_, new_at, type_heaps) = substitute {at & at_type = type} type_heaps
 		= ({ new_at & at_type = TFA fresh_type_vars new_at.at_type}, (was_ok, type_heaps))
+	substitue_arg_type at=:{at_type = TFAC type_vars type type_contexts} (was_ok, type_heaps)
+		# (fresh_type_vars, type_heaps) = foldSt build_avar_subst type_vars ([], type_heaps)
+		  (_, new_at, type_heaps) = substitute {at & at_type = type} type_heaps
+		= ({ new_at & at_type = TFAC fresh_type_vars new_at.at_type type_contexts}, (was_ok, type_heaps))
 	substitue_arg_type type (was_ok, type_heaps)
 		# (_, type, type_heaps) = substitute type type_heaps
 		= (type, (was_ok, type_heaps))
@@ -877,7 +881,7 @@ checkDclMacros :: !Index !Level !Index !Index !*ExpressionInfo !*Heaps !*CheckSt
 										  -> (!*ExpressionInfo,!*Heaps,!*CheckState)
 checkDclMacros mod_index level fun_index to_index e_info heaps cs
 	| fun_index == to_index
-		= ( e_info, heaps, cs)
+		= (e_info, heaps, cs)
 		# (macro_def,e_info) = e_info!ef_macro_defs.[mod_index,fun_index]
 		# (macro_def,_, e_info, heaps, cs) = checkFunction macro_def mod_index (DclMacroIndex mod_index fun_index) level 0 {} e_info heaps cs
 		# e_info = { e_info & ef_macro_defs.[mod_index,fun_index] = macro_def }
@@ -997,11 +1001,11 @@ array_plus_list a l = arrayPlusList a l
 checkCommonDefinitions :: !(Optional (CopiedDefinitions, Int)) !Index !*CommonDefs !*{# DclModule} !*Heaps !*CheckState
 												  -> (!DictionaryInfo,!*CommonDefs,!*{# DclModule},!*Heaps, !*CheckState)
 checkCommonDefinitions opt_icl_info module_index common modules heaps cs
-	# (com_type_defs, com_cons_defs, com_selector_defs, modules, heaps, cs)
+	# (com_type_defs, com_cons_defs, com_selector_defs, com_class_defs, modules, heaps, cs)
 			= checkTypeDefs module_index opt_icl_info
-					common.com_type_defs common.com_cons_defs common.com_selector_defs modules heaps cs
+					common.com_type_defs common.com_cons_defs common.com_selector_defs common.com_class_defs modules heaps cs
 	  (com_class_defs, com_member_defs, com_type_defs, modules, heaps, cs)
-	  		= checkTypeClasses module_index opt_icl_info common.com_class_defs common.com_member_defs com_type_defs modules heaps cs
+	  		= checkTypeClasses module_index opt_icl_info com_class_defs common.com_member_defs com_type_defs modules heaps cs
 	  (com_member_defs, com_type_defs, com_class_defs, modules, heaps, cs)
 	  		= checkMemberTypes module_index opt_icl_info com_member_defs com_type_defs com_class_defs modules heaps cs
 	  (com_instance_defs, com_type_defs, com_class_defs, com_member_defs, modules, heaps, cs)

frontend/checkFunctionBodies.icl

@@ -1073,6 +1073,7 @@ transform_pattern (AP_Algebraic cons_symbol global_type_index args opt_var) patt
 					# glob_object = {glob_object & ds_index=pds_def,ds_ident=pds_ident}
 					= ({pattern & ap_symbol.glob_object=glob_object},cs)
 					= abort "replace_overloaded_symbol_in_pattern"
+
 transform_pattern (AP_Basic basic_val opt_var) patterns pattern_scheme pattern_variables defaul result_expr _ pos var_store expr_heap opt_dynamics cs
 	# pattern = { bp_value = basic_val, bp_expr = result_expr, bp_position = pos}
 	  pattern_variables = cons_optional opt_var pattern_variables
@@ -1309,6 +1310,10 @@ where
 				SK_Constructor _
 					# app_expr = App {app_symb = symbol, app_args = [], app_info_ptr = nilPtr}
 					-> (app_expr, free_vars, e_state, e_info, cs)
+				SK_OverloadedConstructor cons_index
+					# (new_info_ptr, es_expr_heap) = newPtr EI_Empty e_state.es_expr_heap
+					  app_expr = App {app_symb = {symbol & symb_kind=SK_Constructor cons_index}, app_args = [], app_info_ptr = new_info_ptr}
+					-> (app_expr, free_vars, {e_state & es_expr_heap = es_expr_heap}, e_info, cs)
 				SK_NewTypeConstructor _
 					# cs = { cs & cs_error = checkError id "argument missing (for newtype constructor)" cs.cs_error}
 					# app_expr = App { app_symb = symbol , app_args = [], app_info_ptr = nilPtr }
@@ -1372,18 +1377,22 @@ where
 			# {me_type={st_arity},me_priority} = com_member_defs.[def_index]
 			= (SK_OverloadedFunction { glob_object = def_index, glob_module = mod_index }, st_arity, me_priority)
 		ste_kind_to_symbol_kind STE_Constructor def_index mod_index {dcl_common={com_cons_defs}}
-			# {cons_type={st_arity},cons_priority,cons_number} = com_cons_defs.[def_index]
+			# {cons_type={st_arity,st_args,st_context},cons_priority,cons_number} = com_cons_defs.[def_index]
 			| cons_number <> -2
-				= (SK_Constructor {glob_object = def_index, glob_module = mod_index}, st_arity, cons_priority)
+				| isEmpty st_context && no_TFAC_argument st_args
+					= (SK_Constructor {glob_object = def_index, glob_module = mod_index}, st_arity, cons_priority)
+					= (SK_OverloadedConstructor {glob_object = def_index, glob_module = mod_index}, st_arity, cons_priority)
 				= (SK_NewTypeConstructor {gi_index = def_index, gi_module = mod_index}, st_arity, cons_priority)
 	determine_info_of_symbol {ste_kind=STE_Member, ste_index} _ e_input=:{ei_mod_index} e_state e_info=:{ef_member_defs} cs
 		# ({me_type={st_arity},me_priority}, ef_member_defs) = ef_member_defs![ste_index]
 		= (SK_OverloadedFunction { glob_object = ste_index, glob_module = ei_mod_index}, st_arity, me_priority,
 				e_state, { e_info & ef_member_defs = ef_member_defs }, cs)
 	determine_info_of_symbol {ste_kind=STE_Constructor, ste_index} _ e_input=:{ei_mod_index} e_state e_info cs
-		# ({cons_type={st_arity},cons_priority,cons_number}, e_info) = e_info!ef_cons_defs.[ste_index]
+		# ({cons_type={st_arity,st_args,st_context},cons_priority,cons_number}, e_info) = e_info!ef_cons_defs.[ste_index]
 		| cons_number <> -2
-			= (SK_Constructor {glob_object = ste_index, glob_module =  ei_mod_index}, st_arity, cons_priority, e_state, e_info, cs)
+			| isEmpty st_context && no_TFAC_argument st_args
+				= (SK_Constructor {glob_object = ste_index, glob_module = ei_mod_index}, st_arity, cons_priority, e_state, e_info, cs)
+				= (SK_OverloadedConstructor {glob_object = ste_index, glob_module = ei_mod_index}, st_arity, cons_priority, e_state, e_info, cs)
 			= (SK_NewTypeConstructor {gi_index = ste_index, gi_module = ei_mod_index}, st_arity, cons_priority, e_state, e_info, cs)
 	determine_info_of_symbol {ste_kind=STE_DclFunction, ste_index} _ e_input=:{ei_mod_index} e_state=:{es_calls} e_info=:{ef_is_macro_fun} cs
 		# ({ft_type={st_arity},ft_priority}, e_info) = e_info!ef_modules.[ei_mod_index].dcl_functions.[ste_index]
@@ -1402,6 +1411,10 @@ where
 			= SK_LocalMacroFunction index.glob_object
 			= SK_Function index
 
+	no_TFAC_argument [{at_type=TFAC _ _ _}:_] = False
+	no_TFAC_argument [_:args] = no_TFAC_argument args
+	no_TFAC_argument [] = True
+
 checkQualifiedIdentExpression free_vars module_id ident_name is_expr_list e_input=:{ei_fun_index,ei_mod_index} e_state e_info cs
 	# (found,{decl_kind,decl_ident,decl_index},cs) = search_qualified_ident module_id ident_name ExpressionNameSpaceN cs
 	| not found
@@ -1417,12 +1430,15 @@ checkQualifiedIdentExpression free_vars module_id ident_name is_expr_list e_inpu
 					# e_state = { e_state & es_calls = [DclFunCall mod_index decl_index : e_state.es_calls ]}
 					-> (app_expr, free_vars, e_state, e_info, cs)
 			STE_Imported STE_Constructor mod_index
-				# ({cons_type={st_arity},cons_priority,cons_number}, e_info) = e_info!ef_modules.[mod_index].dcl_common.com_cons_defs.[decl_index]
+				# ({cons_type={st_arity,st_context},cons_priority,cons_number}, e_info) = e_info!ef_modules.[mod_index].dcl_common.com_cons_defs.[decl_index]
 				| cons_number <> -2
 					# kind = SK_Constructor { glob_object = decl_index, glob_module = mod_index }
 					  symbol = { symb_ident = decl_ident, symb_kind = kind }
-					# app_expr = build_application_or_constant_for_constructor symbol st_arity cons_priority
-					-> (app_expr, free_vars, e_state, e_info, cs)
+					| isEmpty st_context
+						# (app_expr,e_state) = build_application_or_constant_for_function symbol st_arity cons_priority e_state
+						-> (app_expr, free_vars, e_state, e_info, cs)
+						# app_expr = build_application_or_constant_for_constructor symbol st_arity cons_priority
+						-> (app_expr, free_vars, e_state, e_info, cs)
 					# kind = SK_NewTypeConstructor { gi_index = decl_index, gi_module = mod_index }
 					# symbol = { symb_ident = decl_ident, symb_kind = kind }
 					# app_expr = build_application_or_constant_for_constructor symbol st_arity cons_priority
@@ -2663,6 +2679,13 @@ buildApplication symbol=:{symb_kind=SK_Constructor _} form_arity act_arity args
 	| act_arity > form_arity
 		= (app, e_state, checkError symbol.symb_ident "used with too many arguments" error)
 		= (app, e_state, error)
+buildApplication symbol=:{symb_kind=SK_OverloadedConstructor cons_index} form_arity act_arity args e_state error
+	# (new_info_ptr, es_expr_heap) = newPtr EI_Empty e_state.es_expr_heap
+	  e_state = {e_state & es_expr_heap=es_expr_heap}
+	  app = App {app_symb = {symbol & symb_kind=SK_Constructor cons_index}, app_args = args, app_info_ptr = new_info_ptr}
+	| act_arity > form_arity
+		= (app, e_state, checkError symbol.symb_ident "used with too many arguments" error)
+		= (app, e_state, error)
 buildApplication symbol=:{symb_kind=SK_NewTypeConstructor _} form_arity act_arity args e_state error
 	# app = App { app_symb = symbol , app_args = args, app_info_ptr = nilPtr }
 	| act_arity == form_arity
@@ -2682,6 +2705,10 @@ buildApplicationWithoutArguments :: !SymbIdent !*ExpressionState !*ErrorAdmin ->
 buildApplicationWithoutArguments symbol=:{symb_kind=SK_Constructor _} e_state error
 	# app = App { app_symb = symbol , app_args = [], app_info_ptr = nilPtr }
 	= (app, e_state, error)
+buildApplicationWithoutArguments symbol=:{symb_kind=SK_OverloadedConstructor cons_index} e_state error
+	# (new_info_ptr, es_expr_heap) = newPtr EI_Empty e_state.es_expr_heap
+	  app = App {app_symb = {symbol & symb_kind=SK_Constructor cons_index}, app_args = [], app_info_ptr = new_info_ptr}
+	= (app, {e_state & es_expr_heap = es_expr_heap}, error)
 buildApplicationWithoutArguments symbol=:{symb_kind=SK_NewTypeConstructor _} e_state error
 	# app = App { app_symb = symbol , app_args = [], app_info_ptr = nilPtr }
 	= (app, e_state, checkError symbol.symb_ident "argument missing (for newtype constructor)" error)

frontend/checktypes.dcl

@@ -3,8 +3,8 @@ definition module checktypes
 import checksupport
 
 checkTypeDefs :: !Index !(Optional (CopiedDefinitions, Int))
-		!*{#CheckedTypeDef} !*{#ConsDef} !*{#SelectorDef} !*{#DclModule} !*Heaps !*CheckState
-	-> (!*{#CheckedTypeDef},!*{#ConsDef},!*{#SelectorDef},!*{#DclModule},!*Heaps,!*CheckState)
+		!*{#CheckedTypeDef} !*{#ConsDef} !*{#SelectorDef} !v:{#ClassDef} !*{#DclModule} !*Heaps !*CheckState
+	-> (!*{#CheckedTypeDef},!*{#ConsDef},!*{#SelectorDef},!v:{#ClassDef},!*{#DclModule},!*Heaps,!*CheckState)
 
 checkFunctionType :: !Index !SymbolType !FunSpecials !u:{#CheckedTypeDef} !v:{#ClassDef} !u:{#DclModule} !*TypeHeaps !*CheckState
 						-> (!SymbolType,!FunSpecials,!u:{#CheckedTypeDef},!v:{#ClassDef},!u:{#DclModule},!*TypeHeaps,!*CheckState)

frontend/classify.icl

@@ -483,6 +483,16 @@ instance consumerRequirements Expression where
 		= (CPassive, False, ai)
 	consumerRequirements (FailExpr _) _ ai
 		= (CPassive, False, ai)
+	consumerRequirements (DictionariesFunction dictionaries expr expr_type) common_defs ai
+		# (new_next_var,new_next_var_of_fun,ai_var_heap) = init_variables dictionaries ai.ai_next_var ai.ai_next_var_of_fun ai.ai_var_heap
+		# ai = {ai & ai_next_var=new_next_var,ai_next_var_of_fun=new_next_var_of_fun,ai_var_heap=ai_var_heap}
+		= consumerRequirements expr common_defs ai
+		where
+			init_variables [({fv_info_ptr},_):dictionaries] ai_next_var ai_next_var_of_fun ai_var_heap
+				# ai_var_heap = writePtr fv_info_ptr (VI_AccVar ai_next_var ai_next_var_of_fun) ai_var_heap
+				= init_variables dictionaries (inc ai_next_var) (inc ai_next_var_of_fun) ai_var_heap
+			init_variables [] ai_next_var ai_next_var_of_fun ai_var_heap
+				= (ai_next_var,ai_next_var_of_fun,ai_var_heap)
 	consumerRequirements expr _ ai
 		= abort ("consumerRequirements [Expression]" ---> expr)
 
@@ -685,7 +695,7 @@ instance consumerRequirements Case where
 										  		_ -> False
 
 		inspect_patterns :: !{#CommonDefs} !Bool !CasePatterns ![(Int,Bool)] -> (!Bool,!Bool)
-		inspect_patterns common_defs has_default (AlgebraicPatterns {gi_index,gi_module} algebraic_patterns) constructors_and_unsafe_bits
+		inspect_patterns common_defs has_default (AlgebraicPatterns {gi_index,gi_module} _) constructors_and_unsafe_bits
 			# type_def						= common_defs.[gi_module].com_type_defs.[gi_index]
 			  defined_symbols				= case type_def.td_rhs of
 													AlgType defined_symbols		-> defined_symbols
@@ -1473,6 +1483,13 @@ count_locals EE n
 count_locals (FailExpr _) n = n
 count_locals (NoBind _) n
 	= n
+count_locals (DictionariesFunction dictionaries expr expr_type) n
+	= count_locals expr (foldSt count_local_dictionary dictionaries n)
+	where
+		count_local_dictionary ({fv_count},_) n
+			| fv_count > 0
+				= n+1
+				= n
 
 count_optional_locals (Yes e) n
 	= count_locals e n
@@ -1781,6 +1798,8 @@ instance producerRequirements Expression where
 		= (True,prs)
 	producerRequirements (FailExpr _) prs
 		= (True,prs)
+	producerRequirements (DictionariesFunction dictionaries expr expr_type) prs
+		= producerRequirements expr prs
 	producerRequirements expr prs
 		= abort ("producerRequirements " ---> expr)
 

frontend/comparedefimp.icl

@@ -110,9 +110,14 @@ where
 		  comp_type_var_heap = initialyseATypeVars dcl_cons_def.cons_exi_vars icl_cons_def.cons_exi_vars comp_type_var_heap
 		  comp_st = { comp_st & comp_type_var_heap = comp_type_var_heap }
 		  (ok, comp_st) = compare (dcl_cons_type.st_args,dcl_cons_type.st_args_strictness) (icl_cons_type.st_args,icl_cons_type.st_args_strictness) comp_st
-		| ok && do_compare_result_types
-			= compare dcl_cons_type.st_result icl_cons_type.st_result comp_st
-			= (ok, comp_st)
+		| not ok
+			= (False,comp_st)
+		| do_compare_result_types
+			# (ok,comp_st) = compare dcl_cons_type.st_result icl_cons_type.st_result comp_st
+			| ok
+				= compare dcl_cons_type.st_context icl_cons_type.st_context comp_st
+				= (False,comp_st)
+			= compare dcl_cons_type.st_context icl_cons_type.st_context comp_st
 
 compareClassDefs :: !{#Int} {#Bool} !{# ClassDef} !{# MemberDef} !u:{# ClassDef} !v:{# MemberDef} !*CompareState
 	-> (!u:{# ClassDef}, !v:{# MemberDef}, !*CompareState)
@@ -298,6 +303,12 @@ where
 		  type_heaps = clear_type_vars dclvars (comp_st.comp_type_var_heap, comp_st.comp_attr_var_heap)
 		  (comp_type_var_heap, comp_attr_var_heap) = clear_type_vars iclvars type_heaps
 		= (ok, {comp_st & comp_type_var_heap = comp_type_var_heap, comp_attr_var_heap = comp_attr_var_heap})
+	compare (TFAC dclvars dcltype dcl_contexts) (TFAC iclvars icltype icl_contexts) comp_st=:{comp_type_var_heap}
+		# comp_type_var_heap = initialyseATypeVars dclvars iclvars comp_type_var_heap
+		  (ok, comp_st) = compare (dcltype,dcl_contexts) (icltype,icl_contexts) {comp_st & comp_type_var_heap = comp_type_var_heap}
+		  type_heaps = clear_type_vars dclvars (comp_st.comp_type_var_heap, comp_st.comp_attr_var_heap)
+		  (comp_type_var_heap, comp_attr_var_heap) = clear_type_vars iclvars type_heaps
+		= (ok, {comp_st & comp_type_var_heap = comp_type_var_heap, comp_attr_var_heap = comp_attr_var_heap})
 	compare _ _ comp_st
 		= (False, comp_st)
 
@@ -940,6 +951,10 @@ instance t_corresponds Type where
 	t_corresponds (TFA dclVars dclType) (TFA iclVars iclType)
 		=	do (init_atype_vars dclVars iclVars)
 		&&&	t_corresponds dclType iclType
+	t_corresponds (TFAC dclVars dclType dclContexts) (TFAC iclVars iclType iclContexts)
+		=	do (init_atype_vars dclVars iclVars)
+		&&&	t_corresponds dclType iclType
+		&&&	t_corresponds dclContexts iclContexts
 	t_corresponds _ _
 		= return False
 		
@@ -1084,9 +1099,9 @@ instance e_corresponds FunctionBody where
 	// both bodies are either CheckedBodies or TransformedBodies
 	e_corresponds dclDef iclDef
 		=	e_corresponds (from_body dclDef) (from_body iclDef)
-	  where
-		from_body (TransformedBody {tb_args, tb_rhs}) = (tb_args, [tb_rhs])
-		from_body (CheckedBody {cb_args, cb_rhs}) = (cb_args, [ca_rhs \\ {ca_rhs} <- cb_rhs])
+
+from_body (TransformedBody {tb_args, tb_rhs}) = (tb_args, [tb_rhs])
+from_body (CheckedBody {cb_args, cb_rhs}) = (cb_args, [ca_rhs \\ {ca_rhs} <- cb_rhs])
 		
 instance e_corresponds FreeVar where
 	e_corresponds dclVar iclVar
@@ -1387,31 +1402,3 @@ do_nothing ec_state
 give_error s ec_state
 	= { ec_state & ec_error_admin = checkError s ErrorMessage ec_state.ec_error_admin }
 
-/*
-instance <<< Priority
-	where
-		(<<<) file NoPrio = file <<< "NoPrio"		
-		(<<<) file (Prio LeftAssoc i) = file <<< "Prio LeftAssoc " <<< i
-		(<<<) file (Prio RightAssoc i) = file <<< "Prio RightAssoc " <<< i
-		(<<<) file (Prio NoAssoc i) = file <<< "Prio NoAssoc " <<< i
-
-Trace_array a
-	= trace_array 0
-	where
-		trace_array i
-			| i<size a
-				= Trace_tn i && Trace_tn a.[i] && trace_array (i+1)
-				= True;
-
-Trace_tn d
-	= file_to_true (stderr <<< d <<< '\n')
-
-file_to_true :: !File -> Bool;
-file_to_true file = code {
-  .inline file_to_true
-          pop_b 2
-          pushB TRUE
-  .end
- };
-
-*/
\ No newline at end of file

frontend/convertDynamics.icl

@@ -301,6 +301,9 @@ instance convertDynamics Expression where
 		= (EE, ci)
 	convertDynamics cinp expr=:(NoBind _) ci
 		= (expr,ci)
+	convertDynamics cinp (DictionariesFunction dictionaries expr expr_type) ci
+		# (expr,ci) = convertDynamics cinp expr ci
+		= (DictionariesFunction dictionaries expr expr_type,ci)
 
 instance convertDynamics App where
 	convertDynamics cinp app=:{app_args} ci
@@ -561,6 +564,7 @@ where
 		# type_fun
 			=	App {app_symb = fun_ident, app_args = [], app_info_ptr = nilPtr}
 		= (App {app_symb = cinp_dynamic_representation.dr_type_code_constructor_symb_ident, app_args = [type_fun], app_info_ptr = nilPtr}, ci)
+
 	typeConstructor (GTT_Basic basic_type) ci
 		#! predefined_TC_basic_type
 			= case basic_type of
@@ -737,7 +741,6 @@ create_dynamic_and_selector_idents common_defs predefined_symbols
 	// otherwise
 		# ({pds_module=pds_module1, pds_def=pds_def1} , predefined_symbols) = predefined_symbols![PD_Dyn_DynamicTemp]
 		# {td_rhs=RecordType {rt_constructor}} = common_defs.[pds_module1].com_type_defs.[pds_def1]
-	
 		# dynamic_defined_symbol
 			= {glob_module = pds_module1, glob_object = rt_constructor}
 		# dynamic_type = {gi_module = pds_module1, gi_index = pds_def1}

frontend/convertcases.icl

@@ -259,6 +259,8 @@ where
 		= rs
 	weightedRefCount rci (NoBind ptr) rs
 		= rs
+	weightedRefCount rci (DictionariesFunction _ expr _) rs
+		= weightedRefCount rci expr rs
 	weightedRefCount rci (FailExpr _) rs
 		= rs
 	weightedRefCount rci expr rs
@@ -582,6 +584,9 @@ where
 		= (NoBind ptr, ds)
 	distributeLets _ (FailExpr id) ds
 		= (FailExpr id, ds)
+	distributeLets di (DictionariesFunction dictionaries expr expr_type) ds
+		# (expr,ds) = distributeLets di expr ds
+		= (DictionariesFunction dictionaries expr expr_type,ds)
 
 instance distributeLets Case
 where
@@ -1641,6 +1646,33 @@ where
 		# (failExpr, cs)
 			=	convertNonRootFail ci ident cs
 		= (failExpr, cs)
+	convertCases ci (DictionariesFunction dictionaries expr expr_type) cs
+		# (expr,cs) = convertRootCases {ci & ci_case_level=CaseLevelRoot,ci_bound_vars=dictionaries++ci.ci_bound_vars} expr cs
+	      (old_fv_info_ptr_values,var_heap) = store_VI_FreeVar_in_dictionary_vars_and_save_old_values dictionaries [] cs.cs_var_heap
+	      (old_fv_info_ptr_values,var_heap) = store_VI_BoundVar_in_bound_vars_and_save_old_values ci.ci_bound_vars old_fv_info_ptr_values var_heap
+		  (expr, {cp_free_vars,cp_var_heap,cp_local_vars}) = copy expr {cp_free_vars=[], cp_var_heap=var_heap, cp_local_vars=[]}
+		  (bound_vars, free_typed_vars, var_heap) = retrieve_variables cp_free_vars cp_var_heap
+		  (free_typed_dictinary_vars, var_heap) = retrieve_dictionary_variables dictionaries var_heap
+		  cs = {cs & cs_var_heap = var_heap}
+		  (fun_ident,cs) = new_case_function No expr_type expr (free_typed_vars++free_typed_dictinary_vars) cp_local_vars ci.ci_group_index cs
+		  cs_var_heap = restore_old_fv_info_ptr_values old_fv_info_ptr_values (dictionaries++ci.ci_bound_vars) cs.cs_var_heap
+		= (App {app_symb=fun_ident, app_args=bound_vars, app_info_ptr=nilPtr}, {cs & cs_var_heap=cs_var_heap})
+	where
+		store_VI_FreeVar_in_dictionary_vars_and_save_old_values [({fv_info_ptr,fv_ident},type):bound_vars] old_fv_info_ptr_values var_heap
+			# (old_fv_info_ptr_value,var_heap) = readPtr fv_info_ptr var_heap
+			  (new_info_ptr,var_heap) = newPtr (VI_Labelled_Empty "convertCases [FreeVar]") var_heap
+			  var_heap = writePtr fv_info_ptr (VI_FreeVar fv_ident new_info_ptr 0 type) var_heap
+			  (old_fv_info_ptr_values,var_heap) = store_VI_FreeVar_in_dictionary_vars_and_save_old_values bound_vars old_fv_info_ptr_values var_heap
+			= ([old_fv_info_ptr_value:old_fv_info_ptr_values],var_heap)
+		store_VI_FreeVar_in_dictionary_vars_and_save_old_values [] old_fv_info_ptr_values var_heap
+			= (old_fv_info_ptr_values,var_heap)
+
+		retrieve_dictionary_variables cp_free_vars cp_var_heap
+			= foldSt retrieve_dictionary_variable cp_free_vars ([], cp_var_heap)
+		where
+			retrieve_dictionary_variable ({fv_info_ptr}, type) (free_typed_vars, var_heap)
+				# (VI_FreeVar name new_ptr count type, var_heap) = readPtr fv_info_ptr var_heap
+				= ([({fv_def_level = NotALevel, fv_ident = name, fv_info_ptr = new_ptr, fv_count = count}, type) : free_typed_vars], var_heap)
 	convertCases ci expr cs
 		= (expr, cs)
 

frontend/expand_types.icl

@@ -158,6 +158,11 @@ where
 		| changed
 			= (True,TFA vars type, ets)
 			= (False,tfa_type, ets)
+	expandSynTypes rem_annots common_defs tfac_type=:(TFAC vars type type_context) ets
+		# (changed,type, ets) = expandSynTypes rem_annots common_defs type ets
+		| changed
+			= (True,TFAC vars type type_context, ets)
+			= (False,tfac_type, ets)
 	expandSynTypes rem_annots common_defs type ets
 		= (False,type, ets)
 

frontend/frontend.icl

-		/*
-	module owner: Ronny Wichers Schreur
-*/
 implementation module frontend
 
 import scanner, parse, postparse, check, type, trans, partition, convertcases, overloading, utilities, convertDynamics,
@@ -347,17 +344,42 @@ showMacrosInModule dcl_index (macro_defs,file)
 			# (macro,macro_defs) = macro_defs![dcl_index,macro_index]
 			= (macro_defs, file <<< macro_index <<< macro <<< '\n')
 
-showComponents :: !u:{! Group} !Int !Bool !*{# FunDef} !*File  -> (!u:{! Group}, !*{# FunDef},!*File)
+showGroups :: !u:{! Group} !Int !Bool !*{# FunDef} !*File  -> (!u:{! Group}, !*{# FunDef},!*File)
+showGroups comps comp_index show_types fun_defs file
+	| comp_index >= size comps
+		= (comps, fun_defs, file)
+		# (comp, comps) = comps![comp_index]
+		# (fun_defs, file) = show_group comp.group_members show_types fun_defs (file <<< "component " <<< comp_index <<< '\n')
+		= showGroups comps (inc comp_index) show_types fun_defs file
+
+show_group [] show_types fun_defs file
+	= (fun_defs, file <<< '\n')
+show_group [fun:funs] show_types fun_defs file
+	# (fun_def, fun_defs) = fun_defs![fun]
+	# file=file<<<fun<<<'\n'
+	| show_types
+		= show_group funs show_types fun_defs (file <<< fun_def.fun_type <<< '\n' <<< fun_def)
+		= show_group funs show_types fun_defs (file <<< fun_def)
+//		= show_group funs show_types fun_defs (file <<< fun_def.fun_ident)
+
+showComponents :: !u:{!Component} !Int !Bool !*{# FunDef} !*File  -> (!u:{!Component}, !*{# FunDef},!*File)
 showComponents comps comp_index show_types fun_defs file
 	| comp_index >= size comps
 		= (comps, fun_defs, file)
 		# (comp, comps) = comps![comp_index]
-		# (fun_defs, file) = show_component comp.group_members show_types fun_defs (file <<< "component " <<< comp_index <<< '\n')
+		# (fun_defs, file) = show_component comp.component_members show_types fun_defs (file <<< "component " <<< comp_index <<< '\n')
 		= showComponents comps (inc comp_index) show_types fun_defs file
 
-show_component [] show_types fun_defs file
+show_component NoComponentMembers show_types fun_defs file
 	= (fun_defs, file <<< '\n')
-show_component [fun:funs] show_types fun_defs file
+show_component (ComponentMember fun funs) show_types fun_defs file
+	# (fun_def, fun_defs) = fun_defs![fun]
+	# file=file<<<fun<<<'\n'
+	| show_types
+		= show_component funs show_types fun_defs (file <<< fun_def.fun_type <<< '\n' <<< fun_def)
+		= show_component funs show_types fun_defs (file <<< fun_def)
+//		= show_component funs show_types fun_defs (file <<< fun_def.fun_ident)
+show_component (GeneratedComponentMember fun _ funs) show_types fun_defs file
 	# (fun_def, fun_defs) = fun_defs![fun]
 	# file=file<<<fun<<<'\n'
 	| show_types

frontend/mergecases.icl

-/*
-	module owner: Ronny Wichers Schreur
-*/
 implementation module mergecases
 
 import syntax, transform, compare_types, utilities
@@ -147,7 +144,7 @@ where
 	
 	has_no_default No 		= True
 	has_no_default (Yes _) 	= False
-	
+
 	skip_alias var_info_ptr var_heap
 		= case sreadPtr var_info_ptr var_heap of
 			VI_Alias bv
@@ -209,7 +206,7 @@ where
 	new_variable fv=:{fv_ident, fv_info_ptr} var_heap
 		# (new_info_ptr, var_heap) = newPtr VI_Empty var_heap
 		= ({fv & fv_info_ptr = new_info_ptr}, var_heap <:= (fv_info_ptr, VI_Variable fv_ident new_info_ptr))
-		
+
 	rebuild_let_expression lad expr var_heap expr_heap
 		# (rev_let_lazy_binds, var_heap) = foldSt renew_let_var lad.let_lazy_binds ([], var_heap)
 		  (let_info_ptr, expr_heap) = newPtr EI_Empty expr_heap
@@ -373,14 +370,14 @@ where
 				= ([ pattern : patterns ], var_heap, symbol_heap, error)
 		merge_basic_pattern_with_patterns new_pattern [] var_heap symbol_heap error
 			= ([new_pattern], var_heap, symbol_heap, error)
-	
+
 	replace_variables vars expr ap_vars var_heap symbol_heap
 		# var_heap = build_aliases vars ap_vars var_heap
 		# us = { us_var_heap = var_heap, us_symbol_heap = symbol_heap, us_local_macro_functions = No }
 		  (expr, us) = unfold expr us
 		= (expr, us.us_var_heap, us.us_symbol_heap)
 	where
-		build_aliases [var1 : vars1] [ {fv_ident,fv_info_ptr} : vars2 ] var_heap
+		build_aliases [var1 : vars1] [{fv_ident,fv_info_ptr} : vars2] var_heap
 			= build_aliases vars1 vars2 (writePtr var1.fv_info_ptr (VI_Variable fv_ident fv_info_ptr) var_heap)
 		build_aliases [] [] var_heap
 			= var_heap

frontend/parse.icl

@@ -425,7 +425,7 @@ where
 		| ~(isGlobalContext parseContext)
 			= (False,abort "no def(3)",parseError "definition" No "imports only at the global level" pState)
 			# (imp, pState) = wantFromImports pState
-	   		= (True, PD_Import [imp], pState) -->> imp
+	   		= (True, PD_Import [imp], pState)
 	try_definition parseContext ClassToken pos pState
 		| ~(isGlobalContext parseContext)
 			= (False,abort "no def(2)",parseError "definition" No "class definitions are only at the global level" pState)
@@ -1131,7 +1131,7 @@ where
 			  (file_name, line_nr, pState)
 			  					= getFileAndLineNr pState
 			  (rhs_exp, pState) = wantExpression pState
-			  pState			= wantEndRootExpression pState -->> ("#",lhs_exp,"=",rhs_exp)
+			  pState			= wantEndRootExpression pState // -->> ("#",lhs_exp,"=",rhs_exp)
 	  	  	  (locals , pState) = optionalLocals WithToken localsExpected pState
 			=	( True
 				, {	ndwl_strict	= strict
@@ -1536,6 +1536,13 @@ optionalContext pState
 		= want_contexts pState
 		= ([], tokenBack pState)
 
+optional_constructor_context :: !ParseState -> ([TypeContext],ParseState)
+optional_constructor_context pState
+	# (token, pState) = nextToken TypeContext pState
+	| token == AndToken
+		= want_contexts pState
+		= ([], tokenBack pState)
+
 want_contexts :: ParseState -> ([TypeContext],ParseState)
 want_contexts pState
 	# (contexts, pState) = want_context pState
@@ -1926,8 +1933,9 @@ where
 		# token = basic_type_to_constructor token
 		# (pc_cons_ident,  pc_cons_prio, pc_cons_pos, pState) = want_cons_name_and_prio token pState
 		  (pc_arg_types, pState) = parseList tryBrackSAType pState
+		  (pc_context,pState) = optional_constructor_context pState
 		  cons = {	pc_cons_ident = pc_cons_ident, pc_arg_types = atypes_from_satypes pc_arg_types, pc_args_strictness=strictness_from_satypes pc_arg_types,
-		  			pc_cons_arity = length pc_arg_types, pc_cons_prio = pc_cons_prio, pc_exi_vars = exi_vars, pc_cons_pos = pc_cons_pos}
+		  			pc_context = pc_context, pc_cons_arity = length pc_arg_types, pc_cons_prio = pc_cons_prio, pc_exi_vars = exi_vars, pc_cons_pos = pc_cons_pos}
 		= (cons,pState)
 
 	want_newtype_constructor :: ![ATypeVar] !Token !ParseState -> (.ParsedConstructor,!ParseState)
@@ -1936,7 +1944,7 @@ where
 		  (pc_cons_ident,  pc_cons_prio, pc_cons_pos, pState) = want_cons_name_and_prio token pState
 		  (succ, pc_arg_type, pState) = trySimpleType TA_Anonymous pState
 		  cons = {	pc_cons_ident = pc_cons_ident, pc_arg_types = [pc_arg_type], pc_args_strictness = NotStrict,