Commit dd4f5c27 authored by John van Groningen's avatar John van Groningen
Browse files

add instance declarations with a qualified class name

parent 6fbe0922
......@@ -1018,12 +1018,12 @@ where
= check_kinds_of_class_instances common_defs (inc instance_index) instance_defs class_infos as
where
check_kinds_of_class_instance :: !{#CommonDefs} !ClassInstance !*ClassDefInfos !*AnalyseState -> (!*ClassDefInfos, !*AnalyseState)
check_kinds_of_class_instance common_defs {ins_class_index,ins_class_ident={ci_ident,ci_arity},ins_ident,ins_pos,ins_type={it_vars,it_types,it_context}} class_infos
check_kinds_of_class_instance common_defs {ins_class_index,ins_class_ident={ci_ident=Ident class_ident,ci_arity},ins_ident,ins_pos,ins_type={it_vars,it_types,it_context}} class_infos
as=:{as_type_var_heap,as_kind_heap,as_error}
# as_error = pushErrorAdmin (newPosition ins_ident ins_pos) as_error
(as_type_var_heap, as_kind_heap) = bindFreshKindVariablesToTypeVars it_vars as_type_var_heap as_kind_heap
as = { as & as_type_var_heap = as_type_var_heap, as_kind_heap = as_kind_heap, as_error = as_error }
ins_class = {glob_module=ins_class_index.gi_module,glob_object={ds_index=ins_class_index.gi_index,ds_ident=ci_ident,ds_arity=ci_arity}}
ins_class = {glob_module=ins_class_index.gi_module,glob_object={ds_index=ins_class_index.gi_index,ds_ident=class_ident,ds_arity=ci_arity}}
context = {tc_class = TCClass ins_class, tc_types = it_types, tc_var = nilPtr}
(class_infos, as) = determine_kinds_of_type_contexts common_defs [context : it_context] class_infos as
= (class_infos, { as & as_error = popErrorAdmin as.as_error})
......@@ -1107,7 +1107,7 @@ where
(class_infos, as) = check_kinds_of_symbol_type common_defs ft_type class_infos
{ as & as_error = as_error }
= (class_infos, { as & as_error = popErrorAdmin as.as_error})
check_kinds_of_symbol_type :: !{#CommonDefs} !SymbolType !*ClassDefInfos !*AnalyseState -> (!*ClassDefInfos, !*AnalyseState)
check_kinds_of_symbol_type common_defs {st_vars,st_result,st_args,st_context} class_infos as=:{as_type_var_heap,as_kind_heap}
# (as_type_var_heap, as_kind_heap) = bindFreshKindVariablesToTypeVars st_vars as_type_var_heap as_kind_heap
......
......@@ -180,23 +180,38 @@ where
= (instance_defs, is, type_heaps, cs)
check_instance :: !ClassInstance !Index !u:InstanceSymbols !*TypeHeaps !*CheckState -> (!ClassInstance, !u:InstanceSymbols, !*TypeHeaps, !*CheckState)
check_instance ins=:{ins_class_ident={ci_ident={id_name,id_info}},ins_pos,ins_ident} module_index is type_heaps cs=:{cs_symbol_table}
# (entry, cs_symbol_table) = readPtr id_info cs_symbol_table
check_instance ins=:{ins_class_ident={ci_ident=Ident {id_name,id_info}},ins_pos,ins_ident} module_index is type_heaps cs=:{cs_symbol_table}
# ({ste_index,ste_kind}, cs_symbol_table) = readPtr id_info cs_symbol_table
# cs = pushErrorAdmin (newPosition ins_ident ins_pos) { cs & cs_symbol_table = cs_symbol_table }
# (ins, is, type_heaps, cs) = case entry.ste_kind of
# (ins, is, type_heaps, cs) = case ste_kind of
STE_Class
# (class_def, is) = is!is_class_defs.[entry.ste_index]
-> check_class_instance class_def module_index entry.ste_index module_index ins is type_heaps cs
STE_Imported STE_Class decl_index
# (class_def, is) = is!is_modules.[decl_index].dcl_common.com_class_defs.[entry.ste_index]
-> check_class_instance class_def module_index entry.ste_index decl_index ins is type_heaps cs
# (class_def, is) = is!is_class_defs.[ste_index]
-> check_class_instance class_def module_index ste_index module_index ins is type_heaps cs
STE_Imported STE_Class decl_index
# (class_def, is) = is!is_modules.[decl_index].dcl_common.com_class_defs.[ste_index]
-> check_class_instance class_def module_index ste_index decl_index ins is type_heaps cs
ste -> (ins, is, type_heaps, { cs & cs_error = checkError id_name "class undefined" cs.cs_error })
= (ins, is, type_heaps, popErrorAdmin cs)
check_instance ins=:{ins_class_ident={ci_ident=QualifiedIdent module_ident class_name},ins_pos,ins_ident}
module_index is type_heaps cs
# cs = pushErrorAdmin (newPosition ins_ident ins_pos) cs
# (found,{decl_kind,decl_ident=type_ident,decl_index=class_index},cs) = search_qualified_ident module_ident class_name ClassNameSpaceN cs
| not found
# cs = {cs & cs_error = checkError ("'"+++module_ident.id_name+++"'."+++class_name) "class undefined" cs.cs_error}
= (ins, is, type_heaps, popErrorAdmin cs)
= case decl_kind of
STE_Imported STE_Class class_module
# (class_def, is) = is!is_modules.[class_module].dcl_common.com_class_defs.[class_index]
# ins = {ins & ins_class_ident.ci_ident=Ident class_def.class_ident}
-> check_class_instance class_def module_index class_index class_module ins is type_heaps cs
_
# cs = {cs & cs_error = checkError ("'"+++module_ident.id_name+++"'."+++class_name) "class undefined" cs.cs_error}
-> (ins, is, type_heaps, popErrorAdmin cs)
check_class_instance :: ClassDef !Index !Index !Index !ClassInstance !u:InstanceSymbols !*TypeHeaps !*CheckState
-> (!ClassInstance, !u:InstanceSymbols, !*TypeHeaps, !*CheckState)
check_class_instance class_def module_index class_index class_mod_index
ins=:{ins_class_ident=ins_class_ident=:{ci_ident={id_name,id_info},ci_arity},ins_type,ins_specials,ins_pos,ins_ident}
ins=:{ins_class_ident=ins_class_ident=:{ci_ident,ci_arity},ins_type,ins_specials,ins_pos,ins_ident}
is=:{is_class_defs,is_modules} type_heaps cs=:{cs_symbol_table}
| class_def.class_arity == ci_arity
# ins_class_index = {gi_index = class_index, gi_module = class_mod_index}
......@@ -205,6 +220,7 @@ where
is.is_type_defs is.is_class_defs is.is_modules type_heaps cs
is = { is & is_type_defs = is_type_defs, is_class_defs = is_class_defs, is_modules = is_modules }
= ({ins & ins_class_index = ins_class_index, ins_type = ins_type, ins_specials = ins_specials}, is, type_heaps, cs)
# (Ident {id_name}) = ci_ident
# cs = {cs & cs_error = checkError id_name ("wrong arity: expected "+++toString class_def.class_arity+++" found "+++toString ci_arity) cs.cs_error}
= (ins, is, type_heaps, cs)
......
......@@ -600,9 +600,9 @@ instance check_completeness ClassDef where
= check_completeness class_context cci ccs
instance check_completeness ClassInstance where
check_completeness {ins_class_index={gi_module,gi_index},ins_class_ident={ci_ident},ins_type} cci ccs
check_completeness {ins_class_index={gi_module,gi_index},ins_class_ident={ci_ident=Ident class_ident},ins_type} cci ccs
= check_completeness ins_type cci
(check_whether_ident_is_imported ci_ident gi_module gi_index STE_Class cci ccs)
(check_whether_ident_is_imported class_ident gi_module gi_index STE_Class cci ccs)
instance check_completeness ConsDef
where
......
......@@ -1841,7 +1841,7 @@ where
#! class_ident = genericIdentToClassIdent gc_ident.id_name this_kind
#! ins =
{ ins_class_index = {gi_module=gs_main_module, gi_index=class_index}
, ins_class_ident = {ci_ident=class_ident, ci_arity=1}
, ins_class_ident = {ci_ident=Ident class_ident, ci_arity=1}
, ins_ident = class_ident
, ins_type = ins_type
, ins_members = {{cim_ident=ds_ident,cim_arity=ds_arity,cim_index=ds_index}}
......@@ -1920,7 +1920,7 @@ where
# class_ds = {ds_index = class_index, ds_arity=1, ds_ident=class_ident}
#! ins =
{ ins_class_index = {gi_module=gs_main_module, gi_index=class_index}
, ins_class_ident = {ci_ident=class_ident, ci_arity=1}
, ins_class_ident = {ci_ident=Ident class_ident, ci_arity=1}
, ins_ident = class_ident
, ins_type = ins_type
, ins_members = {class_instance_member}
......
implementation module parse
import StdEnv
import scanner, syntax, hashtable, utilities, predef, containers, compilerSwitches
import scanner, syntax, hashtable, utilities, predef, containers
ParseOnly :== False
......@@ -715,7 +715,7 @@ where
# (subst, pState) = want_rest_substitutions type_var pState
= (True, subst, wantEndOfDefinition "substitution" pState)
= (False, [], pState)
want_rest_substitutions type_var pState
# pState = wantToken GeneralContext "specials" EqualToken pState
(type, pState) = want pState
......@@ -1341,37 +1341,47 @@ wantClassDefinition parseContext pos pState
wantInstanceDeclaration :: !ParseContext !Position !ParseState -> (!ParsedDefinition, !ParseState)
wantInstanceDeclaration parseContext pi_pos pState
# (class_name, pState) = want pState
(pi_class, pState) = stringToIdent class_name IC_Class pState
((pi_types, pi_context), pState) = want_instance_type pState
(pi_ident, pState) = stringToIdent class_name (IC_Instance pi_types) pState
# (token, pState) = nextToken TypeContext pState
| isIclContext parseContext
# pState = want_begin_group token pState
(pi_members, pState) = wantDefinitions (SetClassOrInstanceDefsContext parseContext) pState
pState = wantEndGroup "instance" pState
= (PD_Instance {pi_class = pi_class, pi_ident = pi_ident, pi_types = pi_types, pi_context = pi_context,
pi_members = pi_members, pi_specials = SP_None, pi_pos = pi_pos}, pState)
// otherwise // ~ (isIclContext parseContext)
| token == CommaToken
# (pi_types_and_contexts, pState) = want_instance_types pState
(idents, pState) = seqList [stringToIdent class_name (IC_Instance type) \\ (type,context) <- pi_types_and_contexts] pState
= (PD_Instances
[ { pi_class = pi_class, pi_ident = ident, pi_types = type, pi_context = context
, pi_members = [], pi_specials = SP_None, pi_pos = pi_pos}
\\ (type,context) <- [ (pi_types, pi_context) : pi_types_and_contexts ]
& ident <- [ pi_ident : idents ]
]
, pState
)
// otherwise // token <> CommaToken
# (specials, pState) = optionalSpecials (tokenBack pState)
pState = wantEndOfDefinition "instance declaration" pState
# (token, pState) = nextToken GeneralContext pState
= case token of
IdentToken class_name
# (pi_class, pState) = stringToIdent class_name IC_Class pState
-> want_instance_declaration class_name (Ident pi_class) parseContext pi_pos pState
QualifiedIdentToken module_name class_name
# (module_ident, pState) = stringToQualifiedModuleIdent module_name class_name IC_Class pState
-> want_instance_declaration class_name (QualifiedIdent module_ident class_name) parseContext pi_pos pState
_
# pState = parseError "String" (Yes token) "identifier" pState
# (pi_class, pState) = stringToIdent "" IC_Class pState
-> want_instance_declaration "" (Ident pi_class) parseContext pi_pos pState
where
want_instance_declaration class_name pi_class parseContext pi_pos pState
# ((pi_types, pi_context), pState) = want_instance_type pState
(pi_ident, pState) = stringToIdent class_name (IC_Instance pi_types) pState
# (token, pState) = nextToken TypeContext pState
| isIclContext parseContext
# pState = want_begin_group token pState
(pi_members, pState) = wantDefinitions (SetClassOrInstanceDefsContext parseContext) pState
pState = wantEndGroup "instance" pState
= (PD_Instance {pi_class = pi_class, pi_ident = pi_ident, pi_types = pi_types, pi_context = pi_context,
pi_members = [], pi_specials = specials, pi_pos = pi_pos}, pState)
where
pi_members = pi_members, pi_specials = SP_None, pi_pos = pi_pos}, pState)
// otherwise // ~ (isIclContext parseContext)
| token == CommaToken
# (pi_types_and_contexts, pState) = want_instance_types pState
(idents, pState) = seqList [stringToIdent class_name (IC_Instance type) \\ (type,context) <- pi_types_and_contexts] pState
= (PD_Instances
[ { pi_class = pi_class, pi_ident = ident, pi_types = type, pi_context = context
, pi_members = [], pi_specials = SP_None, pi_pos = pi_pos}
\\ (type,context) <- [ (pi_types, pi_context) : pi_types_and_contexts ]
& ident <- [ pi_ident : idents ]
]
, pState
)
// otherwise // token <> CommaToken
# (specials, pState) = optionalSpecials (tokenBack pState)
pState = wantEndOfDefinition "instance declaration" pState
= (PD_Instance {pi_class = pi_class, pi_ident = pi_ident, pi_types = pi_types, pi_context = pi_context,
pi_members = [], pi_specials = specials, pi_pos = pi_pos}, pState)
want_begin_group token pState // For JvG layout
# // (token, pState) = nextToken TypeContext pState PK
(token, pState)
......
......@@ -295,7 +295,7 @@ cNameLocationDependent :== True
}
:: ParsedInstance member =
{ pi_class :: !Ident
{ pi_class :: !IdentOrQualifiedIdent
, pi_ident :: !Ident
, pi_types :: ![Type]
, pi_context :: ![TypeContext]
......@@ -304,6 +304,10 @@ cNameLocationDependent :== True
, pi_specials :: !Specials
}
:: IdentOrQualifiedIdent
= Ident !Ident
| QualifiedIdent /*module*/!Ident !String
/*
Objects of type Specials are used to specify specialized instances of overloaded functions.
These can only occur in definition modules. After parsing the SP_ParsedSubstitutions alternative
......@@ -449,7 +453,7 @@ cNameLocationDependent :== True
}
:: ClassIdent =
{ ci_ident :: !Ident
{ ci_ident :: !IdentOrQualifiedIdent
, ci_arity :: !Int
}
......@@ -666,7 +670,7 @@ cIsALocalVar :== False
, cc_linear_bits ::![Bool]
, cc_producer ::!ProdClass
}
:: ConsClass :== Int
:: ProdClass :== Bool
......@@ -1436,7 +1440,7 @@ instance <<< (Module a) | <<< a, ParsedDefinition, InstanceType, AttributeVar, T
IndexRange,
FunType,
GenericClassInfo,
TCClass
TCClass, IdentOrQualifiedIdent
instance <<< FunctionBody
......
......@@ -941,6 +941,13 @@ where
_
= file <<< "STE_???"
instance <<< IdentOrQualifiedIdent
where
(<<<) file (Ident ident)
= file <<< ident
(<<<) file (QualifiedIdent module_ident name)
= file<<<'\''<<<module_ident<<<"'."<<<name
readable :: !Ident -> String // somewhat hacky
readable {id_name}
| size id_name>0 && id_name.[0]=='_'
......
Supports Markdown
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