aboutsummaryrefslogtreecommitdiff
path: root/frontend
diff options
context:
space:
mode:
Diffstat (limited to 'frontend')
-rw-r--r--frontend/checkFunctionBodies.icl32
-rw-r--r--frontend/parse.icl8
-rw-r--r--frontend/syntax.dcl12
-rw-r--r--frontend/syntax.icl27
-rw-r--r--frontend/type.icl53
5 files changed, 87 insertions, 45 deletions
diff --git a/frontend/checkFunctionBodies.icl b/frontend/checkFunctionBodies.icl
index d7a7144..2b729d6 100644
--- a/frontend/checkFunctionBodies.icl
+++ b/frontend/checkFunctionBodies.icl
@@ -1009,22 +1009,26 @@ where
cons_optional No variables
= variables
-checkExpression free_vars (PE_Selection is_unique expr [PS_Array index_expr]) e_input e_state e_info cs
+checkExpression free_vars (PE_Selection selector_kind expr [PS_Array index_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
- | is_unique
- # (glob_select_symb, cs) = getPredefinedGlobalSymbol PD_UnqArraySelectFun PD_StdArray STE_Member 2 cs
- (selector, free_vars, e_state, e_info, cs) = checkArraySelection glob_select_symb free_vars index_expr e_input e_state e_info cs
- = (Selection NormalSelector expr [selector], free_vars, e_state, e_info, cs)
- # (glob_select_symb, cs) = getPredefinedGlobalSymbol PD_ArraySelectFun PD_StdArray STE_Member 2 cs
- (selector, free_vars, e_state, e_info, cs) = checkArraySelection glob_select_symb free_vars index_expr e_input e_state e_info cs
- = (Selection NormalSelector expr [selector], free_vars, e_state, e_info, cs)
-checkExpression free_vars (PE_Selection is_unique expr selectors) e_input e_state e_info cs
+ # (select_fun, selector_kind)
+ = case selector_kind of
+ ParsedNormalSelector
+ -> (PD_ArraySelectFun, NormalSelector)
+ ParsedUniqueSelector _
+ -> (PD_UnqArraySelectFun, NormalSelectorUniqueElementResult)
+ # (glob_select_symb, cs) = getPredefinedGlobalSymbol select_fun PD_StdArray STE_Member 2 cs
+ (selector, free_vars, e_state, e_info, cs) = checkArraySelection glob_select_symb free_vars index_expr e_input e_state e_info cs
+ = (Selection selector_kind expr [selector], free_vars, e_state, e_info, cs)
+checkExpression free_vars (PE_Selection selector_kind expr selectors) e_input e_state e_info cs
# (selectors, free_vars, e_state, e_info, cs) = checkSelectors cEndWithSelection free_vars selectors 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
- | is_unique
- # (tuple_type, cs) = getPredefinedGlobalSymbol (GetTupleTypeIndex 2) PD_PredefinedModule STE_Type 2 cs
- = (Selection (UniqueSelector tuple_type False) expr selectors, free_vars, e_state, e_info, cs)
- = (Selection NormalSelector expr selectors, free_vars, e_state, e_info, cs)
+ = case selector_kind of
+ ParsedNormalSelector
+ -> (Selection NormalSelector expr selectors, free_vars, e_state, e_info, cs)
+ ParsedUniqueSelector unique_element
+ # (tuple_type, cs) = getPredefinedGlobalSymbol (GetTupleTypeIndex 2) PD_PredefinedModule STE_Type 2 cs
+ -> (Selection (UniqueSelector tuple_type) expr selectors, free_vars, e_state, e_info, cs)
checkExpression free_vars (PE_Update expr1 selectors expr2) e_input e_state e_info cs
# (expr1, free_vars, e_state, e_info, cs) = checkExpression free_vars expr1 e_input e_state e_info cs
(selectors, free_vars, e_state, e_info, cs) = checkSelectors cEndWithUpdate free_vars selectors e_input e_state e_info cs
@@ -2191,7 +2195,7 @@ buildSelections e_input {ap_opt_var, ap_array_var, ap_selections}
-> (unq_select_symb, NormalSelector, cs)
_ # (select_symb, cs) = getPredefinedGlobalSymbol PD_ArraySelectFun PD_StdArray STE_Member 2 cs
(tuple_type, cs) = getPredefinedGlobalSymbol (GetTupleTypeIndex 2) PD_PredefinedModule STE_Type 2 cs
- -> (select_symb, UniqueSelector tuple_type False, cs)
+ -> (select_symb, UniqueSelector tuple_type, cs)
e_state
= { e_state & es_var_heap = es_var_heap, es_expr_heap = es_expr_heap }
(index_exprs, (free_vars, e_state, e_info, cs))
diff --git a/frontend/parse.icl b/frontend/parse.icl
index e68201b..8e0aa74 100644
--- a/frontend/parse.icl
+++ b/frontend/parse.icl
@@ -2175,7 +2175,7 @@ where
| token == DotToken
# (token, pState) = nextToken FunctionContext pState
(selectors, pState) = wantSelectors token pState
- = (PE_Selection cNonUniqueSelection exp selectors, pState)
+ = (PE_Selection ParsedNormalSelector exp selectors, pState)
| token == ExclamationToken
# (token, pState) = nextToken FunctionContext pState
// JVG added for strict lists:
@@ -2183,7 +2183,7 @@ where
= (exp, tokenBack (tokenBack pState))
//
# (selectors, pState) = wantSelectors token pState
- = (PE_Selection cUniqueSelection exp selectors, pState)
+ = (PE_Selection (ParsedUniqueSelector False) exp selectors, pState)
| otherwise
= (exp, tokenBack pState)
@@ -2869,7 +2869,7 @@ where
# (shareIdent, pState)
= make_ident optionalIdent level pState
select
- = PE_Selection cNonUniqueSelection (PE_Ident shareIdent) [PS_Record fieldIdent final_record_type]
+ = PE_Selection ParsedNormalSelector (PE_Ident shareIdent) [PS_Record fieldIdent final_record_type]
(update_expr, pState)
= transform_record_or_array_update No select (map sub_update updates) (level+1) pState
= ({bind_dst = fieldIdent, bind_src = update_expr}, (Yes shareIdent,record_type,pState))
@@ -2941,7 +2941,7 @@ where
select_def
= buildNodeDef
(PE_Tuple [PE_Ident element_id, PE_Ident array_id])
- (PE_Selection cUniqueSelection expr (reverse [PS_Array (PE_Ident index_id) : initial_selectors]))
+ (PE_Selection (ParsedUniqueSelector True) expr (reverse [PS_Array (PE_Ident index_id) : initial_selectors]))
(updated_element, pState)
= transform_record_update No
(PE_Ident element_id)
diff --git a/frontend/syntax.dcl b/frontend/syntax.dcl
index b022af6..62cb971 100644
--- a/frontend/syntax.dcl
+++ b/frontend/syntax.dcl
@@ -1028,8 +1028,10 @@ instance toString KindInfo
:: LocalDef :== ParsedDefinition
-cUniqueSelection :== True
-cNonUniqueSelection :== False
+:: ParsedSelectorKind
+ = ParsedNormalSelector // .
+ | ParsedUniqueSelector // !
+ !Bool // is result element unique?
:: ParsedExpr = PE_List ![ParsedExpr]
| PE_Ident !Ident
@@ -1041,7 +1043,7 @@ cNonUniqueSelection :== False
| PE_ArrayPattern ![ElemAssignment]
| PE_UpdateComprehension !ParsedExpr !ParsedExpr !ParsedExpr ![Qualifier]
| PE_ArrayDenot ![ParsedExpr]
- | PE_Selection !Bool !ParsedExpr ![ParsedSelection]
+ | PE_Selection !ParsedSelectorKind !ParsedExpr ![ParsedSelection]
| PE_Update !ParsedExpr [ParsedSelection] ParsedExpr
| PE_Case !Ident !ParsedExpr [CaseAlt]
| PE_If !Ident !ParsedExpr !ParsedExpr !ParsedExpr
@@ -1100,10 +1102,10 @@ cIsStrict :== True
cIsNotStrict :== False
:: SelectorKind
- = NormalSelector // .
+ = NormalSelector
+ | NormalSelectorUniqueElementResult
| UniqueSelector // !
(Global DefinedSymbol) // tuple type
- !Bool // is result element unique?
/*
:: SelectorKind = SEK_Normal | SEK_First | SEK_Next | SEK_Last
diff --git a/frontend/syntax.icl b/frontend/syntax.icl
index e73457c..440f23f 100644
--- a/frontend/syntax.icl
+++ b/frontend/syntax.icl
@@ -1020,8 +1020,10 @@ cNotVarNumber :== -1
:: LocalDef :== ParsedDefinition
-cUniqueSelection :== True
-cNonUniqueSelection :== False
+:: ParsedSelectorKind
+ = ParsedNormalSelector // .
+ | ParsedUniqueSelector // !
+ !Bool // is result element unique?
:: ParsedExpr = PE_List ![ParsedExpr]
| PE_Ident !Ident
@@ -1033,7 +1035,7 @@ cNonUniqueSelection :== False
| PE_ArrayPattern ![ElemAssignment]
| PE_UpdateComprehension !ParsedExpr !ParsedExpr !ParsedExpr ![Qualifier]
| PE_ArrayDenot ![ParsedExpr]
- | PE_Selection !Bool !ParsedExpr ![ParsedSelection]
+ | PE_Selection !ParsedSelectorKind !ParsedExpr ![ParsedSelection]
| PE_Update !ParsedExpr [ParsedSelection] ParsedExpr
| PE_Case !Ident !ParsedExpr [CaseAlt]
| PE_If !Ident !ParsedExpr !ParsedExpr !ParsedExpr
@@ -1093,10 +1095,10 @@ cIsStrict :== True
cIsNotStrict :== False
:: SelectorKind
- = NormalSelector // .
+ = NormalSelector
+ | NormalSelectorUniqueElementResult
| UniqueSelector // !
(Global DefinedSymbol) // tuple type
- !Bool // is result element unique?
:: Expression = Var !BoundVar
| App !App
@@ -1661,9 +1663,9 @@ where
instance <<< SelectorKind
where
- (<<<) file NormalSelector = file <<< "!"
- (<<<) file (UniqueSelector _ False) = file <<< "!"
- (<<<) file (UniqueSelector _ True) = file <<< "!*"
+ (<<<) file NormalSelector = file <<< "."
+ (<<<) file NormalSelectorUniqueElementResult = file <<< "!*"
+ (<<<) file (UniqueSelector _) = file <<< "!"
instance <<< Selection
where
@@ -1695,7 +1697,7 @@ where
(<<<) file (PE_List exprs) = file <<< exprs
(<<<) file (PE_Tuple args) = file <<< '(' <<< args <<< ')'
(<<<) file (PE_Basic basic_value) = file <<< basic_value
- (<<<) file (PE_Selection is_unique expr selectors) = file <<< expr <<< (if is_unique '!' '.') <<< selectors
+ (<<<) file (PE_Selection selector_kind expr selectors) = file <<< expr <<< selector_kind <<< selectors
(<<<) file (PE_Update expr1 selections expr2) = file <<< '{' <<< expr1 <<< " & " <<< selections <<< " = " <<< expr2 <<< '}'
(<<<) file (PE_Record PE_Empty _ fields) = file <<< '{' <<< fields <<< '}'
(<<<) file (PE_Record rec _ fields) = file <<< '{' <<< rec <<< " & " <<< fields <<< '}'
@@ -1718,7 +1720,12 @@ where
-> file <<< "dynamic " <<< expr
(<<<) file _ = file <<< "some expression"
-
+instance <<< ParsedSelectorKind
+where
+ (<<<) file ParsedNormalSelector = file <<< "."
+ (<<<) file (ParsedUniqueSelector False) = file <<< "!"
+ (<<<) file (ParsedUniqueSelector True) = file <<< "!*"
+
instance <<< ParsedSelection
where
(<<<) file (PS_Record selector _) = file <<< selector
diff --git a/frontend/type.icl b/frontend/type.icl
index 433a041..9f34c7f 100644
--- a/frontend/type.icl
+++ b/frontend/type.icl
@@ -1470,9 +1470,9 @@ where
requirements ti (Selection selector_kind expr selectors) reqs_ts
# (expr_type, opt_expr_ptr, (reqs, ts)) = requirements ti expr reqs_ts
= case selector_kind of
- UniqueSelector {glob_object={ds_ident,ds_index,ds_arity}, glob_module} _
+ UniqueSelector {glob_object={ds_ident,ds_index,ds_arity}, glob_module}
# (var, ts) = freshAttributedVariable ts
- (_, result_type, (reqs, ts)) = requirementsOfSelectors ti No expr selectors False var expr (reqs, ts)
+ (_, result_type, (reqs, ts)) = requirementsOfSelectors ti No expr selectors False False var expr (reqs, ts)
tuple_type = MakeTypeSymbIdent { glob_object = ds_index, glob_module = glob_module } ds_ident ds_arity
non_unique_type_var = { at_attribute = TA_Multi, at_annotation = AN_None, at_type = TempV ts.ts_var_store }
req_type_coercions
@@ -1482,13 +1482,16 @@ where
result_type = { at_type = TA tuple_type [non_unique_type_var,var], at_attribute = TA_Unique, at_annotation = AN_None }
-> (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}))
- _
- # (_, result_type, reqs_ts) = requirementsOfSelectors ti No expr selectors True expr_type expr (reqs, ts)
+ NormalSelectorUniqueElementResult
+ # (_, result_type, reqs_ts) = requirementsOfSelectors ti No expr selectors True True expr_type expr (reqs, ts)
+ -> (result_type, opt_expr_ptr, reqs_ts)
+ NormalSelector
+ # (_, result_type, reqs_ts) = requirementsOfSelectors ti No expr selectors True False expr_type expr (reqs, ts)
-> (result_type, opt_expr_ptr, reqs_ts)
requirements ti (Update composite_expr selectors elem_expr) reqs_ts
# (composite_expr_type, opt_composite_expr_ptr, reqs_ts) = requirements ti composite_expr reqs_ts
(has_array_selection, result_type, (reqs, ts))
- = requirementsOfSelectors ti (Yes elem_expr) composite_expr selectors True composite_expr_type composite_expr reqs_ts
+ = requirementsOfSelectors ti (Yes elem_expr) composite_expr selectors True False composite_expr_type composite_expr reqs_ts
| has_array_selection
# ts = { ts & ts_expr_heap = storeAttribute opt_composite_expr_ptr TA_Unique ts.ts_expr_heap }
= (composite_expr_type, No, (reqs, ts))
@@ -1560,21 +1563,29 @@ where
= (abort ("Error in requirements\n" ---> expr), No, reqs_ts)
-requirementsOfSelectors ti opt_expr expr [selector] tc_coercible sel_expr_type sel_expr reqs_ts
- = requirementsOfSelector ti opt_expr expr selector tc_coercible sel_expr_type sel_expr reqs_ts
-requirementsOfSelectors ti opt_expr expr [selector : selectors] tc_coercible sel_expr_type sel_expr reqs_ts
- # (has_array_selection, result_type, reqs_ts) = requirementsOfSelector ti No expr selector tc_coercible sel_expr_type sel_expr reqs_ts
- # (have_array_selection, result_type, reqs_ts) = requirementsOfSelectors ti opt_expr expr selectors tc_coercible result_type sel_expr reqs_ts
+requirementsOfSelectors ti opt_expr expr [selector] tc_coercible change_uselect sel_expr_type sel_expr reqs_ts
+ = requirementsOfSelector ti opt_expr expr selector tc_coercible change_uselect sel_expr_type sel_expr reqs_ts
+requirementsOfSelectors ti opt_expr expr [selector : selectors] tc_coercible change_uselect sel_expr_type sel_expr reqs_ts
+ # (has_array_selection, result_type, reqs_ts) = requirementsOfSelector ti No expr selector tc_coercible change_uselect sel_expr_type sel_expr reqs_ts
+ # (have_array_selection, result_type, reqs_ts) = requirementsOfSelectors ti opt_expr expr selectors tc_coercible False result_type sel_expr reqs_ts
= (has_array_selection || have_array_selection, result_type, reqs_ts)
-requirementsOfSelector ti _ expr (RecordSelection field _) tc_coercible sel_expr_type sel_expr (reqs, ts )
+requirementsOfSelector ti _ expr (RecordSelection field _) tc_coercible change_uselect sel_expr_type sel_expr (reqs, ts )
# ({tst_args, tst_result, tst_attr_env}, ts) = standardFieldSelectorType (CP_Expression sel_expr) field ti ts
req_type_coercions = [{ tc_demanded = hd tst_args, tc_offered = sel_expr_type, tc_position = CP_Expression sel_expr, tc_coercible = tc_coercible } :
reqs.req_type_coercions ]
= (False, tst_result, ({ reqs & req_type_coercions = req_type_coercions }, ts))
-requirementsOfSelector ti opt_expr expr (ArraySelection {glob_object = {ds_ident,ds_index,ds_arity},glob_module} expr_ptr index_expr) tc_coercible sel_expr_type sel_expr (reqs, ts)
+requirementsOfSelector ti opt_expr expr (ArraySelection {glob_object = {ds_ident,ds_index,ds_arity},glob_module} expr_ptr index_expr) tc_coercible change_uselect sel_expr_type sel_expr (reqs, ts)
# {me_type} = ti.ti_common_defs.[glob_module].com_member_defs.[ds_index]
({tst_attr_env,tst_args,tst_result,tst_context}, ts) = freshSymbolType (Yes (CP_Expression expr)) cWithFreshContextVars me_type ti.ti_common_defs ts
+ # (tst_args, tst_result, ts)
+ = case ds_ident.id_name of
+ // RWS FIXME: use predef symbols
+ "uselect"
+ | change_uselect
+ -> change_uselect_attributes tst_args tst_result ts
+ _
+ -> (tst_args, tst_result, ts)
(dem_array_type, dem_index_type, rest_type) = array_and_index_type tst_args
reqs ={ reqs & req_attr_coercions = tst_attr_env ++ reqs.req_attr_coercions}
(index_type, opt_expr_ptr, (reqs, ts)) = requirements ti index_expr (reqs, ts)
@@ -1601,6 +1612,24 @@ where
tc_position = CP_Expression elem_expr, tc_coercible = True } : reqs.req_type_coercions ]}
= (reqs, ts)
+ /*
+ change
+ uselect :: !u:(a e) !Int -> ( e, !u:(a e)) | uselect_u e
+ to
+ uselect :: !u:(a .e) !Int -> (.e, !u:(a .e)) | uselect_u e
+ (necessary for uselects in updates)
+ */
+ change_uselect_attributes :: [AType] AType u:TypeState -> ([AType], AType, u:TypeState)
+ change_uselect_attributes args=:[arg_array=:{at_type=aa :@: [ae]}, arg_int]
+ result=:{at_type=TA tuple_symb [result_element, result_array=:{at_type=ra :@: [re]}]} ts
+ # (attribute, ts) = freshAttribute ts
+ # 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 _ _ ts
+ = abort "type.icl, change_uselect_attributes: wrong type for uselect"
+
+
possibly_accumulate_reqs_in_new_group position state_transition reqs_ts
:== possibly_accumulate_reqs position reqs_ts
where
generated by cgit v1.2.3 (git 2.39.1) at 2025-03-14 17:08:19 +0000