diff options
| -rw-r--r-- | frontend/convertDynamics.icl | 2 | ||||
| -rw-r--r-- | frontend/overloading.icl | 24 | ||||
| -rw-r--r-- | frontend/syntax.dcl | 2 | ||||
| -rw-r--r-- | frontend/syntax.icl | 2 |
4 files changed, 23 insertions, 7 deletions
diff --git a/frontend/convertDynamics.icl b/frontend/convertDynamics.icl index 26ab7fc..2ce916e 100644 --- a/frontend/convertDynamics.icl +++ b/frontend/convertDynamics.icl @@ -560,7 +560,7 @@ where -> type_code_constructor_expression PD_TC__StrictArray ci PD_UnboxedArrayType -> type_code_constructor_expression PD_TC__UnboxedArray ci - typeConstructor (GTT_Constructor fun_ident) ci + typeConstructor (GTT_Constructor fun_ident _) ci # type_fun = App {app_symb = fun_ident, app_args = [], app_info_ptr = nilPtr} = (App {app_symb = cinp_dynamic_representation.dr_type_code_constructor_symb_ident, app_args = [type_fun], app_info_ptr = nilPtr}, ci) diff --git a/frontend/overloading.icl b/frontend/overloading.icl index a4e42e8..d501d40 100644 --- a/frontend/overloading.icl +++ b/frontend/overloading.icl @@ -32,7 +32,7 @@ import genericsupport, type_io_common | CA_Context !TypeContext | CA_LocalTypeCode !VarInfoPtr /* for (local) type pattern variables */ | CA_GlobalTypeCode !TypeCodeInstance /* for (global) type constructors */ - + instanceError symbol types err # err = errorHeading "Overloading error" err format = { form_properties = cNoProperties, form_attr_position = No } @@ -1004,7 +1004,12 @@ where ({ heaps & hp_type_heaps = hp_type_heaps }, ptrs)) adjust_member_application defs contexts _ (CA_GlobalTypeCode {tci_constructor,tci_contexts}) _ heaps_and_ptrs # (exprs, heaps_and_ptrs) = convertClassApplsToExpressions defs contexts tci_contexts heaps_and_ptrs - = (EI_TypeCode (TCE_Constructor tci_constructor (expressionsToTypeCodeExpressions exprs)), heaps_and_ptrs) + typeCodeExpressions = expressionsToTypeCodeExpressions exprs + = case tci_constructor of + GTT_Constructor _ True + -> (EI_TypeCode (TCE_UnqType (TCE_Constructor tci_constructor typeCodeExpressions)), heaps_and_ptrs) + _ + -> (EI_TypeCode (TCE_Constructor tci_constructor typeCodeExpressions), heaps_and_ptrs) adjust_member_application defs contexts _ (CA_LocalTypeCode new_var_ptr) _ heaps_and_ptrs = (EI_TypeCode (TCE_Var new_var_ptr), heaps_and_ptrs) @@ -1117,7 +1122,12 @@ where = (TypeCodeExpression (TCE_Var new_var_ptr), heaps_and_ptrs) convert_class_appl_to_expression defs contexts (CA_GlobalTypeCode {tci_constructor,tci_contexts}) heaps_and_ptrs # (exprs, heaps_and_ptrs) = convertClassApplsToExpressions defs contexts tci_contexts heaps_and_ptrs - = (TypeCodeExpression (TCE_Constructor tci_constructor (expressionsToTypeCodeExpressions exprs)), heaps_and_ptrs) + typeCodeExpressions = expressionsToTypeCodeExpressions exprs + = case tci_constructor of + GTT_Constructor _ True + -> (TypeCodeExpression (TCE_UnqType (TCE_Constructor tci_constructor typeCodeExpressions)), heaps_and_ptrs) + _ + -> (TypeCodeExpression (TCE_Constructor tci_constructor typeCodeExpressions), heaps_and_ptrs) convert_reduced_contexts_to_expression defs contexts {rcs_class_context,rcs_constraints_contexts} heaps_and_ptrs # (rcs_exprs, heaps_and_ptrs) = mapSt (convert_class_appl_to_expression defs contexts) rcs_constraints_contexts heaps_and_ptrs @@ -1493,7 +1503,11 @@ toTypeCodeConstructor type=:{glob_object=type_index, glob_module=module_index} c = { symb_ident = {id_name = "TD;"+++type.td_ident.id_name, id_info = nilPtr} , symb_kind = SK_Function {glob_module = module_index, glob_object = td_fun_index} } - = GTT_Constructor type_fun + # is_unique_type + = case type.td_attribute of + TA_Unique -> True + _ -> False + = GTT_Constructor type_fun is_unique_type fatal :: {#Char} {#Char} -> .a fatal function_name message @@ -1511,7 +1525,7 @@ instance toTypeCodeExpression Type where = toTypeCodeExpression type (tci,var_heap,error) # type_constructor = toTypeCodeConstructor type_index tci_common_defs (type_code_args, tci) - = mapSt (toTypeCodeExpression) type_args (tci,var_heap,error) + = mapSt toTypeCodeExpression type_args (tci,var_heap,error) = (TCE_Constructor type_constructor type_code_args, tci) toTypeCodeExpression (TAS cons_id type_args _) state = toTypeCodeExpression (TA cons_id type_args) state diff --git a/frontend/syntax.dcl b/frontend/syntax.dcl index d2a47c7..fd7ce17 100644 --- a/frontend/syntax.dcl +++ b/frontend/syntax.dcl @@ -1476,7 +1476,7 @@ instance == OverloadedListType :: GlobalTCType = GTT_Basic !BasicType - | GTT_Constructor !SymbIdent + | GTT_Constructor !SymbIdent !Bool/*is unique type*/ | GTT_PredefTypeConstructor !(Global Index) | GTT_Function diff --git a/frontend/syntax.icl b/frontend/syntax.icl index 8d429c3..da5445c 100644 --- a/frontend/syntax.icl +++ b/frontend/syntax.icl @@ -448,6 +448,8 @@ where = file <<< "TCE_Selector " <<< selectors <<< "VAR " <<< info_ptr (<<<) file (TCE_UniType vars type_code) = file <<< "TCE_UniType " <<< vars <<< " " <<< type_code + (<<<) file (TCE_UnqType type_code) + = file <<< "TCE_UnqType " <<< type_code instance <<< (Ptr a) where |