diff options
Diffstat (limited to 'frontend')
| -rw-r--r-- | frontend/checkFunctionBodies.icl | 23 | ||||
| -rw-r--r-- | frontend/overloading.icl | 2 | ||||
| -rw-r--r-- | frontend/parse.icl | 86 | ||||
| -rw-r--r-- | frontend/postparse.icl | 38 | ||||
| -rw-r--r-- | frontend/syntax.dcl | 13 | ||||
| -rw-r--r-- | frontend/syntax.icl | 3 | ||||
| -rw-r--r-- | frontend/transform.icl | 17 | ||||
| -rw-r--r-- | frontend/type.icl | 9 |
8 files changed, 139 insertions, 52 deletions
diff --git a/frontend/checkFunctionBodies.icl b/frontend/checkFunctionBodies.icl index 8d8a20f..accf0d3 100644 --- a/frontend/checkFunctionBodies.icl +++ b/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 diff --git a/frontend/overloading.icl b/frontend/overloading.icl index 26d3381..e063788 100644 --- a/frontend/overloading.icl +++ b/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) diff --git a/frontend/parse.icl b/frontend/parse.icl index a020dba..0b4d468 100644 --- a/frontend/parse.icl +++ b/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 diff --git a/frontend/postparse.icl b/frontend/postparse.icl index 6a04239..0bb2f37 100644 --- a/frontend/postparse.icl +++ b/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) diff --git a/frontend/syntax.dcl b/frontend/syntax.dcl index 3cbafa0..12131b1 100644 --- a/frontend/syntax.dcl +++ b/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 diff --git a/frontend/syntax.icl b/frontend/syntax.icl index 96c5b84..13d3e80 100644 --- a/frontend/syntax.icl +++ b/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 diff --git a/frontend/transform.icl b/frontend/transform.icl index 3763da1..5dc7c7c 100644 --- a/frontend/transform.icl +++ b/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) diff --git a/frontend/type.icl b/frontend/type.icl index 6574e31..2a349bd 100644 --- a/frontend/type.icl +++ b/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) |