diff options
Diffstat (limited to 'frontend')
| -rw-r--r-- | frontend/analtypes.icl | 317 | ||||
| -rw-r--r-- | frontend/analunitypes.icl | 17 | ||||
| -rw-r--r-- | frontend/check.icl | 16 | ||||
| -rw-r--r-- | frontend/checkFunctionBodies.icl | 428 | ||||
| -rw-r--r-- | frontend/checktypes.icl | 11 | ||||
| -rw-r--r-- | frontend/comparedefimp.icl | 31 | ||||
| -rw-r--r-- | frontend/mergecases.icl | 41 | ||||
| -rw-r--r-- | frontend/overloading.icl | 139 | ||||
| -rw-r--r-- | frontend/parse.icl | 97 | ||||
| -rw-r--r-- | frontend/partition.icl | 2 | ||||
| -rw-r--r-- | frontend/postparse.icl | 7 | ||||
| -rw-r--r-- | frontend/refmark.icl | 3 | ||||
| -rw-r--r-- | frontend/syntax.dcl | 11 | ||||
| -rw-r--r-- | frontend/syntax.icl | 6 | ||||
| -rw-r--r-- | frontend/trans.icl | 12 | ||||
| -rw-r--r-- | frontend/transform.icl | 26 | ||||
| -rw-r--r-- | frontend/type.dcl | 3 | ||||
| -rw-r--r-- | frontend/type.icl | 65 | ||||
| -rw-r--r-- | frontend/typesupport.icl | 29 | ||||
| -rw-r--r-- | frontend/unitype.icl | 16 |
20 files changed, 887 insertions, 390 deletions
diff --git a/frontend/analtypes.icl b/frontend/analtypes.icl index 8dfde96..7ab73ed 100644 --- a/frontend/analtypes.icl +++ b/frontend/analtypes.icl @@ -7,7 +7,7 @@ import syntax, checksupport, checktypes, check, typesupport, utilities, analunit :: PartitioningInfo = { pi_marks :: !.{# .{# Int}} - , pi_type_defs :: !.{# .{# CheckedTypeDef}} + , pi_type_defs :: ! {# {# CheckedTypeDef}} , pi_type_def_infos :: !.TypeDefInfos , pi_next_num :: !Int , pi_next_group_num :: !Int @@ -19,19 +19,20 @@ import syntax, checksupport, checktypes, check, typesupport, utilities, analunit cNotPartitionated :== -1 cChecking :== -1 -partionateAndExpandTypes :: !NumberSet !Index !*CommonDefs !*{#DclModule} !*TypeHeaps !*ErrorAdmin - -> (!TypeGroups, !*{# CommonDefs}, !*TypeDefInfos, !*CommonDefs, !*{#DclModule}, !*TypeHeaps, !*ErrorAdmin) -partionateAndExpandTypes used_module_numbers main_dcl_module_index icl_common=:{com_type_defs,com_class_defs} dcl_modules type_heaps error +partionateAndExpandTypes :: !NumberSet !Index !*CommonDefs !*{#DclModule} !*TypeHeaps !*ErrorAdmin + -> (!TypeGroups, !*{# CommonDefs}, !*TypeDefInfos, !*CommonDefs,!*{#DclModule},!*TypeHeaps,!*ErrorAdmin) +partionateAndExpandTypes used_module_numbers main_dcl_module_index icl_common=:{com_type_defs,com_cons_defs,com_class_defs} dcl_modules type_heaps error #! nr_of_modules = size dcl_modules -// #! nr_of_types_in_icl_mod = size com_type_defs - size com_class_defs #! n_exported_dictionaries = size dcl_modules.[main_dcl_module_index].dcl_common.com_class_defs #! index_of_first_not_exported_type_or_dictionary = size dcl_modules.[main_dcl_module_index].dcl_common.com_type_defs #! n_exported_icl_types = index_of_first_not_exported_type_or_dictionary - n_exported_dictionaries #! n_types_without_not_exported_dictionaries = size com_type_defs - (size com_class_defs - n_exported_dictionaries) - # (dcl_type_defs, dcl_modules, new_type_defs, new_marks, type_def_infos) - = copy_type_defs_and_create_marks_and_infos used_module_numbers main_dcl_module_index n_types_without_not_exported_dictionaries nr_of_modules (com_type_defs, dcl_modules) - pi = {pi_marks = new_marks, pi_type_defs = new_type_defs, pi_type_def_infos = type_def_infos, + # (dcl_type_defs,dcl_modules) = dcl_modules![main_dcl_module_index].dcl_common.com_type_defs + # (dcl_modules, type_defs, new_marks, type_def_infos) + = create_type_defs_marks_and_infos used_module_numbers main_dcl_module_index n_types_without_not_exported_dictionaries nr_of_modules (com_type_defs, dcl_modules) + + pi = {pi_marks = new_marks, pi_type_defs = type_defs, pi_type_def_infos = type_def_infos, pi_next_num = 0, pi_deps = [], pi_next_group_num = 0, pi_groups = [], pi_error = error } {pi_error,pi_groups,pi_type_defs,pi_type_def_infos} = iFoldSt partionate_type_defs 0 nr_of_modules pi @@ -49,106 +50,197 @@ partionateAndExpandTypes used_module_numbers main_dcl_module_index icl_common=:{ # (_, pi) = partitionateTypeDef {gi_module = module_index, gi_index = type_index} pi = pi = pi - | not pi_error.ea_ok - # (icl_type_defs, type_defs) = replace pi_type_defs main_dcl_module_index dcl_type_defs - (dcl_modules, common_defs) = update_modules_and_create_commondefs used_module_numbers type_defs nr_of_modules dcl_modules - = (reverse pi_groups, common_defs, pi_type_def_infos, {icl_common & com_type_defs = icl_type_defs }, dcl_modules, type_heaps, pi_error) - - # (type_defs, dcl_type_defs, type_heaps, error) - = foldSt (expand_synonym_types_of_group main_dcl_module_index) pi_groups (pi_type_defs, dcl_type_defs, type_heaps, pi_error) - (icl_type_defs, type_defs) = replace type_defs main_dcl_module_index dcl_type_defs - (dcl_modules, common_defs) = update_modules_and_create_commondefs used_module_numbers type_defs nr_of_modules dcl_modules - = (reverse pi_groups, common_defs, pi_type_def_infos, {icl_common & com_type_defs = icl_type_defs}, dcl_modules, type_heaps, error) + + # icl_type_defs = pi_type_defs.[main_dcl_module_index] + + icl_type_defs = { icl_type_def \\ icl_type_def <-: icl_type_defs} + new_type_defs = { {} \\ module_n <- [0..nr_of_modules-1] } + icl_cons_defs = com_cons_defs + new_cons_defs = { {} \\ module_n <- [0..nr_of_modules-1] } + + (new_type_defs, icl_type_defs, new_cons_defs, icl_cons_defs, type_heaps, dcl_modules, error) + = expand_synonym_types_of_groups main_dcl_module_index pi_groups + (new_type_defs, icl_type_defs, new_cons_defs, icl_cons_defs, type_heaps, dcl_modules, pi_error) + + icl_common = {icl_common & com_type_defs = icl_type_defs, com_cons_defs = icl_cons_defs} + (dcl_modules, common_defs) = update_modules_and_create_commondefs used_module_numbers new_type_defs new_cons_defs nr_of_modules dcl_modules + = (reverse pi_groups, common_defs, pi_type_def_infos, icl_common, dcl_modules, type_heaps, error) where - copy_type_defs_and_create_marks_and_infos used_module_numbers main_dcl_module_index n_types_without_not_exported_dictionaries nr_of_modules (icl_type_defs, dcl_modules) - # type_defs = { {} \\ module_nr <- [1..nr_of_modules] } - marks = { {} \\ module_nr <- [1..nr_of_modules] } - type_def_infos = { {} \\ module_nr <- [1..nr_of_modules] } - = iFoldSt (copy_type_def_and_create_marks_and_infos used_module_numbers main_dcl_module_index n_types_without_not_exported_dictionaries) 0 nr_of_modules - (icl_type_defs, dcl_modules, type_defs, marks, type_def_infos) + create_type_defs_marks_and_infos :: NumberSet Int Int Int (*{#CheckedTypeDef},*{#DclModule}) -> (!*{#DclModule},!*{#*{#CheckedTypeDef}},!*{#*{#Int}},!*TypeDefInfos) + create_type_defs_marks_and_infos used_module_numbers main_dcl_module_index n_types_without_not_exported_dictionaries nr_of_modules (icl_type_defs, dcl_modules) + # type_defs = { {} \\ module_nr <- [0..nr_of_modules-1] } + marks = { {} \\ module_nr <- [0..nr_of_modules-1] } + type_def_infos = { {} \\ module_nr <- [0..nr_of_modules-1] } + = iFoldSt (create_type_defs_marks_and_infos_for_module used_module_numbers main_dcl_module_index n_types_without_not_exported_dictionaries icl_type_defs) + 0 nr_of_modules (dcl_modules, type_defs, marks, type_def_infos) where - copy_type_def_and_create_marks_and_infos used_module_numbers main_dcl_module_index n_types_without_not_exported_dictionaries module_index - (icl_type_defs, dcl_modules, type_defs, marks, type_def_infos) + create_type_defs_marks_and_infos_for_module used_module_numbers main_dcl_module_index n_types_without_not_exported_dictionaries icl_type_defs module_index + (dcl_modules, type_defs, marks, type_def_infos) | inNumberSet module_index used_module_numbers # ({com_type_defs,com_class_defs}, dcl_modules) = dcl_modules![module_index].dcl_common | module_index == main_dcl_module_index - = ( { type_def \\ type_def <-: com_type_defs }, dcl_modules, { type_defs & [module_index] = icl_type_defs }, + = ( dcl_modules, + { type_defs & [module_index] = icl_type_defs }, { marks & [module_index] = createArray n_types_without_not_exported_dictionaries cNotPartitionated }, { type_def_infos & [module_index] = createArray n_types_without_not_exported_dictionaries EmptyTypeDefInfo }) # nr_of_types = size com_type_defs - size com_class_defs - = ( icl_type_defs, dcl_modules, { type_defs & [module_index] = { type_def \\ type_def <-: com_type_defs }}, + = ( dcl_modules, + { type_defs & [module_index] = com_type_defs }, { marks & [module_index] = createArray nr_of_types cNotPartitionated }, { type_def_infos & [module_index] = createArray nr_of_types EmptyTypeDefInfo }) - = (icl_type_defs, dcl_modules, type_defs, marks,type_def_infos) + = (dcl_modules, type_defs, marks,type_def_infos) - expand_synonym_types_of_group main_dcl_module_index group_members (type_defs, main_dcl_type_defs, type_heaps, error) - = foldSt (expand_synonym_type main_dcl_module_index) group_members (type_defs, main_dcl_type_defs, type_heaps, error) - where - expand_synonym_type main_dcl_module_index gi=:{gi_module,gi_index} (type_defs, main_dcl_type_defs, type_heaps, error) - # (td=:{td_rhs,td_attribute}, type_defs) = type_defs![gi_module, gi_index] - = case td_rhs of - SynType type - # (opt_type, type_defs, type_heaps, error) - = try_to_expand_synonym_type (newPosition td.td_ident td.td_pos) type td_attribute (type_defs, type_heaps, error) - -> case opt_type of - Yes type - # type_defs = { type_defs & [gi_module, gi_index] = { td & td_rhs = SynType type}} - -> try_to_expand_synonym_type_in_main_dcl main_dcl_module_index gi (type_defs, main_dcl_type_defs, type_heaps, error) - No - -> (type_defs, main_dcl_type_defs, type_heaps, error) - _ - -> (type_defs, main_dcl_type_defs, type_heaps, error) - - try_to_expand_synonym_type pos type=:{at_type = TA {type_index={glob_object,glob_module}} types} attribute (type_defs, type_heaps, error) - = try_to_expand_synonym_type_for_TA glob_object glob_module types pos type attribute type_defs type_heaps error - try_to_expand_synonym_type pos type=:{at_type = TAS {type_index={glob_object,glob_module}} types _} attribute (type_defs, type_heaps, error) - = try_to_expand_synonym_type_for_TA glob_object glob_module types pos type attribute type_defs type_heaps error - try_to_expand_synonym_type pos type attribute (type_defs, type_heaps, error) - = (No, type_defs, type_heaps, error) + expand_synonym_types_of_groups main_dcl_module_index pi_groups (new_type_defs, icl_type_defs, new_cons_defs, icl_cons_defs, type_heaps, dcl_modules, error) + | not error.ea_ok + = foldSt (expand_synonym_types_of_group main_dcl_module_index) pi_groups (new_type_defs, icl_type_defs, new_cons_defs, icl_cons_defs, type_heaps, dcl_modules, error) + = (new_type_defs, icl_type_defs, new_cons_defs, icl_cons_defs, type_heaps, dcl_modules, error) - try_to_expand_synonym_type_for_TA glob_object glob_module types pos type attribute type_defs type_heaps error - # (used_td=:{td_rhs}, type_defs) = type_defs![glob_module, glob_object] - = case td_rhs of - SynType {at_type} - # ( subst_rhs, type_heaps) = substituteType used_td.td_attribute attribute used_td.td_args types at_type type_heaps - -> (Yes {type & at_type = subst_rhs }, type_defs, type_heaps, error) - _ - -> (No, type_defs, type_heaps, error) - - try_to_expand_synonym_type_in_main_dcl main_dcl_module_index {gi_module,gi_index} (type_defs, main_dcl_type_defs, type_heaps, error) - | gi_module == main_dcl_module_index && gi_index < size main_dcl_type_defs - # (td=:{td_rhs,td_attribute,td_ident,td_pos}, main_dcl_type_defs) = main_dcl_type_defs![gi_index] + expand_synonym_types_of_group main_dcl_module_index group_members (new_type_defs, icl_type_defs, new_cons_defs, icl_cons_defs, type_heaps, dcl_modules, error) + = foldSt (expand_synonym_type main_dcl_module_index) group_members (new_type_defs, icl_type_defs, new_cons_defs, icl_cons_defs, type_heaps, dcl_modules, error) + where + expand_synonym_type main_dcl_module_index gi=:{gi_module,gi_index} (new_type_defs, icl_type_defs, new_cons_defs, icl_cons_defs, type_heaps, dcl_modules, error) + | gi_module<>main_dcl_module_index + = expand_synonym_type_not_in_icl_module main_dcl_module_index gi (new_type_defs, icl_type_defs, new_cons_defs, icl_cons_defs, type_heaps, dcl_modules, error) + # (td=:{td_rhs,td_attribute}, icl_type_defs) = icl_type_defs![gi_index] = case td_rhs of SynType type - # (opt_type, type_defs, type_heaps, error) - = try_to_expand_synonym_type (newPosition td_ident td_pos) type td_attribute (type_defs, type_heaps, error) + # (opt_type, new_type_defs, icl_type_defs, type_heaps, dcl_modules) + = try_to_expand_synonym_type type td_attribute (new_type_defs, icl_type_defs, type_heaps, dcl_modules) -> case opt_type of Yes type - -> (type_defs, { main_dcl_type_defs & [gi_index] = { td & td_rhs = SynType type}}, type_heaps, error) + # icl_type_defs = { icl_type_defs & [gi_index] = { td & td_rhs = SynType type}} + | gi_index < size dcl_modules.[main_dcl_module_index].dcl_common.com_type_defs + -> expand_synonym_type_not_in_icl_module main_dcl_module_index gi (new_type_defs, icl_type_defs, new_cons_defs, icl_cons_defs, type_heaps, dcl_modules, error) + -> (new_type_defs, icl_type_defs, new_cons_defs, icl_cons_defs, type_heaps, dcl_modules, error) No - -> (type_defs, main_dcl_type_defs, type_heaps, error) + -> (new_type_defs, icl_type_defs, new_cons_defs, icl_cons_defs, type_heaps, dcl_modules, error) + NewType {ds_index} + -> expand_new_type_rhs gi_module ds_index new_type_defs icl_type_defs new_cons_defs icl_cons_defs type_heaps dcl_modules error _ - -> (type_defs, main_dcl_type_defs, type_heaps, error) - = (type_defs, main_dcl_type_defs, type_heaps, error) + -> (new_type_defs, icl_type_defs, new_cons_defs, icl_cons_defs, type_heaps, dcl_modules, error) - update_modules_and_create_commondefs used_module_numbers type_defs nr_of_modules dcl_modules + expand_synonym_type_not_in_icl_module main_dcl_module_index gi=:{gi_module,gi_index} (new_type_defs, icl_type_defs, new_cons_defs, icl_cons_defs, type_heaps, dcl_modules, error) + | size new_type_defs.[gi_module]==0 + # (td=:{td_rhs,td_attribute}, dcl_modules) = dcl_modules![gi_module].dcl_common.com_type_defs.[gi_index] + = case td_rhs of + SynType type + # (opt_type, new_type_defs, icl_type_defs, type_heaps, dcl_modules) + = try_to_expand_synonym_type type td_attribute (new_type_defs, icl_type_defs, type_heaps, dcl_modules) + -> case opt_type of + Yes type + # (com_type_defs,dcl_modules) = dcl_modules![gi_module].dcl_common.com_type_defs + # new_module_type_defs = { { type_def \\ type_def<-:com_type_defs} & [gi_index] = { td & td_rhs = SynType type}} + # new_type_defs = {new_type_defs & [gi_module] = new_module_type_defs} + -> (new_type_defs, icl_type_defs, new_cons_defs, icl_cons_defs, type_heaps, dcl_modules, error) + No + -> (new_type_defs, icl_type_defs, new_cons_defs, icl_cons_defs, type_heaps, dcl_modules, error) + NewType {ds_index} + -> expand_new_type_rhs gi_module ds_index new_type_defs icl_type_defs new_cons_defs icl_cons_defs type_heaps dcl_modules error + _ + -> (new_type_defs, icl_type_defs, new_cons_defs, icl_cons_defs, type_heaps, dcl_modules, error) + # (td=:{td_rhs,td_attribute}, new_type_defs) = new_type_defs![gi_module,gi_index] + = case td_rhs of + SynType type + # (opt_type, new_type_defs, icl_type_defs, type_heaps, dcl_modules) + = try_to_expand_synonym_type type td_attribute (new_type_defs, icl_type_defs, type_heaps, dcl_modules) + -> case opt_type of + Yes type + # new_type_defs = {new_type_defs & [gi_module,gi_index] = { td & td_rhs = SynType type}} + -> (new_type_defs, icl_type_defs, new_cons_defs, icl_cons_defs, type_heaps, dcl_modules, error) + No + -> (new_type_defs, icl_type_defs, new_cons_defs, icl_cons_defs, type_heaps, dcl_modules, error) + NewType {ds_index} + -> expand_new_type_rhs gi_module ds_index new_type_defs icl_type_defs new_cons_defs icl_cons_defs type_heaps dcl_modules error + _ + -> (new_type_defs, icl_type_defs, new_cons_defs, icl_cons_defs, type_heaps, dcl_modules, error) + + expand_new_type_rhs gi_module constructor_index new_type_defs icl_type_defs new_cons_defs icl_cons_defs type_heaps dcl_modules error + | gi_module<>main_dcl_module_index + = expand_new_type_rhs_not_in_icl_module gi_module constructor_index new_type_defs icl_type_defs new_cons_defs icl_cons_defs type_heaps dcl_modules error + # (cons_type,icl_cons_defs) = icl_cons_defs![constructor_index].cons_type + (opt_type, new_type_defs, icl_type_defs, type_heaps, dcl_modules) + = try_to_expand_new_type_constructor_arg cons_type new_type_defs icl_type_defs type_heaps dcl_modules + = case opt_type of + Yes type + # icl_cons_defs = {icl_cons_defs & [constructor_index].cons_type.st_args = [type]} + | constructor_index < size dcl_modules.[main_dcl_module_index].dcl_common.com_cons_defs + -> expand_new_type_rhs_not_in_icl_module gi_module constructor_index new_type_defs icl_type_defs new_cons_defs icl_cons_defs type_heaps dcl_modules error + -> (new_type_defs, icl_type_defs, new_cons_defs, icl_cons_defs, type_heaps, dcl_modules, error) + No + -> (new_type_defs, icl_type_defs, new_cons_defs, icl_cons_defs, type_heaps, dcl_modules, error) + + expand_new_type_rhs_not_in_icl_module gi_module constructor_index new_type_defs icl_type_defs new_cons_defs icl_cons_defs type_heaps dcl_modules error + | size new_cons_defs.[gi_module]==0 + # (cons_type,dcl_modules) = dcl_modules![gi_module].dcl_common.com_cons_defs.[constructor_index].cons_type + (opt_type, new_type_defs, icl_type_defs, type_heaps, dcl_modules) + = try_to_expand_new_type_constructor_arg cons_type new_type_defs icl_type_defs type_heaps dcl_modules + = case opt_type of + Yes type + # (com_cons_defs,dcl_modules) = dcl_modules![gi_module].dcl_common.com_cons_defs + # new_module_cons_defs = { { cons_def \\ cons_def<-:com_cons_defs} & [constructor_index].cons_type.st_args = [type]} + # new_cons_defs = {new_cons_defs & [gi_module] = new_module_cons_defs} + -> (new_type_defs, icl_type_defs, new_cons_defs, icl_cons_defs, type_heaps, dcl_modules, error) + No + -> (new_type_defs, icl_type_defs, new_cons_defs, icl_cons_defs, type_heaps, dcl_modules, error) + # (cons_type,new_cons_defs) = new_cons_defs![gi_module,constructor_index].cons_type + (opt_type, new_type_defs, icl_type_defs, type_heaps, dcl_modules) + = try_to_expand_new_type_constructor_arg cons_type new_type_defs icl_type_defs type_heaps dcl_modules + = case opt_type of + Yes type + # new_cons_defs = {new_cons_defs & [gi_module,constructor_index].cons_type.st_args = [type]} + -> (new_type_defs, icl_type_defs, new_cons_defs, icl_cons_defs, type_heaps, dcl_modules, error) + No + -> (new_type_defs, icl_type_defs, new_cons_defs, icl_cons_defs, type_heaps, dcl_modules, error) + + try_to_expand_new_type_constructor_arg {st_args=[type=:{at_attribute}]} new_type_defs icl_type_defs type_heaps dcl_modules + = try_to_expand_synonym_type type at_attribute (new_type_defs, icl_type_defs, type_heaps, dcl_modules) + + try_to_expand_synonym_type type=:{at_type = TA {type_index={glob_object,glob_module}} types} attribute (new_type_defs, icl_type_defs, type_heaps, dcl_modules) + = try_to_expand_synonym_type_for_TA glob_object glob_module types type attribute new_type_defs icl_type_defs type_heaps dcl_modules + try_to_expand_synonym_type type=:{at_type = TAS {type_index={glob_object,glob_module}} types _} attribute (new_type_defs, icl_type_defs, type_heaps, dcl_modules) + = try_to_expand_synonym_type_for_TA glob_object glob_module types type attribute new_type_defs icl_type_defs type_heaps dcl_modules + try_to_expand_synonym_type type attribute (new_type_defs, icl_type_defs, type_heaps, dcl_modules) + = (No, new_type_defs, icl_type_defs, type_heaps, dcl_modules) + + try_to_expand_synonym_type_for_TA glob_object glob_module types type attribute new_type_defs icl_type_defs type_heaps dcl_modules + | glob_module==main_dcl_module_index + # ({td_rhs,td_attribute,td_args}, icl_type_defs) = icl_type_defs![glob_object] + = try_to_expand td_rhs td_attribute td_args attribute new_type_defs icl_type_defs type_heaps dcl_modules + | size new_type_defs.[glob_module]==0 + # ({td_rhs,td_attribute,td_args}, dcl_modules) = dcl_modules![glob_module].dcl_common.com_type_defs.[glob_object] + = try_to_expand td_rhs td_attribute td_args attribute new_type_defs icl_type_defs type_heaps dcl_modules + # ({td_rhs,td_attribute,td_args}, new_type_defs) = new_type_defs![glob_module,glob_object] + = try_to_expand td_rhs td_attribute td_args attribute new_type_defs icl_type_defs type_heaps dcl_modules + where + try_to_expand (SynType {at_type}) td_attribute td_args attribute new_type_defs icl_type_defs type_heaps dcl_modules + # (subst_rhs, type_heaps) = substituteType td_attribute attribute td_args types at_type type_heaps + = (Yes {type & at_type = subst_rhs }, new_type_defs, icl_type_defs, type_heaps, dcl_modules) + try_to_expand _ td_attribute td_args attribute new_type_defs icl_type_defs type_heaps dcl_modules + = (No, new_type_defs, icl_type_defs, type_heaps, dcl_modules) + + update_modules_and_create_commondefs :: NumberSet *{*{#CheckedTypeDef}} *{#*{#ConsDef}} Int *{#DclModule} -> (!*{#DclModule},!*{#CommonDefs}) + update_modules_and_create_commondefs used_module_numbers new_type_defs new_cons_defs nr_of_modules dcl_modules # (arbitrary_value_for_initializing, dcl_modules) = dcl_modules![0].dcl_common initial_common_defs = createArray nr_of_modules arbitrary_value_for_initializing - = iFoldSt (copy_commondefs_and_adjust_type_defs used_module_numbers type_defs) 0 nr_of_modules (dcl_modules, initial_common_defs) - where - copy_commondefs_and_adjust_type_defs used_module_numbers type_defs module_index (dcl_modules, common_defs) + = iFoldSt (copy_commondefs_and_adjust_type_defs used_module_numbers new_type_defs new_cons_defs) 0 nr_of_modules (dcl_modules, initial_common_defs) + where + copy_commondefs_and_adjust_type_defs used_module_numbers new_type_defs new_cons_defs module_index (dcl_modules, common_defs) | inNumberSet module_index used_module_numbers # (dcl_module=:{dcl_common}, dcl_modules) = dcl_modules![module_index] - dcl_common = { dcl_common & com_type_defs = type_defs.[module_index]} - = ({ dcl_modules & [module_index] = { dcl_module & dcl_common = dcl_common }}, { common_defs & [module_index] = dcl_common }) + | size new_type_defs.[module_index]<>0 + | size new_cons_defs.[module_index]<>0 + # dcl_common = { dcl_common & com_type_defs = new_type_defs.[module_index], com_cons_defs = new_cons_defs.[module_index]} + = ({ dcl_modules & [module_index].dcl_common = dcl_common}, { common_defs & [module_index] = dcl_common }) + # dcl_common = { dcl_common & com_type_defs = new_type_defs.[module_index]} + = ({ dcl_modules & [module_index].dcl_common = dcl_common}, { common_defs & [module_index] = dcl_common }) + | size new_cons_defs.[module_index]<>0 + # dcl_common = { dcl_common & com_cons_defs = new_cons_defs.[module_index]} + = ({ dcl_modules & [module_index].dcl_common = dcl_common}, { common_defs & [module_index] = dcl_common }) + = (dcl_modules, { common_defs & [module_index] = dcl_common }) = (dcl_modules, common_defs) -// # (dcl_common, dcl_modules) = dcl_modules![module_index].dcl_common -// = (dcl_modules, { common_defs & [module_index] = dcl_common }) -// ---> ("update_modules_and_create_commondefs", module_index) - partitionateTypeDef gi=:{gi_module,gi_index} pi=:{pi_type_defs} - # ({td_ident,td_pos,td_used_types}, pi) = pi!pi_type_defs.[gi_module].[gi_index] + # {td_ident,td_pos,td_used_types} = pi_type_defs.[gi_module].[gi_index] pi = push_on_dep_stack gi pi (min_dep, pi) = foldSt visit_type td_used_types (cMAXINT, pi) = try_to_close_group gi min_dep pi @@ -167,10 +259,10 @@ where #! my_mark = pi_marks.[gi_module].[gi_index] | (ldep == cMAXINT || ldep == my_mark) # (pi_deps, group_members) = close_group this_type pi_deps [] - (reorganised_group_members, pi_marks, pi_type_defs, pi_error) = check_cyclic_type_defs group_members [] pi_marks pi_type_defs pi_error + (reorganised_group_members, pi_marks, pi_error) = check_cyclic_type_defs group_members pi_type_defs [] pi_marks pi_error pi_type_def_infos = update_type_def_infos pi_next_group_num reorganised_group_members group_members pi_type_def_infos = (cMAXINT, { pi & pi_marks = pi_marks, pi_deps = pi_deps, pi_next_group_num = inc pi_next_group_num, pi_error = pi_error, - pi_type_defs = pi_type_defs, pi_type_def_infos = pi_type_def_infos, + pi_type_def_infos = pi_type_def_infos, pi_groups = [reorganised_group_members : pi_groups ]}) // ---> ("try_to_close_group", reorganised_group_members, group_members) = (min my_mark ldep, pi) @@ -180,26 +272,27 @@ where = (tds, [td : group]) = close_group first_type tds [td : group] - check_cyclic_type_defs tds group marks type_defs error - = foldSt check_cyclic_type_def tds (group, marks, type_defs, error) + check_cyclic_type_defs tds type_defs group marks error + = foldSt check_cyclic_type_def tds (group, marks, error) where - check_cyclic_type_def td=:{gi_module,gi_index} (group, marks, typedefs, error) + check_cyclic_type_def td=:{gi_module,gi_index} (group, marks, error) # (mark, marks) = marks![gi_module,gi_index] - # ({td_ident,td_pos,td_used_types,td_rhs}, typedefs) = typedefs![gi_module].[gi_index] + # {td_ident,td_pos,td_used_types,td_rhs} = type_defs.[gi_module].[gi_index] | mark == cChecking - = (group, marks, typedefs, typeSynonymError td_ident "cyclic dependency between type synonyms" error) + = (group, marks, typeSynonymError td_ident "cyclic dependency between type synonyms" error) | mark < cMAXINT - | is_synonym_type td_rhs + | is_synonym_or_new_type td_rhs # marks = { marks & [gi_module,gi_index] = cChecking } error = pushErrorAdmin (newPosition td_ident td_pos) error - (group, marks, typedefs, error) = check_cyclic_type_defs td_used_types [td : group] marks typedefs error + (group, marks, error) = check_cyclic_type_defs td_used_types type_defs [td : group] marks error error = popErrorAdmin error - = (group, { marks & [gi_module,gi_index] = cMAXINT }, typedefs, error) - = ([td : group], { marks & [gi_module,gi_index] = cMAXINT }, typedefs, error) - = (group, marks, typedefs, error) + = (group, { marks & [gi_module,gi_index] = cMAXINT }, error) + = ([td : group], { marks & [gi_module,gi_index] = cMAXINT }, error) + = (group, marks, error) - is_synonym_type (SynType _) = True - is_synonym_type td_rhs = False + is_synonym_or_new_type (SynType _) = True + is_synonym_or_new_type (NewType _) = True + is_synonym_or_new_type _ = False update_type_def_infos group_nr group_members tds type_def_infos # (_, type_def_infos) = foldSt (update_type_def_info group_nr group_members) tds (0, type_def_infos) @@ -349,7 +442,7 @@ where where has_root_attr (TA_RootVar _) = True has_root_attr _ = False - + instance analTypes TypeVar where analTypes has_root_attr modules form_tvs {tv_info_ptr} (conds=:{con_var_binds}, as=:{as_type_var_heap, as_kind_heap}) @@ -476,14 +569,23 @@ where cDummyBool :== False -analTypesOfConstructor modules cons_defs [{ds_index}:conses] (conds, as=:{as_type_var_heap,as_kind_heap}) +analTypesOfConstructors modules cons_defs [cons:conses] (conds, as=:{as_type_var_heap,as_kind_heap}) + # (cons_properties,conds_as) = anal_types_of_constructor modules cons_defs cons (conds, as) + (other_properties, conds_as) = analTypesOfConstructors modules cons_defs conses conds_as + = (combineTypeProperties cons_properties other_properties, conds_as) +analTypesOfConstructors _ _ [] conds_as + = (cIsHyperStrict, conds_as) + +analTypesOfConstructor modules cons_defs cons (conds, as) + # (cons_properties,conds_as) = anal_types_of_constructor modules cons_defs cons (conds, as) + = (combineTypeProperties cons_properties cIsHyperStrict,conds_as) + +anal_types_of_constructor modules cons_defs {ds_index} (conds, as=:{as_type_var_heap,as_kind_heap}) # {cons_exi_vars,cons_type} = cons_defs.[ds_index ] (coercible, as_type_var_heap, as_kind_heap) = new_local_kind_variables cons_exi_vars (as_type_var_heap, as_kind_heap) (cons_properties, conds_as) = anal_types_of_cons modules cons_type.st_args cons_type.st_args_strictness 0 (conds, { as & as_type_var_heap = as_type_var_heap, as_kind_heap = as_kind_heap }) - (other_properties, conds_as) = analTypesOfConstructor modules cons_defs conses conds_as - properties = combineTypeProperties cons_properties other_properties - = (if coercible properties (properties bitor cIsNonCoercible), conds_as) + = (if coercible cons_properties (cons_properties bitor cIsNonCoercible), conds_as) where new_local_kind_variables :: [ATypeVar] !(!*TypeVarHeap,!*KindHeap) -> (!Bool,!*TypeVarHeap,!*KindHeap) new_local_kind_variables td_args (type_var_heap, as_kind_heap) @@ -497,7 +599,7 @@ where is_not_a_variable (TA_RootVar var) = False is_not_a_variable attr = True - + anal_types_of_cons modules [] args_strictness strictness_index conds_as = (cIsHyperStrict, conds_as) anal_types_of_cons modules [type : types] args_strictness strictness_index conds_as @@ -510,9 +612,6 @@ where = (cons_props, (conds, { as & as_kind_heap = uki_kind_heap, as_error = uki_error })) // ---> ("anal_types_of_cons", type) -analTypesOfConstructor _ _ [] conds_as - = (cIsHyperStrict, conds_as) - isATopConsVar cv :== cv < 0 encodeTopConsVar cv :== dec (~cv) decodeTopConsVar cv :== ~(inc cv) @@ -578,13 +677,15 @@ where = (combineTypeProperties group_properties type_properties, conds, {as & as_error = popErrorAdmin as.as_error }) where anal_rhs_of_type_def modules com_cons_defs (AlgType conses) conds_as - = analTypesOfConstructor modules com_cons_defs conses conds_as + = analTypesOfConstructors modules com_cons_defs conses conds_as anal_rhs_of_type_def modules com_cons_defs (RecordType {rt_constructor}) conds_as - = analTypesOfConstructor modules com_cons_defs [rt_constructor] conds_as + = analTypesOfConstructor modules com_cons_defs rt_constructor conds_as anal_rhs_of_type_def modules _ (SynType type) conds_as # (type_kind, cv_props, (conds, as=:{as_kind_heap, as_error})) = analTypes True /* cDummyBool */ modules [] type.at_type conds_as {uki_kind_heap, uki_error} = unifyKinds type_kind KI_Const {uki_kind_heap = as_kind_heap, uki_error = as_error} = (cv_props, (conds, { as & as_kind_heap = uki_kind_heap, as_error = uki_error })) + anal_rhs_of_type_def modules com_cons_defs (NewType cons) conds_as + = analTypesOfConstructor modules com_cons_defs cons conds_as determine_kinds {gi_module,gi_index} (kind_heap, td_infos) # (td_info=:{tdi_kinds}, td_infos) = td_infos![gi_module,gi_index] @@ -1084,6 +1185,8 @@ isUniqueTypeRhs common_defs mod_index (SynType rhs) state = isUnique common_defs rhs state isUniqueTypeRhs common_defs mod_index (RecordType {rt_constructor={ds_index}}) state = constructor_is_unique mod_index ds_index common_defs state +isUniqueTypeRhs common_defs mod_index (NewType {ds_index}) state + = constructor_is_unique mod_index ds_index common_defs state isUniqueTypeRhs common_defs mod_index _ state = (False, state) diff --git a/frontend/analunitypes.icl b/frontend/analunitypes.icl index 53e5541..5d80f59 100644 --- a/frontend/analunitypes.icl +++ b/frontend/analunitypes.icl @@ -193,7 +193,9 @@ where # (sign_class, _, scs) = signClassOfType at_type PositiveSign DontUSeTopSign group_nr ci scs = (sign_class, scs) sign_class_of_type_def module_index (RecordType {rt_constructor}) group_nr ci scs - = sign_class_of_type_conses module_index [rt_constructor] group_nr ci BottomSignClass scs + = sign_class_of_type_cons module_index rt_constructor group_nr ci BottomSignClass scs + sign_class_of_type_def module_index (NewType constructor) group_nr ci scs + = sign_class_of_type_cons module_index constructor group_nr ci BottomSignClass scs sign_class_of_type_def _ (AbstractType properties) _ _ scs | properties bitand cIsNonCoercible == 0 = (PostiveSignClass, scs) @@ -202,6 +204,7 @@ where | properties bitand cIsNonCoercible == 0 = (PostiveSignClass, scs) = (TopSignClass, scs) + sign_class_of_type_conses module_index [{ds_index}:conses] group_nr ci cumm_sign_class scs #! cons_def = ci.[module_index].com_cons_defs.[ds_index] # (cumm_sign_class, scs) = sign_class_of_type_of_list cons_def.cons_type.st_args group_nr ci cumm_sign_class scs @@ -209,6 +212,10 @@ where sign_class_of_type_conses module_index [] _ _ cumm_sign_class scs = (cumm_sign_class, scs) + sign_class_of_type_cons module_index {ds_index} group_nr ci cumm_sign_class scs + #! cons_def = ci.[module_index].com_cons_defs.[ds_index] + = sign_class_of_type_of_list cons_def.cons_type.st_args group_nr ci cumm_sign_class scs + sign_class_of_type_of_list [] _ _ cumm_sign_class scs = (cumm_sign_class, scs) sign_class_of_type_of_list [{at_type} : types] group_nr ci cumm_sign_class scs @@ -468,7 +475,9 @@ where # (prop_class, _, pcs) = propClassOfType at_type group_nr ci pcs = (prop_class, pcs) prop_class_of_type_def module_index (RecordType {rt_constructor}) group_nr ci pcs - = prop_class_of_type_conses module_index [rt_constructor] group_nr ci NoPropClass pcs + = prop_class_of_type_cons module_index rt_constructor group_nr ci NoPropClass pcs + prop_class_of_type_def module_index (NewType constructor) group_nr ci pcs + = prop_class_of_type_cons module_index constructor group_nr ci NoPropClass pcs prop_class_of_type_def _ (AbstractType properties) _ _ pcs = (PropClass, pcs) prop_class_of_type_def _ (AbstractSynType properties _) _ _ pcs @@ -481,6 +490,10 @@ where prop_class_of_type_conses module_index [] _ _ cumm_prop_class pcs = (cumm_prop_class, pcs) + prop_class_of_type_cons module_index {ds_index} group_nr ci cumm_prop_class pcs + #! cons_def = ci.[module_index].com_cons_defs.[ds_index] + = prop_class_of_type_of_list cons_def.cons_type.st_args group_nr ci cumm_prop_class pcs + prop_class_of_type_of_list [] _ _ cumm_prop_class pcs = (cumm_prop_class, pcs) prop_class_of_type_of_list [{at_type} : types] group_nr ci cumm_prop_class pcs diff --git a/frontend/check.icl b/frontend/check.icl index 0da0f28..1c2a2f9 100644 --- a/frontend/check.icl +++ b/frontend/check.icl @@ -1455,6 +1455,8 @@ renumber_icl_definitions_as_dcl_definitions (Yes icl_to_dcl_index_table) icl_siz # rt_constructor = {rt_constructor & ds_index=icl_to_dcl_index_table.[cConstructorDefs,rt_constructor.ds_index]} # rt_fields = {{field & fs_index=icl_to_dcl_index_table.[cSelectorDefs,field.fs_index]} \\ field <-: rt_fields} = {td & td_rhs=RecordType {rt_constructor=rt_constructor,rt_fields=rt_fields,rt_is_boxed_record=rt_is_boxed_record}} + renumber_type_def td=:{td_rhs = NewType cons} + = { td & td_rhs = NewType {cons & ds_index=icl_to_dcl_index_table.[cConstructorDefs,cons.ds_index]} } renumber_type_def td = td renumber_icl_decl_symbol (Declaration icl_decl_symbol=:{decl_kind = STE_Constructor, decl_index}) cdefs @@ -1639,6 +1641,10 @@ where # new_cons_defs = if (dcl_cons_index==(-1)) new_cons_defs [ com_cons_defs.[dcl_cons_index] : new_cons_defs ] # (rt_fields, cs) = redirect_field_symbols td_pos rt_fields cs = ([ { td & td_rhs = RecordType { rt & rt_constructor = rt_constructor, rt_fields = rt_fields }} : new_type_defs ],new_cons_defs,new_selector_defs,conversion_table,icl_sizes,icl_decl_symbols,cs) + add_type_def td=:{td_pos, td_rhs = NewType cons} new_type_defs new_cons_defs new_selector_defs conversion_table icl_sizes icl_decl_symbols cs + # (dcl_cons_index,cons,(conversion_table,icl_sizes,icl_decl_symbols,cs)) = copy_and_redirect_symbol STE_Constructor td_pos cons (conversion_table,icl_sizes,icl_decl_symbols,cs) + # new_cons_defs = if (dcl_cons_index==(-1)) new_cons_defs [ com_cons_defs.[dcl_cons_index] : new_cons_defs ] + = ([ { td & td_rhs = NewType cons} : new_type_defs ],new_cons_defs,new_selector_defs,conversion_table,icl_sizes,icl_decl_symbols,cs) add_type_def td=:{td_ident, td_pos, td_rhs = AbstractType _} new_type_defs new_cons_defs new_selector_defs conversion_table icl_sizes icl_decl_symbols cs # cs_error = checkError "abstract type not defined in implementation module" "" (setErrorAdmin (newPosition td_ident td_pos) cs.cs_error) @@ -2703,7 +2709,7 @@ check_module2 mod_ident mod_modification_time mod_imported_objects mod_imports m solved_imports = { si_explicit=[], si_qualified_explicit=[], si_implicit=[] } imports_ikh = ikhInsert` False cPredefinedModuleIndex solved_imports ikhEmpty (deferred_stuff, (_, modules, macro_and_fun_defs, macro_defs, heaps, cs)) - = checkDclModule EndNumbers [] imports_ikh cUndef False cDummyArray support_dynamics mod ste_index cDummyArray modules macro_and_fun_defs macro_defs heaps cs + = checkPredefinedDclModule EndNumbers [] imports_ikh cUndef False cDummyArray support_dynamics mod ste_index cDummyArray modules macro_and_fun_defs macro_defs heaps cs (modules, heaps, cs) = checkInstancesOfDclModule cPredefinedModuleIndex deferred_stuff (modules, heaps, cs) ({dcl_declared={dcls_import,dcls_local,dcls_local_for_import}}, modules) = modules![ste_index] @@ -3392,10 +3398,10 @@ checkInstancesOfDclModule mod_index (nr_of_dcl_functions_and_instances, nr_of_dc (Yes symbol_type) = inst_def.ft_type = { instance_defs & [ds_index] = { inst_def & ft_type = makeElemTypeOfArrayFunctionStrict inst_def.ft_type ins_offset offset_table } } -checkDclModule :: !NumberSet ![Int] !(IntKeyHashtable SolvedImports) !Int !Bool !LargeBitvect !Bool - !(Module (CollectedDefinitions ClassInstance IndexRange)) !Index !*ExplImpInfos !*{#DclModule} !*{#FunDef} !*{#*{#FunDef}} !*Heaps !*CheckState - -> (!(!Int,!Index,![FunType]), !(!*ExplImpInfos, !*{#DclModule}, !*{#FunDef},!*{#*{#FunDef}},!*Heaps, !*CheckState)) -checkDclModule dcl_imported_module_numbers components_importing_module imports_ikh component_nr is_on_cycle modules_in_component_set support_dynamics +checkPredefinedDclModule :: !NumberSet ![Int] !(IntKeyHashtable SolvedImports) !Int !Bool !LargeBitvect !Bool + !(Module (CollectedDefinitions ClassInstance IndexRange)) !Index !*ExplImpInfos !*{#DclModule} !*{#FunDef} !*{#*{#FunDef}} !*Heaps !*CheckState + -> (!(!Int,!Index,![FunType]), !(!*ExplImpInfos, !*{#DclModule}, !*{#FunDef},!*{#*{#FunDef}},!*Heaps, !*CheckState)) +checkPredefinedDclModule dcl_imported_module_numbers components_importing_module imports_ikh component_nr is_on_cycle modules_in_component_set support_dynamics mod=:{mod_ident,mod_defs=mod_defs=:{def_macro_indices,def_funtypes}} mod_index expl_imp_info modules icl_functions macro_defs heaps cs # dcl_common = createCommonDefinitions mod_defs #! first_type_index = size dcl_common.com_type_defs diff --git a/frontend/checkFunctionBodies.icl b/frontend/checkFunctionBodies.icl index accf0d3..21ad9c1 100644 --- a/frontend/checkFunctionBodies.icl +++ b/frontend/checkFunctionBodies.icl @@ -140,7 +140,7 @@ checkFunctionBodies (ParsedBody [{pb_args,pb_rhs={rhs_alts,rhs_locals}, pb_posit = addArraySelections array_patterns rhs_expr free_vars e_input e_state e_info cs cs_symbol_table = removeLocalIdentsFromSymbolTable ei_expr_level var_env cs.cs_symbol_table cs = { cs & cs_symbol_table = cs_symbol_table } - (cb_args, es_var_heap) = mapSt determine_function_arg aux_patterns es_var_heap + (cb_args, es_var_heap) = mapSt determine_function_arg aux_patterns es_var_heap (rhss, free_vars, e_state=:{es_dynamics,es_expr_heap,es_var_heap}, e_info, cs) = check_function_bodies free_vars cb_args bodies e_input { e_state & es_dynamics = [], es_var_heap = es_var_heap } e_info cs (rhs, position, es_var_heap, es_expr_heap, dynamics_in_patterns, cs) @@ -166,6 +166,9 @@ where determine_function_arg (AP_Basic _ opt_var) var_store # ({bind_src,bind_dst}, var_store) = determinePatternVariable opt_var var_store = ({ fv_ident = bind_src, fv_info_ptr = bind_dst, fv_def_level = NotALevel, fv_count = 0 }, var_store) + determine_function_arg (AP_NewType _ _ _ opt_var) var_store + # ({bind_src,bind_dst}, var_store) = determinePatternVariable opt_var var_store + = ({ fv_ident = bind_src, fv_info_ptr = bind_dst, fv_def_level = NotALevel, fv_count = 0 }, var_store) determine_function_arg (AP_Dynamic _ _ opt_var) var_store # ({bind_src,bind_dst}, var_store) = determinePatternVariable opt_var var_store = ({ fv_ident = bind_src, fv_info_ptr = bind_dst, fv_def_level = NotALevel, fv_count = 0 }, var_store) @@ -275,7 +278,19 @@ where = (Case { case_expr = act_var, case_guards = case_guards, case_default = No, case_ident = No, case_explicit = cCaseNotExplicit, case_info_ptr = case_expr_ptr, case_default_pos = NoPos }, - NoPos, var_store, expr_heap, opt_dynamics, cs) + NoPos, var_store, expr_heap, opt_dynamics, cs) + transform_pattern_into_cases (AP_NewType cons_symbol type_index arg opt_var) fun_arg result_expr pattern_position + var_store expr_heap opt_dynamics cs + # (var_arg, result_expr, pattern_position, var_store, expr_heap, opt_dynamics, cs) + = convertSubPattern arg result_expr pattern_position var_store expr_heap opt_dynamics cs + type_symbol = {glob_module = cons_symbol.glob_module, glob_object = type_index} + (act_var, result_expr, expr_heap) = transform_pattern_variable fun_arg opt_var result_expr expr_heap + (case_expr_ptr, expr_heap) = newPtr EI_Empty expr_heap + # alg_patterns = [{ ap_symbol = cons_symbol, ap_vars = [var_arg], ap_expr = result_expr, ap_position = pattern_position }] + # case_guards = NewTypePatterns type_symbol alg_patterns + = (Case { case_expr = act_var, case_guards = case_guards, case_default = No, case_ident = No, + case_explicit = cCaseNotExplicit, case_info_ptr = case_expr_ptr, case_default_pos = NoPos }, + NoPos, var_store, expr_heap, opt_dynamics, cs) transform_pattern_into_cases (AP_Dynamic pattern type opt_var) fun_arg result_expr pattern_position var_store expr_heap opt_dynamics cs # (var_arg, result_expr, pattern_position, var_store, expr_heap, opt_dynamics, cs) = convertSubPattern pattern result_expr pattern_position var_store expr_heap opt_dynamics cs @@ -327,6 +342,8 @@ removeLocalsFromSymbolTable module_index level loc_vars (CollectedLocalDefs {loc # (macro_defs,symbol_table) = removeLocalDclMacrosFromSymbolTable level module_index loc_functions macro_defs symbol_table = (fun_defs,macro_defs,symbol_table) +:: LetBinds :== [([LetBind],[LetBind])] + checkRhs :: [FreeVar] OptGuardedAlts LocalDefs ExpressionInput *ExpressionState *ExpressionInfo *CheckState -> *(!Expression,![FreeVar],!*ExpressionState,!*ExpressionInfo,!*CheckState); checkRhs free_vars rhs_alts rhs_locals e_input=:{ei_expr_level,ei_mod_index,ei_local_functions_index_offset} e_state e_info cs # ei_expr_level = inc ei_expr_level @@ -360,23 +377,23 @@ where = (Yes expr, expr_position, free_vars, e_state, e_info, cs) check_default_expr free_vars No e_input e_state e_info cs = (No, NoPos, free_vars, e_state, e_info, cs) - - convert_guards_to_cases [(let_binds, guard, expr, expr_position, guard_ident)] result_expr result_expr_position es_expr_heap + + convert_guards_to_cases [guard_expr] result_expr result_expr_position es_expr_heap + = convert_guard_to_case guard_expr result_expr result_expr_position es_expr_heap + convert_guards_to_cases [guard_expr : rev_guarded_exprs] result_expr result_expr_position es_expr_heap + # (result_expr, result_expr_position, es_expr_heap) = convert_guard_to_case guard_expr result_expr result_expr_position es_expr_heap + = convert_guards_to_cases rev_guarded_exprs (Yes result_expr) result_expr_position es_expr_heap + + convert_guard_to_case (let_binds, guard, expr, expr_position, guard_ident) result_expr result_expr_position es_expr_heap # (case_expr_ptr, es_expr_heap) = newPtr EI_Empty es_expr_heap basic_pattern = {bp_value = (BVB True), bp_expr = expr, bp_position = expr_position } - case_expr = Case { case_expr = guard, case_guards = BasicPatterns BT_Bool [basic_pattern], - case_default = result_expr, case_default_pos = result_expr_position, - case_ident = Yes guard_ident, case_explicit = cCaseNotExplicit, case_info_ptr = case_expr_ptr } + case_expr = Case {case_expr = guard, case_guards = BasicPatterns BT_Bool [basic_pattern], + case_default = result_expr, case_default_pos = result_expr_position, + case_ident = Yes guard_ident, case_explicit = cCaseNotExplicit, case_info_ptr = case_expr_ptr } = build_sequential_lets let_binds case_expr NoPos es_expr_heap - convert_guards_to_cases [(let_binds, guard, expr, expr_position, guard_ident) : rev_guarded_exprs] result_expr result_expr_position es_expr_heap - # (case_expr_ptr, es_expr_heap) = newPtr EI_Empty es_expr_heap - basic_pattern = {bp_value = (BVB True), bp_expr = expr, bp_position = expr_position } - case_expr = Case { case_expr = guard, case_guards = BasicPatterns BT_Bool [basic_pattern], - case_default = result_expr, case_default_pos = result_expr_position, - case_ident = Yes guard_ident, case_explicit = cCaseNotExplicit, case_info_ptr = case_expr_ptr } - (result_expr, result_expr_position, es_expr_heap) = build_sequential_lets let_binds case_expr NoPos es_expr_heap - = convert_guards_to_cases rev_guarded_exprs (Yes result_expr) result_expr_position es_expr_heap + check_guarded_expressions :: [FreeVar] [GuardedExpr] [[Ident]] [(LetBinds,Expression,Expression,Position,Ident)] ExpressionInput *ExpressionState *ExpressionInfo *CheckState + -> *([[Ident]],[(LetBinds,Expression,Expression,Position,Ident)],Int,[FreeVar], *ExpressionState,*ExpressionInfo,*CheckState) check_guarded_expressions free_vars [gexpr : gexprs] let_vars_list rev_guarded_exprs e_input e_state e_info cs # (let_vars_list, rev_guarded_exprs, ei_expr_level, free_vars, e_state, e_info, cs) = check_guarded_expression free_vars gexpr let_vars_list rev_guarded_exprs e_input e_state e_info cs @@ -423,8 +440,8 @@ where remove_seq_let_vars level [let_vars : let_vars_list] symbol_table = remove_seq_let_vars (dec level) let_vars_list (removeLocalIdentsFromSymbolTable level let_vars symbol_table) - check_sequential_lets :: [FreeVar] [NodeDefWithLocals] u:[[Ident]] !ExpressionInput *ExpressionState *ExpressionInfo *CheckState - -> *(![.([LetBind],![LetBind])],!u:[[Ident]],!Int,![FreeVar],!*ExpressionState,!*ExpressionInfo,!*CheckState); + check_sequential_lets :: [FreeVar] [NodeDefWithLocals] u:[[Ident]] !ExpressionInput *ExpressionState *ExpressionInfo *CheckState + -> *(!LetBinds,!u:[[Ident]],!Int,![FreeVar],!*ExpressionState,!*ExpressionInfo,!*CheckState); check_sequential_lets free_vars [seq_let:seq_lets] let_vars_list e_input=:{ei_expr_level,ei_mod_index} e_state e_info cs # ei_expr_level = inc ei_expr_level e_input = { e_input & ei_expr_level = ei_expr_level } @@ -470,7 +487,7 @@ where e_state = { e_state & es_var_heap = ps_var_heap, es_expr_heap = hp_expression_heap, es_type_heaps = hp_type_heaps,es_generic_heap=hp_generic_heap,es_fun_defs = ps_fun_defs } = (src_expr, pattern, accus, free_vars, e_state, e_info, popErrorAdmin cs) - build_sequential_lets :: ![(![LetBind],![LetBind])] !Expression !Position !*ExpressionHeap -> (!Expression, !Position, !*ExpressionHeap) + build_sequential_lets :: !LetBinds !Expression !Position !*ExpressionHeap -> (!Expression, !Position, !*ExpressionHeap) build_sequential_lets [] expr let_expr_position expr_heap = (expr, let_expr_position, expr_heap) build_sequential_lets [(strict_binds, lazy_binds) : seq_lets] expr let_expr_position expr_heap @@ -513,35 +530,35 @@ where first_argument_of_infix_operator_missing = "first argument of infix operator missing" - build_expression [Constant symb _ (Prio _ _) _ , _: _] e_state cs_error + build_expression [Constant symb _ (Prio _ _) , _: _] e_state cs_error = (EE, e_state, checkError symb.symb_ident first_argument_of_infix_operator_missing cs_error) - build_expression [Constant symb arity _ is_fun] e_state cs_error - = buildApplicationWithoutArguments symb is_fun e_state cs_error + build_expression [Constant symb arity _] e_state cs_error + = buildApplicationWithoutArguments symb e_state cs_error build_expression [expr] e_state cs_error = (expr, e_state, cs_error) build_expression [expr : exprs] e_state cs_error # (opt_opr, left, e_state, cs_error) = split_at_operator [expr] exprs e_state cs_error (left_expr, e_state, cs_error) = combine_expressions left [] 0 e_state cs_error = case opt_opr of - Yes (symb, arity, prio, is_fun, right) + Yes (symb, arity, prio, right) -> case right of - [Constant symb _ (Prio _ _) _:_] + [Constant symb _ (Prio _ _):_] -> (EE, e_state, checkError symb.symb_ident first_argument_of_infix_operator_missing cs_error) _ - -> build_operator_expression [] left_expr (symb, arity, prio, is_fun) right e_state cs_error + -> build_operator_expression [] left_expr (symb, arity, prio) right e_state cs_error No -> (left_expr, e_state, cs_error) where - split_at_operator left [Constant symb arity NoPrio is_fun : exprs] e_state cs_error - # (appl_exp, e_state, cs_error) = buildApplicationWithoutArguments symb is_fun e_state cs_error + split_at_operator left [Constant symb arity NoPrio : exprs] e_state cs_error + # (appl_exp, e_state, cs_error) = buildApplicationWithoutArguments symb e_state cs_error = split_at_operator [appl_exp : left] exprs e_state cs_error - split_at_operator left [Constant symb arity (Prio _ _) is_fun] e_state cs_error + split_at_operator left [Constant symb arity (Prio _ _)] e_state cs_error = (No, left, e_state, checkError symb.symb_ident "second argument of infix operator missing" cs_error) - split_at_operator left [Constant symb arity prio is_fun] e_state cs_error - # (appl_exp, e_state, cs_error) = buildApplicationWithoutArguments symb is_fun e_state cs_error + split_at_operator left [Constant symb arity prio] e_state cs_error + # (appl_exp, e_state, cs_error) = buildApplicationWithoutArguments symb e_state cs_error = (No, [appl_exp : left], e_state, cs_error) - split_at_operator left [expr=:(Constant symb arity prio is_fun) : exprs] e_state cs_error - = (Yes (symb, arity, prio, is_fun, exprs), left, e_state, cs_error) + split_at_operator left [expr=:(Constant symb arity prio) : exprs] e_state cs_error + = (Yes (symb, arity, prio, exprs), left, e_state, cs_error) split_at_operator left [expr : exprs] e_state cs_error = split_at_operator [expr : left] exprs e_state cs_error split_at_operator exp [] e_state cs_error @@ -549,8 +566,8 @@ where combine_expressions [first_expr] args arity e_state cs_error = case first_expr of - Constant symb form_arity _ is_fun - -> buildApplication symb form_arity arity is_fun args e_state cs_error + Constant symb form_arity _ + -> buildApplication symb form_arity arity args e_state cs_error _ | arity == 0 -> (first_expr, e_state, cs_error) @@ -559,36 +576,36 @@ where = combine_expressions rev_args [rev_arg : args] (inc arity) e_state cs_error - build_operator_expression left_appls left1 (symb1, arity1, prio1, is_fun1) [re : res] e_state cs_error + build_operator_expression left_appls left1 (symb1, arity1, prio1) [re : res] e_state cs_error # (opt_opr, left2, e_state, cs_error) = split_at_operator [re] res e_state cs_error = case opt_opr of - Yes (symb2, arity2, prio2, is_fun2, right) + Yes (symb2, arity2, prio2, right) # optional_prio = determinePriority prio1 prio2 -> case optional_prio of Yes priority | priority # (middle_exp, e_state, cs_error) = combine_expressions left2 [] 0 e_state cs_error - (new_left, e_state, cs_error) = buildApplication symb1 arity1 2 is_fun1 [left1,middle_exp] e_state cs_error + (new_left, e_state, cs_error) = buildApplication symb1 arity1 2 [left1,middle_exp] e_state cs_error (left_appls, new_left, e_state, cs_error) = build_left_operand left_appls prio2 new_left e_state cs_error - -> build_operator_expression left_appls new_left (symb2, arity2, prio2, is_fun2) right e_state cs_error + -> build_operator_expression left_appls new_left (symb2, arity2, prio2) right e_state cs_error # (middle_exp, e_state, cs_error) = combine_expressions left2 [] 0 e_state cs_error - -> build_operator_expression [(symb1, arity1, prio1, is_fun1, left1) : left_appls] - middle_exp (symb2, arity2, prio2, is_fun2) right e_state cs_error + -> build_operator_expression [(symb1, arity1, prio1, left1) : left_appls] + middle_exp (symb2, arity2, prio2) right e_state cs_error No -> (EE, e_state, checkError symb1.symb_ident "conflicting priorities" cs_error) No # (right, e_state, cs_error) = combine_expressions left2 [] 0 e_state cs_error - (result_expr, e_state, cs_error) = buildApplication symb1 arity1 2 is_fun1 [left1,right] e_state cs_error + (result_expr, e_state, cs_error) = buildApplication symb1 arity1 2 [left1,right] e_state cs_error -> build_final_expression left_appls result_expr e_state cs_error build_left_operand [] _ result_expr e_state cs_error = ([], result_expr, e_state, cs_error) - build_left_operand la=:[(symb, arity, priol, is_fun, left) : left_appls] prior result_expr e_state cs_error + build_left_operand la=:[(symb, arity, priol, left) : left_appls] prior result_expr e_state cs_error # optional_prio = determinePriority priol prior = case optional_prio of Yes priority | priority - # (result_expr, e_state, cs_error) = buildApplication symb arity 2 is_fun [left,result_expr] e_state cs_error + # (result_expr, e_state, cs_error) = buildApplication symb arity 2 [left,result_expr] e_state cs_error -> build_left_operand left_appls prior result_expr e_state cs_error -> (la, result_expr, e_state, cs_error) No @@ -596,8 +613,8 @@ where build_final_expression [] result_expr e_state cs_error = (result_expr, e_state, cs_error) - build_final_expression [(symb, arity, _, is_fun, left) : left_appls] result_expr e_state cs_error - # (result_expr, e_state, cs_error) = buildApplication symb arity 2 is_fun [left,result_expr] e_state cs_error + build_final_expression [(symb, arity, _, left) : left_appls] result_expr e_state cs_error + # (result_expr, e_state, cs_error) = buildApplication symb arity 2 [left,result_expr] e_state cs_error = build_final_expression left_appls result_expr e_state cs_error checkExpression free_vars (PE_Let strict let_locals expr) e_input=:{ei_expr_level,ei_mod_index,ei_local_functions_index_offset} e_state e_info cs @@ -621,24 +638,25 @@ checkExpression free_vars (PE_Let strict let_locals expr) e_input=:{ei_expr_leve checkExpression free_vars (PE_Case case_ident expr alts) e_input e_state e_info cs # (pattern_expr, free_vars, e_state, e_info, cs) = checkExpression free_vars expr e_input e_state e_info cs (guards, _, pattern_variables, defaul, free_vars, e_state, e_info, cs) - = check_guarded_expressions free_vars alts [] case_ident.id_name e_input e_state e_info cs + = check_case_alts free_vars alts [] case_ident.id_name e_input e_state e_info cs (pattern_expr, binds, es_expr_heap) = bind_pattern_variables pattern_variables pattern_expr e_state.es_expr_heap (case_expr, es_var_heap, es_expr_heap, cs_error) = build_and_share_case guards defaul pattern_expr case_ident cCaseExplicit e_state.es_var_heap es_expr_heap cs.cs_error cs = {cs & cs_error = cs_error} (result_expr, es_expr_heap) = buildLetExpression [] binds case_expr NoPos es_expr_heap = (result_expr, free_vars, { e_state & es_var_heap = es_var_heap, es_expr_heap = es_expr_heap }, e_info, cs) - where - check_guarded_expressions free_vars [g] pattern_variables case_name e_input=:{ei_expr_level} e_state e_info cs + check_case_alts free_vars [g] pattern_variables case_name e_input=:{ei_expr_level} e_state e_info cs # e_input = { e_input & ei_expr_level = inc ei_expr_level } - = check_guarded_expression free_vars g NoPattern NoPattern pattern_variables No case_name e_input e_state e_info cs - check_guarded_expressions free_vars [g : gs] pattern_variables case_name e_input=:{ei_expr_level} e_state e_info cs + = check_case_alt free_vars g NoPattern NoPattern pattern_variables No case_name e_input e_state e_info cs + check_case_alts free_vars [g : gs] pattern_variables case_name e_input=:{ei_expr_level} e_state e_info cs # e_input = { e_input & ei_expr_level = inc ei_expr_level } (gs, pattern_scheme, pattern_variables, defaul, free_vars, e_state, e_info, cs) - = check_guarded_expressions free_vars gs pattern_variables case_name e_input e_state e_info cs - = check_guarded_expression free_vars g gs pattern_scheme pattern_variables defaul case_name e_input e_state e_info cs + = check_case_alts free_vars gs pattern_variables case_name e_input e_state e_info cs + = check_case_alt free_vars g gs pattern_scheme pattern_variables defaul case_name e_input e_state e_info cs - check_guarded_expression free_vars {calt_pattern,calt_rhs={rhs_alts,rhs_locals},calt_position} patterns pattern_scheme pattern_variables defaul case_name + check_case_alt :: [FreeVar] CaseAlt CasePatterns CasePatterns [(Bind Ident (Ptr VarInfo))] (Optional ((Optional FreeVar),Expression)) {#Char} ExpressionInput *ExpressionState *ExpressionInfo *CheckState + -> *(CasePatterns,CasePatterns,[(Bind Ident (Ptr VarInfo))],(Optional ((Optional FreeVar),Expression)),[FreeVar],*ExpressionState,*ExpressionInfo,*CheckState) + check_case_alt free_vars {calt_pattern,calt_rhs={rhs_alts,rhs_locals},calt_position} patterns pattern_scheme pattern_variables defaul case_name e_input=:{ei_expr_level,ei_mod_index} e_state=:{es_fun_defs,es_var_heap,es_dynamics=outer_dynamics} e_info cs # (pattern, (var_env, array_patterns), {ps_fun_defs,ps_var_heap}, e_info, cs) = checkPattern calt_pattern No { pi_def_level = ei_expr_level, pi_mod_index = ei_mod_index, pi_is_node_pattern = False } ([], []) @@ -855,16 +873,37 @@ where transform_pattern (AP_Variable name var_info opt_var) NoPattern pattern_scheme pattern_variables No result_expr _ pos var_store expr_heap opt_dynamics cs = ( NoPattern, pattern_scheme, cons_optional opt_var pattern_variables, Yes (Yes { fv_ident = name, fv_info_ptr = var_info, fv_def_level = NotALevel, fv_count = 0 }, result_expr), - var_store, expr_heap, opt_dynamics, cs) + var_store, expr_heap, opt_dynamics, cs) transform_pattern (AP_Variable name var_info opt_var) patterns pattern_scheme pattern_variables defaul result_expr case_name pos var_store expr_heap opt_dynamics cs # free_var = { fv_ident = name, fv_info_ptr = var_info, fv_def_level = NotALevel, fv_count = 0 } (new_bound_var, expr_heap) = allocate_bound_var free_var expr_heap case_ident = { id_name = case_name, id_info = nilPtr } (new_case, var_store, expr_heap, cs_error) = build_and_share_case patterns defaul (Var new_bound_var) case_ident cCaseExplicit var_store expr_heap cs.cs_error cs = {cs & cs_error = cs_error} - new_defaul = insert_as_default new_case result_expr + new_defaul = insert_as_default result_expr new_case = (NoPattern, pattern_scheme, (cons_optional opt_var pattern_variables), Yes (Yes free_var, new_defaul), var_store, expr_heap, opt_dynamics, cs) + transform_pattern (AP_NewType cons_symbol type_index arg opt_var) patterns pattern_scheme pattern_variables defaul result_expr _ pos var_store expr_heap opt_dynamics cs + # (var_arg, result_expr, _, var_store, expr_heap, opt_dynamics, cs) = convertSubPattern arg result_expr pos var_store expr_heap opt_dynamics cs + type_symbol = { glob_module = cons_symbol.glob_module, glob_object = type_index} + pattern_variables = cons_optional opt_var pattern_variables + # pattern = { ap_symbol = cons_symbol, ap_vars = [var_arg], ap_expr = result_expr, ap_position = pos} + = case pattern_scheme of + NewTypePatterns alg_type _ + | type_symbol == alg_type + # newtype_patterns = case patterns of + NewTypePatterns _ newtype_patterns -> newtype_patterns + NoPattern -> [] + -> (NewTypePatterns type_symbol [pattern : newtype_patterns], pattern_scheme, pattern_variables, defaul, var_store, expr_heap, opt_dynamics, cs) + -> (patterns, pattern_scheme, pattern_variables, defaul, var_store, expr_heap, opt_dynamics, + { cs & cs_error = checkError cons_symbol.glob_object.ds_ident "incompatible types of patterns" cs.cs_error }) + NoPattern + -> (NewTypePatterns type_symbol [pattern], NewTypePatterns type_symbol [], pattern_variables, defaul, var_store, expr_heap, opt_dynamics, cs) + _ + -> (patterns, pattern_scheme, pattern_variables, defaul, var_store, expr_heap, opt_dynamics,illegal_combination_of_patterns_error cons_symbol cs) + where + illegal_combination_of_patterns_error cons_symbol cs + = { cs & cs_error = checkError cons_symbol.glob_object.ds_ident "illegal combination of patterns" cs.cs_error } transform_pattern (AP_WildCard (Yes opt_var)) patterns pattern_scheme pattern_variables defaul result_expr case_name pos var_store expr_heap opt_dynamics cs = transform_pattern (AP_Variable opt_var.bind_src opt_var.bind_dst No) patterns pattern_scheme pattern_variables defaul result_expr case_name pos var_store expr_heap opt_dynamics cs @@ -879,16 +918,16 @@ where insert_as_default :: !Expression !Expression -> Expression - insert_as_default to_insert (Let lad=:{let_expr}) - = Let { lad & let_expr = insert_as_default to_insert let_expr } - insert_as_default to_insert (Case kees=:{case_default}) + insert_as_default (Let lad=:{let_expr}) to_insert + = Let { lad & let_expr = insert_as_default let_expr to_insert } + insert_as_default (Case kees=:{case_default,case_explicit=False}) to_insert = case case_default of No -> Case { kees & case_default = Yes to_insert } - Yes defaul -> Case { kees & case_default = Yes (insert_as_default to_insert defaul)} - insert_as_default _ expr = expr // checkWarning "pattern won't match" + Yes defaul -> Case { kees & case_default = Yes (insert_as_default defaul to_insert)} + insert_as_default expr _ = expr // checkWarning "pattern won't match" build_and_share_case patterns defaul expr case_ident explicit var_heap expr_heap error_admin - # (expr, expr_heap)= build_case patterns defaul expr case_ident explicit expr_heap + # (expr, expr_heap) = build_case patterns defaul expr case_ident explicit expr_heap # (expr, var_heap, expr_heap) = share_case_expr expr var_heap expr_heap = (expr, var_heap, expr_heap, error_admin) @@ -914,8 +953,7 @@ where Yes (opt_var, result) -> case opt_var of Yes var - # (let_expression, expr_heap) = bind_default_variable expr var result expr_heap - -> (let_expression, expr_heap) + -> bind_default_variable expr var result expr_heap No -> (result, expr_heap) No @@ -928,8 +966,7 @@ where # (type_case_info_ptr, expr_heap) = newPtr EI_Empty expr_heap (bound_var, expr_heap) = allocate_bound_var var expr_heap result = buildTypeCase (Var bound_var) patterns (Yes result) type_case_info_ptr cCaseExplicit - (case_expression, expr_heap) = bind_default_variable expr var result expr_heap - -> (case_expression, expr_heap) + -> bind_default_variable expr var result expr_heap No # (type_case_info_ptr, expr_heap) = newPtr EI_Empty expr_heap -> (buildTypeCase expr patterns (Yes result) type_case_info_ptr cCaseExplicit, expr_heap) @@ -945,8 +982,7 @@ where case_ident = Yes case_ident, case_info_ptr = case_expr_ptr, case_explicit = explicit, case_default_pos = NoPos } - (case_expression, expr_heap) = bind_default_variable expr var result expr_heap - -> (case_expression, expr_heap) + -> bind_default_variable expr var result expr_heap No # (case_expr_ptr, expr_heap) = newPtr EI_Empty expr_heap -> (Case {case_expr = expr, case_guards = patterns, case_default = Yes result, @@ -1058,19 +1094,6 @@ where # (expr, free_vars, e_state, e_info, cs) = checkExpression free_vars bind_src e_input e_state e_info cs = ({ field & bind_src = expr }, free_vars, e_state, e_info, cs) - - get_field_var (AP_Algebraic _ _ _ (Yes {bind_src,bind_dst})) - = (bind_src, bind_dst) - get_field_var (AP_Basic _ (Yes {bind_src,bind_dst})) - = (bind_src, bind_dst) - get_field_var (AP_Dynamic _ _ (Yes {bind_src,bind_dst})) - = (bind_src, bind_dst) - get_field_var (AP_Variable id var_ptr _) - = (id, var_ptr) - get_field_var (AP_WildCard (Yes {bind_src,bind_dst})) - = (bind_src, bind_dst) - get_field_var _ - = ({ id_name = "** ERRONEOUS **", id_info = nilPtr }, nilPtr) checkExpression free_vars (PE_Dynamic expr opt_type) e_input e_state=:{es_dynamics=outer_dynamics} e_info cs # (dyn_expr, free_vars, e_state=:{es_dynamics, es_expr_heap}, e_info, cs) = checkExpression free_vars expr e_input {e_state & es_dynamics = []} e_info cs @@ -1222,6 +1245,23 @@ checkExpression free_vars (PE_TypeSignature array_kind expr) e_input e_state e_i strict_array_type = {at_attribute = array_type_attr_var, at_type = TA strict_array_type_symb_ident [element_type]} = (strict_array_type,var_store,attr_store) +/* + # {th_vars,th_attrs}=e_state.es_type_heaps + # (element_type_var_ptr,th_vars) = newPtr TVI_Empty th_vars + # (element_type_attr_ptr,th_attrs) = newPtr AVI_Empty th_attrs + # (array_type_attr_ptr,th_attrs) = newPtr AVI_Empty th_attrs + # e_state = {e_state & es_type_heaps = {th_vars=th_vars,th_attrs=th_attrs}} + + # element_type_var = {tv_ident = {id_name = "element_type_var", id_info = nilPtr}, tv_info_ptr = element_type_var_ptr} + # element_type_attr_var = {av_ident = {id_name = "element_type_attr", id_info = nilPtr},av_info_ptr = element_type_attr_ptr} + # array_type_attr_var = {av_ident = {id_name = "array_type_attr", id_info = nilPtr},av_info_ptr = array_type_attr_ptr} + + # element_type = {at_attribute = TA_Var element_type_attr_var, at_type = TV element_type_var} + # strict_array_type = {at_attribute = TA_Var array_type_attr_var, at_type = TA strict_array_type_symb_ident [element_type]} + + # expr = TypeSignature strict_array_type expr +*/ + checkExpression free_vars expr e_input e_state e_info cs = abort "checkExpression (checkFunctionBodies.icl)" // <<- expr @@ -1283,19 +1323,25 @@ where = (EE, free_vars, e_state, e_info, { cs & cs_error = checkError id "generic: missing kind argument" cs_error}) check_id_expression entry is_expr_list free_vars id=:{id_info} e_input e_state e_info cs - # (symb_kind, arity, priority, is_a_function, e_state, e_info, cs) = determine_info_of_symbol entry id_info e_input e_state e_info cs + # (symb_kind, arity, priority, e_state, e_info, cs) = determine_info_of_symbol entry id_info e_input e_state e_info cs symbol = { symb_ident = id, symb_kind = symb_kind } | is_expr_list - = (Constant symbol arity priority is_a_function, free_vars, e_state, e_info, cs) - | is_a_function - # (new_info_ptr, es_expr_heap) = newPtr EI_Empty e_state.es_expr_heap - # app_expr = App { app_symb = symbol , app_args = [], app_info_ptr = new_info_ptr } - = (app_expr, free_vars, { e_state & es_expr_heap = es_expr_heap }, e_info, cs) - # app_expr = App { app_symb = symbol , app_args = [], app_info_ptr = nilPtr } - = (app_expr, free_vars, e_state, e_info, cs) + = (Constant symbol arity priority, free_vars, e_state, e_info, cs) + = case symb_kind of + SK_Constructor _ + # app_expr = App { app_symb = symbol , app_args = [], app_info_ptr = nilPtr } + -> (app_expr, free_vars, e_state, e_info, cs) + SK_NewTypeConstructor _ + # cs = { cs & cs_error = checkError id "argument missing (for newtype constructor)" cs.cs_error} + # app_expr = App { app_symb = symbol , app_args = [], app_info_ptr = nilPtr } + -> (app_expr, free_vars, e_state, e_info, cs) + _ + # (new_info_ptr, es_expr_heap) = newPtr EI_Empty e_state.es_expr_heap + # app_expr = App { app_symb = symbol , app_args = [], app_info_ptr = new_info_ptr } + -> (app_expr, free_vars, { e_state & es_expr_heap = es_expr_heap }, e_info, cs) determine_info_of_symbol :: !SymbolTableEntry !SymbolPtr !ExpressionInput !*ExpressionState !u:ExpressionInfo !*CheckState - -> (!SymbKind, !Int, !Priority, !Bool, !*ExpressionState, !u:ExpressionInfo,!*CheckState) + -> (!SymbKind, !Int, !Priority, !*ExpressionState, !u:ExpressionInfo,!*CheckState) determine_info_of_symbol entry=:{ste_kind=STE_FunctionOrMacro calls,ste_index,ste_def_level} symb_info e_input=:{ei_fun_index} e_state=:{es_calls} e_info cs=:{cs_symbol_table,cs_x} # (fun_def,e_state) = e_state!es_fun_defs.[ste_index] @@ -1303,10 +1349,10 @@ where # index = { glob_object = ste_index, glob_module = cs_x.x_main_dcl_module_n } # symbol_kind = convert_DefOrImpFunKind_to_icl_SymbKind fun_kind index fi_properties | is_called_before ei_fun_index calls - = (symbol_kind, fun_arity, fun_priority, cIsAFunction, e_state, e_info, cs) + = (symbol_kind, fun_arity, fun_priority, e_state, e_info, cs) # cs = { cs & cs_symbol_table = cs_symbol_table <:= (symb_info, { entry & ste_kind = STE_FunctionOrMacro [ ei_fun_index : calls ]})} # e_state = { e_state & es_calls = [FunCall ste_index ste_def_level : es_calls ]} - = (symbol_kind, fun_arity, fun_priority, cIsAFunction, e_state, e_info, cs) + = (symbol_kind, fun_arity, fun_priority, e_state, e_info, cs) determine_info_of_symbol entry=:{ste_kind=STE_DclMacroOrLocalMacroFunction calls,ste_index,ste_def_level} symb_info e_input=:{ei_fun_index, ei_mod_index} e_state=:{es_calls} e_info cs=:{cs_symbol_table} # (macro_def,e_info) = e_info!ef_macro_defs.[ei_mod_index,ste_index] @@ -1314,10 +1360,10 @@ where # index = { glob_object = ste_index, glob_module = ei_mod_index } # symbol_kind = convert_DefOrImpFunKind_to_dcl_SymbKind fun_kind index fi_properties | is_called_before ei_fun_index calls - = (symbol_kind, fun_arity, fun_priority, cIsAFunction, e_state, e_info, cs) + = (symbol_kind, fun_arity, fun_priority, e_state, e_info, cs) # cs = { cs & cs_symbol_table = cs_symbol_table <:= (symb_info, { entry & ste_kind = STE_DclMacroOrLocalMacroFunction [ ei_fun_index : calls ]})} # e_state = { e_state & es_calls = [MacroCall ei_mod_index ste_index ste_def_level : es_calls ]} - = (symbol_kind, fun_arity, fun_priority, cIsAFunction, e_state, e_info, cs) + = (symbol_kind, fun_arity, fun_priority, e_state, e_info, cs) determine_info_of_symbol entry=:{ste_kind=STE_Imported (STE_DclMacroOrLocalMacroFunction calls) macro_mod_index,ste_index,ste_def_level} symb_info e_input=:{ei_fun_index} e_state=:{es_calls} e_info cs=:{cs_symbol_table} # (macro_def,e_info) = e_info!ef_macro_defs.[macro_mod_index,ste_index] @@ -1325,48 +1371,51 @@ where # index = { glob_object = ste_index, glob_module = macro_mod_index } # symbol_kind = convert_DefOrImpFunKind_to_dcl_SymbKind fun_kind index fi_properties | is_called_before ei_fun_index calls - = (symbol_kind, fun_arity, fun_priority, cIsAFunction, e_state, e_info, cs) + = (symbol_kind, fun_arity, fun_priority, e_state, e_info, cs) # cs = { cs & cs_symbol_table = cs_symbol_table <:= (symb_info, { entry & ste_kind = STE_Imported (STE_DclMacroOrLocalMacroFunction [ ei_fun_index : calls ]) macro_mod_index})} # e_state = { e_state & es_calls = [MacroCall macro_mod_index ste_index ste_def_level : es_calls ]} - = (symbol_kind, fun_arity, fun_priority, cIsAFunction, e_state, e_info, cs) + = (symbol_kind, fun_arity, fun_priority, e_state, e_info, cs) determine_info_of_symbol entry=:{ste_kind=STE_Imported STE_DclFunction mod_index,ste_index} symb_index e_input e_state=:{es_calls} e_info=:{ef_is_macro_fun} cs # ({ft_type={st_arity},ft_priority}, e_info) = e_info!ef_modules.[mod_index].dcl_functions.[ste_index] # kind = SK_Function { glob_object = ste_index, glob_module = mod_index } | not ef_is_macro_fun - = (kind, st_arity, ft_priority, cIsAFunction, e_state, e_info, cs) + = (kind, st_arity, ft_priority, e_state, e_info, cs) | dcl_fun_is_called_before ste_index mod_index es_calls - = (kind, st_arity, ft_priority, cIsAFunction, e_state, e_info , cs) + = (kind, st_arity, ft_priority, e_state, e_info , cs) # e_state = { e_state & es_calls = [DclFunCall mod_index ste_index : es_calls ]} - = (kind, st_arity, ft_priority, cIsAFunction, e_state, e_info, cs) + = (kind, st_arity, ft_priority, e_state, e_info, cs) determine_info_of_symbol entry=:{ste_kind=STE_Imported kind mod_index,ste_index} symb_index e_input e_state e_info=:{ef_modules} cs # (mod_def, ef_modules) = ef_modules![mod_index] - # (kind, arity, priority, is_fun) = ste_kind_to_symbol_kind kind ste_index mod_index mod_def - = (kind, arity, priority, is_fun, e_state, { e_info & ef_modules = ef_modules }, cs) + # (kind, arity, priority) = ste_kind_to_symbol_kind kind ste_index mod_index mod_def + = (kind, arity, priority, e_state, { e_info & ef_modules = ef_modules }, cs) where - ste_kind_to_symbol_kind :: !STE_Kind !Index !Index !DclModule -> (!SymbKind, !Int, !Priority, !Bool); + ste_kind_to_symbol_kind :: !STE_Kind !Index !Index !DclModule -> (!SymbKind, !Int, !Priority); ste_kind_to_symbol_kind STE_Member def_index mod_index {dcl_common={com_member_defs}} # {me_type={st_arity},me_priority} = com_member_defs.[def_index] - = (SK_OverloadedFunction { glob_object = def_index, glob_module = mod_index }, st_arity, me_priority, cIsAFunction) + = (SK_OverloadedFunction { glob_object = def_index, glob_module = mod_index }, st_arity, me_priority) ste_kind_to_symbol_kind STE_Constructor def_index mod_index {dcl_common={com_cons_defs}} - # {cons_type={st_arity},cons_priority} = com_cons_defs.[def_index] - = (SK_Constructor { glob_object = def_index, glob_module = mod_index }, st_arity, cons_priority, cIsNotAFunction) + # {cons_type={st_arity},cons_priority,cons_number} = com_cons_defs.[def_index] + | cons_number <> -2 + = (SK_Constructor { glob_object = def_index, glob_module = mod_index }, st_arity, cons_priority) + = (SK_NewTypeConstructor {gi_index = def_index, gi_module = mod_index}, st_arity, cons_priority) determine_info_of_symbol {ste_kind=STE_Member, ste_index} _ e_input=:{ei_mod_index} e_state e_info=:{ef_member_defs} cs # ({me_type={st_arity},me_priority}, ef_member_defs) = ef_member_defs![ste_index] - = (SK_OverloadedFunction { glob_object = ste_index, glob_module = ei_mod_index}, st_arity, me_priority, cIsAFunction, + = (SK_OverloadedFunction { glob_object = ste_index, glob_module = ei_mod_index}, st_arity, me_priority, e_state, { e_info & ef_member_defs = ef_member_defs }, cs) - determine_info_of_symbol {ste_kind=STE_Constructor, ste_index} _ e_input=:{ei_mod_index} e_state e_info=:{ef_cons_defs} cs - # ({cons_type={st_arity},cons_priority}, ef_cons_defs) = ef_cons_defs![ste_index] - = (SK_Constructor { glob_object = ste_index, glob_module = ei_mod_index}, st_arity, cons_priority, cIsNotAFunction, - e_state, { e_info & ef_cons_defs = ef_cons_defs }, cs) + determine_info_of_symbol {ste_kind=STE_Constructor, ste_index} _ e_input=:{ei_mod_index} e_state e_info cs + # ({cons_type={st_arity},cons_priority,cons_number}, e_info) = e_info!ef_cons_defs.[ste_index] + | cons_number <> -2 + = (SK_Constructor { glob_object = ste_index, glob_module = ei_mod_index}, st_arity, cons_priority, e_state, e_info, cs) + = (SK_NewTypeConstructor {gi_index = ste_index, gi_module = ei_mod_index}, st_arity, cons_priority, e_state, e_info, cs) determine_info_of_symbol {ste_kind=STE_DclFunction, ste_index} _ e_input=:{ei_mod_index} e_state=:{es_calls} e_info=:{ef_is_macro_fun} cs # ({ft_type={st_arity},ft_priority}, e_info) = e_info!ef_modules.[ei_mod_index].dcl_functions.[ste_index] # kind = SK_Function { glob_object = ste_index, glob_module = ei_mod_index } | not ef_is_macro_fun - = (kind, st_arity, ft_priority, cIsAFunction, e_state, e_info, cs) + = (kind, st_arity, ft_priority, e_state, e_info, cs) | dcl_fun_is_called_before ste_index ei_mod_index es_calls - = (kind, st_arity, ft_priority, cIsAFunction, e_state, e_info, cs) + = (kind, st_arity, ft_priority, e_state, e_info, cs) # e_state = { e_state & es_calls = [DclFunCall ei_mod_index ste_index : es_calls ]} - = (kind, st_arity, ft_priority, cIsAFunction, e_state, e_info, cs) + = (kind, st_arity, ft_priority, e_state, e_info, cs) convert_DefOrImpFunKind_to_icl_SymbKind FK_Macro index fi_properties = SK_IclMacro index.glob_object; @@ -1390,11 +1439,16 @@ checkQualifiedIdentExpression free_vars module_id ident_name is_expr_list e_inpu # e_state = { e_state & es_calls = [DclFunCall mod_index decl_index : e_state.es_calls ]} -> (app_expr, free_vars, e_state, e_info, cs) STE_Imported STE_Constructor mod_index - # ({cons_type={st_arity},cons_priority}, e_info) = e_info!ef_modules.[mod_index].dcl_common.com_cons_defs.[decl_index] - # kind = SK_Constructor { glob_object = decl_index, glob_module = mod_index } - # symbol = { symb_ident = decl_ident, symb_kind = kind } - # app_expr = build_application_or_constant_for_constructor symbol st_arity cons_priority - -> (app_expr, free_vars, e_state, e_info, cs) + # ({cons_type={st_arity},cons_priority,cons_number}, e_info) = e_info!ef_modules.[mod_index].dcl_common.com_cons_defs.[decl_index] + | cons_number <> -2 + # kind = SK_Constructor { glob_object = decl_index, glob_module = mod_index } + # symbol = { symb_ident = decl_ident, symb_kind = kind } + # app_expr = build_application_or_constant_for_constructor symbol st_arity cons_priority + -> (app_expr, free_vars, e_state, e_info, cs) + # kind = SK_NewTypeConstructor { gi_index = decl_index, gi_module = mod_index } + # symbol = { symb_ident = decl_ident, symb_kind = kind } + # app_expr = build_application_or_constant_for_constructor symbol st_arity cons_priority + -> (app_expr, free_vars, e_state, e_info, cs) STE_Imported STE_Member mod_index # ({me_type={st_arity},me_priority}, e_info) = e_info!ef_modules.[mod_index].dcl_common.com_member_defs.[decl_index] # kind = SK_OverloadedFunction { glob_object = decl_index, glob_module = mod_index } @@ -1447,14 +1501,14 @@ checkQualifiedIdentExpression free_vars module_id ident_name is_expr_list e_inpu where build_application_or_constant_for_function symbol arity priority e_state | is_expr_list - = (Constant symbol arity priority cIsAFunction, e_state) + = (Constant symbol arity priority, e_state) # (new_info_ptr, es_expr_heap) = newPtr EI_Empty e_state.es_expr_heap # app = { app_symb = symbol , app_args = [], app_info_ptr = new_info_ptr } = (App app, { e_state & es_expr_heap = es_expr_heap }) build_application_or_constant_for_constructor symbol arity priority | is_expr_list - = Constant symbol arity priority cIsNotAFunction + = Constant symbol arity priority = App { app_symb = symbol , app_args = [], app_info_ptr = nilPtr } convert_DefOrImpFunKind_to_dcl_SymbKind FK_Macro index fi_properties @@ -1625,9 +1679,6 @@ checkPattern (PE_Record record opt_type fields) opt_var p_input=:{pi_mod_index, (patterns, ps_var_heap) = bind_opt_record_variable opt_var pi_is_node_pattern patterns new_fields ps.ps_var_heap -> (AP_Algebraic record_symbol type_index patterns opt_var, (var_env, array_patterns), { ps & ps_var_heap = ps_var_heap }, e_info, cs) No - # id_name = case (hd fields).bind_dst of - FieldName {id_name} -> id_name - QualifiedFieldName module_id field_name -> module_id.id_name+++"@"+++field_name -> (AP_Empty, accus, ps, e_info, cs) where @@ -1650,6 +1701,9 @@ where add_bound_variable (AP_Basic bas_val No) {bind_dst = {glob_object={fs_var}}} ps_var_heap # (new_info_ptr, ps_var_heap) = newPtr VI_Empty ps_var_heap = (AP_Basic bas_val (Yes { bind_src = fs_var, bind_dst = new_info_ptr}), ps_var_heap) + add_bound_variable (AP_NewType symbol index pattern No) {bind_dst = {glob_object={fs_var}}} ps_var_heap + # (new_info_ptr, ps_var_heap) = newPtr VI_Empty ps_var_heap + = (AP_NewType symbol index pattern (Yes { bind_src = fs_var, bind_dst = new_info_ptr}), ps_var_heap) add_bound_variable (AP_Dynamic dynamic_pattern dynamic_type No) {bind_dst = {glob_object={fs_var}}} ps_var_heap # (new_info_ptr, ps_var_heap) = newPtr VI_Empty ps_var_heap = (AP_Dynamic dynamic_pattern dynamic_type (Yes { bind_src = fs_var, bind_dst = new_info_ptr}), ps_var_heap) @@ -1762,25 +1816,29 @@ checkPatternConstructor mod_index is_expr_list {ste_kind = STE_Imported (STE_Dcl = checkMacroPatternConstructor macro macro_module_index mod_index True is_expr_list ste_index ident opt_var ps e_info cs checkPatternConstructor mod_index is_expr_list {ste_index, ste_kind} cons_ident opt_var ps e_info=:{ef_cons_defs,ef_modules} cs=:{cs_error} - # (cons_index, cons_module, cons_arity, cons_priority, cons_type_index, ef_cons_defs, ef_modules, cs_error) + # (cons_index, cons_module, cons_arity, cons_priority, cons_type_index, cons_number, ef_cons_defs, ef_modules, cs_error) = determine_pattern_symbol mod_index ste_index ste_kind cons_ident.id_name ef_cons_defs ef_modules cs_error e_info = { e_info & ef_cons_defs = ef_cons_defs, ef_modules = ef_modules } cons_symbol = { glob_object = MakeDefinedSymbol cons_ident cons_index cons_arity, glob_module = cons_module } - | is_expr_list - = (AP_Constant (APK_Constructor cons_type_index) cons_symbol cons_priority, ps, e_info, { cs & cs_error = cs_error }) - | cons_arity == 0 - = (AP_Algebraic cons_symbol cons_type_index [] opt_var, ps, e_info, { cs & cs_error = cs_error }) - = (AP_Algebraic cons_symbol cons_type_index [] opt_var, ps, e_info, { cs & cs_error = checkError cons_ident "constructor arguments are missing" cs_error }) + | cons_number <> -2 + | is_expr_list + = (AP_Constant (APK_Constructor cons_type_index) cons_symbol cons_priority, ps, e_info, { cs & cs_error = cs_error }) + | cons_arity == 0 + = (AP_Algebraic cons_symbol cons_type_index [] opt_var, ps, e_info, { cs & cs_error = cs_error }) + = (AP_Algebraic cons_symbol cons_type_index [] opt_var, ps, e_info, { cs & cs_error = checkError cons_ident "constructor arguments are missing" cs_error }) + | is_expr_list + = (AP_Constant (APK_NewTypeConstructor cons_type_index) cons_symbol cons_priority, ps, e_info, { cs & cs_error = cs_error }) + = (AP_NewType cons_symbol cons_type_index AP_Empty opt_var, ps, e_info, { cs & cs_error = checkError cons_ident "constructor argument is missing" cs_error }) where determine_pattern_symbol mod_index id_index STE_Constructor id_name cons_defs modules error - # ({cons_type={st_arity},cons_priority, cons_type_index}, cons_defs) = cons_defs![id_index] - = (id_index, mod_index, st_arity, cons_priority, cons_type_index, cons_defs, modules, error) + # ({cons_type={st_arity},cons_priority,cons_type_index,cons_number}, cons_defs) = cons_defs![id_index] + = (id_index, mod_index, st_arity, cons_priority, cons_type_index, cons_number, cons_defs, modules, error) determine_pattern_symbol mod_index id_index (STE_Imported STE_Constructor import_mod_index) id_name cons_defs modules error # ({dcl_common},modules) = modules![import_mod_index] - {cons_type={st_arity},cons_priority, cons_type_index} = dcl_common.com_cons_defs.[id_index] - = (id_index, import_mod_index, st_arity, cons_priority, cons_type_index, cons_defs, modules, error) + {cons_type={st_arity},cons_priority,cons_type_index,cons_number} = dcl_common.com_cons_defs.[id_index] + = (id_index, import_mod_index, st_arity, cons_priority, cons_type_index, cons_number, cons_defs, modules, error) determine_pattern_symbol mod_index id_index id_kind id_name cons_defs modules error - = (id_index, NoIndex, 0, NoPrio, NoIndex, cons_defs, modules, checkError id_name "constructor expected" error) + = (id_index, NoIndex, 0, NoPrio, NoIndex, NoIndex, cons_defs, modules, checkError id_name "constructor expected" error) checkQualifiedPatternConstructor :: !STE_Kind !Index !Ident !{#Char} !{#Char} !Index !Bool !(Optional (Bind Ident VarInfoPtr)) !*PatternState !*ExpressionInfo !*CheckState -> (!AuxiliaryPattern, !*PatternState, !*ExpressionInfo, !*CheckState); @@ -1798,25 +1856,29 @@ checkQualifiedPatternConstructor (STE_Imported (STE_DclMacroOrLocalMacroFunction = checkQualifiedMacroPatternConstructor macro macro_module_index mod_index True is_expr_list ste_index module_name ident_name opt_var ps e_info cs checkQualifiedPatternConstructor ste_kind ste_index decl_ident module_name ident_name mod_index is_expr_list opt_var ps e_info=:{ef_cons_defs,ef_modules} cs=:{cs_error} - # (cons_index, cons_module, cons_arity, cons_priority, cons_type_index, ef_cons_defs, ef_modules, cs_error) + # (cons_index, cons_module, cons_arity, cons_priority, cons_type_index, cons_number, ef_cons_defs, ef_modules, cs_error) = determine_pattern_symbol mod_index ste_index ste_kind module_name ident_name ef_cons_defs ef_modules cs_error e_info = { e_info & ef_cons_defs = ef_cons_defs, ef_modules = ef_modules } cons_symbol = { glob_object = MakeDefinedSymbol decl_ident cons_index cons_arity, glob_module = cons_module } - | is_expr_list - = (AP_Constant (APK_Constructor cons_type_index) cons_symbol cons_priority, ps, e_info, { cs & cs_error = cs_error }) - | cons_arity == 0 - = (AP_Algebraic cons_symbol cons_type_index [] opt_var, ps, e_info, { cs & cs_error = cs_error }) - = (AP_Algebraic cons_symbol cons_type_index [] opt_var, ps, e_info, { cs & cs_error = checkError ident_name "constructor arguments are missing" cs_error }) + | cons_number <> -2 + | is_expr_list + = (AP_Constant (APK_Constructor cons_type_index) cons_symbol cons_priority, ps, e_info, { cs & cs_error = cs_error }) + | cons_arity == 0 + = (AP_Algebraic cons_symbol cons_type_index [] opt_var, ps, e_info, { cs & cs_error = cs_error }) + = (AP_Algebraic cons_symbol cons_type_index [] opt_var, ps, e_info, { cs & cs_error = checkError ident_name "constructor arguments are missing" cs_error }) + | is_expr_list + = (AP_Constant (APK_NewTypeConstructor cons_type_index) cons_symbol cons_priority, ps, e_info, { cs & cs_error = cs_error }) + = (AP_NewType cons_symbol cons_type_index AP_Empty opt_var, ps, e_info, { cs & cs_error = checkError ident_name "constructor argument is missing" cs_error }) where determine_pattern_symbol mod_index id_index STE_Constructor module_name ident_name cons_defs modules error - # ({cons_type={st_arity},cons_priority, cons_type_index}, cons_defs) = cons_defs![id_index] - = (id_index, mod_index, st_arity, cons_priority, cons_type_index, cons_defs, modules, error) + # ({cons_type={st_arity},cons_priority,cons_type_index,cons_number}, cons_defs) = cons_defs![id_index] + = (id_index, mod_index, st_arity, cons_priority, cons_type_index, cons_number, cons_defs, modules, error) determine_pattern_symbol mod_index id_index (STE_Imported STE_Constructor import_mod_index) module_name ident_name cons_defs modules error # ({dcl_common},modules) = modules![import_mod_index] - {cons_type={st_arity},cons_priority, cons_type_index} = dcl_common.com_cons_defs.[id_index] - = (id_index, import_mod_index, st_arity, cons_priority, cons_type_index, cons_defs, modules, error) + {cons_type={st_arity},cons_priority,cons_type_index,cons_number} = dcl_common.com_cons_defs.[id_index] + = (id_index, import_mod_index, st_arity, cons_priority, cons_type_index, cons_number, cons_defs, modules, error) determine_pattern_symbol mod_index id_index id_kind module_name ident_name cons_defs modules error - = (id_index, NoIndex, 0, NoPrio, NoIndex, cons_defs, modules, checkError (module_name+++"@"+++ident_name) "constructor expected" error) + = (id_index, NoIndex, 0, NoPrio, NoIndex, NoIndex, cons_defs, modules, checkError (module_name+++"@"+++ident_name) "constructor expected" error) checkBoundPattern {bind_src,bind_dst} opt_var p_input (var_env, array_patterns) ps e_info cs=:{cs_symbol_table} | isLowerCaseName bind_dst.id_name @@ -1913,6 +1975,22 @@ convertSubPattern (AP_Basic basic_val opt_var) result_expr pattern_position var_ case_explicit = cCaseNotExplicit, case_default_pos = NoPos}, NoPos, var_store, expr_heap, opt_dynamics, cs) +convertSubPattern (AP_NewType cons_symbol type_index arg opt_var) result_expr pattern_position + var_store expr_heap opt_dynamics cs + # (var_arg, result_expr, pattern_position, var_store, expr_heap, opt_dynamics, cs) + = convertSubPattern arg result_expr pattern_position var_store expr_heap opt_dynamics cs + type_symbol = { glob_module = cons_symbol.glob_module, glob_object = type_index } + ({bind_src,bind_dst}, var_store) = determinePatternVariable opt_var var_store + (var_expr_ptr, expr_heap) = newPtr EI_Empty expr_heap + (case_expr_ptr, expr_heap) = newPtr EI_Empty expr_heap + # alg_patterns = [{ ap_symbol = cons_symbol, ap_vars = [var_arg], ap_expr = result_expr, ap_position = pattern_position }] + # case_guards = NewTypePatterns type_symbol alg_patterns + = ({ fv_ident = bind_src, fv_info_ptr = bind_dst, fv_def_level = NotALevel, fv_count = 0 }, + Case { case_expr = Var { var_ident = bind_src, var_info_ptr = bind_dst, var_expr_ptr = var_expr_ptr }, + case_guards = case_guards, case_default = No, case_ident = No, case_info_ptr = case_expr_ptr, + case_explicit = cCaseNotExplicit, + case_default_pos = NoPos }, + NoPos, var_store, expr_heap, opt_dynamics, cs) convertSubPattern (AP_Dynamic pattern type opt_var) result_expr pattern_position var_store expr_heap opt_dynamics cs # (var_arg, result_expr, pattern_position, var_store, expr_heap, opt_dynamics, cs) = convertSubPattern pattern result_expr pattern_position var_store expr_heap opt_dynamics cs @@ -1983,6 +2061,11 @@ transfromPatternIntoBind mod_index def_level (AP_Algebraic cons_symbol=:{glob_mo = bind_match_expr (MatchExpr cons_symbol src_expr) opt_var_bind position def_level var_store expr_heap -> transform_sub_patterns mod_index def_level args tuple_cons.glob_object 0 match_var match_bind position var_store expr_heap e_info cs +transfromPatternIntoBind mod_index def_level (AP_NewType cons_symbol type_index arg opt_var) src_expr position var_store expr_heap e_info cs + # (src_expr, opt_var_bind, var_store, expr_heap) = bind_opt_var opt_var src_expr position var_store expr_heap + # (binds, var_store, expr_heap, e_info, cs) + = transfromPatternIntoBind mod_index def_level arg (MatchExpr {cons_symbol & glob_object.ds_arity = -2} src_expr) position var_store expr_heap e_info cs + = (opt_var_bind ++ binds, var_store, expr_heap, e_info, cs) transfromPatternIntoBind mod_index def_level (AP_WildCard _) src_expr _ var_store expr_heap e_info cs = ([], var_store, expr_heap, e_info, cs) transfromPatternIntoBind _ _ pattern src_expr _ var_store expr_heap e_info cs @@ -2022,6 +2105,11 @@ transfromPatternIntoStrictBind mod_index def_level (AP_Algebraic cons_symbol=:{g # (lazy_binds,var_store,expr_heap,e_info,cs) = transform_sub_patterns mod_index def_level args tuple_cons.glob_object 0 match_var match_bind position var_store expr_heap e_info cs -> (lazy_binds,src_bind,var_store,expr_heap,e_info,cs) +transfromPatternIntoStrictBind mod_index def_level (AP_NewType cons_symbol type_index arg opt_var) src_expr position var_store expr_heap e_info cs + # (src_expr, src_bind, var_store, expr_heap) = bind_opt_var_or_create_new_var opt_var src_expr position def_level var_store expr_heap + # (binds, var_store, expr_heap, e_info, cs) + = transfromPatternIntoBind mod_index def_level arg (MatchExpr {cons_symbol & glob_object.ds_arity = -2} src_expr) position var_store expr_heap e_info cs + = (binds,src_bind, var_store, expr_heap, e_info, cs) transfromPatternIntoStrictBind mod_index def_level (AP_WildCard _) src_expr _ var_store expr_heap e_info cs = ([],[],var_store, expr_heap, e_info, cs) transfromPatternIntoStrictBind _ _ pattern src_expr _ var_store expr_heap e_info cs @@ -2539,31 +2627,43 @@ buildLetExpression let_strict_binds let_lazy_binds expr let_expr_position expr_h = (Let {let_strict_binds = let_strict_binds, let_lazy_binds = let_lazy_binds, let_expr = expr, let_info_ptr = let_expr_ptr, let_expr_position = let_expr_position }, expr_heap) -buildApplication :: !SymbIdent !Int !Int !Bool ![Expression] !*ExpressionState !*ErrorAdmin -> (!Expression,!*ExpressionState,!*ErrorAdmin) -buildApplication symbol form_arity act_arity is_fun args e_state=:{es_expr_heap} error - | is_fun - # (new_info_ptr, es_expr_heap) = newPtr EI_Empty es_expr_heap - | form_arity < act_arity - # app = { app_symb = symbol , app_args = take form_arity args, app_info_ptr = new_info_ptr } - = (App app @ drop form_arity args, { e_state & es_expr_heap = es_expr_heap }, error) - # app = { app_symb = symbol , app_args = take form_arity args, app_info_ptr = new_info_ptr } - = (App app, { e_state & es_expr_heap = es_expr_heap }, error) - # app = App { app_symb = symbol , app_args = args, app_info_ptr = nilPtr } - | form_arity < act_arity - = (app, e_state, checkError symbol.symb_ident "used with too many arguments" error) - = (app, e_state, error) - -buildApplicationWithoutArguments :: !SymbIdent !Bool !*ExpressionState !*ErrorAdmin -> (!Expression,!*ExpressionState,!*ErrorAdmin) -buildApplicationWithoutArguments symbol is_fun e_state error - | is_fun - # (new_info_ptr, es_expr_heap) = newPtr EI_Empty e_state.es_expr_heap - # app = App { app_symb = symbol , app_args = [], app_info_ptr = new_info_ptr } - = (app, { e_state & es_expr_heap = es_expr_heap }, error) - # app = App { app_symb = symbol , app_args = [], app_info_ptr = nilPtr } +buildApplication :: !SymbIdent !Int !Int ![Expression] !*ExpressionState !*ErrorAdmin -> (!Expression,!*ExpressionState,!*ErrorAdmin) +buildApplication symbol=:{symb_kind=SK_Constructor _} form_arity act_arity args e_state error + # app = App { app_symb = symbol , app_args = args, app_info_ptr = nilPtr } + | act_arity > form_arity + = (app, e_state, checkError symbol.symb_ident "used with too many arguments" error) + = (app, e_state, error) +buildApplication symbol=:{symb_kind=SK_NewTypeConstructor _} form_arity act_arity args e_state error + # app = App { app_symb = symbol , app_args = args, app_info_ptr = nilPtr } + | act_arity == form_arity = (app, e_state, error) + | act_arity > form_arity + = (app, e_state, checkError symbol.symb_ident "used with too many arguments" error) + = (app, e_state, checkError symbol.symb_ident "argument missing (for newtype constructor)" error) +buildApplication symbol form_arity act_arity args e_state=:{es_expr_heap} error + # (new_info_ptr, es_expr_heap) = newPtr EI_Empty es_expr_heap + | form_arity < act_arity + # app = { app_symb = symbol , app_args = take form_arity args, app_info_ptr = new_info_ptr } + = (App app @ drop form_arity args, { e_state & es_expr_heap = es_expr_heap }, error) + # app = { app_symb = symbol , app_args = take form_arity args, app_info_ptr = new_info_ptr } + = (App app, { e_state & es_expr_heap = es_expr_heap }, error) + +buildApplicationWithoutArguments :: !SymbIdent !*ExpressionState !*ErrorAdmin -> (!Expression,!*ExpressionState,!*ErrorAdmin) +buildApplicationWithoutArguments symbol=:{symb_kind=SK_Constructor _} e_state error + # app = App { app_symb = symbol , app_args = [], app_info_ptr = nilPtr } + = (app, e_state, error) +buildApplicationWithoutArguments symbol=:{symb_kind=SK_NewTypeConstructor _} e_state error + # app = App { app_symb = symbol , app_args = [], app_info_ptr = nilPtr } + = (app, e_state, checkError symbol.symb_ident "argument missing (for newtype constructor)" error) +buildApplicationWithoutArguments symbol e_state error + # (new_info_ptr, es_expr_heap) = newPtr EI_Empty e_state.es_expr_heap + # app = App { app_symb = symbol , app_args = [], app_info_ptr = new_info_ptr } + = (app, { e_state & es_expr_heap = es_expr_heap }, error) buildPattern mod_index (APK_Constructor type_index) cons_ident args opt_var ps e_info cs = (AP_Algebraic cons_ident type_index args opt_var, ps, e_info, cs) +buildPattern mod_index (APK_NewTypeConstructor type_index) cons_ident [arg] opt_var ps e_info cs + = (AP_NewType cons_ident type_index arg opt_var, ps, e_info, cs) buildPattern mod_index (APK_Macro is_dcl_macro) {glob_module,glob_object} args opt_var ps e_info=:{ef_modules,ef_macro_defs,ef_cons_defs} cs=:{cs_error} | is_dcl_macro # (macro,ef_macro_defs) = ef_macro_defs![glob_module,glob_object.ds_index] diff --git a/frontend/checktypes.icl b/frontend/checktypes.icl index c2ccb0f..d3286b4 100644 --- a/frontend/checktypes.icl +++ b/frontend/checktypes.icl @@ -341,10 +341,15 @@ where = [av : attr_vars] add_attr_var attr attr_vars = attr_vars - check_rhs_of_TypeDef {td_rhs = SynType type} _ cti ts_ti_cs # (type, type_attr, ts_ti_cs) = bindTypes cti type ts_ti_cs = (SynType type, ts_ti_cs) + check_rhs_of_TypeDef {td_ident,td_arity,td_args,td_rhs = td_rhs=:NewType cons} attr_vars cti=:{cti_module_index,cti_type_index,cti_lhs_attribute} ts_ti_cs + # type_lhs = { at_attribute = cti_lhs_attribute, + at_type = TA (MakeTypeSymbIdent { glob_object = cti_type_index, glob_module = cti_module_index } td_ident td_arity) + [{at_attribute = atv_attribute,at_type = TV atv_variable} \\ {atv_variable, atv_attribute} <- td_args]} + ts_ti_cs = bind_types_of_constructor cti -2 [ atv_variable \\ {atv_variable} <- td_args] attr_vars type_lhs cons ts_ti_cs + = (td_rhs, ts_ti_cs) check_rhs_of_TypeDef {td_rhs = AbstractSynType properties type} _ cti ts_ti_cs # (type, type_attr, ts_ti_cs) = bindTypes cti type ts_ti_cs = (AbstractSynType properties type, ts_ti_cs) @@ -380,7 +385,7 @@ where = ({ ts & ts_cons_defs.[ds_index] = cons_def}, { ti & ti_var_heap = ti_var_heap }, { cs & cs_symbol_table=symbol_table }) where bind_types_of_cons :: ![AType] !CurrentTypeInfo ![TypeVar] ![AttrInequality] !(!*TypeSymbols, !*TypeInfo, !*CheckState) - -> (![AType], ![[ATypeVar]], ![AttrInequality], !(!*TypeSymbols, !*TypeInfo, !*CheckState)) + -> (![AType], ![[ATypeVar]], ![AttrInequality],!(!*TypeSymbols, !*TypeInfo, !*CheckState)) bind_types_of_cons [] cti free_vars attr_env ts_ti_cs = ([], [], attr_env, ts_ti_cs) bind_types_of_cons [type : types] cti free_vars attr_env ts_ti_cs @@ -529,7 +534,7 @@ checkArityOfType act_arity form_arity (SynType _) checkArityOfType act_arity form_arity _ = form_arity >= act_arity -checkAbstractType type_index(AbstractType _) = type_index <> cPredefinedModuleIndex +checkAbstractType type_index (AbstractType _) = type_index <> cPredefinedModuleIndex checkAbstractType type_index (AbstractSynType _ _) = type_index <> cPredefinedModuleIndex checkAbstractType _ _ = False diff --git a/frontend/comparedefimp.icl b/frontend/comparedefimp.icl index d39201c..b12c925 100644 --- a/frontend/comparedefimp.icl +++ b/frontend/comparedefimp.icl @@ -73,7 +73,15 @@ where = True # field_nr = dec field_nr = dcl_fields.[field_nr].fs_index == icl_fields.[field_nr].fs_index && compare_fields field_nr dcl_fields icl_fields - + compare_rhs_of_types (NewType dclConstructor) (NewType iclConstructor) dcl_cons_defs icl_cons_defs comp_st + | dclConstructor.ds_index<>iclConstructor.ds_index + = (False, icl_cons_defs, comp_st) + # dcl_cons_def = dcl_cons_defs.[dclConstructor.ds_index] + (icl_cons_def, icl_cons_defs) = icl_cons_defs![iclConstructor.ds_index] + # (ok, comp_st) = compare_cons_def_types True icl_cons_def dcl_cons_def comp_st + = (ok, icl_cons_defs, comp_st) + compare_rhs_of_types (AbstractType _) (NewType _) dcl_cons_defs icl_cons_defs comp_st + = (False, icl_cons_defs, comp_st) compare_rhs_of_types (AbstractType _) icl_type dcl_cons_defs icl_cons_defs comp_st = (True, icl_cons_defs, comp_st) compare_rhs_of_types (AbstractSynType _ dclType) (SynType iclType) dcl_cons_defs icl_cons_defs comp_st @@ -81,11 +89,15 @@ where = (ok, icl_cons_defs, comp_st) compare_rhs_of_types dcl_type icl_type dcl_cons_defs icl_cons_defs comp_st = (False, icl_cons_defs, comp_st) - - compare_constructors do_compare_result_types cons_index dcl_cons_defs icl_cons_defs comp_st=:{comp_type_var_heap} + + compare_constructors do_compare_result_types cons_index dcl_cons_defs icl_cons_defs comp_st # dcl_cons_def = dcl_cons_defs.[cons_index] (icl_cons_def, icl_cons_defs) = icl_cons_defs![cons_index] - dcl_cons_type = dcl_cons_def.cons_type + (ok, comp_st) = compare_cons_def_types do_compare_result_types icl_cons_def dcl_cons_def comp_st + = (ok, icl_cons_defs, comp_st) + + compare_cons_def_types do_compare_result_types icl_cons_def dcl_cons_def comp_st=:{comp_type_var_heap} + # dcl_cons_type = dcl_cons_def.cons_type icl_cons_type = icl_cons_def.cons_type comp_type_var_heap = initialyseATypeVars dcl_cons_def.cons_exi_vars icl_cons_def.cons_exi_vars comp_type_var_heap comp_st = { comp_st & comp_type_var_heap = comp_type_var_heap } @@ -93,10 +105,9 @@ where | dcl_cons_def.cons_priority == icl_cons_def.cons_priority | ok && do_compare_result_types # (ok, comp_st) = compare dcl_cons_type.st_result icl_cons_type.st_result comp_st - = (ok, icl_cons_defs, comp_st) - = (ok, icl_cons_defs, comp_st) - = (False, icl_cons_defs, comp_st) - + = (ok, comp_st) + = (ok, comp_st) + = (False, comp_st) compareClassDefs :: !{#Int} {#Bool} !{# ClassDef} !{# MemberDef} !u:{# ClassDef} !v:{# MemberDef} !*CompareState -> (!u:{# ClassDef}, !v:{# MemberDef}, !*CompareState) @@ -857,10 +868,14 @@ instance t_corresponds TypeRhs where = t_corresponds dclType iclType t_corresponds (RecordType dclRecord) (RecordType iclRecord) = t_corresponds dclRecord iclRecord + t_corresponds (AbstractType _) (NewType _) + = return False t_corresponds (AbstractType _) _ = return True t_corresponds (AbstractSynType _ dclType) (SynType iclType) = t_corresponds dclType iclType + t_corresponds (NewType dclConstructor) (NewType iclConstructor) + = t_corresponds dclConstructor iclConstructor // sanity check ... t_corresponds UnknownType _ diff --git a/frontend/mergecases.icl b/frontend/mergecases.icl index 3152fcd..adaca74 100644 --- a/frontend/mergecases.icl +++ b/frontend/mergecases.icl @@ -5,14 +5,6 @@ implementation module mergecases import syntax, check, StdCompare, utilities -/* -cContainsFreeVars :== True -cContainsNoFreeVars :== False - -cMacroIsCalled :== True -cNoMacroIsCalled :== False -*/ - class GetSetPatternRhs a where get_pattern_rhs :: !a -> Expression @@ -41,7 +33,7 @@ mergeCases expr_and_pos [] var_heap symbol_heap error mergeCases (Let lad=:{let_expr}, pos) exprs var_heap symbol_heap error # ((let_expr, _), var_heap, symbol_heap, error) = mergeCases (let_expr, NoPos) exprs var_heap symbol_heap error = ((Let {lad & let_expr = let_expr}, pos), var_heap,symbol_heap, error) -mergeCases (case_expr=:(Case first_case=:{case_expr = Var {var_info_ptr}, case_default = No, case_explicit}), case_pos) +mergeCases (Case first_case=:{case_expr = Var {var_info_ptr}, case_default = No, case_explicit}, case_pos) [(expr, expr_pos) : exprs] var_heap symbol_heap error | not case_explicit # (split_result, var_heap, symbol_heap) = split_case var_info_ptr expr var_heap symbol_heap @@ -71,7 +63,7 @@ where -> (Yes cees, var_heap, symbol_heap) -> (No, var_heap, symbol_heap) No - -> (No, var_heap, symbol_heap) + -> (No, var_heap, symbol_heap) BasicPatterns type [basic_pattern] # (split_result, var_heap, symbol_heap) = split_case split_var_info_ptr basic_pattern.bp_expr var_heap symbol_heap -> case split_result of @@ -95,7 +87,19 @@ where -> (Yes cees, var_heap, symbol_heap) -> (No, var_heap, symbol_heap) No - -> (No, var_heap, symbol_heap) + -> (No, var_heap, symbol_heap) + NewTypePatterns type [newtype_pattern] + # (split_result, var_heap, symbol_heap) = split_case split_var_info_ptr newtype_pattern.ap_expr var_heap symbol_heap + -> case split_result of + Yes split_case + | not split_case.case_explicit + # (cees,symbol_heap) = push_expression_into_guards_and_default + ( \ guard_expr -> { this_case & case_guards = NewTypePatterns type [{ newtype_pattern & ap_expr = guard_expr }] } ) + split_case symbol_heap + -> (Yes cees, var_heap, symbol_heap) + -> (No, var_heap, symbol_heap) + No + -> (No, var_heap, symbol_heap) DynamicPatterns [dynamic_pattern] /* Don't merge dynamic cases, as a work around for the following case apply :: Dynamic Dynamic -> Int @@ -175,6 +179,9 @@ where push_expression_into_guards split_case=:{case_guards=OverloadedListPatterns type decons_expr patterns} symbol_heap # (new_patterns,symbol_heap) = push_expression_into_patterns patterns symbol_heap = ({split_case & case_guards=OverloadedListPatterns type decons_expr new_patterns},symbol_heap) + push_expression_into_guards split_case=:{case_guards=NewTypePatterns type patterns} symbol_heap + # (new_patterns,symbol_heap) = push_expression_into_patterns patterns symbol_heap + = ({split_case & case_guards=NewTypePatterns type new_patterns},symbol_heap) push_expression_into_guards split_case=:{case_guards=DynamicPatterns patterns} symbol_heap # (new_patterns,symbol_heap) = push_expression_into_patterns patterns symbol_heap = ({split_case & case_guards=DynamicPatterns new_patterns},symbol_heap) @@ -236,6 +243,9 @@ where push_let_expression_into_guards lad (OverloadedListPatterns type decons_expr patterns) var_heap expr_heap # (patterns, var_heap, expr_heap) = push_let_expression_into_algebraic_pattern lad patterns var_heap expr_heap = (OverloadedListPatterns type decons_expr patterns, var_heap, expr_heap) + push_let_expression_into_guards lad (NewTypePatterns type patterns) var_heap expr_heap + # (patterns, var_heap, expr_heap) = push_let_expression_into_algebraic_pattern lad patterns var_heap expr_heap + = (NewTypePatterns type patterns, var_heap, expr_heap) push_let_expression_into_guards lad (DynamicPatterns patterns) var_heap expr_heap # (patterns, var_heap, expr_heap) = push_let_expression_into_dynamic_pattern lad patterns var_heap expr_heap = (DynamicPatterns patterns, var_heap, expr_heap) @@ -281,6 +291,11 @@ where -> merge_overloaded_list_patterns type1 decons_expr1 patterns1 patterns2 var_heap symbol_heap error _ -> (guards, var_heap, symbol_heap, incompatible_patterns_in_case_error error) + merge_guards guards=:(NewTypePatterns type1 patterns1) (NewTypePatterns type2 patterns2) var_heap symbol_heap error + | type1 == type2 + # (merged_patterns, var_heap, symbol_heap, error) = merge_algebraic_or_overloaded_list_patterns patterns1 patterns2 var_heap symbol_heap error + = (NewTypePatterns type1 merged_patterns, var_heap, symbol_heap, error) + = (guards, var_heap, symbol_heap, incompatible_patterns_in_case_error error) merge_guards guards=:(DynamicPatterns patterns1) (DynamicPatterns patterns2) var_heap symbol_heap error # (merged_patterns, var_heap, symbol_heap, error) = merge_dynamic_patterns patterns1 patterns2 var_heap symbol_heap error = (DynamicPatterns merged_patterns, var_heap, symbol_heap, error) @@ -401,7 +416,7 @@ where incompatible_patterns_in_case_error error = checkError "" "incompatible patterns in case" error -mergeCases (case_expr=:(Case first_case=:{case_default, case_default_pos, case_explicit}), case_pos) [expr : exprs] var_heap symbol_heap error +mergeCases (Case first_case=:{case_default, case_default_pos, case_explicit}, case_pos) [expr : exprs] var_heap symbol_heap error | not case_explicit = case case_default of Yes default_expr @@ -412,7 +427,7 @@ mergeCases (case_expr=:(Case first_case=:{case_default, case_default_pos, case_e # ((default_expr, pos), var_heap, symbol_heap, error) = mergeCases expr exprs var_heap symbol_heap error -> ((Case { first_case & case_default = Yes default_expr, case_default_pos = pos }, case_pos), var_heap, symbol_heap, error) -mergeCases expr_and_pos _ var_heap symbol_heap error +mergeCases expr_and_pos=:(_,pos) _ var_heap symbol_heap error = (expr_and_pos, var_heap, symbol_heap, checkWarning "" " alternative will never match" error) isOverloaded (OverloadedList _ _ _ _) diff --git a/frontend/overloading.icl b/frontend/overloading.icl index e063788..1250c5b 100644 --- a/frontend/overloading.icl +++ b/frontend/overloading.icl @@ -72,6 +72,9 @@ typeCodeInDynamicError err=:{ea_ok} err = {err & ea_ok=ea_ok} = { err & ea_file = err.ea_file <<< "TC context not allowed in dynamic" <<< '\n' } +cycleAfterRemovingNewTypeConstructorsError ident err + # err = errorHeading "Error" err + = { err & ea_file = err.ea_file <<< (" cycle in definition of '" +++ toString ident +++ "' after removing newtype constructors") <<< '\n' } /* As soon as all overloaded variables in an type context are instantiated, context reduction is carried out. @@ -1363,6 +1366,8 @@ class updateExpression e :: !Index !e !*UpdateInfo -> (!e, !*UpdateInfo) instance updateExpression Expression where + updateExpression group_index (App {app_symb={symb_kind=SK_NewTypeConstructor _},app_args=[arg]}) ui + = updateExpression group_index arg ui updateExpression group_index (App app=:{app_symb=symb=:{symb_kind,symb_ident},app_args,app_info_ptr}) ui # (app_args, ui) = updateExpression group_index app_args ui | isNilPtr app_info_ptr @@ -1481,10 +1486,13 @@ where # ((expr, exprs), ui) = updateExpression group_index (expr, exprs) ui = (expr @ exprs, ui) updateExpression group_index (Let lad=:{let_lazy_binds, let_strict_binds, let_expr}) ui + # ui = set_aliases_for_binds_that_will_become_aliases let_lazy_binds ui # (let_lazy_binds, ui) = updateExpression group_index let_lazy_binds ui # (let_strict_binds, ui) = updateExpression group_index let_strict_binds ui # (let_expr, ui) = updateExpression group_index let_expr ui = (Let {lad & let_lazy_binds = let_lazy_binds, let_strict_binds = let_strict_binds, let_expr = let_expr}, ui) + updateExpression group_index case_expr=:(Case {case_guards=NewTypePatterns _ _}) ui + = remove_NewTypePatterns_case_and_update_expression case_expr group_index ui updateExpression group_index (Case kees=:{case_expr,case_guards,case_default}) ui # ((case_expr,(case_guards,case_default)), ui) = updateExpression group_index (case_expr,(case_guards,case_default)) ui = (Case { kees & case_expr = case_expr, case_guards = case_guards, case_default = case_default }, ui) @@ -1515,17 +1523,98 @@ where (EI_TypeOfDynamic type_code, ui_symbol_heap) = readPtr dyn_info_ptr ui.ui_symbol_heap ui = { ui & ui_symbol_heap = ui_symbol_heap } = (DynamicExpr { dyn & dyn_expr = dyn_expr, dyn_type_code = type_code }, ui) - updateExpression group_index (MatchExpr cons_symbol expr) ui - # (expr, ui) = updateExpression group_index expr ui - = (MatchExpr cons_symbol expr, ui) + updateExpression group_index (MatchExpr cons_symbol=:{glob_object={ds_arity}} expr) ui + | ds_arity <> -2 + # (expr, ui) = updateExpression group_index expr ui + = (MatchExpr cons_symbol expr, ui) + // newtype constructor + = updateExpression group_index expr ui updateExpression group_index (TupleSelect symbol argn_nr expr) ui # (expr, ui) = updateExpression group_index expr ui = (TupleSelect symbol argn_nr expr, ui) updateExpression group_index (TypeSignature _ expr) ui = updateExpression group_index expr ui + updateExpression group_index expr=:(Var {var_info_ptr}) ui + # (var_info,var_heap) = readPtr var_info_ptr ui.ui_var_heap + # ui = { ui & ui_var_heap = var_heap } + = case var_info of + VI_Alias var2 + # (var_info2,var_heap) = readPtr var2.var_info_ptr ui.ui_var_heap + # ui = { ui & ui_var_heap = var_heap } + -> skip_aliases var_info2 var2 var_info_ptr ui + _ + -> (expr,ui) + where + skip_aliases var_info2=:(VI_Alias var3) var2 var_info_ptr1 ui=:{ui_var_heap} + # ui = set_alias_and_detect_cycle var_info_ptr1 var3 ui + | var3.var_info_ptr==var_info_ptr1 + = (Var var2,ui) + # (var_info3,var_heap) = readPtr var3.var_info_ptr ui.ui_var_heap + # ui = { ui & ui_var_heap = var_heap } + = skip_aliases var_info3 var3 var2.var_info_ptr ui + skip_aliases var_info2 var2 var_info ui + = (Var var2,ui) updateExpression group_index expr ui = (expr, ui) +set_alias_and_detect_cycle info_ptr var ui + | info_ptr<>var.var_info_ptr + = { ui & ui_var_heap = writePtr info_ptr (VI_Alias var) ui.ui_var_heap } + # (var_info,var_heap) = readPtr info_ptr ui.ui_var_heap + # ui = { ui & ui_var_heap = var_heap } + = case var_info of + VI_Alias var + | var.var_info_ptr==info_ptr // to prevent repeating cycle error + -> ui + _ + # ui = { ui & ui_var_heap = writePtr info_ptr (VI_Alias var) ui.ui_var_heap } + -> {ui & ui_error = cycleAfterRemovingNewTypeConstructorsError var.var_ident ui.ui_error} + +remove_NewTypePatterns_case_and_update_expression :: !Expression !Index !*UpdateInfo -> (!Expression,!*UpdateInfo) +remove_NewTypePatterns_case_and_update_expression (Case {case_guards=NewTypePatterns type [{ap_symbol,ap_vars=[ap_var=:{fv_info_ptr}],ap_expr,ap_position}], + case_expr, case_default, case_explicit, case_info_ptr}) group_index ui + # ap_expr = add_case_default ap_expr case_default + # ap_expr = if case_explicit + (mark_case_explicit ap_expr) + ap_expr + # (case_expr,ui) = updateExpression group_index case_expr ui + = case case_expr of + Var var + # ui = set_alias_and_detect_cycle fv_info_ptr var ui + -> updateExpression group_index ap_expr ui + case_expr + # (ap_expr,ui) = updateExpression group_index ap_expr ui + # let_bind = {lb_dst = ap_var, lb_src = case_expr, lb_position = ap_position} + # (EI_CaseType {ct_pattern_type}, ui_symbol_heap) = readPtr case_info_ptr ui.ui_symbol_heap +// # (let_info_ptr, ui_symbol_heap) = newPtr (EI_LetType [ct_pattern_type]) ui_symbol_heap + # let_info_ptr = case_info_ptr + # ui_symbol_heap = writePtr case_info_ptr (EI_LetType [ct_pattern_type]) ui_symbol_heap + # ui = { ui & ui_symbol_heap = ui_symbol_heap } + # let_expr = Let { let_strict_binds = [], let_lazy_binds = [let_bind], let_expr = ap_expr, + let_info_ptr = let_info_ptr, let_expr_position = ap_position } + -> (let_expr,ui) + where + mark_case_explicit (Case case_=:{case_explicit}) + = Case {case_ & case_explicit=True} + mark_case_explicit (Let let_=:{let_expr}) + = Let {let_ & let_expr=mark_case_explicit let_expr} + mark_case_explicit expr + = expr + + add_case_default expr No + = expr + add_case_default expr (Yes default_expr) + = add_default expr default_expr + where + add_default (Case kees=:{case_default=No,case_explicit=False}) default_expr + = Case { kees & case_default = Yes default_expr } + add_default (Case kees=:{case_default=Yes case_default_expr,case_explicit=False}) default_expr + = Case { kees & case_default = Yes (add_default case_default_expr default_expr)} + add_default (Let lad=:{let_expr}) default_expr + = Let { lad & let_expr = add_default let_expr default_expr } + add_default expr _ + = expr + instance updateExpression LetBind where updateExpression group_index bind=:{lb_src} ui @@ -1607,6 +1696,50 @@ where updateExpression group_index l ui = mapSt (updateExpression group_index) l ui +set_aliases_for_binds_that_will_become_aliases :: ![LetBind] !*UpdateInfo -> *UpdateInfo +set_aliases_for_binds_that_will_become_aliases [] ui + = ui +set_aliases_for_binds_that_will_become_aliases [{lb_dst={fv_info_ptr},lb_src}:let_binds] ui + # ui = make_alias_if_expression_will_become_var lb_src fv_info_ptr ui + = set_aliases_for_binds_that_will_become_aliases let_binds ui +where + make_alias_if_expression_will_become_var (Var var) fv_info_ptr ui + = set_alias_and_detect_cycle fv_info_ptr var ui + make_alias_if_expression_will_become_var (App {app_symb={symb_kind=SK_NewTypeConstructor _},app_args=[arg]}) fv_info_ptr ui + = skip_newtypes_and_make_alias_if_var arg fv_info_ptr ui + make_alias_if_expression_will_become_var (MatchExpr {glob_object={ds_arity = -2}} expr) fv_info_ptr ui + = skip_newtypes_and_make_alias_if_var expr fv_info_ptr ui + make_alias_if_expression_will_become_var expr=:(Case {case_guards=NewTypePatterns _ _}) fv_info_ptr ui + = skip_newtypes_and_make_alias_if_var expr fv_info_ptr ui + make_alias_if_expression_will_become_var _ fv_info_ptr ui + = ui + + skip_newtypes_and_make_alias_if_var expr fv_info_ptr ui + = case skip_newtypes expr of + Var var + -> set_alias_and_detect_cycle fv_info_ptr var ui + _ + -> ui + where + skip_newtypes (App {app_symb={symb_kind=SK_NewTypeConstructor _},app_args=[arg]}) + = skip_newtypes arg + skip_newtypes (MatchExpr {glob_object={ds_arity = -2}} expr) + = skip_newtypes expr + skip_newtypes expr=:(Case {case_guards=NewTypePatterns type [{ap_symbol,ap_vars=[ap_var=:{fv_info_ptr}],ap_expr}],case_expr}) + = case skip_newtypes case_expr of + Var case_var + -> case skip_newtypes ap_expr of + Var rhs_var + | rhs_var.var_info_ptr==fv_info_ptr + -> case_expr + -> ap_expr + _ + -> expr + _ + -> expr + skip_newtypes expr + = expr + adjustClassExpressions symb_ident exprs tail_exprs ui = mapAppendSt (adjustClassExpression symb_ident) exprs tail_exprs ui where diff --git a/frontend/parse.icl b/frontend/parse.icl index 0b4d468..593e320 100644 --- a/frontend/parse.icl +++ b/frontend/parse.icl @@ -1651,7 +1651,7 @@ wantTypeDef :: !ParseContext !Position !ParseState -> (ParsedDefinition, !Parse wantTypeDef parseContext pos pState # (type_lhs, annot, pState) = want_type_lhs pos pState (token, pState) = nextToken TypeContext pState - (def, pState) = want_type_rhs parseContext type_lhs token annot pState + (def, pState) = want_type_rhs token parseContext type_lhs annot pState pState = wantEndOfDefinition "type definition (6)" pState = (def, pState) where @@ -1664,8 +1664,8 @@ where (contexts, pState) = optionalContext pState = (MakeTypeDef ident args (ConsList []) attr contexts pos, annot, pState) - want_type_rhs :: !ParseContext !ParsedTypeDef !Token !Annotation !ParseState -> (ParsedDefinition, !ParseState) - want_type_rhs parseContext td=:{td_ident,td_attribute} EqualToken annot pState + want_type_rhs :: !Token !ParseContext !ParsedTypeDef !Annotation !ParseState -> (ParsedDefinition, !ParseState) + want_type_rhs EqualToken parseContext td=:{td_ident,td_attribute} annot pState # name = td_ident.id_name pState = verify_annot_attr annot td_attribute name pState (exi_vars, pState) = optionalExistentialQuantifiedVariables pState @@ -1695,7 +1695,7 @@ where (rec_cons_ident, pState) = stringToIdent ("_" + name) IC_Expression pState = (PD_Type { td & td_rhs = SelectorList rec_cons_ident exi_vars is_boxed_record fields }, pState) - want_type_rhs parseContext td=:{td_attribute} ColonDefinesToken annot pState // type Macro + want_type_rhs ColonDefinesToken parseContext td=:{td_attribute} annot pState // type synonym # name = td.td_ident.id_name pState = verify_annot_attr annot td_attribute name pState (atype, pState) = want pState // Atype @@ -1704,7 +1704,18 @@ where = (PD_Type td, pState) = (PD_Type td, parseError "Type synonym" No ("No lhs strictness annotation for the type synonym "+name) pState) - want_type_rhs parseContext td=:{td_attribute} token=:OpenToken annot pState + want_type_rhs DefinesColonToken parseContext td=:{td_ident,td_attribute} annot pState + # name = td_ident.id_name + pState = verify_annot_attr annot td_attribute name pState + (exi_vars, pState) = optionalExistentialQuantifiedVariables pState + (token, pState) = nextToken GeneralContext pState + (condef, pState) = want_newtype_constructor exi_vars token pState + td = { td & td_rhs = NewTypeCons condef } + | annot == AN_None + = (PD_Type td, pState) + = (PD_Type td, parseError "New type" No ("No lhs strictness annotation for the new type "+name) pState) + + want_type_rhs token=:OpenToken parseContext td=:{td_attribute} annot pState | isIclContext parseContext = (PD_Erroneous, parseError "type RHS" (Yes token) "type definition" pState) # pState = wantToken TypeContext "Abstract type synonym" ColonDefinesToken pState @@ -1717,7 +1728,7 @@ where = (PD_Type td, pState) = (PD_Type td, parseError "abstract type" No ("type attribute "+toString td_attribute+" for abstract type "+name+" is not") (tokenBack pState)) - want_type_rhs parseContext td=:{td_attribute} token annot pState + want_type_rhs token parseContext td=:{td_attribute} annot pState | isIclContext parseContext = (PD_Erroneous, parseError "type RHS" (Yes token) "type definition" pState) | td_attribute == TA_Anonymous || td_attribute == TA_Unique || td_attribute == TA_None @@ -1747,11 +1758,7 @@ where want_constructor_list :: ![ATypeVar] !Token !ParseState -> (.[ParsedConstructor],ParseState) want_constructor_list exi_vars token pState - # token = basic_type_to_constructor token - # (pc_cons_ident, pc_cons_prio, pc_cons_pos, pState) = want_cons_name_and_prio token pState - (pc_arg_types, pState) = parseList tryBrackSAType pState - cons = { pc_cons_ident = pc_cons_ident, pc_arg_types = atypes_from_satypes pc_arg_types, pc_args_strictness=strictness_from_satypes pc_arg_types, pc_cons_arity = length pc_arg_types, - pc_cons_prio = pc_cons_prio, pc_exi_vars = exi_vars, pc_cons_pos = pc_cons_pos} + # (cons,pState) = want_constructor exi_vars token pState (token, pState) = nextToken TypeContext pState | token == BarToken # (exi_vars, pState) = optionalExistentialQuantifiedVariables pState @@ -1760,31 +1767,51 @@ where = ([cons : cons_list], pState) // otherwise = ([cons], tokenBack pState) - where - want_cons_name_and_prio :: !Token !ParseState -> (Ident, !Priority, !Position, !ParseState) - want_cons_name_and_prio tok=:(IdentToken name) pState - # (ident, pState) = stringToIdent name IC_Expression pState - (fname, linenr, pState) = getFileAndLineNr pState - (token, pState) = nextToken TypeContext pState - (prio, pState) = optionalPriority cIsNotInfix token pState - | isLowerCaseName name - = (ident, prio, LinePos fname linenr, parseError "Algebraic type: constructor definitions" (Yes tok) "constructor name" pState) - = (ident, prio, LinePos fname linenr, pState) - want_cons_name_and_prio OpenToken pState - # (name, pState) = wantConstructorName "infix constructor" pState - (fname, linenr, pState) = getFileAndLineNr pState - (ident, pState) = stringToIdent name IC_Expression pState - (token, pState) = nextToken TypeContext (wantToken TypeContext "type: constructor and prio" CloseToken pState) - (prio, pState) = optionalPriority cIsInfix token pState + + want_constructor :: ![ATypeVar] !Token !ParseState -> (.ParsedConstructor,!ParseState) + want_constructor exi_vars token pState + # token = basic_type_to_constructor token + # (pc_cons_ident, pc_cons_prio, pc_cons_pos, pState) = want_cons_name_and_prio token pState + (pc_arg_types, pState) = parseList tryBrackSAType pState + cons = { pc_cons_ident = pc_cons_ident, pc_arg_types = atypes_from_satypes pc_arg_types, pc_args_strictness=strictness_from_satypes pc_arg_types, + pc_cons_arity = length pc_arg_types, pc_cons_prio = pc_cons_prio, pc_exi_vars = exi_vars, pc_cons_pos = pc_cons_pos} + = (cons,pState) + + want_newtype_constructor :: ![ATypeVar] !Token !ParseState -> (.ParsedConstructor,!ParseState) + want_newtype_constructor exi_vars token pState + # token = basic_type_to_constructor token + (pc_cons_ident, pc_cons_prio, pc_cons_pos, pState) = want_cons_name_and_prio token pState + (succ, pc_arg_type, pState) = trySimpleType TA_Anonymous pState + cons = { pc_cons_ident = pc_cons_ident, pc_arg_types = [pc_arg_type], pc_args_strictness = NotStrict, + pc_cons_arity = 1, pc_cons_prio = pc_cons_prio, pc_exi_vars = exi_vars, pc_cons_pos = pc_cons_pos} + | succ + = (cons,pState) + = (cons,parseError "newtype definition" No "type" pState) + + want_cons_name_and_prio :: !Token !ParseState -> (Ident, !Priority, !Position, !ParseState) + want_cons_name_and_prio tok=:(IdentToken name) pState + # (ident, pState) = stringToIdent name IC_Expression pState + (fname, linenr, pState) = getFileAndLineNr pState + (token, pState) = nextToken TypeContext pState + (prio, pState) = optionalPriority cIsNotInfix token pState + | isLowerCaseName name + = (ident, prio, LinePos fname linenr, parseError "Algebraic or new type: constructor definitions" (Yes tok) "constructor name" pState) = (ident, prio, LinePos fname linenr, pState) - want_cons_name_and_prio DotToken pState - # (token,pState) = nextToken GeneralContext pState - = case token of - IdentToken name - | isFunnyIdName name -> want_cons_name_and_prio (IdentToken ("."+name)) pState - _ -> (erroneousIdent, NoPrio, NoPos, parseError "Algebraic type: constructor list" (Yes DotToken) "constructor name" (tokenBack pState)) - want_cons_name_and_prio token pState - = (erroneousIdent, NoPrio, NoPos, parseError "Algebraic type: constructor list" (Yes token) "constructor name" pState) + want_cons_name_and_prio OpenToken pState + # (name, pState) = wantConstructorName "infix constructor" pState + (fname, linenr, pState) = getFileAndLineNr pState + (ident, pState) = stringToIdent name IC_Expression pState + (token, pState) = nextToken TypeContext (wantToken TypeContext "type: constructor and prio" CloseToken pState) + (prio, pState) = optionalPriority cIsInfix token pState + = (ident, prio, LinePos fname linenr, pState) + want_cons_name_and_prio DotToken pState + # (token,pState) = nextToken GeneralContext pState + = case token of + IdentToken name + | isFunnyIdName name -> want_cons_name_and_prio (IdentToken ("."+name)) pState + _ -> (erroneousIdent, NoPrio, NoPos, parseError "Algebraic or new type: constructor list" (Yes DotToken) "constructor name" (tokenBack pState)) + want_cons_name_and_prio token pState + = (erroneousIdent, NoPrio, NoPos, parseError "Algebraic or new type: constructor list" (Yes token) "constructor name" pState) basic_type_to_constructor IntTypeToken = IdentToken "Int" basic_type_to_constructor CharTypeToken = IdentToken "Char" diff --git a/frontend/partition.icl b/frontend/partition.icl index 071cc0a..63aeeef 100644 --- a/frontend/partition.icl +++ b/frontend/partition.icl @@ -464,7 +464,7 @@ where = find_calls fc_info expr fc_state find_calls fc_info (FreeVar _) fc_state = abort "FreeVar" - find_calls fc_info (Constant _ _ _ _) fc_state + find_calls fc_info (Constant _ _ _) fc_state = abort "Constant" find_calls fc_info (ClassVariable _) fc_state = abort "ClassVariable" diff --git a/frontend/postparse.icl b/frontend/postparse.icl index 0bb2f37..402e14c 100644 --- a/frontend/postparse.icl +++ b/frontend/postparse.icl @@ -1292,6 +1292,13 @@ where = ([cons : conses], next_cons_index) determine_symbols_of_conses [] next_cons_index = ([], next_cons_index) +reorganiseDefinitions icl_module [PD_Type type_def=:{td_rhs = NewTypeCons cons_def=:{pc_cons_ident,pc_cons_arity}} : defs] cons_count sel_count mem_count type_count ca + # cons_symb = { ds_ident = pc_cons_ident, ds_arity = pc_cons_arity, ds_index = cons_count } + cons_count = inc cons_count + (fun_defs, c_defs, imports, imported_objects,foreign_exports, ca) = reorganiseDefinitions icl_module defs cons_count sel_count mem_count (type_count+1) ca + type_def = { type_def & td_rhs = NewType cons_symb } + c_defs = { c_defs & def_types = [type_def : c_defs.def_types], def_constructors = [ParsedConstructorToConsDef cons_def : c_defs.def_constructors] } + = (fun_defs, c_defs, imports, imported_objects,foreign_exports, ca) reorganiseDefinitions icl_module [PD_Type type_def=:{td_ident, td_rhs = SelectorList rec_cons_id exivars is_boxed_record sel_defs, td_pos } : defs] cons_count sel_count mem_count type_count ca # (sel_syms, new_count) = determine_symbols_of_selectors sel_defs sel_count (fun_defs, c_defs, imports, imported_objects,foreign_exports, ca) = reorganiseDefinitions icl_module defs (inc cons_count) new_count mem_count (type_count+1) ca diff --git a/frontend/refmark.icl b/frontend/refmark.icl index 4bfefb5..9f53f86 100644 --- a/frontend/refmark.icl +++ b/frontend/refmark.icl @@ -372,6 +372,9 @@ where refMarkOfCase free_vars sel def {case_expr, case_guards=OverloadedListPatterns type _ patterns, case_explicit, case_default} rms = refMarkOfAlgebraicOrOverloadedListCase free_vars sel def case_expr patterns case_explicit case_default rms +refMarkOfCase free_vars sel def {case_expr, case_guards=NewTypePatterns type patterns, case_explicit, case_default} rms + = refMarkOfAlgebraicOrOverloadedListCase free_vars sel def case_expr patterns case_explicit case_default rms + refMarkOfCase free_vars sel def {case_expr, case_guards=DynamicPatterns patterns,case_default,case_explicit} rms=:{rms_var_heap} # (def, all_closed_let_vars, rms) = refMarkOfDefault case_explicit free_vars sel def case_expr case_default [] { rms & rms_var_heap = rms_var_heap } (pattern_depth, all_closed_let_vars, rms) = foldSt (ref_mark_of_dynamic_pattern free_vars sel def case_expr) patterns (0, all_closed_let_vars, rms) diff --git a/frontend/syntax.dcl b/frontend/syntax.dcl index 12131b1..98a230f 100644 --- a/frontend/syntax.dcl +++ b/frontend/syntax.dcl @@ -184,6 +184,7 @@ instance == FunctionOrMacroIndex :: RhsDefsOfType = ConsList ![ParsedConstructor] | SelectorList !Ident ![ATypeVar] !Bool /*is_boxed_record*/ ![ParsedSelector] | TypeSpec !AType + | NewTypeCons !ParsedConstructor | EmptyRhs !BITVECT | AbstractTypeSpec !BITVECT !AType @@ -496,6 +497,7 @@ cIsImportedObject :== False :: TypeRhs = AlgType ![DefinedSymbol] | SynType !AType | RecordType !RecordType + | NewType !DefinedSymbol | AbstractType !BITVECT | AbstractSynType !BITVECT !AType | UnknownType @@ -669,12 +671,13 @@ pIsSafe :== True = AP_Algebraic !(Global DefinedSymbol) !Index [AuxiliaryPattern] OptionalVariable | AP_Variable !Ident !VarInfoPtr OptionalVariable | AP_Basic !BasicValue OptionalVariable + | AP_NewType !(Global DefinedSymbol) !Index AuxiliaryPattern OptionalVariable | AP_Dynamic !AuxiliaryPattern !DynamicType !OptionalVariable | AP_Constant !AP_Kind !(Global DefinedSymbol) !Priority | AP_WildCard !OptionalVariable | AP_Empty -:: AP_Kind = APK_Constructor !Index | APK_Macro !Bool // is_dcl_macro +:: AP_Kind = APK_Constructor !Index | APK_NewTypeConstructor !Index | APK_Macro !Bool // is_dcl_macro from convertDynamics import :: TypeCodeVariableInfo, :: DynamicValueAliasInfo @@ -760,6 +763,7 @@ cNonRecursiveAppl :== False | SK_OverloadedFunction !(Global Index) | SK_GeneratedFunction !FunctionInfoPtr !Index | SK_Constructor !(Global Index) + | SK_NewTypeConstructor !GlobalIndex | SK_Generic !(Global Index) !TypeKind | SK_TypeCode @@ -907,7 +911,7 @@ cNonRecursiveAppl :== False , cons_type :: !SymbolType , cons_arg_vars :: ![[ATypeVar]] , cons_priority :: !Priority - , cons_number :: !Index + , cons_number :: !Index // -2 for newtype constructor , cons_type_index :: !Index , cons_exi_vars :: ![ATypeVar] , cons_type_ptr :: !VarInfoPtr @@ -1277,7 +1281,7 @@ cIsNotStrict :== False | MatchExpr !(Global DefinedSymbol) !Expression | FreeVar FreeVar - | Constant !SymbIdent !Int !Priority !Bool /* auxiliary clause used during checking */ + | Constant !SymbIdent !Int !Priority /* auxiliary clause used during checking */ | ClassVariable !VarInfoPtr /* auxiliary clause used during overloading */ | DynamicExpr !DynamicExpr @@ -1337,6 +1341,7 @@ cIsNotStrict :== False :: CasePatterns= AlgebraicPatterns !(Global Index) ![AlgebraicPattern] | BasicPatterns !BasicType [BasicPattern] + | NewTypePatterns !(Global Index) ![AlgebraicPattern] | DynamicPatterns [DynamicPattern] /* auxiliary */ | OverloadedListPatterns !OverloadedListType !Expression ![AlgebraicPattern] | NoPattern /* auxiliary */ diff --git a/frontend/syntax.icl b/frontend/syntax.icl index 13d3e80..3af5c35 100644 --- a/frontend/syntax.icl +++ b/frontend/syntax.icl @@ -306,6 +306,7 @@ where (<<<) file (AlgebraicPatterns type patterns) = file <<< patterns (<<<) file (DynamicPatterns patterns) = file <<< patterns (<<<) file (OverloadedListPatterns type decons_expr patterns) = file <<< decons_expr <<< " " <<< patterns + (<<<) file (NewTypePatterns type patterns) = file <<< patterns (<<<) file NoPattern = file instance <<< CheckedAlternative @@ -388,7 +389,7 @@ where (<<<) file (DynamicExpr {dyn_expr,dyn_type_code}) = file <<< "dynamic " <<< dyn_expr <<< " :: " <<< dyn_type_code // (<<<) file (DynamicExpr {dyn_expr,dyn_uni_vars,dyn_type_code}) = writeVarPtrs (file <<< "dynamic " <<< dyn_expr <<< " :: dyn_uni_vars") dyn_uni_vars <<< "dyn_type_code=" <<< dyn_type_code (<<<) file (TypeCodeExpression type_code) = file <<< type_code - (<<<) file (Constant symb _ _ _) = file <<< "** Constant **" <<< symb + (<<<) file (Constant symb _ _) = file <<< "** Constant **" <<< symb (<<<) file (ABCCodeExpr code_sequence do_inline) = file <<< (if do_inline "code inline\n" "code\n") <<< code_sequence (<<<) file (AnyCodeExpr input output code_sequence) = file <<< "code\n" <<< input <<< "\n" <<< output <<< "\n" <<< code_sequence @@ -685,9 +686,10 @@ where instance <<< RhsDefsOfType where + (<<<) file (TypeSpec type) = file <<< type (<<<) file (ConsList cons_defs) = file <<< cons_defs (<<<) file (SelectorList _ _ _ sel_defs) = file <<< sel_defs - (<<<) file (TypeSpec type) = file <<< type + (<<<) file (NewTypeCons cons_def) = file <<< cons_def (<<<) file _ = file instance <<< ParsedConstructor diff --git a/frontend/trans.icl b/frontend/trans.icl index e56c8e5..ae05198 100644 --- a/frontend/trans.icl +++ b/frontend/trans.icl @@ -1915,6 +1915,7 @@ determine_arg (PR_Class class_app free_vars_and_types class_type) _ {fv_info_ptr = { ti_common_defs = ro.ro_common_defs , ti_functions = ro.ro_imported_funs , ti_main_dcl_module_n = ro.ro_main_dcl_module_n + , ti_expand_newtypes = True } // AA: Dummy generic dictionary does not unify with corresponding class dictionary. // Make it unify @@ -1987,6 +1988,7 @@ determine_arg producer (Yes {st_args, st_args_strictness, st_result, st_attr_var = { ti_common_defs = ro.ro_common_defs , ti_functions = ro.ro_imported_funs , ti_main_dcl_module_n = ro.ro_main_dcl_module_n + , ti_expand_newtypes = True } # (succ, das_subst, das_type_heaps) = unify application_type arg_type type_input das_subst das_type_heaps @@ -3911,6 +3913,11 @@ expand_syn_types_in_TA rem_annots common_defs ta_type attribute ets=:{ets_type_d | glob_module == ets.ets_main_dcl_module_n -> (changed,ta_type, ets) -> (changed,ta_type, collect_imported_constructors common_defs glob_module td_rhs ets) + NewType {ds_index} + # {cons_type={st_args=[arg_type:_]}} = common_defs.[glob_module].com_cons_defs.[ds_index]; + # (type,ets_type_heaps) = bind_and_substitute_before_expand types td_args td_attribute arg_type rem_annots attribute ets.ets_type_heaps + # (_,type,ets) = expandSynTypes rem_annots common_defs type { ets & ets_type_heaps = ets_type_heaps } + -> (True,type,ets) _ #! (changed,types, ets) = expandSynTypes rem_annots common_defs types ets # ta_type = if changed @@ -3924,9 +3931,8 @@ expand_syn_types_in_TA rem_annots common_defs ta_type attribute ets=:{ets_type_d where bind_and_substitute_before_expand types td_args td_attribute rhs_type rem_annots attribute ets_type_heaps # ets_type_heaps = bind_attr td_attribute attribute ets_type_heaps - ets_type_heaps = (fold2St bind_var_and_attr td_args types ets_type_heaps) - (type, ets_type_heaps) = substitute_rhs rem_annots rhs_type.at_type ets_type_heaps - = (type, ets_type_heaps) + ets_type_heaps = fold2St bind_var_and_attr td_args types ets_type_heaps + = substitute_rhs rem_annots rhs_type.at_type ets_type_heaps where bind_var_and_attr { atv_attribute = TA_Var {av_info_ptr}, atv_variable = {tv_info_ptr} } {at_attribute,at_type} type_heaps=:{th_vars,th_attrs} = { type_heaps & th_vars = th_vars <:= (tv_info_ptr, TVI_Type at_type), th_attrs = th_attrs <:= (av_info_ptr, AVI_Attr at_attribute) } diff --git a/frontend/transform.icl b/frontend/transform.icl index 5dc7c7c..ce9d7ab 100644 --- a/frontend/transform.icl +++ b/frontend/transform.icl @@ -172,6 +172,9 @@ where # (patterns, ls) = lift patterns ls # (decons_expr, ls) = lift decons_expr ls = (OverloadedListPatterns type decons_expr patterns, ls) + lift (NewTypePatterns type patterns) ls + # (patterns, ls) = lift patterns ls + = (NewTypePatterns type patterns, ls) lift (DynamicPatterns patterns) ls # (patterns, ls) = lift patterns ls = (DynamicPatterns patterns, ls) @@ -689,6 +692,9 @@ where # (patterns, us) = unfold patterns ui us # (decons_expr, us) = unfold decons_expr ui us = (OverloadedListPatterns type decons_expr patterns, us) + unfold (NewTypePatterns type patterns) ui us + # (patterns, us) = unfold patterns ui us + = (NewTypePatterns type patterns, us) unfold (DynamicPatterns patterns) ui us # (patterns, us) = unfold patterns ui us = (DynamicPatterns patterns, us) @@ -1202,11 +1208,6 @@ where where has_no_curried_macro_CasePatterns (AlgebraicPatterns type patterns) = has_no_curried_macro_AlgebraicPatterns patterns - where - has_no_curried_macro_AlgebraicPatterns [{ap_expr}:patterns] - = has_no_curried_macro_Expression ap_expr && has_no_curried_macro_AlgebraicPatterns patterns - has_no_curried_macro_AlgebraicPatterns [] - = True has_no_curried_macro_CasePatterns (BasicPatterns type patterns) = has_no_curried_macro_BasicPatterns patterns where @@ -1214,6 +1215,8 @@ where = has_no_curried_macro_Expression bp_expr && has_no_curried_macro_BasicPatterns patterns has_no_curried_macro_BasicPatterns [] = True + has_no_curried_macro_CasePatterns (NewTypePatterns type patterns) + = has_no_curried_macro_AlgebraicPatterns patterns has_no_curried_macro_CasePatterns (DynamicPatterns patterns) = has_no_curried_macro_DynamicPatterns patterns where @@ -1222,6 +1225,11 @@ where has_no_curried_macro_DynamicPatterns [] = True + has_no_curried_macro_AlgebraicPatterns [{ap_expr}:patterns] + = has_no_curried_macro_Expression ap_expr && has_no_curried_macro_AlgebraicPatterns patterns + has_no_curried_macro_AlgebraicPatterns [] + = True + has_no_curried_macro_OptionalExpression (Yes expr) = has_no_curried_macro_Expression expr has_no_curried_macro_OptionalExpression No @@ -1670,6 +1678,8 @@ where = [BasicPatterns basicType [pattern] \\ pattern <- patterns] split_patterns (OverloadedListPatterns overloaded_list_type decons_expr patterns) = [OverloadedListPatterns overloaded_list_type decons_expr [pattern] \\ pattern <- patterns] + split_patterns (NewTypePatterns index patterns) + = [NewTypePatterns index [pattern] \\ pattern <- patterns] split_patterns (DynamicPatterns patterns) = [DynamicPatterns [pattern] \\ pattern <- patterns] split_patterns NoPattern @@ -1700,6 +1710,9 @@ where expand (OverloadedListPatterns type decons_expr patterns) ei # (patterns, ei) = expand patterns ei = (OverloadedListPatterns type decons_expr patterns, ei) + expand (NewTypePatterns type patterns) ei + # (patterns, ei) = expand patterns ei + = (NewTypePatterns type patterns, ei) expand (DynamicPatterns patterns) ei # (patterns, ei) = expand patterns ei = (DynamicPatterns patterns, ei) @@ -2088,6 +2101,9 @@ where collectVariables (OverloadedListPatterns type decons_expr patterns) free_vars dynamics cos # (patterns, free_vars, dynamics, cos) = collectVariables patterns free_vars dynamics cos = (OverloadedListPatterns type decons_expr patterns, free_vars, dynamics, cos) + collectVariables (NewTypePatterns type patterns) free_vars dynamics cos + # (patterns, free_vars, dynamics, cos) = collectVariables patterns free_vars dynamics cos + = (NewTypePatterns type patterns, free_vars, dynamics, cos) collectVariables (DynamicPatterns patterns) free_vars dynamics cos # (patterns, free_vars, dynamics, cos) = collectVariables patterns free_vars dynamics cos = (DynamicPatterns patterns, free_vars, dynamics, cos) diff --git a/frontend/type.dcl b/frontend/type.dcl index f7d998b..c636c8b 100644 --- a/frontend/type.dcl +++ b/frontend/type.dcl @@ -24,9 +24,10 @@ class unify a :: !a !a !TypeInput !*{! Type} !*TypeHeaps -> (!Bool, !*{! Type}, instance unify AType :: TypeInput = - { ti_common_defs :: !{# CommonDefs } + ! { ti_common_defs :: !{# CommonDefs } , ti_functions :: !{# {# FunType }} , ti_main_dcl_module_n :: !Int + , ti_expand_newtypes :: !Bool } class arraySubst type :: !type !u:{!Type} -> (!Bool,!type, !u:{! Type}) diff --git a/frontend/type.icl b/frontend/type.icl index 2a349bd..991c646 100644 --- a/frontend/type.icl +++ b/frontend/type.icl @@ -6,9 +6,10 @@ import compilerSwitches import genericsupport :: TypeInput = - { ti_common_defs :: !{# CommonDefs } + ! { ti_common_defs :: !{# CommonDefs } , ti_functions :: !{# {# FunType }} , ti_main_dcl_module_n :: !Int + , ti_expand_newtypes :: !Bool } :: TypeState = @@ -308,7 +309,7 @@ unifyTypes tv=:(TempV tv_number) attr1 type2 attr2 modules subst heaps = (True, { subst & [tv_number1] = tv}, heaps) unify_variable_with_type tv_number type attr subst modules heaps | containsTypeVariable tv_number type subst - # (succ, type, heaps) = tryToExpand type attr modules.ti_common_defs heaps + # (succ, type, heaps) = tryToExpandInUnify type attr modules heaps | succ = unify_variable_with_type tv_number type attr subst modules heaps = (False, subst, heaps) @@ -342,10 +343,10 @@ unifyTypes TArrow attr1 TArrow attr2 modules subst heaps unifyTypes (TArrow1 t1) attr1 (TArrow1 t2) attr2 modules subst heaps = unify t1 t2 modules subst heaps unifyTypes (cons_var :@: types) attr1 type2 attr2 modules subst heaps - # (_, type2, heaps) = tryToExpand type2 attr2 modules.ti_common_defs heaps + # (_, type2, heaps) = tryToExpandInUnify type2 attr2 modules heaps = unifyTypeApplications cons_var attr1 types type2 attr2 modules subst heaps unifyTypes type1 attr1 (cons_var :@: types) attr2 modules subst heaps - # (_, type1, heaps) = tryToExpand type1 attr1 modules.ti_common_defs heaps + # (_, type1, heaps) = tryToExpandInUnify type1 attr1 modules heaps = unifyTypeApplications cons_var attr2 types type1 attr1 modules subst heaps unifyTypes t1=:(TempQV qv_number1) attr1 t2=:(TempQV qv_number2) attr2 modules subst heaps = (qv_number1 == qv_number2, subst, heaps) @@ -354,19 +355,49 @@ unifyTypes (TempQV qv_number) attr1 type attr2 modules subst heaps unifyTypes type attr1 (TempQV qv_number1) attr2 modules subst heaps = (False, subst, heaps) unifyTypes type1 attr1 type2 attr2 modules subst heaps - # (succ1, type1, heaps) = tryToExpand type1 attr1 modules.ti_common_defs heaps - (succ2, type2, heaps) = tryToExpand type2 attr2 modules.ti_common_defs heaps + # (succ1, type1, heaps) = tryToExpandInUnify type1 attr1 modules heaps + (succ2, type2, heaps) = tryToExpandInUnify type2 attr2 modules heaps | succ1 || succ2 = unifyTypes type1 attr1 type2 attr2 modules subst heaps = (False, subst, heaps) expandAndUnifyTypes t1 attr1 t2 attr2 modules subst heaps - # (succ1, t1, heaps) = tryToExpand t1 attr1 modules.ti_common_defs heaps - (succ2, t2, heaps) = tryToExpand t2 attr2 modules.ti_common_defs heaps + # (succ1, t1, heaps) = tryToExpandInUnify t1 attr1 modules heaps + (succ2, t2, heaps) = tryToExpandInUnify t2 attr2 modules heaps | succ1 || succ2 = unifyTypes t1 attr1 t2 attr2 modules subst heaps = (False, subst, heaps) +tryToExpandInUnify :: !Type !TypeAttribute !TypeInput !*TypeHeaps -> (!Bool, !Type, !*TypeHeaps) +tryToExpandInUnify type=:(TA {type_index={glob_object,glob_module}} type_args) type_attr type_input type_heaps + #! type_def = type_input.ti_common_defs.[glob_module].com_type_defs.[glob_object] + = case type_def.td_rhs of + SynType {at_type} + # (expanded_type, type_heaps) = substituteType type_def.td_attribute type_attr type_def.td_args type_args at_type type_heaps + -> (True, expanded_type, type_heaps) + NewType {ds_index} + | type_input.ti_expand_newtypes + # {cons_type={st_args=[{at_type}:_]}} = type_input.ti_common_defs.[glob_module].com_cons_defs.[ds_index]; + # (expanded_type, type_heaps) = substituteType type_def.td_attribute type_attr type_def.td_args type_args at_type type_heaps + -> (True, expanded_type, type_heaps) + _ + -> (False, type, type_heaps) +tryToExpandInUnify type=:(TAS {type_index={glob_object,glob_module}} type_args _) type_attr type_input type_heaps + #! type_def = type_input.ti_common_defs.[glob_module].com_type_defs.[glob_object] + = case type_def.td_rhs of + SynType {at_type} + # (expanded_type, type_heaps) = substituteType type_def.td_attribute type_attr type_def.td_args type_args at_type type_heaps + -> (True, expanded_type, type_heaps) + NewType {ds_index} + | type_input.ti_expand_newtypes + # {cons_type={st_args=[{at_type}:_]}} = type_input.ti_common_defs.[glob_module].com_cons_defs.[ds_index]; + # (expanded_type, type_heaps) = substituteType type_def.td_attribute type_attr type_def.td_args type_args at_type type_heaps + -> (True, expanded_type, type_heaps) + _ + -> (False, type, type_heaps) +tryToExpandInUnify type type_attr modules type_heaps + = (False, type, type_heaps) + tryToExpand :: !Type !TypeAttribute !{# CommonDefs} !*TypeHeaps -> (!Bool, !Type, !*TypeHeaps) tryToExpand type=:(TA {type_index={glob_object,glob_module}} type_args) type_attr ti_common_defs type_heaps #! type_def = ti_common_defs.[glob_module].com_type_defs.[glob_object] @@ -1231,6 +1262,9 @@ getSymbolType pos ti=:{ti_functions,ti_common_defs,ti_main_dcl_module_n} {symb_k getSymbolType pos ti {symb_kind = SK_Constructor {glob_module,glob_object}} n_app_args ts # (fresh_cons_type, ts) = standardRhsConstructorType pos glob_object glob_module n_app_args ti ts = (fresh_cons_type, [], ts) +getSymbolType pos ti {symb_kind = SK_NewTypeConstructor {gi_module,gi_index}} n_app_args ts + # (fresh_cons_type, ts) = standardRhsConstructorType pos gi_index gi_module n_app_args ti ts + = (fresh_cons_type, [], ts) getSymbolType pos ti=:{ti_functions,ti_common_defs,ti_main_dcl_module_n} {symb_kind = SK_LocalMacroFunction glob_object, symb_ident} n_app_args ts | glob_object>=size ts.ts_fun_env = abort symb_ident.id_name; @@ -1393,6 +1427,17 @@ where req_overloaded_calls = [app_info_ptr : reqs.req_overloaded_calls ] }, { ts & ts_expr_heap = ts_expr_heap })) + requirements_of_guarded_expressions (NewTypePatterns alg_type patterns) ti=:{ti_common_defs} match_expr pattern_type opt_pattern_ptr + goal_type (reqs, ts) + # (cons_types, result_type, new_attr_env,td_rhs,ts) = freshAlgebraicType alg_type patterns ti_common_defs ts + ts_var_heap = update_case_variable match_expr td_rhs cons_types alg_type ts.ts_var_heap + (used_cons_types, (reqs, ts)) = requirements_of_algebraic_patterns ti patterns cons_types goal_type [] (reqs, { ts & ts_var_heap = ts_var_heap } ) + ts_expr_heap = storeAttribute opt_pattern_ptr result_type.at_attribute ts.ts_expr_heap + (position, ts_var_heap) = getPositionOfExpr match_expr ts.ts_var_heap + = (reverse used_cons_types, ({ reqs & req_type_coercions = [{tc_demanded = result_type,tc_offered = pattern_type, tc_position = position, + tc_coercible = True} : reqs.req_type_coercions], + req_attr_coercions = new_attr_env ++ reqs.req_attr_coercions }, { ts & ts_expr_heap = ts_expr_heap, ts_var_heap = ts_var_heap })) + requirements_of_guarded_expressions (DynamicPatterns dynamic_patterns) ti match_expr pattern_type opt_pattern_ptr goal_type reqs_ts # dyn_type = { at_type = TB BT_Dynamic, at_attribute = TA_Multi } (used_dyn_types, (reqs, ts)) = requirements_of_dynamic_patterns ti goal_type dynamic_patterns [] reqs_ts @@ -1747,7 +1792,7 @@ where reqs = { reqs & req_attr_coercions = tst_attr_env ++ reqs.req_attr_coercions, req_type_coercions = [{ tc_demanded = tst_result, tc_offered = e_type, tc_position = cp, tc_coercible = True } : reqs.req_type_coercions ] } ts = { ts & ts_expr_heap = storeAttribute opt_expr_ptr tst_result.at_attribute ts.ts_expr_heap } - | ds_arity<>1 + | ds_arity>1 // ds_arity == -2 for newtype # tuple_type = MakeTypeSymbIdent { glob_object = PD_Arity2TupleTypeIndex+(ds_arity-2), glob_module = cPredefinedModuleIndex } predefined_idents.[PD_Arity2TupleType+(ds_arity-2)] ds_arity = ({ at_type = TA tuple_type tst_args, at_attribute = TA_Unique }, No, (reqs, ts)) = ( hd tst_args, No, (reqs, ts)) @@ -2246,7 +2291,7 @@ typeProgram comps main_dcl_module_n fun_defs specials list_inferred_types icl_de ts = { ts_fun_env = InitFunEnv fun_env_size, ts_var_heap = hp_var_heap, ts_expr_heap = hp_expression_heap, ts_generic_heap = hp_generic_heap, ts_var_store = 0, ts_attr_store = FirstAttrVar, ts_cons_variables = [], ts_exis_variables = [], ts_type_heaps = { hp_type_heaps & th_vars = th_vars }, ts_td_infos = td_infos, ts_error = ts_error, ts_fun_defs=fun_defs } - ti = { ti_common_defs = ti_common_defs, ti_functions = ti_functions,ti_main_dcl_module_n=main_dcl_module_n } + ti = { ti_common_defs = ti_common_defs, ti_functions = ti_functions,ti_main_dcl_module_n=main_dcl_module_n, ti_expand_newtypes = False } special_instances = { si_next_array_member_index = fun_env_size, si_array_instances = [], si_list_instances = [], si_tail_strict_list_instances = [] } # (type_error, predef_symbols, special_instances, out, ts) = type_components list_inferred_types 0 comps class_instances ti (False, predef_symbols, special_instances, out, ts) (fun_defs,ts_fun_env) = update_function_types 0 comps ts.ts_fun_env ts.ts_fun_defs diff --git a/frontend/typesupport.icl b/frontend/typesupport.icl index 54358b0..32e5419 100644 --- a/frontend/typesupport.icl +++ b/frontend/typesupport.icl @@ -157,15 +157,15 @@ where # (argtype, cus) = clean_up cui argtype cus (restype, cus) = clean_up cui restype cus = (argtype --> restype, cus) + clean_up cui t=:(TB _) cus + = (t, cus) //AA.. clean_up cui (TArrow1 argtype) cus # (argtype, cus) = clean_up cui argtype cus = (TArrow1 argtype, cus) clean_up cui t=:TArrow cus = (t, cus) -//..AA - clean_up cui t=:(TB _) cus - = (t, cus) +//..AA clean_up cui (TempCV tempvar :@: types) cus # (type, cus) = cus!cus_var_env.[tempvar] # (type, cus) = cleanUpVariable cui.cui_top_level type tempvar cus @@ -510,7 +510,6 @@ where update_expression_types :: !CleanUpInput ![ExprInfoPtr] !*ExpressionHeap !*CleanUpState -> (!*ExpressionHeap,!*CleanUpState); update_expression_types cui expr_ptrs expr_heap cus -// = (expr_heap, cus) = foldSt (update_expression_type cui) expr_ptrs (expr_heap, cus) update_expression_type cui expr_ptr (expr_heap, cus) @@ -1614,7 +1613,7 @@ getImplicitAttrInequalities st=:{st_args, st_result} = Empty get_ineqs_of_atype_list [a_type:a_types] = Pair (get_ineqs_of_atype a_type) (get_ineqs_of_atype_list a_types) - + beautifulizeAttributes :: !SymbolType !*AttrVarHeap -> (!SymbolType, !.AttrVarHeap) beautifulizeAttributes symbol_type th_attrs # (nr_of_attr_vars, rev_all_attr_vars, th_attrs) @@ -1626,17 +1625,12 @@ beautifulizeAttributes symbol_type th_attrs (_, attr_env_coercions) = foldSt removeRedundancy all_int_inequalities (createArray nr_of_attr_vars False, attr_env_coercions) - implicit_inequalities - = getImplicitAttrInequalities symbol_type + implicit_inequalities = getImplicitAttrInequalities symbol_type (implicit_int_inequalities, th_attrs) = mapSt pointers_to_int implicit_inequalities th_attrs - attr_env_coercions - = foldSt remove_inequality implicit_int_inequalities attr_env_coercions - st_attr_env - = coercionsToAttrEnv {el \\ el<-reverse rev_all_attr_vars } attr_env_coercions - (symbol_type, th_attrs) - = anonymizeAttrVars { symbol_type & st_attr_env = st_attr_env } implicit_inequalities th_attrs - = (symbol_type, th_attrs) + attr_env_coercions = foldSt remove_inequality implicit_int_inequalities attr_env_coercions + st_attr_env = coercionsToAttrEnv {el \\ el<-reverse rev_all_attr_vars } attr_env_coercions + = anonymizeAttrVars { symbol_type & st_attr_env = st_attr_env } implicit_inequalities th_attrs where pointers_to_int {ai_offered, ai_demanded} th_attrs # (AVI_Attr (TA_TempVar offered), th_attrs) = readPtr ai_offered.av_info_ptr th_attrs @@ -1690,13 +1684,12 @@ beautifulizeAttributes symbol_type th_attrs | visited.[candidate] = (accu, visited) = ([candidate:accu], visited) - + assignNumbersToAttrVars :: !SymbolType !*AttrVarHeap -> (!Int, ![AttributeVar], !.AttrVarHeap) assignNumbersToAttrVars {st_attr_vars, st_args, st_result, st_attr_env} th_attrs - # th_attrs - = foldSt initializeToAVI_Empty st_attr_vars th_attrs + # th_attrs = foldSt initializeToAVI_Empty st_attr_vars th_attrs (nr_of_attr_vars, attr_vars, th_attrs) - = performOnAttrVars assign_number_to_unencountered_attr_var (st_args, st_result) + = performOnAttrVars assign_number_to_unencountered_attr_var (st_args, st_result) (0, [], th_attrs) | fst (foldSt hasnt_got_a_number st_attr_env (False, th_attrs)) = abort "sanity check nr 834 in module typesupport failed" diff --git a/frontend/unitype.icl b/frontend/unitype.icl index d05677c..fc8cc6d 100644 --- a/frontend/unitype.icl +++ b/frontend/unitype.icl @@ -331,19 +331,19 @@ where | changed = (True, arg_type0 --> res_type, subst, ls) = (False, type, subst, ls) + lift modules cons_vars type=:(TA cons_id cons_args) subst ls=:{ls_type_heaps} + # (_, type, ls_type_heaps) = tryToExpand type TA_Multi modules ls_type_heaps + = liftTypeApplication modules cons_vars type subst {ls & ls_type_heaps = ls_type_heaps} + lift modules cons_vars type=:(TAS cons_id cons_args _) subst ls=:{ls_type_heaps} + # (_, type, ls_type_heaps) = tryToExpand type TA_Multi modules ls_type_heaps + = liftTypeApplication modules cons_vars type subst {ls & ls_type_heaps = ls_type_heaps} //AA.. lift modules cons_vars type=:(TArrow1 arg_type) subst ls # (changed, arg_type, subst, ls) = lift modules cons_vars arg_type subst ls | changed = (True, TArrow1 arg_type, subst, ls) = (False, type, subst, ls) -//..AA - lift modules cons_vars type=:(TA cons_id cons_args) subst ls=:{ls_type_heaps} - # (_, type, ls_type_heaps) = tryToExpand type TA_Multi modules ls_type_heaps - = liftTypeApplication modules cons_vars type subst {ls & ls_type_heaps = ls_type_heaps} - lift modules cons_vars type=:(TAS cons_id cons_args _) subst ls=:{ls_type_heaps} - # (_, type, ls_type_heaps) = tryToExpand type TA_Multi modules ls_type_heaps - = liftTypeApplication modules cons_vars type subst {ls & ls_type_heaps = ls_type_heaps} +//..AA lift modules cons_vars type=:(TempCV temp_var :@: types) subst ls # (changed, var_type, subst, ls) = liftTempTypeVariable modules cons_vars temp_var subst ls (changed_types, types, subst, ls) = lift_list modules cons_vars types subst ls @@ -1114,6 +1114,8 @@ where = (False,NoPos) find_var_position_in_case_guards (OverloadedListPatterns _ _ algebraic_patterns) = find_var_position_in_algebraic_patterns algebraic_patterns + find_var_position_in_case_guards (NewTypePatterns _ algebraic_patterns) + = find_var_position_in_algebraic_patterns algebraic_patterns find_var_position_in_case_guards (DynamicPatterns dynamic_patterns) = find_var_position_in_dynamic_patterns dynamic_patterns where |