diff options
| -rw-r--r-- | frontend/check.icl | 19 | ||||
| -rw-r--r-- | frontend/convertDynamics.icl | 106 | ||||
| -rw-r--r-- | frontend/frontend.icl | 3 | ||||
| -rw-r--r-- | frontend/postparse.icl | 2 | ||||
| -rw-r--r-- | frontend/predef.dcl | 242 | ||||
| -rw-r--r-- | frontend/predef.icl | 102 | ||||
| -rw-r--r-- | frontend/typereify.dcl | 3 | ||||
| -rw-r--r-- | frontend/typereify.icl | 455 |
8 files changed, 281 insertions, 651 deletions
diff --git a/frontend/check.icl b/frontend/check.icl index 33e7b80..a17ad19 100644 --- a/frontend/check.icl +++ b/frontend/check.icl @@ -2109,7 +2109,6 @@ check_module1 cdefs icl_global_function_range fun_defs optional_dcl_mod optional <=< adjust_predefined_module_symbol PD_StdStrictLists <=< adjust_predefined_module_symbol PD_StdDynamic <=< adjust_predefined_module_symbol PD_StdGeneric - <=< adjust_predefined_module_symbol PD_CleanTypes <=< adjust_predefined_module_symbol PD_StdMisc <=< adjust_predefined_module_symbol PD_PredefinedModule = ([], [], { cs & cs_predef_symbols = cs_predef_symbols, cs_symbol_table = cs_symbol_table}) @@ -3139,8 +3138,10 @@ where <=< adjustPredefSymbol PD_Dyn_UnificationEnvironment mod_index STE_Type <=< adjust_predef_symbols PD_Dyn_TypeScheme PD_Dyn__TypeFixedVar mod_index STE_Constructor <=< adjust_predef_symbols PD_Dyn_initial_unification_environment PD_Dyn_normalise mod_index STE_DclFunction - <=< adjust_predef_symbols PD_Dyn_TypeCodeConstructorInt PD_Dyn_TypeCodeConstructor_UnboxedArray mod_index STE_DclFunction - <=< adjustPredefSymbol PD_Dyn__to_TypeCodeConstructor mod_index STE_DclFunction) + <=< adjustPredefSymbol PD_Dyn__to_TypeCodeConstructor mod_index STE_DclFunction + <=< adjustPredefSymbol PD_TypeCodeConstructor mod_index STE_Type + <=< adjust_predef_symbols PD_TC_Int PD_TC__UnboxedArray mod_index STE_Constructor + ) # (pre_mod, cs_predef_symbols) = cs_predef_symbols![PD_StdGeneric] # type_bimap = predefined_idents.[PD_TypeBimap] | pre_mod.pds_def == mod_index @@ -3157,18 +3158,6 @@ where = (class_members, class_instances, fun_types, { cs & cs_predef_symbols = cs_predef_symbols} <=< adjustPredefSymbol PD_abort mod_index STE_DclFunction <=< adjustPredefSymbol PD_undef mod_index STE_DclFunction) - # (pre_mod, cs_predef_symbols) = cs_predef_symbols![PD_CleanTypes] - | pre_mod.pds_def == mod_index - = (class_members, class_instances, fun_types, { cs & cs_predef_symbols = cs_predef_symbols} - <=< adjustPredefSymbol PD_CTTypeDef mod_index STE_Type - <=< adjustPredefSymbol PD_CTAlgType mod_index STE_Constructor - <=< adjustPredefSymbol PD_CTRecordType mod_index STE_Constructor - <=< adjustPredefSymbol PD_CTSynType mod_index STE_Constructor - <=< adjustPredefSymbol PD_CTPredefined mod_index STE_Constructor - <=< adjustPredefSymbol PD_CTConsDef mod_index STE_Type - <=< adjustPredefSymbol PD__CTToCons mod_index STE_DclFunction - <=< adjustPredefSymbol PD_CTFieldDef mod_index STE_Type ) - = (class_members, class_instances, fun_types, { cs & cs_predef_symbols = cs_predef_symbols}) where unused diff --git a/frontend/convertDynamics.icl b/frontend/convertDynamics.icl index 8fab72d..e6753aa 100644 --- a/frontend/convertDynamics.icl +++ b/frontend/convertDynamics.icl @@ -20,13 +20,14 @@ import type_io; } :: DynamicRepresentation = - { dr_type_ident :: SymbIdent + !{ dr_type_ident :: SymbIdent , dr_dynamic_type :: Global Index , dr_dynamic_symbol :: Global DefinedSymbol + , dr_type_code_constructor_symb_ident :: SymbIdent } :: ConversionInput = - { cinp_dynamic_representation :: DynamicRepresentation + { cinp_dynamic_representation :: !DynamicRepresentation , cinp_st_args :: ![FreeVar] , cinp_subst_var :: !BoundVar } @@ -507,7 +508,6 @@ convertTypeCode pattern _ (TCE_TypeTerm var_info_ptr) (has_var, binds, ci=:{ci_v # (expr, ci) = createTypePatternVariable ci # ci = {ci & ci_var_heap = writePtr var_info_ptr (VI_TypeCodeVariable (TCI_TypePatternVar expr)) ci.ci_var_heap} -> (expr, (True, binds, ci)) - convertTypeCode pattern cinp (TCE_App t arg) (has_var, binds, ci) # (typeapp_symb, ci) = getSymbol PD_Dyn_TypeApp SK_Constructor 2 ci @@ -518,7 +518,7 @@ convertTypeCode pattern cinp (TCE_App t arg) (has_var, binds, ci) = (App {app_symb = typeapp_symb, app_args = [typecode_t, typecode_arg], app_info_ptr = nilPtr}, st) -convertTypeCode pattern cinp (TCE_Constructor cons []) (has_var, binds, ci) +convertTypeCode pattern {cinp_dynamic_representation} (TCE_Constructor cons []) (has_var, binds, ci) # (typecons_symb, ci) = getSymbol PD_Dyn_TypeCons SK_Constructor 1 ci # (constructor, ci) @@ -536,62 +536,50 @@ where typeConstructor (GTT_PredefTypeConstructor {glob_object=type_index}) ci | PD_Arity2TupleTypeIndex <= type_index && type_index <= PD_Arity32TupleTypeIndex - # arity - = type_index - PD_Arity2TupleTypeIndex + 2 - # (tuple_symb, ci) - = getSymbol PD_Dyn_TypeCodeConstructor_Tuple SK_Function 1 ci - = (App {app_symb = tuple_symb, app_args = [BasicExpr (BVInt arity)], app_info_ptr = nilPtr}, ci) + = type_code_constructor_expression (type_index + (PD_TC__Tuple2 - PD_Arity2TupleTypeIndex)) ci // otherwise - # predef_type_index - = type_index + FirstTypePredefinedSymbolIndex - = constructorExp (predefinedTypeConstructor predef_type_index) SK_Function 0 ci + # predef_type_index = type_index + FirstTypePredefinedSymbolIndex + = case predef_type_index of + PD_ListType + -> type_code_constructor_expression PD_TC__List ci + PD_StrictListType + -> type_code_constructor_expression PD_TC__StrictList ci + PD_UnboxedListType + -> type_code_constructor_expression PD_TC__UnboxedList ci + PD_TailStrictListType + -> type_code_constructor_expression PD_TC__TailStrictList ci + PD_StrictTailStrictListType + -> type_code_constructor_expression PD_TC__StrictTailStrictList ci + PD_UnboxedTailStrictListType + -> type_code_constructor_expression PD_TC__UnboxedTailStrictList ci + PD_LazyArrayType + -> type_code_constructor_expression PD_TC__LazyArray ci + PD_StrictArrayType + -> type_code_constructor_expression PD_TC__StrictArray ci + PD_UnboxedArrayType + -> type_code_constructor_expression PD_TC__UnboxedArray ci typeConstructor (GTT_Constructor fun_ident) ci # type_fun = App {app_symb = fun_ident, app_args = [], app_info_ptr = nilPtr} - # (to_tc_symb, ci) - = getSymbol PD_Dyn__to_TypeCodeConstructor SK_Function 2 ci - = (App {app_symb = to_tc_symb, app_args = [type_fun], app_info_ptr = nilPtr}, ci) + = (App {app_symb = cinp_dynamic_representation.dr_type_code_constructor_symb_ident, app_args = [type_fun], app_info_ptr = nilPtr}, ci) typeConstructor (GTT_Basic basic_type) ci - = constructorExp (basicTypeConstructor basic_type) SK_Function 0 ci + #! predefined_TC_basic_type + = case basic_type of + BT_Int -> PD_TC_Int + BT_Char -> PD_TC_Char + BT_Real -> PD_TC_Real + BT_Bool -> PD_TC_Bool + BT_Dynamic -> PD_TC_Dynamic + BT_File -> PD_TC_File + BT_World -> PD_TC_World + = type_code_constructor_expression predefined_TC_basic_type ci typeConstructor GTT_Function ci - = constructorExp PD_Dyn_TypeCodeConstructor_Arrow SK_Function 0 ci - - basicTypeConstructor BT_Int - = PD_Dyn_TypeCodeConstructorInt - basicTypeConstructor BT_Char - = PD_Dyn_TypeCodeConstructorChar - basicTypeConstructor BT_Real - = PD_Dyn_TypeCodeConstructorReal - basicTypeConstructor BT_Bool - = PD_Dyn_TypeCodeConstructorBool - basicTypeConstructor BT_Dynamic - = PD_Dyn_TypeCodeConstructorDynamic - basicTypeConstructor BT_File - = PD_Dyn_TypeCodeConstructorFile - basicTypeConstructor BT_World - = PD_Dyn_TypeCodeConstructorWorld - - predefinedTypeConstructor predef_type_index - | predef_type_index == PD_ListType - = PD_Dyn_TypeCodeConstructor_List - | predef_type_index == PD_StrictListType - = PD_Dyn_TypeCodeConstructor_StrictList - | predef_type_index == PD_UnboxedListType - = PD_Dyn_TypeCodeConstructor_UnboxedList - | predef_type_index == PD_TailStrictListType - = PD_Dyn_TypeCodeConstructor_TailStrictList - | predef_type_index == PD_StrictTailStrictListType - = PD_Dyn_TypeCodeConstructor_StrictTailStrictList - | predef_type_index == PD_UnboxedTailStrictListType - = PD_Dyn_TypeCodeConstructor_UnboxedTailStrictList - | predef_type_index == PD_LazyArrayType - = PD_Dyn_TypeCodeConstructor_LazyArray - | predef_type_index == PD_StrictArrayType - = PD_Dyn_TypeCodeConstructor_StrictArray - | predef_type_index == PD_UnboxedArrayType - = PD_Dyn_TypeCodeConstructor_UnboxedArray - // otherwise - = fatal "predefinedType" "TC code from predef" + = type_code_constructor_expression PD_TC__Arrow ci + + type_code_constructor_expression predefined_TC_type ci + # (cons_TC_Char, ci) = constructorExp predefined_TC_type SK_Constructor 0 ci + = (App {app_symb = cinp_dynamic_representation.dr_type_code_constructor_symb_ident, app_args = [cons_TC_Char], app_info_ptr = nilPtr}, ci) + convertTypeCode pattern cinp (TCE_Constructor cons args) st # curried_type = foldl TCE_App (TCE_Constructor cons []) args @@ -751,10 +739,11 @@ create_dynamic_and_selector_idents common_defs predefined_symbols = ({ dr_type_ident = undef , dr_dynamic_type = undef , dr_dynamic_symbol = undef + , dr_type_code_constructor_symb_ident = undef },predefined_symbols) - // otherwise + // otherwise # ({pds_module=pds_module1, pds_def=pds_def1} , predefined_symbols) = predefined_symbols![PD_Dyn_DynamicTemp] - # {td_rhs=RecordType {rt_constructor,rt_fields}} = common_defs.[pds_module1].com_type_defs.[pds_def1] + # {td_rhs=RecordType {rt_constructor}} = common_defs.[pds_module1].com_type_defs.[pds_def1] # dynamic_defined_symbol = {glob_module = pds_module1, glob_object = rt_constructor} @@ -765,8 +754,13 @@ create_dynamic_and_selector_idents common_defs predefined_symbols symb_ident = rt_constructor.ds_ident , symb_kind = SK_Constructor {glob_module = pds_module1, glob_object = rt_constructor.ds_index} } + # ({pds_module=pds_module2, pds_def=pds_def2}, predefined_symbols) = predefined_symbols![PD_TypeCodeConstructor] + # {td_rhs=RecordType {rt_constructor}} = common_defs.[pds_module2].com_type_defs.[pds_def2] + # type_code_constructor_symb_ident + = {symb_ident = rt_constructor.ds_ident, symb_kind = SK_Constructor {glob_module = pds_module2, glob_object = rt_constructor.ds_index}} = ({ dr_type_ident = dynamic_temp_symb_ident , dr_dynamic_type = dynamic_type , dr_dynamic_symbol = dynamic_defined_symbol + , dr_type_code_constructor_symb_ident = type_code_constructor_symb_ident }, predefined_symbols) diff --git a/frontend/frontend.icl b/frontend/frontend.icl index b604a45..91849e3 100644 --- a/frontend/frontend.icl +++ b/frontend/frontend.icl @@ -98,9 +98,6 @@ frontEndInterface options mod_ident search_paths cached_dcl_modules cached_dcl_m // # (td_infos, th_vars, error_admin) = analyseTypeDefs ti_common_defs type_groups td_infos type_heaps.th_vars error_admin ({com_type_defs}, ti_common_defs) = replace ti_common_defs main_dcl_module_n icl_common - | support_dynamics && not (sanityCheckTypeFunctions main_dcl_module_n icl_common dcl_mods fun_defs) - = abort "frontend: sanityCheckTypeFunctions failed" - # hp_var_heap = heaps.hp_var_heap #! n_types_with_type_functions = size ti_common_defs.[main_dcl_module_n].com_type_defs #! n_constructors_with_type_functions = size ti_common_defs.[main_dcl_module_n].com_cons_defs diff --git a/frontend/postparse.icl b/frontend/postparse.icl index fef6944..03501fc 100644 --- a/frontend/postparse.icl +++ b/frontend/postparse.icl @@ -1483,7 +1483,7 @@ qualified_ident_to_import_declaration IC_Selector ident reorganiseDefinitionsAndAddTypes mod_ident support_dynamics icl_module defs ca | support_dynamics # clean_types_module_ident - = predefined_idents.[PD_CleanTypes] + = predefined_idents.[PD_StdDynamic] # clean_types_module = { import_module = clean_types_module_ident , import_symbols = ImportSymbolsAll diff --git a/frontend/predef.dcl b/frontend/predef.dcl index f4a4d77..8c45127 100644 --- a/frontend/predef.dcl +++ b/frontend/predef.dcl @@ -160,121 +160,145 @@ PD_Dyn_initial_unification_environment :== 172 PD_Dyn_bind_global_type_pattern_var :== 173 PD_Dyn_unify :== 174 PD_Dyn_normalise :== 175 -// predefined type code constructor (expressions) -PD_Dyn_TypeCodeConstructorInt :== 176 -PD_Dyn_TypeCodeConstructorChar :== 177 -PD_Dyn_TypeCodeConstructorReal :== 178 -PD_Dyn_TypeCodeConstructorBool :== 179 -PD_Dyn_TypeCodeConstructorDynamic :== 180 -PD_Dyn_TypeCodeConstructorFile :== 181 -PD_Dyn_TypeCodeConstructorWorld :== 182 -PD_Dyn_TypeCodeConstructor_Arrow :== 183 -PD_Dyn_TypeCodeConstructor_List :== 184 -PD_Dyn_TypeCodeConstructor_StrictList :== 185 -PD_Dyn_TypeCodeConstructor_UnboxedList :== 186 -PD_Dyn_TypeCodeConstructor_TailStrictList :== 187 -PD_Dyn_TypeCodeConstructor_StrictTailStrictList :== 188 -PD_Dyn_TypeCodeConstructor_UnboxedTailStrictList :== 189 -PD_Dyn_TypeCodeConstructor_Tuple :== 190 -PD_Dyn_TypeCodeConstructor_LazyArray :== 191 -PD_Dyn_TypeCodeConstructor_StrictArray :== 192 -PD_Dyn_TypeCodeConstructor_UnboxedArray :== 193 /* Generics */ -PD_StdGeneric :== 194 +PD_StdGeneric :== 176 // Generics types -PD_TypeBimap :== 195 -PD_TypeUNIT :== 196 -PD_TypeEITHER :== 197 -PD_TypePAIR :== 198 +PD_TypeBimap :== 177 +PD_TypeUNIT :== 178 +PD_TypeEITHER :== 179 +PD_TypePAIR :== 180 // for constructor info -PD_TypeCONS :== 199 -PD_TypeFIELD :== 200 -PD_TypeOBJECT :== 201 -PD_GenericInfo :== 202 -PD_TGenericConsDescriptor :== 203 -PD_TGenericFieldDescriptor :== 204 -PD_TGenericTypeDefDescriptor :== 205 -PD_TGenConsPrio :== 206 -PD_TGenConsAssoc :== 207 -PD_TGenType :== 208 - -PD_TypeGenericDict :== 209 +PD_TypeCONS :== 181 +PD_TypeFIELD :== 182 +PD_TypeOBJECT :== 183 +PD_GenericInfo :== 184 +//PD_TGenericConsDescriptor :== 184 +PD_TGenericFieldDescriptor :== 185 +PD_TGenericTypeDefDescriptor :== 186 +PD_TGenConsPrio :== 187 +PD_TGenConsAssoc :== 188 +PD_TGenType :== 189 + +PD_TypeGenericDict :== 190 // Generics fields -PD_map_to :== 210 -PD_map_from :== 211 -// Generics expressions -PD_ConsBimap :== 212 -PD_ConsUNIT :== 213 -PD_ConsLEFT :== 214 -PD_ConsRIGHT :== 215 -PD_ConsPAIR :== 216 +PD_map_to :== 191 +PD_map_from :== 192 +// Generics expression +PD_ConsBimap :== 193 +PD_ConsUNIT :== 194 +PD_ConsLEFT :== 195 +PD_ConsRIGHT :== 196 +PD_ConsPAIR :== 197 // for constructor info -PD_ConsCONS :== 217 -PD_ConsFIELD :== 218 -PD_ConsOBJECT :== 219 -PD_NoGenericInfo :== 220 -PD_GenericConsInfo :== 221 -PD_GenericFieldInfo :== 222 -PD_GenericTypeInfo :== 223 -PD_CGenericConsDescriptor :== 224 -PD_CGenericFieldDescriptor :== 225 -PD_CGenericTypeDefDescriptor :== 226 -PD_CGenConsNoPrio :== 227 -PD_CGenConsPrio :== 228 -PD_CGenConsAssocNone :== 229 -PD_CGenConsAssocLeft :== 230 -PD_CGenConsAssocRight :== 231 -PD_CGenTypeCons :== 232 -PD_CGenTypeVar :== 233 -PD_CGenTypeArrow :== 234 -PD_CGenTypeApp :== 235 - -PD_bimapId :== 236 -PD_GenericBimap :== 237 - -PD_FromS :== 238 -PD_FromTS :== 239 -PD_FromSTS :== 240 -PD_FromU :== 241 -PD_FromUTS :== 242 -PD_FromO :== 243 - -PD_FromThenS :== 244 -PD_FromThenTS :== 245 -PD_FromThenSTS :== 246 -PD_FromThenU :== 247 -PD_FromThenUTS :== 248 -PD_FromThenO :== 249 - -PD_FromToS :== 250 -PD_FromToTS :== 251 -PD_FromToSTS :== 252 -PD_FromToU :== 253 -PD_FromToUTS :== 254 -PD_FromToO :== 255 - -PD_FromThenToS :== 256 -PD_FromThenToTS :== 257 -PD_FromThenToSTS :== 258 -PD_FromThenToU :== 259 -PD_FromThenToUTS :== 260 -PD_FromThenToO :== 261 - -/* Clean Type introspection */ -PD_CleanTypes :== 262 -PD_CTTypeDef :== 263 -PD_CTAlgType :== 264 -PD_CTRecordType :== 265 -PD_CTSynType :== 266 -PD_CTPredefined :== 267 -PD_CTConsDef :== 268 -PD__CTToCons :== 269 -PD_CTFieldDef :== 270 - -PD_Dyn__to_TypeCodeConstructor :== 271 - -PD_NrOfPredefSymbols :== 272 +PD_ConsCONS :== 198 +PD_ConsFIELD :== 199 +PD_ConsOBJECT :== 200 +PD_NoGenericInfo :== 201 +PD_GenericConsInfo :== 202 +PD_GenericFieldInfo :== 203 +PD_GenericTypeInfo :== 204 +PD_CGenericConsDescriptor :== 205 +PD_CGenericFieldDescriptor :== 206 +PD_CGenericTypeDefDescriptor :== 207 +PD_CGenConsNoPrio :== 208 +PD_CGenConsPrio :== 209 +PD_CGenConsAssocNone :== 210 +PD_CGenConsAssocLeft :== 211 +PD_CGenConsAssocRight :== 212 +PD_CGenTypeCons :== 213 +PD_CGenTypeVar :== 214 +PD_CGenTypeArrow :== 215 +PD_CGenTypeApp :== 216 + +PD_bimapId :== 217 +PD_GenericBimap :== 218 + +PD_FromS :== 219 +PD_FromTS :== 220 +PD_FromSTS :== 221 +PD_FromU :== 222 +PD_FromUTS :== 223 +PD_FromO :== 224 + +PD_FromThenS :== 225 +PD_FromThenTS :== 226 +PD_FromThenSTS :== 227 +PD_FromThenU :== 228 +PD_FromThenUTS :== 229 +PD_FromThenO :== 230 + +PD_FromToS :== 231 +PD_FromToTS :== 232 +PD_FromToSTS :== 233 +PD_FromToU :== 234 +PD_FromToUTS :== 235 +PD_FromToO :== 236 + +PD_FromThenToS :== 237 +PD_FromThenToTS :== 238 +PD_FromThenToSTS :== 239 +PD_FromThenToU :== 240 +PD_FromThenToUTS :== 241 +PD_FromThenToO :== 242 + +PD_Dyn__to_TypeCodeConstructor :== 243 +PD_TypeCodeConstructor :== 244 + +PD_TC_Int :== 245 +PD_TC_Char :== 246 +PD_TC_Real :== 247 +PD_TC_Bool :== 248 +PD_TC_Dynamic :== 249 +PD_TC_File :== 250 +PD_TC_World :== 251 + +PD_TC__Arrow :== 252 + +PD_TC__List :== 253 +PD_TC__StrictList :== 254 +PD_TC__UnboxedList :== 255 +PD_TC__TailStrictList :== 256 +PD_TC__StrictTailStrictList :== 257 +PD_TC__UnboxedTailStrictList :== 258 + +PD_TC__Tuple2 :== 259 +PD_TC__Tuple3 :== 260 +PD_TC__Tuple4 :== 261 +PD_TC__Tuple5 :== 262 +PD_TC__Tuple6 :== 263 +PD_TC__Tuple7 :== 264 +PD_TC__Tuple8 :== 265 +PD_TC__Tuple9 :== 266 +PD_TC__Tuple10 :== 267 +PD_TC__Tuple11 :== 268 +PD_TC__Tuple12 :== 269 +PD_TC__Tuple13 :== 270 +PD_TC__Tuple14 :== 271 +PD_TC__Tuple15 :== 272 +PD_TC__Tuple16 :== 273 +PD_TC__Tuple17 :== 274 +PD_TC__Tuple18 :== 275 +PD_TC__Tuple19 :== 276 +PD_TC__Tuple20 :== 277 +PD_TC__Tuple21 :== 278 +PD_TC__Tuple22 :== 279 +PD_TC__Tuple23 :== 280 +PD_TC__Tuple24 :== 281 +PD_TC__Tuple25 :== 282 +PD_TC__Tuple26 :== 283 +PD_TC__Tuple27 :== 284 +PD_TC__Tuple28 :== 285 +PD_TC__Tuple29 :== 286 +PD_TC__Tuple30 :== 287 +PD_TC__Tuple31 :== 288 +PD_TC__Tuple32 :== 289 + +PD_TC__LazyArray :== 290 +PD_TC__StrictArray :== 291 +PD_TC__UnboxedArray :== 292 + +PD_NrOfPredefSymbols :== 293 GetTupleConsIndex tup_arity :== PD_Arity2TupleSymbol + tup_arity - 2 GetTupleTypeIndex tup_arity :== PD_Arity2TupleType + tup_arity - 2 diff --git a/frontend/predef.icl b/frontend/predef.icl index fb7c168..73ec622 100644 --- a/frontend/predef.icl +++ b/frontend/predef.icl @@ -112,26 +112,61 @@ predefined_idents [PD_Dyn_unify] = i "_unify", [PD_Dyn_normalise] = i "_normalise", - [PD_Dyn_TypeCodeConstructorInt] = i "TypeCodeConstructorInt", - [PD_Dyn_TypeCodeConstructorChar] = i "TypeCodeConstructorChar", - [PD_Dyn_TypeCodeConstructorReal] = i "TypeCodeConstructorReal", - [PD_Dyn_TypeCodeConstructorBool] = i "TypeCodeConstructorBool", - [PD_Dyn_TypeCodeConstructorDynamic] = i "TypeCodeConstructorDynamic", - [PD_Dyn_TypeCodeConstructorFile] = i "TypeCodeConstructorFile", - [PD_Dyn_TypeCodeConstructorWorld] = i "TypeCodeConstructorWorld", - [PD_Dyn_TypeCodeConstructor_Arrow] = i "TypeCodeConstructor_Arrow", - [PD_Dyn_TypeCodeConstructor_List] = i "TypeCodeConstructor_List", - [PD_Dyn_TypeCodeConstructor_StrictList] = i "TypeCodeConstructor_StrictList", - [PD_Dyn_TypeCodeConstructor_UnboxedList] = i "TypeCodeConstructor_UnboxedList", - [PD_Dyn_TypeCodeConstructor_TailStrictList] = i "TypeCodeConstructor_TailStrictList", - [PD_Dyn_TypeCodeConstructor_StrictTailStrictList] = i "TypeCodeConstructor_StrictTailStrictList", - [PD_Dyn_TypeCodeConstructor_UnboxedTailStrictList] = i "TypeCodeConstructor_UnboxedTailStrictList", - [PD_Dyn_TypeCodeConstructor_Tuple] = i "TypeCodeConstructor_Tuple", - [PD_Dyn_TypeCodeConstructor_LazyArray] = i "TypeCodeConstructor_LazyArray", - [PD_Dyn_TypeCodeConstructor_StrictArray] = i "TypeCodeConstructor_StrictArray", - [PD_Dyn_TypeCodeConstructor_UnboxedArray] = i "TypeCodeConstructor_UnboxedArray", - [PD_Dyn__to_TypeCodeConstructor] = i "_to_TypeCodeConstructor", + [PD_TypeCodeConstructor] = i "TypeCodeConstructor", + + [PD_TC_Int] = i "TC_Int", + [PD_TC_Char] = i "TC_Char", + [PD_TC_Real] = i "TC_Real", + [PD_TC_Bool] = i "TC_Bool", + [PD_TC_Dynamic] = i "TC_Dynamic", + [PD_TC_File] = i "TC_File", + [PD_TC_World] = i "TC_World", + + [PD_TC__Arrow] = i "TC__Arrow", + + [PD_TC__List] = i "TC__List", + [PD_TC__StrictList] = i "TC__StrictList", + [PD_TC__UnboxedList] = i "TC__UnboxedList", + [PD_TC__TailStrictList] = i "TC__TailStrictList", + [PD_TC__StrictTailStrictList] = i "TC__StrictTailStrictList", + [PD_TC__UnboxedTailStrictList] = i "TC__UnboxedTailStrictList", + + [PD_TC__Tuple2] = i "TC__Tuple2", + [PD_TC__Tuple3] = i "TC__Tuple3", + [PD_TC__Tuple4] = i "TC__Tuple4", + [PD_TC__Tuple5] = i "TC__Tuple5", + [PD_TC__Tuple6] = i "TC__Tuple6", + [PD_TC__Tuple7] = i "TC__Tuple7", + [PD_TC__Tuple8] = i "TC__Tuple8", + [PD_TC__Tuple9] = i "TC__Tuple9", + [PD_TC__Tuple10] = i "TC__Tuple10", + [PD_TC__Tuple11] = i "TC__Tuple11", + [PD_TC__Tuple12] = i "TC__Tuple12", + [PD_TC__Tuple13] = i "TC__Tuple13", + [PD_TC__Tuple14] = i "TC__Tuple14", + [PD_TC__Tuple15] = i "TC__Tuple15", + [PD_TC__Tuple16] = i "TC__Tuple16", + [PD_TC__Tuple17] = i "TC__Tuple17", + [PD_TC__Tuple18] = i "TC__Tuple18", + [PD_TC__Tuple19] = i "TC__Tuple19", + [PD_TC__Tuple20] = i "TC__Tuple20", + [PD_TC__Tuple21] = i "TC__Tuple21", + [PD_TC__Tuple22] = i "TC__Tuple22", + [PD_TC__Tuple23] = i "TC__Tuple23", + [PD_TC__Tuple24] = i "TC__Tuple24", + [PD_TC__Tuple25] = i "TC__Tuple25", + [PD_TC__Tuple26] = i "TC__Tuple26", + [PD_TC__Tuple27] = i "TC__Tuple27", + [PD_TC__Tuple28] = i "TC__Tuple28", + [PD_TC__Tuple29] = i "TC__Tuple29", + [PD_TC__Tuple30] = i "TC__Tuple30", + [PD_TC__Tuple31] = i "TC__Tuple31", + [PD_TC__Tuple32] = i "TC__Tuple32", + + [PD_TC__LazyArray] = i "TC__LazyArray", + [PD_TC__StrictArray] = i "TC__StrictArray", + [PD_TC__UnboxedArray] = i "TC__UnboxedArray", [PD_StdGeneric] = i "StdGeneric", [PD_TypeBimap] = i "Bimap", @@ -213,17 +248,7 @@ predefined_idents [PD_FromThenToSTS]= i "_from_then_to_sts", [PD_FromThenToU]= i "_from_then_to_u", [PD_FromThenToUTS]= i "_from_then_to_uts", - [PD_FromThenToO]= i "_from_then_to_o", - - [PD_CleanTypes] = i "StdCleanTypes", - [PD_CTTypeDef] = i "CTTypeDef", - [PD_CTAlgType] = i "CTAlgType", - [PD_CTRecordType] = i "CTRecordType", - [PD_CTSynType] = i "CTSynType", - [PD_CTPredefined] = i "CTPredefined", - [PD_CTConsDef] = i "CTConsDef", - [PD__CTToCons] = i "CTToCons", - [PD_CTFieldDef] = i "CTFieldDef" + [PD_FromThenToO]= i "_from_then_to_o" } =: idents @@ -341,10 +366,14 @@ where <<- (local_predefined_idents, IC_Type, PD_Dyn_DynamicTemp) <<- (local_predefined_idents, IC_Type, PD_Dyn_TypeCode) <<- (local_predefined_idents, IC_Type, PD_Dyn_UnificationEnvironment) - # hash_table = put_predefined_idents_in_hash_table PD_Dyn_TypeScheme PD_Dyn_TypeCodeConstructor_UnboxedArray IC_Expression local_predefined_idents hash_table + # hash_table = put_predefined_idents_in_hash_table PD_Dyn_TypeScheme PD_Dyn_normalise IC_Expression local_predefined_idents hash_table <<- (local_predefined_idents, IC_Expression, PD_Dyn__to_TypeCodeConstructor) + <<- (local_predefined_idents, IC_Type, PD_TypeCodeConstructor) + <<- (local_predefined_idents, IC_Module NoQualifiedIdents, PD_StdGeneric) + # hash_table = put_predefined_idents_in_hash_table PD_TC_Int PD_TC__UnboxedArray IC_Expression local_predefined_idents hash_table + # hash_table = put_predefined_idents_in_hash_table PD_TypeBimap PD_TypeGenericDict IC_Type local_predefined_idents hash_table # hash_table = put_predefined_idents_in_hash_table PD_ConsBimap PD_bimapId IC_Expression local_predefined_idents hash_table <<- (local_predefined_idents, IC_Generic, PD_GenericBimap) @@ -357,17 +386,6 @@ where <<- (local_predefined_idents, IC_Expression, PD_abort) <<- (local_predefined_idents, IC_Expression, PD_undef) - - <<- (local_predefined_idents, IC_Module NoQualifiedIdents, PD_CleanTypes) - - <<- (local_predefined_idents, IC_Type, PD_CTTypeDef) - <<- (local_predefined_idents, IC_Expression, PD_CTAlgType) - <<- (local_predefined_idents, IC_Expression, PD_CTRecordType) - <<- (local_predefined_idents, IC_Expression, PD_CTSynType) - <<- (local_predefined_idents, IC_Expression, PD_CTPredefined) - <<- (local_predefined_idents, IC_Type, PD_CTConsDef) - <<- (local_predefined_idents, IC_Expression, PD__CTToCons) - <<- (local_predefined_idents, IC_Type, PD_CTFieldDef) <<- (local_predefined_idents, IC_Expression, PD_Start) diff --git a/frontend/typereify.dcl b/frontend/typereify.dcl index 292d211..1c43819 100644 --- a/frontend/typereify.dcl +++ b/frontend/typereify.dcl @@ -15,6 +15,3 @@ addTypeFunctions :: Ident Int *{#DclModule} *{#FunDef} *CommonDefs *PredefinedSy buildTypeFunctions :: !Int !*{#FunDef} !{#CommonDefs} *PredefinedSymbols *VarHeap *TypeHeaps -> (*{#FunDef}, *PredefinedSymbols,*VarHeap,*TypeHeaps) - -sanityCheckTypeFunctions :: !Int !CommonDefs !{#DclModule} !{#FunDef} - -> Bool diff --git a/frontend/typereify.icl b/frontend/typereify.icl index 22b55bb..3c34ed1 100644 --- a/frontend/typereify.icl +++ b/frontend/typereify.icl @@ -6,10 +6,6 @@ implementation module typereify import syntax import typesupport -typeFunName :: Ident -> {#Char} -typeFunName {id_name} - = "TD;" +++ id_name - class makeTypeFun a :: Ident Position SymbolType *VarHeap *SymbolTable -> (a, *VarHeap, *SymbolTable) @@ -72,29 +68,29 @@ instance isTypeSynonym TypeRhs where add_dcl_type_fun_types :: TypeSymbIdent Int *{#DclModule} *VarHeap *SymbolTable -> (*{#DclModule},*VarHeap,*SymbolTable) -add_dcl_type_fun_types ctTypeDefSymb add_dcl_type_fun_types dcl_mods var_heap symbols +add_dcl_type_fun_types ctListDefSymb n_cached_dcls dcl_mods var_heap symbols # (n, dcl_mods) = usize dcl_mods - = add_type_fun_types add_dcl_type_fun_types n ctTypeDefSymb dcl_mods var_heap symbols + = add_type_fun_types n_cached_dcls n ctListDefSymb dcl_mods var_heap symbols where add_type_fun_types :: Int Int TypeSymbIdent *{#DclModule} *VarHeap *SymbolTable -> (*{#DclModule},*VarHeap,*SymbolTable) - add_type_fun_types module_n n ctTypeDefSymb dcl_mods var_heap symbols + add_type_fun_types module_n n ctListDefSymb dcl_mods var_heap symbols | module_n >= n = (dcl_mods, var_heap, symbols) | module_n == cPredefinedModuleIndex - = add_type_fun_types (module_n+1) n ctTypeDefSymb dcl_mods var_heap symbols + = add_type_fun_types (module_n+1) n ctListDefSymb dcl_mods var_heap symbols # (dcl_mod, dcl_mods) = dcl_mods![module_n] # (dcl_mod, var_heap, symbols) - = add_fun_types ctTypeDefSymb dcl_mod var_heap symbols + = add_fun_types ctListDefSymb dcl_mod var_heap symbols # dcl_mods = {dcl_mods & [module_n] = dcl_mod} - = add_type_fun_types (module_n+1) n ctTypeDefSymb dcl_mods var_heap symbols + = add_type_fun_types (module_n+1) n ctListDefSymb dcl_mods var_heap symbols add_fun_types :: TypeSymbIdent DclModule *VarHeap *SymbolTable -> (DclModule,*VarHeap,*SymbolTable) -add_fun_types ctTypeDefSymb dcl_mod=:{dcl_name, dcl_functions, dcl_common={com_type_defs}} var_heap symbols +add_fun_types ctListDefSymb dcl_mod=:{dcl_name, dcl_functions, dcl_common={com_type_defs}} var_heap symbols # n_functions = size dcl_functions (type_funs, com_type_defs, var_heap, symbols) - = addTypeFunctionsA dcl_name n_functions ctTypeDefSymb {def \\ def <-: com_type_defs} var_heap symbols + = addTypeFunctionsA dcl_name n_functions ctListDefSymb {def \\ def <-: com_type_defs} var_heap symbols dcl_functions = {function \\ function <- [e \\ e <-: dcl_functions] ++ type_funs} dcl_type_funs = {ir_from = n_functions, ir_to = size dcl_functions} dcl_mod = { dcl_mod & dcl_functions = dcl_functions @@ -103,16 +99,23 @@ add_fun_types ctTypeDefSymb dcl_mod=:{dcl_name, dcl_functions, dcl_common={com_t } = (dcl_mod, var_heap, symbols) -getCTTypeDefSymb predefs - # ({pds_module, pds_def}, predefs) = predefs![PD_CTTypeDef] - # ident = predefined_idents.[PD_CTTypeDef] - # type_symb = {MakeNewTypeSymbIdent ident 0 & type_index.glob_module = pds_module, type_index.glob_object = pds_def} +getListTypeSymb predefs + # ({pds_module, pds_def}, predefs) = predefs![PD_ListType] + ident = predefined_idents.[PD_ListType] + type_symb = {MakeNewTypeSymbIdent ident 0 & type_index.glob_module = pds_module, type_index.glob_object = pds_def} = (type_symb, predefs) +getNilSymb :: *PredefinedSymbols -> (SymbIdent, !*PredefinedSymbols) +getNilSymb predefs + # ({pds_module, pds_def}, predefs) = predefs![PD_NilSymbol] + pds_ident = predefined_idents.[PD_NilSymbol] + symbol = { symb_ident = pds_ident, symb_kind = SK_Constructor { glob_module = pds_module, glob_object = pds_def} } + = (symbol, predefs) + addTypeFunctions :: Ident Int *{#DclModule} *{#FunDef} *CommonDefs *PredefinedSymbols *VarHeap *SymbolTable -> (IndexRange, *{#DclModule},*{#FunDef},*CommonDefs,*PredefinedSymbols,*VarHeap,*SymbolTable) addTypeFunctions mod_ident nr_cached_dcls dcl_modules icl_functions icl_common predefs var_heap symbols - # (ctTypeDefSymb, predefs) = getCTTypeDefSymb predefs + # (ctTypeDefSymb, predefs) = getListTypeSymb predefs # (dcl_modules, var_heap, symbols) = add_dcl_type_fun_types ctTypeDefSymb nr_cached_dcls dcl_modules var_heap symbols # (icl_type_fun_range, icl_functions, icl_common, var_heap, symbols) @@ -132,39 +135,14 @@ addTypeFunctions mod_ident nr_cached_dcls dcl_modules icl_functions icl_common p # (nr_of_functions, icl_functions) = usize icl_functions = (icl_type_fun_range, dcl_modules, icl_functions, icl_common, predefs, var_heap, symbols) -getSymbol :: Index ((Global Index) -> SymbKind) *PredefinedSymbols -> (SymbIdent, !*PredefinedSymbols) -getSymbol index symb_kind predef_symbols - # ({pds_module, pds_def}, predef_symbols) = predef_symbols![index] - # pds_ident = predefined_idents.[index] - symbol = { symb_ident = pds_ident, symb_kind = symb_kind { glob_module = pds_module, glob_object = pds_def} } - = (symbol, predef_symbols) - -predefFunction :: Index *PredefinedSymbols -> (SymbIdent, !*PredefinedSymbols) -predefFunction cons_index predefs - = getSymbol cons_index SK_Function predefs - -predefConstructor :: Index *PredefinedSymbols -> (SymbIdent, !*PredefinedSymbols) -predefConstructor cons_index predefs - = getSymbol cons_index SK_Constructor predefs - -predefRecordConstructor :: Index {#CommonDefs} *PredefinedSymbols -> (SymbIdent, !*PredefinedSymbols) -predefRecordConstructor record_type_index common_defs predefs - # ({pds_module=pds_module1, pds_def=pds_def1}, predefs) - = predefs![record_type_index] - # {td_rhs=RecordType {rt_constructor,rt_fields}} = common_defs.[pds_module1].com_type_defs.[pds_def1] - # record_cons_symb_ident - = { SymbIdent | - symb_ident = rt_constructor.ds_ident - , symb_kind = SK_Constructor {glob_module = pds_module1, glob_object = rt_constructor.ds_index} - } - = (record_cons_symb_ident, predefs) - :: BuildTypeFunState = !{ bs_predefs :: !.PredefinedSymbols - , bs_type_heaps :: .TypeHeaps - , bs_var_heap :: .VarHeap + , bs_type_heaps :: !.TypeHeaps + , bs_var_heap :: !.VarHeap } +:: Info = { ri_main :: !Int, ri_common_defs :: !{#CommonDefs} } + buildTypeFunctions :: !Int !*{#FunDef} !{#CommonDefs} *PredefinedSymbols *VarHeap *TypeHeaps -> (*{#FunDef}, *PredefinedSymbols, *VarHeap, *TypeHeaps) @@ -181,11 +159,7 @@ buildTypeFunctions main icl_functions common_defs predefs var_heap type_heaps where build i n type_defs functions bs_state | i < n - # info = - { ri_main = main - , ri_common_defs = common_defs - , ri_type_var_num = 0 - } + # info = {ri_main = main, ri_common_defs = common_defs} # (functions, bs_state) = buildTypeFunction type_defs.[i] functions info bs_state = build (i+1) n type_defs functions bs_state @@ -197,45 +171,17 @@ buildTypeFunction type_def=:{td_fun_index, td_args} functions info bs_state | td_fun_index == NoIndex = (functions, bs_state) // otherwise - # (rhs, bs_state) - = numberTypeVarsBeforeRiefy td_args (reify type_def) info bs_state # (new_info_ptr, bs_var_heap) = newPtr VI_Empty bs_state.bs_var_heap - # bs_state = {bs_state & bs_var_heap=bs_var_heap} - # var_id = {id_name = "_x", id_info = nilPtr} - lhs_free_var = {fv_def_level = NotALevel, fv_ident = var_id, fv_info_ptr = new_info_ptr, fv_count = 0} + bs_state & bs_var_heap=bs_var_heap + var_id = {id_name = "_x", id_info = nilPtr} + # (symb_Nil, bs_predefs) = getNilSymb bs_state.bs_predefs + bs_state & bs_predefs = bs_predefs + rhs = App {app_symb = symb_Nil, app_args = [], app_info_ptr = nilPtr} + # lhs_free_var = {fv_def_level = NotALevel, fv_ident = var_id, fv_info_ptr = new_info_ptr, fv_count = 0} # body = {tb_args = [lhs_free_var], tb_rhs = rhs} # functions = {functions & [td_fun_index].fun_body=TransformedBody body} = (functions, bs_state) -numberTypeVarsBeforeRiefy :: a Riefier Info *BuildTypeFunState - -> (Expression, *BuildTypeFunState) | numberTypeVars a -numberTypeVarsBeforeRiefy vars riefier info bs_state - # bs_type_heaps - = bs_state.bs_type_heaps - # (ri_type_var_num, th_vars) - = numberTypeVars vars (info.ri_type_var_num, bs_type_heaps.th_vars) - # bs_type_heaps - = {bs_type_heaps & th_vars = th_vars} - # bs_state - = {bs_state & bs_type_heaps = bs_type_heaps} - # (expr, bs_state) - = riefier {info & ri_type_var_num=ri_type_var_num} bs_state - = (expr, bs_state) - -class numberTypeVars a :: a (!Int, !*TypeVarHeap) -> (!Int, !*TypeVarHeap) - -instance numberTypeVars [a] | numberTypeVars a where - numberTypeVars l h - = foldSt numberTypeVars l h - -instance numberTypeVars ATypeVar where - numberTypeVars {atv_variable} h - = numberTypeVars atv_variable h - -instance numberTypeVars TypeVar where - numberTypeVars {tv_info_ptr} (n, h) - = (n+1, writePtr tv_info_ptr (TVI_Reify n) h) - addTypeFunctionsA :: Ident Int TypeSymbIdent *{#CheckedTypeDef} *VarHeap *SymbolTable -> ([a], *{#CheckedTypeDef}, *VarHeap, *SymbolTable) | makeTypeFun a addTypeFunctionsA mod first_td_fun_index ct_type_def type_defs var_heap symbol_table @@ -277,12 +223,10 @@ addTypeFunctionsA mod first_td_fun_index ct_type_def type_defs var_heap symbol_t } # (fun_ident, symbol_table) = newPtr entry symbol_table - # type_fun_ident = {id_name=typeFunName td_ident, id_info=fun_ident} + # type_fun_ident = {id_name="TD;"+++td_ident, id_info=fun_ident} - # ident = predefined_idents.[PD_CTTypeDef] - # type_symb = ct_type_def + # result_type = TA ct_type_def [{at_attribute = TA_None, at_type = TB BT_Bool}] - # result_type = TA ct_type_def [] # symbol_type = { st_vars = [] , st_args = [{at_attribute= TA_None, at_type = TB BT_Bool}] @@ -296,291 +240,6 @@ addTypeFunctionsA mod first_td_fun_index ct_type_def type_defs var_heap symbol_t = makeTypeFun type_fun_ident td_pos symbol_type var_heap symbol_table -:: ExpressionM :== BMonad Expression -:: BMonad a :== *BuildTypeFunState -> *(a, *BuildTypeFunState) - -apply :: Expression Expression -> Expression -apply (App app=:{app_args}) a - = App {app & app_args = app_args ++ [a]} -apply f a - = f @ [a] - -lift symb - = return (App {app_symb = symb, app_args = [], app_info_ptr = nilPtr}) - -cons :: Index Info *BuildTypeFunState - -> *(Expression, *BuildTypeFunState) -cons cons_index info bs=:{bs_predefs} - # (symbol, bs_predefs) - = getSymbol cons_index SK_Constructor bs_predefs - = lift symbol {bs & bs_predefs=bs_predefs} - -record :: Index Info *BuildTypeFunState - -> *(Expression, *BuildTypeFunState) -record type_index info=:{ri_common_defs} bs=:{bs_predefs} - # (symbol, bs_predefs) - = predefRecordConstructor type_index ri_common_defs bs_predefs - = lift symbol {bs & bs_predefs=bs_predefs} - -quote :: {#Char} -> {#Char} -quote string - = "\"" +++ string +++ "\"" - -(o`) infixr 9 -(o`) f g info x :== g info (f info x) - -function :: Index Info *BuildTypeFunState - -> *(Expression, *BuildTypeFunState) -function fun_index info bs=:{bs_predefs} - # (symbol, bs_predefs) - = getSymbol fun_index SK_Function bs_predefs - = lift symbol {bs & bs_predefs=bs_predefs} - -(`) infixl 9 -(`) f a info state - # (rf, state) - = f info state - # (ra, state) - = reify a info state - = (apply rf ra, state) - -:: Info = - { ri_main :: !Int - , ri_common_defs :: !{#CommonDefs} - , ri_type_var_num :: !Int - } - -:: Riefier :== Info -> BMonad Expression -class reify a :: a -> Riefier - -instance reify [a] | reify a where - reify [] - = cons PD_NilSymbol - reify [h:t] - = cons PD_ConsSymbol ` h ` t - -instance reify Int where - reify int - = basic (BVInt int) - -instance reify Bool where - reify bool - = basic (BVB bool) - -instance reify {#Char} where - reify string - = basic (BVS string) - -instance reify CheckedTypeDef where - reify {td_ident, td_arity, td_attribute, td_rhs} - = record PD_CTTypeDef ` quote td_ident.id_name ` td_arity ` is_unq_attribute td_attribute ` td_rhs - where - is_unq_attribute (TA_Var _) - = False - is_unq_attribute TA_Unique - = True - -instance reify TypeRhs where - reify (AlgType constructors) - = cons PD_CTAlgType ` get constructors - where - get constructors info=:{ri_main, ri_common_defs} state - = reify [(ds_index,common_defs.[ds_index]) \\ {ds_index} <- constructors] info state - where - common_defs - = ri_common_defs.[ri_main].com_cons_defs - reify (RecordType record_type) - = reify record_type - reify (SynType _) - = cons PD_CTSynType - -instance reify (Int, ConsDef) where - reify (cons_index, {cons_ident, cons_type, cons_exi_vars}) - = numberTypeVarsBeforeRiefy cons_exi_vars - (record PD_CTConsDef - ` (function PD__CTToCons ` consSymbol cons_ident cons_index) - ` cons_type.st_args ` length cons_exi_vars) - where - consSymbol cons_ident cons_index info=:{ri_main} state - # cons_symb = - { symb_ident = cons_ident - , symb_kind = SK_Constructor { glob_module = ri_main, glob_object = cons_index} - } - = reify cons_symb info state - -instance reify RecordType where - reify {rt_fields} // +++ constructor ??? +++ is_boxed - = cons PD_CTRecordType ` [field \\ field <-: rt_fields] - -instance reify FieldSymbol where - reify {fs_index} - = selector fs_index - where - selector fs_index info=:{ri_main,ri_common_defs} st - = (numberTypeVarsBeforeRiefy vars - (record PD_CTFieldDef - ` quote def.sd_ident.id_name - ` length (def.sd_exi_vars) - ` def.sd_type.st_result)) - info st - where - def - = ri_common_defs.[ri_main].com_selector_defs.[fs_index] - vars - = [atv_variable \\ {atv_variable} <- def.sd_exi_vars] - ++ def.sd_type.st_vars - -instance reify AType where - reify {at_type} - = reify at_type - -instance reify Riefier where - reify x - = x - -instance reify Type where - reify type=:(TA symb args) - = reifyApp symb args - reify type=:(TAS symb args _) - = reifyApp symb args - reify (TV var) - = reify var - reify (TQV var) - = reify var - reify (a :@: args) - = foldl` reifyApply (reify a) args - reify TArrow - = cons PD_Dyn_TypeCons ` function PD_Dyn_TypeCodeConstructor_Arrow - reify (TArrow1 a) - = cons PD_Dyn_TypeApp ` - (cons PD_Dyn_TypeCons ` function PD_Dyn_TypeCodeConstructor_Arrow) ` a - reify (a --> b) - = cons PD_Dyn_TypeApp ` (cons PD_Dyn_TypeApp ` - (cons PD_Dyn_TypeCons ` function PD_Dyn_TypeCodeConstructor_Arrow) ` a) ` b - reify (TB basic_type) - = reify basic_type - reify (TFA vars type) - = numberTypeVarsBeforeRiefy vars (reify type) - -reifyApp :: TypeSymbIdent [AType] Info *BuildTypeFunState - -> (Expression, *BuildTypeFunState) -reifyApp symb args info=:{ri_common_defs} bs_state=:{bs_type_heaps} - # (expanded, expanded_type, bs_type_heaps) - = expandTypeSynonym ri_common_defs symb args bs_type_heaps - # bs_state - = {bs_state & bs_type_heaps=bs_type_heaps} - | expanded - = reify expanded_type info bs_state - // otherwise - = foldl` reifyApply (reify symb) args info bs_state - -foldl` op r l = foldl r l // crashes if it's a macro - where - foldl r [] = r - foldl r [a:x] = foldl (op r a) x - -reifyApply a h - = cons PD_Dyn_TypeApp ` a ` h - -instance reify ConsVariable where - reify (CV var) - = reify var - -instance reify TypeVar where - reify {tv_info_ptr, tv_ident} - = cons PD_Dyn_TypeVar ` typeVarNum tv_info_ptr - where - typeVarNum tv_info_ptr info bs=:{bs_type_heaps} - # (tv_info, th_vars) - = readPtr tv_info_ptr bs_type_heaps.th_vars - # tv_num - = case tv_info of - TVI_Reify tv_num - -> tv_num - _ - -> abort "typeVar" // <<- (tv_ident.id_name, tv_info) - # bs_type_heaps - = {bs_type_heaps & th_vars = th_vars} - = reify tv_num info {bs & bs_type_heaps = bs_type_heaps} - -instance reify BasicType where - reify (BT_String string_type) - = reify string_type - reify basic_type - = cons PD_Dyn_TypeCons ` function (predef basic_type) - where - predef BT_Int - = PD_Dyn_TypeCodeConstructorInt - predef BT_Char - = PD_Dyn_TypeCodeConstructorChar - predef BT_Real - = PD_Dyn_TypeCodeConstructorReal - predef BT_Bool - = PD_Dyn_TypeCodeConstructorBool - predef BT_Dynamic - = PD_Dyn_TypeCodeConstructorDynamic - predef BT_File - = PD_Dyn_TypeCodeConstructorFile - predef BT_World - = PD_Dyn_TypeCodeConstructorWorld - -instance reify SymbIdent where - reify symb - = reify {app_symb = symb, app_args = [], app_info_ptr = nilPtr} - -instance reify TypeSymbIdent where - reify symb - = cons PD_Dyn_TypeCons ` reifyTypeIdent symb - where - reifyTypeIdent {type_index} info=:{ri_common_defs} st - = reify (toTypeCodeConstructor type_index ri_common_defs) info st - -instance reify GlobalTCType where - reify (GTT_PredefTypeConstructor {glob_object=type_index}) - | PD_Arity2TupleTypeIndex <= type_index && type_index <= PD_Arity32TupleTypeIndex - # arity - = type_index - PD_Arity2TupleTypeIndex + 2 - = function PD_Dyn_TypeCodeConstructor_Tuple ` arity - // otherwise - # predef_type_index - = type_index + FirstTypePredefinedSymbolIndex - = function (predefinedTypeConstructor predef_type_index) - reify (GTT_Constructor type_fun) - = function PD_Dyn__to_TypeCodeConstructor ` type_fun - -predefinedTypeConstructor predef_type_index - | predef_type_index == PD_ListType - = PD_Dyn_TypeCodeConstructor_List - | predef_type_index == PD_StrictListType - = PD_Dyn_TypeCodeConstructor_StrictList - | predef_type_index == PD_UnboxedListType - = PD_Dyn_TypeCodeConstructor_UnboxedList - | predef_type_index == PD_TailStrictListType - = PD_Dyn_TypeCodeConstructor_TailStrictList - | predef_type_index == PD_StrictTailStrictListType - = PD_Dyn_TypeCodeConstructor_StrictTailStrictList - | predef_type_index == PD_UnboxedTailStrictListType - = PD_Dyn_TypeCodeConstructor_UnboxedTailStrictList - | predef_type_index == PD_LazyArrayType - = PD_Dyn_TypeCodeConstructor_LazyArray - | predef_type_index == PD_StrictArrayType - = PD_Dyn_TypeCodeConstructor_StrictArray - | predef_type_index == PD_UnboxedArrayType - = PD_Dyn_TypeCodeConstructor_UnboxedArray - // otherwise - = fatal "predefinedType" "TC code from predef" - -instance reify App where - reify app - = reify (App app) - -instance reify Expression where - reify expr - = \x -> return expr - -basic :: BasicValue -> Riefier -basic value - = \x -> return (BasicExpr value) // copied and adopted from overloading toTypeCodeConstructor type=:{glob_object=type_index, glob_module=module_index} common_defs @@ -618,51 +277,3 @@ expandTypeSynonym defs cons_id type_args type_heaps -> (True, expanded_type, type_heaps) _ -> (False, undef, type_heaps) - -sanityCheckTypeFunctions :: !Int !CommonDefs !{#DclModule} !{#FunDef} - -> Bool -sanityCheckTypeFunctions main_dcl icl_common dcl_mods fun_defs - = checkType {def.fun_ident.id_name \\ def <-: fun_defs} icl_common - && all checkDcl [dcl \\ dcl <-: dcl_mods] - && compareTypes icl_common dcl_mods.[main_dcl].dcl_common - where - checkDcl :: DclModule -> Bool - checkDcl {dcl_functions, dcl_common} - = checkType {f.ft_ident.id_name \\ f <-: dcl_functions} dcl_common - -class checkType a :: {{#Char}} a -> Bool - -instance checkType CommonDefs where - checkType names {com_type_defs} - = checkType names com_type_defs - -instance checkType (a e) | Array a e & checkType e where - checkType names a - = all (checkType names) [e \\ e <-: a] - -instance checkType (TypeDef a) where - checkType names {td_ident, td_fun_index} - | td_fun_index == NoIndex - = True - | names.[td_fun_index] == typeFunName td_ident - = True - // otherwise - = False // ->> (names.[td_fun_index], "<>", typeFunName td_ident) - -class compareTypes a :: a a -> Bool - -instance compareTypes CommonDefs where - compareTypes a b - = compareTypes a.com_type_defs b.com_type_defs - -instance compareTypes (a e) | Array a e & compareTypes e where - compareTypes a b - = and [compareTypes ea eb \\ ea <-: a & eb <-: b] - -instance compareTypes (TypeDef a) where - compareTypes a b - | a.td_fun_index == b.td_fun_index - = True - // otherwise - = False // ->> (a.td_ident.id_name, a.td_fun_index, "<>", - // b.td_ident.id_name, b.td_fun_index) |