Commit fddc9775 authored by Martin Wierich's avatar Martin Wierich
Browse files

- implemented comparison between redundant definitions in icl and dcl modules

    (new module: comparedefimp)
- implemented array patterns. Further work: arrays are in lazy context (should be strict),
    currently only one dimensional arrays
- optimised memory usage for explicit imports
parent 579aa151
......@@ -13,7 +13,8 @@ instance =< Int, Expression, {# Char}, Ident, [a] | =< a, BasicType //, Global a
instance =< Type
instance == BasicType, TypeVar, TypeSymbIdent, DefinedSymbol, TypeContext , BasicValue, FunKind, Global a | == a
instance == BasicType, TypeVar, TypeSymbIdent, DefinedSymbol, TypeContext , BasicValue,
FunKind, Global a | == a, Priority, Assoc
export == Int
......
......@@ -70,8 +70,6 @@ where
= tc1 == tc2 && types1 == types2
equal_constructor_args (TB tb1) (TB tb2)
= tb1 == tb2
equal_constructor_args (TA tc1 types1) (TA tc2 types2)
= tc1 == tc2 && types1 == types2
equal_constructor_args (type1 :@: types1) (type2 :@: types2)
= type1 == type2 && types1 == types2
equal_constructor_args (TQV varid1) (TQV varid2)
......@@ -79,6 +77,15 @@ where
equal_constructor_args type1 type2
= True
instance == Priority
where
(==) NoPrio NoPrio = True
(==) (Prio assoc1 prio1) (Prio assoc2 prio2) = assoc1==assoc2 && prio1==prio2
instance == Assoc
where
(==) a1 a2 = equal_constructor a1 a2
:: CompareValue :== Int
Smaller :== -1
Greater :== 1
......
......@@ -2,8 +2,6 @@ definition module check
import syntax, transform, checksupport, typesupport, predef
//MOVE
//cIclModIndex :== 0
cPredefinedModuleIndex :== 1
checkModule :: !ScannedModule !Int ![FunDef] !ScannedModule !ScannedModule ![ScannedModule] !*PredefinedSymbols !*SymbolTable !*File
......
This diff is collapsed.
......@@ -120,8 +120,7 @@ instance toIdent ConsDef, TypeDef a, ClassDef, MemberDef, FunDef, SelectorDef //
instance toIdent SymbIdent, TypeSymbIdent, BoundVar, TypeVar, ATypeVar, Ident
instance toInt STE_Kind
instance <<< STE_Kind
instance <<< IdentPos
instance <<< STE_Kind, IdentPos, Declaration
retrieveAndRemoveImportsFromSymbolTable :: ![(.a,.Declarations)] [Declaration] *(Heap SymbolTableEntry) -> ([Declaration],.Heap SymbolTableEntry);
retrieveAndRemoveImportsOfModuleFromSymbolTable :: ![.Declaration] ![.Declaration] ![.Declaration] !*(Heap SymbolTableEntry) -> ([Declaration],.Heap SymbolTableEntry);
......
......@@ -527,4 +527,8 @@ where
STE_Empty
= file <<< "STE_Empty"
instance <<< Declaration
where
(<<<) file { dcl_ident }
= file <<< dcl_ident
......@@ -256,7 +256,7 @@ CS_Checking :== 0
}
class expand a :: !Index !a !*SynTypeInfo !*CheckState -> (!a, !TypeAttribute, !*SynTypeInfo, !*CheckState)
class expand a :: !Index !a !*SynTypeInfo !*CheckState -> (!a, !*SynTypeInfo, !*CheckState)
expandTypeVariable :: TypeVar !*SynTypeInfo !*CheckState -> (!Type, !TypeAttribute, !*SynTypeInfo, !*CheckState)
expandTypeVariable {tv_name={id_info}} sti cs=:{cs_symbol_table}
......@@ -267,29 +267,30 @@ expandTypeVariable {tv_name={id_info}} sti cs=:{cs_symbol_table}
instance expand Type
where
expand module_index (TV tv) sti cs
= expandTypeVariable tv sti cs
# (type, _, sti, cs) = expandTypeVariable tv sti cs
= (type, sti, cs)
expand module_index type=:(TA type_cons=:{type_name,type_index={glob_object,glob_module}} types) sti=:{sti_marks} cs=:{cs_error,cs_symbol_table}
| module_index == glob_module
#! mark = sti_marks.[glob_object]
| mark == CS_NotChecked
# (sti, cs) = expandSynType module_index glob_object sti cs
(types, attr, sti, cs) = expand module_index types sti cs
= (TA type_cons types, attr, sti, cs)
(types, sti, cs) = expand module_index types sti cs
= (TA type_cons types, sti, cs)
| mark == CS_Checked
# (types, attr, sti, cs) = expand module_index types sti cs
= (TA type_cons types, attr, sti, cs)
# (types, sti, cs) = expand module_index types sti cs
= (TA type_cons types, sti, cs)
// | mark == CS_Checking
= (type, TA_None, sti, { cs & cs_error = checkError type_name "cyclic dependency between type synonyms" cs_error })
# (types, attr, sti, cs) = expand module_index types sti cs
= (TA type_cons types, attr, sti, cs)
= (type, sti, { cs & cs_error = checkError type_name "cyclic dependency between type synonyms" cs_error })
# (types, sti, cs) = expand module_index types sti cs
= (TA type_cons types, sti, cs)
expand module_index (arg_type --> res_type) sti cs
# (arg_type, _, sti, cs) = expand module_index arg_type sti cs
(res_type, _, sti, cs) = expand module_index res_type sti cs
= (arg_type --> res_type, TA_None, sti, cs)
# (arg_type, sti, cs) = expand module_index arg_type sti cs
(res_type, sti, cs) = expand module_index res_type sti cs
= (arg_type --> res_type, sti, cs)
expand module_index (CV tv :@: types) sti cs
# (type, type_attr, sti, cs) = expandTypeVariable tv sti cs
(types, _, sti, cs) = expand module_index types sti cs
= (simplify_type_appl type types, type_attr, sti, cs)
# (type, _, sti, cs) = expandTypeVariable tv sti cs
(types, sti, cs) = expand module_index types sti cs
= (simplify_type_appl type types, sti, cs)
where
simplify_type_appl :: !Type ![AType] -> Type
simplify_type_appl (TA type_cons=:{type_arity} cons_args) type_args
......@@ -297,22 +298,25 @@ where
simplify_type_appl (TV tv) type_args
= CV tv :@: type_args
expand module_index type sti cs
= (type, TA_None, sti, cs)
= (type, sti, cs)
instance expand [a] | expand a
where
expand module_index [x:xs] sti cs
# (x, _, sti, cs) = expand module_index x sti cs
(xs, _, sti, cs) = expand module_index xs sti cs
= ([x:xs], TA_None, sti, cs)
# (x, sti, cs) = expand module_index x sti cs
(xs, sti, cs) = expand module_index xs sti cs
= ([x:xs], sti, cs)
expand module_index [] sti cs
= ([], TA_None, sti, cs)
= ([], sti, cs)
instance expand AType
where
expand module_index atype=:{at_type=(TV tv)} sti cs
# (at_type, attr, sti, cs) = expandTypeVariable tv sti cs
= ({ atype & at_type = at_type, at_attribute = attr }, sti, cs)
expand module_index atype=:{at_type} sti cs
# (at_type, attr, sti, cs) = expand module_index at_type sti cs
= ({ atype & at_type = at_type, at_attribute = attr }, attr, sti, cs)
# (at_type, sti, cs) = expand module_index at_type sti cs
= ({ atype & at_type = at_type }, sti, cs)
class look_for_cycles a :: !Index !a !(!*SynTypeInfo, !*CheckState) -> (!*SynTypeInfo, !*CheckState)
......@@ -357,7 +361,7 @@ expandSynType mod_index type_index sti=:{sti_type_defs,sti_marks,sti_modules} cs
position = newPosition type_def.td_name type_def.td_pos
cs_error = pushErrorAdmin position cs.cs_error
sti_marks = { sti_marks & [type_index] = CS_Checking }
(exp_type, _, sti, cs) = expand mod_index rhs_type.at_type
(exp_type, sti, cs) = expand mod_index rhs_type.at_type
{ sti_type_defs = sti_type_defs, sti_modules = sti_modules, sti_marks = sti_marks }
{ cs & cs_error = cs_error, cs_symbol_table = cs_symbol_table }
-> ({sti & sti_type_defs = { sti.sti_type_defs & [type_index] = { type_def & td_rhs = SynType { type & at_type = exp_type }}},
......@@ -924,9 +928,11 @@ checkSpecialTypes mod_index SP_None type_defs modules heaps cs
= (SP_None, type_defs, modules, heaps, cs)
/* MW: already defined in module syntax
instance <<< SelectorDef
where
(<<<) file {sd_symb} = file <<< sd_symb
*/
instance <<< AttrInequality
where
......
definition module comparedefimp
import syntax, checksupport
// compare definition and implementation module
compareDefImp :: !*{# DclModule} !*IclModule !*Heaps !*ErrorAdmin
-> (!.{# DclModule}, !.IclModule,!.Heaps,!.ErrorAdmin);
This diff is collapsed.
......@@ -568,10 +568,6 @@ zipAppend2 xs [] zs = zs
zipAppend2 [x : xs] [y : ys] zs = [ (x,y) : zipAppend2 xs ys zs ]
instance <<< FreeVar
where
(<<<) file {fv_name,fv_info_ptr} = file <<< fv_name <<< '[' <<< fv_info_ptr <<< ']'
instance <<< Ptr a
where
(<<<) file ptr = file <<< ptrToInt ptr
......
......@@ -280,7 +280,7 @@ newFunction opt_id fun_bodies local_vars arg_types result_type group_index (ci_n
, fun_type = Yes fun_type
, fun_pos = NoPos
, fun_index = NoIndex
, fun_kind = FK_Function cFunctionGenerated
, fun_kind = FK_Function cNameNotLocationDependent
, fun_lifted = 0
, fun_info = { EmptyFunInfo & fi_group_index = group_index, fi_local_vars = local_vars }
}
......@@ -1481,10 +1481,6 @@ instance <<< Ptr a
where
(<<<) file ptr = file <<< ptrToInt ptr
instance <<< FreeVar
where
(<<<) file {fv_name,fv_info_ptr} = file <<< fv_name <<< '[' <<< fv_info_ptr <<< ']'
instance <<< BoundVar
where
(<<<) file {var_name,var_info_ptr} = file <<< var_name <<< '[' <<< var_info_ptr <<< ']'
......
......@@ -73,8 +73,7 @@ possibly_filter_decls [] decls_of_imported_module _ modules cs // implicit impor
= (decls_of_imported_module, modules, cs)
possibly_filter_decls listed_symbols decls_of_imported_module (file_name, line_nr) modules cs
// explicit import
#!
ident_pos = { ip_ident= { id_name="", id_info=nilPtr }
#! ident_pos = { ip_ident= { id_name="", id_info=nilPtr }
, ip_line = line_nr
, ip_file = file_name
}
......@@ -87,17 +86,17 @@ filter_explicitly_imported_decl _ [] akku _ modules cs
= (akku, modules, cs)
filter_explicitly_imported_decl import_symbols [(index,{dcls_import,dcls_local,dcls_explicit}):new_decls] akku
line_nr modules cs
# undefined = -1
atoms = flatten (map toAtom import_symbols)
# undefined = -1
atoms = flatten (map toAtom import_symbols)
structures = flatten (map toStructure import_symbols)
(checked_atoms, cs) = checkAtoms atoms cs
unimported = (checked_atoms, structures)
unimported = (checked_atoms, structures)
((dcls_import,unimported), modules, cs)
= filter_decl dcls_import [] unimported undefined modules cs
= filter_decl dcls_import unimported undefined modules cs
((dcls_local,unimported), modules, cs)
= filter_decl dcls_local [] unimported index modules cs
cs_error = foldSt checkAtomError (fst unimported) cs.cs_error
cs_error = foldSt checkStructureError (snd unimported) cs_error
= filter_decl dcls_local unimported index modules cs
cs_error = foldSt checkAtomError (fst unimported) cs.cs_error
cs_error = foldSt checkStructureError (snd unimported) cs_error
cs = { cs & cs_error=cs_error }
| (isEmpty dcls_import && isEmpty dcls_local && isEmpty dcls_explicit)
= filter_explicitly_imported_decl import_symbols new_decls akku line_nr modules cs
......@@ -146,16 +145,16 @@ filter_explicitly_imported_decl import_symbols [(index,{dcls_import,dcls_local,d
to_structure _ No _
= []
to_structure ident (Yes []) structureType
= [(ident, SI_DotDot, structureType, No)]
= [(ident, SI_DotDot, structureType, No)]
to_structure ident (Yes elements) structureType
# element_idents = removeDup [ ii_ident \\ {ii_ident}<-elements]
= [(ident, (SI_Elements element_idents True),structureType, No)]
# element_idents = removeDup [ ii_ident \\ {ii_ident}<-elements]
= [(ident, (SI_Elements element_idents True),structureType, No)]
checkAtoms l cs
# groups = grouped l
# wrong = filter isErrornous groups
wrong = filter isErrornous groups
unique = map hd groups
| isEmpty wrong
| isEmpty wrong
= (unique, cs)
= (unique, foldSt error wrong cs)
where
......@@ -252,12 +251,17 @@ instance == ConsequenceKind
(==) CK_Macro c = case c of CK_Macro-> True
_ -> False
filter_decl [] akku unimported _ modules cs
= ((akku, unimported), modules, cs)
filter_decl [decl:decls] akku unimported index modules cs
# ((appears,unimported), modules, cs) = decl_appears decl unimported index modules cs
= filter_decl decls (if appears [decl:akku] akku) unimported index modules cs
NoPosition :== -1
filter_decl [] unimported _ modules cs
= (([], unimported), modules, cs)
filter_decl [decl:decls] unimported index modules cs
# ((appears,unimported), modules, cs) = decl_appears decl unimported index modules cs
(r=:((recurs, unimported), modules, cs)) = filter_decl decls unimported index modules cs
| appears
= (([decl:recurs],unimported), modules, cs)
= r
decl_appears :: !Declaration !ExplicitImports !Index !*{#DclModule} !*CheckState
-> (!(!Bool, !ExplicitImports), !*{#DclModule}, !*CheckState)
decl_appears dec=:{dcl_kind=STE_Imported ste_Kind def_index} unimported _ modules cs
......@@ -303,32 +307,30 @@ decl_appears {dcl_ident, dcl_kind, dcl_index} unimported index modules cs
isAtom STE_Instance = True
// CommonDefs CollectedDefinitions
elementAppears imported_st dcl_ident dcl_index (atomicImports, structureImports) index modules cs
# ((result, structureImports), modules, cs)
= element_appears imported_st dcl_ident dcl_index structureImports [] index modules cs
= element_appears imported_st dcl_ident dcl_index structureImports structureImports 0 index modules cs
= ((result, (atomicImports, structureImports)), modules, cs)
atomAppears dcl_ident dcl_index (atomicImports, structureImports) index modules cs
# ((result, atomicImports), modules, cs)
= atom_appears dcl_ident dcl_index atomicImports [] index modules cs
= atom_appears dcl_ident dcl_index atomicImports atomicImports 0 index modules cs
= ((result, (atomicImports, structureImports)), modules, cs)
atom_appears _ _ [] akku _ modules cs
= ((False, akku), modules, cs)
atom_appears ident dcl_index [h=:(import_ident, atomType):t] akku index modules cs
atom_appears _ _ [] atomic_imports _ _ modules cs
= ((False, atomic_imports), modules, cs)
atom_appears ident dcl_index [h=:(import_ident, atomType):t] atomic_imports unimp_index index modules cs
// MW2..
| do_temporary_import_solution_XXX
&& ident.id_name==import_ident.id_name
&& atomType==(AT_stomme_funktion_die_alle_symbolen_kann_importeren_omdat_niemand_zin_heft_oude_pragrammen_naar_de_nieuwe_syntax_te_vertalen True) // True or False doesn't matter in this line
# new_h = (import_ident, AT_stomme_funktion_die_alle_symbolen_kann_importeren_omdat_niemand_zin_heft_oude_pragrammen_naar_de_nieuwe_syntax_te_vertalen True)
= ((True, [new_h:t]++akku), modules, cs)
= ((True, [new_h: removeAt unimp_index atomic_imports]), modules, cs)
// ..MW2
| ident==import_ident
# (modules, cs) = checkRecordError atomType import_ident dcl_index index modules cs
= ((True, t++akku), modules, cs)
# (modules, cs) = checkRecordError atomType import_ident dcl_index index modules cs
= ((True, removeAt unimp_index atomic_imports), modules, cs)
// goes further with next alternative
where
checkRecordError atomType import_ident dcl_index index modules cs
......@@ -345,8 +347,8 @@ atom_appears ident dcl_index [h=:(import_ident, atomType):t] akku index modules
_ -> checkError import_ident "imported as an algebraic type" cs_error
_ -> cs_error
= (modules, { cs & cs_error=cs_error })
atom_appears ident dcl_index [h:t] akku index modules cs
= atom_appears ident dcl_index t [h:akku] index modules cs
atom_appears ident dcl_index [h:t] atomic_imports unimp_index index modules cs
= atom_appears ident dcl_index t atomic_imports (inc unimp_index) index modules cs
instance == StructureType
where
......@@ -355,55 +357,58 @@ instance == StructureType
(==) ST_Class ST_Class = True
(==) _ _ = False
element_appears _ _ _ [] akku _ modules cs
= ((False, akku), modules, cs)
// MW remove this later ..
element_appears _ _ _ [] atomic_imports _ _ modules cs
= ((False, atomic_imports), modules, cs)
// MW2 remove this later ..
element_appears imported_st element_ident dcl_index
[h=:(_, SI_DotDot, ST_stomm_stomm_stomm type_name_string, optInfo):t] akku
[h=:(_, SI_DotDot, ST_stomm_stomm_stomm type_name_string, optInfo):t] atomic_imports unimp_index
index modules cs
| do_temporary_import_solution_XXX
# (appears, modules, cs)
= element_appears_in_stomm_struct imported_st element_ident dcl_index index type_name_string modules cs
| appears
= ((appears,[h:t]++akku), modules, cs)
= element_appears imported_st element_ident dcl_index t [h:akku] index modules cs
= ((appears, atomic_imports), modules, cs)
= element_appears imported_st element_ident dcl_index t atomic_imports (inc unimp_index) index modules cs
// otherwise go further with next alternative
// ..MW
// ..MW2
element_appears imported_st element_ident dcl_index
[h=:(_, _, st, _):t] akku
[h=:(_, _, st, _):t] atomic_imports unimp_index
index modules cs
| imported_st<>st
= element_appears imported_st element_ident dcl_index t [h:akku] index modules cs
= element_appears imported_st element_ident dcl_index t atomic_imports (inc unimp_index) index modules cs
// goes further with next alternative
element_appears imported_st element_ident dcl_index
[h=:(_, _, _, (Yes notDefinedHere)):t] akku
[h=:(_, _, _, (Yes notDefinedHere)):t] atomic_imports unimp_index
index modules cs
| notDefinedHere==dcl_index
= element_appears imported_st element_ident dcl_index t [h:akku] index modules cs
= element_appears imported_st element_ident dcl_index t atomic_imports (inc unimp_index) index modules cs
// goes further with next alternative
element_appears imported_st element_ident dcl_index
[h=:(struct_id, (SI_Elements elements explicit), st, optInfo):t] akku
[h=:(struct_id, (SI_Elements elements explicit), st, optInfo):t] atomic_imports unimp_index
index modules cs
| not (isMember element_ident elements)
= element_appears imported_st element_ident dcl_index t atomic_imports (inc unimp_index) index modules cs
# (l,r) = span ((<>) element_ident) elements
| isEmpty r
= element_appears imported_st element_ident dcl_index t [h:akku] index modules cs
# oneLess = l++(tl r)
newStructure = (struct_id, (SI_Elements oneLess explicit), st, optInfo)
oneLess = l++(tl r)
newStructure = (struct_id, (SI_Elements oneLess explicit), st, optInfo)
atomic_imports_1 = removeAt unimp_index atomic_imports
| not explicit
= ((True, [newStructure: t]++akku), modules, cs)
= ((True, [newStructure: atomic_imports_1]), modules, cs)
// the found element was explicitly specified by the programmer: check it
# (appears, _, _, modules, cs)
= element_appears_in_struct imported_st element_ident dcl_index struct_id index modules cs
| appears
= ((True, [newStructure: t]++akku), modules, cs)
= ((True, [newStructure: atomic_imports_1]), modules, cs)
# message = "does not belong to specified "+++(case st of
ST_Class -> "class."
_ -> "type.")
cs = { cs & cs_error= checkError element_ident message cs.cs_error}
= ((False, t++akku), modules, cs)
= ((False, atomic_imports_1), modules, cs)
element_appears imported_st element_ident dcl_index
[h=:(struct_id, SI_DotDot, st, optInfo):t] akku
[h=:(struct_id, SI_DotDot, st, optInfo):t] atomic_imports unimp_index
index modules cs
| (case st of {ST_stomm_stomm_stomm _ -> True; _ -> False}) && (False->>"element_appears weird case")
= undef
# (appears, defined, opt_element_idents, modules, cs)
= element_appears_in_struct imported_st element_ident dcl_index struct_id index modules cs
| not appears
......@@ -411,17 +416,19 @@ element_appears imported_st element_ident dcl_index
No -> SI_DotDot
Yes element_idents -> (SI_Elements element_idents False)
newStructure = (struct_id, structureInfo, st, (if defined No (Yes dcl_index)))
= element_appears imported_st element_ident dcl_index t [newStructure:akku] index modules cs
new_atomic_imports = [newStructure : removeAt unimp_index atomic_imports]
= element_appears imported_st element_ident dcl_index t new_atomic_imports (inc unimp_index) index modules cs
# (Yes element_idents) = opt_element_idents
oneLess = filter ((<>) element_ident) element_idents
newStructure = (struct_id, (SI_Elements oneLess False), st, No)
= ((True,[newStructure:t]++akku), modules, cs)
element_appears imported_st element_ident dcl_index [h:t] akku index modules cs
= element_appears imported_st element_ident dcl_index t [h:akku] index modules cs
newStructure = (struct_id, (SI_Elements oneLess False), st, No)
new_atomic_imports = [newStructure : removeAt unimp_index atomic_imports]
= ((True,new_atomic_imports), modules, cs)
element_appears imported_st element_ident dcl_index [h:t] atomic_imports unimp_index index modules cs
= element_appears imported_st element_ident dcl_index t atomic_imports (inc unimp_index) index modules cs
lookup_type dcl_index index modules cs
# (dcl_module=:{dcl_name=dcl_name=:{id_info}}, modules) = modules ! [index]
(module_entry, cs_symbol_table) = readPtr id_info cs.cs_symbol_table
# (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 }
= continuation module_entry.ste_kind dcl_module modules cs
where
......
......@@ -19,6 +19,16 @@ Start world
(ms.ms_out, ms.ms_files))) world
= fclose ms_out world
CommandLoop proj ms=:{ms_io}
# answer = "c t5\n"
(command, argument) = SplitAtLayoutChar (dropWhile isSpace (fromString answer))
| command == []
= CommandLoop proj { ms & ms_io = ms_io}
# (ready, proj, ms) = DoCommand command argument proj { ms & ms_io = ms_io}
= ms
/*
CommandLoop proj ms=:{ms_io}
# (answer, ms_io) = freadline (ms_io <<< "> ")
(command, argument) = SplitAtLayoutChar (dropWhile isSpace (fromString answer))
......@@ -28,6 +38,7 @@ CommandLoop proj ms=:{ms_io}
| ready
= ms
= CommandLoop proj ms
*/
:: MainStateDefs funs funtypes types conses classes instances members selectors =
{ msd_funs :: !funs
......
......@@ -476,11 +476,11 @@ where
-> (PD_Function pos name is_infix [] rhs fun_kind, parseError "CAF" No "No arguments for a CAF" pState)
_ -> (PD_Function pos name is_infix args rhs fun_kind, pState)
where
token_to_fun_kind s BarToken = (FK_Function cFunctionNotGenerated, False, s)
token_to_fun_kind s (SeqLetToken _) = (FK_Function cFunctionNotGenerated, False, s)
token_to_fun_kind s EqualToken = (FK_Function cFunctionNotGenerated, True, s)
token_to_fun_kind s BarToken = (FK_Function cNameNotLocationDependent, False, s)
token_to_fun_kind s (SeqLetToken _) = (FK_Function cNameNotLocationDependent, False, s)
token_to_fun_kind s EqualToken = (FK_Function cNameNotLocationDependent, True, s)
token_to_fun_kind s ColonDefinesToken = (FK_Macro, False, s)
token_to_fun_kind s DoubleArrowToken = (FK_Function cFunctionNotGenerated, True, s)
token_to_fun_kind s DoubleArrowToken = (FK_Function cNameNotLocationDependent, True, s)
token_to_fun_kind s DefinesColonToken = (FK_Caf, False, s)
token_to_fun_kind s token = (FK_Unknown, False, parseError "RHS" (Yes token) "defines token (=, => or =:) or argument" s)
......@@ -1808,7 +1808,7 @@ wantSelectors token pState
where
want_selector :: !Token !*ParseState -> *(![ParsedSelection], !*ParseState)
want_selector SquareOpenToken pState
# (array_selectors, pState) = want_array_selectors pState
# (array_selectors, pState) = want_array_selectors pState
= (array_selectors, wantToken FunctionContext "array selector" SquareCloseToken pState)
where
want_array_selectors :: !*ParseState -> *(![ParsedSelection], !*ParseState)
......@@ -2153,9 +2153,9 @@ wantRecordOrArrayExp is_pattern pState
= (PE_ArrayDenot [], pState)
| is_pattern
| token == SquareOpenToken
// # (elems, pState) = want_array_assignments cIsAPattern pState // currently no array selections in pattern PK
// = (PE_Array PE_Empty elems [], wantToken FunctionContext "array selections in pattern" CurlyCloseToken pState)
= (PE_Empty, parseError "array selection" No "No array selection in pattern" pState)
# (elems, pState) = want_array_assignments cIsAPattern pState
= (PE_ArrayPattern elems, wantToken FunctionContext "array selections in pattern" CurlyCloseToken pState)
// MW was = (PE_Empty, parseError "array selection" No "No array selection in pattern" pState)
// otherwise // is_pattern && token <> SquareOpenToken
= want_record_pattern token pState
// otherwise // ~ is_pattern
......
......@@ -208,6 +208,7 @@ where
instance collectFunctions CaseAlt
where
collectFunctions calt=:{calt_pattern,calt_rhs} ca
// MW why not # (calt_rhs, fun_defs, ca) = collectFunctions calt_rhs ca
# ((calt_pattern,calt_rhs), fun_defs, ca) = collectFunctions (calt_pattern,calt_rhs) ca
= ({calt & calt_pattern = calt_pattern, calt_rhs = calt_rhs}, fun_defs, ca)
......@@ -311,7 +312,7 @@ transformLambda lam_ident args result
# lam_rhs = { rhs_alts = UnGuardedExpr { ewl_nodes = [], ewl_expr = result, ewl_locals = NoCollectedLocalDefs },
rhs_locals = NoCollectedLocalDefs }
lam_body = [{pb_args = args, pb_rhs = lam_rhs }]
fun_def = MakeNewFunction lam_ident (length args) lam_body (FK_Function cFunctionGenerated) NoPrio No NoPos
fun_def = MakeNewFunction lam_ident (length args) lam_body (FK_Function cNameLocationDependent) NoPrio No NoPos
= fun_def
makeNilExpression :: *CollectAdmin -> (ParsedExpr,*CollectAdmin)
......@@ -739,7 +740,7 @@ MakeNewFunction name arity body kind prio opt_type pos
// +++ position
MakeNewParsedDef ident args rhs
:== PD_Function NoPos ident False args rhs (FK_Function cFunctionGenerated)
:== PD_Function NoPos ident False args rhs (FK_Function cNameLocationDependent)
collectFunctionBodies :: !Ident !Int