Skip to content
GitLab
Commit f736c783 authored by John van Groningen's avatar John van Groningen
Browse files

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

parent cc1c5c8d
Hide whitespace changes
Inline Side-by-side
frontend/checkFunctionBodies.icl
View file @ f736c783
......@@ -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
View file @ f736c783
......@@ -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
View file @ f736c783
......@@ -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
View file @ f736c783
......@@ -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
View file @ f736c783
......@@ -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
View file @ f736c783
......@@ -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
View file @ f736c783
......@@ -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
View file @ f736c783
......@@ -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)
......
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment