Commit dcd5d94f authored by Maarten de Mol's avatar Maarten de Mol
Browse files

Added: field to CModule to indicate number of data-constructors in a...

Added: field to CModule to indicate number of data-constructors in a DCL-module, not counting dictionary-creators.
Updated: support for recognizing dictionay creators by means of temporary translation to classes.
parent 30b6d91a
......@@ -167,15 +167,20 @@ bindDefinition mb_conversions all_names all_ptrs (DclDefinitionPtr dcl_name def_
MemberDef -> cMemberDefs
ClassInstance -> cInstanceDefs
# conv_table = conv_tables.[conv_index]
| def_index >= size conv_table
// Check for record-constructors belonging to dictionaries; temporarily replace these by class pointers
| def_kind == ConsDef
# nr_conses = size conv_table
= bindDefinition (Just conversions) all_names all_ptrs (DclDefinitionPtr dcl_name def_name ClassDef (def_index-nr_conses)) heaps
| (def_kind <> ConsDef) && (def_index >= size conv_table)
# dicts = conversions.ccDictionaries
# icl_ptr = check_dictionary def_name def_kind dicts (IclDefinitionPtr dcl_name (-2) def_name def_kind def_index)
= bindDefinition (Just conversions) all_names all_ptrs icl_ptr heaps
# def_index = conv_table.[def_index]
# (nr_conses, heaps) = find_nr_conses dcl_name all_names all_ptrs heaps
| (def_kind == ConsDef) && (def_index >= nr_conses)
// Constructor is a dictionary creator, which cannot be converted at this time.
// Therefore, it is replaced by the class that the dictionary belongs to and is later converted back.
# def_name = remove_last_semicolon def_name
# class_ptr = (DclDefinitionPtr dcl_name def_name ClassDef (def_index-nr_conses))
= bindDefinition (Just conversions) all_names all_ptrs class_ptr heaps
# def_index = case def_index >= size conv_table of
True -> def_index
False -> conv_table.[def_index]
= bindDefinition (Just conversions) all_names all_ptrs (IclDefinitionPtr dcl_name (-2) def_name def_kind def_index) heaps
where
check_dictionary :: !String !CompilerDefinitionKind ![(CName, IndexedPtr)] !IndexedPtr -> !IndexedPtr
......@@ -185,6 +190,25 @@ bindDefinition mb_conversions all_names all_ptrs (DclDefinitionPtr dcl_name def_
= newptr
check_dictionary defname other dicts oldptr
= oldptr
// When temporary converting dictionary_creators (conses) to classes, its index has to be adjusted by the number of real conses in the dcl.
// This number is stored in the module (and set by the function 'convertFrontEndSyntaxTree' in 'Conversion.icl'.
find_nr_conses :: !String ![ModuleName] ![ModulePtr] !*CHeaps -> (!Int, !*CHeaps)
find_nr_conses dcl_name [name:names] [ptr:ptrs] heaps
| dcl_name <> name = find_nr_conses dcl_name names ptrs heaps
# (mod, heaps) = readPointer ptr heaps
= (mod.pmOriginalNrDclConses, heaps)
find_nr_conses _ _ _ heaps
= (0, heaps)
// When temporary converting record-constructors to class pointers, the last ; has to be removed to get the proper class name.
remove_last_semicolon :: !String -> String
remove_last_semicolon name
# size_name = size name
| size_name == 0 = name
# last_char = name.[size_name - 1]
| last_char <> ';' = name
= name % (0, size name - 2)
bindDefinition mb_conversions all_names all_ptrs (IclDefinitionPtr icl_name icl_key _ CheckedTypeDef def_index) heaps
# (ok, conversions, heaps) = findConversions mb_conversions icl_name all_names all_ptrs heaps
| not ok = (pushError (X_Internal ("Rule 'bindDefinition' does not match. (unknown iclmodule " +++ icl_name +++ ")")) OK, DummyValue, heaps)
......@@ -196,6 +220,9 @@ bindDefinition mb_conversions all_names all_ptrs (IclDefinitionPtr icl_name icl_
bindDefinition mb_conversions all_names all_ptrs (IclDefinitionPtr icl_name icl_key _ ClassDef def_index) heaps
# (ok, conversions, heaps) = findConversions mb_conversions icl_name all_names all_ptrs heaps
| not ok = (pushError (X_Internal ("Rule 'bindDefinition' does not match. (unknown iclmodule " +++ icl_name +++ ")")) OK, DummyValue, heaps)
| def_index >= size conversions.ccClassPtrs = abort "HALLO! NIET DOEN!"
= (OK, conversions.ccClassPtrs.[def_index], heaps)
bindDefinition mb_conversions all_names all_ptrs (IclDefinitionPtr "_tupleselect" icl_key _ FunDef def_index) heaps
= (OK, CTupleSelectPtr icl_key def_index, heaps)
......@@ -216,6 +243,32 @@ bindDefinition mb_conversions all_names all_ptrs (IclDefinitionPtr icl_name icl_
| not ok = (pushError (X_Internal ("Rule 'bindDefinition' does not match. (unknown iclmodule " +++ icl_name +++ ")")) OK, DummyValue, heaps)
= (OK, conversions.ccSelectorPtrs.[def_index], heaps)
// -------------------------------------------------------------------------------------------------------------------------------------------------
bindDefinition2 :: !(Maybe CompilerConversion) ![ModuleName] ![ModulePtr] !IndexedPtr !*CHeaps -> (!Error, !HeapPtr, !*CHeaps)
// -------------------------------------------------------------------------------------------------------------------------------------------------
bindDefinition2 mb_conversions all_names all_ptrs ptr1 heaps
# (error, ptr2, heaps) = bindDefinition mb_conversions all_names all_ptrs ptr1 heaps
| isError error = (error, ptr2, heaps)
# kind_1 = get_kind ptr1
# kind_2 = ptrKind ptr2
= check kind_1 kind_2 error ptr1 ptr2 heaps
where
get_kind :: !IndexedPtr -> CompilerDefinitionKind
get_kind (IclDefinitionPtr _ _ _ kind _)
= kind
get_kind (DclDefinitionPtr _ _ kind _)
= kind
check :: !CompilerDefinitionKind !DefinitionKind !Error !IndexedPtr !HeapPtr !*CHeaps -> (!Error, !HeapPtr, !*CHeaps)
check CheckedTypeDef CRecordType error ptr1 ptr2 heaps
= (error, ptr2, heaps)
check kind1 CRecordType error ptr1 ptr2 heaps
// #! heaps = heaps --->> ptr1
= (error, ptr2, heaps)
check _ _ error ptr1 ptr2 heaps
= (error, ptr2, heaps)
......@@ -620,7 +673,7 @@ bindModule all_names all_ptrs mod_ptr heaps prj
bindFuns :: ![HeapPtr] ![CFunDefI] !*CHeaps !*CProject -> (!Error, !*CHeaps, !*CProject)
bindFuns [ptr:ptrs] [def:defs] heaps prj
# (error, def, heaps) = changeDefinition (bindDefinition Nothing all_names all_ptrs) def heaps
# (error, def, heaps) = changeDefinition (bindDefinition2 Nothing all_names all_ptrs) def heaps
| isError error = (error, heaps, prj)
# (error, prj) = putFunDef ptr def prj
| isError error = (error, heaps, prj)
......
......@@ -544,6 +544,7 @@ convertFrontEndSyntaxTree tree heaps mod_key mod_path cheaps prj
# (mod_ptr, cheaps) = newPointer DummyValue cheaps
# (cenv, mod_name, dcl_modules, tree, heaps) = makeConvertEnv mod_key mod_ptr tree cheaps heaps
# icl_module = tree.fe_icl
# maybe_dcl_module = find_own_dcl_module 0 (size tree.fe_dcls) mod_name tree.fe_dcls
# checked_type_defs = [def \\ def <-: icl_module.icl_common.com_type_defs]
# (error, type_ptrs, alg_defs, rec_defs, cenv, prj) = convertTypeDefs checked_type_defs cenv prj
......@@ -614,6 +615,7 @@ convertFrontEndSyntaxTree tree heaps mod_key mod_path cheaps prj
, ccConversionTable = conversion_table
, ccDclIclConversions = {} //fromOptional tree.fe_dclIclConversions
}
, pmOriginalNrDclConses = find_original_nr_dcl_conses maybe_dcl_module
}
# cheaps = writePointer mod_ptr mod cenv.cenvHeaps
= (OK, mod_ptr, heaps, cheaps, prj)
......@@ -622,6 +624,19 @@ convertFrontEndSyntaxTree tree heaps mod_key mod_path cheaps prj
fromOptional (Yes a) = a
fromOptional No = {}
find_own_dcl_module :: !Int !Int !String !{#DclModule} -> Maybe DclModule
find_own_dcl_module index nr_dcls module_name dcls
| index >= nr_dcls = Nothing
# dcl = dcls.[index]
| dcl.dcl_name.id_name == module_name = Just dcl
= find_own_dcl_module (index+1) nr_dcls module_name dcls
find_original_nr_dcl_conses :: !(Maybe DclModule) -> Int
find_original_nr_dcl_conses Nothing
= 0
find_original_nr_dcl_conses (Just dcl)
= (size dcl.dcl_common.com_cons_defs) - (size dcl.dcl_common.com_class_defs)
get_conversion_table :: !ModuleName !{#DclModule} -> ConversionTable
get_conversion_table modname dcls
# si = size dcls
......
......@@ -426,6 +426,7 @@ instance DummyValue (CMemberDef def_ptr) | DummyValue def_ptr
, pmRecordFieldPtrs :: ![HeapPtr]
, pmCompilerStore :: !Maybe CompilerStore
, pmCompilerConversion :: !CompilerConversion
, pmOriginalNrDclConses :: !Int // needed for conversion of dictionary creation conses (which are translated via classes)
}
instance DummyValue CModule
......
......@@ -507,12 +507,14 @@ instance DummyValue (CMemberDef def_ptr) | DummyValue def_ptr
, pmRecordFieldPtrs :: ![HeapPtr]
, pmCompilerStore :: !Maybe CompilerStore
, pmCompilerConversion :: !CompilerConversion
, pmOriginalNrDclConses :: !Int // needed for conversion of dictionary creation conses (which are translated via classes)
}
instance DummyValue CModule
where DummyValue = {pmName = "", pmPath = "", pmImportedModules = [], pmAlgTypePtrs = [],
pmClassPtrs = [], pmDataConsPtrs = [], pmFunPtrs = [],
pmInstancePtrs = [], pmMemberPtrs = [], pmRecordTypePtrs = [],
pmRecordFieldPtrs = [], pmCompilerStore = Nothing, pmCompilerConversion = DummyValue}
pmRecordFieldPtrs = [], pmCompilerStore = Nothing, pmCompilerConversion = DummyValue,
pmOriginalNrDclConses = 0}
// -------------------------------------------------------------------------------------------------------------------------------------------------
:: CPredefined =
......
......@@ -1108,6 +1108,7 @@ where
# name = if (isInfix inf) ("(" +++ name +++ ")") name
// | isJust fundef.fdDeltaRule = (OK, fundef.fdName +++ "", fundef.fdInfix, prj)
= (OK, name, inf, prj)
#! prj = prj --->> kind
= (pushError (X_Internal ("encountered something other than a function or data-constructor at an application")) OK, DummyValue, DummyValue, prj)
FormattedShow finfo (CLet strict bindings expr) heaps prj
# (finfo, heaps) = storeExprVars (map fst bindings) finfo heaps
......
......@@ -279,6 +279,7 @@ CPredefined
, pmRecordTypePtrs = [CTCDictPtr]
, pmCompilerStore = Nothing
, pmCompilerConversion = DummyValue
, pmOriginalNrDclConses = DummyValue
}
// -------------------------------------------------------------------------------------------------------------------------------------------------
......
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