diff options
| -rw-r--r-- | frontend/analtypes.icl | 6 | ||||
| -rw-r--r-- | frontend/check.icl | 34 | ||||
| -rw-r--r-- | frontend/explicitimports.icl | 4 | ||||
| -rw-r--r-- | frontend/generics1.icl | 4 | ||||
| -rw-r--r-- | frontend/parse.icl | 74 | ||||
| -rw-r--r-- | frontend/syntax.dcl | 12 | ||||
| -rw-r--r-- | frontend/syntax.icl | 7 |
7 files changed, 89 insertions, 52 deletions
diff --git a/frontend/analtypes.icl b/frontend/analtypes.icl index 7940696..619426d 100644 --- a/frontend/analtypes.icl +++ b/frontend/analtypes.icl @@ -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 diff --git a/frontend/check.icl b/frontend/check.icl index cc35a74..1c99f9c 100644 --- a/frontend/check.icl +++ b/frontend/check.icl @@ -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) diff --git a/frontend/explicitimports.icl b/frontend/explicitimports.icl index ad6f224..9e692e8 100644 --- a/frontend/explicitimports.icl +++ b/frontend/explicitimports.icl @@ -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 diff --git a/frontend/generics1.icl b/frontend/generics1.icl index bdd297c..8fbd05d 100644 --- a/frontend/generics1.icl +++ b/frontend/generics1.icl @@ -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} diff --git a/frontend/parse.icl b/frontend/parse.icl index 9bbbf07..6c0b1ec 100644 --- a/frontend/parse.icl +++ b/frontend/parse.icl @@ -1,7 +1,7 @@ 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) diff --git a/frontend/syntax.dcl b/frontend/syntax.dcl index a689b8c..6bf9923 100644 --- a/frontend/syntax.dcl +++ b/frontend/syntax.dcl @@ -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 diff --git a/frontend/syntax.icl b/frontend/syntax.icl index b670b7e..fc47517 100644 --- a/frontend/syntax.icl +++ b/frontend/syntax.icl @@ -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]=='_' |