store strictness annotations in SymbolType instead of AType

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

26 files changed, 1778 insertions, 798 deletions

diff --git a/backend/backendconvert.icl b/backend/backendconvert.icl
index 0e9d0a5..6a75b15 100644
--- a/backend/backendconvert.icl
+++ b/backend/backendconvert.icl
@@ -790,12 +790,14 @@ declareFunType moduleIndex nrOfDclFunctions functionIndex {ft_symb, ft_type_ptr}
 
 			functionName :: {#Char} Int Int -> {#Char}
 			functionName name functionIndex nrOfDclFunctions 
+//				| trace_tn (name+++(if (functionIndex < nrOfDclFunctions) "" (";" +++ toString functionIndex)))
+
 				| functionIndex < nrOfDclFunctions
 					=	name
 				// otherwise
 					=	name +++ ";" +++ toString functionIndex
 
-import StdDebug
+//import StdDebug
 
 /*
 declareCurrentDclModuleTypes :: {#CheckedTypeDef} {#Int} -> BackEnder
@@ -824,10 +826,13 @@ defineType moduleIndex constructors _ typeIndex {td_name, td_args, td_rhs=AlgTyp
 		=	convertConstructors typeIndex td_name.id_name moduleIndex constructors constructorSymbols be
 	=	appBackEnd (BEAlgebraicType flatType constructors) be
 defineType moduleIndex constructors selectors typeIndex {td_args, td_rhs=RecordType {rt_constructor, rt_fields}} be
+//	| trace_tn constructorDef.cons_symb
+
 	# (flatType, be)
 		=	convertTypeLhs moduleIndex typeIndex td_args be
 	# (fields, be)
-		=	convertSelectors moduleIndex selectors rt_fields be
+//		=	convertSelectors moduleIndex selectors rt_fields be
+		=	convertSelectors moduleIndex selectors rt_fields constructorDef.cons_type.st_args_strictness be
 	# (constructorType,be) = constructorTypeFunction be
 	# (constructorTypeNode, be)
 		=	beNormalTypeNode
@@ -875,15 +880,32 @@ convertConstructor typeIndex typeName moduleIndex constructorDefs {ds_index}
 						_
 							->	(constructorDef.cons_type,be)) // ->> (typeName, typeIndex, constructorDef.cons_symb.id_name, ds_index, constructorDef.cons_type)
 
-convertSelectors :: ModuleIndex {#SelectorDef} {#FieldSymbol} -> BEMonad BEFieldListP
-convertSelectors moduleIndex selectors symbols
-	=	foldrA (beFields o convertSelector moduleIndex selectors) beNoFields symbols
 
-convertSelector :: ModuleIndex {#SelectorDef} FieldSymbol -> BEMonad BEFieldListP
-convertSelector moduleIndex selectorDefs {fs_index}
+foldrAi function result array
+	:== foldrA 0
+	where
+		arraySize
+			=	size array
+		foldrA index
+			| index == arraySize
+				=	result
+			// otherwise
+				=	function index array.[index] (foldrA (index+1))
+
+//convertSelectors :: ModuleIndex {#SelectorDef} {#FieldSymbol} -> BEMonad BEFieldListP
+convertSelectors :: ModuleIndex {#SelectorDef} {#FieldSymbol} StrictnessList -> BEMonad BEFieldListP
+convertSelectors moduleIndex selectors symbols strictness
+//	=	foldrA (beFields o convertSelector moduleIndex selectors) beNoFields symbols
+	=	foldrAi (\i -> (beFields o convertSelector moduleIndex selectors (arg_is_strict i strictness))) beNoFields symbols
+
+//convertSelector :: ModuleIndex {#SelectorDef} FieldSymbol -> BEMonad BEFieldListP
+convertSelector :: ModuleIndex {#SelectorDef} Bool FieldSymbol -> BEMonad BEFieldListP
+//convertSelector moduleIndex selectorDefs {fs_index}
+convertSelector moduleIndex selectorDefs is_strict {fs_index}
 	= \be0 -> let (selectorType,be) = selectorTypeFunction be0 in
 		(	appBackEnd (BEDeclareField fs_index moduleIndex selectorDef.sd_symb.id_name)
-		o`	beField fs_index moduleIndex (convertAnnotTypeNode (selectorType.st_result))) be
+//		o`	beField fs_index moduleIndex (convertAnnotTypeNode (selectorType.st_result))) be
+		o`	beField fs_index moduleIndex (convertAnnotAndTypeNode (if is_strict AN_Strict AN_None) (selectorType.st_result))) be
 	where
 		selectorDef
 			=	selectorDefs.[fs_index]
@@ -1238,6 +1260,7 @@ convertRules rules main_dcl_module_n aliasDummyId be
 
 convertRule :: Ident (Int,FunDef) Int -> BEMonad BEImpRuleP
 convertRule aliasDummyId (index, {fun_type=Yes type, fun_body=body, fun_pos, fun_kind, fun_symb}) main_dcl_module_n
+//	| trace_tn fun_symb.id_name
 	=	beRule index (cafness fun_kind)
 			(convertTypeAlt index main_dcl_module_n (type -*-> ("convertRule", fun_symb.id_name, index, type)))
 			(convertFunctionBody index (positionToLineNumber fun_pos) aliasDummyId body main_dcl_module_n)
@@ -1324,8 +1347,9 @@ convertAttributeKind attributeVar
 	=	beAttributeKind (convertAttributeVar attributeVar)
 
 convertSymbolTypeArgs :: SymbolType -> BEMonad BETypeArgP
-convertSymbolTypeArgs {st_args}
-	=	convertTypeArgs st_args
+convertSymbolTypeArgs {st_args,st_args_strictness}
+//	=	convertTypeArgs st_args
+	= convertAnnotatedTypeArgs st_args st_args_strictness
 
 convertBasicTypeKind :: BasicType -> BESymbKind
 convertBasicTypeKind BT_Int
@@ -1392,7 +1416,7 @@ convertAttribution attr
 	=	abort "backendconvert, convertAttribution: unknown TypeAttribute" // <<- attr
 
 convertAnnotTypeNode :: AType -> BEMonad BETypeNodeP
-convertAnnotTypeNode {at_type, at_annotation, at_attribute}
+convertAnnotTypeNode {at_type, at_attribute}
 /*
 	=	convertTypeNode at_type
 	:-	beAnnotateTypeNode (convertAnnotation at_annotation)
@@ -1405,6 +1429,15 @@ convertAnnotTypeNode {at_type, at_annotation, at_attribute}
 	:-	beAttributeTypeNode c_attrib
 //	) s
 	where
+		c_annot = convertAnnotation AN_None // at_annotation
+		c_attrib = convertAttribution at_attribute
+
+convertAnnotAndTypeNode :: Annotation AType -> BEMonad BETypeNodeP
+convertAnnotAndTypeNode at_annotation {at_type, at_attribute}
+	= convertTypeNode at_type
+	:-	beAnnotateTypeNode c_annot
+	:-	beAttributeTypeNode c_attrib
+	where
 		c_annot = convertAnnotation at_annotation
 		c_attrib = convertAttribution at_attribute
 
@@ -1417,6 +1450,9 @@ convertTypeNode (TB basicType)
 	=	beNormalTypeNode (beBasicSymbol (convertBasicTypeKind basicType)) beNoTypeArgs	
 convertTypeNode (TA typeSymbolIdent typeArgs)
 	=	beNormalTypeNode (convertTypeSymbolIdent typeSymbolIdent) (convertTypeArgs typeArgs )
+convertTypeNode (TAS typeSymbolIdent typeArgs strictness)
+//	=	beNormalTypeNode (convertTypeSymbolIdent typeSymbolIdent) (convertTypeArgs typeArgs )
+	=	beNormalTypeNode (convertTypeSymbolIdent typeSymbolIdent) (convertAnnotatedTypeArgs typeArgs strictness)
 convertTypeNode (TV {tv_name})
 	=	beVarTypeNode tv_name.id_name
 convertTypeNode (TempQV n)
@@ -1426,7 +1462,7 @@ convertTypeNode (TempV n)
 convertTypeNode (a --> b) 
 	=	beNormalTypeNode (beBasicSymbol BEFunType) (convertTypeArgs [a, b])
 convertTypeNode (a :@: b)
-	=	beNormalTypeNode (beBasicSymbol BEApplySymb) (convertTypeArgs [{at_attribute=TA_Multi, at_annotation=AN_None, at_type = consVariableToType a} : b])
+	=	beNormalTypeNode (beBasicSymbol BEApplySymb) (convertTypeArgs [{at_attribute=TA_Multi, at_type = consVariableToType a} : b])
 convertTypeNode TE
 	=	beNormalTypeNode beDontCareDefinitionSymbol beNoTypeArgs
 convertTypeNode (TFA vars type)
@@ -1446,6 +1482,16 @@ convertTypeArgs :: [AType] -> BEMonad BETypeArgP
 convertTypeArgs args
 	=	sfoldr (beTypeArgs o convertAnnotTypeNode) beNoTypeArgs args
 
+convertAnnotatedTypeArgs :: [AType] StrictnessList -> BEMonad BETypeArgP
+convertAnnotatedTypeArgs args strictness
+	= foldr args 0
+	where
+		foldr [] i
+			= beNoTypeArgs
+		foldr [a:x] i
+//			| trace_tn (toString i+++" "+++toString (arg_strictness_annotation i strictness))
+			= (beTypeArgs o (convertAnnotAndTypeNode (arg_strictness_annotation i strictness))) a (foldr x (i+1))
+
 convertTransformedBody :: Int Int Ident TransformedBody Int -> BEMonad BERuleAltP
 convertTransformedBody functionIndex lineNumber aliasDummyId body main_dcl_module_n
 	| isCodeBlock body.tb_rhs
diff --git a/backend/backendinterface.icl b/backend/backendinterface.icl
index afb53af..45df650 100644
--- a/backend/backendinterface.icl
+++ b/backend/backendinterface.icl
@@ -99,6 +99,9 @@ printFunctionType :: Bool Bool DictionaryToClassInfo (Int, FunDef) (*AttrVarHeap
 printFunctionType all attr info (functionIndex, {fun_symb,fun_type=Yes type}) (attrHeap, file, backEnd)
 	| not all && functionIndex >= size info.dtic_dclModules.[info.dtci_iclModuleIndex].dcl_functions
 		=	(attrHeap, file, backEnd)
+
+//	| trace_tn (toString fun_symb) && True ---> type.st_args
+
 	# (strictnessAdded, type, backEnd)
 		=	addStrictnessFromBackEnd functionIndex fun_symb.id_name backEnd type
 	| not strictnessAdded && not all
@@ -127,6 +130,9 @@ addStrictnessFromBackEnd functionIndex functionName backEnd type
 		=	{si_robust_encoding = False, si_positions = strictPositions, si_size = bitSize, si_name = functionName}
 	  offset
 	  	=	0
+
+//	| trace_tn (toString bitSize+++" "+++toString strictPositions.[0])
+
 	# (robust, offset)
 		=	nextBit strictnessInfo offset
 	  strictnessInfo
@@ -134,11 +140,19 @@ addStrictnessFromBackEnd functionIndex functionName backEnd type
 	# (anyStrictnessAdded, offset)
 		=	nextBit strictnessInfo offset
 	# (type, offset)
-		=	addStrictness strictnessInfo type offset
+		=	addStrictnessToSymbolType strictnessInfo type offset
 	# type
 		=	checkFinalOffset strictnessInfo offset type
 	= (anyStrictnessAdded, type, backEnd)
 
+addStrictnessToSymbolType strictPositions=:{si_size} args offset
+	| offset >= si_size // short cut
+		=	(args, offset)
+addStrictnessToSymbolType strictPositions type=:{st_args,st_args_strictness} offset
+	# (st_args, offset,args_strictness)
+		=	addStrictness strictPositions st_args offset st_args_strictness 0
+	=	({type & st_args = st_args,st_args_strictness=args_strictness}, offset)
+
 :: StrictnessInfo =
 	{	si_size :: !Int
 	,	si_positions :: !LargeBitvect
@@ -146,7 +160,7 @@ addStrictnessFromBackEnd functionIndex functionName backEnd type
 	,	si_robust_encoding :: !Bool
 	}
 
-class addStrictness a :: !StrictnessInfo !a Int -> (!a, !Int)
+class addStrictness a :: !StrictnessInfo !a Int StrictnessList Int -> (!a, !Int,!StrictnessList)
 
 nextBit :: StrictnessInfo Int -> (Bool, Int)
 nextBit {si_size, si_positions, si_robust_encoding} offset
@@ -187,58 +201,64 @@ checkFinalOffset info=:{si_size, si_robust_encoding} offset value
 	// otherwise
 		=	value
 
-instance addStrictness SymbolType where
-	addStrictness strictPositions=:{si_size} args offset
-		| offset >= si_size // short cut
-			=	(args, offset)
-	addStrictness strictPositions type=:{st_args} offset
-		# (st_args, offset)
-			=	addStrictness strictPositions st_args offset
-		=	({type & st_args = st_args}, offset)
-
 instance addStrictness [a] | addStrictness a where
-	addStrictness strictPositions l offset
-		=	mapSt (addStrictness strictPositions) l offset
+	addStrictness strictPositions [] offset args_strictness args_strictness_index
+		= ([],offset,args_strictness)
+	addStrictness strictPositions [type:types] offset args_strictness args_strictness_index
+		# (type,offset,args_strictness)=addStrictness strictPositions type offset args_strictness args_strictness_index
+		# (types,offset,args_strictness)=addStrictness strictPositions types offset args_strictness (args_strictness_index+1)
+		= ([type:types],offset,args_strictness)
 
 instance addStrictness AType where
-	addStrictness strictPositions arg=:{at_annotation, at_type} offset
-		# (at_annotation, offset)
-			=	addStrictness strictPositions at_annotation offset
+	addStrictness strictPositions arg=:{at_type} offset args_strictness args_strictness_index
+		# (is_strict,offset,args_strictness)
+			=	addStrictnessAnnotation strictPositions offset args_strictness args_strictness_index
 		# (at_type, offset)
-			=	addStrictnessToType strictPositions (at_annotation == AN_Strict) at_type offset
-		=	({arg & at_annotation = at_annotation, at_type = at_type}, offset)
-
-instance addStrictness Annotation where
-	addStrictness info annotation offset
-		# offset
-			=	checkStrictness info wasStrict offset
-		# (strictAdded, offset)
-			=	nextBit info offset
-		| strictAdded
-			| wasStrict
+			=	addStrictnessToType strictPositions is_strict at_type offset
+		=	({arg & at_type=at_type}, offset,args_strictness)
+
+addStrictnessAnnotation info offset args_strictness args_strictness_index
+	# wasStrict = arg_is_strict args_strictness_index args_strictness
+	# offset
+		=	checkStrictness info wasStrict offset
+	# (strictAdded, offset)
+		=	nextBit info offset
+	| strictAdded
+		| wasStrict
 				=	abort "backendinterface, addStrictness: already strict"
-			// otherwise
-				=	(AN_Strict, offset)
 		// otherwise
-			=	(annotation, offset)
-		where
-			wasStrict
-				=	annotation == AN_Strict
+			# args_strictness = add_strictness args_strictness_index args_strictness
+			=	(True, offset,args_strictness)
+	// otherwise
+		=	(wasStrict, offset,args_strictness)
 
 addStrictnessToType :: StrictnessInfo Bool Type Int -> (Type, Int)
-addStrictnessToType strictPositions isStrict type=:(TA ident=:{type_name,type_arity} args) offset
+addStrictnessToType strictPositions isStrict type=:(TA ident=:{type_index={glob_object,glob_module}} args) offset
 	# offset
 		=	checkType strictPositions isTuple offset
 	| isTuple && isStrict
-		# (args, offset)
-			=	addStrictness strictPositions args offset
-		=	(TA ident args, offset)
+		# (args, offset,args_strictness)
+			=	addStrictness strictPositions args offset NotStrict 0
+		| is_not_strict args_strictness
+			=	(TA ident args, offset)
+			=	(TAS ident args args_strictness, offset)
 	// otherwise
 		=	(type, offset)
 	where
-		// FIXME: don't match on name but use predef info
 		isTuple
-			= type_name.id_name == "_Tuple" +++ toString type_arity
+			= glob_module==cPredefinedModuleIndex && (glob_object>=PD_Arity2TupleTypeIndex && glob_object<=PD_Arity32TupleTypeIndex)
+addStrictnessToType strictPositions isStrict type=:(TAS ident=:{type_index={glob_object,glob_module}} args strictness) offset
+	# offset
+		=	checkType strictPositions isTuple offset
+	| isTuple && isStrict
+		# (args, offset,strictness)
+			=	addStrictness strictPositions args offset strictness 0
+		=	(TAS ident args strictness, offset)
+	// otherwise
+		=	(type, offset)
+	where
+		isTuple
+			= glob_module==cPredefinedModuleIndex && (glob_object>=PD_Arity2TupleTypeIndex && glob_object<=PD_Arity32TupleTypeIndex)
 addStrictnessToType strictPositions _ type offset
 	# offset
 		=	checkType strictPositions False offset
@@ -274,6 +294,8 @@ instance collectAttrVars TypeAttribute where
 instance collectAttrVars Type where
 	collectAttrVars (TA _ types) collect
 		=	collectAttrVars types collect
+	collectAttrVars (TAS _ types _) collect
+		=	collectAttrVars types collect
 	collectAttrVars (type1 --> type2) collect
 		=	collectAttrVars type1 (collectAttrVars type2 collect)
 	collectAttrVars (TArrow1 type) collect
@@ -316,28 +338,54 @@ DictionaryToClassInfo iclModuleIndex iclModule dclModules :==
 	}
 
 dictionariesToClasses :: DictionaryToClassInfo SymbolType -> SymbolType
-dictionariesToClasses info type=:{st_args, st_arity, st_context=[]}
+dictionariesToClasses info type=:{st_args, st_args_strictness, st_arity, st_context=[]}
 	# (reversedTypes, reversedContexts)
 		=	dictionaryArgsToClasses info st_args ([], [])
+	# n_contexts = length reversedContexts
+	# new_st_args_strictness = remove_first_n_strictness_values n_contexts st_args_strictness
+		with
+			remove_first_n_strictness_values 0 s
+				= s
+			remove_first_n_strictness_values _ NotStrict
+				= NotStrict
+			remove_first_n_strictness_values n (Strict s)
+				| n<32
+					 = Strict (((s>>1) bitand 0x7fffffff)>>(n-1))
+					 = NotStrict
+			remove_first_n_strictness_values n (StrictList s l)
+				| n<32
+					# s2=case l of
+							Strict s -> s
+							StrictList s _ -> s
+							NotStrict -> 0
+					# s=(((s>>1) bitand 0x7fffffff)>>(n-1)) bitor (s2<<(32-n))
+					= StrictList s (remove_first_n_strictness_values n l)
+					= remove_first_n_strictness_values (n-32) l
 	=	{type & st_args = reverse reversedTypes, st_context = reverse reversedContexts,
-				st_arity = st_arity - length reversedContexts}
+				st_arity = st_arity - n_contexts, st_args_strictness=new_st_args_strictness}
 
 dictionaryArgsToClasses :: DictionaryToClassInfo [AType] ([AType], [TypeContext]) -> ([AType], [TypeContext])
 dictionaryArgsToClasses info args result
 	=	foldSt (dictionaryArgToClass info) args result
-
-dictionaryArgToClass :: DictionaryToClassInfo AType ([AType], [TypeContext]) -> ([AType], [TypeContext])
-dictionaryArgToClass info type=:{at_type=TA typeSymbol args} (reversedTypes, reversedContexts)
-	=	case typeToClass info typeSymbol of
-			Yes klass
-				->	(reversedTypes, [context : reversedContexts])
-				with
-					context	
-						=	{tc_class = klass, tc_types = [at_type \\ {at_type} <- args], tc_var = nilPtr}
-			No
-				->	([type : reversedTypes], reversedContexts)
-dictionaryArgToClass _ type (reversedTypes, reversedContexts)
-	=	([type : reversedTypes], reversedContexts)
+where
+	dictionaryArgToClass :: DictionaryToClassInfo AType ([AType], [TypeContext]) -> ([AType], [TypeContext])
+	dictionaryArgToClass info type=:{at_type=TA typeSymbol args} (reversedTypes, reversedContexts)
+		=	case typeToClass info typeSymbol of
+				Yes klass
+					->	(reversedTypes, [dictionary_to_context klass args : reversedContexts])
+				No
+					->	([type : reversedTypes], reversedContexts)
+	dictionaryArgToClass info type=:{at_type=TAS typeSymbol args _} (reversedTypes, reversedContexts)
+		=	case typeToClass info typeSymbol of
+				Yes klass
+					->	(reversedTypes, [dictionary_to_context klass args : reversedContexts])
+				No
+					->	([type : reversedTypes], reversedContexts)
+	dictionaryArgToClass _ type (reversedTypes, reversedContexts)
+		=	([type : reversedTypes], reversedContexts)
+	
+	dictionary_to_context klass args
+		=	{tc_class = klass, tc_types = [at_type \\ {at_type} <- args], tc_var = nilPtr}
 
 typeToClass :: DictionaryToClassInfo TypeSymbIdent -> Optional (Global DefinedSymbol)
 typeToClass info {type_name, type_arity, type_index={glob_module, glob_object}}
diff --git a/frontend/StdCompare.icl b/frontend/StdCompare.icl
index e14b52f..7495abf 100644
--- a/frontend/StdCompare.icl
+++ b/frontend/StdCompare.icl
@@ -81,6 +81,12 @@ where
 			= arg_type1 == arg_type2 && restype1 == restype2
 		equal_constructor_args (TA tc1 types1) (TA tc2 types2)
 			= tc1 == tc2 && types1 == types2
+		equal_constructor_args (TA tc1 types1) (TAS tc2 types2 _)
+			= tc1 == tc2 && types1 == types2
+		equal_constructor_args (TAS tc1 types1 _) (TA tc2 types2)
+			= tc1 == tc2 && types1 == types2
+		equal_constructor_args (TAS tc1 types1 _) (TAS tc2 types2 _)
+			= tc1 == tc2 && types1 == types2
 		equal_constructor_args (TB tb1) (TB tb2)
 			= tb1 == tb2
 		equal_constructor_args (type1 :@: types1) (type2 :@: types2)
@@ -236,6 +242,9 @@ where
 	where
 		compare_arguments (TB tb1) (TB tb2)		= tb1 =< tb2 
 		compare_arguments (TA tc1 _) (TA tc2 _)	= tc1 =< tc2
+		compare_arguments (TA tc1 _) (TAS tc2 _ _)	= tc1 =< tc2
+		compare_arguments (TAS tc1 _ _) (TA tc2 _)	= tc1 =< tc2
+		compare_arguments (TAS tc1 _ _) (TAS tc2 _ _)	= tc1 =< tc2
 		compare_arguments _ _					= Equal
 
 smallerOrEqual :: !Type !Type -> CompareValue
@@ -251,6 +260,21 @@ smallerOrEqual t1 t2
 			| cmp_app_symb==Equal
 				= args1 =< args2
 			= cmp_app_symb
+		compare_arguments (TA tc1 args1) (TAS tc2 args2 _)
+			# cmp_app_symb = tc1 =< tc2
+			| cmp_app_symb==Equal
+				= args1 =< args2
+			= cmp_app_symb
+		compare_arguments (TAS tc1 args1 _) (TA tc2 args2)
+			# cmp_app_symb = tc1 =< tc2
+			| cmp_app_symb==Equal
+				= args1 =< args2
+			= cmp_app_symb
+		compare_arguments (TAS tc1 args1 _) (TAS tc2 args2 _)
+			# cmp_app_symb = tc1 =< tc2
+			| cmp_app_symb==Equal
+				= args1 =< args2
+			= cmp_app_symb
 		compare_arguments (l1 --> r1) (l2 --> r2)
 			# cmp_app_symb = l1 =< l2
 			| cmp_app_symb==Equal
diff --git a/frontend/analtypes.icl b/frontend/analtypes.icl
index 434c5a8..e82b354 100644
--- a/frontend/analtypes.icl
+++ b/frontend/analtypes.icl
@@ -106,7 +106,14 @@ where
 				_
 					-> (type_defs, main_dcl_type_defs, type_heaps, error)
 
-		try_to_expand_synonym_type pos type=:{at_type = TA {type_name,type_index={glob_object,glob_module}} types} attribute (type_defs, type_heaps, error)
+		try_to_expand_synonym_type pos type=:{at_type = TA {type_index={glob_object,glob_module}} types} attribute (type_defs, type_heaps, error)
+			= try_to_expand_synonym_type_for_TA glob_object glob_module types pos type attribute type_defs type_heaps error
+		try_to_expand_synonym_type pos type=:{at_type = TAS {type_index={glob_object,glob_module}} types _} attribute (type_defs, type_heaps, error)
+			= try_to_expand_synonym_type_for_TA glob_object glob_module types pos type attribute type_defs type_heaps error
+		try_to_expand_synonym_type pos type attribute (type_defs, type_heaps, error)
+			= (No, type_defs, type_heaps, error)
+
+		try_to_expand_synonym_type_for_TA glob_object glob_module types pos type attribute type_defs type_heaps error
 			# (used_td=:{td_rhs}, type_defs) = type_defs![glob_module, glob_object]
 			= case td_rhs of
 				SynType {at_type}
@@ -117,8 +124,6 @@ where
 						-> (No, type_defs, type_heaps, error)
 				_
 					-> (No, type_defs, type_heaps, error)
-		try_to_expand_synonym_type pos type attribute (type_defs, type_heaps, error)
-			= (No, type_defs, type_heaps, error)
 
 		try_to_expand_synonym_type_in_main_dcl main_dcl_module_index {gi_module,gi_index} (type_defs, main_dcl_type_defs, type_heaps, error)
 			| main_dcl_module_index == main_dcl_module_index && gi_index < size main_dcl_type_defs
@@ -365,52 +370,58 @@ where
 			= (kind_info, cIsHyperStrict, ({ conds & con_var_binds = [{vb_var = kind_info_ptr, vb_vars = form_tvs } : con_var_binds] },
 						 { as & as_type_var_heap = as_type_var_heap, as_kind_heap = as_kind_heap }))
 
+analTypes_for_TA :: Ident Int Int Int [AType] !Bool !{#CommonDefs} ![KindInfoPtr] !Conditions !*AnalyseState
+	-> (!KindInfo, !TypeProperties, !(!Conditions, !*AnalyseState))
+analTypes_for_TA type_name glob_module glob_object type_arity types has_root_attr modules form_tvs conds as
+	# form_type_arity = modules.[glob_module].com_type_defs.[glob_object].td_arity
+	  ({tdi_kinds, tdi_properties}, as) = as!as_td_infos.[glob_module].[glob_object]
+	| type_arity <= form_type_arity
+		# kind = kindArrowToKindInfo (drop type_arity tdi_kinds)
+		| tdi_properties bitand cIsAnalysed == 0
+			# (type_properties, conds_as) = anal_types_of_rec_type_cons modules form_tvs types tdi_kinds (conds, as)
+			= (kind, type_properties, conds_as)
+			# (type_properties, conds_as) = anal_types_of_type_cons modules form_tvs types tdi_kinds (conds, as)
+			= (kind, type_properties, conds_as)
+		= (KI_Const, tdi_properties, (conds, { as & as_error = checkError type_name type_appl_error as.as_error }))
+where
+	anal_types_of_rec_type_cons modules form_tvs [] _ conds_as
+		= (cIsHyperStrict, conds_as)
+	anal_types_of_rec_type_cons modules form_tvs [type : types] [(KindVar kind_info_ptr) : tvs] conds_as
+		# (type_kind, type_props, (conds, as=:{as_kind_heap,as_error})) = analTypes has_root_attr modules [ kind_info_ptr : form_tvs ] type conds_as
+		  (kind, as_kind_heap) = readPtr kind_info_ptr as_kind_heap
+		  {uki_kind_heap, uki_error} = unifyKinds type_kind kind {uki_kind_heap = as_kind_heap, uki_error = as_error}
+		| is_type_var type
+			# (other_type_props, conds_as) = anal_types_of_rec_type_cons modules form_tvs types tvs
+					(conds, { as & as_kind_heap = uki_kind_heap, as_error = uki_error })
+			= (combineTypeProperties type_props other_type_props, conds_as)
+			# (other_type_props, conds_as) =  anal_types_of_rec_type_cons modules form_tvs types tvs
+					({ conds & con_top_var_binds = [kind_info_ptr : conds.con_top_var_binds]}, { as & as_kind_heap = uki_kind_heap, as_error = uki_error })
+			= (combineTypeProperties type_props other_type_props, conds_as)
+	where
+		is_type_var {at_type = TV _}
+			= True
+		is_type_var _
+			= False
+		
+	anal_types_of_type_cons modules form_tvs [] _ conds_as
+		= (cIsHyperStrict, conds_as)
+	anal_types_of_type_cons modules form_tvs [type : types] [tk : tks] conds_as
+		# (type_kind, type_props, (conds, as=:{as_kind_heap,as_error})) = analTypes has_root_attr modules form_tvs type conds_as
+		  {uki_kind_heap, uki_error} = unifyKinds type_kind (kindToKindInfo tk) {uki_kind_heap = as_kind_heap, uki_error = as_error}
+		  as = { as & as_kind_heap = uki_kind_heap, as_error = uki_error }
+		  (other_type_props, conds_as) =  anal_types_of_type_cons modules form_tvs types tks (conds, as)
+		= (combineTypeProperties type_props other_type_props, conds_as)
+	anal_types_of_type_cons modules form_tvs types tks conds_as
+		= abort ("anal_types_of_type_cons (analtypes.icl)" ---> (types, tks))
+
 instance analTypes Type
 where
 	analTypes has_root_attr modules form_tvs (TV tv) conds_as
 		= analTypes has_root_attr modules form_tvs tv conds_as
 	analTypes has_root_attr modules form_tvs type=:(TA {type_name,type_index={glob_module,glob_object},type_arity} types) (conds, as)
-		# form_type_arity = modules.[glob_module].com_type_defs.[glob_object].td_arity
-		  ({tdi_kinds, tdi_properties}, as) = as!as_td_infos.[glob_module].[glob_object]
-		| type_arity <= form_type_arity
-			# kind = kindArrowToKindInfo (drop type_arity tdi_kinds)
-			| tdi_properties bitand cIsAnalysed == 0
-				# (type_properties, conds_as) = anal_types_of_rec_type_cons modules form_tvs types tdi_kinds (conds, as)
-				= (kind, type_properties, conds_as)
-				# (type_properties, conds_as) = anal_types_of_type_cons modules form_tvs types tdi_kinds (conds, as)
-				= (kind, type_properties, conds_as)
-			= (KI_Const, tdi_properties, (conds, { as & as_error = checkError type_name type_appl_error as.as_error }))
-	where
-		anal_types_of_rec_type_cons modules form_tvs [] _ conds_as
-			= (cIsHyperStrict, conds_as)
-		anal_types_of_rec_type_cons modules form_tvs [type : types] [(KindVar kind_info_ptr) : tvs] conds_as
-			# (type_kind, type_props, (conds, as=:{as_kind_heap,as_error})) = analTypes has_root_attr modules [ kind_info_ptr : form_tvs ] type conds_as
-			  (kind, as_kind_heap) = readPtr kind_info_ptr as_kind_heap
-			  {uki_kind_heap, uki_error} = unifyKinds type_kind kind {uki_kind_heap = as_kind_heap, uki_error = as_error}
-			| is_type_var type
-				# (other_type_props, conds_as) = anal_types_of_rec_type_cons modules form_tvs types tvs
-						(conds, { as & as_kind_heap = uki_kind_heap, as_error = uki_error })
-				= (combineTypeProperties type_props other_type_props, conds_as)
-				# (other_type_props, conds_as) =  anal_types_of_rec_type_cons modules form_tvs types tvs
-						({ conds & con_top_var_binds = [kind_info_ptr : conds.con_top_var_binds]}, { as & as_kind_heap = uki_kind_heap, as_error = uki_error })
-				= (combineTypeProperties type_props other_type_props, conds_as)
-		where
-			is_type_var {at_type = TV _}
-				= True
-			is_type_var _
-				= False
-			
-		anal_types_of_type_cons modules form_tvs [] _ conds_as
-			= (cIsHyperStrict, conds_as)
-		anal_types_of_type_cons modules form_tvs [type : types] [tk : tks] conds_as
-			# (type_kind, type_props, (conds, as=:{as_kind_heap,as_error})) = analTypes has_root_attr modules form_tvs type conds_as
-			  {uki_kind_heap, uki_error} = unifyKinds type_kind (kindToKindInfo tk) {uki_kind_heap = as_kind_heap, uki_error = as_error}
-			  as = { as & as_kind_heap = uki_kind_heap, as_error = uki_error }
-			  (other_type_props, conds_as) =  anal_types_of_type_cons modules form_tvs types tks (conds, as)
-			= (combineTypeProperties type_props other_type_props, conds_as)
-		anal_types_of_type_cons modules form_tvs types tks conds_as
-			= abort ("anal_types_of_type_cons (analtypes.icl)" ---> (types, tks))
-		
+		= analTypes_for_TA type_name glob_module glob_object type_arity types has_root_attr modules form_tvs conds as
+	analTypes has_root_attr modules form_tvs type=:(TAS {type_name,type_index={glob_module,glob_object},type_arity} types _) (conds, as)
+		= analTypes_for_TA type_name glob_module glob_object type_arity types has_root_attr modules form_tvs conds as
 	analTypes has_root_attr modules form_tvs (arg_type --> res_type) conds_as
 		# (arg_kind, arg_type_props, conds_as) = analTypes has_root_attr modules form_tvs arg_type conds_as
 		  (res_kind, res_type_props, (conds, as=:{as_kind_heap,as_error})) = analTypes has_root_attr modules form_tvs res_type conds_as
@@ -475,7 +486,7 @@ cDummyBool :== False
 analTypesOfConstructor modules cons_defs [{ds_index}:conses] (conds, as=:{as_type_var_heap,as_kind_heap})
 	# {cons_exi_vars,cons_type} = cons_defs.[ds_index ]
 	  (coercible, as_type_var_heap, as_kind_heap) = new_local_kind_variables cons_exi_vars (as_type_var_heap, as_kind_heap)
-	  (cons_properties, conds_as) = anal_types_of_cons modules cons_type.st_args
+	  (cons_properties, conds_as) = anal_types_of_cons modules cons_type.st_args cons_type.st_args_strictness 0
 			(conds, { as & as_type_var_heap = as_type_var_heap, as_kind_heap = as_kind_heap })
 	  (other_properties, conds_as) = analTypesOfConstructor modules cons_defs conses conds_as
 	  properties = combineTypeProperties cons_properties other_properties
@@ -494,23 +505,17 @@ where
 		is_not_a_variable (TA_RootVar var)	= False
 		is_not_a_variable attr				= True
 			
-	anal_types_of_cons modules [] conds_as
+	anal_types_of_cons modules [] args_strictness strictness_index conds_as
 		= (cIsHyperStrict, conds_as)
-	anal_types_of_cons modules [type : types] conds_as
-		# (other_type_props, conds_as) = anal_types_of_cons modules types conds_as
+	anal_types_of_cons modules [type : types] args_strictness strictness_index conds_as
+		# (other_type_props, conds_as) = anal_types_of_cons modules types args_strictness (strictness_index+1) conds_as
 		  (type_kind, cv_props, (conds, as=:{as_kind_heap, as_error})) = analTypes cDummyBool modules [] type conds_as
 		  {uki_kind_heap, uki_error} = unifyKinds type_kind KI_Const {uki_kind_heap = as_kind_heap, uki_error = as_error}
-		  cons_props = if	(type_is_strict type.at_annotation)
+		  cons_props = if (arg_is_strict strictness_index args_strictness)
 							(combineTypeProperties cv_props other_type_props)
 							(combineCoercionProperties cv_props other_type_props)
 		= (cons_props, (conds, { as & as_kind_heap = uki_kind_heap, as_error = uki_error }))
 
-	where 
-		type_is_strict AN_Strict
-			= True
-		type_is_strict annot
-			= False
-
 analTypesOfConstructor _ _ [] conds_as
 	= (cIsHyperStrict, conds_as)
 
@@ -957,25 +962,31 @@ instance isUnique AType
 instance isUnique Type
   where
 	isUnique common_defs (TA {type_index={glob_module, glob_object}} type_args) (td_infos, th_vars)
-		# type_def
-				= common_defs.[glob_module].com_type_defs.[glob_object]
-		| isUniqueAttr type_def.td_attribute
-			= (True, (td_infos, th_vars))
-		# (prop_classification, th_vars, td_infos)
-				= propClassification glob_object glob_module (repeatn type_def.td_arity 0)
-						common_defs th_vars td_infos
-		  (uniqueness_of_args, (td_infos, th_vars))
-		  		= mapSt (isUnique common_defs) type_args (td_infos, th_vars)
-		= (unique_if_arg_is_unique_and_propagating uniqueness_of_args prop_classification, (td_infos, th_vars))
-	  where
-		unique_if_arg_is_unique_and_propagating [] _
-			= False
-		unique_if_arg_is_unique_and_propagating [is_unique_argument:rest] prop_classification
-			| isOdd prop_classification /*MW:cool!*/ && is_unique_argument
-				= True
-			= unique_if_arg_is_unique_and_propagating rest (prop_classification>>1)
+		= isUnique_for_TA glob_module glob_object type_args common_defs td_infos th_vars
+	isUnique common_defs (TAS {type_index={glob_module, glob_object}} type_args _) (td_infos, th_vars)
+		= isUnique_for_TA glob_module glob_object type_args common_defs td_infos th_vars
 	isUnique common_defs _ state
 		= (False, state)
 
+isUnique_for_TA :: Int Int [AType] !{# CommonDefs} !*TypeDefInfos !*TypeVarHeap -> (!Bool, !(!*TypeDefInfos, !*TypeVarHeap))
+isUnique_for_TA glob_module glob_object type_args common_defs td_infos th_vars
+	# type_def
+			= common_defs.[glob_module].com_type_defs.[glob_object]
+	| isUniqueAttr type_def.td_attribute
+		= (True, (td_infos, th_vars))
+	# (prop_classification, th_vars, td_infos)
+			= propClassification glob_object glob_module (repeatn type_def.td_arity 0)
+					common_defs th_vars td_infos
+	  (uniqueness_of_args, (td_infos, th_vars))
+	  		= mapSt (isUnique common_defs) type_args (td_infos, th_vars)
+	= (unique_if_arg_is_unique_and_propagating uniqueness_of_args prop_classification, (td_infos, th_vars))
+  where
+	unique_if_arg_is_unique_and_propagating [] _
+		= False
+	unique_if_arg_is_unique_and_propagating [is_unique_argument:rest] prop_classification
+		| isOdd prop_classification && is_unique_argument
+			= True
+		= unique_if_arg_is_unique_and_propagating rest (prop_classification>>1)
+
 isUniqueAttr TA_Unique = True
 isUniqueAttr _ = False
diff --git a/frontend/analunitypes.icl b/frontend/analunitypes.icl
index eec067d..e59b98e 100644
--- a/frontend/analunitypes.icl
+++ b/frontend/analunitypes.icl
@@ -236,12 +236,8 @@ where
 UseTopSign		:== True
 DontUSeTopSign	:== False
 
-signClassOfType :: !Type !Sign !Bool !Int !{#CommonDefs} !*SignClassState -> (!SignClassification,!SignClassification,!*SignClassState)
-signClassOfType (TV tv) sign use_top_sign group_nr ci scs
-	# (sign_class, type_class, scs) = signClassOfTypeVariable tv ci scs
-	= (sign *+ sign_class, type_class, scs)
-
-signClassOfType (TA {type_index = {glob_module, glob_object}} types) sign use_top_sign group_nr ci scs
+signClassOfType_for_TA :: Int Int [AType] !Sign !Bool !Int !{#CommonDefs} !*SignClassState -> (!SignClassification,!SignClassification,!*SignClassState)
+signClassOfType_for_TA glob_module glob_object types sign use_top_sign group_nr ci scs
 	# (td_info=:{tdi_group_nr,tdi_index_in_group,tdi_kinds}, scs) = scs!scs_type_def_infos.[glob_module].[glob_object]
 	| tdi_group_nr == group_nr
 		= sign_class_of_type_list_of_rec_type types sign use_top_sign tdi_index_in_group ci [] scs 
@@ -282,6 +278,17 @@ where
 	adjust_sign_class {sc_pos_vect,sc_neg_vect} arity
 		= { sc_pos_vect = sc_pos_vect >> arity, sc_neg_vect = sc_neg_vect >> arity }
 
+signClassOfType :: !Type !Sign !Bool !Int !{#CommonDefs} !*SignClassState -> (!SignClassification,!SignClassification,!*SignClassState)
+signClassOfType (TV tv) sign use_top_sign group_nr ci scs
+	# (sign_class, type_class, scs) = signClassOfTypeVariable tv ci scs
+	= (sign *+ sign_class, type_class, scs)
+
+signClassOfType (TA {type_index = {glob_module, glob_object}} types) sign use_top_sign group_nr ci scs
+	= signClassOfType_for_TA glob_module glob_object types sign use_top_sign group_nr ci scs
+
+signClassOfType (TAS {type_index = {glob_module, glob_object}} types _) sign use_top_sign group_nr ci scs
+	= signClassOfType_for_TA glob_module glob_object types sign use_top_sign group_nr ci scs
+
 signClassOfType (CV tv :@: types) sign use_top_sign group_nr ci scs
 	# (sign_class, type_class, scs) = signClassOfTypeVariable tv ci scs
 	  (sign_class, scs) = sign_class_of_type_list types sign use_top_sign group_nr type_class 0 sign_class ci scs
@@ -487,11 +494,8 @@ propClassOfTypeVariable {tv_info_ptr} ci pcs=:{pcs_type_var_heap}
 		_
 			-> (NoPropClass, PropClass, pcs)
 
-propClassOfType :: !Type !Int !{#CommonDefs} !*PropClassState -> (!PropClassification, !PropClassification, !*PropClassState)
-propClassOfType (TV tv) _ ci pcs
-	= propClassOfTypeVariable tv ci pcs
-
-propClassOfType (TA {type_name,type_index = {glob_module, glob_object}} types) group_nr ci pcs
+propClassOfType_for_TA :: Int Int [AType] !Int !{#CommonDefs} !*PropClassState -> (!PropClassification, !PropClassification, !*PropClassState)
+propClassOfType_for_TA glob_module glob_object types group_nr ci pcs
 	# (td_info=:{tdi_group_nr,tdi_index_in_group,tdi_kinds}, pcs) = pcs!pcs_type_def_infos.[glob_module].[glob_object]
 	| tdi_group_nr == group_nr
 		= prop_class_of_type_list_of_rec_type types tdi_index_in_group ci [] pcs 
@@ -531,6 +535,16 @@ where
 	determine_cummulative_prop [] _ prop_class hio_prop_classes type_index group_nr ci cumm_class pcs
 		= (cumm_class, pcs)
 
+propClassOfType :: !Type !Int !{#CommonDefs} !*PropClassState -> (!PropClassification, !PropClassification, !*PropClassState)
+propClassOfType (TV tv) _ ci pcs
+	= propClassOfTypeVariable tv ci pcs
+
+propClassOfType (TA {type_index = {glob_module, glob_object}} types) group_nr ci pcs
+	= propClassOfType_for_TA glob_module glob_object types group_nr ci pcs
+
+propClassOfType (TAS {type_index = {glob_module, glob_object}} types _) group_nr ci pcs
+	= propClassOfType_for_TA glob_module glob_object types group_nr ci pcs
+
 propClassOfType (CV tv :@: types) group_nr ci pcs
 	# (prop_class, type_class, pcs) = propClassOfTypeVariable tv ci pcs
 	  (prop_class, pcs) = prop_class_of_type_list types type_class 0 group_nr ci prop_class pcs
diff --git a/frontend/check.icl b/frontend/check.icl
index b44311b..a206af6 100644
--- a/frontend/check.icl
+++ b/frontend/check.icl
@@ -578,13 +578,19 @@ where
 		= state
 		
 	must_not_be_essentially_unique x_main_dcl_module_n {tv_name, tv_info_ptr} th_vars modules type_defs error
-		# (TVI_Type type, th_vars)
-				= readPtr tv_info_ptr th_vars
+		# (TVI_Type type, th_vars) = readPtr tv_info_ptr th_vars
 		= case type of
 			TA {type_name, type_index} _
+				-> must_not_be_essentially_unique_for_TA type_name type_index th_vars
+			TAS {type_name, type_index} _ _
+				-> must_not_be_essentially_unique_for_TA type_name type_index th_vars
+			_
+				-> (False, th_vars, modules, type_defs, error)
+		where
+			must_not_be_essentially_unique_for_TA type_name type_index th_vars
 				# (type_def, type_defs, modules)
 						= getTypeDef x_main_dcl_module_n type_index type_defs modules
-				-> case type_def.td_attribute of
+				= case type_def.td_attribute of
 					TA_Unique
 						-> (True, th_vars, modules, type_defs,
 							checkError type_name 
@@ -595,9 +601,7 @@ where
 						   )
 					_
 						-> (False, th_vars, modules, type_defs, error)
-			_
-				-> (False, th_vars, modules, type_defs, error)
-
+		
 getTypeDef :: !Index !(Global Index) !v:{#CheckedTypeDef} !w:{#DclModule}
 		-> (!CheckedTypeDef, !v:{#CheckedTypeDef}, !w:{#DclModule})
 getTypeDef x_main_dcl_module_n {glob_module,glob_object} type_defs modules
@@ -640,8 +644,9 @@ where
 				# empty_st = 
 					{	st_vars = []
 					,	st_args = []
+					,	st_args_strictness=NotStrict
 					,	st_arity = -1
-					,	st_result = {at_type=TE, at_attribute=TA_None, at_annotation=AN_None}
+					,	st_result = {at_type=TE, at_attribute=TA_None}
 					,	st_context = []
 					,	st_attr_vars = []
 					,	st_attr_env = []
@@ -1277,7 +1282,7 @@ renumber_icl_definitions_as_dcl_definitions (Yes icl_to_dcl_index_table) icl_siz
 				# dummy_ident = {id_name="",id_info=nilPtr}
 				# com_type_defs=reorder_and_enlarge_array com_type_defs n_dictionary_types icl_to_dcl_index_table.[cTypeDefs]
 									{td_name=dummy_ident,td_index= -1,td_arity=0,td_args=[],td_attrs=[],td_context=[],td_rhs=UnknownType,td_attribute=TA_None,td_pos=NoPos,td_used_types=[]}
-				# dummy_symbol_type={st_vars=[],st_args=[],st_arity=0,st_result={at_attribute=TA_None,at_annotation=AN_None,at_type=TE},st_context=[],st_attr_vars=[],st_attr_env=[]}
+				# dummy_symbol_type={st_vars=[],st_args=[],st_args_strictness=NotStrict,st_arity=0,st_result={at_attribute=TA_None,at_type=TE},st_context=[],st_attr_vars=[],st_attr_env=[]}
 				# com_selector_defs=reorder_and_enlarge_array com_selector_defs n_dictionary_selectors icl_to_dcl_index_table.[cSelectorDefs]
 					 				{sd_symb=dummy_ident,sd_field=dummy_ident,sd_type=dummy_symbol_type,sd_exi_vars=[],sd_field_nr=0,sd_type_index=0,sd_type_ptr=nilPtr,sd_pos=NoPos}
 				# com_cons_defs=reorder_and_enlarge_array com_cons_defs n_dictionary_constructors icl_to_dcl_index_table.[cConstructorDefs]
@@ -2413,24 +2418,34 @@ where
 elemTypeIsStrict [TA {type_index={glob_object,glob_module}} _ : _] predef_symbols
 	= glob_module == predef_symbols.[PD_PredefinedModule].pds_def &&
 		(glob_object == predef_symbols.[PD_StrictArrayType].pds_def || glob_object == predef_symbols.[PD_UnboxedArrayType].pds_def)
+elemTypeIsStrict [TAS {type_index={glob_object,glob_module}} _ _ : _] predef_symbols
+	= glob_module == predef_symbols.[PD_PredefinedModule].pds_def &&
+		(glob_object == predef_symbols.[PD_StrictArrayType].pds_def || glob_object == predef_symbols.[PD_UnboxedArrayType].pds_def)
 
 makeElemTypeOfArrayFunctionStrict :: !SymbolType !Index !{# Index} -> SymbolType
-makeElemTypeOfArrayFunctionStrict st=:{st_args,st_result} me_offset offset_table
+makeElemTypeOfArrayFunctionStrict st=:{st_args,st_args_strictness,st_result} me_offset offset_table
 	# array_fun_kind = offset_table.[me_offset]
 	| array_fun_kind == PD_UnqArraySelectFun
-		# (TA tuple [elem : res_array]) = st_result.at_type
-		= { st & st_result = { st_result &  at_type = TA tuple [{ elem & at_annotation = AN_Strict } : res_array]}}
+		= case st_result.at_type of
+			TA tuple elems
+				-> { st & st_result = { st_result & at_type = TAS tuple elems (Strict 1)}}
+			TAS tuple elems strictness
+				-> { st & st_result = { st_result & at_type = TAS tuple elems (add_strictness 0 strictness)}}
 	| array_fun_kind == PD_ArrayUpdateFun
 		# [array, index, elem: _] = st_args
-		= { st & st_args = [array, index, { elem & at_annotation = AN_Strict }] }
+		= { st & st_args_strictness=add_strictness 2 st_args_strictness,st_args = [array, index, elem ] }
 	| array_fun_kind == PD_CreateArrayFun
 		# [array, elem: _] = st_args
-		= { st & st_args = [array, { elem & at_annotation = AN_Strict }] }
+		= { st & st_args_strictness=add_strictness 1 st_args_strictness,st_args = [array, elem ] }
 	| array_fun_kind == PD_ArrayReplaceFun
 		# [arg_array, index, elem: _] = st_args
-		  (TA tuple [elem : res_array]) = st_result.at_type
-		= { st & st_args = [arg_array, index, { elem & at_annotation = AN_Strict }],
-					st_result = { st_result &  at_type = TA tuple [{ elem & at_annotation = AN_Strict } : res_array]}}
+		= case st_result.at_type of
+			 TA tuple elems
+				-> { st & st_args_strictness=add_strictness 2 st_args_strictness,st_args = [arg_array, index, elem],
+					st_result = { st_result &  at_type = TAS tuple elems (Strict 1)}}
+			 TAS tuple elems strictness
+				-> { st & st_args_strictness=add_strictness 2 st_args_strictness,st_args = [arg_array, index, elem],
+					st_result = { st_result &  at_type = TAS tuple elems (add_strictness 0 strictness)}}
 		= st
 
 initialDclModule ({mod_name, mod_modification_time, mod_defs=mod_defs=:{def_funtypes,def_macro_indices}, mod_type}, sizes, all_defs) module_n
diff --git a/frontend/checktypes.icl b/frontend/checktypes.icl
index 50079ce..7d85b2f 100644
--- a/frontend/checktypes.icl
+++ b/frontend/checktypes.icl
@@ -107,6 +107,9 @@ retrieveTypeDefinition type_ptr mod_index symbol_table used_types
 		_
 			-> ((NotFound, mod_index), symbol_table, used_types)
 
+determine_type_attribute TA_Unique		= TA_Unique
+determine_type_attribute _				= TA_Multi
+
 instance bindTypes Type
 where
 	bindTypes cti (TV tv) ts_ti_cs
@@ -128,10 +131,22 @@ where
 								determine_type_attribute td_attribute, ts_ti_cs)
 				= (TE, TA_Multi, (ts, ti, { cs & cs_error = checkError type_cons.type_name "used with wrong arity" cs.cs_error }))
 			= (TE, TA_Multi, (ts, ti, { cs & cs_error = checkError type_cons.type_name "undefined" cs.cs_error}))
-	where
-		determine_type_attribute TA_Unique		= TA_Unique
-		determine_type_attribute _				= TA_Multi
-	
+	bindTypes cti=:{cti_module_index,cti_type_index,cti_lhs_attribute} type=:(TAS type_cons=:{type_name=type_name=:{id_info}} types strictness)
+					(ts=:{ts_type_defs,ts_modules}, ti, cs=:{cs_symbol_table})
+		# ((type_index, type_module), cs_symbol_table, ti_used_types) = retrieveTypeDefinition id_info cti_module_index cs_symbol_table ti.ti_used_types
+		  ti = { ti & ti_used_types = ti_used_types }
+		# cs = { cs & cs_symbol_table = cs_symbol_table }
+		| type_index <> NotFound
+			# ({td_arity,td_attribute,td_rhs},type_index,ts_type_defs,ts_modules) = getTypeDef type_index type_module cti_module_index ts_type_defs ts_modules
+			  ts = { ts & ts_type_defs = ts_type_defs, ts_modules = ts_modules }
+			| checkArityOfType type_cons.type_arity td_arity td_rhs
+				# (types, _, ts_ti_cs) = bindTypes cti types (ts, ti, cs)
+				| type_module == cti_module_index && cti_type_index == type_index
+					= (TAS { type_cons & type_index = { glob_object = type_index, glob_module = type_module}} types strictness, cti_lhs_attribute, ts_ti_cs)
+					= (TAS { type_cons & type_index = { glob_object = type_index, glob_module = type_module}} types strictness,
+								determine_type_attribute td_attribute, ts_ti_cs)
+				= (TE, TA_Multi, (ts, ti, { cs & cs_error = checkError type_cons.type_name "used with wrong arity" cs.cs_error }))
+			= (TE, TA_Multi, (ts, ti, { cs & cs_error = checkError type_cons.type_name "undefined" cs.cs_error}))	
 	bindTypes cti (arg_type --> res_type) ts_ti_cs
 		# (arg_type, _, ts_ti_cs) = bindTypes cti arg_type ts_ti_cs
 		  (res_type, _, ts_ti_cs) = bindTypes cti res_type ts_ti_cs
@@ -206,16 +221,16 @@ where
 		-> (!TypeRhs, !(!*TypeSymbols, !*TypeInfo, !*CheckState))
 	//
 	check_rhs_of_TypeDef {td_name,td_arity,td_args,td_rhs = td_rhs=:AlgType conses} attr_vars cti=:{cti_module_index,cti_type_index,cti_lhs_attribute} ts_ti_cs
-		# type_lhs = { at_annotation = AN_None, at_attribute = cti_lhs_attribute,
+		# type_lhs = { at_attribute = cti_lhs_attribute,
 				  	   at_type = TA (MakeTypeSymbIdent { glob_object = cti_type_index, glob_module = cti_module_index } td_name td_arity)
-									[{at_annotation = AN_None, at_attribute = atv_attribute,at_type = TV atv_variable} \\ {atv_variable, atv_attribute} <- td_args]}
+									[{at_attribute = atv_attribute,at_type = TV atv_variable} \\ {atv_variable, atv_attribute} <- td_args]}
 		  ts_ti_cs = bind_types_of_constructors cti 0 [ atv_variable \\ {atv_variable} <- td_args] attr_vars type_lhs conses ts_ti_cs
 		= (td_rhs, ts_ti_cs)
 	check_rhs_of_TypeDef {td_name,td_arity,td_args,td_rhs = td_rhs=:RecordType {rt_constructor=rec_cons=:{ds_index}, rt_fields}}
 			attr_vars cti=:{cti_module_index,cti_type_index,cti_lhs_attribute} ts_ti_cs
-		# type_lhs = {	at_annotation = AN_None, at_attribute = cti_lhs_attribute,
+		# type_lhs = {	at_attribute = cti_lhs_attribute,
 						at_type = TA (MakeTypeSymbIdent { glob_object = cti_type_index, glob_module = cti_module_index } td_name td_arity)
-				[{at_annotation = AN_None, at_attribute = atv_attribute,at_type = TV atv_variable} \\ {atv_variable, atv_attribute} <- td_args]}
+				[{ at_attribute = atv_attribute,at_type = TV atv_variable} \\ {atv_variable, atv_attribute} <- td_args]}
 		  (ts, ti, cs) = bind_types_of_constructors cti 0  [ atv_variable \\ {atv_variable} <- td_args]
 		  						attr_vars type_lhs [rec_cons] ts_ti_cs
 		# (rec_cons_def, ts) = ts!ts_cons_defs.[ds_index]
@@ -298,7 +313,7 @@ where
 				| stv_count == 0
 					= (local_vars, symbol_table)
 					
-					= ([{ atv_variable = { tv & tv_info_ptr = stv_info_ptr}, atv_attribute = stv_attribute, atv_annotation = AN_None } : local_vars],
+					= ([{ atv_variable = { tv & tv_info_ptr = stv_info_ptr}, atv_attribute = stv_attribute } : local_vars],
 							symbol_table <:= (id_info, { ste & ste_kind = STE_BoundTypeVariable { bv & stv_count = 0}}))
 
 	retrieve_used_types symb_ptrs symbol_table
@@ -491,6 +506,22 @@ where
 	check_attribute var_name dem_attr _ this_attr oti cs
 		= (TA_Multi, oti, cs)
 
+check_args_of_type_cons :: !Index !Int !DemandedAttributeKind ![AType] ![ATypeVar] !(!u:OpenTypeSymbols, !*OpenTypeInfo, !*CheckState)
+	-> (![AType], !(!u:OpenTypeSymbols, !*OpenTypeInfo, !*CheckState))
+check_args_of_type_cons mod_index scope dem_attr_kind [] _ cot_state
+	= ([], cot_state)
+check_args_of_type_cons mod_index scope dem_attr_kind [arg_type : arg_types] [ {atv_attribute} : td_args ] cot_state
+	# (arg_type, cot_state) = checkOpenAType mod_index scope (new_demanded_attribute dem_attr_kind /* DAK_None */ atv_attribute) arg_type cot_state
+	  (arg_types, cot_state) = check_args_of_type_cons mod_index scope dem_attr_kind arg_types td_args cot_state
+	= ([arg_type : arg_types], cot_state)
+
+new_demanded_attribute DAK_Ignore _
+	= DAK_Ignore
+new_demanded_attribute _ TA_Unique
+	= DAK_Unique
+new_demanded_attribute dem_attr_kind _
+	= dem_attr_kind
+
 checkOpenAType :: !Index !Int !DemandedAttributeKind !AType !(!u:OpenTypeSymbols, !*OpenTypeInfo, !*CheckState)
 	-> (!AType, !(!u:OpenTypeSymbols, !*OpenTypeInfo, !*CheckState))
 checkOpenAType mod_index scope dem_attr type=:{at_type = TV tv, at_attribute} (ots, oti, cs)
@@ -536,23 +567,21 @@ checkOpenAType mod_index scope dem_attr_kind type=:{ at_type=TA type_cons=:{type
 			= ({ 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}))
-where
-	check_args_of_type_cons :: !Index !Int !DemandedAttributeKind ![AType] ![ATypeVar] !(!u:OpenTypeSymbols, !*OpenTypeInfo, !*CheckState)
-		-> (![AType], !(!u:OpenTypeSymbols, !*OpenTypeInfo, !*CheckState))
-	check_args_of_type_cons mod_index scope dem_attr_kind [] _ cot_state
-		= ([], cot_state)
-	check_args_of_type_cons mod_index scope dem_attr_kind [arg_type : arg_types] [ {atv_attribute} : td_args ] cot_state
-		# (arg_type, cot_state) = checkOpenAType mod_index scope (new_demanded_attribute dem_attr_kind /* DAK_None */ atv_attribute) arg_type cot_state
-		  (arg_types, cot_state) = check_args_of_type_cons mod_index scope dem_attr_kind arg_types td_args cot_state
-		= ([arg_type : arg_types], cot_state)
-
-	new_demanded_attribute DAK_Ignore _
-		= DAK_Ignore
-	new_demanded_attribute _ TA_Unique
-		= DAK_Unique
-	new_demanded_attribute dem_attr_kind _
-		= dem_attr_kind
-
+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})
+	# (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 types td_args (ots, oti, cs)
+			  (new_attr, oti, cs) = newAttribute (new_demanded_attribute dem_attr td_attribute) id_name at_attribute oti cs
+			= ({ type & at_type = TAS type_cons types strictness, 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 = arg_type --> result_type, at_attribute} cot_state
 	# (arg_type, cot_state) = checkOpenAType mod_index scope DAK_None arg_type cot_state
 	  (result_type, (ots, oti, cs)) = checkOpenAType mod_index scope DAK_None result_type cot_state
@@ -605,7 +634,7 @@ checkOpenTypes mod_index scope dem_attr types cot_state
 	= mapSt (checkOpenType mod_index scope dem_attr) types cot_state
 
 checkOpenType mod_index scope dem_attr type cot_state
-	# ({at_type}, cot_state) = checkOpenAType mod_index scope dem_attr { at_type = type, at_attribute = TA_Multi, at_annotation = AN_None } cot_state
+	# ({at_type}, cot_state) = checkOpenAType mod_index scope dem_attr { at_type = type, at_attribute = TA_Multi } cot_state
 	= (at_type, cot_state)
 	
 checkOpenATypes mod_index scope types cot_state
@@ -649,6 +678,12 @@ checkInstanceType mod_index ins_class it=:{it_types,it_context} specials type_de
 	  where
 		compare_context_and_instance_type (TA {type_index=ti1} _) (TA {type_index=ti2} _) are_equal_accu
 			= ti1==ti2 && are_equal_accu
+		compare_context_and_instance_type (TA {type_index=ti1} _) (TAS {type_index=ti2} _ _) are_equal_accu
+			= ti1==ti2 && are_equal_accu
+		compare_context_and_instance_type (TAS {type_index=ti1} _ _) (TA {type_index=ti2} _) are_equal_accu
+			= ti1==ti2 && are_equal_accu
+		compare_context_and_instance_type (TAS {type_index=ti1} _ _) (TAS {type_index=ti2} _ _) are_equal_accu
+			= ti1==ti2 && are_equal_accu
 		compare_context_and_instance_type (_ --> _) (_ --> _) are_equal_accu
 			= are_equal_accu
 //AA..
@@ -1198,7 +1233,7 @@ removeVariablesFromSymbolTable scope vars symbol_table
 	,	index_selector	:: !Index
 	}
 
-makeAttributedType attr annot type :== { at_attribute = attr, at_annotation = annot, at_type = type }
+makeAttributedType attr type :== { at_attribute = attr, at_type = type }
 
 createClassDictionaries ::		  !Bool !Index !Index !Index !Index !*{#CheckedTypeDef} !*{# SelectorDef} !*{# ConsDef} !*{#ClassDef} !*{#DclModule} !*TypeVarHeap !*VarHeap !*SymbolTable
 	-> (![CheckedTypeDef],![SelectorDef],![ConsDef],!DictionaryInfo,!*{#CheckedTypeDef},!*{# SelectorDef},!*{# ConsDef},!*{#ClassDef},!*{#DclModule},!*TypeVarHeap,!*VarHeap,!*SymbolTable)
@@ -1311,13 +1346,13 @@ where
 
 		  type_symb = MakeTypeSymbIdent { glob_object = index_type, glob_module = mod_index } rec_type_id class_arity
 				
-		  rec_type		= makeAttributedType TA_Multi AN_Strict (TA type_symb [makeAttributedType TA_Multi AN_None TE \\ i <- [1..class_arity]])
-		  field_type	= makeAttributedType TA_Multi AN_None TE
+		  rec_type		= makeAttributedType TA_Multi (TA type_symb [makeAttributedType TA_Multi TE \\ i <- [1..class_arity]])
+		  field_type	= makeAttributedType TA_Multi TE
 		  (rev_fields, var_heap, symbol_table)
 	  			= build_fields 0 nr_of_members class_members rec_type field_type index_type index_selector [] var_heap symbol_table
 		  (index_selector, rev_fields, rev_field_types, class_defs, modules, var_heap, symbol_table)
 	  			= build_context_fields mod_index nr_of_members class_context rec_type index_type (index_selector + nr_of_members) rev_fields
-	  					[ { field_type & at_annotation = AN_Strict } \\ i <- [1..nr_of_members] ] class_defs modules var_heap symbol_table
+	  					[ field_type \\ i <- [1..nr_of_members] ] class_defs modules var_heap symbol_table
 
 		  (cons_id_info, symbol_table) = newPtr EmptySymbolTableEntry symbol_table
 		  rec_cons_id = { class_name & id_info = cons_id_info}
@@ -1341,7 +1376,7 @@ where
 		
 		  cons_def = 	
 			{	cons_symb		= rec_cons_id
-			,	cons_type		= { st_vars	= [], st_args = reverse rev_field_types, st_result = rec_type,
+			,	cons_type		= { st_vars	= [], st_args = reverse rev_field_types, st_args_strictness = first_n_strict nr_of_fields, st_result = rec_type,
 								    st_arity = nr_of_fields, st_context = [], st_attr_vars = [], st_attr_env = [] }
 			,	cons_priority	= NoPrio
 			,	cons_index		= 0
@@ -1362,7 +1397,7 @@ where
 	
 	new_attributed_type_variable tv type_var_heap
 		# (new_tv_ptr, type_var_heap) = newPtr TVI_Empty type_var_heap
-		= ({atv_attribute = TA_Multi, atv_annotation = AN_None , atv_variable = { tv & tv_info_ptr = new_tv_ptr }}, type_var_heap)
+		= ({atv_attribute = TA_Multi, atv_variable = { tv & tv_info_ptr = new_tv_ptr }}, type_var_heap)
 		
 	build_fields field_nr nr_of_fields class_members rec_type field_type rec_type_index next_selector_index rev_fields var_heap symbol_table
 		| field_nr < nr_of_fields
@@ -1376,7 +1411,7 @@ where
 			next_selector_index rev_fields rev_field_types class_defs modules var_heap symbol_table
 		# ({class_name, class_arity, class_dictionary = {ds_ident, ds_index}}, _, class_defs, modules) = getClassDef ds_index glob_module mod_index class_defs modules
 		  type_symb = MakeTypeSymbIdent { glob_object = ds_index, glob_module = glob_module } ds_ident class_arity
-		  field_type = makeAttributedType TA_Multi AN_Strict (TA type_symb [makeAttributedType TA_Multi AN_None TE \\ i <- [1..class_arity]])
+		  field_type = makeAttributedType TA_Multi (TA type_symb [makeAttributedType TA_Multi TE \\ i <- [1..class_arity]])
 /* RWS FIXME ...
 	This is a patch for the case that the class has a context field which class
 	has not yet been seen. For example (note the order of definitions):
@@ -1387,7 +1422,7 @@ where
 		2) bind context fields
 	This should then also work across (dcl) module boundaries.
 */
-		  field_type = if (ds_index == NoIndex) (makeAttributedType TA_Multi AN_Strict TE) field_type
+		  field_type = if (ds_index == NoIndex) (makeAttributedType TA_Multi TE) field_type
 // ... RWS
 		  (field, var_heap, symbol_table) = build_field field_nr class_name.id_name rec_type_index rec_type field_type next_selector_index var_heap symbol_table
 		= build_context_fields mod_index (inc field_nr) tcs rec_type rec_type_index (inc next_selector_index) [ field : rev_fields ]
@@ -1402,7 +1437,7 @@ where
   		  sel_def =
   		  	{	sd_symb			= field_id
   		  	,	sd_field		= field_id
-  		  	,	sd_type			= { st_vars	= [], st_args = [ rec_type ], st_result = field_type, st_arity = 1,
+  		  	,	sd_type			= { st_vars	= [], st_args = [ rec_type ], st_args_strictness=Strict 1, st_result = field_type, st_arity = 1,
   		  	                        st_context = [], st_attr_vars = [], st_attr_env = [] }
 			,	sd_exi_vars		= []
 			,	sd_field_nr		= field_nr
diff --git a/frontend/comparedefimp.icl b/frontend/comparedefimp.icl
index ecdbabc..9580c2f 100644
--- a/frontend/comparedefimp.icl
+++ b/frontend/comparedefimp.icl
@@ -187,6 +187,12 @@ instance compare Type
 where
 	compare (TA dclIdent dclArgs) (TA iclIdent iclArgs) comp_st
 		= compare (dclIdent.type_index, dclArgs) (iclIdent.type_index, iclArgs) comp_st
+	compare (TA dclIdent dclArgs) (TAS iclIdent iclArgs iclStrictness) comp_st
+		= compare (dclIdent.type_index, (dclArgs,NotStrict)) (iclIdent.type_index, (iclArgs,iclStrictness)) comp_st
+	compare (TAS dclIdent dclArgs dclStrictness) (TA iclIdent iclArgs) comp_st
+		= compare (dclIdent.type_index, (dclArgs,dclStrictness)) (iclIdent.type_index, (iclArgs,NotStrict)) comp_st
+	compare (TAS dclIdent dclArgs dclStrictness) (TAS iclIdent iclArgs iclStrictness) comp_st
+		= compare (dclIdent.type_index, (dclArgs,dclStrictness)) (iclIdent.type_index, (iclArgs,iclStrictness)) comp_st
 	compare (dclFun --> dclArg) (iclFun --> iclArg) comp_st
 		= compare (dclFun, dclArg) (iclFun, iclArg) comp_st
 	compare (CV dclVar :@: dclArgs) (CV iclVar :@: iclArgs) comp_st
@@ -203,7 +209,7 @@ where
 instance compare AType
 where
 	compare at1 at2 comp_st
-		= compare (at1.at_attribute, (at1.at_annotation,  at1.at_type)) (at2.at_attribute, (at2.at_annotation, at2.at_type)) comp_st
+		= compare (at1.at_attribute, at1.at_type) (at2.at_attribute, at2.at_type) comp_st
 
 instance compare TypeAttribute
 where
@@ -223,6 +229,20 @@ instance compare Annotation
 where
 	compare an1 an2 comp_st
 		= (equal_constructor an1 an2, comp_st)
+
+instance compare StrictnessList
+where
+	compare strictness1 strictness2 comp_st
+		= (equal_strictness_lists strictness1 strictness2,comp_st)
+
+equal_strictness_lists NotStrict NotStrict
+	= True
+equal_strictness_lists NotStrict (Strict s)
+	= s==0
+equal_strictness_lists (Strict s) NotStrict
+	= s==0
+equal_strictness_lists (Strict s1) (Strict s2)
+	= s1==s2
 	
 instance compare AttributeVar
 where
@@ -267,8 +287,8 @@ where
 		  comp_attr_var_heap = initialyseAttributeVars dcl_st.st_attr_vars comp_attr_var_heap
 		  comp_attr_var_heap = initialyseAttributeVars icl_st.st_attr_vars comp_attr_var_heap
 		  comp_st = { comp_st & comp_type_var_heap = comp_type_var_heap, comp_attr_var_heap = comp_attr_var_heap }
-		= compare	(dcl_st.st_args, (dcl_st.st_result, (dcl_st.st_context, dcl_st.st_attr_env)))
-					(icl_st.st_args, (icl_st.st_result, (icl_st.st_context, icl_st.st_attr_env))) comp_st
+		= compare	(dcl_st.st_args, (dcl_st.st_args_strictness, (dcl_st.st_result, (dcl_st.st_context, dcl_st.st_attr_env))))
+					(icl_st.st_args, (icl_st.st_args_strictness, (icl_st.st_result, (icl_st.st_context, icl_st.st_attr_env)))) comp_st
 //						---> ("compare SymbolType", dcl_st, icl_st)
 
 instance compare InstanceType
@@ -689,7 +709,6 @@ instance t_corresponds DefinedSymbol where
 instance t_corresponds ATypeVar where
 	t_corresponds dclDef iclDef
 		=	t_corresponds dclDef.atv_attribute iclDef.atv_attribute
-		&&&	t_corresponds dclDef.atv_annotation iclDef.atv_annotation
 		&&&	t_corresponds dclDef.atv_variable iclDef.atv_variable
 
 instance t_corresponds Annotation where
@@ -698,11 +717,17 @@ instance t_corresponds Annotation where
 	  where
 		t_corresponds` dcl_annotation icl_annotation tc_state=:{tc_ignore_strictness}
 			= (tc_ignore_strictness || dcl_annotation==icl_annotation, tc_state)
+
+instance t_corresponds StrictnessList where
+	t_corresponds dcl_strictness icl_strictness 
+		= t_corresponds` dcl_strictness icl_strictness
+	  where
+		t_corresponds` dcl_strictness icl_strictness tc_state=:{tc_ignore_strictness}
+			= (tc_ignore_strictness || equal_strictness_lists dcl_strictness icl_strictness, tc_state)
 			
 instance t_corresponds AType where
 	t_corresponds dclDef iclDef
 		=	t_corresponds dclDef.at_attribute iclDef.at_attribute
-		&&&	t_corresponds dclDef.at_annotation iclDef.at_annotation
 		&&&	t_corresponds dclDef.at_type iclDef.at_type
 
 instance t_corresponds TypeAttribute where
@@ -740,6 +765,21 @@ instance t_corresponds Type where
 		=	equal dclIdent.type_name iclIdent.type_name
 		&&& equal dclIdent.type_index.glob_module iclIdent.type_index.glob_module
 		&&& t_corresponds dclArgs iclArgs
+	t_corresponds (TA dclIdent dclArgs) icl_type=:(TAS iclIdent iclArgs iclStrictness)
+		=	equal dclIdent.type_name iclIdent.type_name
+		&&& equal dclIdent.type_index.glob_module iclIdent.type_index.glob_module
+		&&& return (equal_strictness_lists NotStrict iclStrictness)
+		&&& t_corresponds dclArgs iclArgs
+	t_corresponds (TAS dclIdent dclArgs dclStrictness) icl_type=:(TA iclIdent iclArgs)
+		=	equal dclIdent.type_name iclIdent.type_name
+		&&& equal dclIdent.type_index.glob_module iclIdent.type_index.glob_module
+		&&& return (equal_strictness_lists dclStrictness NotStrict)
+		&&& t_corresponds dclArgs iclArgs
+	t_corresponds (TAS dclIdent dclArgs dclStrictness) icl_type=:(TAS iclIdent iclArgs iclStrictness)
+		=	equal dclIdent.type_name iclIdent.type_name
+		&&& equal dclIdent.type_index.glob_module iclIdent.type_index.glob_module
+		&&& return (equal_strictness_lists dclStrictness iclStrictness)
+		&&& t_corresponds dclArgs iclArgs
 	t_corresponds (dclFun --> dclArg) (iclFun --> iclArg)
 		=	t_corresponds dclFun iclFun
 		&&&	t_corresponds dclArg iclArg
@@ -818,6 +858,7 @@ init_atype_vars atype_vars
 instance t_corresponds SymbolType where
 	t_corresponds dclDef iclDef
 		=	t_corresponds dclDef.st_args iclDef.st_args
+		&&&	t_corresponds dclDef.st_args_strictness iclDef.st_args_strictness
 		&&&	t_corresponds dclDef.st_result iclDef.st_result
 		&&&	t_corresponds dclDef.st_context iclDef.st_context
 		&&&	t_corresponds dclDef.st_attr_env iclDef.st_attr_env
diff --git a/frontend/containers.dcl b/frontend/containers.dcl
index e788c86..3b66e02 100644
--- a/frontend/containers.dcl
+++ b/frontend/containers.dcl
@@ -1,11 +1,11 @@
 definition module containers
 
 /*2.0
-from syntax import ::Optional
+from syntax import ::Optional,::StrictnessList,::Annotation
 from StdOverloaded import class toString
 0.2*/
 //1.3
-from syntax import Optional
+from syntax import Optional,StrictnessList,Annotation
 from StdOverloaded import toString
 //3.1
 
@@ -27,6 +27,17 @@ bitvectReset :: !Int !*LargeBitvect -> .LargeBitvect
 bitvectSetFirstN :: !Int !*LargeBitvect -> .LargeBitvect 
 bitvectResetAll :: !*LargeBitvect -> .LargeBitvect 
 
+add_strictness :: !Int !StrictnessList -> StrictnessList
+first_n_strict :: !Int -> StrictnessList
+insert_n_strictness_values_at_beginning :: !Int !StrictnessList -> StrictnessList
+insert_n_lazy_values_at_beginning :: !Int !StrictnessList -> StrictnessList
+arg_strictness_annotation :: !Int !StrictnessList -> Annotation;
+is_not_strict :: !StrictnessList -> Bool
+arg_is_strict :: !Int !StrictnessList -> Bool;
+add_next_strict :: !Int !Int !StrictnessList -> (!Int,!Int,!StrictnessList)
+add_next_not_strict :: !Int !Int !StrictnessList -> (!Int,!Int,!StrictnessList)
+append_strictness :: !Int !StrictnessList -> StrictnessList
+
 :: IntKey :== Int
 
 :: IntKeyHashtable a = IntKeyHashtable !Int !Int !Int !.{!.IntKeyTree a}
diff --git a/frontend/containers.icl b/frontend/containers.icl
index 13f0fe1..138fc9d 100644
--- a/frontend/containers.icl
+++ b/frontend/containers.icl
@@ -178,6 +178,134 @@ bitvectOr op1 op2
 			= (has_changed, op1, op2)
 		= (True, op1, { op2 & [i] = or })
 
+add_strictness :: !Int !StrictnessList -> StrictnessList
+add_strictness index NotStrict
+	| index<32
+		= Strict (1<<index);
+		= StrictList 0 (add_strictness (index-32) NotStrict)
+add_strictness index (Strict s)
+	| index<32
+		= Strict (s bitor (1<<index));
+		= StrictList s (add_strictness (index-32) NotStrict)
+add_strictness index (StrictList s l)
+	| index<32
+		= StrictList (s bitor (1<<index)) l;
+		= StrictList s (add_strictness (index-32) l)
+
+first_n_strict :: !Int -> StrictnessList
+first_n_strict 0
+	= NotStrict
+first_n_strict n
+	| n<32
+		= Strict (bitnot ((-1)<<n))
+		= StrictList (-1) (first_n_strict (n-32))
+
+insert_n_strictness_values_at_beginning :: !Int !StrictnessList -> StrictnessList
+insert_n_strictness_values_at_beginning 0 s
+	= s
+insert_n_strictness_values_at_beginning n NotStrict
+	| n<32
+		= Strict (bitnot ((-1)<<n))
+		= StrictList (-1) (first_n_strict (n-32))
+insert_n_strictness_values_at_beginning n (Strict s)
+	| n<32
+		# s2=((s>>1) bitand 0x7fffffff)>>(31-n)
+		# s=(bitnot ((-1)<<n)) bitor (s<<n)
+		| s2==0
+			= Strict s
+			= StrictList s (Strict s2)
+		= StrictList (-1) (first_n_strict (n-32))
+insert_n_strictness_values_at_beginning n (StrictList s l)
+	| n<32
+		# s2=((s>>1) bitand 0x7fffffff)>>(31-n)
+		# s=(bitnot ((-1)<<n)) bitor (s<<n)
+		= StrictList s (shift_or l n s2)
+		= StrictList (-1) (insert_n_strictness_values_at_beginning (n-32) l)
+
+insert_n_lazy_values_at_beginning :: !Int !StrictnessList -> StrictnessList
+insert_n_lazy_values_at_beginning 0 s
+	= s
+insert_n_lazy_values_at_beginning n NotStrict
+	= NotStrict
+insert_n_lazy_values_at_beginning n (Strict s)
+	| n<32
+		# s2=((s>>1) bitand 0x7fffffff)>>(31-n)
+		# s=s<<n
+		| s2==0
+			= Strict s
+			= StrictList s (Strict s2)
+		= StrictList (-1) (first_n_strict (n-32))
+insert_n_lazy_values_at_beginning n (StrictList s l)
+	| n<32
+		# s2=((s>>1) bitand 0x7fffffff)>>(31-n)
+		# s=s<<n
+		= StrictList s (shift_or l n s2)
+		= StrictList (-1) (insert_n_lazy_values_at_beginning (n-32) l)
+
+shift_or NotStrict n s2
+	| s2==0	
+		= NotStrict
+		= Strict s2
+shift_or (Strict s) n s2
+	# new_s=(s<<n) bitor s2
+	# new_s2=((s>>1) bitand 0x7fffffff)>>(31-n)
+	| new_s2==0
+		= Strict new_s
+		= StrictList new_s (Strict new_s2)
+shift_or (StrictList s l) n s2
+	# new_s=(s<<n) bitor s2
+	# new_s2=((s>>1) bitand 0x7fffffff)>>(31-n)
+	= StrictList new_s (shift_or l n new_s2)
+
+arg_strictness_annotation :: !Int !StrictnessList -> Annotation;
+arg_strictness_annotation _ NotStrict
+	= AN_None
+arg_strictness_annotation i (Strict s)
+	| i<32 && (s>>i) bitand 1>0
+		= AN_Strict
+		= AN_None
+arg_strictness_annotation i (StrictList s l)
+	| i<32
+		| (s>>i) bitand 1>0
+			= AN_Strict
+			= AN_None
+		= arg_strictness_annotation (i-32) l
+
+arg_is_strict :: !Int !StrictnessList -> Bool;
+arg_is_strict _ NotStrict
+	= False
+arg_is_strict i (Strict s)
+	= i<32 && (s>>i) bitand 1>0
+arg_is_strict i (StrictList s l)
+	| i<32
+		= (s>>i) bitand 1>0
+		= arg_is_strict (i-32) l
+
+is_not_strict :: !StrictnessList -> Bool
+is_not_strict NotStrict = True
+is_not_strict (Strict s) = s==0
+is_not_strict (StrictList s l) = s==0 && is_not_strict l
+
+add_next_strict :: !Int !Int !StrictnessList -> (!Int,!Int,!StrictnessList)
+add_next_strict strictness_index strictness strictness_list
+	| strictness_index<32
+		= (strictness_index+1,strictness bitor (1<<strictness_index),strictness_list)
+		= (0,0x80000000,append_strictness strictness strictness_list)
+
+add_next_not_strict :: !Int !Int !StrictnessList -> (!Int,!Int,!StrictnessList)
+add_next_not_strict strictness_index strictness strictness_list
+	| strictness_index<32
+		= (strictness_index+1,strictness,strictness_list)
+		= (0,0,append_strictness strictness strictness_list)
+
+append_strictness :: !Int !StrictnessList -> StrictnessList
+append_strictness strictness NotStrict
+	= Strict strictness
+append_strictness strictness (Strict s)
+	= StrictList s (Strict strictness)
+append_strictness strictness (StrictList s l)
+	= StrictList s (append_strictness strictness l)
+
 screw :== 80
 
 :: IntKey :== Int
diff --git a/frontend/convertDynamics.icl b/frontend/convertDynamics.icl
index b08e577..aefc2fb 100644
--- a/frontend/convertDynamics.icl
+++ b/frontend/convertDynamics.icl
@@ -412,7 +412,7 @@ where
 					//
 					# (Yes old_case_default) = this_case_default
 //					# (let_info_ptr,  ci) = let_ptr ci
-					# (default_var, ci) = newVariable "s" (VI_BoundVar {at_attribute=TA_None,at_annotation=AN_None,at_type=TE}) ci
+					# (default_var, ci) = newVariable "s" (VI_BoundVar {at_attribute=TA_None,at_type=TE}) ci
 					# default_fv = varToFreeVar default_var 1
 					# ci
 						= { ci & ci_new_variables = [default_fv : ci.ci_new_variables]}
@@ -1298,7 +1298,7 @@ let_ptr2 let_types ci=:{ci_expr_heap}
 
 /* Sjaak ... */
 toAType :: Type -> AType
-toAType type = { at_attribute = TA_Multi, at_annotation = AN_None, at_type = type }
+toAType type = { at_attribute = TA_Multi, at_type = type }
 
 empty_attributed_type :: AType
 empty_attributed_type = toAType TE
diff --git a/frontend/generics.icl b/frontend/generics.icl
index 69ab161..428588d 100644
--- a/frontend/generics.icl
+++ b/frontend/generics.icl
@@ -1978,12 +1978,12 @@ buildCurriedType :: ![AType] !AType !TypeAttribute ![AttrInequality] ![Attribute
 buildCurriedType [] type cum_attr attr_env attr_vars attr_var_name attr_store th_attrs 
 	= (type, attr_env, attr_vars, attr_store, th_attrs)
 buildCurriedType [at=:{at_attribute}] type cum_attr attr_env attr_vars attr_var_name attr_store th_attrs
-	# atype = {at_annotation = AN_None, at_attribute = cum_attr , at_type = at --> type }
+	# atype = {at_attribute = cum_attr , at_type = at --> type }
 	= (atype, attr_env, attr_vars, attr_store, th_attrs)
 buildCurriedType [at=:{at_attribute}:ats] type cum_attr attr_env attr_vars attr_var_name attr_store th_attrs
 	# (next_cum_attr, new_attr_env, attr_vars, attr_store, th_attrs) = combine_attributes at_attribute cum_attr attr_env attr_vars attr_store th_attrs
 	  (res_type, attr_env, attr_vars, attr_store, th_attrs) = buildCurriedType ats type next_cum_attr attr_env attr_vars attr_var_name attr_store th_attrs
-	# atype = {at_annotation = AN_None, at_attribute = cum_attr , at_type = at --> res_type }  
+	# atype = {at_attribute = cum_attr , at_type = at --> res_type }  
 	= (atype, attr_env, attr_vars, attr_store, th_attrs)
 where
 	combine_attributes TA_Unique cum_attr attr_env attr_vars attr_store th_attrs
@@ -2096,7 +2096,7 @@ where
 				(TA_Var av) -> [av:avs]
 				_			-> avs
 			#! th = {th & th_vars = th_vars}
-			= (	{atv_attribute=attr, atv_variable=tv, atv_annotation=AN_None},
+			= (	{atv_attribute=attr, atv_variable=tv},
 				(avs, th))
 
 			 
@@ -2401,7 +2401,7 @@ where
 					#! (TVI_Attribute attr, th_vars) = readPtr tv_info_ptr th_vars
 					#! avs = (collect_attr_var attr) ++ avs
 					#! th = {th & th_vars = th_vars}
-					= (	{atv_attribute=attr, atv_variable=tv, atv_annotation=AN_None},
+					= (	{atv_attribute=attr, atv_variable=tv},
 						(avs, th))
 				collect_attr_var (TA_Var av)	= [av]
 				collect_attr_var _ 				= []
@@ -2510,7 +2510,7 @@ where
 					= (attr, ([fresh_av:avs], th_attrs))
 		#! (st, th) = substituteInSymbolType gt_type {th & th_vars = th_vars, th_attrs = th_attrs}
 
-		#! atvs = [{atv_attribute=attr, atv_variable=tv, atv_annotation=AN_None} \\
+		#! atvs = [{atv_attribute=attr, atv_variable=tv} \\
 			attr 	<- attrs &
 			tv 		<- tvs]
 		
@@ -2967,6 +2967,7 @@ buildIsomapType module_index type_def_index
 	# generic_type = 
 		{ gt_type = 
 			{ st_vars = []
+			, st_args_strictness=NotStrict
 			, st_args = []
 			, st_arity = 0
 			, st_result = buildATypeISO t1 t2 gs_predefs
@@ -3430,7 +3431,6 @@ getGenericMember {glob_module, glob_object} kind modules
 makeAType :: !Type !TypeAttribute -> !AType
 makeAType type attr = 
 	{	at_attribute = attr
-	, 	at_annotation = AN_None
 	, 	at_type = type
 	}
 
diff --git a/frontend/overloading.icl b/frontend/overloading.icl
index cc34472..2113023 100644
--- a/frontend/overloading.icl
+++ b/frontend/overloading.icl
@@ -259,12 +259,22 @@ where
 
 	adjust_type_attribute _ _ (TV _) state
 		= state
-	adjust_type_attribute defs (TA type_cons1 cons_args1) (TA type_cons2 cons_args2) (ok, coercion_env, type_heaps)
+	adjust_type_attribute defs type1=:(TA type_cons1 cons_args1) type2=:(TA type_cons2 cons_args2) (ok, coercion_env, type_heaps)
 		| type_cons1 == type_cons2
 			= adjust_attributes_and_subtypes defs cons_args1 cons_args2 (ok, coercion_env, type_heaps)
-			# (_, type1, type_heaps) = tryToExpandTypeSyn defs type_cons1 cons_args1 type_heaps
-			  (_, type2, type_heaps) = tryToExpandTypeSyn defs type_cons2 cons_args2 type_heaps
-			= adjust_type_attribute defs type1 type2 (ok, coercion_env, type_heaps)
+			= expand_types_and_adjust_type_attribute type_cons1 cons_args1 type_cons2 cons_args2 defs type1 type2 ok coercion_env type_heaps
+	adjust_type_attribute defs type1=:(TA type_cons1 cons_args1) type2=:(TAS type_cons2 cons_args2 _) (ok, coercion_env, type_heaps)
+		| type_cons1 == type_cons2
+			= adjust_attributes_and_subtypes defs cons_args1 cons_args2 (ok, coercion_env, type_heaps)
+			= expand_types_and_adjust_type_attribute type_cons1 cons_args1 type_cons2 cons_args2 defs type1 type2 ok coercion_env type_heaps
+	adjust_type_attribute defs type1=:(TAS type_cons1 cons_args1 _) type2=:(TA type_cons2 cons_args2) (ok, coercion_env, type_heaps)
+		| type_cons1 == type_cons2
+			= adjust_attributes_and_subtypes defs cons_args1 cons_args2 (ok, coercion_env, type_heaps)
+			= expand_types_and_adjust_type_attribute type_cons1 cons_args1 type_cons2 cons_args2 defs type1 type2 ok coercion_env type_heaps
+	adjust_type_attribute defs type1=:(TAS type_cons1 cons_args1 _) type2=:(TAS type_cons2 cons_args2 _) (ok, coercion_env, type_heaps)
+		| type_cons1 == type_cons2
+			= adjust_attributes_and_subtypes defs cons_args1 cons_args2 (ok, coercion_env, type_heaps)
+			= expand_types_and_adjust_type_attribute type_cons1 cons_args1 type_cons2 cons_args2 defs type1 type2 ok coercion_env type_heaps
 	adjust_type_attribute defs (arg_type1 --> res_type1) (arg_type2 --> res_type2) state
 		= adjust_attributes_and_subtypes defs [arg_type1, res_type1] [arg_type2, res_type2] state
 // AA..
@@ -273,19 +283,33 @@ where
 // ..AA
 	adjust_type_attribute defs (_ :@: types1) (_ :@: types2) state
 		= adjust_attributes_and_subtypes defs types1 types2 state
-	adjust_type_attribute _ (TA type_cons1 cons_args1) type2 (ok, coercion_env, type_heaps)
-		# (expanded, type1, type_heaps) = tryToExpandTypeSyn defs type_cons1 cons_args1 type_heaps
+	adjust_type_attribute _ type1=:(TA type_cons1 cons_args1) type2 (ok, coercion_env, type_heaps)
+		# (expanded, type1, type_heaps) = tryToExpandTypeSyn defs type1 type_cons1 cons_args1 type_heaps
 		| expanded
 			= adjust_type_attribute defs type1 type2 (ok, coercion_env, type_heaps)
 			= (ok, coercion_env, type_heaps)
-	adjust_type_attribute _ type1 (TA type_cons2 cons_args2) (ok, coercion_env, type_heaps)
-		# (expanded, type2, type_heaps) = tryToExpandTypeSyn defs type_cons2 cons_args2 type_heaps
+	adjust_type_attribute _ type1=:(TAS type_cons1 cons_args1 _) type2 (ok, coercion_env, type_heaps)
+		# (expanded, type1, type_heaps) = tryToExpandTypeSyn defs type1 type_cons1 cons_args1 type_heaps
+		| expanded
+			= adjust_type_attribute defs type1 type2 (ok, coercion_env, type_heaps)
+			= (ok, coercion_env, type_heaps)
+	adjust_type_attribute _ type1 type2=:(TA type_cons2 cons_args2) (ok, coercion_env, type_heaps)
+		# (expanded, type2, type_heaps) = tryToExpandTypeSyn defs type2 type_cons2 cons_args2 type_heaps
+		| expanded
+			= adjust_type_attribute defs type1 type2 (ok, coercion_env, type_heaps)
+			= (ok, coercion_env, type_heaps)
+	adjust_type_attribute _ type1 type2=:(TAS type_cons2 cons_args2 _) (ok, coercion_env, type_heaps)
+		# (expanded, type2, type_heaps) = tryToExpandTypeSyn defs type2 type_cons2 cons_args2 type_heaps
 		| expanded
 			= adjust_type_attribute defs type1 type2 (ok, coercion_env, type_heaps)
 			= (ok, coercion_env, type_heaps)
 	adjust_type_attribute _ _ _ state
 		= state
 	
+	expand_types_and_adjust_type_attribute type_cons1 cons_args1 type_cons2 cons_args2 defs type1 type2 ok coercion_env type_heaps
+		# (_, type1, type_heaps) = tryToExpandTypeSyn defs type1 type_cons1 cons_args1 type_heaps
+		  (_, type2, type_heaps) = tryToExpandTypeSyn defs type2 type_cons2 cons_args2 type_heaps
+		= adjust_type_attribute defs type1 type2 (ok, coercion_env, type_heaps)
 
 	adjust_attributes_and_subtypes defs types1 types2 state
 		= fold2St (adjust_attribute_and_subtypes defs) types1 types2 state
@@ -506,6 +530,14 @@ where
 			  (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)
 			= (CA_GlobalTypeCode { tci_index = inst_index, tci_contexts = rc_red_contexts }, instances)
+		reduce_tc_context type_code_class (TAS cons_id=:{type_index={glob_module}} cons_args _) (new_contexts, special_instances=:{si_next_TC_member_index, si_TC_instances}, type_pattern_vars, var_heap)
+			# defining_module_name
+				= dcl_modules.[glob_module].dcl_name.id_name
+			# (inst_index, (si_next_TC_member_index, si_TC_instances))
+			  		= addGlobalTCInstance (GTT_Constructor cons_id defining_module_name) (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)
+			= (CA_GlobalTypeCode { tci_index = inst_index, 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)
 			# (inst_index, (si_next_TC_member_index, si_TC_instances))
 			  		= addGlobalTCInstance (GTT_Basic basic_type) (si_next_TC_member_index, si_TC_instances)
@@ -554,14 +586,14 @@ addGlobalTCInstance type_of_TC (next_member_index, instances=:[inst : insts])
 addGlobalTCInstance type_of_TC (next_member_index, [])
 	= (next_member_index, (inc next_member_index, [{ gtci_index = next_member_index, gtci_type = type_of_TC }]))
 
-tryToExpandTypeSyn defs cons_id=:{type_name,type_index={glob_object,glob_module}} type_args type_heaps
+tryToExpandTypeSyn defs type cons_id=:{type_name,type_index={glob_object,glob_module}} type_args type_heaps
 	# {td_name,td_rhs,td_args,td_attribute} = defs.[glob_module].com_type_defs.[glob_object]
 	= case td_rhs of
 		SynType {at_type}
 			# (_, expanded_type, type_heaps) = substituteType td_attribute TA_Multi td_args type_args at_type type_heaps
 			-> (True, expanded_type, type_heaps) 
 		_
-			-> (False, TA cons_id type_args, type_heaps)
+			-> (False, type, type_heaps)
 
 class match type ::  !{# CommonDefs} !type !type !*TypeHeaps -> (!Bool, !*TypeHeaps)
 
@@ -569,30 +601,45 @@ instance match AType
 where
 	match defs atype1 atype2 type_heaps = match defs atype1.at_type atype2.at_type type_heaps
 
+expand_and_match cons_id1 cons_args1 cons_id2 cons_args2 defs type1 type2 type_heaps
+	# (succ1, type1, type_heaps) = tryToExpandTypeSyn defs type1 cons_id1 cons_args1 type_heaps
+	# (succ2, type2, type_heaps) = tryToExpandTypeSyn defs type2 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
+					-> match defs cons_args1 cons_args2 type_heaps
+					-> (False, type_heaps)
+			_
+					-> (False, type_heaps)
+	
+*/
+		= (False, type_heaps)
+
 instance match Type
 where 
 	match defs (TV {tv_info_ptr}) type type_heaps=:{th_vars}
 		= (True, { type_heaps & th_vars = th_vars <:= (tv_info_ptr,TVI_Type type)})
-	match defs (TA cons_id1 cons_args1) (TA cons_id2 cons_args2) type_heaps
+	match defs type1=:(TA cons_id1 cons_args1) type2=:(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
-			# (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
-							-> match defs cons_args1 cons_args2 type_heaps
-							-> (False, type_heaps)
-					_
-							-> (False, type_heaps)
-
-*/
-				= (False, type_heaps)
+			= expand_and_match cons_id1 cons_args1 cons_id2 cons_args2 defs type1 type2 type_heaps
+	match defs type1=:(TA cons_id1 cons_args1) type2=:(TAS cons_id2 cons_args2 _) type_heaps
+		| cons_id1 == cons_id2
+			= match defs cons_args1 cons_args2 type_heaps
+			= expand_and_match cons_id1 cons_args1 cons_id2 cons_args2 defs type1 type2 type_heaps
+	match defs type1=:(TAS cons_id1 cons_args1 _) type2=:(TA cons_id2 cons_args2) type_heaps
+		| cons_id1 == cons_id2
+			= match defs cons_args1 cons_args2 type_heaps
+			= expand_and_match cons_id1 cons_args1 cons_id2 cons_args2 defs type1 type2 type_heaps
+	match defs type1=:(TAS cons_id1 cons_args1 _) type2=:(TAS cons_id2 cons_args2 _) type_heaps
+		| cons_id1 == cons_id2
+			= match defs cons_args1 cons_args2 type_heaps
+			= expand_and_match cons_id1 cons_args1 cons_id2 cons_args2 defs type1 type2 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
 	match defs (type1 :@: types1) (type2 :@: types2) type_heaps
@@ -602,6 +649,11 @@ where
 		| diff >= 0
 			= match defs (TV tv, types) (TA { type_cons & type_arity = diff } (take diff cons_args), drop diff cons_args) type_heaps
 			= (False, type_heaps)
+	match defs (CV tv :@: types) (TAS type_cons cons_args _) type_heaps
+		# diff = type_cons.type_arity - length types
+		| diff >= 0
+			= match defs (TV tv, types) (TA { type_cons & type_arity = diff } (take diff cons_args), drop diff cons_args) type_heaps
+			= (False, type_heaps)
 //AA..
 	match defs TArrow TArrow type_heaps
 		= (True, type_heaps)
@@ -612,13 +664,24 @@ where
 		= (tb1 == tb2, type_heaps)
 /*	match defs type (TB (BT_String array_type)) type_heaps
 		= match defs type array_type type_heaps
-*/	match defs (TA cons_id cons_args) type2 type_heaps
-		# (succ, type1, type_heaps) = tryToExpandTypeSyn defs cons_id cons_args type_heaps
+*/
+	match defs type1=:(TA cons_id cons_args) type2 type_heaps
+		# (succ, type1, type_heaps) = tryToExpandTypeSyn defs type1 cons_id cons_args type_heaps
+		| succ
+			= match defs type1 type2 type_heaps
+			= (False, type_heaps)
+	match defs type1=:(TAS cons_id cons_args _) type2 type_heaps
+		# (succ, type1, type_heaps) = tryToExpandTypeSyn defs type1 cons_id cons_args type_heaps
+		| succ
+			= match defs type1 type2 type_heaps
+			= (False, type_heaps)
+	match defs type1 type2=:(TA cons_id cons_args) type_heaps
+		# (succ, type2, type_heaps) = tryToExpandTypeSyn defs type2 cons_id cons_args type_heaps
 		| succ
 			= match defs type1 type2 type_heaps
 			= (False, type_heaps)
-	match defs type1 (TA cons_id cons_args) type_heaps
-		# (succ, type2, type_heaps) = tryToExpandTypeSyn defs cons_id cons_args type_heaps
+	match defs type1 type2=:(TAS cons_id cons_args _) type_heaps
+		# (succ, type2, type_heaps) = tryToExpandTypeSyn defs type2 cons_id cons_args type_heaps
 		| succ
 			= match defs type1 type2 type_heaps
 			= (False, type_heaps)
@@ -845,7 +908,7 @@ expressionToTypeCodeExpression expr									= abort "expressionToTypeCodeExpress
 generateClassSelection address last_selectors
 	= mapAppend (\(off_set,selector) -> RecordSelection selector off_set) address last_selectors
 
-AttributedType type :== { at_attribute = TA_Multi, at_annotation = AN_None, at_type = type }
+AttributedType type :== { at_attribute = TA_Multi, at_type = type }
 
 instance toString ClassApplication
 where 
@@ -982,14 +1045,13 @@ where
 					-> (Yes [ (tc_index, selector) : address ], type_heaps)
 				No
 					-> find_super_instance context tcs (inc tc_index) address  dict_mod dict_index defs type_heaps
-		
 
 getClassVariable :: !Ident !VarInfoPtr !*VarHeap !*ErrorAdmin -> (!Ident, !VarInfoPtr, !*VarHeap, !*ErrorAdmin)
 getClassVariable symb var_info_ptr var_heap error
 	= case (readPtr var_info_ptr var_heap) of
 		(VI_ClassVar var_name new_info_ptr count, var_heap)
 			-> (var_name, new_info_ptr, var_heap <:= (var_info_ptr, VI_ClassVar var_name new_info_ptr (inc count)), error)
-		(_, var_heap)
+		(_,var_heap)
 			# (new_info_ptr, var_heap) = newPtr VI_Empty var_heap
 			-> (symb, new_info_ptr, var_heap <:= (var_info_ptr, VI_ClassVar symb new_info_ptr 1), overloadingError symb error)
 
@@ -1103,7 +1165,6 @@ where
 					VI_Empty
 						# (new_info_ptr, var_heap) = newPtr VI_Empty var_heap
 						-> ([var_info_ptr : variables], var_heap <:= (var_info_ptr, VI_ClassVar (build_var_name id_name) new_info_ptr 0))
-//							---> ("determine_class_argument (VI_ForwardClassVar)", ptrToInt tc_var, ptrToInt var_info_ptr)
 					_
 						-> abort ("determine_class_argument 1 (overloading.icl)")//  <<- var_info)
 
@@ -1111,7 +1172,6 @@ where
 				# (new_info_ptr, var_heap) = newPtr VI_Empty var_heap
 				  var_heap	= var_heap
 				-> ([tc_var : variables], var_heap <:= (tc_var, VI_ClassVar (build_var_name id_name) new_info_ptr 0))
-//							---> ("determine_class_argument (VI_Empty)", ptrToInt tc_var)
 			_
 				-> abort ("determine_class_argument 2 (overloading.icl)") // <<- var_info)
 
@@ -1246,6 +1306,13 @@ where
 		  		= addGlobalTCInstance (GTT_Constructor cons_id defining_module_name) (tci_next_index, tci_instances)
 		  (type_code_args, tci) = mapSt (toTypeCodeExpression symb_name) type_args ({ tci & tci_next_index = tci_next_index, tci_instances = tci_instances },var_heap,error)
 		= (TCE_Constructor inst_index type_code_args, tci)
+	toTypeCodeExpression symb_name (TAS cons_id=:{type_index={glob_module}} type_args _) (tci=:{tci_next_index,tci_instances,tci_dcl_modules},var_heap,error)
+		# defining_module_name
+			= tci_dcl_modules.[glob_module].dcl_name.id_name
+		# (inst_index, (tci_next_index, tci_instances))
+		  		= addGlobalTCInstance (GTT_Constructor cons_id defining_module_name) (tci_next_index, tci_instances)
+		  (type_code_args, tci) = mapSt (toTypeCodeExpression symb_name) type_args ({ tci & tci_next_index = tci_next_index, tci_instances = tci_instances },var_heap,error)
+		= (TCE_Constructor inst_index type_code_args, tci)
 	toTypeCodeExpression symb_name (TB basic_type) (tci=:{tci_next_index,tci_instances},var_heap,error)
 		# (inst_index, (tci_next_index, tci_instances))
 		  		= addGlobalTCInstance (GTT_Basic basic_type) (tci_next_index, tci_instances)
@@ -1688,7 +1755,7 @@ let_ptr nr_of_binds ui=:{ui_symbol_heap}
 	= (expr_info_ptr, {ui &  ui_symbol_heap = ui_symbol_heap})
 where 
 	empty_attributed_type :: AType
-	empty_attributed_type = { at_attribute = TA_Multi, at_annotation = AN_None, at_type = TE }
+	empty_attributed_type = { at_attribute = TA_Multi, at_type = TE }
 
 class equalTypes a :: !a !a !*TypeVarHeap -> (!Bool, !*TypeVarHeap)
 
@@ -1721,6 +1788,18 @@ where
 		| tc1 == tc2
 			= equalTypes types1 types2 type_var_heap
 			= (False, type_var_heap)
+	equalTypes (TA tc1 types1) (TAS tc2 types2 _) type_var_heap
+		| tc1 == tc2
+			= equalTypes types1 types2 type_var_heap
+			= (False, type_var_heap)
+	equalTypes (TAS tc1 types1 _) (TA tc2 types2) type_var_heap
+		| tc1 == tc2
+			= equalTypes types1 types2 type_var_heap
+			= (False, type_var_heap)
+	equalTypes (TAS tc1 types1 _) (TAS tc2 types2 _) type_var_heap
+		| tc1 == tc2
+			= equalTypes types1 types2 type_var_heap
+			= (False, type_var_heap)
 	equalTypes (TB basic1) (TB basic2) type_var_heap
 		= (basic1 == basic2, type_var_heap)
 	equalTypes (CV tv :@: types1) (TempCV var_number :@: types2) type_var_heap
diff --git a/frontend/parse.icl b/frontend/parse.icl
index c9c9563..858505a 100644
--- a/frontend/parse.icl
+++ b/frontend/parse.icl
@@ -1,7 +1,7 @@
 implementation module parse
 
 import StdEnv
-import scanner, syntax, hashtable, utilities, predef, compilerSwitches
+import scanner, syntax, hashtable, utilities, predef, containers, compilerSwitches
 
 ParseOnly :== False
 
@@ -129,10 +129,10 @@ stringToBoxedIdent ident ident_class pState=:{ps_hash_table}
 
 internalIdent s p :== (ident,parse_state)
 	where
-		({boxed_ident=ident},parse_state) = internaBoxedlIdent s p
+		({boxed_ident=ident},parse_state) = internalBoxedIdent s p
 
-internaBoxedlIdent :: !String !*ParseState -> (!BoxedIdent, !*ParseState)
-internaBoxedlIdent prefix pState
+internalBoxedIdent :: !String !*ParseState -> (!BoxedIdent, !*ParseState)
+internalBoxedIdent prefix pState
 	# ({fp_line,fp_col},pState=:{ps_hash_table})	= getPosition pState
 	  case_string									= prefix +++ ";" +++ toString fp_line +++ ";" +++ toString fp_col
 	  (case_ident, ps_hash_table)					= putIdentInHashTable case_string IC_Expression ps_hash_table
@@ -346,6 +346,7 @@ where
 				= { 
 					pc_cons_name		= pc_cons_name
 				,	pc_arg_types		= []
+				,	pc_args_strictness	= NotStrict
 				,	pc_cons_arity		= 0
 				,	pc_cons_prio		= NoPrio
 				,	pc_exi_vars			= []
@@ -1437,10 +1438,10 @@ tryAttributedTypeVar :: !ParseState -> (!Bool, ATypeVar, !ParseState)
 tryAttributedTypeVar pState
 	# (token, pState) = nextToken TypeContext pState
 	| is_type_arg_token token
-		# (aOrA, annot, attr, pState)	= optionalAnnotAndAttr (tokenBack pState)
+		# (aOrA, attr, pState)	= warnAnnotAndOptionalAttr (tokenBack pState)
 	      (succ, type_var, pState)		= tryTypeVar pState
 	    | succ
-			= (True, { atv_attribute = attr, atv_annotation = annot, atv_variable = type_var }, pState)
+			= (True, { atv_attribute = attr, atv_variable = type_var }, pState)
 		| aOrA // annot <> AN_None || attr <> TA_None
 			# (token, pState) = nextToken TypeContext pState
 			= (False, no_type_var, parseError "Attributed type var" (Yes token) "type variabele after annotation or attribute" pState)
@@ -1534,8 +1535,8 @@ where
 	want_constructor_list exi_vars token pState
 		# token = basic_type_to_constructor token
 		# (pc_cons_name,  pc_cons_prio, pc_cons_pos, pState) = want_cons_name_and_prio token pState
-		  (pc_arg_types, pState) = parseList tryBrackAType pState
-		  cons = { pc_cons_name = pc_cons_name, pc_arg_types = pc_arg_types, pc_cons_arity = length pc_arg_types,
+		  (pc_arg_types, pState) = parseList tryBrackSAType pState
+		  cons = { pc_cons_name = pc_cons_name, 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}
 		  (token, pState) = nextToken TypeContext pState
 		| token == BarToken
@@ -1584,6 +1585,46 @@ where
 
 makeAttributeVar name :== { av_name = name, av_info_ptr = nilPtr }
 
+optionalAnnot :: !ParseState -> (!Bool,!Annotation, !ParseState)
+optionalAnnot pState
+   	# (token, pState) = nextToken TypeContext pState
+   	| token == ExclamationToken
+	  	# (token, pState) = nextToken TypeContext pState
+// JVG added for strict lists:
+		| token==SquareCloseToken
+			= (False,AN_None,tokenBack (tokenBack pState))
+		= (True, AN_Strict, tokenBack pState)
+	| otherwise // token <> ExclamationToken
+		= (False, AN_None, tokenBack pState)
+
+optionalAnnotWithPosition :: !ParseState -> (!Bool,!AnnotationWithPosition, !ParseState)
+optionalAnnotWithPosition pState
+   	# (token, pState) = nextToken TypeContext pState
+   	| token == ExclamationToken
+	  	# (token, pState) = nextToken TypeContext pState
+// JVG added for strict lists:
+		| token==SquareCloseToken
+			= (False,NoAnnot,tokenBack (tokenBack pState))
+		# (position,pState) = getPosition pState
+		= (True, StrictAnnotWithPosition position, tokenBack pState)
+	| otherwise // token <> ExclamationToken
+		= (False, NoAnnot, tokenBack pState)
+
+warnAnnotAndOptionalAttr :: !ParseState -> (!Bool, !TypeAttribute, !ParseState)
+warnAnnotAndOptionalAttr pState
+   	# (token, pState) = nextToken TypeContext pState
+   	| token == ExclamationToken
+	  	# (token, pState) = nextToken TypeContext pState
+// JVG added for strict lists:
+		| token==SquareCloseToken
+			= (False,TA_None,tokenBack (tokenBack pState))
+// Sjaak  (_   , attr, pState)  = optional_attribute token pState
+		# (_   , attr, pState)  = tryAttribute token pState
+		# pState = parseWarning "" "! ignored" pState
+		= (True, attr, pState)
+	| otherwise // token <> ExclamationToken
+		= tryAttribute token pState
+
 optionalAnnotAndAttr :: !ParseState -> (!Bool, !Annotation, !TypeAttribute, !ParseState)
 optionalAnnotAndAttr pState
    	# (token, pState) = nextToken TypeContext pState
@@ -1599,6 +1640,22 @@ optionalAnnotAndAttr pState
 		# (succ, attr, pState)  = tryAttribute token pState
 		= (succ, AN_None, attr, pState)
 
+optionalAnnotAndAttrWithPosition :: !ParseState -> (!Bool, !AnnotationWithPosition, !TypeAttribute, !ParseState)
+optionalAnnotAndAttrWithPosition pState
+   	# (token, pState) = nextToken TypeContext pState
+   	| token == ExclamationToken
+	  	# (token, pState) = nextToken TypeContext pState
+// JVG added for strict lists:
+		| token==SquareCloseToken
+			= (False,NoAnnot,TA_None,tokenBack (tokenBack pState))
+// Sjaak  (_   , attr, pState)  = optional_attribute token pState
+		# (position,pState) = getPosition pState
+		# (_   , attr, pState)  = tryAttribute token pState
+		= (True, StrictAnnotWithPosition position, attr, pState)
+	| otherwise // token <> ExclamationToken
+		# (succ, attr, pState)  = tryAttribute token pState
+		= (succ, NoAnnot, attr, pState)
+
 // Sjaak 210801 ...
 		  
 tryAttribute :: !Token !ParseState -> (!Bool, !TypeAttribute, !ParseState)
@@ -1635,24 +1692,75 @@ wantFields record_type pState
 			  (ps_selector_name, pState) 	= stringToIdent field_name IC_Selector pState
 			  (ps_field_var, pState) 		= stringToIdent field_name IC_Expression pState
 			  pState          				= wantToken TypeContext "record field" DoubleColonToken pState
-			  (ps_field_type, pState)  		= want pState // wantAType
-			= ({ ps_field_name = ps_field_name, ps_selector_name = ps_selector_name, ps_field_type = ps_field_type, ps_field_var = ps_field_var,
-					ps_field_pos = LinePos fname linenr}, pState)
+//			  (ps_field_type, pState)  		= want pState // wantAType
+			  (annotation,ps_field_type, pState) = wantAnnotatedAType pState
+			= ({ ps_field_name = ps_field_name, ps_selector_name = ps_selector_name, ps_field_type = ps_field_type,
+					ps_field_annotation = annotation,
+					ps_field_var = ps_field_var, ps_field_pos = LinePos fname linenr}, pState)
+
+atypes_from_sptypes_and_warn_if_strict :: ![SATypeWithPosition] !ParseState -> (![AType],!ParseState)
+atypes_from_sptypes_and_warn_if_strict [] pState
+	= ([],pState)
+atypes_from_sptypes_and_warn_if_strict [{sp_type,sp_annotation}:types] pState
+	# pState = warnIfStrictAnnot sp_annotation pState
+	# (atypes,pState) = atypes_from_sptypes_and_warn_if_strict types pState
+	= ([sp_type:atypes],pState)
+
+atypes_from_sptypes :: ![SATypeWithPosition] -> [AType]
+atypes_from_sptypes []
+	= []
+atypes_from_sptypes [{sp_type}:types]
+	= [sp_type:atypes_from_sptypes types]
+
+atypes_from_satypes :: ![SAType] -> [AType]
+atypes_from_satypes []
+	= []
+atypes_from_satypes [{s_type}:types]
+	= [s_type:atypes_from_satypes types]
+
+strictness_from_satypes types
+	= add_strictness_for_arguments types 0 0 NotStrict
+where 
+	add_strictness_for_arguments :: ![SAType] !Int !Int !StrictnessList -> StrictnessList
+	add_strictness_for_arguments [] strictness_index strictness strictness_list
+		| strictness==0
+			= strictness_list
+			= append_strictness strictness strictness_list
+	add_strictness_for_arguments [{s_annotation=AN_Strict}:types] strictness_index strictness strictness_list
+		# (strictness_index,strictness,strictness_list) = add_next_strict strictness_index strictness strictness_list
+		= add_strictness_for_arguments types strictness_index strictness strictness_list
+	add_strictness_for_arguments [{s_annotation=AN_None}:types] strictness_index strictness strictness_list
+		# (strictness_index,strictness,strictness_list) = add_next_not_strict strictness_index strictness strictness_list
+		= add_strictness_for_arguments types strictness_index strictness strictness_list
+
+strictness_from_sptypes types
+	= add_strictness_for_arguments types 0 0 NotStrict
+where 
+	add_strictness_for_arguments :: ![SATypeWithPosition] !Int !Int !StrictnessList -> StrictnessList
+	add_strictness_for_arguments [] strictness_index strictness strictness_list
+		| strictness==0
+			= strictness_list
+			= append_strictness strictness strictness_list
+	add_strictness_for_arguments [{sp_annotation=StrictAnnotWithPosition _}:types] strictness_index strictness strictness_list
+		# (strictness_index,strictness,strictness_list) = add_next_strict strictness_index strictness strictness_list
+		= add_strictness_for_arguments types strictness_index strictness strictness_list
+	add_strictness_for_arguments [{sp_annotation=NoAnnot}:types] strictness_index strictness strictness_list
+		# (strictness_index,strictness,strictness_list) = add_next_not_strict strictness_index strictness strictness_list
+		= add_strictness_for_arguments types strictness_index strictness strictness_list
 
 makeSymbolType args result context attr_env :==
-	{ st_vars = [], st_args = args, st_arity = length args, st_result = result,
+	{ st_vars = [], st_args = atypes_from_sptypes args, st_args_strictness = strictness_from_sptypes args,st_arity = length args, st_result = result,
 	  st_context = context, st_attr_env = attr_env, st_attr_vars = [] }
-
+ 
 instance want SymbolType
 where
 	want pState
 		# (vars , pState) = optionalUniversalQuantifiedVariables pState // PK
-   		# (types, pState) = parseList tryBrackAType pState
+ 		# (types, pState) = parseList tryBrackSATypeWithPosition pState
 		  (token, pState) = nextToken TypeContext pState //-->> ("arg types:",types)
-   		  (tspec, pState) = want_rest_of_symbol_type token types pState
-   		= (tspec, pState)
+   		= want_rest_of_symbol_type token types pState
 	where
-		want_rest_of_symbol_type :: !Token ![AType] !ParseState -> (SymbolType, !ParseState)
+		want_rest_of_symbol_type :: !Token ![SATypeWithPosition] !ParseState -> (!SymbolType, !ParseState)
 		want_rest_of_symbol_type ArrowToken types pState
 			# pState				= case types of
 										[]	-> parseWarning "want SymbolType" "types before -> expected" pState
@@ -1663,17 +1771,22 @@ where
 			= (makeSymbolType types type context attr_env, pState)
 		want_rest_of_symbol_type token [] pState
 			= (makeSymbolType [] (MakeAttributedType TE) [] [], parseError "symbol type" (Yes token) "type" pState)
-		want_rest_of_symbol_type token [type] pState
+		want_rest_of_symbol_type token [{sp_type=type,sp_annotation}] pState
+			# pState = warnIfStrictAnnot sp_annotation pState
 			# (context, pState) = optionalContext (tokenBack pState)
 			  (attr_env, pState) = optionalCoercions pState
 			= (makeSymbolType [] type context attr_env, pState)
-		want_rest_of_symbol_type token [type=:{at_type = TA type_symb []} : types] pState
-		 	# type = { type & at_type = TA { type_symb & type_arity = length types } types }
+		want_rest_of_symbol_type token [{sp_type=type=:{at_type = TA type_symb [] },sp_annotation} : types] pState
+			# pState = warnIfStrictAnnot sp_annotation pState
+			# (atypes,pState) = atypes_from_sptypes_and_warn_if_strict types pState
+		 	# type = { type & at_type = TA { type_symb & type_arity = length atypes } atypes }
 			  (context, pState) = optionalContext (tokenBack pState)
 			  (attr_env, pState) = optionalCoercions pState
 			= (makeSymbolType [] type context attr_env, pState)
-		want_rest_of_symbol_type token [type=:{at_type = TV tv} : types] pState
-		 	# type = { type & at_type = CV tv :@: types }
+		want_rest_of_symbol_type token [{sp_type=type=:{at_type = TV tv},sp_annotation} : types] pState
+			# pState = warnIfStrictAnnot sp_annotation pState
+			# (atypes,pState) = atypes_from_sptypes_and_warn_if_strict types pState
+		 	# type = { type & at_type = CV tv :@: atypes }
 			  (context, pState) = optionalContext (tokenBack pState)
 			  (attr_env, pState) = optionalCoercions pState
 			= (makeSymbolType [] type context attr_env, pState)
@@ -1751,6 +1864,82 @@ where
 		= ({ at_annotation = annot, at_attribute = attr, at_type = type_var }, pState)
 */
 
+:: SAType = {s_annotation::!Annotation,s_type::!AType}
+
+:: SATypeWithPosition = {sp_annotation::!AnnotationWithPosition,sp_type::!AType}
+
+instance want SAType
+where
+	want pState
+		# (annotation,a_type,pState) = wantAnnotatedAType pState
+		= ({s_annotation=annotation,s_type=a_type},pState)
+
+:: AnnotationWithPosition = NoAnnot | StrictAnnotWithPosition !FilePosition;
+
+wantAnnotatedATypeWithPosition :: !ParseState -> (!AnnotationWithPosition,!AType,!ParseState)
+wantAnnotatedATypeWithPosition pState
+	# (vars , pState)		= optionalUniversalQuantifiedVariables pState	
+	# (_,annotation,pState) = optionalAnnotWithPosition pState
+	# (succ, atype, pState)	= tryAnnotatedAType True TA_None vars pState
+	| succ
+		= (annotation, atype, pState)
+	// otherwise //~ succ
+		# (token, pState) = nextToken TypeContext pState
+		= (annotation, atype, parseError "atype" (Yes token) "attributed and annotated type" pState)
+
+wantAnnotatedAType :: !ParseState -> (!Annotation,!AType,!ParseState)
+wantAnnotatedAType pState
+	# (vars , pState)		= optionalUniversalQuantifiedVariables pState	
+	# (_,annotation,pState) = optionalAnnot pState
+	# (succ, atype, pState)	= tryAnnotatedAType True TA_None vars pState
+	| succ
+		= (annotation, atype, pState)
+	// otherwise //~ succ
+		# (token, pState) = nextToken TypeContext pState
+		= (annotation, atype, parseError "atype" (Yes token) "attributed and annotated type" pState)
+
+tryAnnotatedAType :: !Bool !TypeAttribute ![ATypeVar] !ParseState -> (!Bool, !AType,!ParseState)
+tryAnnotatedAType tryAA attr vars pState
+	# (types, pState)		= parseList tryBrackAType pState
+	| isEmpty types
+		| isEmpty vars
+			= (False, {at_attribute = attr, at_type = TE}, pState)
+		// otherwise // PK
+			# (token, pState) = nextToken TypeContext pState
+			= (False, {at_attribute = attr, at_type = TFA vars TE}
+			  , parseError "annotated type" (Yes token) "type" (tokenBack pState))
+	# (token, pState)		= nextToken TypeContext pState
+	| token == ArrowToken
+		# (rtype, pState)	= wantAType pState
+		  atype = make_curry_type attr types rtype
+		| isEmpty vars
+			= ( True, atype, pState)
+			= ( True, { atype & at_type = TFA vars atype.at_type }, pState)
+	// otherwise (not that types is non-empty)
+// Sjaak	
+	# (atype, pState) = convertAAType types attr (tokenBack pState)
+	| isEmpty vars
+		= (True, atype, pState)
+		= (True, { atype & at_type = TFA vars atype.at_type }, pState)
+where
+	make_curry_type attr [t1] res_type
+		= {at_attribute = attr, at_type = t1 --> res_type}
+	make_curry_type attr [t1:tr] res_type
+		= {at_attribute = attr, at_type = t1 --> make_curry_type TA_None tr res_type}
+	make_curry_type _ _ _ = abort "make_curry_type: wrong assumption"
+
+tryBrackSAType :: !ParseState -> (!Bool, SAType, !ParseState)
+tryBrackSAType pState
+	# (_, annot, attr, pState)	= optionalAnnotAndAttr pState
+	# (succ, atype, pState) = trySimpleType attr pState
+	= (succ, {s_annotation=annot,s_type=atype}, pState)
+
+tryBrackSATypeWithPosition :: !ParseState -> (!Bool, SATypeWithPosition, !ParseState)
+tryBrackSATypeWithPosition pState
+	# (_, annot, attr, pState)	= optionalAnnotAndAttrWithPosition pState
+	# (succ, atype, pState) = trySimpleType attr pState
+	= (succ, {sp_annotation=annot,sp_type=atype}, pState)
+
 instance want AType
 where
 	want pState = wantAType pState
@@ -1763,7 +1952,7 @@ wantType :: !ParseState -> (!Type,!ParseState)
 wantType pState
 	# (vars, pState)	= optionalUniversalQuantifiedVariables pState
 	| isEmpty vars
-		# (succ, atype, pState)	= tryAType False AN_None TA_None pState
+		# (succ, atype, pState)	= tryAType False TA_None pState
 		  (succ2, type, pState)	= tryATypeToType atype pState
 		| succ&&succ2
 			= (type, pState)
@@ -1776,7 +1965,7 @@ wantType pState
 
 wantAType :: !ParseState -> (!AType,!ParseState)
 wantAType pState
-	# (succ, atype, pState)	= tryAType True AN_None TA_None pState
+	# (succ, atype, pState)	= tryAType True TA_None pState
 	| succ
 		= (atype, pState)
 	// otherwise //~ succ
@@ -1785,31 +1974,31 @@ wantAType pState
 
 tryType :: !ParseState -> (!Bool,!Type,!ParseState)
 tryType pState
-	# (succ, atype, pState)	= tryAType False AN_None TA_None pState
+	# (succ, atype, pState)	= tryAType False TA_None pState
 	  (succ2, type, pState)	= tryATypeToType atype pState
 	= (succ&&succ2, type, pState)
 
-tryAType :: !Bool !Annotation !TypeAttribute !ParseState -> (!Bool,!AType,!ParseState)
-tryAType tryAA annot attr pState
+tryAType :: !Bool !TypeAttribute !ParseState -> (!Bool,!AType,!ParseState)
+tryAType tryAA attr pState
 	# (vars , pState)		= optionalUniversalQuantifiedVariables pState
 	# (types, pState)		= parseList tryBrackAType pState
 	| isEmpty types
 		| isEmpty vars
-			= (False, {at_annotation = annot, at_attribute = attr, at_type = TE}, pState)
+			= (False, {at_attribute = attr, at_type = TE}, pState)
 		// otherwise // PK
 			# (token, pState) = nextToken TypeContext pState
-			= (False, {at_annotation = annot, at_attribute = attr, at_type = TFA vars TE}
+			= (False, {at_attribute = attr, at_type = TFA vars TE}
 			  , parseError "annotated type" (Yes token) "type" (tokenBack pState))
 	# (token, pState)		= nextToken TypeContext pState
 	| token == ArrowToken
 		# (rtype, pState)	= wantAType pState
-		  atype = make_curry_type annot attr types rtype
+		  atype = make_curry_type attr types rtype
 		| isEmpty vars
 			= ( True, atype, pState)
 			= ( True, { atype & at_type = TFA vars atype.at_type }, pState)
 	// otherwise (not that types is non-empty)
 // Sjaak	
-	# (atype, pState) = convertAAType types annot attr (tokenBack pState)
+	# (atype, pState) = convertAAType types attr (tokenBack pState)
 	| isEmpty vars
 		= (True, atype, pState)
 		= (True, { atype & at_type = TFA vars atype.at_type }, pState)
@@ -1823,23 +2012,22 @@ tryFunctionType types annot attr pState
 	  )
 */
 where
-	make_curry_type annot attr [t1] res_type
-		= {at_annotation = annot, at_attribute = attr, at_type = t1 --> res_type}
-	make_curry_type annot attr [t1:tr] res_type
-		= {at_annotation = annot, at_attribute = attr, at_type = t1 --> make_curry_type AN_None TA_None tr res_type}
-	make_curry_type _ _ _ _ = abort "make_curry_type: wrong assumption"
+	make_curry_type attr [t1] res_type
+		= {at_attribute = attr, at_type = t1 --> res_type}
+	make_curry_type attr [t1:tr] res_type
+		= {at_attribute = attr, at_type = t1 --> make_curry_type TA_None tr res_type}
+	make_curry_type _ _ _ = abort "make_curry_type: wrong assumption"
 
 // Sjaak ...
-convertAAType :: ![AType] !Annotation !TypeAttribute !ParseState -> (!AType,!ParseState)
-convertAAType [atype:atypes] annot attr pState
-	#	(annot, pState)	= determAnnot annot atype.at_annotation pState
-		type			= atype.at_type
+convertAAType :: ![AType] !TypeAttribute !ParseState -> (!AType,!ParseState)
+convertAAType [atype:atypes] attr pState
+	#	type			= atype.at_type
 		(attr, pState)	= determAttr attr atype.at_attribute type pState
 	| isEmpty atypes
-		= ( {at_annotation = annot, at_attribute = attr, at_type = type}, pState)
+		= ( {at_attribute = attr, at_type = type}, pState)
 	// otherwise // type application
 		# (type, pState)	= convert_list_of_types atype.at_type atypes pState
-		= ({at_annotation = annot, at_attribute = attr, at_type = type}, pState)
+		= ({at_attribute = attr, at_type = type}, pState)
 where
 	convert_list_of_types (TA sym []) types pState
 		= (TA { sym & type_arity = length types } types, pState)
@@ -1862,19 +2050,19 @@ tryApplicationType _ annot attr pState
 */
 tryBrackType :: !ParseState -> (!Bool, Type, !ParseState)
 tryBrackType pState
-	# (succ, atype, pState) 	= trySimpleType AN_None TA_None pState
+	# (succ, atype, pState) 	= trySimpleType TA_None pState
 	  (succ2, type, pState)		= tryATypeToType atype pState
 	= (succ&&succ2, type, pState)
 
 tryBrackAType :: !ParseState -> (!Bool, AType, !ParseState)
 tryBrackAType pState
-	# (_, annot, attr, pState)	= optionalAnnotAndAttr pState
-	= trySimpleType annot attr pState
+	# (_, attr, pState)	= warnAnnotAndOptionalAttr pState
+	= trySimpleType attr pState
 
-trySimpleType :: !Annotation !TypeAttribute !ParseState -> (!Bool, !AType, !ParseState)
-trySimpleType annot attr pState
+trySimpleType :: !TypeAttribute !ParseState -> (!Bool, !AType, !ParseState)
+trySimpleType attr pState
 	# (token, pState)		= nextToken TypeContext pState
-	= trySimpleTypeT token annot attr pState
+	= trySimpleTypeT token attr pState
 
 is_tail_strict_list_or_nil pState
 	# (square_close_position, pState) = getPosition pState
@@ -1889,16 +2077,16 @@ is_tail_strict_list_or_nil pState
 		= (True,pState)
 		= (False,pState)
 
-trySimpleTypeT :: !Token !Annotation !TypeAttribute !ParseState -> (!Bool, !AType, !ParseState)
-trySimpleTypeT (IdentToken id) annot attr pState
+trySimpleTypeT :: !Token !TypeAttribute !ParseState -> (!Bool, !AType, !ParseState)
+trySimpleTypeT (IdentToken id) attr pState
 	| isLowerCaseName id
 		# (typevar, pState)	= nameToTypeVar id pState
 		  (attr, pState)	= adjustAttribute attr typevar pState
-		= (True, {at_annotation = annot, at_attribute = attr, at_type = typevar}, pState)
+		= (True, {at_attribute = attr, at_type = typevar}, pState)
 	| otherwise // | isUpperCaseName id || isFunnyIdName id
 	# (type, pState) = stringToType id pState
-	= (True, {at_annotation = annot, at_attribute = attr, at_type = type}, pState)
-trySimpleTypeT SquareOpenToken annot attr pState
+	= (True, {at_attribute = attr, at_type = type}, pState)
+trySimpleTypeT SquareOpenToken attr pState
 	# (token, pState) = nextToken TypeContext pState
 	# (head_strictness,token,pState) = wantHeadStrictness token pState
 		with
@@ -1916,61 +2104,61 @@ trySimpleTypeT SquareOpenToken annot attr pState
 			# (tail_strict,pState) = is_tail_strict_list_or_nil pState
 			| tail_strict
 				# list_symbol = makeTailStrictListTypeSymbol HeadLazy 0
-		  		= (True, {at_annotation = annot, at_attribute = attr, at_type = TA list_symbol []}, pState)					
+		  		= (True, {at_attribute = attr, at_type = TA list_symbol []}, pState)					
 				# list_symbol = makeListTypeSymbol head_strictness 0
-		  		= (True, {at_annotation = annot, at_attribute = attr, at_type = TA list_symbol []}, pState)
+		  		= (True, {at_attribute = attr, at_type = TA list_symbol []}, pState)
 		# list_symbol = makeListTypeSymbol head_strictness 0
-  		= (True, {at_annotation = annot, at_attribute = attr, at_type = TA list_symbol []}, pState)
+  		= (True, {at_attribute = attr, at_type = TA list_symbol []}, pState)
 
 	| token==ExclamationToken
 		# (token,pState) = nextToken TypeContext pState
 		| token==SquareCloseToken
 			# list_symbol = makeTailStrictListTypeSymbol head_strictness 0
-  			= (True, {at_annotation = annot, at_attribute = attr, at_type = TA list_symbol []}, pState)
-			= (False, {at_annotation = annot, at_attribute = attr, at_type = TE}, parseError "List type" (Yes token) "]" pState)
+  			= (True, {at_attribute = attr, at_type = TA list_symbol []}, pState)
+			= (False, {at_attribute = attr, at_type = TE}, parseError "List type" (Yes token) "]" pState)
 
 	# (type, pState)	= wantAType (tokenBack pState)
 	  (token, pState)	= nextToken TypeContext pState
 	| token == SquareCloseToken
 		# list_symbol = makeListTypeSymbol head_strictness 1
-		= (True, {at_annotation = annot, at_attribute = attr, at_type = TA list_symbol [type]}, pState)
+		= (True, {at_attribute = attr, at_type = TA list_symbol [type]}, pState)
 
 	| token==ExclamationToken
 		# (token,pState) = nextToken TypeContext pState
 		| token==SquareCloseToken
 			# list_symbol = makeTailStrictListTypeSymbol head_strictness 1
-			= (True, {at_annotation = annot, at_attribute = attr, at_type = TA list_symbol [type]}, pState)
-			= (False, {at_annotation = annot, at_attribute = attr, at_type = TE}, parseError "List type" (Yes token) "]" pState)
+			= (True, {at_attribute = attr, at_type = TA list_symbol [type]}, pState)
+			= (False, {at_attribute = attr, at_type = TE}, parseError "List type" (Yes token) "]" pState)
 
 	// otherwise // token <> SquareCloseToken
-		= (False, {at_annotation = annot, at_attribute = attr, at_type = TE}, parseError "List type" (Yes token) "]" pState)
-trySimpleTypeT OpenToken annot attr pState
+		= (False, {at_attribute = attr, at_type = TE}, parseError "List type" (Yes token) "]" pState)
+trySimpleTypeT OpenToken attr pState
 	# (token, pState) = nextToken TypeContext pState
 	| token == CommaToken
 		# (tup_arity, pState)		= determine_arity_of_tuple 2 pState
 		  tuple_symbol = makeTupleTypeSymbol tup_arity 0
-		= (True, {at_annotation = annot, at_attribute = attr, at_type = TA tuple_symbol []}, pState)	
+		= (True, {at_attribute = attr, at_type = TA tuple_symbol []}, pState)	
 	| token == ArrowToken
 		# (token, pState) = nextToken TypeContext pState
 		| token == CloseToken
-			= (True, {at_annotation = annot, at_attribute = attr, at_type = TArrow}, pState)
-			= (False,{at_annotation = annot, at_attribute = attr, at_type = TE},
+			= (True, {at_attribute = attr, at_type = TArrow}, pState)
+			= (False,{at_attribute = attr, at_type = TE},
 				parseError "arrow type" (Yes token) ")" pState)
 	// otherwise // token <> CommaToken
-	# (atype, pState)	= wantAType (tokenBack pState)
+	# (annot_with_pos,atype, pState) = wantAnnotatedATypeWithPosition (tokenBack pState)
 	  (token, pState)	= nextToken TypeContext pState
 	| token == CloseToken
-		# (annot, pState)	= determAnnot annot atype.at_annotation pState
-		  type				= atype.at_type
+		# type				= atype.at_type
 		  (attr, pState)	= determAttr  attr  atype.at_attribute type pState
-		= (True, {at_annotation = annot, at_attribute = attr, at_type = type}, pState)
+		  pState = warnIfStrictAnnot annot_with_pos pState
+		= (True, {at_attribute = attr, at_type = type}, pState)
 	| token == CommaToken // TupleType
-		# (atypes, pState)	= wantSequence CommaToken TypeContext pState
+		# (satypes, pState)	= wantSequence CommaToken TypeContext pState
 		  pState			= wantToken TypeContext "tuple type" CloseToken pState
-		  atypes			= [atype:atypes]
-		  arity				= length atypes
+		  satypes			= [{s_annotation=(case annot_with_pos of NoAnnot -> AN_None; StrictAnnotWithPosition _ -> AN_Strict),s_type=atype}:satypes]
+		  arity				= length satypes
 	 	  tuple_symbol = makeTupleTypeSymbol arity arity
-		= (True, {at_annotation = annot, at_attribute = attr, at_type = TA tuple_symbol atypes}, pState)
+		= (True, {at_attribute = attr, at_type = TAS tuple_symbol (atypes_from_satypes satypes) (strictness_from_satypes satypes)}, pState)
 	// otherwise // token <> CloseToken && token <> CommaToken
 		= (False, atype, parseError "Simple type" (Yes token) "')' or ','" pState)
 where
@@ -1982,44 +2170,44 @@ where
 		| CloseToken == token
 			= (arity, pState)
 			= (arity, parseError "tuple type" (Yes token) ")" pState)
-trySimpleTypeT CurlyOpenToken annot attr pState
+trySimpleTypeT CurlyOpenToken attr pState
 	# (token, pState) = nextToken TypeContext pState
 	| token == CurlyCloseToken
 		# array_symbol = makeLazyArraySymbol 0
-		= (True, {at_annotation = annot, at_attribute = attr, at_type = TA array_symbol []}, pState)
+		= (True, {at_attribute = attr, at_type = TA array_symbol []}, pState)
 	| token == HashToken
 		# (token, pState) = nextToken TypeContext pState
 		| token == CurlyCloseToken
 			# array_symbol = makeUnboxedArraySymbol 0
-			= (True, {at_annotation = annot, at_attribute = attr, at_type = TA array_symbol []}, pState)
+			= (True, {at_attribute = attr, at_type = TA array_symbol []}, pState)
 		// otherwise // token <> CurlyCloseToken
 	  		# (atype, pState)			= wantAType (tokenBack pState)
   			  pState					= wantToken TypeContext "unboxed array type" CurlyCloseToken pState
   			  array_symbol = makeUnboxedArraySymbol 1
-  			= (True, {at_annotation = annot, at_attribute = attr, at_type = TA array_symbol [atype]}, pState)
+  			= (True, {at_attribute = attr, at_type = TA array_symbol [atype]}, pState)
 	| token == ExclamationToken
 		# (token, pState) = nextToken TypeContext pState
 		| token == CurlyCloseToken
 			# array_symbol = makeStrictArraySymbol 0
-			= (True,  {at_annotation = annot, at_attribute = attr, at_type = TA array_symbol []}, pState)
+			= (True,  {at_attribute = attr, at_type = TA array_symbol []}, pState)
 		// otherwise // token <> CurlyCloseToken
 	  		# (atype,pState)			= wantAType (tokenBack pState)
   			  pState					= wantToken TypeContext "strict array type" CurlyCloseToken pState
   			  array_symbol = makeStrictArraySymbol 1
-  			= (True, {at_annotation = annot, at_attribute = attr, at_type = TA array_symbol [atype]}, pState)
+  			= (True, {at_attribute = attr, at_type = TA array_symbol [atype]}, pState)
   	// otherwise
   		# (atype,pState)			= wantAType (tokenBack pState)
   		  pState					= wantToken TypeContext "lazy array type" CurlyCloseToken pState
 		  array_symbol = makeLazyArraySymbol 1
-		= (True, {at_annotation = annot, at_attribute = attr, at_type = TA array_symbol [atype]}, pState)
-trySimpleTypeT StringTypeToken annot attr pState
+		= (True, {at_attribute = attr, at_type = TA array_symbol [atype]}, pState)
+trySimpleTypeT StringTypeToken attr pState
 	# type = makeStringType
-	= (True, {at_annotation = annot, at_attribute = attr, at_type = type}, pState)
-trySimpleTypeT token annot attr pState
+	= (True, {at_attribute = attr, at_type = type}, pState)
+trySimpleTypeT token attr pState
 	# (bt, pState) = try token pState
 	= case bt of
-		Yes bt	-> (True , {at_annotation = annot, at_attribute = attr, at_type = TB bt}, pState)
-		no		-> (False, {at_annotation = annot, at_attribute = attr, at_type = TE}   , pState)
+		Yes bt	-> (True , {at_attribute = attr, at_type = TB bt}, pState)
+		no		-> (False, {at_attribute = attr, at_type = TE}   , pState)
 
 instance try BasicType
 where
@@ -2094,10 +2282,10 @@ tryQuantifiedTypeVar pState
  	| succ
 		# (typevar, pState)	= wantTypeVar pState
 		  (attr, pState)	= adjustAttributeOfTypeVariable attr typevar.tv_name pState
-		= (True, {atv_attribute = attr, atv_annotation = AN_None, atv_variable = typevar}, pState)
+		= (True, {atv_attribute = attr, atv_variable = typevar}, pState)
 	# (succ, typevar, pState) = tryTypeVarT token pState
 	| succ
-		= (True, {atv_attribute = TA_None, atv_annotation = AN_None, atv_variable = typevar}, pState)
+		= (True, {atv_attribute = TA_None, atv_variable = typevar}, pState)
 		= (False, abort "no ATypeVar", pState)
 where			
 	try_attribute DotToken      pState = (True,	TA_Anonymous,	pState)
@@ -2106,12 +2294,12 @@ where
 
 tryATypeToType :: !AType !ParseState -> (!Bool, !Type, !ParseState)
 tryATypeToType atype pState
-	| atype.at_annotation <> AN_None
+/*	| atype.at_annotation <> AN_None
 		= ( False
 		  , atype.at_type
 		  , parseError "simple type" No ("type instead of type annotation "+toString atype.at_annotation) pState
 		  )
-	| atype.at_attribute <> TA_None
+*/	| atype.at_attribute <> TA_None
 		= ( False
 		  , atype.at_type
 		  , parseError "simple type" No ("type instead of type attribute "+toString atype.at_attribute) pState
@@ -3420,6 +3608,26 @@ instance getPosition ParseState
 where
 	getPosition pState = accScanState getPosition pState
 
+warnIfStrictAnnot NoAnnot pState = pState
+warnIfStrictAnnot (StrictAnnotWithPosition position) pState = parseWarningWithPosition "" "! ignored" position pState
+
+parseWarningWithPosition :: !{# Char} !{# Char} !FilePosition !ParseState -> ParseState
+parseWarningWithPosition act msg position pState
+	| pState.ps_skipping
+		= pState
+	| otherwise // not pState.ps_skipping
+		# (filename,pState=:{ps_error={pea_file,pea_ok}})	= getFilename pState
+		  pea_file 	= 	pea_file
+		  				<<< "Parse warning ["
+		  				<<< filename <<< ","
+		  				<<< position
+		  				<<< (if (size act > 0) ("," + act) "") <<< "]: "
+		  				<<< msg
+		  				<<< "\n"
+		=	{ pState
+			& ps_error		= { pea_file = pea_file, pea_ok = pea_ok }
+			}
+
 parseWarning :: !{# Char} !{# Char} !ParseState -> ParseState
 parseWarning act msg pState
 	| pState.ps_skipping
diff --git a/frontend/postparse.icl b/frontend/postparse.icl
index 99ac98e..2b0d3d2 100644
--- a/frontend/postparse.icl
+++ b/frontend/postparse.icl
@@ -1,7 +1,7 @@
 implementation module postparse
 
 import StdEnv
-import syntax, parse, utilities, StdCompare
+import syntax, parse, utilities, containers, StdCompare
 //import RWSDebug
 
 :: *CollectAdmin =
@@ -1180,6 +1180,22 @@ collectFunctionBodies fun_name fun_arity fun_prio fun_kind all_defs=:[PD_Functio
 collectFunctionBodies fun_name fun_arity fun_prio fun_kind defs ca
 	= ([], fun_kind, defs, ca)
 
+strictness_from_fields :: ![ParsedSelector] -> StrictnessList
+strictness_from_fields fields
+	= add_strictness_for_arguments fields 0 0 NotStrict
+where 
+	add_strictness_for_arguments :: ![ParsedSelector] !Int !Int !StrictnessList -> StrictnessList
+	add_strictness_for_arguments [] strictness_index strictness strictness_list
+		| strictness==0
+			= strictness_list
+			= append_strictness strictness strictness_list
+	add_strictness_for_arguments [{ps_field_annotation=AN_Strict}:fields] strictness_index strictness strictness_list
+		# (strictness_index,strictness,strictness_list) = add_next_strict strictness_index strictness strictness_list
+		= add_strictness_for_arguments fields strictness_index strictness strictness_list
+	add_strictness_for_arguments [{ps_field_annotation=AN_None}:fields] strictness_index strictness strictness_list
+		# (strictness_index,strictness,strictness_list) = add_next_not_strict strictness_index strictness strictness_list
+		= add_strictness_for_arguments fields strictness_index strictness strictness_list
+
 reorganiseDefinitions :: Bool [ParsedDefinition] Index Index Index Index *CollectAdmin -> (![FunDef],!CollectedDefinitions (ParsedInstance FunDef) [FunDef], ![ParsedImport], ![ImportedObject], !*CollectAdmin)
 reorganiseDefinitions icl_module [PD_Function pos name is_infix args rhs fun_kind : defs] cons_count sel_count mem_count type_count ca
 	# prio = if is_infix (Prio NoAssoc 9) NoPrio
@@ -1239,8 +1255,9 @@ reorganiseDefinitions icl_module [PD_Type type_def=:{td_name, td_rhs = SelectorL
 	# (sel_syms, new_count) = determine_symbols_of_selectors sel_defs sel_count
 	  (fun_defs, c_defs, imports, imported_objects, ca) = reorganiseDefinitions icl_module defs (inc cons_count) new_count mem_count (type_count+1) ca
 	  cons_arity = new_count - sel_count
+	  pc_arg_types = [ ps_field_type \\ {ps_field_type} <- sel_defs ]
 	  cons_def = {	pc_cons_name = rec_cons_id, pc_cons_prio = NoPrio, pc_cons_arity = cons_arity, pc_cons_pos = td_pos,
-	  				pc_arg_types = [ ps_field_type \\ {ps_field_type} <- sel_defs ], pc_exi_vars = exivars }
+	  				pc_arg_types = pc_arg_types, pc_args_strictness=strictness_from_fields sel_defs,pc_exi_vars = exivars }
 	  type_def = { type_def & td_rhs = RecordType {rt_constructor = { ds_ident = rec_cons_id, ds_arity = cons_arity, ds_index = cons_count },
 	  							rt_fields =  { sel \\ sel <- sel_syms }}}
 	  c_defs = { c_defs & def_types = [type_def : c_defs.def_types], def_constructors = [ParsedConstructorToConsDef cons_def : c_defs.def_constructors],
diff --git a/frontend/predef.icl b/frontend/predef.icl
index 7f65509..563486d 100644
--- a/frontend/predef.icl
+++ b/frontend/predef.icl
@@ -516,8 +516,8 @@ make_type_def type_cons_index type_vars type_rhs pre_def_symbols
 	# type_cons_ident = predefined_idents.[type_cons_index]
 	= (MakeTypeDef type_cons_ident (map (\tv -> MakeAttributedTypeVar tv) type_vars) type_rhs TA_None [] NoPos, pre_def_symbols)
 
-make_list_definition :: Int Int Int Ident TypeVar AType *{#PredefinedSymbol} -> (!TypeDef TypeRhs,!ConsDef,!ConsDef,!.{#PredefinedSymbol})
-make_list_definition list_type_pre_def_symbol_index cons_pre_def_symbol_index nil_pre_def_symbol_index pre_mod_id type_var type_var_with_attr pre_def_symbols
+make_list_definition :: Int Int Int Ident TypeVar AType StrictnessList *{#PredefinedSymbol} -> (!TypeDef TypeRhs,!ConsDef,!ConsDef,!.{#PredefinedSymbol})
+make_list_definition list_type_pre_def_symbol_index cons_pre_def_symbol_index nil_pre_def_symbol_index pre_mod_id type_var type_var_with_attr cons_strictness pre_def_symbols
 	# cons_ident = predefined_idents.[cons_pre_def_symbol_index]
 	  nil_ident = predefined_idents.[nil_pre_def_symbol_index]
 	  list_ident = predefined_idents.[list_type_pre_def_symbol_index] 
@@ -527,8 +527,8 @@ make_list_definition list_type_pre_def_symbol_index cons_pre_def_symbol_index ni
 	  (list_def, pre_def_symbols) = make_type_def list_type_pre_def_symbol_index [type_var] (AlgType [cons_symb,nil_symb]) pre_def_symbols	
 	  list_type = MakeAttributedType (TA (MakeNewTypeSymbIdent list_ident 1) [type_var_with_attr])
 	  cons_def = {	pc_cons_name = cons_ident, pc_cons_arity = 2, pc_arg_types = [type_var_with_attr, list_type],
-	  				pc_cons_prio =  NoPrio, pc_exi_vars = [], pc_cons_pos = PreDefPos pre_mod_id}
-	  nil_def = {	pc_cons_name = nil_ident, pc_cons_arity = 0, pc_arg_types = [],
+				 	pc_args_strictness=cons_strictness,	pc_cons_prio =  NoPrio, pc_exi_vars = [], pc_cons_pos = PreDefPos pre_mod_id}
+	  nil_def = {	pc_cons_name = nil_ident, pc_cons_arity = 0, pc_arg_types = [], pc_args_strictness=NotStrict,
 	  				pc_cons_prio =  NoPrio, pc_exi_vars = [], pc_cons_pos = PreDefPos pre_mod_id}
 	= (list_def,ParsedConstructorToConsDef cons_def,ParsedConstructorToConsDef nil_def,pre_def_symbols);
 
@@ -547,19 +547,19 @@ buildPredefinedModule pre_def_symbols
 	  (string_def, pre_def_symbols)	= make_type_def PD_StringType [] (SynType unb_arr_of_char_type) pre_def_symbols
 	
 	  (list_def,cons_def,nil_def,pre_def_symbols)
-		= make_list_definition PD_ListType PD_ConsSymbol PD_NilSymbol pre_mod_ident type_var type_var_with_attr pre_def_symbols
+		= make_list_definition PD_ListType PD_ConsSymbol PD_NilSymbol pre_mod_ident type_var type_var_with_attr NotStrict pre_def_symbols
 	  (strict_list_def,strict_cons_def,strict_nil_def,pre_def_symbols)
-		= make_list_definition PD_StrictListType PD_StrictConsSymbol PD_StrictNilSymbol pre_mod_ident type_var type_var_with_attr pre_def_symbols
+		= make_list_definition PD_StrictListType PD_StrictConsSymbol PD_StrictNilSymbol pre_mod_ident type_var type_var_with_attr (Strict 1) pre_def_symbols
 	  (unboxed_list_def,unboxed_cons_def,unboxed_nil_def,pre_def_symbols)
-		= make_list_definition PD_UnboxedListType PD_UnboxedConsSymbol PD_UnboxedNilSymbol pre_mod_ident type_var type_var_with_attr pre_def_symbols
+		= make_list_definition PD_UnboxedListType PD_UnboxedConsSymbol PD_UnboxedNilSymbol pre_mod_ident type_var type_var_with_attr (Strict 1) pre_def_symbols
 	  (tail_strict_list_def,tail_strict_cons_def,tail_strict_nil_def,pre_def_symbols)
-		= make_list_definition PD_TailStrictListType PD_TailStrictConsSymbol PD_TailStrictNilSymbol pre_mod_ident type_var type_var_with_attr pre_def_symbols
+		= make_list_definition PD_TailStrictListType PD_TailStrictConsSymbol PD_TailStrictNilSymbol pre_mod_ident type_var type_var_with_attr (Strict 2) pre_def_symbols
 	  (strict_tail_strict_list_def,strict_tail_strict_cons_def,strict_tail_strict_nil_def,pre_def_symbols)
-		= make_list_definition PD_StrictTailStrictListType PD_StrictTailStrictConsSymbol PD_StrictTailStrictNilSymbol pre_mod_ident type_var type_var_with_attr pre_def_symbols
+		= make_list_definition PD_StrictTailStrictListType PD_StrictTailStrictConsSymbol PD_StrictTailStrictNilSymbol pre_mod_ident type_var type_var_with_attr (Strict 3) pre_def_symbols
 	  (unboxed_tail_strict_list_def,unboxed_tail_strict_cons_def,unboxed_tail_strict_nil_def,pre_def_symbols)
-		= make_list_definition PD_UnboxedTailStrictListType PD_UnboxedTailStrictConsSymbol PD_UnboxedTailStrictNilSymbol pre_mod_ident type_var type_var_with_attr pre_def_symbols
+		= make_list_definition PD_UnboxedTailStrictListType PD_UnboxedTailStrictConsSymbol PD_UnboxedTailStrictNilSymbol pre_mod_ident type_var type_var_with_attr (Strict 3) pre_def_symbols
 	  (overloaded_list_def,overloaded_cons_def,overloaded_nil_def,pre_def_symbols)
-		= make_list_definition PD_OverloadedListType PD_OverloadedConsSymbol PD_OverloadedNilSymbol pre_mod_ident type_var type_var_with_attr pre_def_symbols
+		= make_list_definition PD_OverloadedListType PD_OverloadedConsSymbol PD_OverloadedNilSymbol pre_mod_ident type_var type_var_with_attr NotStrict pre_def_symbols
 
 	  (array_def, pre_def_symbols)		= make_type_def PD_LazyArrayType [type_var] (AbstractType cAllBitsClear) pre_def_symbols
 	  (strict_def, pre_def_symbols)		= make_type_def PD_StrictArrayType [type_var] (AbstractType cIsHyperStrict) pre_def_symbols
@@ -585,7 +585,9 @@ where
 			  
 			  (tuple_type_def, pre_def_symbols)	= make_type_def (GetTupleTypeIndex tup_arity) type_vars (AlgType [tuple_cons_symb]) pre_def_symbols
 			  tuple_cons_def	= { pc_cons_name = tuple_ident, pc_cons_arity = tup_arity, pc_cons_pos = PreDefPos pre_mod_id,
-			  						pc_arg_types = [ MakeAttributedType (TV tv) \\ tv <- type_vars], pc_cons_prio =  NoPrio, pc_exi_vars = []}
+			  						pc_arg_types = [ MakeAttributedType (TV tv) \\ tv <- type_vars],
+			  						pc_args_strictness = NotStrict,
+			  						pc_cons_prio =  NoPrio, pc_exi_vars = []}
 			= add_tuple_defs pre_mod_id (dec tup_arity) [tuple_type_def : type_defs] [ParsedConstructorToConsDef tuple_cons_def : cons_defs] pre_def_symbols
 			= (type_defs, cons_defs, pre_def_symbols)
 	where
@@ -603,8 +605,8 @@ where
 		
 		  class_var = MakeTypeVar type_var_ident
 
-		  me_type = { st_vars = [], st_args = [], st_arity = 0,
-					  st_result = { at_attribute = TA_None, at_annotation = AN_None, at_type = TV class_var },
+		  me_type = { st_vars = [], st_args = [], st_args_strictness=NotStrict, st_arity = 0,
+					  st_result = { at_attribute = TA_None, at_type = TV class_var },
 					  st_context = [ {tc_class = {glob_module = NoIndex, glob_object = {ds_ident = tc_class_name, ds_arity = 1, ds_index = NoIndex }},
 					   				tc_types = [ TV class_var ], tc_var = nilPtr}],
 					  st_attr_vars = [], st_attr_env = [] }
@@ -621,8 +623,8 @@ where
 
 // MW..
 	make_identity_fun_type alias_dummy_id type_var
-		# a = { at_attribute = TA_Anonymous, at_annotation = AN_Strict, at_type = TV type_var }
-		  id_symbol_type = { st_vars = [], st_args = [a], st_arity = 1, st_result = a, st_context = [], 
+		# a = { at_attribute = TA_Anonymous, at_type = TV type_var }
+		  id_symbol_type = { st_vars = [], st_args = [a], st_args_strictness = Strict 1, st_arity = 1, st_result = a, st_context = [], 
 							st_attr_vars = [], st_attr_env = [] } // !.a -> .a
 		= { ft_symb = alias_dummy_id, ft_arity = 1, ft_priority = NoPrio, ft_type = id_symbol_type, ft_pos = NoPos,
 			ft_specials = SP_None, ft_type_ptr = nilPtr }
diff --git a/frontend/refmark.icl b/frontend/refmark.icl
index 02f691b..e447641 100644
--- a/frontend/refmark.icl
+++ b/frontend/refmark.icl
@@ -749,6 +749,9 @@ where
 	has_observing_type (TA {type_index = {glob_object,glob_module}} type_args) type_def_infos subst
 		# {tdi_properties} = type_def_infos.[glob_module].[glob_object]
 		= foldSt (\ {at_type} ok -> ok && has_observing_type at_type type_def_infos subst) type_args (tdi_properties bitand cIsHyperStrict <> 0)
+	has_observing_type (TAS {type_index = {glob_object,glob_module}} type_args _) type_def_infos subst
+		# {tdi_properties} = type_def_infos.[glob_module].[glob_object]
+		= foldSt (\ {at_type} ok -> ok && has_observing_type at_type type_def_infos subst) type_args (tdi_properties bitand cIsHyperStrict <> 0)
 	has_observing_type type type_def_infos subst
 		= False
 					
diff --git a/frontend/syntax.dcl b/frontend/syntax.dcl
index cfae612..bdbaecd 100644
--- a/frontend/syntax.dcl
+++ b/frontend/syntax.dcl
@@ -176,12 +176,15 @@ cIsNotAFunction :== False
 
 ::	FunKind = FK_Function !Bool | FK_Macro | FK_Caf | FK_NodeDefOrFunction | FK_Unknown
 
+::	StrictnessList = NotStrict | Strict !Int | StrictList !Int StrictnessList
+
 cNameNotLocationDependent :== False
 cNameLocationDependent :== True
 
 ::	ParsedSelector =
 	{	ps_field_name		:: !Ident
 	,	ps_selector_name	:: !Ident
+	,	ps_field_annotation	:: !Annotation
 	,	ps_field_type		:: !AType
 	,	ps_field_var		:: !Ident
 	,	ps_field_pos		:: !Position
@@ -192,6 +195,7 @@ cNameLocationDependent :== True
 	,	pc_cons_arity	:: !Int
 	,	pc_exi_vars		:: ![ATypeVar]
 	,	pc_arg_types	:: ![AType]
+	,	pc_args_strictness	:: !StrictnessList
 	,	pc_cons_prio	:: !Priority
 	,	pc_cons_pos		:: !Position
 	}
@@ -814,6 +818,7 @@ cNonRecursiveAppl	:== False
 ::	SymbolType =
 	{	st_vars			:: ![TypeVar]
 	,	st_args			:: ![AType]
+	,	st_args_strictness :: !StrictnessList
 	,	st_arity		:: !Int
 	,	st_result		:: !AType
 	,	st_context		:: ![TypeContext]
@@ -829,7 +834,6 @@ cNonRecursiveAppl	:== False
 
 ::	AType =
 	{	at_attribute	:: !TypeAttribute
-	,	at_annotation	:: !Annotation
 	,	at_type			:: !Type
 	}
 	
@@ -838,6 +842,7 @@ cNonRecursiveAppl	:== False
 
 
 ::	Type	=	TA !TypeSymbIdent ![AType]
+			|	TAS !TypeSymbIdent ![AType] !StrictnessList
 			|	(-->) infixr 9 !AType !AType
 			| 	TArrow							/* (->) */
 			| 	TArrow1	!AType					/* ((->) a) */
@@ -924,7 +929,6 @@ cNonRecursiveAppl	:== False
 
 ::	ATypeVar =
 	{	atv_attribute		:: !TypeAttribute
-	,	atv_annotation		:: !Annotation
 	,	atv_variable		:: !TypeVar
 	}
 
@@ -939,7 +943,7 @@ cNonRecursiveAppl	:== False
 	,	av_info_ptr		:: !AttrVarInfoPtr
 	}
 
-::	Annotation	=  AN_Strict | AN_None 
+::	Annotation	=  AN_Strict | AN_None
 
 ::	BasicType	= BT_Int | BT_Char | BT_Real | BT_Bool | BT_Dynamic
 				| BT_File | BT_World
@@ -1322,8 +1326,8 @@ EmptyTypeDefInfo :== { tdi_kinds = [], tdi_properties = cAllBitsClear, tdi_group
 MakeTypeVar name	:== { tv_name = name, tv_info_ptr = nilPtr }
 MakeVar name		:== { var_name = name, var_info_ptr = nilPtr, var_expr_ptr = nilPtr }
 
-MakeAttributedType type :== { at_attribute = TA_None, at_annotation = AN_None, at_type = type }
-MakeAttributedTypeVar type_var :== { atv_attribute = TA_None, atv_annotation = AN_None, atv_variable = type_var }
+MakeAttributedType type :== { at_attribute = TA_None, at_type = type }
+MakeAttributedTypeVar type_var :== { atv_attribute = TA_None, atv_variable = type_var }
 
 EmptyFunInfo :== { fi_calls = [], fi_group_index = NoIndex, fi_def_level = NotALevel,
 				   fi_free_vars = [], fi_local_vars = [], fi_dynamics = [], fi_properties=0 }
@@ -1345,12 +1349,12 @@ MakeTypeSymbIdent type_index name arity
 ParsedSelectorToSelectorDef sd_type_index ps :==
 	{	sd_symb = ps.ps_selector_name, sd_field_nr = NoIndex, sd_pos =  ps.ps_field_pos, sd_type_index = sd_type_index,
 		sd_exi_vars = [], sd_type_ptr = nilPtr, sd_field = ps.ps_field_name,
-		sd_type	= { st_vars = [], st_args = [], st_result = ps.ps_field_type, st_arity = 0, st_context = [],
+		sd_type	= { st_vars = [], st_args = [], st_args_strictness=NotStrict, st_result = ps.ps_field_type, st_arity = 0, st_context = [],
 				    st_attr_env = [], st_attr_vars = [] }}
 
 ParsedConstructorToConsDef pc :==
 	{	cons_symb = pc.pc_cons_name, cons_pos = pc.pc_cons_pos, cons_priority = pc.pc_cons_prio, cons_index = NoIndex, cons_type_index = NoIndex,
-		cons_type = { st_vars = [], st_args = pc.pc_arg_types, st_result = MakeAttributedType TE, 
+		cons_type = { st_vars = [], st_args = pc.pc_arg_types, st_args_strictness=pc.pc_args_strictness, st_result = MakeAttributedType TE, 
 				  st_arity = pc.pc_cons_arity, st_context = [], st_attr_env = [], st_attr_vars = []},
 		cons_exi_vars = pc.pc_exi_vars, cons_type_ptr = nilPtr, cons_arg_vars = [] }
 
diff --git a/frontend/syntax.icl b/frontend/syntax.icl
index 8071393..0c6b9aa 100644
--- a/frontend/syntax.icl
+++ b/frontend/syntax.icl
@@ -172,6 +172,8 @@ cIsNotAFunction :== False
 	|	PD_ImportedObjects [ImportedObject]
 	|	PD_Erroneous
 
+::	StrictnessList = NotStrict | Strict !Int | StrictList !Int StrictnessList
+
 ::	FunKind = FK_Function !Bool | FK_Macro | FK_Caf | FK_NodeDefOrFunction | FK_Unknown
 
 cNameNotLocationDependent :== False
@@ -180,6 +182,7 @@ cNameLocationDependent :== True
 ::	ParsedSelector =
 	{	ps_field_name		:: !Ident
 	,	ps_selector_name	:: !Ident
+	,	ps_field_annotation	:: !Annotation
 	,	ps_field_type		:: !AType
 	,	ps_field_var		:: !Ident
 	,	ps_field_pos		:: !Position
@@ -190,6 +193,7 @@ cNameLocationDependent :== True
 	,	pc_cons_arity	:: !Int
 	,	pc_exi_vars		:: ![ATypeVar]
 	,	pc_arg_types	:: ![AType]
+	,	pc_args_strictness	:: !StrictnessList
 	,	pc_cons_prio	:: !Priority
 	,	pc_cons_pos		:: !Position
 	}
@@ -796,6 +800,7 @@ cNotVarNumber :== -1
 ::	SymbolType =
 	{	st_vars			:: ![TypeVar]
 	,	st_args			:: ![AType]
+	,	st_args_strictness :: !StrictnessList
 	,	st_arity		:: !Int
 	,	st_result		:: !AType
 	,	st_context		:: ![TypeContext]
@@ -811,7 +816,6 @@ cNotVarNumber :== -1
 
 ::	AType =
 	{	at_attribute	:: !TypeAttribute
-	,	at_annotation	:: !Annotation
 	,	at_type			:: !Type
 	}
 	
@@ -819,6 +823,7 @@ cNotVarNumber :== -1
 ::	TempVarId		:== Int
 
 ::	Type	=	TA !TypeSymbIdent ![AType]
+			|	TAS !TypeSymbIdent ![AType] !StrictnessList
 			|	(-->) infixr 9 !AType !AType
 			| 	TArrow							/* (->) */
 			| 	TArrow1	!AType					/* ((->) a) */
@@ -908,7 +913,6 @@ cNotVarNumber :== -1
 
 ::	ATypeVar =
 	{	atv_attribute		:: !TypeAttribute
-	,	atv_annotation		:: !Annotation
 	,	atv_variable		:: !TypeVar
 	}
 
@@ -1283,6 +1287,8 @@ instance needs_brackets Type
 where
 	needs_brackets (TA {type_arity} _)
 		= type_arity > 0
+	needs_brackets (TAS {type_arity} _ _)
+		= type_arity > 0
 	needs_brackets (_ --> _)
 		= True
 	needs_brackets (_ :@: _)
@@ -1341,8 +1347,8 @@ where
 
 instance <<< AType
 where
-	(<<<) file {at_annotation,at_attribute,at_type}
-		= file <<< at_annotation <<< at_attribute <<< at_type
+	(<<<) file {at_attribute,at_type}
+		= file <<< at_attribute <<< at_type
 
 instance <<< TypeAttribute
 where
@@ -1383,8 +1389,8 @@ where
 
 instance <<< ATypeVar
 where
-	(<<<) file {atv_annotation,atv_attribute,atv_variable}
-		= file <<< atv_annotation <<< atv_attribute <<< atv_variable
+	(<<<) file {atv_attribute,atv_variable}
+		= file <<< atv_attribute <<< atv_variable
 
 instance <<< ConsVariable
 where
@@ -1395,6 +1401,15 @@ where
 	(<<<) file (TempQCV tv)
 		= file <<<  "E." <<< tv <<< ' ' 
 
+instance <<< StrictnessList
+where
+	(<<<) file (NotStrict)
+		= file <<< 0
+	(<<<) file (Strict s)
+		= file <<< s
+	(<<<) file (StrictList s l)
+		= file <<< s <<< ' ' <<< l
+
 instance <<< Type
 where
 	(<<<) file (TV varid)
@@ -1403,6 +1418,8 @@ where
 		= file  <<< 'v' <<< tv_number <<< ' ' 
 	(<<<) file (TA consid types)
 		= file  <<< consid <<< " " <<< types
+	(<<<) file (TAS consid types strictness)
+		= file  <<< consid <<< ' ' <<< strictness <<< ' ' <<< types
 	(<<<) file (arg_type --> res_type)
 		= file <<< arg_type <<< " -> " <<< res_type
 //AA..		
@@ -1437,8 +1454,8 @@ instance <<< SymbolType
 where
 	(<<<) file st=:{st_vars,st_attr_vars}
 		| st.st_arity == 0
-			= write_inequalities st.st_attr_env (write_contexts st.st_context (file <<< '[' <<< st_vars <<< ',' <<< st_attr_vars <<< ']' <<< st.st_result))
-			= write_inequalities st.st_attr_env (write_contexts st.st_context (file <<< '[' <<< st_vars <<< ',' <<< st_attr_vars <<< ']' <<< st.st_args <<< " -> " <<< st.st_result))
+			= write_inequalities st.st_attr_env (write_contexts st.st_context (file <<< '[' <<< st_vars <<< ',' <<< st_attr_vars <<< ']' <<< st.st_args_strictness <<< ' ' <<< st.st_result))
+			= write_inequalities st.st_attr_env (write_contexts st.st_context (file <<< '[' <<< st_vars <<< ',' <<< st_attr_vars <<< ']' <<< st.st_args_strictness <<< ' ' <<< st.st_args <<< " -> " <<< st.st_result))
 
 write_contexts [] file
 	= file
@@ -2184,8 +2201,8 @@ EmptyTypeDefInfo :== { tdi_kinds = [], tdi_properties = cAllBitsClear, tdi_group
 MakeTypeVar name :== { tv_name = name, tv_info_ptr = nilPtr }
 MakeVar name :== { var_name = name, var_info_ptr = nilPtr, var_expr_ptr = nilPtr }
 
-MakeAttributedType type :== { at_attribute = TA_None, at_annotation = AN_None, at_type = type }
-MakeAttributedTypeVar type_var :== { atv_attribute = TA_None, atv_annotation = AN_None, atv_variable = type_var }
+MakeAttributedType type :== { at_attribute = TA_None, at_type = type }
+MakeAttributedTypeVar type_var :== { atv_attribute = TA_None, atv_variable = type_var }
 
 EmptyFunInfo :== { fi_calls = [], fi_group_index = NoIndex, fi_def_level = NotALevel,
 				   fi_free_vars = [], fi_local_vars = [], fi_dynamics = [], fi_properties=0 }
@@ -2212,12 +2229,12 @@ MakeTypeSymbIdentMacro type_index name arity
 ParsedSelectorToSelectorDef sd_type_index ps :==
 	{	sd_symb = ps.ps_selector_name, sd_field_nr = NoIndex, sd_pos =  ps.ps_field_pos, sd_type_index = sd_type_index,
 		sd_exi_vars = [], sd_type_ptr = nilPtr, sd_field = ps.ps_field_name,
-		sd_type	= { st_vars = [], st_args = [], st_result = ps.ps_field_type, st_arity = 0, st_context = [],
+		sd_type	= { st_vars = [], st_args = [], st_args_strictness=NotStrict, st_result = ps.ps_field_type, st_arity = 0, st_context = [],
 				    st_attr_env = [], st_attr_vars = [] }}
 
 ParsedConstructorToConsDef pc :==
 	{	cons_symb = pc.pc_cons_name, cons_pos = pc.pc_cons_pos, cons_priority = pc.pc_cons_prio, cons_index = NoIndex, cons_type_index = NoIndex,
-		cons_type = { st_vars = [], st_args = pc.pc_arg_types, st_result = MakeAttributedType TE, 
+		cons_type = { st_vars = [], st_args = pc.pc_arg_types, st_args_strictness=pc.pc_args_strictness, st_result = MakeAttributedType TE, 
 				  st_arity = pc.pc_cons_arity, st_context = [], st_attr_env = [], st_attr_vars = []},
 		cons_exi_vars = pc.pc_exi_vars, cons_type_ptr = nilPtr, cons_arg_vars = [] }
 
diff --git a/frontend/trans.icl b/frontend/trans.icl
index c6d1a7a..d7e436b 100644
--- a/frontend/trans.icl
+++ b/frontend/trans.icl
@@ -999,8 +999,7 @@ transformCase this_case=:{case_expr,case_guards,case_default,case_ident,case_inf
 			| cons_index.glob_module == glob_module && cons_index.glob_object == ds_index
 				# zipped = zip2 ap_vars app_args
 				  {cons_type} = ro.ro_common_defs.[glob_module].com_cons_defs.[ds_index]
-				  laziness = [type.at_annotation == AN_None \\ type <- cons_type.st_args]
-				  unfoldables = [ (lazy && linear) || in_normal_form app_arg \\ linear <- linearity & app_arg <- app_args & lazy <- laziness]
+				  unfoldables = [ ((not (arg_is_strict i cons_type.st_args_strictness)) && linear) || in_normal_form app_arg \\ linear <- linearity & app_arg <- app_args & i <- [0..]]
 				  unfoldable_args = filterWith unfoldables zipped
 				  not_unfoldable = map not unfoldables
 				  non_unfoldable_args = filterWith not_unfoldable zipped
@@ -1160,7 +1159,7 @@ possibly_generate_case_function kees=:{case_info_ptr} aci=:{aci_free_vars} ro ti
 		  (copied_expr, {us_var_heap=ti_var_heap, us_symbol_heap=ti_symbol_heap, us_cleanup_info=ti_cleanup_info,
 								us_opt_type_heaps = Yes ti_type_heaps})
 				= unfold new_expr ui us
-		  fun_type = { st_vars = fresh_type_vars, st_args = fresh_arg_types, st_arity = fun_arity, st_result = fresh_result_type,
+		  fun_type = { st_vars = fresh_type_vars, st_args = fresh_arg_types, st_arity = fun_arity, st_args_strictness=NotStrict, st_result = fresh_result_type,
 						st_context = [], st_attr_vars = [], st_attr_env = [] }
 		  fun_def =	{	fun_symb = ro_fun.symb_name
 					,	fun_arity = fun_arity
@@ -1433,8 +1432,30 @@ readableCoercions {coer_demanded}
 		# (vars, _) = flattenCoercionTree ct
 		= map TA_TempVar vars
 
+:: ATypesWithStrictness = {ats_types::![AType],ats_strictness::!StrictnessList};
+
+compute_args_strictness new_arg_types_array = compute_args_strictness 0 0 NotStrict 0 new_arg_types_array
+  	where
+  		compute_args_strictness strictness_index strictness strictness_list array_index new_arg_types_array
+  			| array_index==size new_arg_types_array
+  				| strictness==0
+  					= strictness_list
+  					= append_strictness strictness strictness_list
+  				# {ats_types,ats_strictness} = new_arg_types_array.[array_index]
+  				# (strictness_index,strictness) = add_strictness_for_arguments ats_types 0 strictness_index strictness strictness_list
+  					with
+  						add_strictness_for_arguments [] ats_strictness_index strictness_index strictness strictness_list
+  							= (strictness_index,strictness)
+  						add_strictness_for_arguments [_:ats_types] ats_strictness_index strictness_index strictness strictness_list
+  							| arg_is_strict ats_strictness_index ats_strictness
+  								# (strictness_index,strictness,strictness_list) = add_next_strict strictness_index strictness strictness_list
+  								= add_strictness_for_arguments ats_types (ats_strictness_index+1) strictness_index strictness strictness_list
+  								# (strictness_index,strictness,strictness_list) = add_next_not_strict strictness_index strictness strictness_list
+  								= add_strictness_for_arguments ats_types (ats_strictness_index+1) strictness_index strictness strictness_list
+  				= compute_args_strictness strictness_index strictness strictness_list (array_index+1) new_arg_types_array
+	
 generateFunction :: !FunDef !ConsClasses !{! Producer} !FunctionInfoPtr !ReadOnlyTI !*TransformInfo -> (!Index, !Int, !*TransformInfo)
-generateFunction fd=:{fun_body = TransformedBody {tb_args,tb_rhs},fun_info = {fi_group_index}} 
+generateFunction fd=:{fun_body = TransformedBody {tb_args,tb_rhs},fun_info = {fi_group_index}}
 				 {cc_args,cc_linear_bits} prods fun_def_ptr ro
 				 ti=:{ti_var_heap,ti_next_fun_nr,ti_new_functions,ti_fun_heap,ti_symbol_heap,ti_fun_defs,
 				 		ti_type_heaps,ti_cons_args,ti_cleanup_info, ti_type_def_infos}
@@ -1449,7 +1470,7 @@ generateFunction fd=:{fun_body = TransformedBody {tb_args,tb_rhs},fun_info = {fi
 //		= undef
 */
 	#!(fi_group_index, ti_cons_args, ti_fun_defs, ti_fun_heap)
-			= max_group_index 0 prods fi_group_index ti_fun_defs ti_fun_heap ti_cons_args
+			= max_group_index 0 prods ro.ro_main_dcl_module_n fi_group_index ti_fun_defs ti_fun_heap ti_cons_args
 	# (Yes consumer_symbol_type) 
 			= fd.fun_type
 	  (function_producer_types, ti_fun_defs, ti_fun_heap)
@@ -1460,7 +1481,7 @@ generateFunction fd=:{fun_body = TransformedBody {tb_args,tb_rhs},fun_info = {fi
 	  ([Yes sound_consumer_symbol_type:opt_sound_function_producer_types], (ti_type_heaps, ti_type_def_infos))
 	  		= mapSt (add_propagation_attributes ro.ro_common_defs) [Yes consumer_symbol_type: fresh_function_producer_types]
 	  				(ti_type_heaps, ti_type_def_infos)
-	  ({st_attr_vars,st_args,st_result,st_attr_env})
+	  ({st_attr_vars,st_args,st_args_strictness,st_result,st_attr_env})
 	  		= sound_consumer_symbol_type
 	  (class_types, ti_fun_defs, ti_fun_heap)
 	  		= iFoldSt (accum_class_type prods ro) 0 (size prods) 
@@ -1492,10 +1513,13 @@ generateFunction fd=:{fun_body = TransformedBody {tb_args,tb_rhs},fun_info = {fi
 	    uniqueness_requirements, subst, let_bindings, ti_type_heaps=:{th_vars},
 	    ti_symbol_heap, ti_fun_defs, ti_fun_heap, ti_var_heap, ti_cons_args)
 			= determine_args cc_linear_bits cc_args 0 prods opt_sound_function_producer_types tb_args
-							(st_args_array st_args) next_attr_nr (tb_rhs, ro) 
+							(st_args_array st_args st_args_strictness) next_attr_nr (tb_rhs, ro) 
 							[] subst ([],[],[],[]) ti_type_heaps ti_symbol_heap ti_fun_defs 
 							ti_fun_heap ti_var_heap ti_cons_args
-	  new_arg_types = flatten [ el \\ el<-:new_arg_types_array ]
+	  new_arg_types = flatten [ ats_types \\ {ats_types}<-:new_arg_types_array ]
+	  
+	  new_args_strictness = compute_args_strictness new_arg_types_array
+	  	  	  
 	  (cons_vars, th_vars)
 			= foldSt set_cons_var_bit propagating_cons_vars
 					(createArray (inc (BITINDEX nr_of_all_type_vars)) 0, th_vars)
@@ -1544,7 +1568,7 @@ generateFunction fd=:{fun_body = TransformedBody {tb_args,tb_rhs},fun_info = {fi
 	  		= { el \\ el <- fresh_type_vars }
 	  (attr_partition, demanded) 
 	  		= partitionateAttributes coercions.coer_offered coercions.coer_demanded
-	  		// to eliminate circles in the attribute inequalities graph that was built during "determine_args"
+	  		// to eliminate circles in the attribute inequalities graph that was built during "det ermine_arg s"
 	  (fresh_attr_vars, ti_type_heaps)
 	  		= accAttrVarHeap (create_fresh_attr_vars demanded (size demanded)) { ti_type_heaps & th_vars = th_vars }
 	  		// the attribute variables stored in the "demanded" graph are represented as integers: 
@@ -1565,8 +1589,8 @@ generateFunction fd=:{fun_body = TransformedBody {tb_args,tb_rhs},fun_info = {fi
  	  		= getTypeVars (fresh_arg_types, fresh_result_type) ti_type_heaps.th_vars
 	  fun_arity
 	  		= length new_fun_args
-	  new_fun_type
-	  		= Yes { st_vars = all_fresh_type_vars, st_args = fresh_arg_types, st_arity = fun_arity,
+	# new_fun_type
+	  		= Yes { st_vars = all_fresh_type_vars, st_args = fresh_arg_types, st_args_strictness=new_args_strictness, st_arity = fun_arity,
 					st_result = fresh_result_type, st_context = [], st_attr_vars = all_attr_vars,
 					st_attr_env = coercionsToAttrEnv fresh_attr_vars final_coercions }
 /* DvA... STRICT_LET
@@ -1672,9 +1696,10 @@ where
 	is_dictionary _ es_td_infos
 		= False
 
-	st_args_array :: ![AType] -> .{![AType]}
-	st_args_array st_args
-		= { [el] \\ el <- st_args }
+	st_args_array :: ![AType] !StrictnessList -> .{#ATypesWithStrictness}
+	st_args_array st_args args_strictness
+		# strict1=Strict 1
+		= { {ats_types=[el],ats_strictness=if (arg_is_strict i args_strictness) strict1 NotStrict} \\ i<-[0..] & el <- st_args }
 		
 	determine_args _ [] prod_index producers prod_atypes forms arg_types next_attr_nr _ 
 				uniqueness_requirements subst let_bindings type_heaps symbol_heap fun_defs fun_heap var_heap ti_cons_args
@@ -1721,7 +1746,7 @@ where
 		determine_arg (PR_Class class_app free_vars_and_types class_type) _ {fv_info_ptr,fv_name} prod_index (_,(_, ro))
 					  (vars, arg_types, next_attr_nr, new_linear_bits, new_cons_args, 
 						uniqueness_requirements, subst, let_bindings, type_heaps, symbol_heap, fun_defs, fun_heap, var_heap, ti_cons_args)
-			# (arg_type, arg_types)
+			# ({ats_types=[arg_type:_]}, arg_types)
 					= arg_types![prod_index]
 			  (_, int_class_type, type_heaps)
 			  		= substitute class_type type_heaps
@@ -1733,14 +1758,14 @@ where
 					  ,	ti_main_dcl_module_n = ro.ro_main_dcl_module_n
 					  }
 			# (succ, subst, type_heaps)
-			  		= unify class_atype (hd arg_type) type_input subst type_heaps
+			  		= unify class_atype arg_type type_input subst type_heaps
 			| not succ
-				= abort ("sanity check nr 93 in module trans failed\n"--->(class_atype,"\n", (hd arg_type)))
+				= abort ("sanity check nr 93 in module trans failed\n"--->(class_atype,"\n", arg_type))
 			= ( mapAppend (\({var_info_ptr,var_name}, _)
 							-> { fv_name = var_name, fv_info_ptr = var_info_ptr, fv_def_level = NotALevel, fv_count = 0 })
 						  free_vars_and_types vars
-			  , { arg_types & [prod_index] = [ { empty_atype & at_type = at_type }
-			  									\\ (_, at_type) <- free_vars_and_types] }
+			  , { arg_types & [prod_index] = {ats_types= [ { empty_atype & at_type = at_type } \\ (_, at_type) <- free_vars_and_types],
+			  								  ats_strictness = first_n_strict (length free_vars_and_types) } }
 			  , next_attr_nr
 			  , mapAppend (\_ -> True) free_vars_and_types new_linear_bits
 			  , mapAppend (\_ -> cActive) free_vars_and_types new_cons_args
@@ -1754,7 +1779,7 @@ where
 			  , writeVarInfo fv_info_ptr (VI_Dictionary class_app.app_symb class_app.app_args class_type) var_heap
 			  , ti_cons_args
 			  )
-		determine_arg producer (Yes {st_args, st_result, st_attr_vars, st_context, st_attr_env, st_arity})
+		determine_arg producer (Yes {st_args, st_args_strictness, st_result, st_attr_vars, st_context, st_attr_env, st_arity})
 						{fv_info_ptr,fv_name} prod_index 
 						((linear_bit, _),(consumer_body_rhs, ro))
 						(vars, arg_types, next_attr_nr, new_linear_bits, new_cons_args, 
@@ -1768,7 +1793,7 @@ where
 					= size fun_defs
 			# ({cc_args, cc_linear_bits}, fun_heap, ti_cons_args)
 					= calc_cons_args curried symbol symbol_arity ti_cons_args linear_bit size_fun_defs fun_heap
-			  (arg_type, arg_types)
+			  ({ats_types=[arg_type:_],ats_strictness}, arg_types)
 			  		= arg_types![prod_index]
 			  (next_attr_nr, th_attrs)
 			  		= foldSt bind_to_temp_attr_var st_attr_vars (next_attr_nr, th_attrs)
@@ -1785,13 +1810,13 @@ where
 					  ,	ti_main_dcl_module_n = ro.ro_main_dcl_module_n
 					  }
 			  (succ, subst, type_heaps)
-			  		= unify application_type (hd arg_type) type_input subst type_heaps
+			  		= unify application_type arg_type type_input subst type_heaps
 			| not succ
-				= abort ("sanity check nr 94 in module trans failed"--->(application_type, (hd arg_type)))
+				= abort ("sanity check nr 94 in module trans failed"--->(application_type, arg_type))
 			# (attr_inequalities, type_heaps)
 					= accAttrVarHeap (mapSt substitute_attr_inequality st_attr_env) type_heaps
 			  new_uniqueness_requirement
-			  		= { ur_offered = application_type, ur_demanded = hd arg_type,
+			  		= { ur_offered = application_type, ur_demanded = arg_type,
 			  			ur_attr_ineqs = attr_inequalities }
 			  (opt_body, var_names, fun_defs, fun_heap)
 			  		= case producer of
@@ -1819,7 +1844,7 @@ where
 							-> (VI_Body symbol tb (take nr_of_applied_args form_vars), var_heap)
 /* DvA... STRICT_LET
 			  (expr_to_unfold, var_heap, let_bindings)
-					= case (hd arg_type).at_annotation of
+					= case arg_type.at_annotation of
 						AN_Strict
 							# (new_info_ptr_l, var_heap) = newPtr VI_Empty var_heap
 			  				# free_var_l = { fv_name = { id_name = "free_l", id_info = nilPtr }, fv_info_ptr = new_info_ptr_l, fv_count = 0, fv_def_level = NotALevel }
@@ -1830,12 +1855,12 @@ where
 							# var_heap = writeVarInfo new_info_ptr_l expr_to_unfold var_heap
 
 							# let_bindings = case let_bindings of
-											(s,l,st,lt) -> ([bind:s],l,[hd arg_type:st],lt)
+											(s,l,st,lt) -> ([bind:s],l,[arg_type:st],lt)
 							-> (VI_Empty, var_heap, let_bindings)
 						_	-> (expr_to_unfold,var_heap,let_bindings)
 ...DvA */
 			= (	form_vars
-			  , { arg_types & [prod_index] = take nr_of_applied_args st_args }
+			  , { arg_types & [prod_index] = {ats_types=take nr_of_applied_args st_args,ats_strictness=st_args_strictness} }
 			  , next_attr_nr
 			  , cc_linear_bits++new_linear_bits
 			  , cc_args++new_cons_args
@@ -1909,7 +1934,7 @@ where
 				= abort "sanity check nr 234 failed in module trans"
 			# (applied_args, unapplied_args) = splitAt (nr_of_applied_args-nr_context_args) st_args
 			  attr_approx = if (any has_unique_attribute applied_args) TA_Unique TA_Multi
-			= foldr (\atype1 atype2->{at_attribute=attr_approx, at_annotation=AN_None, at_type=atype1-->atype2})
+			= foldr (\atype1 atype2->{at_attribute=attr_approx, at_type=atype1-->atype2})
 					st_result unapplied_args
 		  where
 			has_unique_attribute {at_attribute=TA_Unique} = True
@@ -2049,9 +2074,11 @@ where
 				= (symbol_type, fun_defs, fun_heap)
 				= (symbol_type, fun_defs, fun_heap)
 			# {ft_type} = ro.ro_imported_funs.[glob_module].[glob_object]
-			  (_, ft_type) = removeAnnotations ft_type
-			  st_args = addTypesOfDictionaries ro.ro_common_defs ft_type.st_context ft_type.st_args
-			= ({ft_type & st_args = st_args, st_arity = length st_args, st_context = [] }, fun_defs, fun_heap)
+			  (_, ft_type=:{st_args,st_args_strictness}) = removeAnnotations ft_type
+			  new_st_args = addTypesOfDictionaries ro.ro_common_defs ft_type.st_context st_args
+			  new_st_arity = length new_st_args
+			  new_st_args_strictness = insert_n_strictness_values_at_beginning (new_st_arity-length st_args) st_args_strictness
+			= ({ft_type & st_args = new_st_args, st_args_strictness = new_st_args_strictness, st_arity = new_st_arity, st_context = [] }, fun_defs, fun_heap)
 // ... Sjaak
 	get_producer_type {symb_kind=SK_LocalMacroFunction glob_object} ro fun_defs fun_heap
 		# ({fun_type=Yes symbol_type}, fun_defs) = fun_defs![glob_object]
@@ -2095,13 +2122,28 @@ where
 		  		= cs
 		= (btype, (coercions, subst, ti_type_heaps, ti_type_def_infos))
 
-	max_group_index prod_index producers current_max fun_defs fun_heap cons_args
-		| prod_index == size producers
-			= (current_max, cons_args, fun_defs, fun_heap)
-			# (current_max, cons_args, fun_defs, fun_heap)
-				= max_group_index_of_producer producers.[prod_index] current_max fun_defs fun_heap cons_args
-			= max_group_index (inc prod_index) producers current_max fun_defs fun_heap cons_args
+	create_fresh_attr_vars :: !{!CoercionTree} !Int !*AttrVarHeap -> (!{!TypeAttribute}, !.AttrVarHeap)
+	create_fresh_attr_vars demanded nr_of_attr_vars th_attrs
+		# fresh_array = createArray nr_of_attr_vars TA_None
+		= iFoldSt (allocate_fresh_attr_var demanded) 0 nr_of_attr_vars (fresh_array, th_attrs)
+	  where
+		allocate_fresh_attr_var demanded i (attr_var_array, th_attrs)
+			= case demanded.[i] of
+				CT_Unique
+					-> ({ attr_var_array & [i] = TA_Unique}, th_attrs)
+				CT_NonUnique
+					-> ({ attr_var_array & [i] = TA_Multi}, th_attrs)
+				_
+					# (new_info_ptr, th_attrs) = newPtr AVI_Empty th_attrs
+					-> ({ attr_var_array & [i] = TA_Var { av_name = NewAttrVarId i, av_info_ptr = new_info_ptr }}, th_attrs)
 
+max_group_index prod_index producers ro_main_dcl_module_n current_max fun_defs fun_heap cons_args
+	| prod_index == size producers
+		= (current_max, cons_args, fun_defs, fun_heap)
+		# (current_max, cons_args, fun_defs, fun_heap)
+			= max_group_index_of_producer producers.[prod_index] current_max fun_defs fun_heap cons_args
+		= max_group_index (inc prod_index) producers ro_main_dcl_module_n current_max fun_defs fun_heap cons_args
+where
 	max_group_index_of_producer PR_Empty current_max fun_defs fun_heap cons_args
 		= (current_max, cons_args, fun_defs, fun_heap)
 	max_group_index_of_producer (PR_Class {app_args} _ _) current_max fun_defs fun_heap cons_args
@@ -2128,8 +2170,6 @@ where
 		= (current_max, cons_args, fun_defs, fun_heap)	// DvA: not a clue what we're trying here...
 	max_group_index_of_producer prod current_max fun_defs fun_heap cons_args
 		= abort ("trans.icl: max_group_index_of_producer" ---> prod)
-
-	ro_main_dcl_module_n = ro.ro_main_dcl_module_n
 	
 	max_group_index_of_member
 				(App {app_symb = {symb_name, symb_kind = SK_Function { glob_object = fun_index, glob_module = mod_index}}}) 
@@ -2169,21 +2209,6 @@ where
 			# (FI_Function generated_function, fun_heap) = readPtr fun_ptr fun_heap
 			= (max generated_function.gf_fun_def.fun_info.fi_group_index current_max, fun_defs, fun_heap)
 
-	create_fresh_attr_vars :: !{!CoercionTree} !Int !*AttrVarHeap -> (!{!TypeAttribute}, !.AttrVarHeap)
-	create_fresh_attr_vars demanded nr_of_attr_vars th_attrs
-		# fresh_array = createArray nr_of_attr_vars TA_None
-		= iFoldSt (allocate_fresh_attr_var demanded) 0 nr_of_attr_vars (fresh_array, th_attrs)
-	  where
-		allocate_fresh_attr_var demanded i (attr_var_array, th_attrs)
-			= case demanded.[i] of
-				CT_Unique
-					-> ({ attr_var_array & [i] = TA_Unique}, th_attrs)
-				CT_NonUnique
-					-> ({ attr_var_array & [i] = TA_Multi}, th_attrs)
-				_
-					# (new_info_ptr, th_attrs) = newPtr AVI_Empty th_attrs
-					-> ({ attr_var_array & [i] = TA_Var { av_name = NewAttrVarId i, av_info_ptr = new_info_ptr }}, th_attrs)
-
 class replaceIntegers a :: !a !({!TypeVar}, !{!TypeAttribute}, !AttributePartition) !*{#Bool} -> (!a, !.{#Bool})
 	// get rid of all those TempV and TA_Var things
 
@@ -2216,6 +2241,9 @@ instance replaceIntegers Type where
 	replaceIntegers (TA type_symb_ident args) input used
 		# (args, used) = replaceIntegers args input used
 		= (TA type_symb_ident args, used)
+	replaceIntegers (TAS type_symb_ident args strictness) input used
+		# (args, used) = replaceIntegers args input used
+		= (TAS type_symb_ident args strictness, used)
 	replaceIntegers (a --> b) input used
 		# (a, used) = replaceIntegers a input used
 		  (b, used) = replaceIntegers b input used
@@ -2739,20 +2767,22 @@ where
 				= common_defs.[glob_module].com_class_defs.[ds_index]
 		  dict_type_symb
 		  		= 	MakeTypeSymbIdent { glob_object = ds_index, glob_module = glob_module } ds_ident class_arity
-		= { at_attribute = TA_Multi, at_annotation = AN_Strict, at_type = TA dict_type_symb (
+		= { at_attribute = TA_Multi, /* at_annotation = AN_Strict, */ at_type = TA dict_type_symb (
 //				map (\type -> { at_attribute = TA_Multi, at_annotation = AN_None, at_type = type }) tc_types) }
 				fst (mapSt 	(\type class_cons_vars
 								-> let at_attribute = if (lowest_bit class_cons_vars) TA_MultiOfPropagatingConsVar TA_Multi
-							   		in ( { at_attribute = at_attribute, at_annotation = AN_None, at_type = type },
+							   		in ( { at_attribute = at_attribute, at_type = type },
 						   				class_cons_vars>>1)
 						   	)
 						  	tc_types
 						  	class_cons_vars))}
 
-expandSynTypesInSymbolType rem_annots common_defs st=:{st_args,st_result,st_context} ets
+expandSynTypesInSymbolType rem_annots common_defs st=:{st_args,st_args_strictness,st_result,st_context} ets
 	# (_,(st_args,st_result), ets) = expandSynTypes rem_annots common_defs (st_args,st_result) ets
-	  st_args = addTypesOfDictionaries common_defs st_context st_args
-	= ({st & st_args = st_args, st_result = st_result, st_arity = length st_args, st_context = [] }, ets)
+	  new_st_args = addTypesOfDictionaries common_defs st_context st_args
+	  new_st_arity = length new_st_args
+	  new_st_args_strictness = insert_n_strictness_values_at_beginning (new_st_arity-length st_args) st_args_strictness
+	= ({st & st_args = new_st_args, st_args_strictness = new_st_args_strictness, st_result = st_result, st_arity = new_st_arity, st_context = [] }, ets)
 	
 class expandSynTypes a :: !Bool !{# CommonDefs} !a !*ExpandTypeState -> (!Bool,!a, !*ExpandTypeState)
 
@@ -2772,6 +2802,8 @@ where
 			= (False,type, ets)
 	expandSynTypes rem_annots common_defs type=:(TA type_symb types) ets
 		= expand_syn_types_in_TA rem_annots common_defs type TA_Multi ets
+	expandSynTypes rem_annots common_defs type=:(TAS type_symb types _) ets
+		= expand_syn_types_in_TA rem_annots common_defs type TA_Multi ets
 // Sjaak 240801 ...
 	expandSynTypes rem_annots common_defs tfa_type=:(TFA vars type) ets
 		# (changed,type, ets) = expandSynTypes rem_annots common_defs type ets
@@ -2800,23 +2832,12 @@ where
 		# (changed_type2,type2,ets) = expandSynTypes rem_annots common_defs type2 ets
 		= (changed_type1 || changed_type2,(type1,type2),ets)
 
-expand_syn_types_in_TA rem_annots common_defs ta_type=:(TA type_symb=:{type_index={glob_object,glob_module},type_name} types) attribute ets=:{ets_type_defs}
-	# ({td_rhs,td_name,td_args,td_attribute},ets_type_defs) = ets_type_defs![glob_module].[glob_object]
-	  ets = { ets & ets_type_defs = ets_type_defs }
-	= case td_rhs of
-		SynType rhs_type
-			# ets_type_heaps = bind_attr td_attribute attribute ets.ets_type_heaps
-			  ets_type_heaps = (fold2St bind_var_and_attr td_args types ets_type_heaps)
-			  (_, type, ets_type_heaps) = substitute_rhs rem_annots rhs_type.at_type ets_type_heaps
-			# (_,type,ets) = expandSynTypes rem_annots common_defs type { ets & ets_type_heaps = ets_type_heaps }
-			-> (True,type,ets)
-		_
-			# (changed,types, ets) = expandSynTypes rem_annots common_defs types ets
-			# ta_type = if changed (TA type_symb types) ta_type
-			| glob_module == ets.ets_main_dcl_module_n
-				-> (changed,ta_type, ets)
-				-> (changed,ta_type, collect_imported_constructors common_defs glob_module td_rhs ets)
-where
+bind_and_substitute_before_expand types td_args td_attribute rhs_type rem_annots attribute ets_type_heaps
+	# ets_type_heaps = bind_attr td_attribute attribute ets_type_heaps
+	  ets_type_heaps = (fold2St bind_var_and_attr td_args types ets_type_heaps)
+	  (_, type, ets_type_heaps) = substitute_rhs rem_annots rhs_type.at_type ets_type_heaps
+	= (type, ets_type_heaps)
+	where
 		bind_var_and_attr {	atv_attribute = TA_Var {av_info_ptr},  atv_variable = {tv_info_ptr} } {at_attribute,at_type} type_heaps=:{th_vars,th_attrs}
 			= { type_heaps & th_vars = th_vars <:= (tv_info_ptr, TVI_Type at_type), th_attrs = th_attrs <:= (av_info_ptr, AVI_Attr at_attribute) }
 		bind_var_and_attr { atv_variable  = {tv_info_ptr}} {at_type} type_heaps=:{th_vars}
@@ -2827,34 +2848,63 @@ where
 		bind_attr _ attribute type_heaps
 			= type_heaps
 
-		collect_imported_constructors common_defs mod_index (RecordType {rt_constructor}) ets=:{ets_collected_conses,ets_var_heap}
-			# (ets_collected_conses, ets_var_heap)
-					= collect_imported_constructor mod_index common_defs.[mod_index].com_cons_defs rt_constructor (ets_collected_conses, ets_var_heap)
-			= { ets & ets_collected_conses = ets_collected_conses, ets_var_heap = ets_var_heap }
-		collect_imported_constructors common_defs mod_index (AlgType constructors) ets=:{ets_collected_conses,ets_var_heap}
-			# (ets_collected_conses, ets_var_heap) 
-					= foldSt (collect_imported_constructor mod_index common_defs.[mod_index].com_cons_defs) constructors (ets_collected_conses, ets_var_heap)
-			= { ets & ets_collected_conses = ets_collected_conses, ets_var_heap = ets_var_heap }
-		collect_imported_constructors common_defs mod_index _ ets
-			= ets
-
-		collect_imported_constructor mod_index cons_defs {ds_index} (collected_conses, var_heap)
-			# {cons_type_ptr} = cons_defs.[ds_index]
-			  (type_info, var_heap) = readVarInfo cons_type_ptr var_heap
-			| has_been_collected type_info
-				= (collected_conses, var_heap)
-				= ([{ glob_module = mod_index, glob_object = ds_index } : collected_conses ], writeVarInfo cons_type_ptr VI_Used var_heap)
-
-		has_been_collected VI_Used				= True
-		has_been_collected (VI_ExpandedType _)	= True
-		has_been_collected _					= False
-
 		substitute_rhs rem_annots rhs_type type_heaps
 			| rem_annots
 				# (_, rhs_type) = removeAnnotations rhs_type
 			  	= substitute rhs_type type_heaps
 			  	= substitute rhs_type type_heaps
 
+collect_imported_constructors common_defs mod_index (RecordType {rt_constructor}) ets=:{ets_collected_conses,ets_var_heap}
+	# (ets_collected_conses, ets_var_heap)
+			= collect_imported_constructor mod_index common_defs.[mod_index].com_cons_defs rt_constructor (ets_collected_conses, ets_var_heap)
+	= { ets & ets_collected_conses = ets_collected_conses, ets_var_heap = ets_var_heap }
+collect_imported_constructors common_defs mod_index (AlgType constructors) ets=:{ets_collected_conses,ets_var_heap}
+	# (ets_collected_conses, ets_var_heap) 
+			= foldSt (collect_imported_constructor mod_index common_defs.[mod_index].com_cons_defs) constructors (ets_collected_conses, ets_var_heap)
+	= { ets & ets_collected_conses = ets_collected_conses, ets_var_heap = ets_var_heap }
+collect_imported_constructors common_defs mod_index _ ets
+	= ets
+
+collect_imported_constructor mod_index cons_defs {ds_index} (collected_conses, var_heap)
+	# {cons_type_ptr} = cons_defs.[ds_index]
+	  (type_info, var_heap) = readVarInfo cons_type_ptr var_heap
+	| has_been_collected type_info
+		= (collected_conses, var_heap)
+		= ([{ glob_module = mod_index, glob_object = ds_index } : collected_conses ], writeVarInfo cons_type_ptr VI_Used var_heap)
+where
+	has_been_collected VI_Used				= True
+	has_been_collected (VI_ExpandedType _)	= True
+	has_been_collected _					= False
+
+expand_syn_types_in_TA rem_annots common_defs ta_type=:(TA type_symb=:{type_index={glob_object,glob_module},type_name} types) attribute ets=:{ets_type_defs}
+	# ({td_rhs,td_name,td_args,td_attribute},ets_type_defs) = ets_type_defs![glob_module].[glob_object]
+	  ets = { ets & ets_type_defs = ets_type_defs }
+	= case td_rhs of
+		SynType rhs_type
+			# (type,ets_type_heaps) = bind_and_substitute_before_expand types td_args td_attribute rhs_type rem_annots attribute ets.ets_type_heaps
+			# (_,type,ets) = expandSynTypes rem_annots common_defs type { ets & ets_type_heaps = ets_type_heaps }
+			-> (True,type,ets)
+		_
+			# (changed,types, ets) = expandSynTypes rem_annots common_defs types ets
+			# ta_type = if changed (TA type_symb types) ta_type
+			| glob_module == ets.ets_main_dcl_module_n
+				-> (changed,ta_type, ets)
+				-> (changed,ta_type, collect_imported_constructors common_defs glob_module td_rhs ets)
+expand_syn_types_in_TA rem_annots common_defs ta_type=:(TAS type_symb=:{type_index={glob_object,glob_module},type_name} types strictness) attribute ets=:{ets_type_defs}
+	# ({td_rhs,td_name,td_args,td_attribute},ets_type_defs) = ets_type_defs![glob_module].[glob_object]
+	  ets = { ets & ets_type_defs = ets_type_defs }
+	= case td_rhs of
+		SynType rhs_type
+			# (type,ets_type_heaps) = bind_and_substitute_before_expand types td_args td_attribute rhs_type rem_annots attribute ets.ets_type_heaps
+			# (_,type,ets) = expandSynTypes rem_annots common_defs type { ets & ets_type_heaps = ets_type_heaps }
+			-> (True,type,ets)
+		_
+			# (changed,types, ets) = expandSynTypes rem_annots common_defs types ets
+			# ta_type = if changed (TAS type_symb types strictness) ta_type
+			| glob_module == ets.ets_main_dcl_module_n
+				-> (changed,ta_type, ets)
+				-> (changed,ta_type, collect_imported_constructors common_defs glob_module td_rhs ets)
+
 instance expandSynTypes AType
 where
 	expandSynTypes rem_annots common_defs atype ets
@@ -2865,6 +2915,11 @@ where
 			| changed
 				= (True,{ atype & at_type = at_type }, ets)
 				= (False,atype,ets)
+		expand_syn_types_in_a_type rem_annots common_defs atype=:{at_type = at_type=: TAS type_symb types _,at_attribute} ets
+			# (changed,at_type, ets) = expand_syn_types_in_TA rem_annots common_defs at_type at_attribute ets
+			| changed
+				= (True,{ atype & at_type = at_type }, ets)
+				= (False,atype,ets)
 		expand_syn_types_in_a_type rem_annots common_defs atype ets
 			# (changed,at_type, ets) = expandSynTypes rem_annots common_defs atype.at_type ets
 			| changed
@@ -3112,7 +3167,7 @@ lowest_bit int :== int bitand 1 <> 0
 isYes (Yes _) = True
 isYes _ = False
 
-empty_atype = { at_attribute = TA_Multi, at_annotation = AN_None, at_type = TE }
+empty_atype = { at_attribute = TA_Multi, at_type = TE }
 
 mapExprSt map_expr map_free_var postprocess_free_var expr st :== map_expr_st expr st
   where
diff --git a/frontend/type.icl b/frontend/type.icl
index c84bc24..43c93d7 100644
--- a/frontend/type.icl
+++ b/frontend/type.icl
@@ -81,7 +81,12 @@ where
 	arraySubst type=:(TA cons_id cons_args) subst
 		# (changed, cons_args, subst) = arraySubst cons_args subst
 		| changed
-			= (True, TA cons_id cons_args, subst) 
+			= (True, TA cons_id cons_args, subst)
+			= (False,type, subst) 
+	arraySubst type=:(TAS cons_id cons_args strictness) subst
+		# (changed, cons_args, subst) = arraySubst cons_args subst
+		| changed
+			= (True, TAS cons_id cons_args strictness, subst)
 			= (False,type, subst) 
 	arraySubst tcv=:(TempCV tv_number :@: types) subst
 		# (type, subst) = subst![tv_number]
@@ -183,6 +188,8 @@ where
 //..AA
 	containsTypeVariable var_id (TA cons_id cons_args) subst
 		= containsTypeVariable var_id cons_args subst
+	containsTypeVariable var_id (TAS cons_id cons_args _) subst
+		= containsTypeVariable var_id cons_args subst
 	containsTypeVariable var_id (type :@: types) subst
 		= containsTypeVariable var_id type subst || containsTypeVariable var_id types subst
 	containsTypeVariable _ _ _
@@ -308,23 +315,28 @@ unifyTypes t1=:(TB tb1) attr1 t2=:(TB tb2) attr2 modules subst heaps
 	| tb1 == tb2
 		= (True, subst, heaps)
 		= (False, subst, heaps)
+unifyTypes t1=:(TA cons_id1 cons_args1) attr1 t2=:(TA cons_id2 cons_args2) attr2 modules subst heaps
+	| cons_id1 == cons_id2
+		= unify cons_args1 cons_args2 modules subst heaps
+		= expandAndUnifyTypes t1 attr1 t2 attr2 modules subst heaps
+unifyTypes t1=:(TA cons_id1 cons_args1) attr1 t2=:(TAS cons_id2 cons_args2 _) attr2 modules subst heaps
+	| cons_id1 == cons_id2
+		= unify cons_args1 cons_args2 modules subst heaps
+		= expandAndUnifyTypes t1 attr1 t2 attr2 modules subst heaps
+unifyTypes t1=:(TAS cons_id1 cons_args1 _) attr1 t2=:(TA cons_id2 cons_args2) attr2 modules subst heaps
+	| cons_id1 == cons_id2
+		= unify cons_args1 cons_args2 modules subst heaps
+		= expandAndUnifyTypes t1 attr1 t2 attr2 modules subst heaps
+unifyTypes t1=:(TAS cons_id1 cons_args1 _) attr1 t2=:(TAS cons_id2 cons_args2 _) attr2 modules subst heaps
+	| cons_id1 == cons_id2
+		= unify cons_args1 cons_args2 modules subst heaps
+		= expandAndUnifyTypes t1 attr1 t2 attr2 modules subst heaps
 unifyTypes (arg_type1 --> res_type1) attr1 (arg_type2 --> res_type2) attr2 modules subst heaps
 	= unify (arg_type1,res_type1) (arg_type2,res_type2) modules subst heaps
-//AA..	
 unifyTypes TArrow attr1 TArrow attr2 modules subst heaps
 	= (True, subst, heaps)	
 unifyTypes (TArrow1 t1) attr1 (TArrow1 t2) attr2 modules subst heaps
 	= unify t1 t2 modules subst heaps	
-//..AA
-unifyTypes t1=:(TA cons_id1 cons_args1) attr1 t2=:(TA cons_id2 cons_args2) attr2 modules subst heaps
-	| cons_id1 == cons_id2
-		= unify cons_args1 cons_args2 modules subst heaps
-		# (succ1, t1, heaps) = tryToExpand t1 attr1 modules.ti_common_defs heaps
-		  (succ2, t2, heaps) = tryToExpand t2 attr2 modules.ti_common_defs heaps
-		| succ1 || succ2
-			= unifyTypes t1 attr1 t2 attr2 modules subst heaps
-			= (False, subst, heaps)
-//				---> "unifyTypes1"
 unifyTypes (cons_var :@: types) attr1 type2 attr2 modules subst heaps
 	# (_, type2, heaps) = tryToExpand type2 attr2 modules.ti_common_defs heaps
 	= unifyTypeApplications cons_var attr1 types type2 attr2 modules subst heaps
@@ -344,6 +356,13 @@ unifyTypes type1 attr1 type2 attr2 modules subst heaps
 		= unifyTypes type1 attr1 type2 attr2 modules subst heaps
 		= (False, subst, heaps)
 
+expandAndUnifyTypes t1 attr1 t2 attr2 modules subst heaps
+	# (succ1, t1, heaps) = tryToExpand t1 attr1 modules.ti_common_defs heaps
+	  (succ2, t2, heaps) = tryToExpand t2 attr2 modules.ti_common_defs heaps
+	| succ1 || succ2
+		= unifyTypes t1 attr1 t2 attr2 modules subst heaps
+		= (False, subst, heaps)
+
 tryToExpand :: !Type !TypeAttribute !{# CommonDefs} !*TypeHeaps -> (!Bool, !Type, !*TypeHeaps)
 tryToExpand type=:(TA {type_index={glob_object,glob_module}} type_args) type_attr ti_common_defs type_heaps
 	#! type_def = ti_common_defs.[glob_module].com_type_defs.[glob_object]
@@ -353,6 +372,14 @@ tryToExpand type=:(TA {type_index={glob_object,glob_module}} type_args) type_att
 			-> (True, expanded_type, type_heaps)
 		_
 			-> (False, type, type_heaps)
+tryToExpand type=:(TAS {type_index={glob_object,glob_module}} type_args _) type_attr ti_common_defs type_heaps
+	#! type_def = ti_common_defs.[glob_module].com_type_defs.[glob_object]
+	= case type_def.td_rhs of
+		SynType {at_type}
+			# (_, expanded_type, type_heaps) = substituteType type_def.td_attribute type_attr type_def.td_args type_args at_type type_heaps
+			-> (True, expanded_type, type_heaps)
+		_
+			-> (False, type, type_heaps)
 tryToExpand type type_attr modules type_heaps
 	= (False, type, type_heaps)
 
@@ -369,6 +396,8 @@ toCV is_exist temp_var_id
 simplifyTypeApplication :: !Type ![AType] -> (!Bool, !Type)
 simplifyTypeApplication (TA type_cons=:{type_arity} cons_args) type_args
 	= (True, TA { type_cons & type_arity = type_arity + length type_args } (cons_args ++ type_args))
+simplifyTypeApplication (TAS type_cons=:{type_arity} cons_args strictness) type_args
+	= (True, TAS { type_cons & type_arity = type_arity + length type_args } (cons_args ++ type_args) strictness)
 simplifyTypeApplication (cons_var :@: types) type_args
 	= (True, cons_var :@: (types ++ type_args))
 simplifyTypeApplication (TempV tv_number) type_args
@@ -419,6 +448,15 @@ unifyCVwithType is_exist tv_number type_args type=:(TA type_cons cons_args) modu
 		    = (False, subst, heaps)
 		= (False, subst, heaps)
 
+unifyCVwithType is_exist tv_number type_args type=:(TAS type_cons cons_args strictness) modules subst heaps
+	# diff = type_cons.type_arity - length type_args
+	| diff >= 0 
+		# (succ, subst, heaps) = unify type_args (drop diff cons_args) modules subst heaps
+		| succ
+			= unifyTypes (toTV is_exist tv_number) TA_Multi (TAS { type_cons & type_arity = diff } (take diff cons_args) strictness) TA_Multi modules subst heaps
+		    = (False, subst, heaps)
+		= (False, subst, heaps)
+
 // AA..
 unifyCVwithType is_exist tv_number [type_arg1, type_arg2] type=:(atype1 --> atype2) modules subst heaps
 	# (succ, subst, heaps) = unify (type_arg1, type_arg2) (atype1, atype2) modules subst heaps
@@ -558,6 +596,9 @@ where
 	freshCopy (TA cons_id=:{type_index={glob_object,glob_module}} cons_args)  type_heaps
 		# (cons_args, type_heaps) = freshCopy cons_args type_heaps
 		= (TA cons_id cons_args, type_heaps)
+	freshCopy (TAS cons_id=:{type_index={glob_object,glob_module}} cons_args strictness)  type_heaps
+		# (cons_args, type_heaps) = freshCopy cons_args type_heaps
+		= (TAS cons_id cons_args strictness, type_heaps)
 	freshCopy (arg_type --> res_type) type_heaps
 		# (arg_type, type_heaps) = freshCopy arg_type type_heaps
 		  (res_type, type_heaps) = freshCopy res_type type_heaps
@@ -891,12 +932,12 @@ where
 
 freshAttributedVariable :: !u:TypeState -> (!AType, !u:TypeState)
 freshAttributedVariable ts=:{ts_var_store,ts_attr_store}
-	= ({ at_attribute = TA_TempVar ts_attr_store, at_annotation = AN_None, at_type = TempV ts_var_store },
+	= ({ at_attribute = TA_TempVar ts_attr_store, at_type = TempV ts_var_store },
 	     {ts & ts_var_store = inc ts_var_store, ts_attr_store = inc ts_attr_store})
 
 freshNonUniqueVariable :: !u:TypeState -> (!AType, !u:TypeState)
 freshNonUniqueVariable ts=:{ts_var_store}
-	= ({ at_attribute = TA_Multi, at_annotation = AN_None, at_type = TempV ts_var_store },
+	= ({ at_attribute = TA_Multi, at_type = TempV ts_var_store },
 	     {ts & ts_var_store = inc ts_var_store})
 
 freshAttribute :: !u:TypeState -> (!TypeAttribute, !u:TypeState)
@@ -918,6 +959,63 @@ attribute_error type_attr (Yes err)
 	# err = errorHeading "Type error" err
 	= Yes { err & ea_file = err.ea_file <<< "* attribute expected instead of " <<< type_attr <<< '\n' }
 
+add_propagation_attributes_to_atypes modules [] ps
+	= ([], [], ps) 
+add_propagation_attributes_to_atypes modules [atype : atypes] ps
+	# (atype, prop_class, ps) = addPropagationAttributesToAType modules atype ps
+	  (atypes, prop_classes, ps) = add_propagation_attributes_to_atypes modules atypes ps
+	= ([atype : atypes], [prop_class : prop_classes], ps)
+
+determine_attribute_of_cons modules TA_Unique cons_args prop_class attr_var_heap attr_vars attr_env ps_error
+	= (TA_Unique, prop_class >> length cons_args, attr_var_heap, attr_vars, attr_env, ps_error)
+determine_attribute_of_cons modules cons_attr cons_args prop_class attr_var_heap attr_vars attr_env ps_error
+	# (cumm_attr, prop_attrs, prop_class) = determine_cummulative_attribute cons_args TA_Multi [] prop_class
+	  (comb_attr, attr_var_heap, attr_vars, attr_env, ps_error)
+	  		= combine_attributes cons_attr cumm_attr prop_attrs attr_var_heap attr_vars attr_env ps_error
+	= (comb_attr, prop_class, attr_var_heap, attr_vars, attr_env, ps_error)
+where
+	determine_cummulative_attribute [] cumm_attr attr_vars prop_class
+		= (cumm_attr, attr_vars, prop_class)
+	determine_cummulative_attribute [{at_attribute} : types ] cumm_attr attr_vars prop_class
+		| prop_class bitand 1 == 0
+			= determine_cummulative_attribute types cumm_attr attr_vars (prop_class >> 1)
+			= case at_attribute of
+				TA_Unique
+					-> (TA_Unique, [], prop_class >> length types)
+				TA_Multi
+					-> determine_cummulative_attribute types cumm_attr attr_vars (prop_class >> 1)
+				TA_Var attr_var
+					-> determine_cummulative_attribute types at_attribute [attr_var : attr_vars] (prop_class >> 1)
+				TA_MultiOfPropagatingConsVar
+					-> determine_cummulative_attribute types cumm_attr attr_vars (prop_class >> 1)
+
+	combine_attributes (TA_Var attr_var) cumm_attr prop_vars attr_var_heap attr_vars attr_env ps_error
+		= case cumm_attr of
+			TA_Unique
+				-> (TA_Unique, attr_var_heap, attr_vars, attr_env, attribute_error attr_var ps_error)
+			
+			TA_Multi
+				-> (TA_Var attr_var, attr_var_heap, attr_vars, attr_env, ps_error)
+			TA_Var _
+				-> (TA_Var attr_var, attr_var_heap, attr_vars, foldSt (new_inequality attr_var) prop_vars attr_env, ps_error)
+	where
+		new_inequality off_attr_var dem_attr_var [] 
+			= [{ ai_demanded = dem_attr_var, ai_offered = off_attr_var }]
+		new_inequality off_attr_var dem_attr_var ins=:[ inequal : iequals ]
+			 | dem_attr_var.av_info_ptr == inequal.ai_demanded.av_info_ptr && off_attr_var.av_info_ptr == inequal.ai_offered.av_info_ptr
+			 	= ins
+			 	= [ inequal : new_inequality off_attr_var dem_attr_var iequals ]
+
+	combine_attributes _ (TA_Var var) prop_vars attr_var_heap attr_vars attr_env ps_error
+		# (new_attr_ptr, attr_var_heap) = newPtr AVI_Empty attr_var_heap
+		  new_attr_var = { var & av_info_ptr = new_attr_ptr }
+		= (TA_Var new_attr_var, attr_var_heap, [new_attr_var : attr_vars],
+				mapAppend (\ai_demanded -> { ai_demanded = ai_demanded, ai_offered = new_attr_var }) prop_vars attr_env, ps_error)
+	combine_attributes cons_attr TA_Unique _ attr_var_heap attr_vars attr_env ps_error
+		= (TA_Unique, attr_var_heap, attr_vars, attr_env, ps_error)
+	combine_attributes cons_attr _ _ attr_var_heap attr_vars attr_env ps_error
+		= (cons_attr, attr_var_heap, attr_vars, attr_env, ps_error)
+
 addPropagationAttributesToAType :: {#CommonDefs} !AType !*PropState -> *(!AType,Int,!*PropState);
 addPropagationAttributesToAType modules type=:{at_type = TA cons_id=:{type_index={glob_object,glob_module},type_name} cons_args, at_attribute} ps
 	# (cons_args, props, ps=:{prop_td_infos,prop_type_heaps,prop_attr_vars,prop_attr_env,prop_error})
@@ -928,64 +1026,15 @@ addPropagationAttributesToAType modules type=:{at_type = TA cons_id=:{type_index
 	= ({ type & at_type = TA cons_id cons_args, at_attribute = at_attribute }, prop_class,  { ps & prop_attr_vars = prop_attr_vars,
 			prop_td_infos = prop_td_infos, prop_attr_env = prop_attr_env,
 				prop_type_heaps = { prop_type_heaps & th_vars = th_vars, th_attrs = th_attrs}, prop_error = prop_error })
-	where
-		add_propagation_attributes_to_atypes modules [] ps
-			= ([], [], ps) 
-		add_propagation_attributes_to_atypes modules [atype : atypes] ps
-			# (atype, prop_class, ps) = addPropagationAttributesToAType modules atype ps
-			  (atypes, prop_classes, ps) = add_propagation_attributes_to_atypes modules atypes ps
-			= ([atype : atypes], [prop_class : prop_classes], ps)
-	
-		determine_attribute_of_cons modules TA_Unique cons_args prop_class attr_var_heap attr_vars attr_env ps_error
-			= (TA_Unique, prop_class >> length cons_args, attr_var_heap, attr_vars, attr_env, ps_error)
-		determine_attribute_of_cons modules cons_attr cons_args prop_class attr_var_heap attr_vars attr_env ps_error
-			# (cumm_attr, prop_attrs, prop_class) = determine_cummulative_attribute cons_args TA_Multi [] prop_class
-			  (comb_attr, attr_var_heap, attr_vars, attr_env, ps_error)
-			  		= combine_attributes cons_attr cumm_attr prop_attrs attr_var_heap attr_vars attr_env ps_error
-			= (comb_attr, prop_class, attr_var_heap, attr_vars, attr_env, ps_error)
-			  
-		determine_cummulative_attribute [] cumm_attr attr_vars prop_class
-			= (cumm_attr, attr_vars, prop_class)
-		determine_cummulative_attribute [{at_attribute} : types ] cumm_attr attr_vars prop_class
-			| prop_class bitand 1 == 0
-				= determine_cummulative_attribute types cumm_attr attr_vars (prop_class >> 1)
-				= case at_attribute of
-					TA_Unique
-						-> (TA_Unique, [], prop_class >> length types)
-					TA_Multi
-						-> determine_cummulative_attribute types cumm_attr attr_vars (prop_class >> 1)
-					TA_Var attr_var
-						-> determine_cummulative_attribute types at_attribute [attr_var : attr_vars] (prop_class >> 1)
-					TA_MultiOfPropagatingConsVar
-						-> determine_cummulative_attribute types cumm_attr attr_vars (prop_class >> 1)
-
-		combine_attributes (TA_Var attr_var) cumm_attr prop_vars attr_var_heap attr_vars attr_env ps_error
-			= case cumm_attr of
-				TA_Unique
-					-> (TA_Unique, attr_var_heap, attr_vars, attr_env, attribute_error attr_var ps_error)
-				
-				TA_Multi
-					-> (TA_Var attr_var, attr_var_heap, attr_vars, attr_env, ps_error)
-				TA_Var _
-					-> (TA_Var attr_var, attr_var_heap, attr_vars, foldSt (new_inequality attr_var) prop_vars attr_env, ps_error)
-		where
-			new_inequality off_attr_var dem_attr_var [] 
-				= [{ ai_demanded = dem_attr_var, ai_offered = off_attr_var }]
-			new_inequality off_attr_var dem_attr_var ins=:[ inequal : iequals ]
-				 | dem_attr_var.av_info_ptr == inequal.ai_demanded.av_info_ptr && off_attr_var.av_info_ptr == inequal.ai_offered.av_info_ptr
-				 	= ins
-				 	= [ inequal : new_inequality off_attr_var dem_attr_var iequals ]
-	
-		combine_attributes _ (TA_Var var) prop_vars attr_var_heap attr_vars attr_env ps_error
-			# (new_attr_ptr, attr_var_heap) = newPtr AVI_Empty attr_var_heap
-			  new_attr_var = { var & av_info_ptr = new_attr_ptr }
-			= (TA_Var new_attr_var, attr_var_heap, [new_attr_var : attr_vars],
-					mapAppend (\ai_demanded -> { ai_demanded = ai_demanded, ai_offered = new_attr_var }) prop_vars attr_env, ps_error)
-		combine_attributes cons_attr TA_Unique _ attr_var_heap attr_vars attr_env ps_error
-			= (TA_Unique, attr_var_heap, attr_vars, attr_env, ps_error)
-		combine_attributes cons_attr _ _ attr_var_heap attr_vars attr_env ps_error
-			= (cons_attr, attr_var_heap, attr_vars, attr_env, ps_error)
-
+addPropagationAttributesToAType modules type=:{at_type = TAS cons_id=:{type_index={glob_object,glob_module},type_name} cons_args strictness, at_attribute} ps
+	# (cons_args, props, ps=:{prop_td_infos,prop_type_heaps,prop_attr_vars,prop_attr_env,prop_error})
+			= add_propagation_attributes_to_atypes modules cons_args ps
+	  (prop_class, th_vars, prop_td_infos) = propClassification glob_object glob_module props modules prop_type_heaps.th_vars prop_td_infos
+	  (at_attribute, prop_class, th_attrs, prop_attr_vars, prop_attr_env, prop_error)
+	  		= determine_attribute_of_cons modules at_attribute cons_args prop_class prop_type_heaps.th_attrs prop_attr_vars prop_attr_env prop_error
+	= ({ type & at_type = TAS cons_id cons_args strictness, at_attribute = at_attribute }, prop_class,  { ps & prop_attr_vars = prop_attr_vars,
+			prop_td_infos = prop_td_infos, prop_attr_env = prop_attr_env,
+				prop_type_heaps = { prop_type_heaps & th_vars = th_vars, th_attrs = th_attrs}, prop_error = prop_error })
 addPropagationAttributesToAType modules type=:{at_type} ps
 	# (at_type, ps) = addPropagationAttributesToType modules at_type ps
 	= ({ type & at_type = at_type }, NoPropClass, ps)
@@ -1049,7 +1098,7 @@ buildCurriedType [] type cum_attr attr_env attr_store
 buildCurriedType [at=:{at_attribute}:ats] type cum_attr attr_env attr_store
 	# (next_cum_attr, attr_env, attr_store) = combine_attributes at_attribute cum_attr attr_env attr_store
 	  (res_type, attr_env, attr_store) = buildCurriedType ats type next_cum_attr attr_env attr_store
-	= ({at_annotation = AN_None, at_attribute = cum_attr , at_type = at --> res_type }, attr_env, attr_store)
+	= ({at_attribute = cum_attr , at_type = at --> res_type }, attr_env, attr_store)
 where
 	combine_attributes TA_Unique cum_attr attr_env attr_store
 		= (TA_Unique, attr_env, attr_store)
@@ -1286,7 +1335,7 @@ where
 										{ ts & ts_expr_heap = ts_expr_heap }))
 
 		requirements_of_guarded_expressions (DynamicPatterns dynamic_patterns) ti match_expr pattern_type opt_pattern_ptr goal_type reqs_ts
-			# dyn_type = { at_type = TB BT_Dynamic, at_attribute = TA_Multi, at_annotation = AN_None }
+			# dyn_type = { at_type = TB BT_Dynamic, at_attribute = TA_Multi }
 			  (used_dyn_types, (reqs, ts)) = requirements_of_dynamic_patterns ti goal_type dynamic_patterns [] reqs_ts
 			  ts_expr_heap = storeAttribute opt_pattern_ptr TA_Multi ts.ts_expr_heap
 			= (reverse used_dyn_types, ({ reqs & req_type_coercions = [{tc_demanded = dyn_type, tc_offered = pattern_type, tc_position = CP_Expression match_expr, tc_coercible = True} :
@@ -1455,10 +1504,10 @@ where
 		  ts_expr_heap = storeAttribute opt_expr_ptr dyn_expr_type.at_attribute ts.ts_expr_heap
 		  type_coercion = { tc_demanded = dyn_type, tc_offered = dyn_expr_type, tc_position = CP_Expression dyn_expr, tc_coercible = True }
 		| isEmpty dyn_context
-			= ({ at_type = TB BT_Dynamic, at_attribute = TA_Multi, at_annotation = AN_None }, No, 
+			= ({ at_type = TB BT_Dynamic, at_attribute = TA_Multi }, No, 
 					({reqs & req_type_coercions = [ type_coercion : reqs.req_type_coercions]}, 
 						{ ts &  ts_expr_heap = ts_expr_heap }))
-			= ({ at_type = TB BT_Dynamic, at_attribute = TA_Multi, at_annotation = AN_None }, No,
+			= ({ at_type = TB BT_Dynamic, at_attribute = TA_Multi }, No,
 					({ reqs & req_type_coercions = [ type_coercion : reqs.req_type_coercions], req_overloaded_calls = [dyn_expr_ptr : reqs.req_overloaded_calls ]},
 						{ ts & ts_expr_heap = ts_expr_heap <:= (dyn_expr_ptr, EI_Overloaded {
 								oc_symbol = type_code_symbol, oc_context = dyn_context, oc_specials = []}) }))
@@ -1489,7 +1538,7 @@ where
 		apply_type [(opt_expr_ptr,type) : types] res_type type_coercions function ts
 			# (type, type_coercions, ts) = determine_demanded_type type opt_expr_ptr type_coercions function ts
 			  (u, ts) = freshAttribute ts
-			= apply_type types { at_annotation = AN_None, at_attribute = u, at_type = type --> res_type } type_coercions function ts
+			= apply_type types { at_attribute = u, at_type = type --> res_type } type_coercions function ts
 		
 		determine_demanded_type :: !AType !(Optional ExprInfoPtr) ![TypeCoercion] !Expression !*TypeState
 			-> (!AType, ![TypeCoercion], !*TypeState)
@@ -1516,12 +1565,12 @@ where
 			UniqueSelector
 				# (var, ts) = freshAttributedVariable ts
 			  	  (_, result_type, (reqs, ts)) =  requirementsOfSelectors ti No expr selectors False False var expr (reqs, ts)
-				  non_unique_type_var = { at_attribute = TA_Multi, at_annotation = AN_None, at_type = TempV ts.ts_var_store }
+				  non_unique_type_var = { at_attribute = TA_Multi, at_type = TempV ts.ts_var_store }
 				  req_type_coercions
 						= [ { tc_demanded = non_unique_type_var, tc_offered = result_type, tc_position = CP_Expression expr, tc_coercible = False },
 							{ tc_demanded = var, tc_offered = expr_type, tc_position = CP_Expression expr, tc_coercible = True } :
 	 								reqs.req_type_coercions]
-				  result_type = { at_type = TA tuple2TypeSymbIdent [non_unique_type_var,var], at_attribute = TA_Unique, at_annotation = AN_None }
+				  result_type = { at_type = TA tuple2TypeSymbIdent [non_unique_type_var,var], at_attribute = TA_Unique }
 				-> (result_type, No, ({ reqs & req_type_coercions = req_type_coercions }, 
 						{ts & ts_var_store = inc ts.ts_var_store, ts_expr_heap = storeAttribute opt_expr_ptr TA_Multi ts.ts_expr_heap}))
 			NormalSelectorUniqueElementResult
@@ -1588,7 +1637,7 @@ where
 		typeOfBasicValue (BVS _) = basicStringType
 
 		attributedBasicType {box=type} ts=:{ts_attr_store}
-			= ({ at_annotation = AN_None, at_attribute = TA_TempVar ts_attr_store, at_type = type}, {ts & ts_attr_store = inc ts_attr_store})
+			= ({ at_attribute = TA_TempVar ts_attr_store, at_type = type}, {ts & ts_attr_store = inc ts_attr_store})
 
 	requirements ti (MatchExpr {glob_object={ds_arity, ds_index},glob_module} expr) reqs_ts=:(reqs, ts)
 		| glob_module==cPredefinedModuleIndex
@@ -1605,7 +1654,7 @@ where
 			  ts = { ts & ts_expr_heap = storeAttribute opt_expr_ptr tst_result.at_attribute ts.ts_expr_heap }
 			| ds_arity<>1
 				# tuple_type = MakeTypeSymbIdent { glob_object = PD_Arity2TupleTypeIndex+(ds_arity-2), glob_module = cPredefinedModuleIndex } predefined_idents.[PD_Arity2TupleType+(ds_arity-2)] ds_arity
-				= ({ at_type = TA tuple_type tst_args, at_attribute = TA_Unique, at_annotation = AN_None }, No, (reqs, ts))
+				= ({ at_type = TA tuple_type tst_args, at_attribute = TA_Unique }, No, (reqs, ts))
 				= ( hd tst_args, No, (reqs, ts))
 
 	requirements _ (AnyCodeExpr _ _ _) (reqs, ts)
@@ -1691,6 +1740,12 @@ where
 		# args = [{arg_array & at_type = aa :@: [{ae & at_attribute = attribute}]}, arg_int]
 		# result = {result & at_type = TA tuple_symb [{result_element & at_attribute = attribute}, {result_array & at_type=ra :@: [{re & at_attribute = attribute}]}]}
 		= (args, result, ts)
+	change_uselect_attributes args=:[arg_array=:{at_type=aa :@: [ae]}, arg_int]
+					result=:{at_type=TAS tuple_symb [result_element, result_array=:{at_type=ra :@: [re]}] strictness} ts
+		# (attribute, ts) =	freshAttribute ts
+		# args = [{arg_array & at_type = aa :@: [{ae & at_attribute = attribute}]}, arg_int]
+		# result = {result & at_type = TAS tuple_symb [{result_element & at_attribute = attribute}, {result_array & at_type=ra :@: [{re & at_attribute = attribute}]}] strictness}
+		= (args, result, ts)
 	change_uselect_attributes _ _ ts
 		= abort "type.icl, change_uselect_attributes: wrong type for uselect"
 
@@ -1727,9 +1782,9 @@ addToBase info_ptr type optional_position ts_var_heap
 	= ts_var_heap  <:= (info_ptr, VI_Type type optional_position)
 	
 attributedBasicType (BT_String string_type) ts=:{ts_attr_store}
-	= ({ at_annotation = AN_None, at_attribute = TA_TempVar ts_attr_store, at_type = string_type}, {ts & ts_attr_store = inc ts_attr_store})
+	= ({ at_attribute = TA_TempVar ts_attr_store, at_type = string_type}, {ts & ts_attr_store = inc ts_attr_store})
 attributedBasicType bas_type ts=:{ts_attr_store}
-	= ({ at_annotation = AN_None, at_attribute = TA_TempVar ts_attr_store, at_type = TB bas_type}, {ts & ts_attr_store = inc ts_attr_store})
+	= ({ at_attribute = TA_TempVar ts_attr_store, at_type = TB bas_type}, {ts & ts_attr_store = inc ts_attr_store})
 
 unify_coercions [{tc_demanded,tc_offered,tc_position}:coercions] modules subst heaps err
 	# (succ, subst, heaps) = unify tc_demanded tc_offered modules subst heaps
@@ -1789,7 +1844,7 @@ where
 	create_general_symboltype :: !Bool !Bool !Int !Int !*TypeState -> (!TempSymbolType, !*TypeState)
 	create_general_symboltype is_start_rule is_caf nr_of_args nr_of_lifted_args ts
 		| is_start_rule && nr_of_args > 0
-			# (tst_args, ts) = fresh_attributed_type_variables (nr_of_args - 1) [{at_attribute = TA_Unique, at_annotation = AN_Strict, at_type = TB BT_World }] ts
+			# (tst_args, ts) = fresh_attributed_type_variables (nr_of_args - 1) [{at_attribute = TA_Unique, /*at_annotation = AN_Strict,*/ at_type = TB BT_World }] ts
 			  (tst_result, ts) = (if is_caf freshNonUniqueVariable freshAttributedVariable) ts
 			= ({ tst_args = tst_args, tst_arity = 1, tst_result = tst_result, tst_context = [], tst_attr_env = [], tst_lifted = 0 }, ts)
 			# (tst_args, ts) = fresh_attributed_type_variables nr_of_args [] ts
@@ -1827,7 +1882,7 @@ where
 						expr_heap <:= (dyn_ptr, EI_TempDynamicType opt_dyn_type loc_dynamics tdt_type contexts expr_ptr type_code_symbol), predef_symbols)
 			EI_Dynamic No loc_dynamics 
 				# fresh_var = TempV var_store
-				  tdt_type = { at_attribute = TA_Multi, at_annotation = AN_None, at_type = fresh_var }
+				  tdt_type = { at_attribute = TA_Multi, at_type = fresh_var }
 
 				# ({pds_module,pds_def},predef_symbols) = predef_symbols![PD_TypeCodeClass]
 				# pds_ident = predefined_idents.[PD_TypeCodeClass]
@@ -1998,10 +2053,10 @@ where
 				= take arity_diff args2 ++ args1
 				= args1
 
-addLiftedArgumentsToSymbolType st=:{st_arity,st_args,st_vars,st_attr_vars,st_context} nr_of_lifted_arguments new_args new_vars new_attrs new_context
-	= { st & st_args = take nr_of_lifted_arguments new_args ++ st_args, st_vars = st_vars ++ drop (length st_vars) new_vars,
-			st_attr_vars = (take (length new_attrs - length st_attr_vars) new_attrs) ++ st_attr_vars, st_arity = st_arity + nr_of_lifted_arguments,
-				st_context = take (length new_context - length st_context) new_context ++ st_context }
+addLiftedArgumentsToSymbolType st=:{st_arity,st_args,st_args_strictness,st_vars,st_attr_vars,st_context} nr_of_lifted_arguments new_args new_vars new_attrs new_context
+	= { st & st_args = take nr_of_lifted_arguments new_args ++ st_args, st_args_strictness = insert_n_lazy_values_at_beginning nr_of_lifted_arguments st_args_strictness,
+			 st_vars = st_vars ++ drop (length st_vars) new_vars, st_attr_vars = (take (length new_attrs - length st_attr_vars) new_attrs) ++ st_attr_vars,
+			 st_arity = st_arity + nr_of_lifted_arguments,st_context = take (length new_context - length st_context) new_context ++ st_context }
 
 ::	FunctionRequirements =
 	{	fe_requirements	:: !Requirements
@@ -2123,21 +2178,9 @@ where
 			= state
 
 		check_type_of_constructor_variable ins_pos common_defs type=:(TA {type_index={glob_module,glob_object},type_arity} types) (error, type_var_heap, td_infos)
-			# {td_arity,td_name} = common_defs.[glob_module].com_type_defs.[glob_object]
-			  ({tdi_properties,tdi_cons_vars}, td_infos) = td_infos![glob_module].[glob_object]
-			| tdi_properties bitand cIsNonCoercible == 0
-				# ({sc_neg_vect}, type_var_heap, td_infos)
-					= signClassification glob_object glob_module [TopSignClass \\ cv <- tdi_cons_vars ] common_defs type_var_heap td_infos
-				= (check_sign type (sc_neg_vect >> type_arity) (td_arity - type_arity) error, type_var_heap, td_infos)							
-				= (checkErrorWithIdentPos (newPosition empty_id ins_pos)
-					 " instance type should be coercible" error, type_var_heap, td_infos)
-		where
-			check_sign type neg_signs arg_nr error
-				| arg_nr == 0
-					= error
-					| neg_signs bitand 1 == 0
-						= check_sign type (neg_signs >> 1) (dec arg_nr) error
-						= checkError type " all arguments of an instance type should have a non-negative sign" error
+			= check_type_of_constructor_variable_for_TA glob_module glob_object type_arity types ins_pos common_defs type error type_var_heap td_infos
+		check_type_of_constructor_variable ins_pos common_defs type=:(TAS {type_index={glob_module,glob_object},type_arity} types _) (error, type_var_heap, td_infos)
+			= check_type_of_constructor_variable_for_TA glob_module glob_object type_arity types ins_pos common_defs type error type_var_heap td_infos
 		check_type_of_constructor_variable ins_pos common_defs type=:(arg_type --> result_type) (error, type_var_heap, td_infos)
 			= (checkErrorWithIdentPos (newPosition empty_id ins_pos) " instance type should be coercible" error,
 				type_var_heap, td_infos)
@@ -2157,6 +2200,23 @@ where
 				type_var_heap, td_infos)
 		check_type_of_constructor_variable ins_pos common_defs type state
 			= state
+
+		check_type_of_constructor_variable_for_TA glob_module glob_object type_arity types ins_pos common_defs type error type_var_heap td_infos
+			# {td_arity,td_name} = common_defs.[glob_module].com_type_defs.[glob_object]
+			  ({tdi_properties,tdi_cons_vars}, td_infos) = td_infos![glob_module].[glob_object]
+			| tdi_properties bitand cIsNonCoercible == 0
+				# ({sc_neg_vect}, type_var_heap, td_infos)
+					= signClassification glob_object glob_module [TopSignClass \\ cv <- tdi_cons_vars ] common_defs type_var_heap td_infos
+				= (check_sign type (sc_neg_vect >> type_arity) (td_arity - type_arity) error, type_var_heap, td_infos)							
+				= (checkErrorWithIdentPos (newPosition empty_id ins_pos)
+					 " instance type should be coercible" error, type_var_heap, td_infos)
+		where
+			check_sign type neg_signs arg_nr error
+				| arg_nr == 0
+					= error
+					| neg_signs bitand 1 == 0
+						= check_sign type (neg_signs >> 1) (dec arg_nr) error
+						= checkError type " all arguments of an instance type should have a non-negative sign" error
 			
 	insert ::  ![Type] !Index !Index !{# CommonDefs } !*ErrorAdmin !*InstanceTree -> (!*ErrorAdmin, !*InstanceTree)
 	insert ins_types new_ins_index new_ins_module modules error IT_Empty
@@ -2291,6 +2351,15 @@ where
 					-> snd (tryToMakeUnique av_number coercions)
 				_
 					-> coercions
+		add_unicity_of_essentially_unique_type common_defs 
+								{at_attribute=TA_TempVar av_number, at_type=TAS {type_index} _ _} coercions
+			# {td_attribute} = common_defs.[type_index.glob_module].com_type_defs.[type_index.glob_object]
+			= case td_attribute of
+				TA_Unique
+					// the type is essentially unique
+					-> snd (tryToMakeUnique av_number coercions)
+				_
+					-> coercions
 		add_unicity_of_essentially_unique_type _ _ coercions
 			= coercions
 
diff --git a/frontend/type_io.icl b/frontend/type_io.icl
index 582250e..ece6b41 100644
--- a/frontend/type_io.icl
+++ b/frontend/type_io.icl
@@ -170,20 +170,11 @@ sel_type_var_heap wtis=:{wtis_type_heaps}
  
 instance WriteTypeInfo ATypeVar
 where 
-	write_type_info {atv_annotation,atv_variable} tcl_file wtis
- 		# (tcl_file,wtis) 
- 			= write_type_info atv_annotation tcl_file wtis
+	write_type_info {atv_variable} tcl_file wtis
  		# (tcl_file,wtis)
  			= write_type_info atv_variable tcl_file wtis
  		= (tcl_file,wtis)
- 		
-instance WriteTypeInfo Annotation
-where 
-	write_type_info AN_Strict tcl_file wtis	
-		= (fwritec '!' tcl_file,wtis)
-	write_type_info AN_None tcl_file wtis
-		= (fwritec ' ' tcl_file,wtis)
-		
+
 instance WriteTypeInfo TypeVar
 where
 	write_type_info {tv_info_ptr} tcl_file wtis
@@ -266,22 +257,33 @@ where
 // NEW ->
 instance WriteTypeInfo SymbolType
 where
-	write_type_info {st_vars,st_args,st_arity,st_result} tcl_file wtis
+	write_type_info {st_vars,st_args,st_args_strictness,st_arity,st_result} tcl_file wtis
 		# (tcl_file,wtis)
 			= write_type_info st_vars tcl_file wtis
 		# (tcl_file,wtis)
-			= write_type_info st_args tcl_file wtis
+			= write_annotated_type_info st_args st_args_strictness tcl_file wtis
 		# (tcl_file,wtis)
 			= write_type_info st_arity tcl_file wtis
 		# (tcl_file,wtis)
 			= write_type_info st_result tcl_file wtis
 		= (tcl_file,wtis)
+
+write_annotated_type_info l strictness tcl_file wtis
+	# tcl_file
+		= fwritei (length l) tcl_file
+	= write_annotated_type_info_loop l 0 tcl_file wtis
+	where
+		write_annotated_type_info_loop [] arg_index tcl_file wtis
+			= (tcl_file,wtis)
+		write_annotated_type_info_loop [x:xs] arg_index tcl_file wtis
+			# tcl_file = fwritec (if (arg_is_strict arg_index strictness) '!' ' ') tcl_file
+			# (tcl_file,wtis)
+				= write_type_info x tcl_file wtis
+			= write_annotated_type_info_loop xs (arg_index+1) tcl_file wtis
 		
 instance WriteTypeInfo AType
 where
-	write_type_info {at_annotation,at_type} tcl_file wtis
-		# (tcl_file,wtis)
-			= write_type_info at_annotation tcl_file wtis
+	write_type_info {at_type} tcl_file wtis
 		# (tcl_file,wtis)
 			= write_type_info at_type tcl_file wtis
 		= (tcl_file,wtis)
@@ -297,6 +299,15 @@ where
 			= write_type_info atypes tcl_file wtis
 		= (tcl_file,wtis)
 
+	write_type_info (TAS type_symb_ident atypes strictness) tcl_file wtis
+		# tcl_file
+			= fwritec TypeTACode tcl_file
+		# (tcl_file,wtis)
+			= write_type_info type_symb_ident tcl_file wtis
+		# (tcl_file,wtis)
+			= write_annotated_type_info atypes strictness tcl_file wtis
+		= (tcl_file,wtis)
+
 	write_type_info (atype1 --> atype2) tcl_file wtis
 		# tcl_file
 			= fwritec TypeArrowCode tcl_file
@@ -471,7 +482,7 @@ openTclFile compile_for_dynamics icl_mod_pathname files
 	| opened
 		=(Yes tcl_file, files)
 	= abort ("couldn't open file \"" +++ tcl_path +++ "\"\n")
-	
+
 closeTclFile :: !*(Optional *File) *Files -> *(!Bool,*Files)
 closeTclFile (Yes tcl_file) files
 	= fclose tcl_file files
@@ -502,5 +513,4 @@ splitBy char string
 			=	size string
 
 // ... copy from compile.icl
-
 // ... MV
diff --git a/frontend/typesupport.dcl b/frontend/typesupport.dcl
index 9c98af7..7868d04 100644
--- a/frontend/typesupport.dcl
+++ b/frontend/typesupport.dcl
@@ -150,6 +150,10 @@ foldATypeSt on_atype on_type type st :== fold_atype_st type st
 		#! st
 				= foldSt fold_atype_st args st
 		= on_type type st
+	fold_type_st type=:(TAS type_symb_ident args _) st
+		#! st
+				= foldSt fold_atype_st args st
+		= on_type type st
 	fold_type_st type=:(l --> r) st
 		#! st
 				= fold_atype_st r (fold_atype_st l st)
diff --git a/frontend/typesupport.icl b/frontend/typesupport.icl
index c7b795a..8bdd493 100644
--- a/frontend/typesupport.icl
+++ b/frontend/typesupport.icl
@@ -26,6 +26,8 @@ import syntax, parse, check, unitype, utilities, checktypes, compilerSwitches
 simplifyTypeApplication :: !Type ![AType] -> (!Bool, !Type)
 simplifyTypeApplication (TA type_cons=:{type_arity} cons_args) type_args
 	= (True, TA { type_cons & type_arity = type_arity + length type_args } (cons_args ++ type_args))
+simplifyTypeApplication (TAS type_cons=:{type_arity} cons_args strictness) type_args
+	= (True, TAS { type_cons & type_arity = type_arity + length type_args } (cons_args ++ type_args) strictness)
 simplifyTypeApplication (CV tv :@: type_args1) type_args2
 	= (True, CV tv :@: (type_args1 ++ type_args2))
 simplifyTypeApplication TArrow [type1, type2] 
@@ -73,7 +75,7 @@ where
 			# (at_attribute, cus)	= cleanUpTypeAttribute True cui at_attribute cus
 			# (type, cus)			= cus!cus_var_env.[qv_number]
 			  (var, cus)			= cleanUpVariable True type qv_number cus
-			= ({atype & at_attribute = at_attribute, at_type = var, at_annotation = AN_None},
+			= ({atype & at_attribute = at_attribute, at_type = var},
 					{cus & cus_exis_vars = add_new_variable type qv_number at_attribute cus.cus_exis_vars})
 	where			
 		add_new_variable TE ev_number ev_attr cus_exis_vars
@@ -83,7 +85,7 @@ where
 	clean_up cui atype=:{at_attribute,at_type} cus
 		# (at_attribute, cus) = cleanUpTypeAttribute False cui at_attribute cus 
 		  (at_type, cus) = clean_up cui at_type cus
-		= ({atype & at_attribute = at_attribute, at_type = at_type, at_annotation = AN_None}, cus)
+		= ({atype & at_attribute = at_attribute, at_type = at_type}, cus)
 
 
 attrIsUndefined TA_None = True
@@ -141,6 +143,9 @@ where
 	clean_up cui (TA tc types) cus
 		# (types, cus) = clean_up cui types cus
 		= (TA tc types, cus)
+	clean_up cui (TAS tc types strictness) cus
+		# (types, cus) = clean_up cui types cus
+		= (TAS tc types strictness, cus)
 	clean_up cui (argtype --> restype) cus
 		# (argtype, cus) = clean_up cui argtype cus
 		  (restype, cus) = clean_up cui restype cus
@@ -237,6 +242,9 @@ where
 	cleanUpClosed (TA tc types) env
 		# (cur, types, env) = cleanUpClosed types env
 		= (cur, TA tc types, env)
+	cleanUpClosed (TAS tc types strictness) env
+		# (cur, types, env) = cleanUpClosed types env
+		= (cur, TAS tc types strictness, env)
 	cleanUpClosed (argtype --> restype) env
 		# (cur, (argtype,restype), env) = cleanUpClosed (argtype,restype) env
 		= (cur, argtype --> restype, env)
@@ -308,7 +316,7 @@ cleanSymbolType :: !Int !*TypeHeaps -> (!SymbolType, !*TypeHeaps)
 cleanSymbolType arity type_heaps
 	# (st_result, clean_state) = newAttributedVariable 0 ([], [], type_heaps)
 	  (st_args, (st_vars, st_attr_vars, type_heaps)) = newAttributedVariables arity [] clean_state
-	= ({ st_arity = arity, st_vars = st_vars , st_args = st_args, st_result = st_result, st_context = [],
+	= ({ st_arity = arity, st_vars = st_vars , st_args = st_args, st_args_strictness=NotStrict, st_result = st_result, st_context = [],
 			st_attr_env = [], st_attr_vars = st_attr_vars }, type_heaps)
 
 newAttributedVariables var_number attributed_variables clean_state=:(_,_,_) /* Temporary hack */
@@ -322,7 +330,7 @@ newAttributedVariable var_number (variables, attributes, type_heaps=:{th_vars,th
 	  new_var = { tv_name = NewVarId var_number, tv_info_ptr = tv_info_ptr }
 	  (av_info_ptr, th_attrs) = newPtr AVI_Empty th_attrs
 	  new_attr_var = { av_name = NewAttrVarId var_number, av_info_ptr = av_info_ptr }
-	= ({ at_annotation = AN_None, at_attribute = TA_Var new_attr_var, at_type = TV new_var},
+	= ({ at_attribute = TA_Var new_attr_var, at_type = TV new_var},
 		([ new_var : variables ], [ new_attr_var : attributes ], { type_heaps & th_vars = th_vars, th_attrs = th_attrs }))
 
 cSpecifiedType	:== True
@@ -351,7 +359,7 @@ cleanUpSymbolType is_start_rule spec_type tst=:{tst_arity,tst_args,tst_result,ts
 				expr_heap { cus & cus_var_env = cus_var_env, cus_attr_env = cus_attr_env,
 							 cus_appears_in_lifted_part = {el\\el<-:cus.cus_appears_in_lifted_part},
 							 cus_error = cus_error }
-	  st = {  st_arity = tst_arity, st_vars = st_vars , st_args = lifted_args ++ st_args, st_result = st_result, st_context = st_context,
+	  st = {  st_arity = tst_arity, st_vars = st_vars , st_args = lifted_args ++ st_args, st_args_strictness=NotStrict, st_result = st_result, st_context = st_context,
 			st_attr_env = st_attr_env, st_attr_vars = st_attr_vars }
 	  cus_error = check_type_of_start_rule is_start_rule st cus_error
 	= (st,			{ cus_var_env & [i] = TE \\ i <- [0..nr_of_temp_vars - 1]},
@@ -393,7 +401,7 @@ where
 					_
 						-> (exi_vars, all_vars, { cus & cus_var_env = { cus.cus_var_env & [var_number] = TE }, cus_error = existentialError cus.cus_error })
 				# (TV var, cus) = cus!cus_var_env.[var_number]
-				= ([{atv_attribute = var_attr, atv_variable = var, atv_annotation = AN_None } : exi_vars ],
+				= ([{atv_attribute = var_attr, atv_variable = var } : exi_vars ],
 						[var_number : all_vars], { cus & cus_var_env = { cus.cus_var_env & [var_number] = TE }})
 
 	clean_up_result_type cui at cus
@@ -597,6 +605,12 @@ instance bindInstances Type
 				-> type_var_heap <:= (tv_info_ptr, TVI_Type type)
 	bindInstances (TA _ arg_types1) (TA _ arg_types2) type_var_heap
 		= bindInstances arg_types1 arg_types2 type_var_heap
+	bindInstances (TA _ arg_types1) (TAS _ arg_types2 _) type_var_heap
+		= bindInstances arg_types1 arg_types2 type_var_heap
+	bindInstances (TAS _ arg_types1 _) (TA _ arg_types2) type_var_heap
+		= bindInstances arg_types1 arg_types2 type_var_heap
+	bindInstances (TAS _ arg_types1 _) (TAS _ arg_types2 _) type_var_heap
+		= bindInstances arg_types1 arg_types2 type_var_heap
 	bindInstances (l1 --> r1) (l2 --> r2) type_var_heap
 		= bindInstances r1 r2 (bindInstances l1 l2 type_var_heap)
 //AA..
@@ -719,6 +733,9 @@ where
 	substitute (TA cons_id cons_args) heaps
 		# (ok, cons_args, heaps) = substitute cons_args heaps
 		= (ok, TA cons_id cons_args,  heaps)
+	substitute (TAS cons_id cons_args strictness) heaps
+		# (ok, cons_args, heaps) = substitute cons_args heaps
+		= (ok, TAS cons_id cons_args strictness,  heaps)
 	substitute (CV type_var :@: types) heaps=:{th_vars}
 		# (tv_info, th_vars) = readPtr type_var.tv_info_ptr th_vars
 		  heaps = { heaps & th_vars = th_vars }
@@ -802,6 +819,11 @@ where
 		| rem 
 			= (True, TA cons_id cons_args)
 			= (False, t)
+	removeAnnotations t=:(TAS cons_id cons_args _)
+		# (rem, cons_args) = removeAnnotations cons_args
+		| rem 
+			= (True, TA cons_id cons_args)
+			= (False, t)
 	removeAnnotations t=:(cv :@: types)
 		# (rem, types) = removeAnnotations types
 		| rem 
@@ -813,21 +835,21 @@ where
 
 instance removeAnnotations AType
 where
-	removeAnnotations atype=:{at_annotation,at_type}
+	removeAnnotations atype=:{at_type}
 		# (rem, at_type) = removeAnnotations at_type
 		| rem
-			= (True, { atype & at_annotation = AN_None, at_type = at_type })
-		| at_annotation == AN_None
+			= (True, { atype & at_type = at_type })
 			= (False, atype)
-			= (True, { atype & at_annotation = AN_None })
 
 instance removeAnnotations SymbolType
 where
-	removeAnnotations st=:{st_args,st_result}
+	removeAnnotations st=:{st_args,st_result,st_args_strictness}
 		# (rem, (st_args,st_result)) = removeAnnotations (st_args,st_result)
 		| rem
-			= (True, { st & st_args = st_args, st_result = st_result })
+			= (True, { st & st_args = st_args, st_args_strictness=NotStrict, st_result = st_result })
+		| is_not_strict st_args_strictness
 			= (False, st)
+			= (True, { st & st_args_strictness=NotStrict })
 
 /*
 expandTypeApplication :: ![ATypeVar] !TypeAttribute !Type ![AType] !TypeAttribute !*TypeHeaps -> (!Type, !*TypeHeaps)
@@ -906,6 +928,18 @@ where
 		| tc1 == tc2
 			= equiv types1 types2 heaps
 			= (False, heaps)
+	equiv (TA tc1 types1) (TAS tc2 types2 _) heaps
+		| tc1 == tc2
+			= equiv types1 types2 heaps
+			= (False, heaps)
+	equiv (TAS tc1 types1 _) (TA tc2 types2) heaps
+		| tc1 == tc2
+			= equiv types1 types2 heaps
+			= (False, heaps)
+	equiv (TAS tc1 types1 _) (TAS tc2 types2 _) heaps
+		| tc1 == tc2
+			= equiv types1 types2 heaps
+			= (False, heaps)
 	equiv (TB basic1) (TB basic2) heaps
 		= (basic1 == basic2, heaps)
 	equiv (CV tv :@: types1) (TempCV var_number :@: types2) heaps
@@ -1105,9 +1139,19 @@ where
 	writeType file (Yes beautifulizer) (_, av)
 		= writeBeautifulAttrVar file beautifulizer (TA_Var av)
 
+:: SAType = {s_annotation::!Annotation,s_type::!AType}
+
+add_strictness_annotations :: [AType] Int StrictnessList -> [SAType]
+add_strictness_annotations [arg:args] strictness_index strictness
+	# annotation=arg_strictness_annotation strictness_index strictness
+	# args=add_strictness_annotations args (strictness_index+1) strictness
+	= [{s_annotation=annotation,s_type=arg}:args]
+add_strictness_annotations [] strictness_index strictness
+	= []
+
 instance writeType SymbolType
 where
-	writeType file opt_beautifulizer (form, {st_args, st_arity, st_result, st_context, st_attr_env})
+	writeType file opt_beautifulizer (form, {st_args, st_args_strictness,st_arity, st_result, st_context, st_attr_env})
 		# file_opt_beautifulizer
 				= case st_arity of
 					0
@@ -1118,8 +1162,14 @@ where
 								bracket_arrow_type _ form
 									=	form
 					_
-						# (file, opt_beautifulizer)
-								= writeType file opt_beautifulizer (form, st_args)
+ 						# (file, opt_beautifulizer)
+//								= writeType file opt_beautifulizer (form, st_args)
+								= write_arguments file opt_beautifulizer form st_args
+							with
+								write_arguments file opt_beautifulizer form st_args
+									| checkProperty form cAnnotated
+										= writeType file opt_beautifulizer (form, add_strictness_annotations st_args 0 st_args_strictness)
+										= writeType file opt_beautifulizer (form, st_args)								
 						-> writeType (file <<< " -> ") opt_beautifulizer (form, st_result)
 		  (file, opt_beautifulizer)
 				= show_context form st_context file_opt_beautifulizer
@@ -1162,11 +1212,14 @@ where
 	writeType file opt_beautifulizer (form, {tc_class={glob_object={ds_ident}}, tc_types})
 		= writeType (file <<< ds_ident <<< ' ') opt_beautifulizer (form, tc_types)
 
+instance writeType SAType
+where
+	writeType file opt_beautifulizer (form, {s_annotation, s_type})
+		= writeType (file <<< s_annotation) opt_beautifulizer (form,s_type)
+
 instance writeType AType
 where
-	writeType file opt_beautifulizer (form, {at_attribute, at_annotation, at_type})
-		| checkProperty form cAnnotated
-			= show_attributed_type (file <<< at_annotation) opt_beautifulizer form at_attribute at_type
+	writeType file opt_beautifulizer (form, {at_attribute, at_type})
 			= show_attributed_type file opt_beautifulizer form at_attribute at_type
 	where
 		show_attributed_type file opt_beautifulizer form TA_Multi type
@@ -1226,53 +1279,12 @@ where
 		= (file <<< varid, No)
 	writeType file No (form, TempV tv_number)
 		= (file  <<< 'v' <<< tv_number, No)
-	writeType file opt_beautifulizer (form, TA {type_name,type_index,type_arity} types)
-		| is_predefined type_index
-			| type_name.id_name=="_List"
-				= writeWithinBrackets "[" "]" file opt_beautifulizer (setProperty form cCommaSeparator, types)
-			| type_name.id_name=="_!List"
-				= writeWithinBrackets "[!" "]" file opt_beautifulizer (setProperty form cCommaSeparator, types)
-			| type_name.id_name=="_#List"
-				= writeWithinBrackets "[#" "]" file opt_beautifulizer (setProperty form cCommaSeparator, types)
-			| type_name.id_name=="_List!"
-				= writeWithinBrackets "[" "!]" file opt_beautifulizer (setProperty form cCommaSeparator, types)
-			| type_name.id_name=="_!List!"
-				= writeWithinBrackets "[!" "!]" file opt_beautifulizer (setProperty form cCommaSeparator, types)
-			| type_name.id_name=="_#List!"
-				= writeWithinBrackets "[#" "!]" file opt_beautifulizer (setProperty form cCommaSeparator, types)
-			| is_lazy_array type_name
-				= writeWithinBrackets "{" "}" file opt_beautifulizer (setProperty form cCommaSeparator, types)
-			| is_strict_array type_name
-				= writeWithinBrackets "{!" "}" file opt_beautifulizer (setProperty form cCommaSeparator, types)
-			| is_unboxed_array type_name
-				= writeWithinBrackets "{#" "}" file opt_beautifulizer (setProperty form cCommaSeparator, types)
-			| is_tuple type_name type_arity
-				= writeWithinBrackets "(" ")" file opt_beautifulizer (setProperty form cCommaSeparator, types)
-			| is_string_type type_name
-				= (file <<< "String", opt_beautifulizer)
-			| type_arity == 0
-				= (file <<< type_name, opt_beautifulizer)
-			| checkProperty form cBrackets
-				# (file, opt_beautifulizer)
-						= writeType (file <<< '(' <<< type_name <<< ' ') opt_beautifulizer (form, types)
-				= (file <<< ')', opt_beautifulizer)
-				= writeType (file <<< type_name <<< ' ') opt_beautifulizer (setProperty form cBrackets, types)
-		| type_arity == 0
-			= (file <<< type_name, opt_beautifulizer)
-		| checkProperty form cBrackets
-			# (file, opt_beautifulizer)
-					= writeType (file <<< '(' <<< type_name <<< ' ') opt_beautifulizer (form, types)
-			= (file <<< ')', opt_beautifulizer)
-			= writeType (file <<< type_name <<< ' ') opt_beautifulizer (setProperty form cBrackets, types)
-	where
-			is_predefined {glob_module} 	= glob_module == cPredefinedModuleIndex
-
-			is_tuple {id_name} tup_arity	= id_name == "_Tuple" +++ toString tup_arity
-			is_lazy_array {id_name} 		= id_name == "_Array"
-			is_strict_array {id_name} 		= id_name == "_!Array"
-			is_unboxed_array {id_name} 		= id_name == "_#Array"
-			is_string_type {id_name}		= id_name == "_String"
-
+	writeType file opt_beautifulizer (form, TA type_symb types)
+		= writeTypeTA file opt_beautifulizer form type_symb types
+	writeType file opt_beautifulizer (form, TAS type_symb types strictness)
+		| checkProperty form cAnnotated
+			= writeTypeTA file opt_beautifulizer form type_symb (add_strictness_annotations types 0 strictness)
+			= writeTypeTA file opt_beautifulizer form type_symb types
 	writeType file opt_beautifulizer (form, arg_type --> res_type)
 		| checkProperty form cBrackets
 			= writeWithinBrackets "(" ")" file opt_beautifulizer
@@ -1320,10 +1332,58 @@ where
 	writeType file _ (form, type)
 		= abort ("<:: (Type) (typesupport.icl)" ---> type)
 
+writeTypeTA :: !*File !(Optional TypeVarBeautifulizer) !Format !TypeSymbIdent !a -> (!*File, !Optional TypeVarBeautifulizer) | writeType a
+writeTypeTA	file opt_beautifulizer form {type_name,type_index,type_arity} types
+	| is_predefined type_index
+		| type_name.id_name=="_List"
+			= writeWithinBrackets "[" "]" file opt_beautifulizer (setProperty form cCommaSeparator, types)
+		| type_name.id_name=="_!List"
+			= writeWithinBrackets "[!" "]" file opt_beautifulizer (setProperty form cCommaSeparator, types)
+		| type_name.id_name=="_#List"
+			= writeWithinBrackets "[#" "]" file opt_beautifulizer (setProperty form cCommaSeparator, types)
+		| type_name.id_name=="_List!"
+			= writeWithinBrackets "[" "!]" file opt_beautifulizer (setProperty form cCommaSeparator, types)
+		| type_name.id_name=="_!List!"
+			= writeWithinBrackets "[!" "!]" file opt_beautifulizer (setProperty form cCommaSeparator, types)
+		| type_name.id_name=="_#List!"
+			= writeWithinBrackets "[#" "!]" file opt_beautifulizer (setProperty form cCommaSeparator, types)
+		| is_lazy_array type_name
+			= writeWithinBrackets "{" "}" file opt_beautifulizer (setProperty form cCommaSeparator, types)
+		| is_strict_array type_name
+			= writeWithinBrackets "{!" "}" file opt_beautifulizer (setProperty form cCommaSeparator, types)
+		| is_unboxed_array type_name
+			= writeWithinBrackets "{#" "}" file opt_beautifulizer (setProperty form cCommaSeparator, types)
+		| is_tuple type_name type_arity
+			= writeWithinBrackets "(" ")" file opt_beautifulizer (setProperty form cCommaSeparator, types)
+		| is_string_type type_name
+			= (file <<< "String", opt_beautifulizer)
+		| type_arity == 0
+			= (file <<< type_name, opt_beautifulizer)
+		| checkProperty form cBrackets
+			# (file, opt_beautifulizer)
+					= writeType (file <<< '(' <<< type_name <<< ' ') opt_beautifulizer (form, types)
+			= (file <<< ')', opt_beautifulizer)
+			= writeType (file <<< type_name <<< ' ') opt_beautifulizer (setProperty form cBrackets, types)
+	| type_arity == 0
+		= (file <<< type_name, opt_beautifulizer)
+	| checkProperty form cBrackets
+		# (file, opt_beautifulizer)
+				= writeType (file <<< '(' <<< type_name <<< ' ') opt_beautifulizer (form, types)
+		= (file <<< ')', opt_beautifulizer)
+		= writeType (file <<< type_name <<< ' ') opt_beautifulizer (setProperty form cBrackets, types)
+where
+		is_predefined {glob_module} 	= glob_module == cPredefinedModuleIndex
+
+		is_tuple {id_name} tup_arity	= id_name == "_Tuple" +++ toString tup_arity
+		is_lazy_array {id_name} 		= id_name == "_Array"
+		is_strict_array {id_name} 		= id_name == "_!Array"
+		is_unboxed_array {id_name} 		= id_name == "_#Array"
+		is_string_type {id_name}		= id_name == "_String"
+
 instance writeType ATypeVar
 where
-	writeType file beautifulizer (form, {atv_attribute,atv_annotation,atv_variable})
-		= writeType file beautifulizer (form, { at_attribute = atv_attribute, at_annotation = atv_annotation, at_type = TV atv_variable })
+	writeType file beautifulizer (form, {atv_attribute,atv_variable})
+		= writeType file beautifulizer (form, { at_attribute = atv_attribute, at_type = TV atv_variable })
 
 writeWithinBrackets br_open br_close file opt_beautifulizer (form, types)
 	# (file, opt_beautifulizer) 
@@ -1472,7 +1532,14 @@ getImplicitAttrInequalities st=:{st_args, st_result}
 	= uniqueBagToList (Pair ineqs1 ineqs2)
   where
 	get_ineqs_of_atype :: !AType -> !.Bag AttrInequality
-	get_ineqs_of_atype a_type=:{at_attribute=TA_Var outer_av, at_type=at_type=:TA type_symb_ident type_args}
+	get_ineqs_of_atype {at_attribute=TA_Var outer_av, at_type=at_type=:TA type_symb_ident type_args}
+		= get_ineqs_of_TA_with_TA_Var outer_av at_type type_symb_ident type_args
+	get_ineqs_of_atype {at_attribute=TA_Var outer_av, at_type=at_type=:TAS type_symb_ident type_args _}
+		= get_ineqs_of_TA_with_TA_Var outer_av at_type type_symb_ident type_args
+	get_ineqs_of_atype {at_type}
+		= get_ineqs_of_type at_type
+
+	get_ineqs_of_TA_with_TA_Var outer_av at_type type_symb_ident type_args
 		# ({tsp_propagation}) = type_symb_ident.type_prop
 		  implicit_ineqs_1 = get_superflous_ineqs outer_av type_args tsp_propagation
 		| isEmptyBag implicit_ineqs_1
@@ -1492,11 +1559,11 @@ getImplicitAttrInequalities st=:{st_args, st_result}
 				TA_Var inner_av
 					-> Pair (Single {ai_demanded=inner_av, ai_offered=outer_av}) other_ineqs
 				_	-> other_ineqs
-	get_ineqs_of_atype {at_type}
-		= get_ineqs_of_type at_type
 
 	get_ineqs_of_type (TA ts args)
 		= get_ineqs_of_atype_list args
+	get_ineqs_of_type (TAS ts args _)
+		= get_ineqs_of_atype_list args
 	get_ineqs_of_type (l --> r)
 		= Pair (get_ineqs_of_atype l) (get_ineqs_of_atype r)
 //AA..
@@ -1684,6 +1751,9 @@ anonymizeAttrVars st=:{st_attr_vars, st_args, st_result, st_attr_env} implicit_i
 	anonymize_type (TA tsi args) th_attrs
 		# (args, th_attrs) = mapSt anonymize_atype args th_attrs
 		= (TA tsi args, th_attrs)
+	anonymize_type (TAS tsi args strictness) th_attrs
+		# (args, th_attrs) = mapSt anonymize_atype args th_attrs
+		= (TAS tsi args strictness, th_attrs)
 	anonymize_type (l --> r) th_attrs
 		# (l, th_attrs) = anonymize_atype l th_attrs
 		  (r, th_attrs) = anonymize_atype r th_attrs
@@ -1731,6 +1801,8 @@ anonymizeAttrVars st=:{st_attr_vars, st_args, st_result, st_attr_env} implicit_i
 	
 		count_attr_vars_of_type (TA _ args) th_attrs
 			= foldSt count_attr_vars_of_atype args th_attrs
+		count_attr_vars_of_type (TAS _ args _) th_attrs
+			= foldSt count_attr_vars_of_atype args th_attrs
 		count_attr_vars_of_type (l --> r) th_attrs
 			= count_attr_vars_of_atype l (count_attr_vars_of_atype r th_attrs)
 //AA..
@@ -1895,6 +1967,8 @@ instance performOnTypeVars Type
   where
 	performOnTypeVars f (TA _ args) st
 		= performOnTypeVars f args st
+	performOnTypeVars f (TAS _ args _) st
+		= performOnTypeVars f args st
 	performOnTypeVars f (at1 --> at2) st
 		= performOnTypeVars f at2 (performOnTypeVars f at1 st)
 //AA..
@@ -1943,6 +2017,8 @@ instance performOnAttrVars Type
   where
 	performOnAttrVars f (TA _ args) st
 		= performOnAttrVars f args st
+	performOnAttrVars f (TAS _ args _) st
+		= performOnAttrVars f args st
 	performOnAttrVars f (at1 --> at2) st
 		= performOnAttrVars f at2 (performOnAttrVars f at1 st)
 //AA..
@@ -1996,6 +2072,10 @@ foldATypeSt on_atype on_type type st :== fold_atype_st type st
 		#! st
 				= foldSt fold_atype_st args st
 		= on_type type st
+	fold_type_st type=:(TAS type_symb_ident args _) st
+		#! st
+				= foldSt fold_atype_st args st
+		= on_type type st
 	fold_type_st type=:(l --> r) st
 		#! st
 				= fold_atype_st r (fold_atype_st l st)
diff --git a/frontend/unitype.icl b/frontend/unitype.icl
index ca83155..20189bd 100644
--- a/frontend/unitype.icl
+++ b/frontend/unitype.icl
@@ -275,41 +275,57 @@ liftTypeApplication modules cons_vars t0=:(TA cons_id=:{type_name,type_index={gl
 		| equal_type_prop type_prop type_prop0
 			= (False, t0, subst, ls)
 			= (True, TA { cons_id & type_prop = type_prop } cons_args, subst, ls)
-	where
-		lift_list :: !{#CommonDefs} !{# BOOLVECT } ![AType] ![TypeKind] !*{!Type} !*LiftState
-			-> (!Bool,![AType], ![SignClassification], ![PropClassification], !*{!Type}, !*LiftState)
-		lift_list modules cons_vars [] _ subst ls
-			= (False, [], [], [], subst, ls)
-		lift_list modules cons_vars ts0=:[t0:ts] [tk : tks] subst ls
-			# (changed, t, subst, ls) = lift modules cons_vars t0 subst ls
-			| changed
-				# (_, ts, sign_classes, prop_classes, subst, ls) = lift_list modules cons_vars ts tks subst ls
-				| IsArrowKind tk
-					# (sign_classes,prop_classes) = add_sign_and_prop_of_arrow_kind t.at_type sign_classes prop_classes
-					= (True,[t:ts],sign_classes,prop_classes,subst,ls)
-					= (True,[t:ts],sign_classes,prop_classes,subst,ls)
-				# (changed, ts, sign_classes, prop_classes, subst, ls) = lift_list modules cons_vars ts tks subst ls
-				| changed
-					| IsArrowKind tk
-						# (sign_classes,prop_classes) = add_sign_and_prop_of_arrow_kind t.at_type sign_classes prop_classes
-						= (True, [t0:ts], sign_classes,prop_classes, subst, ls)
-						= (True, [t:ts], sign_classes, prop_classes, subst, ls)
-					| IsArrowKind tk
-						# (sign_classes,prop_classes) = add_sign_and_prop_of_arrow_kind t.at_type sign_classes prop_classes
-						= (False, ts0, sign_classes, prop_classes, subst, ls)
-						= (False, ts0, sign_classes, prop_classes, subst, ls)
-
-		add_sign_and_prop_of_arrow_kind (TA {type_arity,type_prop} _) sign_classes prop_classes
-			= ([adjustSignClass type_prop.tsp_sign type_arity : sign_classes], [adjustPropClass type_prop.tsp_propagation type_arity : prop_classes])
-		add_sign_and_prop_of_arrow_kind (TempV tmp_var_id) sign_classes prop_classes
-			| isPositive tmp_var_id cons_vars
-				= ([PostiveSignClass : sign_classes], [PropClass : prop_classes])
-				= ([TopSignClass : sign_classes], [NoPropClass : prop_classes])
-		add_sign_and_prop_of_arrow_kind _  sign_classes prop_classes
-			= ([TopSignClass : sign_classes], [PropClass : prop_classes])
+liftTypeApplication modules cons_vars t0=:(TAS cons_id=:{type_name,type_index={glob_object,glob_module},type_arity,type_prop=type_prop0} cons_args strictness) subst ls
+	# ({tdi_kinds}, ls) = ls!ls_td_infos.[glob_module].[glob_object]
+	# (changed,cons_args, sign_classes, prop_classes, subst, ls=:{ls_type_heaps}) = lift_list modules cons_vars cons_args tdi_kinds subst ls
+	| changed
+		# (type_prop, th_vars, ls_td_infos) = typeProperties glob_object glob_module sign_classes prop_classes modules ls_type_heaps.th_vars ls.ls_td_infos
+		  ls = { ls & ls_td_infos = ls_td_infos, ls_type_heaps = {ls_type_heaps & th_vars = th_vars}}
+		| equal_type_prop type_prop type_prop0
+			= (True, TAS cons_id cons_args strictness, subst, ls)
+			= (True, TAS { cons_id & type_prop = type_prop } cons_args strictness, subst, ls)
+		# (type_prop, th_vars, ls_td_infos) = typeProperties glob_object glob_module sign_classes prop_classes modules ls_type_heaps.th_vars ls.ls_td_infos
+		  ls = { ls & ls_td_infos = ls_td_infos, ls_type_heaps = {ls_type_heaps & th_vars = th_vars}}
+		| equal_type_prop type_prop type_prop0
+			= (False, t0, subst, ls)
+			= (True, TAS { cons_id & type_prop = type_prop } cons_args strictness, subst, ls)
 liftTypeApplication modules cons_vars type  subst ls
 	= lift modules cons_vars type  subst ls
 
+lift_list :: !{#CommonDefs} !{# BOOLVECT } ![AType] ![TypeKind] !*{!Type} !*LiftState
+	-> (!Bool,![AType], ![SignClassification], ![PropClassification], !*{!Type}, !*LiftState)
+lift_list modules cons_vars [] _ subst ls
+	= (False, [], [], [], subst, ls)
+lift_list modules cons_vars ts0=:[t0:ts] [tk : tks] subst ls
+	# (changed, t, subst, ls) = lift modules cons_vars t0 subst ls
+	| changed
+		# (_, ts, sign_classes, prop_classes, subst, ls) = lift_list modules cons_vars ts tks subst ls
+		| IsArrowKind tk
+			# (sign_classes,prop_classes) = add_sign_and_prop_of_arrow_kind_in_lift t.at_type cons_vars sign_classes prop_classes
+			= (True,[t:ts],sign_classes,prop_classes,subst,ls)
+			= (True,[t:ts],sign_classes,prop_classes,subst,ls)
+		# (changed, ts, sign_classes, prop_classes, subst, ls) = lift_list modules cons_vars ts tks subst ls
+		| changed
+			| IsArrowKind tk
+				# (sign_classes,prop_classes) = add_sign_and_prop_of_arrow_kind_in_lift t.at_type cons_vars sign_classes prop_classes
+				= (True, [t0:ts], sign_classes,prop_classes, subst, ls)
+				= (True, [t:ts], sign_classes, prop_classes, subst, ls)
+			| IsArrowKind tk
+				# (sign_classes,prop_classes) = add_sign_and_prop_of_arrow_kind_in_lift t.at_type cons_vars sign_classes prop_classes
+				= (False, ts0, sign_classes, prop_classes, subst, ls)
+				= (False, ts0, sign_classes, prop_classes, subst, ls)
+
+add_sign_and_prop_of_arrow_kind_in_lift (TA {type_arity,type_prop} _) cons_vars sign_classes prop_classes
+	= ([adjustSignClass type_prop.tsp_sign type_arity : sign_classes], [adjustPropClass type_prop.tsp_propagation type_arity : prop_classes])
+add_sign_and_prop_of_arrow_kind_in_lift (TAS {type_arity,type_prop} _ _) cons_vars sign_classes prop_classes
+	= ([adjustSignClass type_prop.tsp_sign type_arity : sign_classes], [adjustPropClass type_prop.tsp_propagation type_arity : prop_classes])
+add_sign_and_prop_of_arrow_kind_in_lift (TempV tmp_var_id) cons_vars sign_classes prop_classes
+	| isPositive tmp_var_id cons_vars
+		= ([PostiveSignClass : sign_classes], [PropClass : prop_classes])
+		= ([TopSignClass : sign_classes], [NoPropClass : prop_classes])
+add_sign_and_prop_of_arrow_kind_in_lift _ cons_vars sign_classes prop_classes
+	= ([TopSignClass : sign_classes], [PropClass : prop_classes])
+
 instance lift Type
 where
 	lift modules cons_vars (TempV temp_var) subst ls
@@ -335,6 +351,9 @@ where
 	lift modules cons_vars type=:(TA cons_id cons_args) subst ls=:{ls_type_heaps}
 		# (_, type, ls_type_heaps) = tryToExpand type TA_Multi modules ls_type_heaps
 		= liftTypeApplication modules cons_vars type subst {ls & ls_type_heaps = ls_type_heaps}			
+	lift modules cons_vars type=:(TAS cons_id cons_args _) subst ls=:{ls_type_heaps}
+		# (_, type, ls_type_heaps) = tryToExpand type TA_Multi modules ls_type_heaps
+		= liftTypeApplication modules cons_vars type subst {ls & ls_type_heaps = ls_type_heaps}			
 	lift modules cons_vars type=:(TempCV temp_var :@: types) subst ls
 		# (changed, var_type, subst, ls) = liftTempTypeVariable modules cons_vars temp_var subst ls
 		  (changed_types, types, subst, ls) = lift_list modules cons_vars types subst ls
@@ -342,6 +361,8 @@ where
 			= case var_type of
 				TA type_cons cons_args
 					-> (True, TA { type_cons & type_arity = type_cons.type_arity + length types } (cons_args ++ types), subst, ls)
+				TAS type_cons cons_args strictness
+					-> (True, TAS { type_cons & type_arity = type_cons.type_arity + length types } (cons_args ++ types) strictness, subst, ls)
 				TempV tv_number
 					-> (True, TempCV tv_number :@: types, subst, ls)
 				TempQV tv_number
@@ -461,51 +482,34 @@ where
 		# ({tdi_kinds}, es) = es!es_td_infos.[glob_module].[glob_object]
 		  (changed,cons_args, hio_signs, hio_props, (subst,es=:{es_td_infos,es_type_heaps})) = expand_type_list modules cons_vars cons_args tdi_kinds (subst, es)
 		| changed
-			# (type_prop, th_vars, es_td_infos) = typeProperties glob_object glob_module hio_signs hio_props modules es_type_heaps.th_vars es_td_infos
+		  	# (type_prop, th_vars, es_td_infos) = typeProperties glob_object glob_module hio_signs hio_props modules es_type_heaps.th_vars es_td_infos
+			| equal_type_prop type_prop type_prop0
+			  	# es = { es & es_td_infos = es_td_infos, es_type_heaps = { es_type_heaps & th_vars = th_vars }}
+				= (True,TA cons_id cons_args, (subst, es))
+			  	# es = { es & es_td_infos = es_td_infos, es_type_heaps = { es_type_heaps & th_vars = th_vars }}
+				= (True,TA { cons_id & type_prop = type_prop } cons_args, (subst, es))
+		  	# (type_prop, th_vars, es_td_infos) = typeProperties glob_object glob_module hio_signs hio_props modules es_type_heaps.th_vars es_td_infos
 			| equal_type_prop type_prop type_prop0
-				= (True,TA cons_id cons_args,
-					(subst, { es & es_td_infos = es_td_infos, es_type_heaps = { es_type_heaps & th_vars = th_vars }}))
-				= (True,TA { cons_id & type_prop = type_prop } cons_args,
-						(subst, { es & es_td_infos = es_td_infos, es_type_heaps = { es_type_heaps & th_vars = th_vars }}))
+			  	# es = { es & es_td_infos = es_td_infos, es_type_heaps = { es_type_heaps & th_vars = th_vars }}
+				= (False,t0, (subst, es))
+			  	# es = { es & es_td_infos = es_td_infos, es_type_heaps = { es_type_heaps & th_vars = th_vars }}
+				= (True,TA { cons_id & type_prop = type_prop } cons_args, (subst, es))
+	expandType modules cons_vars t0=:(TAS cons_id=:{type_name, type_index={glob_object,glob_module},type_prop=type_prop0} cons_args strictness) (subst, es)
+		# ({tdi_kinds}, es) = es!es_td_infos.[glob_module].[glob_object]
+		  (changed,cons_args, hio_signs, hio_props, (subst,es=:{es_td_infos,es_type_heaps})) = expand_type_list modules cons_vars cons_args tdi_kinds (subst, es)
+		| changed
+		 	# (type_prop, th_vars, es_td_infos) = typeProperties glob_object glob_module hio_signs hio_props modules es_type_heaps.th_vars es_td_infos
+			| equal_type_prop type_prop type_prop0
+			  	# es = { es & es_td_infos = es_td_infos, es_type_heaps = { es_type_heaps & th_vars = th_vars }}
+				= (True,TAS cons_id cons_args strictness, (subst, es))
+			  	# es = { es & es_td_infos = es_td_infos, es_type_heaps = { es_type_heaps & th_vars = th_vars }}
+				= (True,TAS { cons_id & type_prop = type_prop } cons_args strictness, (subst, es))
 			# (type_prop, th_vars, es_td_infos) = typeProperties glob_object glob_module hio_signs hio_props modules es_type_heaps.th_vars es_td_infos
 			| equal_type_prop type_prop type_prop0
-				= (False,t0,
-					(subst, { es & es_td_infos = es_td_infos, es_type_heaps = { es_type_heaps & th_vars = th_vars }}))
-				= (True,TA { cons_id & type_prop = type_prop } cons_args,
-						(subst, { es & es_td_infos = es_td_infos, es_type_heaps = { es_type_heaps & th_vars = th_vars }}))
-	where
-		expand_type_list ::  !{#CommonDefs} !{# BOOLVECT } ![AType] ![TypeKind] !(!u:{!Type}, !*ExpansionState)
-			-> (!Bool,![AType], ![SignClassification], ![PropClassification], !(!u:{!Type}, !*ExpansionState))
-		expand_type_list modules cons_vars [] _ es
-			= (False,[], [], [], es)
-		expand_type_list modules cons_vars ts0=:[t0:ts] [tk : tks] es
-			# (changed,t, es) = expandType modules cons_vars t0 es
-			| changed
-				# (_,ts, sign_classes, prop_classes, es) = expand_type_list modules cons_vars ts tks es
-				| IsArrowKind tk
-					# (sign_classes,prop_classes) = add_sign_and_prop_of_arrow_kind t.at_type sign_classes prop_classes;
-					= (True,[t:ts], sign_classes, prop_classes, es)
-					= (True,[t:ts], sign_classes, prop_classes, es)
-				# (changed,ts, sign_classes, prop_classes, es) = expand_type_list modules cons_vars ts tks es
-				| changed
-					| IsArrowKind tk
-						# (sign_classes,prop_classes) = add_sign_and_prop_of_arrow_kind t.at_type sign_classes prop_classes;
-						= (True,[t0:ts], sign_classes, prop_classes, es)
-						= (True,[t0:ts], sign_classes, prop_classes, es)
-					| IsArrowKind tk
-						# (sign_classes,prop_classes) = add_sign_and_prop_of_arrow_kind t.at_type sign_classes prop_classes;
-						= (False,ts0, sign_classes, prop_classes, es)
-						= (False,ts0, sign_classes, prop_classes, es)
-
-		add_sign_and_prop_of_arrow_kind (TA {type_arity,type_prop} _) sign_classes prop_classes
-			=([adjustSignClass type_prop.tsp_sign type_arity : sign_classes],[adjustPropClass type_prop.tsp_propagation type_arity : prop_classes])
-		add_sign_and_prop_of_arrow_kind (	TempV tmp_var_id) sign_classes prop_classes
-			| isPositive tmp_var_id cons_vars
-				= ([PostiveSignClass : sign_classes], [PropClass : prop_classes])
-				= ([TopSignClass : sign_classes], [NoPropClass : prop_classes])
-		add_sign_and_prop_of_arrow_kind _ sign_classes prop_classes
-			= ([TopSignClass : sign_classes], [PropClass : prop_classes])
-
+		 		# es = { es & es_td_infos = es_td_infos, es_type_heaps = { es_type_heaps & th_vars = th_vars }}
+				= (False,t0, (subst, es))
+				# es = { es & es_td_infos = es_td_infos, es_type_heaps = { es_type_heaps & th_vars = th_vars }}
+				= (True,TAS { cons_id & type_prop = type_prop } cons_args strictness, (subst, es))
 	expandType modules cons_vars type=:(TempCV temp_var :@: types) es
 		# (changed_type, var_type, es) = expandTempTypeVariable temp_var es
 		  (changed_types, types, es) = expandType modules cons_vars types es
@@ -514,6 +518,9 @@ where
 				TA type_cons=:{type_arity} cons_args
 					# nr_of_new_args = length types
 					-> (True, TA { type_cons & type_arity = type_arity + nr_of_new_args } (cons_args ++ types), es)
+				TAS type_cons=:{type_arity} cons_args strictness
+					# nr_of_new_args = length types
+					-> (True, TAS { type_cons & type_arity = type_arity + nr_of_new_args } (cons_args ++ types) strictness, es)
 				TempV tv_number
 					-> (True, TempCV tv_number :@: types, es)
 				TempQV tv_number
@@ -534,6 +541,40 @@ where
 		= (False, type, es)
 
 
+expand_type_list ::  !{#CommonDefs} !{# BOOLVECT } ![AType] ![TypeKind] !(!u:{!Type}, !*ExpansionState)
+	-> (!Bool,![AType], ![SignClassification], ![PropClassification], !(!u:{!Type}, !*ExpansionState))
+expand_type_list modules cons_vars [] _ es
+	= (False,[], [], [], es)
+expand_type_list modules cons_vars ts0=:[t0:ts] [tk : tks] es
+	# (changed,t, es) = expandType modules cons_vars t0 es
+	| changed
+		# (_,ts, sign_classes, prop_classes, es) = expand_type_list modules cons_vars ts tks es
+		| IsArrowKind tk
+			# (sign_classes,prop_classes) = add_sign_and_prop_of_arrow_kind_in_expand t.at_type cons_vars sign_classes prop_classes;
+			= (True,[t:ts], sign_classes, prop_classes, es)
+			= (True,[t:ts], sign_classes, prop_classes, es)
+		# (changed,ts, sign_classes, prop_classes, es) = expand_type_list modules cons_vars ts tks es
+		| changed
+			| IsArrowKind tk
+				# (sign_classes,prop_classes) = add_sign_and_prop_of_arrow_kind_in_expand t.at_type cons_vars sign_classes prop_classes;
+				= (True,[t0:ts], sign_classes, prop_classes, es)
+				= (True,[t0:ts], sign_classes, prop_classes, es)
+			| IsArrowKind tk
+				# (sign_classes,prop_classes) = add_sign_and_prop_of_arrow_kind_in_expand t.at_type cons_vars sign_classes prop_classes;
+				= (False,ts0, sign_classes, prop_classes, es)
+				= (False,ts0, sign_classes, prop_classes, es)
+
+add_sign_and_prop_of_arrow_kind_in_expand (TA {type_arity,type_prop} _) cons_vars sign_classes prop_classes
+	=([adjustSignClass type_prop.tsp_sign type_arity : sign_classes],[adjustPropClass type_prop.tsp_propagation type_arity : prop_classes])
+add_sign_and_prop_of_arrow_kind_in_expand (TAS {type_arity,type_prop} _ _) cons_vars sign_classes prop_classes
+	=([adjustSignClass type_prop.tsp_sign type_arity : sign_classes],[adjustPropClass type_prop.tsp_propagation type_arity : prop_classes])
+add_sign_and_prop_of_arrow_kind_in_expand (	TempV tmp_var_id) cons_vars sign_classes prop_classes
+	| isPositive tmp_var_id cons_vars
+		= ([PostiveSignClass : sign_classes], [PropClass : prop_classes])
+		= ([TopSignClass : sign_classes], [NoPropClass : prop_classes])
+add_sign_and_prop_of_arrow_kind_in_expand _ cons_vars sign_classes prop_classes
+	= ([TopSignClass : sign_classes], [PropClass : prop_classes])
+
 instance expandType [a] | expandType a
 where
 	expandType modules cons_vars [] es
@@ -786,21 +827,17 @@ where
 			| tsp_coercible
 				= sign
 				= TopSign
+		adjust_sign sign (TAS {type_name, type_prop={tsp_coercible}} _ _) cons_vars
+			| tsp_coercible
+				= sign
+				= TopSign
 		adjust_sign sign _ cons_vars
 			= sign
 
-		add_propagation_inequalities cons_vars attr (TA {type_name,type_prop={tsp_propagation}} cons_args) coercions
-			= add_inequalities tsp_propagation attr cons_args coercions
-		where
-			add_inequalities prop_class attr [] coercions
-				= (True, coercions)
-			add_inequalities prop_class attr [{at_attribute} : args] coercions
-				| (prop_class bitand 1) == 0
-					= add_inequalities (prop_class >> 1) attr args coercions
-				# (succ, coercions) = coerceAttributes attr at_attribute PositiveSign coercions
-				| succ
-					= add_inequalities (prop_class >> 1) attr args coercions
-					= (False, coercions)
+		add_propagation_inequalities cons_vars attr (TA {type_prop={tsp_propagation}} cons_args) coercions
+			= add_inequalities_for_TA tsp_propagation attr cons_args coercions
+		add_propagation_inequalities cons_vars attr (TAS {type_prop={tsp_propagation}} cons_args _) coercions
+			= add_inequalities_for_TA tsp_propagation attr cons_args coercions
 		add_propagation_inequalities cons_vars attr (TempCV tmp_var_id :@: types) coercions
 			| isPositive tmp_var_id cons_vars
 				= add_inequalities attr types coercions
@@ -816,9 +853,19 @@ where
 		add_propagation_inequalities cons_vars attr type coercions
 				= (True, coercions)
 
-tryToExpandTypeSyn :: !{#CommonDefs} !{#BOOLVECT} !TypeSymbIdent ![AType] !TypeAttribute !*TypeHeaps !*TypeDefInfos
+		add_inequalities_for_TA prop_class attr [] coercions
+			= (True, coercions)
+		add_inequalities_for_TA prop_class attr [{at_attribute} : args] coercions
+			| (prop_class bitand 1) == 0
+				= add_inequalities_for_TA (prop_class >> 1) attr args coercions
+			# (succ, coercions) = coerceAttributes attr at_attribute PositiveSign coercions
+			| succ
+				= add_inequalities_for_TA (prop_class >> 1) attr args coercions
+				= (False, coercions)
+
+tryToExpandTypeSyn :: !{#CommonDefs} !{#BOOLVECT} !Type !TypeSymbIdent ![AType] !TypeAttribute !*TypeHeaps !*TypeDefInfos
 	-> (!Bool, !Type, !*TypeHeaps, !*TypeDefInfos)
-tryToExpandTypeSyn defs cons_vars cons_id=:{type_index={glob_object,glob_module}} type_args attribute type_heaps td_infos
+tryToExpandTypeSyn defs cons_vars type cons_id=:{type_index={glob_object,glob_module}} type_args attribute type_heaps td_infos
 	# {td_rhs,td_args,td_attribute,td_name} = defs.[glob_module].com_type_defs.[glob_object]
 	= case td_rhs of
 		SynType {at_type}			
@@ -828,34 +875,57 @@ tryToExpandTypeSyn defs cons_vars cons_id=:{type_index={glob_object,glob_module}
 			-> (True, expanded_type, clearBindingsOfTypeVarsAndAttributes attribute td_args es_type_heaps, es_td_infos)
 
 		_
-			-> (False, TA cons_id type_args, type_heaps, td_infos)
+			-> (False, type/*TA cons_id type_args*/, type_heaps, td_infos)
 		
 coerceTypes :: !Sign !{# CommonDefs} !{# BOOLVECT} !TypePosition !AType !AType !*CoercionState -> (!Optional TypePosition, !*CoercionState)		
-coerceTypes sign defs cons_vars tpos dem_type=:{at_type = TA dem_cons dem_args} off_type=:{at_type = TA off_cons off_args}  cs=:{crc_type_heaps, crc_td_infos}
+coerceTypes sign defs cons_vars tpos dem_type=:{at_type=type1=:TA dem_cons dem_args} off_type=:{at_type=type2=:TA off_cons off_args}  cs=:{crc_type_heaps, crc_td_infos}
 	| dem_cons == off_cons
 		= coercions_of_arg_types sign defs cons_vars tpos dem_args off_args dem_cons.type_prop.tsp_sign 0 cs
-		# (_, exp_dem_type, crc_type_heaps, crc_td_infos) = tryToExpandTypeSyn defs cons_vars dem_cons dem_args dem_type.at_attribute crc_type_heaps crc_td_infos
-		  (_, exp_off_type, crc_type_heaps, crc_td_infos) = tryToExpandTypeSyn defs cons_vars off_cons off_args off_type.at_attribute crc_type_heaps crc_td_infos
+		# (_, exp_dem_type, crc_type_heaps, crc_td_infos) = tryToExpandTypeSyn defs cons_vars type1 dem_cons dem_args dem_type.at_attribute crc_type_heaps crc_td_infos
+		  (_, exp_off_type, crc_type_heaps, crc_td_infos) = tryToExpandTypeSyn defs cons_vars type2 off_cons off_args off_type.at_attribute crc_type_heaps crc_td_infos
 		= coerceTypes sign defs cons_vars tpos { dem_type & at_type = exp_dem_type } { off_type & at_type = exp_off_type }
 							{ cs & crc_type_heaps = crc_type_heaps, crc_td_infos = crc_td_infos }
-	where
-		coercions_of_arg_types sign defs cons_vars tpos [t1 : ts1] [t2 : ts2] sign_class arg_number cs
-			# arg_sign = sign * signClassToSign sign_class arg_number
-			  (succ, cs) = coerce arg_sign defs cons_vars [arg_number : tpos] t1 t2 cs
-			| Success succ 
-				= coercions_of_arg_types sign defs cons_vars tpos ts1 ts2 sign_class (inc arg_number) cs
-				= (succ, cs)
-		coercions_of_arg_types sign defs cons_vars tpos [] [] _ _ cs
-			= (No, cs)
-coerceTypes sign defs cons_vars tpos dem_type=:{at_type = TA dem_cons dem_args} off_type cs=:{crc_type_heaps, crc_td_infos}
-	# (succ, exp_dem_type, crc_type_heaps, crc_td_infos) = tryToExpandTypeSyn defs cons_vars dem_cons dem_args dem_type.at_attribute crc_type_heaps crc_td_infos
+coerceTypes sign defs cons_vars tpos dem_type=:{at_type=type1=:TA dem_cons dem_args} off_type=:{at_type=type2=:TAS off_cons off_args _}  cs=:{crc_type_heaps, crc_td_infos}
+	| dem_cons == off_cons
+		= coercions_of_arg_types sign defs cons_vars tpos dem_args off_args dem_cons.type_prop.tsp_sign 0 cs
+		# (_, exp_dem_type, crc_type_heaps, crc_td_infos) = tryToExpandTypeSyn defs cons_vars type1 dem_cons dem_args dem_type.at_attribute crc_type_heaps crc_td_infos
+		  (_, exp_off_type, crc_type_heaps, crc_td_infos) = tryToExpandTypeSyn defs cons_vars type2 off_cons off_args off_type.at_attribute crc_type_heaps crc_td_infos
+		= coerceTypes sign defs cons_vars tpos { dem_type & at_type = exp_dem_type } { off_type & at_type = exp_off_type }
+							{ cs & crc_type_heaps = crc_type_heaps, crc_td_infos = crc_td_infos }
+coerceTypes sign defs cons_vars tpos dem_type=:{at_type=type1=:TAS dem_cons dem_args _} off_type=:{at_type=type2=:TA off_cons off_args}  cs=:{crc_type_heaps, crc_td_infos}
+	| dem_cons == off_cons
+		= coercions_of_arg_types sign defs cons_vars tpos dem_args off_args dem_cons.type_prop.tsp_sign 0 cs
+		# (_, exp_dem_type, crc_type_heaps, crc_td_infos) = tryToExpandTypeSyn defs cons_vars type1 dem_cons dem_args dem_type.at_attribute crc_type_heaps crc_td_infos
+		  (_, exp_off_type, crc_type_heaps, crc_td_infos) = tryToExpandTypeSyn defs cons_vars type2 off_cons off_args off_type.at_attribute crc_type_heaps crc_td_infos
+		= coerceTypes sign defs cons_vars tpos { dem_type & at_type = exp_dem_type } { off_type & at_type = exp_off_type }
+							{ cs & crc_type_heaps = crc_type_heaps, crc_td_infos = crc_td_infos }
+coerceTypes sign defs cons_vars tpos dem_type=:{at_type=type1=:TAS dem_cons dem_args _} off_type=:{at_type=type2=:TAS off_cons off_args _}  cs=:{crc_type_heaps, crc_td_infos}
+	| dem_cons == off_cons
+		= coercions_of_arg_types sign defs cons_vars tpos dem_args off_args dem_cons.type_prop.tsp_sign 0 cs
+		# (_, exp_dem_type, crc_type_heaps, crc_td_infos) = tryToExpandTypeSyn defs cons_vars type1 dem_cons dem_args dem_type.at_attribute crc_type_heaps crc_td_infos
+		  (_, exp_off_type, crc_type_heaps, crc_td_infos) = tryToExpandTypeSyn defs cons_vars type2 off_cons off_args off_type.at_attribute crc_type_heaps crc_td_infos
+		= coerceTypes sign defs cons_vars tpos { dem_type & at_type = exp_dem_type } { off_type & at_type = exp_off_type }
+							{ cs & crc_type_heaps = crc_type_heaps, crc_td_infos = crc_td_infos }
+coerceTypes sign defs cons_vars tpos dem_type=:{at_type=type=:TA dem_cons dem_args} off_type cs=:{crc_type_heaps, crc_td_infos}
+	# (succ, exp_dem_type, crc_type_heaps, crc_td_infos) = tryToExpandTypeSyn defs cons_vars type dem_cons dem_args dem_type.at_attribute crc_type_heaps crc_td_infos
 	| succ
 		= coerceTypes sign defs cons_vars tpos { dem_type & at_type = exp_dem_type } off_type
 					{ cs & crc_type_heaps = crc_type_heaps, crc_td_infos = crc_td_infos }
 		= (No, { cs & crc_type_heaps = crc_type_heaps, crc_td_infos = crc_td_infos })
-coerceTypes sign defs cons_vars tpos dem_type  off_type=:{at_type = TA off_cons off_args} cs=:{crc_type_heaps, crc_td_infos}
-	# (succ, exp_off_type, crc_type_heaps, crc_td_infos) = tryToExpandTypeSyn defs cons_vars off_cons off_args off_type.at_attribute
-			crc_type_heaps crc_td_infos
+coerceTypes sign defs cons_vars tpos dem_type=:{at_type=type=:TAS dem_cons dem_args _} off_type cs=:{crc_type_heaps, crc_td_infos}
+	# (succ, exp_dem_type, crc_type_heaps, crc_td_infos) = tryToExpandTypeSyn defs cons_vars type dem_cons dem_args dem_type.at_attribute crc_type_heaps crc_td_infos
+	| succ
+		= coerceTypes sign defs cons_vars tpos { dem_type & at_type = exp_dem_type } off_type
+					{ cs & crc_type_heaps = crc_type_heaps, crc_td_infos = crc_td_infos }
+		= (No, { cs & crc_type_heaps = crc_type_heaps, crc_td_infos = crc_td_infos })
+coerceTypes sign defs cons_vars tpos dem_type off_type=:{at_type=type=:TAS off_cons off_args _} cs=:{crc_type_heaps, crc_td_infos}
+	# (succ, exp_off_type, crc_type_heaps, crc_td_infos) = tryToExpandTypeSyn defs cons_vars type off_cons off_args off_type.at_attribute crc_type_heaps crc_td_infos
+	| succ
+		= coerceTypes sign defs cons_vars tpos dem_type { off_type & at_type = exp_off_type }
+					{ cs & crc_type_heaps = crc_type_heaps, crc_td_infos = crc_td_infos }
+		= (No, { cs & crc_type_heaps = crc_type_heaps, crc_td_infos = crc_td_infos })
+coerceTypes sign defs cons_vars tpos dem_type off_type=:{at_type=type=:TA off_cons off_args} cs=:{crc_type_heaps, crc_td_infos}
+	# (succ, exp_off_type, crc_type_heaps, crc_td_infos) = tryToExpandTypeSyn defs cons_vars type off_cons off_args off_type.at_attribute crc_type_heaps crc_td_infos
 	| succ
 		= coerceTypes sign defs cons_vars tpos dem_type { off_type & at_type = exp_off_type }
 					{ cs & crc_type_heaps = crc_type_heaps, crc_td_infos = crc_td_infos }
@@ -894,6 +964,15 @@ where
 coerceTypes sign defs cons_vars tpos _ _  cs
 	= (No, cs)
 
+coercions_of_arg_types sign defs cons_vars tpos [t1 : ts1] [t2 : ts2] sign_class arg_number cs
+	# arg_sign = sign * signClassToSign sign_class arg_number
+	  (succ, cs) = coerce arg_sign defs cons_vars [arg_number : tpos] t1 t2 cs
+	| Success succ 
+		= coercions_of_arg_types sign defs cons_vars tpos ts1 ts2 sign_class (inc arg_number) cs
+		= (succ, cs)
+coercions_of_arg_types sign defs cons_vars tpos [] [] _ _ cs
+	= (No, cs)
+
 AttrRestricted :== 0
 
 instance <<< CoercionTree
diff --git a/frontend/utilities.icl b/frontend/utilities.icl
index 22e0b70..48a5012 100644
--- a/frontend/utilities.icl
+++ b/frontend/utilities.icl
@@ -433,23 +433,3 @@ replaceTwoDimArrElt ix1 ix2 el arr
 	  (el2, inner_array)
 	  		= replace inner_array ix2 el
 	= (el2, { arr & [ix1] = inner_array })
-/* crashes!
-replaceTwoDimArrElt ix1 ix2 el arr = code
-	{						| A:arr el								B:ix2 ix1
-		push_b 0			| A:arr el								B:ix2 ix1 ix1
-		update_b 2 1		| A:arr el								B:ix2 ix2 ix1
-		update_b 0 2		| A:arr el								B:ix1 ix2 ix1
-		push_a 1			| A:arr el arr							B:ix1 ix2 ix1
-		select _ 1 0		| A:arr el arr.[ix1]					B:ix1 ix2
-		push_array 0
-		updatepop_a 0 1
-		replace _ 1 0		| A:arr arr.[ix1]* new_el				B:ix1
-		push_a 2	 		| A:arr arr.[ix1]* new_el arr			B:ix1
-		update_a 1 3		| A:new_el arr.[ix1]* new_el arr		B:ix1
-		update_a 2 1		| A:new_el arr.[ix1]* arr.[ix1]* arr	B:ix1
-		update _ 1 0		| A:new_el arr.[ix1]* arr*
-		update_a 2 1		| A:new_el new_el arr*
-		update_a 0 2		| A:arr* new_el arr*
-		pop_a 1				| A:arr* new_el
-	}
-*/
\ No newline at end of file