Commit 8e02a38c authored by John van Groningen's avatar John van Groningen
Browse files

report error for constructors or records with >32 arguments/fields

parent b623b4b0
......@@ -146,6 +146,7 @@ newPosition :: !Ident !Position -> IdentPos
checkError :: !a !b !*ErrorAdmin -> *ErrorAdmin | <<< a & <<< b
checkWarning :: !a !b !*ErrorAdmin -> *ErrorAdmin | <<< a & <<< b
checkErrorWithIdentPos :: !IdentPos !a !*ErrorAdmin -> .ErrorAdmin | <<< a;
checkErrorWithPosition :: !Ident !Position !a !*ErrorAdmin -> .ErrorAdmin | <<< a;
checkWarningWithPosition :: !Ident !Position !a !*ErrorAdmin -> .ErrorAdmin | <<< a;
class envLookUp a :: !a !(Env Ident .b) -> (!Bool,.b)
......
......@@ -71,6 +71,11 @@ checkErrorWithIdentPos :: !IdentPos !a !*ErrorAdmin -> .ErrorAdmin | <<< a;
checkErrorWithIdentPos ident_pos mess error=:{ea_file}
= { error & ea_file = ea_file <<< "Error " <<< ident_pos <<< ": " <<< mess <<< '\n', ea_ok = False }
checkErrorWithPosition :: !Ident !Position !a !*ErrorAdmin -> .ErrorAdmin | <<< a;
checkErrorWithPosition ident pos mess error=:{ea_file}
# ident_pos = newPosition ident pos
= { error & ea_file = ea_file <<< "Error " <<< ident_pos <<< ": " <<< mess <<< '\n', ea_ok = False }
checkWarningWithPosition :: !Ident !Position !a !*ErrorAdmin -> .ErrorAdmin | <<< a;
checkWarningWithPosition ident pos mess error=:{ea_file}
# ident_pos = newPosition ident pos
......
......@@ -232,13 +232,15 @@ where
[{at_attribute = atv_attribute,at_type = TV atv_variable} \\ {atv_variable, atv_attribute} <- td_args]}
ts_ti_cs = bind_types_of_constructors cti 0 [ atv_variable \\ {atv_variable} <- td_args] attr_vars type_lhs conses ts_ti_cs
= (td_rhs, ts_ti_cs)
check_rhs_of_TypeDef {td_ident,td_arity,td_args,td_rhs = td_rhs=:RecordType {rt_constructor=rec_cons=:{ds_index}, rt_fields}}
attr_vars cti=:{cti_module_index,cti_type_index,cti_lhs_attribute} ts_ti_cs
check_rhs_of_TypeDef {td_ident,td_arity,td_args,td_rhs = td_rhs=:RecordType {rt_constructor=rec_cons=:{ds_index,ds_arity}, rt_fields}}
attr_vars cti=:{cti_module_index,cti_type_index,cti_lhs_attribute} (ts,ti,cs)
# type_lhs = { at_attribute = cti_lhs_attribute,
at_type = TA (MakeTypeSymbIdent { glob_object = cti_type_index, glob_module = cti_module_index } td_ident td_arity)
[{ at_attribute = atv_attribute,at_type = TV atv_variable} \\ {atv_variable, atv_attribute} <- td_args]}
(ts, ti, cs) = bind_types_of_constructors cti 0 [ atv_variable \\ {atv_variable} <- td_args]
attr_vars type_lhs [rec_cons] ts_ti_cs
cs = if (ds_arity>32)
{ cs & cs_error = checkError ("Record has too many fields ("+++toString ds_arity+++",") "32 are allowed)" cs.cs_error }
cs;
(ts, ti, cs) = bind_types_of_constructor cti 0 [ atv_variable \\ {atv_variable} <- td_args] attr_vars type_lhs rec_cons (ts,ti,cs)
# (rec_cons_def, ts) = ts!ts_cons_defs.[ds_index]
# {cons_type = { st_vars,st_args,st_result,st_attr_vars }, cons_exi_vars} = rec_cons_def
# (ts_selector_defs, ti_var_heap, cs_error) = check_selectors 0 rt_fields cti_type_index st_args st_result st_vars st_attr_vars cons_exi_vars
......@@ -285,26 +287,32 @@ where
= (td_rhs, ts_ti_cs)
bind_types_of_constructors :: !CurrentTypeInfo !Index ![TypeVar] ![AttributeVar] !AType ![DefinedSymbol] !(!*TypeSymbols,!*TypeInfo,!*CheckState)
-> (!*TypeSymbols, !*TypeInfo, !*CheckState)
-> (!*TypeSymbols, !*TypeInfo, !*CheckState)
bind_types_of_constructors cti cons_index free_vars free_attrs type_lhs [cons=:{ds_arity,ds_ident,ds_index}:conses] (ts,ti,cs)
# (ts,cs) = if (ds_arity>32)
(let (cons_pos,ts2) = ts!ts_cons_defs.[ds_index].cons_pos
in (ts2,{ cs & cs_error = checkErrorWithPosition ds_ident cons_pos ("Constructor has too many arguments ("+++toString ds_arity+++", 32 are allowed)") cs.cs_error }))
(ts,cs);
# ts_ti_cs = bind_types_of_constructor cti cons_index free_vars free_attrs type_lhs cons (ts,ti,cs)
= bind_types_of_constructors cti (inc cons_index) free_vars free_attrs type_lhs conses ts_ti_cs
bind_types_of_constructors _ _ _ _ _ [] ts_ti_cs
= ts_ti_cs
bind_types_of_constructors cti=:{cti_lhs_attribute} cons_index free_vars free_attrs type_lhs [{ds_index}:conses] (ts=:{ts_cons_defs}, ti=:{ti_type_heaps}, cs)
# (cons_def, ts_cons_defs) = ts_cons_defs![ds_index]
bind_types_of_constructor :: !CurrentTypeInfo !Index ![TypeVar] ![AttributeVar] !AType !DefinedSymbol !(!*TypeSymbols,!*TypeInfo,!*CheckState)
-> (!*TypeSymbols, !*TypeInfo, !*CheckState)
bind_types_of_constructor cti=:{cti_lhs_attribute} cons_index free_vars free_attrs type_lhs {ds_index} (ts, ti=:{ti_type_heaps}, cs)
# (cons_def, ts) = ts!ts_cons_defs.[ds_index]
# (exi_vars, (ti_type_heaps, cs))
= addExistentionalTypeVariablesToSymbolTable cti_lhs_attribute cons_def.cons_exi_vars ti_type_heaps cs
(st_args, cons_arg_vars, st_attr_env, (ts, ti, cs))
= bind_types_of_cons cons_def.cons_type.st_args cti free_vars []
({ ts & ts_cons_defs = ts_cons_defs }, { ti & ti_type_heaps = ti_type_heaps }, cs)
= bind_types_of_cons cons_def.cons_type.st_args cti free_vars [] (ts, { ti & ti_type_heaps = ti_type_heaps }, cs)
cs_symbol_table = removeAttributedTypeVarsFromSymbolTable cGlobalScope /* cOuterMostLevel */ exi_vars cs.cs_symbol_table
(ts, ti, cs) = bind_types_of_constructors cti (inc cons_index) free_vars free_attrs type_lhs conses
(ts, ti, { cs & cs_symbol_table = cs_symbol_table })
attr_vars = add_universal_attr_vars st_args free_attrs
cons_type = { cons_def.cons_type & st_vars = free_vars, st_args = st_args, st_result = type_lhs, st_attr_vars = attr_vars, st_attr_env = st_attr_env }
(new_type_ptr, ti_var_heap) = newPtr VI_Empty ti.ti_var_heap
= ({ ts & ts_cons_defs = { ts.ts_cons_defs & [ds_index] =
{ cons_def & cons_type = cons_type, cons_index = cons_index, cons_type_index = cti.cti_type_index, cons_exi_vars = exi_vars,
cons_type_ptr = new_type_ptr, cons_arg_vars = cons_arg_vars }}}, { ti & ti_var_heap = ti_var_heap }, cs)
// ---> ("bind_types_of_constructors", cons_def.cons_ident, exi_vars, cons_type)
cons_def = { cons_def & cons_type = cons_type, cons_index = cons_index, cons_type_index = cti.cti_type_index, cons_exi_vars = exi_vars,
cons_type_ptr = new_type_ptr, cons_arg_vars = cons_arg_vars }
= ({ ts & ts_cons_defs.[ds_index] = cons_def}, { ti & ti_var_heap = ti_var_heap }, cs)
where
bind_types_of_cons :: ![AType] !CurrentTypeInfo ![TypeVar] ![AttrInequality] !(!*TypeSymbols, !*TypeInfo, !*CheckState)
-> (![AType], ![[ATypeVar]], ![AttrInequality], !(!*TypeSymbols, !*TypeInfo, !*CheckState))
......
Markdown is supported
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