diff options
| -rw-r--r-- | frontend/check.icl | 24 | ||||
| -rw-r--r-- | frontend/explicitimports.icl | 27 | ||||
| -rw-r--r-- | frontend/frontend.icl | 7 | ||||
| -rw-r--r-- | frontend/transform.icl | 2 | ||||
| -rw-r--r-- | frontend/type.icl | 16 | ||||
| -rw-r--r-- | frontend/unitype.icl | 9 |
6 files changed, 69 insertions, 16 deletions
diff --git a/frontend/check.icl b/frontend/check.icl index 1daf18a..0f691e8 100644 --- a/frontend/check.icl +++ b/frontend/check.icl @@ -279,6 +279,7 @@ where check_member_instances :: !Index !Index !Int !Int !{#DefinedSymbol} !{#DefinedSymbol} !InstanceType ![(Index,SymbolType)] !v:{# MemberDef} !u:{# DclModule} !*VarHeap !*TypeHeaps !*CheckState -> (![(Index,SymbolType)], !v:{# MemberDef}, !u:{# DclModule},!*VarHeap, !*TypeHeaps, !*CheckState) + check_member_instances module_index member_mod_index mem_offset class_size ins_members class_members ins_type instance_types member_defs modules var_heap type_heaps cs | mem_offset == class_size @@ -562,7 +563,6 @@ where -> (Yes (type_def,glob_module), selector_defs, type_defs, modules, cs) No -> (No, selector_defs, type_defs, modules, { cs & cs_error = checkError "" " could not determine the type of this record" cs.cs_error }) - check_and_rearrange_fields mod_index field_index fields field_ass cs_error | field_index < size fields @@ -734,7 +734,6 @@ where determine_pattern_symbol mod_index id_index id_kind id_name cons_defs modules error = (id_index, NoIndex, 0, NoPrio, NoIndex, cons_defs, modules, checkError id_name " constructor expected" error) - checkIdentPattern :: !Bool !Ident !(Optional (Bind Ident VarInfoPtr)) !PatternInput !(![Ident], ![ArrayPattern]) !*PatternState !*ExpressionInfo !*CheckState -> (!AuxiliaryPattern, !(![Ident], ![ArrayPattern]), !*PatternState, !*ExpressionInfo, !*CheckState) checkIdentPattern is_expr_list id=:{id_name,id_info} opt_var {pi_def_level, pi_mod_index} accus=:(var_env, array_patterns) @@ -963,6 +962,12 @@ where bind_opt_record_variable no is_node_pattern patterns _ var_heap = (patterns, var_heap) +checkPattern (PE_Bound bind) opt_var p_input accus ps e_info cs + = checkBoundPattern bind opt_var p_input accus ps e_info cs +checkPattern (PE_Ident id) opt_var p_input accus ps e_info cs + = checkIdentPattern cIsNotInExpressionList id opt_var p_input accus ps e_info cs +checkPattern PE_WildCard opt_var p_input accus ps e_info cs + = (AP_WildCard No, accus, ps, e_info, cs) checkPattern (PE_ArrayPattern selections) opt_var p_input (var_env, array_patterns) ps e_info cs # (var_env, ap_selections, ps_var_heap, cs) = foldSt (check_array_selection p_input.pi_def_level) selections (var_env, [], ps.ps_var_heap, cs) @@ -998,14 +1003,6 @@ checkPattern (PE_ArrayPattern selections) opt_var p_input (var_env, array_patter check_rhs _ _ (var_env, ap_selections, var_heap, cs) = (var_env, ap_selections, var_heap, { cs & cs_error = checkError "" "variable expected on right hand side of array pattern" cs.cs_error }) - -checkPattern (PE_Bound bind) opt_var p_input accus ps e_info cs - = checkBoundPattern bind opt_var p_input accus ps e_info cs - -checkPattern (PE_Ident id) opt_var p_input accus ps e_info cs - = checkIdentPattern cIsNotInExpressionList id opt_var p_input accus ps e_info cs -checkPattern PE_WildCard opt_var p_input accus ps e_info cs - = (AP_WildCard No, accus, ps, e_info, cs) checkPattern expr opt_var p_input accus ps e_info cs = abort "checkPattern: do not know how to handle pattern" ---> expr @@ -1829,6 +1826,8 @@ transfromPatternIntoBind _ _ pattern src_expr var_store expr_heap e_info cs checkLocalFunctions mod_index level (CollectedLocalDefs {loc_functions={ir_from,ir_to}}) fun_defs e_info heaps cs = checkFunctions mod_index level ir_from ir_to fun_defs e_info heaps cs +// JVG: added type +checkRhs :: [FreeVar] OptGuardedAlts LocalDefs ExpressionInput *ExpressionState *ExpressionInfo *CheckState -> *(!Expression,![FreeVar],!*ExpressionState,!*ExpressionInfo,!*CheckState); checkRhs free_vars rhs_alts rhs_locals e_input=:{ei_expr_level,ei_mod_index} e_state e_info cs # ei_expr_level = inc ei_expr_level (loc_defs, (var_env, array_patterns), e_state, e_info, cs) = checkLhssOfLocalDefs ei_expr_level ei_mod_index rhs_locals e_state e_info cs @@ -1890,6 +1889,8 @@ where (expr, free_vars, e_state, e_info, cs) = check_opt_guarded_alts free_vars alt_expr e_input e_state e_info cs = (let_vars_list, [(let_binds, guard, expr) : rev_guarded_exprs], ei_expr_level, free_vars, e_state, e_info, cs ) + // JVG: added type + check_unguarded_expression :: [FreeVar] ExprWithLocalDefs ExpressionInput *ExpressionState *ExpressionInfo *CheckState -> *(!Expression,![FreeVar],!*ExpressionState,!*ExpressionInfo,!*CheckState); check_unguarded_expression free_vars {ewl_nodes,ewl_expr,ewl_locals} e_input=:{ei_expr_level,ei_mod_index} e_state e_info cs # this_expr_level = inc ei_expr_level (loc_defs, (var_env, array_patterns), e_state, e_info, cs) @@ -1931,6 +1932,8 @@ where check_sequential_lets free_vars [] let_vars_list e_input=:{ei_expr_level} e_state e_info cs = ([], let_vars_list, ei_expr_level, free_vars, e_state, e_info, cs) + // JVG: added type + check_sequential_let :: [FreeVar] NodeDefWithLocals ExpressionInput *ExpressionState *ExpressionInfo *CheckState -> *(!Expression,!AuxiliaryPattern,!(![Ident],![ArrayPattern]),![FreeVar],!*ExpressionState,!*ExpressionInfo,!*CheckState); check_sequential_let free_vars {ndwl_def={bind_src,bind_dst},ndwl_locals} e_input=:{ei_expr_level,ei_mod_index} e_state e_info cs # (loc_defs, (loc_env, loc_array_patterns), e_state, e_info, cs) = checkLhssOfLocalDefs ei_expr_level ei_mod_index ndwl_locals e_state e_info cs (src_expr, free_vars, e_state, e_info, cs) = checkExpression free_vars bind_src e_input e_state e_info cs @@ -2014,6 +2017,7 @@ convertSubPattern (AP_WildCard opt_var) result_expr var_store expr_heap opt_dyna convertSubPattern (AP_Empty _) result_expr var_store expr_heap opt_dynamics cs = convertSubPattern (AP_WildCard No) EE var_store expr_heap opt_dynamics cs + typeOfBasicValue :: !BasicValue !*CheckState -> (!BasicType, !*CheckState) typeOfBasicValue (BVI _) cs = (BT_Int, cs) typeOfBasicValue (BVC _) cs = (BT_Char, cs) diff --git a/frontend/explicitimports.icl b/frontend/explicitimports.icl index f04a136..59db7dd 100644 --- a/frontend/explicitimports.icl +++ b/frontend/explicitimports.icl @@ -448,7 +448,8 @@ element_appears_in_stomm_struct imported_st element_ident dcl_index index type_n = abort "element_appears_in_stomm_struct will be never called, when the above guard holds. This statement is only to remind people to remove this function." # (dcl_module=:{dcl_name=dcl_name=:{id_info}}, modules) = modules ! [index] (module_entry, cs_symbol_table) = readPtr id_info cs.cs_symbol_table - cs = { cs & cs_symbol_table=cs_symbol_table } +//JVG: add #! + #! cs = { cs & cs_symbol_table=cs_symbol_table } = continuation imported_st module_entry.ste_kind dcl_module modules cs where continuation ST_RecordType (STE_OpenModule _ modul) _ modules cs @@ -558,9 +559,17 @@ check_completeness_of_module mod_index dcls_explicit file_name (f_consequences, # dcls_imp = [((dcl_ident, kind), (dcl_index, mod_index), (file_name, line_nr)) \\ ({dcl_ident, dcl_index, dcl_kind=STE_Imported kind mod_index}, line_nr) <- dcls_explicit] (conseqs, (f_consequences, modules, icl_functions, expr_heap)) +/* JVG: = seqList (map (consequences_of mod_index) dcls_imp) (f_consequences, modules, icl_functions, expr_heap) +*/ + = mapSt (consequences_of mod_index) dcls_imp (f_consequences, modules, icl_functions, expr_heap) +/**/ conseqs = flatten conseqs +/*JVG: #! (modules, cs) = seq (map checkConsequenceError conseqs) (modules, cs) +*/ + #! (modules, cs) = foldr checkConsequenceError (modules, cs) conseqs +/**/ = (f_consequences, modules, icl_functions, expr_heap, cs) consequences_of :: !Index @@ -568,6 +577,7 @@ consequences_of :: !Index -> (![(!IdentWithKind, !IdentWithCKind, !(!String, !Int))], !(*{!FunctionConsequence}, !*{#DclModule}, !*{#FunDef}, !*ExpressionHeap)) consequences_of count (expl_imp_ident_kind=:(_,expl_imp_kind), (dcl_index, mod_index), errMsgInfo) (f_consequences, modules, icl_functions, expr_heap) +/* JVG: # (modul, modules) = modules![mod_index] (consequences, (f_consequences, icl_functions, expr_heap)) = case expl_imp_kind of @@ -577,6 +587,18 @@ consequences_of count (expl_imp_ident_kind=:(_,expl_imp_kind), (dcl_index, mod_i -> (consequences_of_simple_symbol expl_imp_kind modul dcl_index, (f_consequences, icl_functions,expr_heap)) conseqs = removeDup consequences = ([(expl_imp_ident_kind, conseq, errMsgInfo) \\ conseq<-conseqs], (f_consequences, modules, icl_functions, expr_heap)) +*/ + = case expl_imp_kind of + STE_FunctionOrMacro _ + # (consequences, (f_consequences, icl_functions, expr_heap)) = consequences_of_macro count dcl_index f_consequences icl_functions expr_heap + -> (add_kind_and_error_info_to_consequences consequences, (f_consequences, modules, icl_functions, expr_heap)) + _ + # (modul, modules) = modules![mod_index] + -> (add_kind_and_error_info_to_consequences (consequences_of_simple_symbol expl_imp_kind modul dcl_index), (f_consequences, modules, icl_functions, expr_heap)) + where + add_kind_and_error_info_to_consequences consequences + = [(expl_imp_ident_kind, conseq, errMsgInfo) \\ conseq<-removeDup consequences] +/**/ consequences_of_macro count dcl_index f_consequences icl_functions expr_heap # (icl_function, icl_functions) = icl_functions![dcl_index] @@ -666,6 +688,9 @@ consequences_of_simple_symbol STE_Member {dcl_common} dcl_index consequences_of_simple_symbol STE_Instance {dcl_common} dcl_index = consequences dcl_common.com_instance_defs.[dcl_index] +// JVG added type: +checkConsequenceError :: !((Ident,.STE_Kind),!.(Ident,ConsequenceKind),!(.{#Char},.Int)) !*(*{#DclModule},!*CheckState) -> (!*{#DclModule},!.CheckState) + checkConsequenceError (expl_imp_ident_kind, conseq_ident_kind=:(conseq_ident, conseq_kind), (file_name, line_nr)) (modules, cs=:{cs_symbol_table, cs_error}) # (c_ident, modules) diff --git a/frontend/frontend.icl b/frontend/frontend.icl index a5a9b46..d9d17d8 100644 --- a/frontend/frontend.icl +++ b/frontend/frontend.icl @@ -36,6 +36,9 @@ frontEndInterface mod_ident search_paths predef_symbols hash_table files error i = (predef_symbols, hash_table, files, error, io, out, No) # {icl_functions,icl_instances,icl_specials,icl_common,icl_declared} = icl_mod // (components, icl_functions, error) = showComponents components 0 True icl_functions error + + dcl_mods = {{dcl_mod & dcl_declared={dcls_import=[],dcls_local=[],dcls_explicit=[]}}\\ dcl_mod<-:dcl_mods} + (ok, fun_defs, array_instances, type_code_instances, common_defs, imported_funs, heaps, predef_symbols, error) = typeProgram (components -*-> "Typing") icl_functions icl_specials icl_common icl_declared.dcls_import dcl_mods heaps predef_symbols error | not ok @@ -57,11 +60,15 @@ frontEndInterface mod_ident search_paths predef_symbols hash_table files error i = transformGroups cleanup_info components fun_defs acc_args common_defs imported_funs dcl_types used_conses_in_dynamics var_heap type_heaps expression_heap (dcl_types, used_conses, var_heap, type_heaps) = convertIclModule common_defs dcl_types used_conses var_heap type_heaps (dcl_types, used_conses, var_heap, type_heaps) = convertDclModule dcl_mods common_defs dcl_types used_conses var_heap type_heaps + +// (components, fun_defs, out) = showComponents components 0 False fun_defs out + (used_funs, components, fun_defs, dcl_types, used_conses, var_heap, type_heaps, expression_heap) = convertCasesOfFunctionsIntoPatterns components imported_funs common_defs fun_defs dcl_types used_conses var_heap type_heaps expression_heap (dcl_types, type_heaps, var_heap) = convertImportedTypeSpecifications dcl_mods imported_funs common_defs used_conses used_funs dcl_types type_heaps var_heap +// (components, fun_defs, error) = showTypes components 0 fun_defs error // (components, fun_defs, out) = showComponents components 0 False fun_defs out = (predef_symbols,hash_table,files,error,io,out, diff --git a/frontend/transform.icl b/frontend/transform.icl index 539e0ac..ea48c22 100644 --- a/frontend/transform.icl +++ b/frontend/transform.icl @@ -1154,6 +1154,8 @@ determineVariablesAndRefCounts free_vars expr cos=:{cos_var_heap} retrieveRefCounts free_vars var_heap = mapSt retrieveRefCount free_vars var_heap +// JVG: added type: +retrieveRefCount :: FreeVar *(Heap VarInfo) -> (!FreeVar,!.Heap VarInfo); retrieveRefCount fv=:{fv_info_ptr} var_heap # (VI_Count count _, var_heap) = readPtr fv_info_ptr var_heap = ({ fv & fv_count = count }, var_heap) diff --git a/frontend/type.icl b/frontend/type.icl index 001c608..ed3a10b 100644 --- a/frontend/type.icl +++ b/frontend/type.icl @@ -518,8 +518,9 @@ freshSymbolType fresh_context_vars st=:{st_vars,st_args,st_result,st_context,st_ | new_var_id == var_id = vars = [var_id : add_variable new_var_id var_ids] - - + +// JVG: added type: +freshInequality :: AttrInequality *(Heap AttrVarInfo) -> (!AttrCoercion,!.Heap AttrVarInfo); freshInequality {ai_demanded,ai_offered} attr_heap # (av_dem_info, attr_heap) = readPtr ai_demanded.av_info_ptr attr_heap (av_off_info, attr_heap) = readPtr ai_offered.av_info_ptr attr_heap @@ -810,12 +811,20 @@ where requirements ti {var_name,var_info_ptr,var_expr_ptr} (reqs, ts) # (var_info, ts_var_heap) = readPtr var_info_ptr ts.ts_var_heap ts = { ts & ts_var_heap = ts_var_heap } +/* JVG: changed to reduce allocation because the case is polymorphic and lazy in req and ts: */ + = (case var_info of + VI_Type type + -> type + _ + -> abort ("requirements BoundVar" ---> (var_name <<- var_info)) + , Yes var_expr_ptr, (reqs, ts)) +/* = case var_info of VI_Type type -> (type, Yes var_expr_ptr, (reqs, ts)) _ -> abort ("requirements BoundVar" ---> (var_name <<- var_info)) - +*/ instance requirements App where requirements ti {app_symb,app_args,app_info_ptr} (reqs=:{req_cons_variables, req_attr_coercions}, ts) @@ -1422,6 +1431,7 @@ typeProgram comps fun_defs specials icl_defs imports modules {hp_var_heap, hp_ex type_code_instances = {createArray si_next_TC_member_index GTT_Function & [gtci_index] = gtci_type \\ {gtci_index, gtci_type} <- si_TC_instances} = (not type_error, fun_defs, { ir_from = fun_env_size, ir_to = si_next_array_member_index }, type_code_instances, ti_common_defs, ti_functions, {hp_var_heap = ts_var_heap, hp_expression_heap = ts_expr_heap, hp_type_heaps = ts_type_heaps }, predef_symbols, ts_error.ea_file) +// ---> ("typeProgram", array_inst_types) where collect_imported_instances imports common_defs dummy error class_instances type_var_heap td_infos = foldSt (collect_imported_instance common_defs) imports (dummy, error, class_instances, type_var_heap, td_infos) diff --git a/frontend/unitype.icl b/frontend/unitype.icl index c2031ed..d6fdd1a 100644 --- a/frontend/unitype.icl +++ b/frontend/unitype.icl @@ -228,7 +228,6 @@ liftTempTypeVariable modules cons_vars tv_number subst ls class lift a :: !{# CommonDefs } !{# BOOLVECT } !a !*{! Type} !*LiftState -> (!a, !*{! Type}, !*LiftState) - instance lift Type where lift modules cons_vars (TempV tv_number) subst ls @@ -542,6 +541,8 @@ makeUnique attr {coer_demanded, coer_offered} coer_demanded = { coer_demanded & [attr] = CT_Unique } = make_unique off_coercions {coer_offered = coer_offered, coer_demanded = coer_demanded}// ---> ("makeUnique :", attr) where + // JVG added type: + make_unique :: !CoercionTree !*Coercions -> *Coercions; make_unique (CT_Node this_attr ct_less ct_greater) coercions # coercions = makeUnique this_attr coercions coercions = make_unique ct_less coercions @@ -563,6 +564,8 @@ makeNonUnique attr {coer_demanded, coer_offered} = make_non_unique dem_coercions {coer_offered = coer_offered, coer_demanded = coer_demanded} // ---> ("makeNonUnique", attr) where + // JVG added type: + make_non_unique :: !CoercionTree !*Coercions -> *Coercions; make_non_unique (CT_Node this_attr ct_less ct_greater) coercions # coercions = makeNonUnique this_attr coercions coercions = make_non_unique ct_less coercions @@ -588,7 +591,9 @@ Success (Yes _) = False instance coerce AType where coerce sign defs cons_vars tpos at1=:{at_attribute=attr1, at_type = type1} at2=:{at_attribute=attr2} cs=:{crc_coercions} - # attr_sign = adjust_sign sign type1 cons_vars + // JVG: added ! + #!attr_sign = adjust_sign sign type1 cons_vars +// # attr_sign = adjust_sign sign type1 cons_vars (succ, crc_coercions) = coerceAttributes attr1 attr2 attr_sign crc_coercions | succ # (succ, cs) = coerceTypes sign defs cons_vars tpos at1 at2 { cs & crc_coercions = crc_coercions } |