implement {# and {! in array comprehensions that create a new array

frontend/checkFunctionBodies.icl

@@ -1199,6 +1199,29 @@ checkExpression free_vars (PE_Generic id=:{id_name,id_info} kind) e_input e_stat
 */
 			= (generic_defs, {e_state & es_generic_heap = es_generic_heap}) 									 
 
+checkExpression free_vars (PE_TypeSignature array_kind expr) e_input e_state e_info cs
+	# (expr,free_vars,e_state,e_info,cs) = checkExpression free_vars expr e_input e_state e_info cs
+	  predef_array_index = case array_kind of
+								UnboxedArray -> PD_UnboxedArrayType
+								StrictArray -> PD_StrictArrayType
+	  ({pds_module,pds_def},cs) = cs!cs_predef_symbols.[predef_array_index]
+	#! strict_array_ident = predefined_idents.[predef_array_index]
+	# type_prop = { tsp_sign = BottomSignClass, tsp_propagation = NoPropClass, tsp_coercible = True }
+	  strict_array_type_symb_ident = {type_ident=strict_array_ident,type_arity=1,type_index={glob_module=pds_module,glob_object=pds_def},type_prop=type_prop}
+	  expr = TypeSignature (make_fresh_strict_array_type strict_array_type_symb_ident) expr
+	= (expr,free_vars,e_state,e_info,cs)
+	where
+		make_fresh_strict_array_type strict_array_type_symb_ident var_store attr_store
+			# element_type_var=TempV var_store
+			  var_store=var_store+1
+			  element_type_attr_var = TA_TempVar attr_store
+			  attr_store=attr_store+1
+			  array_type_attr_var = TA_TempVar attr_store
+			  attr_store=attr_store+1
+			  element_type = {at_attribute = element_type_attr_var, at_type = element_type_var}
+			  strict_array_type = {at_attribute = array_type_attr_var, at_type = TA strict_array_type_symb_ident [element_type]}
+			= (strict_array_type,var_store,attr_store)
+
 checkExpression free_vars expr e_input e_state e_info cs
 	= abort "checkExpression (checkFunctionBodies.icl)" // <<- expr
 

frontend/overloading.icl

@@ -1521,6 +1521,8 @@ where
 	updateExpression group_index (TupleSelect symbol argn_nr expr) ui
 		# (expr, ui) = updateExpression group_index expr ui
 		= (TupleSelect symbol argn_nr expr, ui)
+	updateExpression group_index (TypeSignature _ expr) ui
+		= updateExpression group_index expr ui
 	updateExpression group_index expr ui
 		= (expr, ui)
 

frontend/parse.icl

@@ -3145,10 +3145,10 @@ tail_strict_cons_and_nil_symbol_index HeadUnboxed = (PD_cons_uts,PD_nil_uts)
 	(List and Array) Comprehensions
 */
 
-wantArrayComprehension :: !ParsedExpr !ParseState -> (!ParsedExpr, !ParseState)
-wantArrayComprehension exp pState
+wantArrayComprehension :: !ArrayKind !ParsedExpr !ParseState -> (!ParsedExpr, !ParseState)
+wantArrayComprehension array_kind exp pState
 	# (qualifiers, pState) = wantQualifiers pState
-	= (PE_ArrayCompr exp qualifiers, wantToken FunctionContext "array comprehension" CurlyCloseToken pState)
+	= (PE_ArrayCompr array_kind exp qualifiers, wantToken FunctionContext "array comprehension" CurlyCloseToken pState)
 
 wantListComprehension :: !Int !ParsedExpr !ParseState -> (!ParsedExpr, !ParseState)
 wantListComprehension head_strictness exp pState
@@ -3322,8 +3322,8 @@ buildNodeDef lhsExpr rhsExpr
 
 wantRecordOrArrayExp :: !Bool !ParseState -> (ParsedExpr, !ParseState)
 wantRecordOrArrayExp is_pattern pState
-	# (token, pState) = nextToken FunctionContext pState
 	| is_pattern
+		# (token, pState) = nextToken FunctionContext pState
 		| token == SquareOpenToken
 			# (elems, pState) =  want_array_assignments cIsAPattern pState
 			= (PE_ArrayPattern elems, wantToken FunctionContext "array selections in pattern" CurlyCloseToken pState)
@@ -3332,41 +3332,61 @@ wantRecordOrArrayExp is_pattern pState
 		// otherwise // is_pattern && token <> SquareOpenToken
 			= want_record_pattern token pState
 	// otherwise // ~ is_pattern
-	| token == CurlyCloseToken
-		= (PE_ArrayDenot [], pState)		
-		# (opt_type, pState) = try_type_specification token pState
-		= case opt_type of
-			NoRecordName
-				# (succ, field, pState) = try_field_assignment token pState
-				| succ
-					# (token, pState) = nextToken FunctionContext pState
-					| token == CommaToken
+	# pState=appScanState setNoNewOffsideForSeqLetBit pState
+	# (token, pState) = nextToken FunctionContext pState
+	# pState=appScanState clearNoNewOffsideForSeqLetBit pState
+	= case token of
+		ExclamationToken
+			-> want_array_elems StrictArray pState
+		SeqLetToken False
+			-> want_array_elems UnboxedArray pState
+		CurlyCloseToken
+			-> (PE_ArrayDenot OverloadedArray [], pState)
+		_
+			# (opt_type, pState) = try_type_specification token pState
+			-> case opt_type of
+				NoRecordName
+					# (succ, field, pState) = try_field_assignment token pState
+					| succ
 						# (token, pState) = nextToken FunctionContext pState
-						  (fields, pState) = want_field_assignments cIsNotAPattern token pState
-						-> (PE_Record PE_Empty NoRecordName [ field : fields ], wantToken FunctionContext "record or array" CurlyCloseToken pState)
-					| token == CurlyCloseToken
-						-> (PE_Record PE_Empty NoRecordName [ field ], pState)
-						-> (PE_Record PE_Empty NoRecordName [ field ], parseError "record or array" (Yes token) "}" pState)
-				# (expr, pState) = wantRhsExpressionT token pState
-				  (token, pState) = nextToken FunctionContext pState
-				| token == AndToken
-					# (token, pState) = nextToken FunctionContext pState
-					-> want_record_or_array_update token expr pState
-				| token == DoubleBackSlashToken
-					-> wantArrayComprehension expr pState
-				# (elems, pState) = want_array_elems token pState
-				-> (PE_ArrayDenot [expr : elems], pState)
-			opt_type
-				-> want_record opt_type pState
+						| token == CommaToken
+							# (token, pState) = nextToken FunctionContext pState
+							  (fields, pState) = want_field_assignments cIsNotAPattern token pState
+							-> (PE_Record PE_Empty NoRecordName [ field : fields ], wantToken FunctionContext "record or array" CurlyCloseToken pState)
+						| token == CurlyCloseToken
+							-> (PE_Record PE_Empty NoRecordName [ field ], pState)
+							-> (PE_Record PE_Empty NoRecordName [ field ], parseError "record or array" (Yes token) "}" pState)
+					# (expr, pState) = wantRhsExpressionT token pState
+					  (token, pState) = nextToken FunctionContext pState
+					| token == AndToken
+						# (token, pState) = nextToken FunctionContext pState
+						-> want_record_or_array_update token expr pState
+					| token == DoubleBackSlashToken
+						-> wantArrayComprehension OverloadedArray expr pState
+					# (elems, pState) = want_more_array_elems token pState
+					-> (PE_ArrayDenot OverloadedArray [expr : elems], pState)
+				opt_type
+					-> want_record opt_type pState
 where
-	want_array_elems CurlyCloseToken pState
+	want_array_elems array_kind pState
+		# (token, pState) = nextToken FunctionContext pState
+		| token == CurlyCloseToken
+			= (PE_ArrayDenot array_kind [], pState)
+			# (expr, pState) = wantRhsExpressionT token pState
+			  (token, pState) = nextToken FunctionContext pState
+			| token == DoubleBackSlashToken
+				= wantArrayComprehension array_kind expr pState
+				# (elems, pState) = want_more_array_elems token pState
+				= (PE_ArrayDenot array_kind [expr:elems], pState)
+
+	want_more_array_elems CurlyCloseToken pState
 		= ([], pState)
-	want_array_elems CommaToken pState
+	want_more_array_elems CommaToken pState
 		# (elem, pState) = wantExpression cIsNotAPattern pState
 		  (token, pState) = nextToken FunctionContext pState
-		  (elems, pState) = want_array_elems token pState
+		  (elems, pState) = want_more_array_elems token pState
 		= ([elem : elems], pState)
-	want_array_elems token pState
+	want_more_array_elems token pState
 		= ([], parseError "array elements" (Yes token) "<array denotation>" pState)
 	
 	want_record_pattern (IdentToken name) pState

frontend/postparse.icl

@@ -155,19 +155,22 @@ where
 	collectFunctions (PE_ListCompr predef_cons_index predef_nil_index expr qualifiers) icl_module ca
 		# (compr, ca) = transformListComprehension predef_cons_index predef_nil_index expr qualifiers ca
 		= collectFunctions compr icl_module ca
-	collectFunctions (PE_ArrayCompr expr qualifiers) icl_module ca
-		# (compr, ca) = transformArrayComprehension expr qualifiers ca
+	collectFunctions (PE_ArrayCompr array_kind expr qualifiers) icl_module ca
+		# (compr, ca) = transformArrayComprehension array_kind expr qualifiers ca
 		=	collectFunctions compr icl_module ca
 	collectFunctions (PE_UpdateComprehension expr updateExpr identExpr qualifiers) icl_module ca
 		# (compr, ca) = transformUpdateComprehension [expr] [updateExpr] [identExpr] identExpr qualifiers ca
 		= collectFunctions compr icl_module ca
 	collectFunctions (PE_Sequ sequence) icl_module ca
 		= collectFunctions (transformSequence sequence) icl_module ca
-	collectFunctions (PE_ArrayDenot exprs) icl_module ca
-		= collectFunctions (transformArrayDenot exprs) icl_module ca
+	collectFunctions (PE_ArrayDenot array_kind exprs) icl_module ca
+		= collectFunctions (transformArrayDenot array_kind exprs) icl_module ca
 	collectFunctions (PE_Dynamic exprs opt_dyn_type) icl_module ca
 		# (exprs, ca) = collectFunctions exprs icl_module ca
 		= (PE_Dynamic exprs opt_dyn_type, ca)
+	collectFunctions (PE_TypeSignature array_kind expr) icl_module ca
+		# (expr, ca) = collectFunctions expr icl_module ca
+		= (PE_TypeSignature array_kind expr,ca)
 	collectFunctions expr icl_module ca
 		= (expr, ca)
 
@@ -753,7 +756,7 @@ transformUpdateQualifier :: [ParsedExpr] [ParsedExpr] Qualifier *CollectAdmin ->
 transformUpdateQualifier array callArray {qual_generators,qual_let_defs,qual_filter, qual_position, qual_filename} ca
 	# (transformedGenerators,index_generator,ca) = transformGenerators qual_generators qual_filename No ca
 	= CreateTransformedQualifierFromTransformedGenerators transformedGenerators array callArray qual_let_defs qual_filter qual_position qual_filename ca
-	
+
 CreateTransformedQualifierFromTransformedGenerators transformedGenerators array callArray qual_let_defs qual_filter qual_position qual_filename ca
 	# (qual_fun_id, ca) = prefixAndPositionToIdent "cu" qual_position ca
 	=	({	tq_generators = transformedGenerators
@@ -781,13 +784,13 @@ transformListComprehension predef_cons_index predef_nil_index expr qualifiers ca
 	  		]
 	= makeComprehensions transformed_qualifiers success [] ca
 
-transformArrayComprehension :: ParsedExpr [Qualifier] *CollectAdmin -> (ParsedExpr, *CollectAdmin)
-transformArrayComprehension expr qualifiers ca
+transformArrayComprehension :: ArrayKind ParsedExpr [Qualifier] *CollectAdmin -> (ParsedExpr, *CollectAdmin)
+transformArrayComprehension array_kind expr qualifiers ca
 	# [hd_qualifier:_] = qualifiers
 	  qual_position = hd_qualifier.qual_position
 	  (c_i_ident_exp, ca) = prefixAndPositionToIdentExp "c_i" qual_position ca
 	  (c_a_ident_exp, ca) = prefixAndPositionToIdentExp "c_a" qual_position ca
-	  create_array = get_predef_id PD__CreateArrayFun
+	  create_array_expr = predef_ident_expr PD__CreateArrayFun
 	| same_index_for_update_and_array_generators qualifiers
 		# index_generator = {gen_kind=IsListGenerator, gen_pattern=c_i_ident_exp, gen_expr=PE_Sequ (SQ_From PD_From (PE_Basic (BVInt 0))), gen_position=qual_position}
 		# update = PE_Update c_a_ident_exp [PS_Array  c_i_ident_exp] expr
@@ -795,17 +798,20 @@ transformArrayComprehension expr qualifiers ca
 			# {qual_generators,qual_let_defs,qual_filter,qual_position,qual_filename} = hd_qualifier
 			# qual_generators = [index_generator : qual_generators]
 			# (transformedGenerators,index_generator,size_exp,ca) = transformGeneratorsAndReturnSize qual_generators qual_filename No PE_Empty ca
-			# new_array = PE_List [PE_Ident create_array,size_exp]
+			# new_array = PE_List [create_array_expr,size_exp]
+			  new_array = cast_array_kind array_kind new_array
 			# (transformed_qualifier,ca) = CreateTransformedQualifierFromTransformedGenerators transformedGenerators [c_a_ident_exp] [new_array] qual_let_defs qual_filter qual_position qual_filename ca
 			= makeUpdateComprehensionFromTransFormedQualifiers [update] [c_a_ident_exp] c_a_ident_exp [transformed_qualifier] ca
 
 			# (length, ca) = computeSize qualifiers qual_position hd_qualifier.qual_filename ca
-			# new_array = PE_List [PE_Ident create_array,length]
+			# new_array = PE_List [create_array_expr,length]
+			  new_array = cast_array_kind array_kind new_array
 			  qualifiers = [{hd_qualifier & qual_generators = [index_generator : hd_qualifier.qual_generators] }]
 			= transformUpdateComprehension [new_array] [update] [c_a_ident_exp] c_a_ident_exp qualifiers ca
 
 		# (length, ca) = computeSize qualifiers qual_position hd_qualifier.qual_filename ca
-		# new_array = PE_List [PE_Ident create_array,length]
+		# new_array = PE_List [create_array_expr,length]
+		  new_array = cast_array_kind array_kind new_array
 		# inc = get_predef_id PD_IncFun
 		  new_array_and_index =	[new_array,PE_Basic (BVInt 0)]
 		  update = [PE_Update c_a_ident_exp [PS_Array  c_i_ident_exp] expr,PE_List [PE_Ident inc,c_i_ident_exp]]
@@ -993,12 +999,16 @@ transformArrayUpdate expr updates
 		update updateIdent {bind_src=value, bind_dst=index} expr
 			=	updateIdent ` expr ` index ` value
 
-transformArrayDenot :: [ParsedExpr] -> ParsedExpr
-transformArrayDenot exprs
+transformArrayDenot :: ArrayKind [ParsedExpr] -> ParsedExpr
+transformArrayDenot array_kind exprs
+	# create_array_call=cast_array_kind array_kind (predef_ident_expr PD__CreateArrayFun ` length exprs)
 	=	transformArrayUpdate
-			(predef_ident_expr PD__CreateArrayFun ` length exprs)
+			create_array_call
 			[{bind_dst=toParsedExpr i, bind_src=expr} \\ expr <- exprs & i <- [0..]]
 
+cast_array_kind OverloadedArray array_expr = array_expr
+cast_array_kind array_kind array_expr = PE_TypeSignature array_kind array_expr
+
 scanModules :: [ParsedImport] [ScannedModule] [Ident] SearchPaths Bool Bool (ModTimeFunction *Files) *Files *CollectAdmin -> (Bool, [ScannedModule],*Files, *CollectAdmin)
 scanModules [] parsed_modules cached_modules searchPaths support_generics support_dynamics modtimefunction files ca
 	= (True, parsed_modules,files, ca)

frontend/syntax.dcl

@@ -1179,14 +1179,14 @@ instance toString 	KindInfo
 				| PE_Record !ParsedExpr !OptionalRecordName ![FieldAssignment]
 				| PE_ArrayPattern ![ElemAssignment]
 				| PE_UpdateComprehension !ParsedExpr !ParsedExpr !ParsedExpr ![Qualifier]
-				| PE_ArrayDenot ![ParsedExpr]
+				| PE_ArrayDenot !ArrayKind ![ParsedExpr]
 				| PE_Selection !ParsedSelectorKind !ParsedExpr ![ParsedSelection]
 				| PE_Update !ParsedExpr [ParsedSelection] ParsedExpr
 				| PE_Case !Ident !ParsedExpr [CaseAlt]
 				| PE_If !Ident !ParsedExpr !ParsedExpr !ParsedExpr
 				| PE_Let !Bool !LocalDefs !ParsedExpr
 				| PE_ListCompr /*predef_cons_index:*/ !Int /*predef_nil_index:*/ !Int !ParsedExpr ![Qualifier]
-				| PE_ArrayCompr !ParsedExpr ![Qualifier]
+				| PE_ArrayCompr !ArrayKind !ParsedExpr ![Qualifier]
 				| PE_Sequ Sequence
 				| PE_WildCard
 				| PE_Field !ParsedExpr !(Global FieldSymbol) /* Auxiliary, used during checking */
@@ -1199,7 +1199,10 @@ instance toString 	KindInfo
 				| PE_DynamicPattern !ParsedExpr !DynamicType
 				| PE_Dynamic !ParsedExpr !(Optional DynamicType)
 				
-				| PE_Generic !Ident !TypeKind	/* AA: For generics, kind indexed identifier */				
+				| PE_Generic !Ident !TypeKind	/* AA: For generics, kind indexed identifier */
+
+				| PE_TypeSignature !ArrayKind !ParsedExpr
+				
 				| PE_Empty
 
 ::	ParsedSelection	= PS_Record !Ident !OptionalRecordName
@@ -1214,6 +1217,8 @@ instance toString 	KindInfo
 	
 ::	ModuleIdent:==Ident
 
+::	ArrayKind = OverloadedArray | StrictArray | UnboxedArray;
+
 ::	GeneratorKind = IsListGenerator | IsOverloadedListGenerator | IsArrayGenerator
 			
 :: LineAndColumn = {lc_line :: !Int, lc_column :: !Int}
@@ -1278,6 +1283,8 @@ cIsNotStrict	:== False
 				| DynamicExpr !DynamicExpr
 				| TypeCodeExpression !TypeCodeExpression
 
+				| TypeSignature !(Int Int -> (AType,Int,Int)) !Expression
+
 				| EE 
 				| NoBind ExprInfoPtr /* auxiliary, to store fields that are not specified in a record expression */ 
 				| FailExpr !Ident // only allowed on (case) root positions

frontend/syntax.icl

@@ -397,6 +397,7 @@ where
 	(<<<) file (ClassVariable info_ptr)         	= file <<< "ClassVariable " <<< info_ptr
 
 	(<<<) file (FailExpr _) = file <<< "** FAIL **"
+	(<<<) file (TypeSignature array_kind expr) = file <<< "TypeSignature " <<< '(' <<< expr <<< ')'
 	(<<<) file expr         				= abort ("<<< (Expression) [line 1290]" )//<<- expr)
 	
 instance <<< LetBind
@@ -480,7 +481,7 @@ where
 	(<<<) file (PE_Record PE_Empty _ fields) = file <<< '{' <<< fields <<< '}'
 	(<<<) file (PE_Record rec _ fields) = file <<< '{' <<< rec <<< " & " <<< fields <<< '}'
 	(<<<) file (PE_ListCompr _ _ expr quals) = file <<< '[' <<< expr <<< " \\ " <<< quals <<< ']'
-	(<<<) file (PE_ArrayCompr expr quals) = file <<< '{' <<< expr <<< " \\ " <<< quals <<< '}'
+	(<<<) file (PE_ArrayCompr _ expr quals) = file <<< '{' <<< expr <<< " \\ " <<< quals <<< '}'
 	(<<<) file (PE_Sequ seq) = file <<< '[' <<< seq <<< ']'
 	(<<<) file PE_Empty = file <<< "** E **"
 	(<<<) file (PE_Ident symb) = file <<< symb

frontend/transform.icl

@@ -7,7 +7,7 @@ import syntax, check, StdCompare, utilities, mergecases; //, RWSDebug
 	,	ls_x 			:: !.LiftStateX
 	,	ls_expr_heap	:: !.ExpressionHeap
 	}
-	
+
 ::	LiftStateX = {
 		x_fun_defs :: !.{#FunDef},
 		x_macro_defs :: !.{#.{#FunDef}},
@@ -86,6 +86,9 @@ where
 	lift (DynamicExpr expr) ls
 		# (expr, ls) = lift expr ls
 		= (DynamicExpr expr, ls)
+	lift (TypeSignature type_function expr) ls
+		# (expr, ls) = lift expr ls
+		= (TypeSignature type_function expr, ls)
 	lift expr ls
 		= (expr, ls)
 
@@ -432,6 +435,9 @@ where
 	unfold (DynamicExpr expr) ui us
 		# (expr, us) = unfold expr ui us
 		= (DynamicExpr expr, us)
+	unfold (TypeSignature type_function expr) ui us
+		# (expr, us) = unfold expr ui us
+		= (TypeSignature type_function expr, us)
 	unfold expr ui us
 		= (expr, us)
 
@@ -469,6 +475,7 @@ where
 	unfold fv=:{fv_info_ptr,fv_ident} ui us=:{us_var_heap}
 		# (new_info_ptr, us_var_heap) = newPtr VI_Empty us_var_heap
 		= ({ fv & fv_info_ptr = new_info_ptr }, { us & us_var_heap = writePtr fv_info_ptr (VI_Variable fv_ident new_info_ptr) us_var_heap })
+
 instance unfold App
 where
 	unfold app=:{app_symb={symb_kind}, app_args, app_info_ptr} ui us
@@ -1234,6 +1241,8 @@ where
 		= has_no_curried_macro_Expression expr
 	has_no_curried_macro_Expression (MatchExpr cons_ident expr)
 		= has_no_curried_macro_Expression expr
+	has_no_curried_macro_Expression (TypeSignature _ expr)
+		= has_no_curried_macro_Expression expr
 	has_no_curried_macro_Expression expr
 		= True
 
@@ -1609,6 +1618,9 @@ where
 	expand (DynamicExpr dyn) ei
 		# (dyn, ei) = expand dyn ei
 		= (DynamicExpr dyn, ei)
+	expand (TypeSignature type_function expr) ei
+		# (expr, ei) = expand expr ei
+		= (TypeSignature type_function expr, ei)
 	expand expr ei
 		= (expr, ei)
 
@@ -2011,6 +2023,9 @@ where
 	collectVariables (DynamicExpr dynamic_expr) free_vars dynamics cos
 		# (dynamic_expr, free_vars, dynamics, cos) = collectVariables dynamic_expr free_vars dynamics cos
 		= (DynamicExpr dynamic_expr, free_vars, dynamics, cos);
+	collectVariables (TypeSignature type_function expr) free_vars dynamics cos
+		# (expr, free_vars, dynamics, cos) = collectVariables expr free_vars dynamics cos
+		= (TypeSignature type_function expr, free_vars, dynamics, cos);
 	collectVariables expr free_vars dynamics cos
 		= (expr, free_vars, dynamics, cos)
 

frontend/type.icl

@@ -1758,6 +1758,15 @@ where
 	requirements _ (ABCCodeExpr _ _) (reqs, ts)
 		# (fresh_v, ts) = freshAttributedVariable ts
 		= (fresh_v, No, (reqs, ts))
+	requirements ti (TypeSignature make_fresh_type_function expr) (reqs, ts)
+		# {ts_var_store,ts_attr_store} = ts
+		  (type,ts_var_store,ts_attr_store) = make_fresh_type_function ts_var_store ts_attr_store
+		  ts = {ts & ts_var_store=ts_var_store,ts_attr_store=ts_attr_store}
+		  (e_type, opt_expr_ptr, (reqs, ts)) = requirements ti expr (reqs, ts)
+		  new_coercion = {tc_demanded=type, tc_offered=e_type, tc_position=CP_Expression expr, tc_coercible=True}
+		  reqs = { reqs & req_type_coercions = [new_coercion : reqs.req_type_coercions ] }
+		  ts = { ts & ts_expr_heap = storeAttribute opt_expr_ptr type.at_attribute ts.ts_expr_heap }
+		= (type, No, (reqs, ts))
 	requirements _ expr reqs_ts
 		= (abort ("Error in requirements\n" ---> expr), No, reqs_ts)