Skip to content
GitLab
Commit 06045efd authored by John van Groningen's avatar John van Groningen
Browse files

No commit message 

No commit message
parent b3a50c1f
Hide whitespace changes
Inline Side-by-side
backend/backendconvert.icl
View file @ 06045efd
......@@ -4,7 +4,6 @@
implementation module backendconvert
import code from library "backend_library"
import compilerSwitches
import StdEnv
// import StdDebug
......@@ -476,8 +475,7 @@ backEndConvertModulesH predefs {fe_icl =
= currentDcl.dcl_common
# backEnd
= foldSt beExportFunction exported_local_type_funs backEnd
with
with
exported_local_type_funs
| False && currentDcl.dcl_module_kind == MK_None
= []
......@@ -1078,19 +1076,6 @@ where
# backend = appBackEnd (BEAdjustUnboxedListDeconsInstance (index+1) main_dcl_module_n) backend
= adjustRecordListInstances indices backend
types_to_string []
= ""
types_to_string [e:l]
= type_to_string e+++" "+++types_to_string l
type_to_string (TB BT_Int) = "Int"
type_to_string (TB BT_Char) = "Char"
type_to_string (TB BT_Real) = "Real"
type_to_string (TB BT_Bool) = "Bool"
type_to_string (TB BT_File) = "File"
type_to_string _ = "?"
:: AdjustStdArrayInfo =
{ asai_moduleIndex :: !Int
, asai_mapping :: !{#BEArrayFunKind}
......@@ -1407,6 +1392,8 @@ convertTypeNode TE
= beNormalTypeNode beDontCareDefinitionSymbol beNoTypeArgs
convertTypeNode (TFA vars type)
= beAddForAllTypeVariables (convertTypeVars vars) (convertTypeNode type)
convertTypeNode (TGenericFunctionInDictionary gds type_kind generic_dict=:{gi_module,gi_index})
= beNormalTypeNode (beTypeSymbol gi_index gi_module) beNoTypeArgs
convertTypeNode typeNode
= abort "convertTypeNode" // <<- ("backendconvert, convertTypeNode: unknown type node", typeNode)
......@@ -1810,9 +1797,6 @@ where
convertExpr (Conditional {if_cond=cond, if_then, if_else=Yes else})
= beIfNode (convertExpr cond) (convertExpr if_then) (convertExpr else)
convertExpr expr
= undef // <<- ("backendconvert, convertExpr: unknown expression" , expr)
convertArgs :: [Expression] -> BEMonad BEArgP
convertArgs exprs
= sfoldr (beArgs o convertExpr) beNoArgs exprs
......
frontend/checktypes.icl
View file @ 06045efd
implementation module checktypes
import StdEnv
import syntax, checksupport, check, typesupport, utilities,
compilerSwitches // , RWSDebug
import syntax, checksupport, check, typesupport, utilities
import genericsupport
from explicitimports import search_qualified_ident,::NameSpaceN,TypeNameSpaceN,ClassNameSpaceN
......@@ -88,7 +87,7 @@ where
STE_BoundTypeVariable bv=:{stv_attribute, stv_info_ptr}
-> ({ tv & tv_info_ptr = stv_info_ptr}, stv_attribute, (ts, ti, cs))
_
-> (tv, TA_Multi, (ts, ti, { cs & cs_error = checkError var_id "undefined" cs.cs_error }))
-> (tv, TA_Multi, (ts, ti, {cs & cs_error = checkError var_id "type variable undefined" cs.cs_error}))
instance bindTypes [a] | bindTypes a
where
......@@ -189,7 +188,7 @@ where
# (type_vars, (_, ti_type_heaps, cs)) = addTypeVariablesToSymbolTable cRankTwoScope vars [] ti_type_heaps cs
(type, _, (ts, ti, cs)) = bindTypes cti type (ts, {ti & ti_type_heaps = ti_type_heaps}, cs)
cs_symbol_table = removeAttributedTypeVarsFromSymbolTable cRankTwoScope type_vars cs.cs_symbol_table
= (TFA type_vars type, TA_Multi, (ts, ti, { cs & cs_symbol_table = cs_symbol_table }))
= (TFA type_vars type, TA_Multi, (ts, ti, {cs & cs_symbol_table = cs_symbol_table}))
bindTypes cti=:{cti_module_index,cti_type_index,cti_lhs_attribute} type=:(TQualifiedIdent module_id type_name types)
(ts=:{ts_type_defs,ts_modules}, ti, cs)
# (found,{decl_kind,decl_ident=type_ident,decl_index=type_index},cs) = search_qualified_ident module_id type_name TypeNameSpaceN cs
......@@ -257,8 +256,6 @@ addToAttributeEnviron (TA_RootVar attr_var) root_attr attr_env error
addToAttributeEnviron _ _ attr_env error
= (attr_env, checkError "inconsistent attribution of type definition" "" error)
emptyIdent name :== { id_name = name, id_info = nilPtr }
checkTypeDef :: !Index !Index !*TypeSymbols !*TypeInfo !*CheckState -> (!*TypeSymbols, !*TypeInfo, !*CheckState);
......@@ -288,10 +285,8 @@ where
determine_root_attribute TA_Unique name attr_var_heap
= (TA_Unique, [], attr_var_heap)
//
check_rhs_of_TypeDef :: !CheckedTypeDef ![AttributeVar] !CurrentTypeInfo !(!*TypeSymbols, !*TypeInfo, !*CheckState)
-> (!TypeRhs, !(!*TypeSymbols, !*TypeInfo, !*CheckState))
//
check_rhs_of_TypeDef {td_ident,td_arity,td_args,td_rhs = td_rhs=:AlgType conses} 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)
......@@ -602,8 +597,7 @@ where
-> (TA_Multi, oti, { cs & cs_error = checkError var_ident "inconsistently attributed (5)" cs.cs_error })
check_var_attribute var_attr new_attr oti cs
= (var_attr, oti, { cs & cs_error = checkError var_ident "inconsistently attributed (6)" cs.cs_error })// ---> (var_attr, new_attr)
determine_attribute var_ident DAK_Unique new_attr error
= case new_attr of
TA_Multi
......@@ -618,7 +612,6 @@ where
= (TA_Multi, error)
determine_attribute var_ident dem_attr new_attr error
= (new_attr, error)
check_attribute var_ident dem_attr _ this_attr oti cs
= (TA_Multi, oti, cs)
......@@ -1597,17 +1590,19 @@ where
# ({class_ident, class_arity, class_dictionary = {ds_ident, ds_index}}, _, class_defs, modules) = getClassDef ds_index glob_module mod_index class_defs modules
type_symb = MakeTypeSymbIdent { glob_object = ds_index, glob_module = glob_module } ds_ident class_arity
field_type = makeAttributedType TA_Multi (TA type_symb [makeAttributedType TA_Multi TE \\ i <- [1..class_arity]])
(field, var_heap, symbol_table) = build_field field_nr class_ident.id_name rec_type_index rec_type field_type next_selector_index var_heap symbol_table
= build_context_fields mod_index (inc field_nr) tcs rec_type rec_type_index (inc next_selector_index) [ field : rev_fields ]
(field, var_heap, symbol_table)
= build_field field_nr class_ident.id_name rec_type_index rec_type field_type next_selector_index var_heap symbol_table
= build_context_fields mod_index (inc field_nr) tcs rec_type rec_type_index (inc next_selector_index) [field : rev_fields]
[field_type : rev_field_types] class_defs modules var_heap symbol_table
build_context_fields mod_index field_nr [{tc_class = TCGeneric {gtc_generic, gtc_kind}} :tcs] rec_type rec_type_index
build_context_fields mod_index field_nr [{tc_class = TCGeneric {gtc_generic,gtc_kind,gtc_generic_dict}} :tcs] rec_type rec_type_index
next_selector_index rev_fields rev_field_types class_defs modules var_heap symbol_table
// FIXME: We do not know the type before the generic phase.
// The generic phase currently does not update the type.
# field_type = makeAttributedType TA_Multi TE
# field_type = {at_attribute = TA_Multi, at_type = TGenericFunctionInDictionary gtc_generic gtc_kind gtc_generic_dict}
# class_ident = genericIdentToClassIdent gtc_generic.glob_object.ds_ident.id_name gtc_kind
# (field, var_heap, symbol_table) = build_field field_nr class_ident.id_name rec_type_index rec_type field_type next_selector_index var_heap symbol_table
= build_context_fields mod_index (inc field_nr) tcs rec_type rec_type_index (inc next_selector_index) [ field : rev_fields ]
# (field, var_heap, symbol_table)
= build_field field_nr class_ident.id_name rec_type_index rec_type field_type next_selector_index var_heap symbol_table
= build_context_fields mod_index (inc field_nr) tcs rec_type rec_type_index (inc next_selector_index) [field : rev_fields]
[field_type : rev_field_types] class_defs modules var_heap symbol_table
build_context_fields mod_index field_nr [] rec_type rec_type_index next_selector_index rev_fields rev_field_types class_defs modules var_heap symbol_table
= (next_selector_index, rev_fields, rev_field_types , class_defs, modules, var_heap, symbol_table)
......@@ -1617,7 +1612,7 @@ where
(sd_type_ptr, var_heap) = newPtr VI_Empty var_heap
field_id = { id_name = field_name, id_info = id_info }
sel_def =
{ sd_ident = field_id
{ sd_ident = field_id
, sd_field = field_id
, sd_type = { st_vars = [], st_args = [ rec_type ], st_args_strictness=Strict 1, st_result = field_type, st_arity = 1,
st_context = [], st_attr_vars = [], st_attr_env = [] }
......
frontend/convertDynamics.dcl
View file @ 06045efd
......@@ -9,5 +9,7 @@ from transform import ::Group
:: TypeCodeVariableInfo
:: DynamicValueAliasInfo
convertDynamicPatternsIntoUnifyAppls :: !{# CommonDefs} !Int !*{! Group} !*{#FunDef} !*PredefinedSymbols !*VarHeap !*TypeHeaps !*ExpressionHeap (Optional *File) {# DclModule} !IclModule /* TD */ [String]
-> (!*{!Group}, !*{#FunDef}, !*PredefinedSymbols, !*{#{#CheckedTypeDef}}, !*VarHeap, !*TypeHeaps, !*ExpressionHeap, !Optional *File)
convertDynamicPatternsIntoUnifyAppls :: !{# CommonDefs} !Int {#DclModule} !IclModule [String] !Int !Int
!*{!Group} !*{#FunDef} !*PredefinedSymbols !*VarHeap !*TypeHeaps !*ExpressionHeap !(Optional *File)
-> (!*{#{#CheckedTypeDef}},
!*{!Group},!*{#FunDef},!*PredefinedSymbols,!*VarHeap,!*TypeHeaps,!*ExpressionHeap,!(Optional *File))
frontend/convertDynamics.icl
View file @ 06045efd
......@@ -43,8 +43,9 @@ fatal :: {#Char} {#Char} -> .a
fatal function_name message
= abort ("convertDynamics, " +++ function_name +++ ": " +++ message)
write_tcl_file main_dcl_module_n dcl_mods=:{[main_dcl_module_n] = main_dcl_module} icl_common_defs tcl_file directly_imported_dcl_modules type_heaps
predefined_symbols imported_types var_heap common_defs icl_mod
write_tcl_file main_dcl_module_n dcl_mods=:{[main_dcl_module_n] = main_dcl_module} directly_imported_dcl_modules common_defs icl_common
n_types_with_type_functions n_constructors_with_type_functions
tcl_file type_heaps predefined_symbols imported_types var_heap
# write_type_info_state2
= { WriteTypeInfoState |
wtis_n_type_vars = 0
......@@ -53,10 +54,11 @@ write_tcl_file main_dcl_module_n dcl_mods=:{[main_dcl_module_n] = main_dcl_modul
, wtis_type_heaps = type_heaps
, wtis_var_heap = var_heap
, wtis_main_dcl_module_n = main_dcl_module_n
, wtis_icl_generic_defs = icl_common.com_generic_defs
};
#! (tcl_file,write_type_info_state)
= write_type_info icl_common_defs tcl_file write_type_info_state2
= write_type_info_of_types_and_constructors icl_common n_types_with_type_functions n_constructors_with_type_functions tcl_file write_type_info_state2
#! (tcl_file,write_type_info_state)
= write_type_info directly_imported_dcl_modules tcl_file write_type_info_state
......@@ -80,9 +82,13 @@ where
f write_type_info_state=:{wtis_type_heaps,wtis_type_defs,wtis_var_heap}
= (wtis_type_heaps,wtis_type_defs,wtis_var_heap)
convertDynamicPatternsIntoUnifyAppls :: !{# CommonDefs} !Int !*{! Group} !*{#FunDef} !*PredefinedSymbols !*VarHeap !*TypeHeaps !*ExpressionHeap (Optional *File) {# DclModule} !IclModule [String]
-> (!*{!Group}, !*{#FunDef}, !*PredefinedSymbols, !*{#{#CheckedTypeDef}}, !*VarHeap, !*TypeHeaps, !*ExpressionHeap, !Optional *File)
convertDynamicPatternsIntoUnifyAppls common_defs main_dcl_module_n groups fun_defs predefined_symbols var_heap type_heaps expr_heap tcl_file dcl_mods icl_mod directly_imported_dcl_modules
convertDynamicPatternsIntoUnifyAppls :: !{# CommonDefs} !Int {#DclModule} !IclModule [String] !Int !Int
!*{!Group} !*{#FunDef} !*PredefinedSymbols !*VarHeap !*TypeHeaps !*ExpressionHeap !(Optional *File)
-> (!*{#{#CheckedTypeDef}},
!*{!Group},!*{#FunDef},!*PredefinedSymbols,!*VarHeap,!*TypeHeaps,!*ExpressionHeap,!(Optional *File))
convertDynamicPatternsIntoUnifyAppls common_defs main_dcl_module_n dcl_mods icl_mod directly_imported_dcl_modules
n_types_with_type_functions n_constructors_with_type_functions
groups fun_defs predefined_symbols var_heap type_heaps expr_heap tcl_file
#! (dynamic_representation,predefined_symbols)
= create_dynamic_and_selector_idents common_defs predefined_symbols
......@@ -102,13 +108,14 @@ convertDynamicPatternsIntoUnifyAppls common_defs main_dcl_module_n groups fun_de
-> (No,type_heaps,ci_predef_symb,imported_types,ci_var_heap)
Yes tcl_file
# (ok,tcl_file,type_heaps,ci_predef_symb,imported_types,ci_var_heap)
= write_tcl_file main_dcl_module_n dcl_mods icl_mod.icl_common tcl_file directly_imported_dcl_modules type_heaps ci_predef_symb
imported_types ci_var_heap common_defs icl_mod
= write_tcl_file main_dcl_module_n dcl_mods directly_imported_dcl_modules common_defs icl_mod.icl_common
n_types_with_type_functions n_constructors_with_type_functions
tcl_file type_heaps ci_predef_symb imported_types ci_var_heap
| not ok
-> abort "convertDynamicPatternsIntoUnifyAppls: error writing tcl file"
-> (Yes tcl_file,type_heaps,ci_predef_symb,imported_types,ci_var_heap)
= (groups, fun_defs, ci_predef_symb, imported_types, ci_var_heap, type_heaps, ci_expr_heap, tcl_file)
= (imported_types, groups, fun_defs, ci_predef_symb, ci_var_heap, type_heaps, ci_expr_heap, tcl_file)
where
convert_groups group_nr groups dynamic_representation fun_defs_and_ci
| group_nr == size groups
......
frontend/frontend.icl
View file @ 06045efd
......@@ -6,9 +6,6 @@ implementation module frontend
import scanner, parse, postparse, check, type, trans, convertcases, overloading, utilities, convertDynamics,
convertimportedtypes, compilerSwitches, analtypes, generics1,
typereify
//import coredump
//import print
// trace macro
(-*->) infixl
......@@ -28,8 +25,6 @@ frontSyntaxTree cached_dcl_macros cached_dcl_mods main_dcl_module_n predef_symbo
},cached_dcl_macros,cached_dcl_mods,main_dcl_module_n,predef_symbols,hash_table,files,error,io,out,tcl_file,heaps
)
// import StdDebug
frontEndInterface :: !FrontEndOptions !Ident !SearchPaths !{#DclModule} !*{#*{#FunDef}} !(Optional Bool) !*PredefinedSymbols !*HashTable (ModTimeFunction *Files) !*Files !*File !*File !*File !(Optional *File) !*Heaps
-> ( !Optional *FrontEndSyntaxTree,!*{#*{#FunDef}},!{#DclModule},!Int,!*PredefinedSymbols, !*HashTable, !*Files, !*File, !*File, !*File, !Optional *File, !*Heaps)
frontEndInterface options mod_ident search_paths cached_dcl_modules cached_dcl_macros list_inferred_types predef_symbols hash_table modtimefunction files error io out tcl_file heaps
......@@ -108,19 +103,21 @@ frontEndInterface options mod_ident search_paths cached_dcl_modules cached_dcl_m
= 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
# (fun_defs, predef_symbols, hp_var_heap, type_heaps)
= if support_dynamics
(buildTypeFunctions main_dcl_module_n fun_defs ti_common_defs
predef_symbols hp_var_heap type_heaps)
(fun_defs, predef_symbols, hp_var_heap, type_heaps)
# (td_infos, th_vars, error_admin) = analyseTypeDefs ti_common_defs type_groups com_type_defs main_dcl_module_n td_infos type_heaps.th_vars error_admin
= if support_dynamics
(buildTypeFunctions main_dcl_module_n fun_defs ti_common_defs predef_symbols hp_var_heap type_heaps)
(fun_defs, predef_symbols, hp_var_heap, type_heaps)
# (td_infos, th_vars, error_admin)
= analyseTypeDefs ti_common_defs type_groups com_type_defs main_dcl_module_n td_infos type_heaps.th_vars error_admin
# (class_infos, td_infos, th_vars, error_admin)
= determineKindsOfClasses icl_used_module_numbers ti_common_defs td_infos th_vars error_admin
= determineKindsOfClasses icl_used_module_numbers ti_common_defs td_infos th_vars error_admin
# icl_global_functions=icl_function_indices.ifi_global_function_indices
# (fun_defs, dcl_mods, td_infos, th_vars, hp_expression_heap, gen_heap, error_admin)
= checkKindsOfCommonDefsAndFunctions n_cached_dcl_modules main_dcl_module_n icl_used_module_numbers
= checkKindsOfCommonDefsAndFunctions n_cached_dcl_modules main_dcl_module_n icl_used_module_numbers
(icl_global_functions++[icl_function_indices.ifi_local_function_indices])
ti_common_defs fun_defs dcl_mods td_infos class_infos th_vars heaps.hp_expression_heap heaps.hp_generic_heap error_admin
......@@ -173,8 +170,8 @@ frontEndInterface options mod_ident search_paths cached_dcl_modules cached_dcl_m
# icl_function_indices = {icl_function_indices & ifi_gencase_indices = icl_gencase_indices }
# (fun_def_size, fun_defs) = usize fun_defs
# (components, fun_defs) = partitionateFunctions (fun_defs -*-> "partitionateFunctions")
(icl_global_functions++icl_function_indices.ifi_instance_indices
# (components, fun_defs)
= partitionateFunctions fun_defs (icl_global_functions++icl_function_indices.ifi_instance_indices
++[icl_function_indices.ifi_specials_indices
: icl_gencase_indices++icl_function_indices.ifi_type_function_indices])
......@@ -182,9 +179,10 @@ frontEndInterface options mod_ident search_paths cached_dcl_modules cached_dcl_m
= frontSyntaxTree cached_dcl_macros cached_dcl_mods main_dcl_module_n
predef_symbols hash_table files error io out tcl_file icl_mod dcl_mods fun_defs components array_instances heaps
# (components, fun_defs, predef_symbols, dcl_types, var_heap, type_heaps, expression_heap, tcl_file)
= convertDynamicPatternsIntoUnifyAppls common_defs main_dcl_module_n (components -*-> "convertDynamics") fun_defs predef_symbols
heaps.hp_var_heap heaps.hp_type_heaps heaps.hp_expression_heap tcl_file dcl_mods icl_mod directly_imported_dcl_modules
# (dcl_types, components, fun_defs, predef_symbols, var_heap, type_heaps, expression_heap, tcl_file)
= convertDynamicPatternsIntoUnifyAppls common_defs main_dcl_module_n dcl_mods icl_mod directly_imported_dcl_modules
n_types_with_type_functions n_constructors_with_type_functions
components fun_defs predef_symbols heaps.hp_var_heap heaps.hp_type_heaps heaps.hp_expression_heap tcl_file
| options.feo_up_to_phase == FrontEndPhaseConvertDynamics
# heaps = {hp_var_heap=var_heap, hp_type_heaps=type_heaps, hp_expression_heap=expression_heap, hp_generic_heap=newHeap}
......@@ -243,8 +241,8 @@ frontEndInterface options mod_ident search_paths cached_dcl_modules cached_dcl_m
= frontSyntaxTree cached_dcl_macros cached_dcl_mods main_dcl_module_n
predef_symbols hash_table files error io out tcl_file icl_mod dcl_mods fun_defs components array_instances heaps
# (dcl_types, used_conses, var_heap, type_heaps) = convertIclModule main_dcl_module_n common_defs (dcl_types -*-> "Convert icl") used_conses var_heap type_heaps
# (dcl_types, used_conses, var_heap, type_heaps) = convertDclModule main_dcl_module_n dcl_mods common_defs (dcl_types -*-> "Convert dcl") used_conses var_heap type_heaps
# (dcl_types, used_conses, var_heap, type_heaps) = convertIclModule main_dcl_module_n common_defs dcl_types used_conses var_heap type_heaps
# (dcl_types, used_conses, var_heap, type_heaps) = convertDclModule main_dcl_module_n dcl_mods common_defs dcl_types used_conses var_heap type_heaps
// (components, fun_defs, out) = showComponents components 0 False fun_defs out
......
frontend/generics1.icl
View file @ 06045efd
......@@ -650,7 +650,7 @@ buildTypeDefInfo1 td_module {td_ident, td_pos, td_arity} alts fields main_module
# (type_def_dsc_fun, heaps) = build_type_def_dsc group_index cons_dsc_dss type_def_dsc_ds heaps
# (cons_dsc_funs, (modules, heaps)) = zipWithSt (build_cons_dsc group_index type_def_dsc_ds field_dsc_dss) cons_dsc_dss alts (modules, heaps)
# (cons_dsc_funs, (modules, heaps)) = zipWithSt (build_cons_dsc group_index type_def_dsc_ds field_dsc_dss) cons_dsc_dss alts (modules, heaps)
# (field_dsc_funs, (modules, heaps)) = zipWithSt (build_field_dsc group_index (hd cons_dsc_dss)) field_dsc_dss fields (modules, heaps)
......@@ -1413,7 +1413,7 @@ where
{ gtc_generic=glob_def_sym
, gtc_kind = kind
, gtc_class = {glob_module=NoIndex,glob_object={ds_ident=makeIdent "<no generic class>", ds_index=NoIndex, ds_arity=1}}
, gtc_dictionary = {glob_module=NoIndex,glob_object={ds_ident=makeIdent "<no generic dictionary>", ds_index=NoIndex, ds_arity=1}}
, gtc_generic_dict = {gi_module=NoIndex, gi_index=NoIndex}
}
=({tc_class = tc_class, tc_types = [TV tv], tc_var = var_info_ptr}, gs_varh)
......@@ -2190,25 +2190,15 @@ where
, ds_index = class_info.gci_class
}
}
/*
AA HACK: dummy dictionary
*/
#! {pds_module, pds_def} = gs_predefs.[PD_TypeGenericDict]
#! pds_ident = predefined_idents.[PD_TypeGenericDict]
# dictionary =
{ glob_module = pds_module
, glob_object={ds_ident=pds_ident, ds_arity=1, ds_index=pds_def}
}
-> (TCGeneric {gtc & gtc_class=clazz, gtc_dictionary=dictionary}, error)
// AA HACK: dummy dictionary
#! {pds_module,pds_def} = gs_predefs.[PD_TypeGenericDict]
# generic_dict = {gi_module=pds_module, gi_index=pds_def}
-> (TCGeneric {gtc & gtc_class=clazz, gtc_generic_dict=generic_dict}, error)
= (True, {tc & tc_class=tc_class}, (modules, {heaps & hp_generic_heap=hp_generic_heap}, error))
convert_context fun_name fun_pos tc st
= (False, tc, st)
//****************************************************************************************
// specialization
//****************************************************************************************
specializeGeneric ::
!GlobalIndex // generic index
......
frontend/genericsupport.dcl
View file @ 06045efd
......@@ -50,3 +50,4 @@ postfixIdent :: !String !String -> Ident
genericIdentToClassIdent :: !String !TypeKind -> Ident
genericIdentToMemberIdent :: !String !TypeKind -> Ident
genericIdentToFunIdent :: !String !TypeCons -> Ident
kind_to_short_string :: !TypeKind -> {#Char}
frontend/genericsupport.icl
View file @ 06045efd
......@@ -51,7 +51,6 @@ getGenericClass gen kind modules generic_heap
#! class_glob = {glob_module = gci_module, glob_object = gci_class}
-> (Yes class_glob, generic_heap)
lookupGenericClassInfo :: !TypeKind !GenericClassInfos -> (Optional GenericClassInfo)
lookupGenericClassInfo kind class_infos
#! hash_index = case kind of
......@@ -84,14 +83,15 @@ postfixIdent id_name postfix = makeIdent (id_name +++ postfix)
genericIdentToClassIdent :: !String !TypeKind -> Ident
genericIdentToClassIdent id_name kind
= postfixIdent id_name ("_" +++ kind_to_str kind)
= postfixIdent id_name ("_" +++ kind_to_short_string kind)
kind_to_short_string :: !TypeKind -> {#Char}
kind_to_short_string KindConst = "s"
kind_to_short_string (KindArrow kinds) = kinds_to_str kinds +++ "s"
where
kind_to_str KindConst = "s"
kind_to_str (KindArrow kinds)
= kinds_to_str kinds +++ "s"
kinds_to_str [] = ""
kinds_to_str [KindConst:ks] = "s" +++ kinds_to_str ks
kinds_to_str [k:ks] = "o" +++ (kind_to_str k) +++ "c" +++ kinds_to_str ks
kinds_to_str [k:ks] = "o" +++ (kind_to_short_string k) +++ "c" +++ kinds_to_str ks
genericIdentToMemberIdent :: !String !TypeKind -> Ident
genericIdentToMemberIdent id_name kind
......
frontend/parse.icl
View file @ 06045efd
......@@ -1444,10 +1444,10 @@ where
# class_global_ds = { glob_object = MakeDefinedSymbol {id_name="<no class>",id_info=nilPtr} NoIndex 1, glob_module = NoIndex}
# gen_type_context =
{ gtc_generic = { glob_object = MakeDefinedSymbol ident NoIndex 1, glob_module = NoIndex }
{ gtc_generic = {glob_object = MakeDefinedSymbol ident NoIndex 1, glob_module = NoIndex}
, gtc_kind = kind
, gtc_class = { glob_object = MakeDefinedSymbol {id_name="<no class>",id_info=nilPtr} NoIndex 1, glob_module = NoIndex}
, gtc_dictionary = { glob_object = MakeDefinedSymbol {id_name="<no generic dictionary>",id_info=nilPtr} NoIndex 1, glob_module = NoIndex}
, gtc_class = {glob_object = MakeDefinedSymbol {id_name="<no class>",id_info=nilPtr} NoIndex 1, glob_module = NoIndex}
, gtc_generic_dict = {gi_module = NoIndex, gi_index = NoIndex}
}
-> (True, TCGeneric gen_type_context, pState)
......@@ -1511,10 +1511,7 @@ optionalCoercions pState
, parseError "Function type: optional coercions" (Yes token) "<attribute variable>" pState
)
// AA..
/*
Generic definitions
*/
/* Generic definitions */
wantGenericDefinition :: !ParseContext !Position !ParseState -> (!ParsedDefinition, !ParseState)
wantGenericDefinition parseContext pos pState
......@@ -1608,8 +1605,6 @@ where
get_type_cons type pState
# pState = parseError "generic type" No " type constructor" pState
= (abort "no TypeCons", pState)
// ..AA
/*
Type definitions
......
frontend/syntax.dcl
View file @ 06045efd
......@@ -362,7 +362,7 @@ cNameLocationDependent :== True
:: ClassDefInfos :== {# .{! [TypeKind]}}
:: MemberDef =
{ me_ident :: !Ident
{ me_ident :: !Ident
, me_class :: !Global Index
, me_offset :: !Index
, me_type :: !SymbolType
......@@ -373,7 +373,7 @@ cNameLocationDependent :== True
}
:: GenericDef =
{ gen_ident :: !Ident // the generics name in IC_Generic
{ gen_ident :: !Ident // the generics name in IC_Generic
, gen_member_ident :: !Ident // the generics name in IC_Expression
, gen_pos :: !Position
, gen_type :: !SymbolType // Generic type (st_vars include generic type vars)
......@@ -872,7 +872,6 @@ cNonRecursiveAppl :== False
/*
OverloadedCall contains (type) information about functions that are overloaded. This structure is built during type checking
and used after (standard) unification to insert the proper instances of the corresponding functions.
*/
:: OverloadedCall =
......@@ -887,7 +886,7 @@ cNonRecursiveAppl :== False
ct_result_type : the type of the result (of each pattern)
ct_cons_types : the types of the arguments of each pattern constructor
*/
:: CaseType =
{ ct_pattern_type :: !AType
, ct_result_type :: !AType
......@@ -938,18 +937,16 @@ cNonRecursiveAppl :== False
, tc_var :: !VarInfoPtr
}
//AA: class in a type context is either normal class or a generic class
:: TCClass = TCClass !(Global DefinedSymbol) // Normal class
| TCGeneric !GenericTypeContext // Generic class
| TCQualifiedIdent !Ident !String
:: GenericTypeContext =
{ gtc_generic :: !(Global DefinedSymbol)
:: GenericTypeContext =
{ gtc_generic :: !Global DefinedSymbol
, gtc_kind :: !TypeKind
, gtc_class :: !(Global DefinedSymbol) // generated class
, gtc_dictionary:: !(Global DefinedSymbol) // HACK: dictionary different from the one contained in the class
, gtc_class :: !Global DefinedSymbol // generated class
, gtc_generic_dict :: !GlobalIndex // HACK: dictionary different from the one contained in the class
}
//..AA
:: AType =
{ at_attribute :: !TypeAttribute
......@@ -973,7 +970,6 @@ cNonRecursiveAppl :== False
| GTV !TypeVar
| TV !TypeVar
| TempV !TempVarId /* Auxiliary, used during type checking */
| TQV TypeVar
| TempQV !TempVarId /* Auxiliary, used during type checking */
......@@ -981,6 +977,8 @@ cNonRecursiveAppl :== False
| TLifted !TypeVar /* Auxiliary, used during type checking of lifted arguments */
| TQualifiedIdent !Ident !String ![AType]
| TGenericFunctionInDictionary !(Global DefinedSymbol) !TypeKind !GlobalIndex /*GenericDict*/
| TE
:: ConsVariable = CV !TypeVar
......
frontend/trans.icl
View file @ 06045efd
......@@ -3927,36 +3927,33 @@ convertSymbolTypeWithoutCollectingImportedConstructors rem_annots common_defs st
convertSymbolType_ :: !Int !{# CommonDefs} !SymbolType !Int !*ImportedTypes !ImportedConstructors !*TypeHeaps !*VarHeap
-> (!SymbolType, !Bool,!*ImportedTypes, !ImportedConstructors, !*TypeHeaps, !*VarHeap)
convertSymbolType_ rem_annots common_defs st main_dcl_module_n imported_types collected_imports type_heaps var_heap
# ets =
{ ets_type_defs = imported_types
# ets = { ets_type_defs = imported_types
, ets_collected_conses = collected_imports
, ets_type_heaps = type_heaps
, ets_var_heap = var_heap
, ets_main_dcl_module_n = main_dcl_module_n
, ets_contains_unexpanded_abs_syn_type = False
}
# {st_args,st_result,st_context,st_args_strictness}
= st
}
# {st_args,st_result,st_context,st_args_strictness} = st
#! (_,(st_args,st_result), ets) = expandSynTypes rem_annots common_defs (st_args,st_result) ets
# new_st_args = addTypesOfDictionaries common_defs st_context st_args
new_st_arity = length new_st_args
st =
{ st
st = { st
& st_args = new_st_args
, st_result = st_result
, st_arity = new_st_arity
, st_args_strictness = insert_n_strictness_values_at_beginning (new_st_arity-length st_args) st_args_strictness
, st_context = []
}
# {ets_type_defs, ets_collected_conses, ets_type_heaps, ets_var_heap,ets_contains_unexpanded_abs_syn_type}
= ets
# {ets_type_defs, ets_collected_conses, ets_type_heaps, ets_var_heap,ets_contains_unexpanded_abs_syn_type} = ets
= (st, ets_contains_unexpanded_abs_syn_type, ets_type_defs, ets_collected_conses, ets_type_heaps, ets_var_heap)
addTypesOfDictionaries :: !{#CommonDefs} ![TypeContext] ![AType] -> [AType]
addTypesOfDictionaries common_defs type_contexts type_args
= mapAppend (add_types_of_dictionary common_defs) type_contexts type_args
where
add_types_of_dictionary common_defs {tc_class = TCGeneric {gtc_dictionary={glob_module,glob_object={ds_ident,ds_index}}}, tc_types}
add_types_of_dictionary common_defs {tc_class = TCGeneric {gtc_generic_dict={gi_module,gi_index}}, tc_types}
#! generict_dict_ident = predefined_idents.[PD_TypeGenericDict]
/*
AA HACK:
Generic classes are always generated locally,
......@@ -3967,7 +3964,7 @@ where
Solution: plug a dummy dictinary type, defined in StdGeneric.
It is possible because all generic class have one class argument and one member.
*/
# dict_type_symb = MakeTypeSymbIdent {glob_object = ds_index, glob_module = glob_module} ds_ident 1
# dict_type_symb = MakeTypeSymbIdent {glob_object = gi_index, glob_module = gi_module} generict_dict_ident 1
# type_arg = {at_attribute = TA_Multi, at_type=hd tc_types}
= {at_attribute = TA_Multi, at_type = TA dict_type_symb [type_arg]}
......@@ -3979,9 +3976,7 @@ where
(dict_args,_) = mapSt (\type class_cons_vars
-> let at_attribute = if (class_cons_vars bitand 1<>0) TA_MultiOfPropagatingConsVar TA_Multi
in ({at_attribute = at_attribute, at_type = type}, class_cons_vars>>1)
)
tc_types
class_cons_vars
) tc_types class_cons_vars
= {at_attribute = TA_Multi, /* at_annotation = AN_Strict, */ at_type = TA dict_type_symb dict_args}
:: ExpandTypeState =
......
frontend/type_io.dcl
View file @ 06045efd
......@@ -8,18 +8,19 @@ import StdEnv
import trans
:: WriteTypeInfoState