Commit 0c72cfd0 authored by John van Groningen's avatar John van Groningen
Browse files

feature, in types of local functions with free variables that are added as...

feature, in types of local functions with free variables that are added as function arguments by lifting
add specifying type and attribute variables that occur in the types of these free variables/lifted arguments
so that the (partial) type of functions that use these variables and attributes can be specified
with syntax:

function_name :: E.^ type_and_attribute_variables : function_type

type_and_attributes_variables is a list of at least one of:

type_var *type_var .type_var (attribute_var:type_var) (attribute_var:)

these type and attribute variables are still polymorphic, but for recursive calls no new variables are created,
so polymorpic recursion is not supported for these variables

a local function type can still not be specified if:
an attribute inequality contains one attribute variable that occurs only in types of free variables/lifted arguments
(and the other attribute variable occurs only in the rest of the function type)
or a class constraint that contains both a type variable that occurs only in types of free variables/lifted arguments
and a type variable that occurs in the rest of the function type
parent 955e1a8f
......@@ -1048,10 +1048,14 @@ new_local_kind_variables_for_universal_vars type_vars type_var_heap as_kind_heap
bindFreshKindVariablesToTypeVars :: [TypeVar] !*TypeVarHeap !*KindHeap -> (!*TypeVarHeap,!*KindHeap)
bindFreshKindVariablesToTypeVars type_vars type_var_heap as_kind_heap
= foldSt new_kind type_vars (type_var_heap, as_kind_heap)
where
new_kind :: !TypeVar !(!*TypeVarHeap,!*KindHeap) -> (!*TypeVarHeap,!*KindHeap)
new_kind {tv_info_ptr} (type_var_heap, kind_heap)
= foldSt new_kind_for_type_var type_vars (type_var_heap, as_kind_heap)
bindFreshKindVariablesToTypeVarsS :: [!TypeVar!] !*TypeVarHeap !*KindHeap -> (!*TypeVarHeap,!*KindHeap)
bindFreshKindVariablesToTypeVarsS type_vars type_var_heap as_kind_heap
= foldStS new_kind_for_type_var type_vars (type_var_heap, as_kind_heap)
new_kind_for_type_var :: !TypeVar !(!*TypeVarHeap,!*KindHeap) -> (!*TypeVarHeap,!*KindHeap)
new_kind_for_type_var {tv_info_ptr} (type_var_heap, kind_heap)
# (kind_info_ptr, kind_heap) = freshKindVarInfoPtr kind_heap
= (type_var_heap <:= (tv_info_ptr, TVI_TypeKind kind_info_ptr), kind_heap)
......@@ -1176,6 +1180,12 @@ where
# as & as_error = pushErrorPosition fun_ident fun_pos as.as_error
(class_infos, as) = check_kinds_of_symbol_type common_defs symbol_type class_infos as
-> (icl_fun_defs, class_infos, expression_heap, {as & as_error = popErrorAdmin as.as_error})
LocalFunDefCheckedType external_type_vars _ symbol_type
# as & as_error = pushErrorPosition fun_ident fun_pos as.as_error
(as_type_var_heap, as_kind_heap) = bindFreshKindVariablesToTypeVarsS external_type_vars as.as_type_var_heap as.as_kind_heap
as & as_type_var_heap=as_type_var_heap, as_kind_heap=as_kind_heap
(class_infos, as) = check_kinds_of_symbol_type common_defs symbol_type class_infos as
-> (icl_fun_defs, class_infos, expression_heap, {as & as_error = popErrorAdmin as.as_error})
NoFunDefType
-> (icl_fun_defs, class_infos, expression_heap, as)
......
......@@ -1194,6 +1194,12 @@ where
cs = if is_caf (check_caf_uniqueness ft.st_result.at_attribute cs) cs
(st_context, var_heap) = initializeContextVariables ft.st_context var_heap
= (FunDefType {ft & st_context = st_context}, type_defs, class_defs, modules, var_heap, type_heaps, cs)
check_function_type (LocalFunDefType external_atype_or_attr_vars ft) module_index is_caf type_defs class_defs modules var_heap type_heaps cs
# (external_type_vars,external_atype_attrs,ft,_,type_defs,class_defs,modules,type_heaps,cs)
= checkLocalFunctionType module_index external_atype_or_attr_vars ft FSP_None type_defs class_defs modules type_heaps cs
cs = if is_caf (check_caf_uniqueness ft.st_result.at_attribute cs) cs
(st_context, var_heap) = initializeContextVariables ft.st_context var_heap
= (LocalFunDefCheckedType external_type_vars external_atype_attrs {ft & st_context = st_context},type_defs,class_defs,modules,var_heap,type_heaps,cs)
check_function_type NoFunDefType module_index _ type_defs class_defs modules var_heap type_heaps cs
= (NoFunDefType, type_defs, class_defs, modules, var_heap, type_heaps, cs)
......
......@@ -9,6 +9,10 @@ checkTypeDefs :: !Index !(Optional (CopiedDefinitions, Int))
checkFunctionType :: !Index !SymbolType !FunSpecials !u:{#CheckedTypeDef} !v:{#ClassDef} !u:{#DclModule} !*TypeHeaps !*CheckState
-> (!SymbolType,!FunSpecials,!u:{#CheckedTypeDef},!v:{#ClassDef},!u:{#DclModule},!*TypeHeaps,!*CheckState)
checkLocalFunctionType :: !Index ![!ATypeVarOrAttributeVar!]
!SymbolType !FunSpecials !u:{#CheckedTypeDef} !v:{#ClassDef} !u:{#DclModule} !*TypeHeaps !*CheckState
-> (![!TypeVar!],![!AttributeVar!],!SymbolType,!FunSpecials,!u:{#CheckedTypeDef},!v:{#ClassDef},!u:{#DclModule},!*TypeHeaps,!*CheckState)
checkMemberType :: !Index !SymbolType !u:{# CheckedTypeDef} !v:{# ClassDef} !u:{# DclModule} !*TypeHeaps !*CheckState
-> (!SymbolType, !u:{# CheckedTypeDef}, !v:{# ClassDef}, !u:{# DclModule}, !*TypeHeaps, !*CheckState)
......
......@@ -5,6 +5,10 @@ import syntax, checksupport, typesupport, utilities
import genericsupport
from explicitimports import search_qualified_ident,qualified_import_for_type,::NameSpaceN,TypeNameSpaceN,ClassNameSpaceN
:: STE_Kind
| STE_TypeAttribute !AttrVarInfoPtr
| STE_UnusedTypeAttribute !AttrVarInfoPtr
:: TypeSymbols =
{ ts_type_defs :: !.{# CheckedTypeDef}
, ts_cons_defs :: !.{# ConsDef}
......@@ -781,8 +785,12 @@ determineAttributeVariable attr_var=:{av_ident=attr_name=:{id_info}} oti=:{oti_h
ste_def_level = cGlobalScope, ste_previous = entry })
new_attr = { attr_var & av_info_ptr = new_attr_ptr}
= (new_attr, { oti & oti_heaps = { oti_heaps & th_attrs = th_attrs }, oti_all_attrs = [new_attr : oti_all_attrs] }, symbol_table)
# (STE_TypeAttribute attr_ptr) = ste_kind
= ({ attr_var & av_info_ptr = attr_ptr}, oti, symbol_table)
= case ste_kind of
STE_TypeAttribute attr_ptr
-> ({attr_var & av_info_ptr = attr_ptr}, oti, symbol_table)
STE_UnusedTypeAttribute attr_ptr
# symbol_table = writePtr id_info {entry & ste_kind = STE_TypeAttribute attr_ptr} symbol_table
-> ({attr_var & av_info_ptr = attr_ptr}, oti, symbol_table)
:: DemandedAttributeKind = DAK_Ignore | DAK_Unique | DAK_None
......@@ -1233,6 +1241,116 @@ checkFunctionType :: !Index !SymbolType !FunSpecials !u:{#CheckedTypeDef} !v:{#C
checkFunctionType mod_index st specials type_defs class_defs modules heaps cs
= checkSymbolType True mod_index st specials type_defs class_defs modules heaps cs
checkLocalFunctionType :: !Index ![!ATypeVarOrAttributeVar!]
!SymbolType !FunSpecials !u:{#CheckedTypeDef} !v:{#ClassDef} !u:{#DclModule} !*TypeHeaps !*CheckState
-> (![!TypeVar!],![!AttributeVar!],!SymbolType,!FunSpecials,!u:{#CheckedTypeDef},!v:{#ClassDef},!u:{#DclModule},!*TypeHeaps,!*CheckState)
checkLocalFunctionType mod_index external_atype_or_attr_vars st specials type_defs class_defs modules heaps cs
# (external_type_vars,external_attr_vars,type_var_heap,attr_var_heap,symbol_table,error)
= define_external_atype_vars external_atype_or_attr_vars [!!] [!!] heaps.th_vars heaps.th_attrs cs.cs_symbol_table cs.cs_error
(external_attr_vars,attr_var_heap,symbol_table,error)
= define_external_attr_vars external_atype_or_attr_vars external_attr_vars attr_var_heap symbol_table error
cs & cs_symbol_table=symbol_table, cs_error=error
heaps & th_vars=type_var_heap, th_attrs=attr_var_heap
(checked_st,specials,type_defs,class_defs,modules,heaps,cs)
= checkSymbolType True mod_index st specials type_defs class_defs modules heaps cs
(type_var_heap,symbol_table,error)
= check_external_type_vars_occur_and_remove external_type_vars heaps.th_vars cs.cs_symbol_table cs.cs_error
(symbol_table,error) = check_external_external_attr_vars_occur_and_remove external_attr_vars symbol_table error
heaps & th_vars=type_var_heap
cs & cs_symbol_table=symbol_table, cs_error=error
= (external_type_vars,external_attr_vars,checked_st,specials,type_defs,class_defs,modules,heaps,cs)
where
define_external_atype_vars :: ![!ATypeVarOrAttributeVar!]
![!TypeVar!] ![!AttributeVar!] !*TypeVarHeap !*AttrVarHeap !*SymbolTable !*ErrorAdmin
-> (![!TypeVar!],![!AttributeVar!],!*TypeVarHeap,!*AttrVarHeap,!*SymbolTable,!*ErrorAdmin)
define_external_atype_vars [!ATypeVar {atv_attribute,atv_variable=atv_variable=:{tv_ident={id_name}}}:external_atype_or_attr_vars!]
external_type_vars external_attr_vars type_var_heap attr_var_heap symbol_table error
# (new_attr,external_attr_vars,attr_var_heap,symbol_table)
= define_external_attr_var atv_attribute id_name external_attr_vars attr_var_heap symbol_table
# (external_type_vars,type_var_heap,symbol_table,error)
= define_external_type_var atv_variable new_attr external_type_vars type_var_heap symbol_table error
= define_external_atype_vars external_atype_or_attr_vars external_type_vars external_attr_vars type_var_heap attr_var_heap symbol_table error
define_external_atype_vars [!_:external_atype_or_attr_vars!] external_type_vars external_attr_vars type_var_heap attr_var_heap symbol_table error
= define_external_atype_vars external_atype_or_attr_vars external_type_vars external_attr_vars type_var_heap attr_var_heap symbol_table error
define_external_atype_vars [!!] external_type_vars external_attr_vars type_var_heap attr_var_heap symbol_table error
= (external_type_vars,external_attr_vars,type_var_heap,attr_var_heap,symbol_table,error)
define_external_attr_var :: !TypeAttribute !{#Char} ![!AttributeVar!] !*AttrVarHeap !*SymbolTable
-> (!TypeAttribute,![!AttributeVar!],!*AttrVarHeap,!*SymbolTable)
define_external_attr_var (TA_Var attr_var=:{av_ident={id_info}}) var_ident external_attr_vars attr_var_heap symbol_table
# (entry=:{ste_kind,ste_def_level}, symbol_table) = readPtr id_info symbol_table
| ste_kind =: STE_Empty || ste_def_level == cModuleScope
# (new_attr_var,external_attr_vars,attr_var_heap,symbol_table)
= define_new_external_attr_var attr_var id_info entry external_attr_vars attr_var_heap symbol_table
= (TA_Var new_attr_var,external_attr_vars,attr_var_heap,symbol_table)
// no error, allow u:a and u:b
# (STE_UnusedTypeAttribute attr_ptr) = ste_kind
new_attr = {attr_var & av_info_ptr = attr_ptr}
= (TA_Var new_attr,external_attr_vars,attr_var_heap,symbol_table)
define_external_attr_var TA_None var_ident external_attr_vars attr_var_heap symbol_table
= (TA_Multi,external_attr_vars,attr_var_heap,symbol_table)
define_external_attr_var type_attribute var_ident external_attr_vars attr_var_heap symbol_table
= (type_attribute,external_attr_vars,attr_var_heap,symbol_table)
define_external_type_var :: !TypeVar !TypeAttribute ![!TypeVar!] !*TypeVarHeap !*SymbolTable !*ErrorAdmin
-> (![!TypeVar!],!*TypeVarHeap,!*SymbolTable,!*ErrorAdmin)
define_external_type_var tv=:{tv_ident={id_info}} new_attr external_type_vars type_var_heap symbol_table error
# (entry=:{ste_kind,ste_def_level},symbol_table) = readPtr id_info symbol_table
| ste_kind =: STE_Empty || ste_def_level == cModuleScope
# (new_var_ptr, type_var_heap) = newPtr (TVI_AttrAndRefCount new_attr 0) type_var_heap
new_var = {tv & tv_info_ptr = new_var_ptr}
new_entry = {ste_index=NoIndex, ste_kind=STE_TypeVariable new_var_ptr, ste_def_level=cGlobalScope, ste_previous=entry}
symbol_table = writePtr id_info new_entry symbol_table
= ([!new_var:external_type_vars!],type_var_heap,symbol_table,error)
# error = checkError tv.tv_ident "type variable already defined" error
= (external_type_vars,type_var_heap,symbol_table,error)
define_external_attr_vars :: ![!ATypeVarOrAttributeVar!] ![!AttributeVar!] !*AttrVarHeap !*SymbolTable !*ErrorAdmin
-> (![!AttributeVar!],!*AttrVarHeap,!*SymbolTable,!*ErrorAdmin)
define_external_attr_vars [!AttributeVar attr_var=:{av_ident={id_info},av_info_ptr}:external_atype_or_attr_vars!] external_attr_vars attr_var_heap symbol_table error
# (entry=:{ste_kind,ste_def_level}, symbol_table) = readPtr id_info symbol_table
| ste_kind =: STE_Empty || ste_def_level == cModuleScope
# (new_attr_var,external_attr_vars,attr_var_heap,symbol_table)
= define_new_external_attr_var attr_var id_info entry external_attr_vars attr_var_heap symbol_table
= define_external_attr_vars external_atype_or_attr_vars external_attr_vars attr_var_heap symbol_table error
# error = checkError attr_var.av_ident "attribute variable already defined" error
= define_external_attr_vars external_atype_or_attr_vars external_attr_vars attr_var_heap symbol_table error
define_external_attr_vars [!_:external_atype_or_attr_vars!] external_attr_vars attr_var_heap symbol_table error
= define_external_attr_vars external_atype_or_attr_vars external_attr_vars attr_var_heap symbol_table error
define_external_attr_vars [!!] external_attr_vars attr_var_heap symbol_table error
= (external_attr_vars,attr_var_heap,symbol_table,error)
define_new_external_attr_var attr_var id_info entry external_attr_vars attr_var_heap symbol_table
#! (new_attr_ptr, attr_var_heap) = newPtr AVI_Empty attr_var_heap
# new_entry = {ste_index = NoIndex, ste_kind = STE_UnusedTypeAttribute new_attr_ptr, ste_def_level = cGlobalScope, ste_previous = entry}
symbol_table = writePtr id_info new_entry symbol_table
new_attr = {attr_var & av_info_ptr = new_attr_ptr}
= (new_attr,[!new_attr:external_attr_vars!],attr_var_heap,symbol_table)
check_external_type_vars_occur_and_remove [!{tv_info_ptr,tv_ident}:external_type_vars!] type_var_heap symbol_table error
# symbol_table = removeDefinitionFromSymbolTable cGlobalScope tv_ident symbol_table
# (tv_info, type_var_heap) = readPtr tv_info_ptr type_var_heap
| tv_info=:(TVI_AttrAndRefCount _ 0)
# error = checkError tv_ident "unused type variable" error
= check_external_type_vars_occur_and_remove external_type_vars type_var_heap symbol_table error
= check_external_type_vars_occur_and_remove external_type_vars type_var_heap symbol_table error
check_external_type_vars_occur_and_remove [!!] type_var_heap symbol_table error
= (type_var_heap,symbol_table,error)
check_external_external_attr_vars_occur_and_remove [!{av_ident=av_ident=:{id_info}}:external_attr_vars!] symbol_table error
| isNilPtr id_info // for TA_Anonymous
= check_external_external_attr_vars_occur_and_remove external_attr_vars symbol_table error
# ({ste_def_level,ste_kind,ste_previous}, symbol_table) = readPtr id_info symbol_table
| ste_def_level>=cGlobalScope
# symbol_table = writePtr id_info ste_previous symbol_table
| ste_def_level==cGlobalScope && ste_kind=:STE_UnusedTypeAttribute _
# error = checkError av_ident "unused attribute variable" error
= check_external_external_attr_vars_occur_and_remove external_attr_vars symbol_table error
= check_external_external_attr_vars_occur_and_remove external_attr_vars symbol_table error
= check_external_external_attr_vars_occur_and_remove external_attr_vars symbol_table error
check_external_external_attr_vars_occur_and_remove [!!] symbol_table error
= (symbol_table,error)
checkMemberType :: !Index !SymbolType !u:{# CheckedTypeDef} !v:{# ClassDef} !u:{# DclModule} !*TypeHeaps !*CheckState
-> (!SymbolType, !u:{# CheckedTypeDef}, !v:{# ClassDef}, !u:{# DclModule}, !*TypeHeaps, !*CheckState)
checkMemberType mod_index st type_defs class_defs modules heaps cs
......@@ -1456,7 +1574,15 @@ where
| entry.ste_kind =: STE_Empty
= symbol_table
= symbol_table <:= (id_info, entry.ste_previous)
checkDynamicTypes mod_index dyn_type_ptrs (FunDefType {st_vars}) type_defs class_defs modules type_heaps expr_heap cs=:{cs_symbol_table}
checkDynamicTypes mod_index dyn_type_ptrs (FunDefType {st_vars}) type_defs class_defs modules type_heaps expr_heap cs
= checkDynamicTypesWithFunctionType mod_index dyn_type_ptrs st_vars type_defs class_defs modules type_heaps expr_heap cs
checkDynamicTypes mod_index dyn_type_ptrs (LocalFunDefCheckedType _ _ {st_vars}) type_defs class_defs modules type_heaps expr_heap cs
= checkDynamicTypesWithFunctionType mod_index dyn_type_ptrs st_vars type_defs class_defs modules type_heaps expr_heap cs
checkDynamicTypesWithFunctionType :: !Index ![ExprInfoPtr] ![TypeVar]
!u:{#CheckedTypeDef} !v:{#ClassDef} !u:{#DclModule} !*TypeHeaps !*ExpressionHeap !*CheckState
-> (!u:{#CheckedTypeDef},!v:{#ClassDef},!u:{#DclModule},!*TypeHeaps,!*ExpressionHeap,!*CheckState)
checkDynamicTypesWithFunctionType mod_index dyn_type_ptrs st_vars type_defs class_defs modules type_heaps expr_heap cs=:{cs_symbol_table}
# (th_vars, cs_symbol_table) = foldSt add_type_variable_to_symbol_table st_vars (type_heaps.th_vars, cs_symbol_table)
(type_defs, class_defs, modules, heaps, expr_heap, cs)
= checkDynamics mod_index cGlobalScope dyn_type_ptrs type_defs class_defs modules
......@@ -2080,6 +2206,7 @@ where
instance toVariable AttributeVar
where
toVariable (STE_TypeAttribute info_ptr) ident = { av_ident = ident, av_info_ptr = info_ptr }
toVariable (STE_UnusedTypeAttribute info_ptr) ident = { av_ident = ident, av_info_ptr = info_ptr }
instance <<< DynamicType
where
......
......@@ -800,6 +800,8 @@ instance check_completeness FunctionBody where
instance check_completeness FunDefType where
check_completeness (FunDefType x) cci ccs
= check_completeness x cci ccs
check_completeness (LocalFunDefType _ x) cci ccs
= check_completeness x cci ccs
check_completeness NoFunDefType _ ccs
= ccs
......
......@@ -14,6 +14,8 @@ instance <<< (a,b,c,d,e,f) | <<< a & <<< b & <<< c & <<< d & <<< e & <<< f
instance <<< (a,b,c,d,e,f,g) | <<< a & <<< b & <<< c & <<< d & <<< e & <<< f & <<< g
instance <<< [a] | <<< a
:: P a b = P !a !b
:: Bind a b =
{ bind_src :: !a
, bind_dst :: !b
......
......@@ -2,6 +2,8 @@ implementation module general
import StdEnv
:: P a b = P !a !b
:: Bind a b =
{ bind_src :: !a
, bind_dst :: !b
......
......@@ -643,8 +643,8 @@ where
want_rhs_of_def :: !ParseContext !(Optional (Ident, Bool), [ParsedExpr]) !Token !Position !ParseState -> (ParsedDefinition, !ParseState)
want_rhs_of_def parseContext (opt_name, []) DoubleColonToken pos pState
# (name, is_infix, pState) = check_name_and_fixity opt_name cHasNoPriority pState
(tspec, pState) = wantSymbolType pState
| isDclContext parseContext
# (tspec, pState) = wantSymbolType pState
# (specials, pState) = optionalFunSpecials pState
#! def = PD_TypeSpec pos name (if is_infix DefaultPriority NoPrio) (Yes tspec) specials;
| not specials=:FSP_ABCCode _
......@@ -654,7 +654,17 @@ want_rhs_of_def parseContext (opt_name, []) DoubleColonToken pos pState
= (def, wantEndOfDefinition "type definition" pState)
// } must be at end of line, make ; optional
= (def, optional_semicolon_without_layout_rule pState)
= (PD_TypeSpec pos name (if is_infix DefaultPriority NoPrio) (Yes tspec) FSP_None, wantEndOfDefinition "type definition" pState)
# priority = if is_infix DefaultPriority NoPrio
| parseContext==cLocalContext
# (token, pState) = nextToken TypeContext pState
| token =: ExistsExternalToken
# (external_type_var_or_attr_vars,pState) = parse_external_type_and_attr_vars pState
# (tspec, pState) = wantSymbolType pState
= (PD_LocalFunctionTypeSpec pos name priority external_type_var_or_attr_vars tspec, wantEndOfDefinition "type definition" pState)
# (tspec, pState) = wantSymbolType (tokenBack pState)
= (PD_TypeSpec pos name priority (Yes tspec) FSP_None, wantEndOfDefinition "type definition" pState)
# (tspec, pState) = wantSymbolType pState
= (PD_TypeSpec pos name priority (Yes tspec) FSP_None, wantEndOfDefinition "type definition" pState)
want_rhs_of_def parseContext (opt_name, args) (PriorityToken prio) pos pState
# (name, _, pState) = check_name_and_fixity opt_name cHasPriority pState
(token, pState) = nextToken TypeContext pState
......@@ -725,6 +735,66 @@ want_rhs_of_def parseContext (Yes (name, is_infix), args) token pos pState
-> (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)
parse_external_type_and_attr_vars :: !ParseState -> (![!ATypeVarOrAttributeVar!],!ParseState)
parse_external_type_and_attr_vars pState
# (external_type_var_or_attr_var,pState) = try_external_type_or_attr_var pState
| external_type_var_or_attr_var=:NoATypeVarOrAttributeVar
# pState = parseError "type and attribute variables" No "type or attribute variable" pState
# pState = wantToken TypeContext "type and attribute variables in types of free variables" ColonToken pState
= ([!!],pState);
# (external_type_var_or_attr_vars,pState) = parse_external_type_or_attr_vars pState
# pState = wantToken TypeContext "type and attribute variables in types of free variables" ColonToken pState
= ([!external_type_var_or_attr_var:external_type_var_or_attr_vars!],pState)
where
try_external_type_or_attr_var pState
# (token, pState) = nextToken TypeContext pState
= case token of
IdentToken name
| isLowerCaseName name
# (id, pState) = stringToIdent name IC_Type pState
-> (ATypeVar {atv_attribute = TA_None, atv_variable = MakeTypeVar id},pState)
DotToken
# (typevar, pState) = wantTypeVar pState
(ident, pState) = stringToIdent typevar.tv_ident.id_name IC_TypeAttr pState
-> (ATypeVar {atv_attribute = TA_Var (makeAttributeVar ident), atv_variable = typevar}, pState)
AsteriskToken
# (typevar, pState) = wantTypeVar pState
-> (ATypeVar {atv_attribute = TA_Unique, atv_variable = typevar},pState)
OpenToken
# (token2, pState) = nextToken TypeContext pState
-> case token2 of
IdentToken name
| isLowerCaseName name
-> want_attribute_variable_with_optional_type_variable name pState
_
-> (NoATypeVarOrAttributeVar,tokenBack (tokenBack pState))
_
-> (NoATypeVarOrAttributeVar,tokenBack pState)
want_attribute_variable_with_optional_type_variable name pState
# (ident, pState) = stringToIdent name IC_TypeAttr pState
# attr_var = makeAttributeVar ident
# pState = wantToken TypeContext "attribute variable with optional type variable" ColonToken pState
# (token, pState) = nextToken TypeContext pState
= case token of
IdentToken name
| isLowerCaseName name
# (id, pState) = stringToIdent name IC_Type pState
# pState = wantToken TypeContext "attribute variable with optional type variable" CloseToken pState
-> (ATypeVar {atv_attribute = TA_Var attr_var, atv_variable = MakeTypeVar id},pState)
CloseToken
-> (AttributeVar attr_var,pState)
_
# pState = wantToken TypeContext "attribute variable with optional type variable" CloseToken (tokenBack pState)
-> (AttributeVar attr_var,pState)
parse_external_type_or_attr_vars pState
# (external_type_var_or_attr_var,pState) = try_external_type_or_attr_var pState
| external_type_var_or_attr_var=:NoATypeVarOrAttributeVar
= ([!!],pState)
# (external_type_var_or_attr_vars,pState) = parse_external_type_or_attr_vars pState
= ([!external_type_var_or_attr_var:external_type_var_or_attr_vars!],pState)
wantGenericFunctionDefinition name parseContext pos pState
//# (type, pState) = wantType pState
# (ok, {at_type=type}, pState) = trySimpleType TA_None pState
......
......@@ -127,28 +127,41 @@ reorganiseLocalDefinitions [PD_TypeSpec pos1 name1 prio type specials : defs] ca
-> reorganiseLocalDefinitions (tl defs) ca
| belongsToTypeSpec name1 prio name is_infix
# fun_arity = determineArity args type
# (bodies, fun_kind, defs, ca) = collectFunctionBodies name1 fun_arity prio fun_kind defs ca
(fun_defs, node_defs, ca) = reorganiseLocalDefinitions defs ca
type = case type of Yes type->FunDefType type; No->NoFunDefType
fun = MakeNewImpOrDefFunction name fun_arity bodies fun_kind prio type pos1
-> ([fun : fun_defs], node_defs, ca)
-> reorganiseLocalDefinitions_typed_function pos1 name1 prio type name fun_arity fun_kind defs ca
-> reorganiseLocalDefinitions defs (postParseFunError name pos "function body expected" ca)
[PD_NodeDef pos pattern=:(PE_Ident id) rhs : defs]
| not (belongsToTypeSpec name1 prio id False)
-> reorganiseLocalDefinitions defs (postParseFunError id pos "function body expected" ca)
| arity type<>0
-> reorganiseLocalDefinitions defs (postParseFunError id pos "this alternative does not have enough arguments" ca)
# (fun_defs, node_defs, ca) = reorganiseLocalDefinitions defs ca
type = case type of Yes type->FunDefType type; No->NoFunDefType
fun = MakeNewImpOrDefFunction id 0
[{ pb_args = [], pb_rhs = rhs, pb_position = pos }]
(FK_Function cNameNotLocationDependent) prio type pos1
-> ([fun : fun_defs], node_defs, ca)
# type = case type of Yes type->FunDefType type; No->NoFunDefType
-> reorganiseLocalDefinitions_typed_node_def pos1 prio type pos id rhs defs ca
_
-> reorganiseLocalDefinitions defs (postParseFunError name1 pos1 "function body expected" ca)
where
arity (Yes {st_arity}) = st_arity
arity No = 2 // it was specified as infix
reorganiseLocalDefinitions [PD_LocalFunctionTypeSpec pos1 name1 prio external_atype_or_attr_vars type : defs] ca
= case defs of
[PD_Function pos name is_infix args rhs fun_kind : othe]
| fun_kind=:FK_Caf
# ca = postParseFunError name pos "No typespecification for local graph definitions allowed" ca
-> reorganiseLocalDefinitions (tl defs) ca
| belongsToTypeSpec name1 prio name is_infix
# fun_arity = type.st_arity
type = LocalFunDefType external_atype_or_attr_vars type
-> reorganiseLocalDefinitions_typed_function pos1 name1 prio type name fun_arity fun_kind defs ca
-> reorganiseLocalDefinitions defs (postParseFunError name pos "function body expected" ca)
[PD_NodeDef pos pattern=:(PE_Ident id) rhs : defs]
| not (belongsToTypeSpec name1 prio id False)
-> reorganiseLocalDefinitions defs (postParseFunError id pos "function body expected" ca)
| type.st_arity<>0
-> reorganiseLocalDefinitions defs (postParseFunError id pos "this alternative does not have enough arguments" ca)
# type = LocalFunDefType external_atype_or_attr_vars type
-> reorganiseLocalDefinitions_typed_node_def pos1 prio type pos id rhs defs ca
_
-> reorganiseLocalDefinitions defs (postParseFunError name1 pos1 "function body expected" ca)
reorganiseLocalDefinitions [PD_DeriveInstanceMember pos member_ident generic_ident arity optional_member_ident : defs] ca
# fun_body = GenerateInstanceBody generic_ident optional_member_ident
fun_def = {fun_ident = member_ident, fun_arity = arity, fun_priority = NoPrio, fun_type = NoFunDefType, fun_kind = FK_Function False,
......@@ -164,6 +177,18 @@ reorganiseLocalDefinitions [PD_DeriveFunction pos function_ident type_cons : def
reorganiseLocalDefinitions [] ca
= ([], [], ca)
reorganiseLocalDefinitions_typed_function pos1 name1 prio type name fun_arity fun_kind defs ca
# (bodies, fun_kind, defs, ca) = collectFunctionBodies name1 fun_arity prio fun_kind defs ca
(fun_defs, node_defs, ca) = reorganiseLocalDefinitions defs ca
fun = MakeNewImpOrDefFunction name fun_arity bodies fun_kind prio type pos1
= ([fun : fun_defs], node_defs, ca)
reorganiseLocalDefinitions_typed_node_def pos1 prio type pos id rhs defs ca
# (fun_defs, node_defs, ca) = reorganiseLocalDefinitions defs ca
fun = MakeNewImpOrDefFunction id 0 [{pb_args = [], pb_rhs = rhs, pb_position = pos}]
(FK_Function cNameNotLocationDependent) prio type pos1
= ([fun : fun_defs], node_defs, ca)
collect_functions_in_node_defs :: [NodeDef ParsedExpr] Bool *CollectAdmin -> ([NodeDef ParsedExpr],*CollectAdmin)
collect_functions_in_node_defs [bind : node_defs] icl_module ca
# (bind, ca) = collectFunctions bind icl_module ca
......
......@@ -112,6 +112,7 @@ instance <<< FilePosition
| GenericWithToken // with
| ExistsToken // E.
| ExistsExternalToken // E.^
| ForAllToken // A.
LazyJustToken :== 0
......
......@@ -198,6 +198,7 @@ ScanOptionNoNewOffsideForSeqLetBit:==4;
| GenericWithToken // with
| ExistsToken // E.
| ExistsExternalToken // E.^
| ForAllToken // A.
LazyJustToken :== 0
......@@ -757,7 +758,11 @@ Scan '?' input co
Scan 'E' input TypeContext
# (eof,c1,input) = ReadNormalChar input
| eof = (IdentToken "E", input)
| c1 == '.' = (ExistsToken, input)
| c1 == '.'
# (eof,c2,input) = ReadNormalChar input
| eof = (ExistsToken, input)
| c2=='^' = (ExistsExternalToken, input)
= (ExistsToken, charBack input)
= ScanIdentFast 1 (charBack input) TypeContext
Scan 'A' input TypeContext
# (eof,c1,input) = ReadNormalChar input
......@@ -1758,6 +1763,7 @@ where
toString GenericOfToken = "of"
toString ExistsToken = "E."
toString ExistsExternalToken = "E.^"
toString ForAllToken = "A."
toString token = "toString (Token) does not know this token"
......
......@@ -51,7 +51,6 @@ instance == FunctionOrMacroIndex
| STE_Instance
| STE_Variable !VarInfoPtr
| STE_TypeVariable !TypeVarInfoPtr
| STE_TypeAttribute !AttrVarInfoPtr
| STE_BoundTypeVariable !STE_BoundTypeVariable
| STE_Imported !STE_Kind !ModuleN
| STE_DclFunction
......@@ -79,6 +78,7 @@ instance == FunctionOrMacroIndex
| STE_BelongingSymbolExported
| STE_BelongingSymbolForExportedSymbol
| STE_TypeExtension
| ..
:: ModuleN:==Int;
......@@ -268,6 +268,7 @@ cIsNotAFunction :== False
| PD_NodeDef Position ParsedExpr Rhs
| PD_Type ParsedTypeDef
| PD_TypeSpec Position Ident Priority (Optional SymbolType) FunSpecials
| PD_LocalFunctionTypeSpec !Position !Ident !Priority ![!ATypeVarOrAttributeVar!] !SymbolType
| PD_Class ClassDef [ParsedDefinition]
| PD_Instance ParsedInstanceAndMembers
| PD_Instances [ParsedInstanceAndMembers]
......@@ -284,6 +285,8 @@ cIsNotAFunction :== False
:: FunKind = FK_Function !Bool | FK_Macro | FK_Caf | FK_NodeDefOrFunction | FK_Unknown
| FK_FunctionWithDerive !Int !Int
:: ATypeVarOrAttributeVar = ATypeVar !ATypeVar | AttributeVar !AttributeVar | NoATypeVarOrAttributeVar
:: StrictnessList = NotStrict | Strict !Int | StrictList !Int StrictnessList
cNameNotLocationDependent :== False
......@@ -758,6 +761,8 @@ FI_HasLocalGenerate :== 2048
:: FunDefType = FunDefType !SymbolType
| NoFunDefType
| LocalFunDefType ![!ATypeVarOrAttributeVar!] !SymbolType
| LocalFunDefCheckedType ![!TypeVar!] ![!AttributeVar!] !SymbolType
:: FunDef =
{ fun_ident :: !Ident
......
......@@ -907,9 +907,6 @@ where
(<<<) file
(STE_TypeVariable _)
= file <<< "STE_TypeVariable"
(<<<) file
(STE_TypeAttribute _)
= file <<< "STE_TypeAttribute"
(<<<) file
(STE_BoundTypeVariable _)
= file <<< "STE_BoundTypeVariable"
......
......@@ -4,7 +4,13 @@ import StdEnv,StdOverloadedList,compare_types
import syntax, typesupport, check, analtypes, overloading, unitype, refmark, predef, utilities, compare_constructor
import check_instances, genericsupport
:: FunctionType | TypeWithPropagationAttributes !SymbolType
:: FunctionType
| SpecifiedType !SymbolType ![AType] !TempSymbolType
| ExpandedType !SymbolType !TempSymbolType !TempSymbolType
| SpecifiedLocalFunType !SymbolType ![!P TypeVar Type!] ![!P AttributeVar TypeAttribute!] ![AType] !TempSymbolType
| ExpandedLocalFunType !SymbolType ![!P TypeVar Type!] ![!P AttributeVar TypeAttribute!] !TempSymbolType !TempSymbolType
| TypeWithPropagationAttributes !SymbolType
| EmptyFunctionType
:: TypeInput =
! { ti_common_defs :: !{# CommonDefs }
......@@ -144,6 +150,13 @@ where
(changed_y, y, subst) = arraySubst y subst
= (changed_x || changed_y, (x,y), subst)
instance arraySubst (P a b) | arraySubst a & arraySubst b
where
arraySubst (P x y) subst
# (changed_x, x, subst) = arraySubst x subst
(changed_y, y, subst) = arraySubst y subst
= (changed_x || changed_y, P x y, subst)
instance arraySubst [a] | arraySubst a
where
arraySubst [] subst
......@@ -154,6 +167,22 @@ where
= (True, [type : types ], subst)
= (False, t, subst)
instance arraySubst [!a!] | arraySubst a
where
arraySubst [!!] subst
= (False, [!!], subst)