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

in derived dynamic types, add uniqueness to algebraic types that are always unique

(the type definition has a * on the left),
add Bool to GTT_Constructor to indicate uniqueness,
generate TCE_UnqType in TypeCode for unique GTT_Constructor's,
this uniqueness property should be propagated, but this is not implemented yet
parent 091f4fb2
......@@ -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)
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment