Skip to content
GitLab
Commit 27472f84 authored by Martin Wierich's avatar Martin Wierich
Browse files

improved typing error messages: type variables are printed like "a" instead 

of "v314", case defaults and guards now also have file position information.
parent 46ed5ee5
Hide whitespace changes
Inline Side-by-side
frontend/StdCompare.dcl
View file @ 27472f84
......@@ -14,7 +14,7 @@ instance =< Int, Expression, {# Char}, Ident, [a] | =< a, BasicType //, (Global
instance =< Type, SymbIdent
instance == BasicType, TypeVar, TypeSymbIdent, DefinedSymbol, TypeContext , BasicValue,
FunKind, (Global a) | == a, Priority, Assoc
FunKind, (Global a) | == a, Priority, Assoc, Type
instance < MemberDef
frontend/StdCompare.icl
View file @ 27472f84
......@@ -74,6 +74,14 @@ where
= type1 == type2 && types1 == types2
equal_constructor_args (TQV varid1) (TQV varid2)
= varid1 == varid2
// MW4..
equal_constructor_args (GTV varid1) (GTV varid2)
= varid1 == varid2
equal_constructor_args (TempQV varid1) (TempQV varid2)
= varid1 == varid2
equal_constructor_args (TLifted varid1) (TLifted varid2)
= varid1 == varid2
// ..MW4
equal_constructor_args type1 type2
= True
......
frontend/check.icl
View file @ 27472f84
......@@ -1867,19 +1867,19 @@ where
check_default_expr free_vars No e_input e_state e_info cs
= (No, free_vars, e_state, e_info, cs)
convert_guards_to_cases [(let_binds, guard, expr)] result_expr es_expr_heap
convert_guards_to_cases [(let_binds, guard, expr, guard_ident)] result_expr es_expr_heap
# (case_expr_ptr, es_expr_heap) = newPtr EI_Empty es_expr_heap
basic_pattern = {bp_value = (BVB True), bp_expr = expr, bp_position = NoPos }
case_expr = Case { case_expr = guard, case_guards = BasicPatterns BT_Bool [basic_pattern],
case_default = result_expr, case_ident = No, case_info_ptr = case_expr_ptr,
case_default_pos = NoPos }
case_default = result_expr, case_ident = Yes guard_ident,
case_info_ptr = case_expr_ptr, case_default_pos = NoPos }
= build_sequential_lets let_binds case_expr es_expr_heap
convert_guards_to_cases [(let_binds, guard, expr) : rev_guarded_exprs] result_expr es_expr_heap
convert_guards_to_cases [(let_binds, guard, expr, guard_ident) : rev_guarded_exprs] result_expr es_expr_heap
# (case_expr_ptr, es_expr_heap) = newPtr EI_Empty es_expr_heap
basic_pattern = {bp_value = (BVB True), bp_expr = expr, bp_position = NoPos }
case_expr = Case { case_expr = guard, case_guards = BasicPatterns BT_Bool [basic_pattern],
case_default = result_expr, case_ident = No, case_info_ptr = case_expr_ptr,
case_default_pos = NoPos }
case_default = result_expr, case_ident = Yes guard_ident,
case_info_ptr = case_expr_ptr, case_default_pos = NoPos }
(result_expr, es_expr_heap) = build_sequential_lets let_binds case_expr es_expr_heap
= convert_guards_to_cases rev_guarded_exprs (Yes result_expr) es_expr_heap
......@@ -1890,14 +1890,14 @@ where
check_guarded_expressions free_vars [] let_vars_list rev_guarded_exprs {ei_expr_level} e_state e_info cs
= (let_vars_list, rev_guarded_exprs, ei_expr_level, free_vars, e_state, e_info, cs)
check_guarded_expression free_vars {alt_nodes,alt_guard,alt_expr}
check_guarded_expression free_vars {alt_nodes,alt_guard,alt_expr,alt_ident}
let_vars_list rev_guarded_exprs e_input=:{ei_expr_level,ei_mod_index} e_state e_info cs
# (let_binds, let_vars_list, ei_expr_level, free_vars, e_state, e_info, cs) = check_sequential_lets free_vars alt_nodes let_vars_list
{ e_input & ei_expr_level = inc ei_expr_level } e_state e_info cs
e_input = { e_input & ei_expr_level = ei_expr_level }
(guard, free_vars, e_state, e_info, cs) = checkExpression free_vars alt_guard e_input e_state e_info cs
(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 )
= (let_vars_list, [(let_binds, guard, expr, alt_ident) : 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);
......
frontend/frontend.dcl
View file @ 27472f84
......@@ -22,5 +22,5 @@ import checksupport, transform, overloading
| FrontEndPhaseConvertModules
| FrontEndPhaseAll
frontEndInterface :: !FrontEndPhase !Ident !SearchPaths !*PredefinedSymbols !*HashTable !*Files !*File !*File !*File -> (!*PredefinedSymbols, !*HashTable, !*Files, !*File, !*File, !*File, !Optional *FrontEndSyntaxTree)
// upToPhase name paths predefs files error io out
\ No newline at end of file
frontEndInterface :: !FrontEndPhase !Ident !SearchPaths !Bool !*PredefinedSymbols !*HashTable !*Files !*File !*File !*File -> (!*PredefinedSymbols, !*HashTable, !*Files, !*File, !*File, !*File, !Optional *FrontEndSyntaxTree)
// upToPhase name paths list_inferred_types predefs files error io out
\ No newline at end of file
frontend/frontend.icl
View file @ 27472f84
......@@ -72,8 +72,8 @@ instance == FrontEndPhase where
(==) a b
= equal_constructor a b
frontEndInterface :: !FrontEndPhase !Ident !SearchPaths !*PredefinedSymbols !*HashTable !*Files !*File !*File !*File -> (!*PredefinedSymbols, !*HashTable, !*Files, !*File, !*File, !*File, !Optional *FrontEndSyntaxTree)
frontEndInterface upToPhase mod_ident search_paths predef_symbols hash_table files error io out
frontEndInterface :: !FrontEndPhase !Ident !SearchPaths !Bool !*PredefinedSymbols !*HashTable !*Files !*File !*File !*File -> (!*PredefinedSymbols, !*HashTable, !*Files, !*File, !*File, !*File, !Optional *FrontEndSyntaxTree)
frontEndInterface upToPhase mod_ident search_paths list_inferred_types predef_symbols hash_table files error io out
# (ok, mod, hash_table, error, predef_symbols, files)
= wantModule cWantIclFile mod_ident NoPos (hash_table -*-> ("Parsing:", mod_ident)) error search_paths predef_symbols files
| not ok
......@@ -101,8 +101,9 @@ frontEndInterface upToPhase mod_ident search_paths predef_symbols hash_table fil
= frontSyntaxTree predef_symbols hash_table files error io out icl_mod dcl_mods fun_defs components array_instances
var_heap optional_dcl_icl_conversions global_fun_range
# (ok, fun_defs, array_instances, type_code_instances, common_defs, imported_funs, heaps, predef_symbols, error)
= typeProgram (components -*-> "Typing") fun_defs icl_specials icl_common icl_declared.dcls_import dcl_mods heaps predef_symbols error
# (ok, fun_defs, array_instances, type_code_instances, common_defs, imported_funs, heaps, predef_symbols, error, out)
= typeProgram (components -*-> "Typing") fun_defs icl_specials list_inferred_types icl_common
icl_declared.dcls_import dcl_mods heaps predef_symbols error out
| not ok
= (predef_symbols, hash_table, files, error, io, out, No)
......@@ -227,4 +228,4 @@ where
# (fun_def, fun_defs) = fun_defs![fun]
# properties = { form_properties = cAttributed bitor cAnnotated, form_attr_position = No }
(Yes ftype) = fun_def.fun_type
= show_types funs fun_defs (file <<< fun_def.fun_symb <<< " :: " <:: (properties, ftype) <<< '\n' )
= show_types funs fun_defs (file <<< fun_def.fun_symb <<< " :: " <:: (properties, ftype, No) <<< '\n' )
frontend/main.icl
View file @ 27472f84
......@@ -147,7 +147,7 @@ compileModule mod_name ms
loadModule mod_ident predef_symbols hash_table ms=:{ms_files,ms_error,ms_io,ms_out,ms_paths}
# (predef_symbols, hash_table, ms_files, ms_error, ms_io, ms_out, optional_syntax_tree)
= frontEndInterface FrontEndPhaseAll mod_ident {sp_locations = [], sp_paths = ms_paths} predef_symbols hash_table ms_files ms_error ms_io ms_out
= frontEndInterface FrontEndPhaseAll mod_ident {sp_locations = [], sp_paths = ms_paths} False predef_symbols hash_table ms_files ms_error ms_io ms_out
ms
= {ms & ms_files=ms_files, ms_error=ms_error,ms_io=ms_io,ms_out=ms_out}
= case optional_syntax_tree of
......
frontend/overloading.icl
View file @ 27472f84
......@@ -93,19 +93,24 @@ where
instanceError symbol types err
# err = errorHeading "Overloading error" err
format = { form_properties = cNoProperties, form_attr_position = No }
= { err & ea_file = err.ea_file <<< " \"" <<< symbol <<< "\" no instance available of type " <:: (format, types) <<< '\n' }
// MW4 was: = { err & ea_file = err.ea_file <<< " \"" <<< symbol <<< "\" no instance available of type " <:: (format, types) <<< '\n' }
= { err & ea_file = err.ea_file <<< " \"" <<< symbol <<< "\" no instance available of type "
<:: (format, types, Yes initialTypeVarBeautifulizer) <<< '\n' }
uniqueError symbol types err
# err = errorHeading "Overloading/Uniqueness error" err
format = { form_properties = cAnnotated, form_attr_position = No }
= { err & ea_file = err.ea_file <<< " \"" <<< symbol
<<< "\" uniqueness specification of instance conflicts with current application " <:: (format, types) <<< '\n'}
// MW4 was: <<< "\" uniqueness specification of instance conflicts with current application " <:: (format, types) <<< '\n'}
<<< "\" uniqueness specification of instance conflicts with current application "
<:: (format, types, Yes initialTypeVarBeautifulizer) <<< '\n'}
unboxError type err
# err = errorHeading "Overloading error of Array class" err
format = { form_properties = cNoProperties, form_attr_position = No }
= { err & ea_file = err.ea_file <<< ' ' <:: (format, type) <<< " instance cannot be unboxed\n"}
// MW4 was: = { err & ea_file = err.ea_file <<< ' ' <:: (format, type) <<< " instance cannot be unboxed\n"}
= { err & ea_file = err.ea_file <<< ' ' <:: (format, type, Yes initialTypeVarBeautifulizer) <<< " instance cannot be unboxed\n"}
overloadingError op_symb err
# err = errorHeading "Overloading error" err
......
frontend/parse.icl
View file @ 27472f84
......@@ -115,7 +115,9 @@ stringToIdent ident ident_class pState=:{ps_hash_table}
internalIdent :: !String !*ParseState -> (!Ident, !*ParseState)
internalIdent prefix pState
# ({fp_line,fp_col},pState=:{ps_hash_table}) = getPosition pState
case_string = prefix +++ toString fp_line +++ "_" +++ toString fp_col
// MW4 was: (changed to make it compatible with conventions used in postparse)
// case_string = prefix +++ toString fp_line +++ "_" +++ toString fp_col
case_string = prefix +++ ";" +++ toString fp_line +++ ";" +++ toString fp_col
(case_ident, ps_hash_table) = putIdentInHashTable case_string IC_Expression ps_hash_table
= (case_ident, { pState & ps_hash_table = ps_hash_table } )
......@@ -643,7 +645,8 @@ where
want_FunctionBody :: !Token ![NodeDefWithLocals] ![GuardedExpr] !(Token -> Bool) !ParseState -> (!OptGuardedAlts, !ParseState)
want_FunctionBody BarToken nodeDefs alts sep pState
// # (lets, pState) = want_StrictLet pState // removed from 2.0
# (token, pState) = nextToken FunctionContext pState
# (guard_position, pState) = getPosition pState // MW4++
(token, pState) = nextToken FunctionContext pState
| token == OtherwiseToken
# (token, pState) = nextToken FunctionContext pState
(nodeDefs2, token, pState) = want_LetBefores token pState
......@@ -663,16 +666,25 @@ where
offside = position.fp_col
(expr, pState) = want_FunctionBody token nodeDefs2 [] sep pState
pState = wantEndNestedGuard (default_found expr) offside pState
alt = { alt_nodes = nodeDefs, alt_guard = guard, alt_expr = expr }
// MW4 was: alt = { alt_nodes = nodeDefs, alt_guard = guard, alt_expr = expr }
alt = { alt_nodes = nodeDefs, alt_guard = guard, alt_expr = expr,
alt_ident = guard_ident guard_position.fp_line }
(token, pState) = nextToken FunctionContext pState
(nodeDefs, token, pState) = want_LetBefores token pState
= want_FunctionBody token nodeDefs [alt:alts] sep pState
// otherwise
# (expr, pState) = root_expression True token nodeDefs2 [] sep pState
alt = { alt_nodes = nodeDefs, alt_guard = guard, alt_expr = expr }
// MW4 was: alt = { alt_nodes = nodeDefs, alt_guard = guard, alt_expr = expr }
alt = { alt_nodes = nodeDefs, alt_guard = guard, alt_expr = expr,
alt_ident = guard_ident guard_position.fp_line }
(token, pState) = nextToken FunctionContext pState
(nodeDefs, token, pState) = want_LetBefores token pState
= want_FunctionBody token nodeDefs [alt:alts] sep pState
// MW4..
where
guard_ident line_nr
= { id_name = "_g;" +++ toString line_nr +++ ";", id_info = nilPtr }
// ..MW4
want_FunctionBody token nodeDefs alts sep pState
= root_expression localsExpected token nodeDefs (reverse alts) sep pState
......
frontend/postparse.icl
View file @ 27472f84
......@@ -565,14 +565,17 @@ makeComprehensions [{tq_generators, tq_filter, tq_end, tq_call, tq_lhs_args, tq_
failure
= continue
rhs
= build_rhs generators success optional_filter failure end
// MW4 was: = build_rhs generators success optional_filter failure end
= build_rhs generators success optional_filter failure end fun_pos
parsed_def
// MW3 was: = MakeNewParsedDef fun_ident lhsArgs rhs
= MakeNewParsedDef fun_ident lhsArgs rhs fun_pos
= (PE_Let cIsStrict (LocalParsedDefs [parsed_def]) call_comprehension, ca)
build_rhs :: [TransformedGenerator] ParsedExpr (Optional ParsedExpr) ParsedExpr ParsedExpr -> Rhs
build_rhs [generator : generators] success optional_filter failure end
// MW4 was: build_rhs :: [TransformedGenerator] ParsedExpr (Optional ParsedExpr) ParsedExpr ParsedExpr -> Rhs
build_rhs :: [TransformedGenerator] ParsedExpr (Optional ParsedExpr) ParsedExpr ParsedExpr Position -> Rhs
// MW4 was: build_rhs [generator : generators] success optional_filter failure end
build_rhs [generator : generators] success optional_filter failure end fun_pos
= case_with_default generator.tg_case1 generator.tg_case_end_expr generator.tg_case_end_pattern
(foldr (case_end end)
(case_with_default generator.tg_case2 generator.tg_element generator.tg_pattern
......@@ -585,9 +588,12 @@ makeComprehensions [{tq_generators, tq_filter, tq_end, tq_call, tq_lhs_args, tq_
Yes filter
-> optGuardedAltToRhs (GuardedAlts [
{alt_nodes = [], alt_guard = filter, alt_expr = UnGuardedExpr
{ewl_nodes = [], ewl_expr = success, ewl_locals = LocalParsedDefs []}}] No)
// MW4 was: {ewl_nodes = [], ewl_expr = success, ewl_locals = LocalParsedDefs []}}] No)
{ewl_nodes = [], ewl_expr = success, ewl_locals = LocalParsedDefs []},
alt_ident = { id_name ="_f;" +++ toString line_nr +++ ";", id_info = nilPtr }}] No)
No
-> exprToRhs success
(LinePos _ line_nr) = fun_pos
/* +++ remove code duplication (bug in 2.0 with nested cases)
case_end :: TransformedGenerator Rhs -> Rhs
......
frontend/syntax.dcl
View file @ 27472f84
......@@ -55,7 +55,7 @@ instance toString Ident
| STE_DictCons !ConsDef
| STE_DictField !SelectorDef
| STE_Called ![Index] /* used during macro expansion to indicate that this function is called */
:: Global object =
{ glob_object :: !object
, glob_module :: !Index
......@@ -876,6 +876,7 @@ cNonRecursiveAppl :== False
{ alt_nodes :: ![NodeDefWithLocals]
, alt_guard :: !ParsedExpr
, alt_expr :: !OptGuardedAlts
, alt_ident :: !Ident
}
:: ExprWithLocalDefs =
......@@ -1126,7 +1127,7 @@ cIsNotStrict :== False
:: CoercionPosition
= CP_Expression !Expression
| CP_FunArg !Ident !Int // Function symbol, argument position (>=1)
:: IdentPos =
{ ip_ident :: !Ident
, ip_line :: !Int
......@@ -1148,7 +1149,7 @@ instance <<< (Module a) | <<< a, ParsedDefinition, InstanceType, AttributeVar, T
Position, CaseAlt, AType, FunDef, ParsedExpr, TypeAttribute, (Bind a b) | <<< a & <<< b, ParsedConstructor, (TypeDef a) | <<< a, TypeVarInfo,
BasicValue, ATypeVar, TypeRhs, FunctionPattern, (Import from_symbol) | <<< from_symbol, ImportDeclaration, ImportedIdent, CasePatterns,
(Optional a) | <<< a, ConsVariable, BasicType, Annotation, Selection, SelectorDef, ConsDef, LocalDefs, FreeVar, ClassInstance, SignClassification,
TypeCodeExpression
TypeCodeExpression, CoercionPosition
instance == TypeAttribute
instance == Annotation
......
frontend/syntax.icl
View file @ 27472f84
......@@ -840,6 +840,7 @@ cNotVarNumber :== -1
{ alt_nodes :: ![NodeDefWithLocals]
, alt_guard :: !ParsedExpr
, alt_expr :: !OptGuardedAlts
, alt_ident :: !Ident
}
:: ExprWithLocalDefs =
......@@ -1762,6 +1763,44 @@ where
(<<<) file (ID_Record ident optIdents) = file <<< ident <<< " { " <<< optIdents <<< " } "
(<<<) file (ID_Instance i1 i2 tup) = file <<< "instance " <<< i1 <<< i2 <<< tup // !ImportedIdent !Ident !(![Type],![TypeContext])
instance <<< CoercionPosition
where
(<<<) file (CP_FunArg fun_name arg_nr) = file <<< "argument " <<< arg_nr <<< " of " <<< readable fun_name
(<<<) file (CP_Expression expression) = show_expression file expression
where
show_expression file (Var {var_name})
= file <<< var_name
show_expression file (FreeVar {fv_name})
= file <<< fv_name
show_expression file (App {app_symb={symb_name}, app_args})
| symb_name.id_name=="_dummyForStrictAlias"
= show_expression file (hd app_args)
= file <<< readable symb_name
show_expression file (fun @ fun_args)
= show_expression file fun
show_expression file (Case {case_ident=No})
= file <<< "(case ... )"
show_expression file (Selection _ expr selectors)
= file <<< "selection"
show_expression file (Update expr1 selectors expr2)
= file <<< "update"
show_expression file (TupleSelect {ds_arity} elem_nr expr)
= file <<< "argument" <<< (elem_nr + 1) <<< " of " <<< ds_arity <<< "-tuple"
show_expression file (BasicExpr bv _)
= file <<< bv
show_expression file (MatchExpr _ _ expr)
= file <<< "match expression"
show_expression file _
= file
readable :: !Ident -> String // somewhat hacky
readable {id_name}
| id_name=="_cons" || id_name=="_nil"
= "list constructor"
| id_name % (0,5) == "_tuple"
= "tuple"
= id_name
instance <<< ImportedIdent
where
(<<<) file {ii_ident, ii_extended} = file <<< ii_ident <<< ' ' <<< ii_extended
......
frontend/type.dcl
View file @ 27472f84
......@@ -3,6 +3,9 @@ definition module type
import StdArray
import syntax, check
/* MW4 was:
typeProgram ::!{! Group} !*{# FunDef} !IndexRange !CommonDefs ![Declaration] !{# DclModule} !*Heaps !*PredefinedSymbols !*File
-> (!Bool, !*{# FunDef}, !IndexRange, {! GlobalTCType}, !{# CommonDefs}, !{# {# FunType} }, !*Heaps, !*PredefinedSymbols, !*File)
*/
typeProgram ::!{! Group} !*{# FunDef} !IndexRange !Bool !CommonDefs ![Declaration] !{# DclModule} !*Heaps !*PredefinedSymbols !*File !*File
-> (!Bool, !*{# FunDef}, !IndexRange, {! GlobalTCType}, !{# CommonDefs}, !{# {# FunType} }, !*Heaps, !*PredefinedSymbols, !*File, !*File)
frontend/type.icl
View file @ 27472f84
......@@ -19,6 +19,7 @@ import RWSDebug
, ts_expr_heap :: !.ExpressionHeap
, ts_td_infos :: !.TypeDefInfos
, ts_error :: !.ErrorAdmin
, ts_out :: !.File // MW4++
}
:: TypeCoercion =
......@@ -167,12 +168,84 @@ where
contains_var var_id _
= False
type_error =: "Type error" // MW4++
type_error_format =: { form_properties = cNoProperties, form_attr_position = No } // MW4++
/* MW4 was:
cannotUnify t1 t2 position err
# err = errorHeading "Type error" err
format = { form_properties = cNoProperties, form_attr_position = No }
= { err & ea_file = err.ea_file <<< optionalFrontPosition position <<< " cannot unify " <:: (format, t1)
<<< " with " <:: (format, t2) <<< position <<< '\n' }
*/
cannotUnify t1 t2 position=:(CP_Expression expr) err=:{ea_loc=[ip:_]}
= case tryToOptimizePosition expr ip of
Yes ident_pos
# err = pushErrorAdmin ident_pos err
err = errorHeading type_error err
err = popErrorAdmin err
-> { err & ea_file = err.ea_file <<< " cannot unify " <:: (type_error_format, t1, Yes initialTypeVarBeautifulizer)
<<< " with " <:: (type_error_format, t2, Yes initialTypeVarBeautifulizer) <<< '\n' }
_
-> cannot_unify t1 t2 position err
cannotUnify t1 t2 position err
= cannot_unify t1 t2 position err
cannot_unify t1 t2 position err
# (err=:{ea_file}) = errorHeading type_error err
ea_file = case position of
CP_FunArg _ _
-> ea_file <<< "\"" <<< position <<< "\""
_
-> ea_file
ea_file = ea_file <<< " cannot unify " <:: (type_error_format, t1, Yes initialTypeVarBeautifulizer)
<<< " with " <:: (type_error_format, t2, Yes initialTypeVarBeautifulizer)
ea_file = case position of
CP_FunArg _ _
-> ea_file
_
-> ea_file <<< " near " <<< position
= { err & ea_file = ea_file <<< '\n' }
// MW4..
tryToOptimizePosition (Case {case_ident=Yes {id_name}}) ip
= tryToOptimizePositionFromString id_name ip
tryToOptimizePosition (App {app_symb={symb_name}}) ip
= tryToOptimizePositionFromString symb_name.id_name ip
tryToOptimizePosition (fun @ _) ip
= tryToOptimizePosition fun ip
tryToOptimizePositionFromString id_name ip
# fst_semicolon_index = searchlArrElt ((==) ';') id_name 0
| fst_semicolon_index < size id_name
# snd_semicolon_index = searchlArrElt ((==) ';') id_name (fst_semicolon_index+1)
prefix = id_name % (0, fst_semicolon_index-1)
line = toInt (id_name % (fst_semicolon_index+1, snd_semicolon_index-1))
= Yes { ip & ip_ident = { id_name = prefix_to_readable_name prefix, id_info = nilPtr }, ip_line = line }
= No
where
prefix_to_readable_name "_c" = "case"
prefix_to_readable_name "_g" = "guard"
prefix_to_readable_name "_f" = "filter"
prefix_to_readable_name prefix
| prefix.[0] == 'c'
= "comprehension"
| prefix.[0] == 'g'
= "generator"
prefix_to_readable_name _ = abort "fatal error 21 in type.icl"
// search for an element in an array
searchlArrElt p s i
:== searchl s i
where
searchl s i
| i>=size s
= i
| p s.[i]
= i
= searchl s (i+1)
// ..MW4
class unify a :: !a !a !TypeInput !*{! Type} !*TypeHeaps -> (!Bool, !*{! Type}, !*TypeHeaps)
......@@ -1438,18 +1511,24 @@ where
specification_error type err
# err = errorHeading "Type error" err
format = { form_properties = cAttributed, form_attr_position = No}
= { err & ea_file = err.ea_file <<< " specified type conflicts with derived type " <:: (format, type) <<< '\n' }
// MW4 was: = { err & ea_file = err.ea_file <<< " specified type conflicts with derived type " <:: (format, type) <<< '\n' }
= { err & ea_file = err.ea_file <<< " specified type conflicts with derived type "
<:: (format, type, Yes initialTypeVarBeautifulizer) <<< '\n' }
cleanUpAndCheckFunctionTypes [] _ _ start_index defs type_contexts coercion_env attr_partition type_var_env attr_var_env (fun_defs, ts)
// MW4 was:cleanUpAndCheckFunctionTypes [] _ _ start_index defs type_contexts coercion_env attr_partition type_var_env attr_var_env (fun_defs, ts)
cleanUpAndCheckFunctionTypes [] _ _ start_index _ defs type_contexts coercion_env attr_partition type_var_env attr_var_env (fun_defs, ts)
= (fun_defs, ts)
cleanUpAndCheckFunctionTypes [fun : funs] [ {fe_requirements = {req_case_and_let_exprs}} : reqs] dict_types start_index defs type_contexts coercion_env
// MW4 was:cleanUpAndCheckFunctionTypes [fun : funs] [ {fe_requirements = {req_case_and_let_exprs}} : reqs] dict_types start_index defs type_contexts coercion_env
cleanUpAndCheckFunctionTypes [fun : funs] [ {fe_requirements = {req_case_and_let_exprs}} : reqs] dict_types start_index list_inferred_types defs type_contexts coercion_env
attr_partition type_var_env attr_var_env (fun_defs, ts)
# (fd, fun_defs) = fun_defs![fun]
dict_ptrs = get_dict_ptrs fun dict_types
(type_var_env, attr_var_env, ts) = clean_up_and_check_function_type fd fun (start_index == fun) defs type_contexts
// MW4 was: (type_var_env, attr_var_env, ts) = clean_up_and_check_function_type fd fun (start_index == fun) defs type_contexts
(type_var_env, attr_var_env, ts) = clean_up_and_check_function_type fd fun (start_index == fun) list_inferred_types defs type_contexts
(dict_ptrs ++ req_case_and_let_exprs) coercion_env attr_partition type_var_env attr_var_env ts
= cleanUpAndCheckFunctionTypes funs reqs dict_types start_index defs type_contexts coercion_env attr_partition type_var_env attr_var_env (fun_defs, ts)
// MW4 was: = cleanUpAndCheckFunctionTypes funs reqs dict_types start_index defs type_contexts coercion_env attr_partition type_var_env attr_var_env (fun_defs, ts)
= cleanUpAndCheckFunctionTypes funs reqs dict_types start_index list_inferred_types defs type_contexts coercion_env attr_partition type_var_env attr_var_env (fun_defs, ts)
where
get_dict_ptrs fun_index []
= []
......@@ -1458,7 +1537,8 @@ where
= ptrs
= get_dict_ptrs fun_index dict_types
clean_up_and_check_function_type {fun_symb,fun_pos,fun_type = opt_fun_type} fun is_start_rule defs type_contexts type_ptrs
// MW4 was: clean_up_and_check_function_type {fun_symb,fun_pos,fun_type = opt_fun_type} fun is_start_rule defs type_contexts type_ptrs
clean_up_and_check_function_type {fun_symb,fun_pos,fun_type = opt_fun_type} fun is_start_rule list_inferred_types defs type_contexts type_ptrs
coercion_env attr_partition type_var_env attr_var_env ts
# (env_type, ts) = ts!ts_fun_env.[fun]
# ts = { ts & ts_error = setErrorAdmin (newPosition fun_symb fun_pos) ts.ts_error}
......@@ -1476,11 +1556,22 @@ where
# (clean_fun_type, type_var_env, attr_var_env, ts_type_heaps, ts_var_heap, ts_expr_heap, ts_error)
= cleanUpSymbolType is_start_rule cDerivedType exp_fun_type type_contexts type_ptrs coercion_env
attr_partition type_var_env attr_var_env ts.ts_type_heaps ts.ts_var_heap ts.ts_expr_heap ts.ts_error
// MW4..
ts_out = ts.ts_out
ts_out = case list_inferred_types of
False
-> ts_out
_
# form = { form_properties = cNoProperties, form_attr_position = No }
-> ts_out <<< fun_symb <<< " :: "
<:: (form, clean_fun_type, Yes initialTypeVarBeautifulizer) <<< '\n'
// ..MW4
ts_fun_env = { ts.ts_fun_env & [fun] = CheckedType clean_fun_type }
-> (type_var_env, attr_var_env, { ts & ts_type_heaps = ts_type_heaps, ts_var_heap = ts_var_heap, ts_expr_heap = ts_expr_heap, ts_fun_env = ts_fun_env, ts_error = ts_error })
// MW4 was: -> (type_var_env, attr_var_env, { ts & ts_type_heaps = ts_type_heaps, ts_var_heap = ts_var_heap, ts_expr_heap = ts_expr_heap, ts_fun_env = ts_fun_env, ts_error = ts_error })
-> (type_var_env, attr_var_env, { ts & ts_type_heaps = ts_type_heaps, ts_var_heap = ts_var_heap, ts_expr_heap = ts_expr_heap, ts_fun_env = ts_fun_env, ts_error = ts_error, ts_out = ts_out })
check_function_type fun_type tmp_fun_type=:{tst_lifted} clean_fun_type=:{st_arity, st_args, st_vars, st_attr_vars, st_context} type_ptrs
defs fun_env attr_var_env type_heaps expr_heap error
defs fun_env attr_var_env type_heaps expr_heap error
# (equi, attr_var_env, type_heaps) = equivalent clean_fun_type tmp_fun_type (length fun_type.st_context) defs attr_var_env type_heaps
| equi
# type_with_lifted_arg_types = addLiftedArgumentsToSymbolType fun_type tst_lifted st_args st_vars st_attr_vars st_context
......@@ -1507,12 +1598,14 @@ addLiftedArgumentsToSymbolType st=:{st_arity,st_args,st_vars,st_attr_vars,st_con
, fe_location :: !IdentPos
}
typeProgram ::!{! Group} !*{# FunDef} !IndexRange !CommonDefs ![Declaration] !{# DclModule} !*Heaps !*PredefinedSymbols !*File
-> (!Bool, !*{# FunDef}, !IndexRange, {! GlobalTCType}, !{# CommonDefs}, !{# {# FunType} }, !*Heaps, !*PredefinedSymbols, !*File)
typeProgram comps fun_defs specials icl_defs imports modules {hp_var_heap, hp_expression_heap, hp_type_heaps} predef_symbols file
// MW4 was:typeProgram ::!{! Group} !*{# FunDef} !IndexRange !CommonDefs ![Declaration] !{# DclModule} !*Heaps !*PredefinedSymbols !*File
typeProgram ::!{! Group} !*{# FunDef} !IndexRange !Bool !CommonDefs ![Declaration] !{# DclModule} !*Heaps !*PredefinedSymbols !*File !*File
// MW4 was: -> (!Bool, !*{# FunDef}, !IndexRange, {! GlobalTCType}, !{# CommonDefs}, !{# {# FunType} }, !*Heaps, !*PredefinedSymbols, !*File)
-> (!Bool, !*{# FunDef}, !IndexRange, {! GlobalTCType}, !{# CommonDefs}, !{# {# FunType} }, !*Heaps, !*PredefinedSymbols, !*File, !*File)
// MW4 was:typeProgram comps fun_defs specials icl_defs imports modules {hp_var_heap, hp_expression_heap, hp_type_heaps} predef_symbols file
typeProgram comps fun_defs specials list_inferred_types icl_defs imports modules {hp_var_heap, hp_expression_heap, hp_type_heaps} predef_symbols file out
#! fun_env_size = size fun_defs
# ts_error = {ea_file = file, ea_loc = [], ea_ok = True }
ti_common_defs = {{dcl_common \\ {dcl_common} <-: modules } & [cIclModIndex] = icl_defs }
ti_functions = {dcl_functions \\ {dcl_functions} <-: modules }
......@@ -1526,19 +1619,24 @@ typeProgram comps fun_defs specials icl_defs imports modules {hp_var_heap, hp_ex
(_, ts_error, class_instances, th_vars, td_infos) = collect_and_check_instances (size icl_defs.com_instance_defs) ti_common_defs state
ts = { ts_fun_env = InitFunEnv fun_env_size, ts_var_heap = hp_var_heap, ts_expr_heap = hp_expression_heap, ts_var_store = 0, ts_attr_store = FirstAttrVar,
ts_type_heaps = { hp_type_heaps & th_vars = th_vars }, ts_td_infos = td_infos, ts_error = ts_error }
// MW4 was: ts_type_heaps = { hp_type_heaps & th_vars = th_vars }, ts_td_infos = td_infos, ts_error = ts_error }
ts_type_heaps = { hp_type_heaps & th_vars = th_vars }, ts_td_infos = td_infos, ts_error = ts_error, ts_out = out }
ti = { ti_common_defs = ti_common_defs, ti_functions = ti_functions }
special_instances = { si_next_array_member_index = fun_env_size, si_array_instances = [], si_next_TC_member_index = 0, si_TC_instances = [] }
# (type_error, fun_defs, predef_symbols, special_instances, ts) = type_components 0 comps class_instances ti (False, fun_defs, predef_symbols, special_instances, ts)
// MW4 was: # (type_error, fun_defs, predef_symbols, special_instances, ts) = type_components 0 comps class_instances ti (False, fun_defs, predef_symbols, special_instances, ts)
# (type_error, fun_defs, predef_symbols, special_instances, ts) = type_components list_inferred_types 0 comps class_instances ti (False, fun_defs, predef_symbols, special_instances, ts)
(fun_defs,ts_fun_env) = update_function_types 0 comps ts.ts_fun_env fun_defs
(type_error, fun_defs, predef_symbols, special_instances, {ts_fun_env,ts_error,ts_var_heap, ts_expr_heap, ts_type_heaps})
= type_instances specials.ir_from specials.ir_to class_instances ti (type_error, fun_defs, predef_symbols, special_instances,
{ ts & ts_fun_env = ts_fun_env })
// MW4 was: (type_error, fun_defs, predef_symbols, special_instances, {ts_fun_env,ts_error,ts_var_heap, ts_expr_heap, ts_type_heaps})
(type_error, fun_defs, predef_symbols, special_instances, {ts_fun_env,ts_error,ts_var_heap, ts_expr_heap, ts_type_heaps, ts_out})
// MW4 was: = type_instances specials.ir_from specials.ir_to class_instances ti (type_error, fun_defs, predef_symbols, special_instances,
= type_instances list_inferred_types specials.ir_from specials.ir_to class_instances ti (type_error, fun_defs, predef_symbols, special_instances,
{ ts & ts_fun_env = ts_fun_env })
{si_array_instances, si_next_array_member_index, si_next_TC_member_index, si_TC_instances}= special_instances
(fun_defs, predef_symbols, ts_type_heaps) = convert_array_instances si_array_instances ti_common_defs fun_defs predef_symbols ts_type_heaps
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)
// MW4 was: {hp_var_heap = ts_var_heap, hp_expression_heap = ts_expr_heap, hp_type_heaps = ts_type_heaps }, predef_symbols, ts_error.ea_file)
{hp_var_heap = ts_var_heap, hp_expression_heap = ts_expr_heap, hp_type_heaps = ts_type_heaps }, predef_symbols, ts_error.ea_file, ts_out)
// ---> ("typeProgram", array_inst_types)
where
collect_imported_instances imports common_defs dummy error class_instances type_var_heap td_infos
......@@ -1611,18 +1709,24 @@ where
= (error, IT_Node ins it_less it_greater)
= (checkError ins_types " instance is overlapping" error, IT_Node ins it_less it_greater)
type_instances ir_from ir_to class_instances ti funs_and_state
// MW4 was: type_instances ir_from ir_to class_instances ti funs_and_state