diff options
Diffstat (limited to 'frontend')
| -rw-r--r-- | frontend/convertDynamics.icl | 6 | ||||
| -rw-r--r-- | frontend/overloading.icl | 28 | ||||
| -rw-r--r-- | frontend/postparse.icl | 49 | ||||
| -rw-r--r-- | frontend/syntax.dcl | 2 | ||||
| -rw-r--r-- | frontend/typereify.icl | 35 |
5 files changed, 20 insertions, 100 deletions
diff --git a/frontend/convertDynamics.icl b/frontend/convertDynamics.icl index d5c8a59..df56c4e 100644 --- a/frontend/convertDynamics.icl +++ b/frontend/convertDynamics.icl @@ -646,14 +646,12 @@ where # predef_type_index = type_index + FirstTypePredefinedSymbolIndex = constructorExp (predefinedTypeConstructor predef_type_index) SK_Function 0 ci - typeConstructor (GTT_Constructor cons_ident fun_ident) ci - # type_cons - = App {app_symb = cons_ident, app_args = [], app_info_ptr = nilPtr} + typeConstructor (GTT_Constructor fun_ident) ci # type_fun = App {app_symb = fun_ident, app_args = [], app_info_ptr = nilPtr} # (to_tc_symb, ci) = getSymbol PD_Dyn__to_TypeCodeConstructor SK_Function 2 ci - = (App {app_symb = to_tc_symb, app_args = [type_cons, type_fun], app_info_ptr = nilPtr}, ci) + = (App {app_symb = to_tc_symb, app_args = [type_fun], app_info_ptr = nilPtr}, ci) typeConstructor (GTT_Basic basic_type) ci = constructorExp (basicTypeConstructor basic_type) SK_Function 0 ci typeConstructor GTT_Function ci diff --git a/frontend/overloading.icl b/frontend/overloading.icl index a8d6729..a8cd068 100644 --- a/frontend/overloading.icl +++ b/frontend/overloading.icl @@ -1293,35 +1293,19 @@ toTypeCodeConstructor type=:{glob_object=type_index, glob_module=module_index} c | module_index == cPredefinedModuleIndex = GTT_PredefTypeConstructor type // otherwise - # tc_type_index - = type_index + 1 - # types - = common_defs.[module_index].com_type_defs - // sanity check ... - # type_ident - = types.[type_index].td_ident.id_name + # type + = common_defs.[module_index].com_type_defs.[type_index] # td_fun_index - = types.[type_index].td_fun_index - # tc_type_name - = types.[tc_type_index].td_ident.id_name - | "TC;" +++ type_ident <> tc_type_name - = fatal "toTypeCodeConstructor" ("name mismatch (" +++ type_ident +++ ", " +++ tc_type_name +++ ")") - // ... sanity check - # ({td_rhs=AlgType [{ds_ident, ds_index}:_]}) - = types.[tc_type_index] - # type_constructor - = { symb_ident = ds_ident - , symb_kind = SK_Constructor {glob_module = module_index, glob_object = ds_index} - } + = type.td_fun_index // sanity check ... | td_fun_index == NoIndex - = fatal "toTypeCodeConstructor" ("no function (" +++ type_ident +++ ")") + = fatal "toTypeCodeConstructor" ("no function (" +++ type.td_ident.id_name +++ ")") // ... sanity check # type_fun - = { symb_ident = {ds_ident & id_info = nilPtr} // this is wrong but let's give it a try + = { symb_ident = {type.td_ident & id_info = nilPtr} // this is wrong but let's give it a try , symb_kind = SK_Function {glob_module = module_index, glob_object = td_fun_index} } - = GTT_Constructor type_constructor type_fun + = GTT_Constructor type_fun fatal :: {#Char} {#Char} -> .a fatal function_name message diff --git a/frontend/postparse.icl b/frontend/postparse.icl index 85d5d91..a440111 100644 --- a/frontend/postparse.icl +++ b/frontend/postparse.icl @@ -1477,54 +1477,9 @@ reorganiseDefinitionsAndAddTypes mod_ident support_dynamics icl_module defs ca , import_file_position = NoPos } # imports = if (mod_ident == clean_types_module_ident) [] [clean_types_module] - # (rev_defs, ca) - = addTypeConstructors defs [PD_Import imports] ca - = reorganiseDefinitions icl_module (reverse rev_defs) 0 0 0 0 ca + = reorganiseDefinitions icl_module [PD_Import imports : defs] 0 0 0 0 ca + // otherwise = reorganiseDefinitions icl_module defs 0 0 0 0 ca - where - addTypeConstructors [] rev_defs ca - = (rev_defs, ca) - addTypeConstructors [PD_Type type_def : defs] rev_defs ca - # (type_def, tc_def, ca) - = addTypeConstructor type_def ca - = addTypeConstructors defs [PD_Type tc_def, PD_Type type_def : rev_defs] ca - addTypeConstructors [def : defs] rev_defs ca - = addTypeConstructors defs [def : rev_defs] ca - -addTypeConstructor def=:{td_ident, td_attribute, td_attrs, td_args, td_arity, td_pos} ca=:{ca_hash_table} - # tc_name = "TC;" +++ td_ident.id_name - # ({boxed_ident=tc_cons_ident}, ca_hash_table) = putIdentInHashTable tc_name IC_Expression ca_hash_table - # ({boxed_ident=tc_type_ident}, ca_hash_table) = putIdentInHashTable tc_name IC_Type ca_hash_table - = (def, type_tc_def tc_type_ident tc_cons_ident td_ident td_attribute td_attrs td_args - td_arity td_pos, { ca & ca_hash_table = ca_hash_table }) - where - type_tc_def ident cons_ident type_ident attr attrs args arity position - = { td_ident = ident - , td_index = NoIndex - , td_arity = arity - , td_args = args - , td_attrs = attrs - , td_context = [] - , td_rhs = ConsList [type_tc_cons cons_ident type_ident args arity position] - , td_attribute = attr - , td_pos = position - , td_used_types = [] - , td_fun_index = NoIndex - } - type_tc_cons cons_ident type_ident args arity position - = { pc_cons_ident = cons_ident - , pc_cons_arity = 1 - , pc_exi_vars = [] - , pc_arg_types = [type type_ident args arity] - , pc_args_strictness = NotStrict - , pc_cons_prio = NoPrio - , pc_cons_pos = position - } - type type_ident args arity - = { at_attribute = TA_None - , at_type = TA (MakeNewTypeSymbIdent type_ident arity) - [{at_attribute = TA_None, at_type = TV arg.atv_variable} \\ arg <- args] - } belongsToTypeSpec name prio new_name is_infix :== name == new_name && sameFixity prio is_infix diff --git a/frontend/syntax.dcl b/frontend/syntax.dcl index e28c750..d36f318 100644 --- a/frontend/syntax.dcl +++ b/frontend/syntax.dcl @@ -1289,7 +1289,7 @@ instance == OverloadedListType :: GlobalTCType = GTT_Basic !BasicType - | GTT_Constructor !SymbIdent !SymbIdent // type_cons type_fun + | GTT_Constructor !SymbIdent | GTT_PredefTypeConstructor !(Global Index) | GTT_Function diff --git a/frontend/typereify.icl b/frontend/typereify.icl index 3f4c1cf..8085c9a 100644 --- a/frontend/typereify.icl +++ b/frontend/typereify.icl @@ -598,8 +598,8 @@ instance reify GlobalTCType where # predef_type_index = type_index + FirstTypePredefinedSymbolIndex = function (predefinedTypeConstructor predef_type_index) - reify (GTT_Constructor type_cons type_fun) - = function PD_Dyn__to_TypeCodeConstructor ` type_cons ` type_fun + reify (GTT_Constructor type_fun) + = function PD_Dyn__to_TypeCodeConstructor ` type_fun predefinedTypeConstructor predef_type_index | predef_type_index == PD_ListType @@ -638,38 +638,21 @@ basic value // copied and adopted from overloading toTypeCodeConstructor type=:{glob_object=type_index, glob_module=module_index} common_defs | module_index == cPredefinedModuleIndex - = GTT_PredefTypeConstructor type + = GTT_PredefTypeConstructor type // otherwise - # tc_type_index - = type_index + 1 - # types - = common_defs.[module_index].com_type_defs - // sanity check ... - # type_ident - = types.[type_index].td_ident.id_name - # tc_type_name - = types.[tc_type_index].td_ident.id_name - | "TC;" +++ type_ident <> tc_type_name - = fatal "toTypeCodeConstructor" ("name mismatch (" +++ type_ident +++ ", " +++ tc_type_name +++ ")") - // ... sanity check - # ({td_rhs=AlgType [{ds_ident, ds_index}:_]}) - = types.[tc_type_index] - # type_constructor - = { symb_ident = ds_ident - , symb_kind = SK_Constructor {glob_module = module_index, glob_object = ds_index} - } + # type + = common_defs.[module_index].com_type_defs.[type_index] # td_fun_index - = types.[type_index].td_fun_index + = type.td_fun_index // sanity check ... | td_fun_index == NoIndex - = fatal "toTypeCodeConstructor" ("no function (" +++ type_ident - +++ " type " +++ toString type_index +++ " module " +++ toString module_index +++ ")") + = fatal "toTypeCodeConstructor" ("no function (" +++ type.td_ident.id_name +++ ")") // ... sanity check # type_fun - = { symb_ident = {ds_ident & id_info = nilPtr} // this is wrong but let's give it a try + = { symb_ident = {type.td_ident & id_info = nilPtr} // this is wrong but let's give it a try , symb_kind = SK_Function {glob_module = module_index, glob_object = td_fun_index} } - = GTT_Constructor type_constructor type_fun + = GTT_Constructor type_fun fatal :: {#Char} {#Char} -> .a fatal function_name message |