Skip to content

GitLab

Commit 581859e3 authored by Ronny Wichers Schreur's avatar Ronny Wichers Schreur 🏘
Browse files

print forall typevars in backend

parent 74d8d79e
Hide whitespace changes
Inline Side-by-side
backend/backend.dcl
View file @ 581859e3
......@@ -67,22 +67,20 @@ BEBoolSymbol :: !Bool !BackEnd -> (!BESymbolP,!BackEnd);
// BESymbolP BEBoolSymbol (int value);
BELiteralSymbol :: !BESymbKind !String !BackEnd -> (!BESymbolP,!BackEnd);
// BESymbolP BELiteralSymbol (BESymbKind kind,CleanString value);
BEPredefineListConstructorSymbol :: !Int !Int !BESymbKind !Int !Int !BackEnd -> BackEnd;
// void BEPredefineListConstructorSymbol(int constructorIndex,int moduleIndex,BESymbKind symbolKind,int head_strictnes,int tail_stricness);
// void BEPredefineListConstructorSymbol (int constructorIndex,int moduleIndex,BESymbKind symbolKind,int head_strictness,int tail_strictness);
BEPredefineListTypeSymbol :: !Int !Int !BESymbKind !Int !Int !BackEnd -> BackEnd;
// void BEPredefineListTypeSymbol(int typeIndex,int moduleIndex,BESymbKind symbolKind,int head_strictnes,int tail_stricness);
// void BEPredefineListTypeSymbol (int typeIndex,int moduleIndex,BESymbKind symbolKind,int head_strictness,int tail_strictness);
BEAdjustStrictListConsInstance :: !Int !Int !BackEnd -> BackEnd;
// void BEAdjustStrictListConsInstance(int functionIndex,int moduleIndex);
// void BEAdjustStrictListConsInstance (int functionIndex,int moduleIndex);
BEAdjustUnboxedListDeconsInstance :: !Int !Int !BackEnd -> BackEnd;
// void BEAdjustUnboxedListDeconsInstance(int functionIndex,int moduleIndex);
// void BEAdjustUnboxedListDeconsInstance (int functionIndex,int moduleIndex);
BEAdjustOverloadedNilFunction :: !Int !Int !BackEnd -> BackEnd;
// void BEAdjustOverloadedNilFunction(int functionIndex,int moduleIndex);
// void BEAdjustOverloadedNilFunction (int functionIndex,int moduleIndex);
BEOverloadedConsSymbol :: !Int !Int !Int !Int !BackEnd -> (!BESymbolP,!BackEnd);
// BESymbolP BEOverloadedConsSymbol (int constructorIndex,int moduleIndex,int deconsIndex,int deconsModuleIndex);
BEOverloadedPushNode :: !Int !BESymbolP !BEArgP !BENodeIdListP !BENodeP !BackEnd -> (!BENodeP,!BackEnd);
// BENodeP BEOverloadedPushNode (int arity,BESymbolP symbol,BEArgP arguments,BENodeIdListP nodeIds,BENodeP decons_node);
BEPredefineConstructorSymbol :: !Int !Int !Int !BESymbKind !BackEnd -> BackEnd;
// void BEPredefineConstructorSymbol (int arity,int constructorIndex,int moduleIndex,BESymbKind symbolKind);
BEPredefineTypeSymbol :: !Int !Int !Int !BESymbKind !BackEnd -> BackEnd;
......@@ -91,14 +89,18 @@ BEBasicSymbol :: !Int !BackEnd -> (!BESymbolP,!BackEnd);
// BESymbolP BEBasicSymbol (BESymbKind kind);
BEVarTypeNode :: !String !BackEnd -> (!BETypeNodeP,!BackEnd);
// BETypeNodeP BEVarTypeNode (CleanString name);
BETypeVars :: !BETypeVarP !BETypeVarListP !BackEnd -> (!BETypeVarListP,!BackEnd);
// BETypeVarListP BETypeVars (BETypeVarP typeVar,BETypeVarListP typeVarList);
BETypeVarListElem :: !BETypeVarP !BEAttribution !BackEnd -> (!BETypeVarListP,!BackEnd);
// BETypeVarListP BETypeVarListElem (BETypeVarP typeVar,BEAttribution attribute);
BETypeVars :: !BETypeVarListP !BETypeVarListP !BackEnd -> (!BETypeVarListP,!BackEnd);
// BETypeVarListP BETypeVars (BETypeVarListP typeVarListElem,BETypeVarListP typeVarList);
BENoTypeVars :: !BackEnd -> (!BETypeVarListP,!BackEnd);
// BETypeVarListP BENoTypeVars ();
BENormalTypeNode :: !BESymbolP !BETypeArgP !BackEnd -> (!BETypeNodeP,!BackEnd);
// BETypeNodeP BENormalTypeNode (BESymbolP symbol,BETypeArgP args);
BEAnnotateTypeNode :: !BEAnnotation !BETypeNodeP !BackEnd -> (!BETypeNodeP,!BackEnd);
// BETypeNodeP BEAnnotateTypeNode (BEAnnotation annotation,BETypeNodeP typeNode);
BEAddForAllTypeVariables :: !BETypeVarListP !BETypeNodeP !BackEnd -> (!BETypeNodeP,!BackEnd);
// BETypeNodeP BEAddForAllTypeVariables (BETypeVarListP vars,BETypeNodeP type);
BEAttributeTypeNode :: !BEAttribution !BETypeNodeP !BackEnd -> (!BETypeNodeP,!BackEnd);
// BETypeNodeP BEAttributeTypeNode (BEAttribution attribution,BETypeNodeP typeNode);
BEAttributeKind :: !BEAttribution !BackEnd -> (!BEAttributeKindList,!BackEnd);
......
backend/backend.icl
View file @ 581859e3
......@@ -128,36 +128,35 @@ BELiteralSymbol a0 a1 a2 = code {
};
// BESymbolP BELiteralSymbol (BESymbKind kind,CleanString value);
BEPredefineListConstructorSymbol :: !Int !Int !BESymbKind !Int !Int !BackEnd -> BackEnd;
BEPredefineListConstructorSymbol a0 a1 a2 a3 a4 a5 = code {
ccall BEPredefineListConstructorSymbol "IIIII:V:I"
};
// void BEPredefineListConstructorSymbol(int constructorIndex,int moduleIndex,BESymbKind symbolKind,int head_strictnes,int tail_stricness);
// void BEPredefineListConstructorSymbol (int constructorIndex,int moduleIndex,BESymbKind symbolKind,int head_strictness,int tail_strictness);
BEPredefineListTypeSymbol :: !Int !Int !BESymbKind !Int !Int !BackEnd -> BackEnd;
BEPredefineListTypeSymbol a0 a1 a2 a3 a4 a5 = code {
ccall BEPredefineListTypeSymbol "IIIII:V:I"
};
// void BEPredefineListTypeSymbol(int typeIndex,int moduleIndex,BESymbKind symbolKind,int head_strictnes,int tail_stricness);
// void BEPredefineListTypeSymbol (int typeIndex,int moduleIndex,BESymbKind symbolKind,int head_strictness,int tail_strictness);
BEAdjustStrictListConsInstance :: !Int !Int !BackEnd -> BackEnd;
BEAdjustStrictListConsInstance a0 a1 a2 = code {
ccall BEAdjustStrictListConsInstance "II:V:I"
};
// void BEAdjustStrictListConsInstance(int functionIndex,int moduleIndex);
// void BEAdjustStrictListConsInstance (int functionIndex,int moduleIndex);
BEAdjustUnboxedListDeconsInstance :: !Int !Int !BackEnd -> BackEnd;
BEAdjustUnboxedListDeconsInstance a0 a1 a2 = code {
ccall BEAdjustUnboxedListDeconsInstance "II:V:I"
};
// void BEAdjustUnboxedListDeconsInstance(int functionIndex,int moduleIndex);
// void BEAdjustUnboxedListDeconsInstance (int functionIndex,int moduleIndex);
BEAdjustOverloadedNilFunction :: !Int !Int !BackEnd -> BackEnd;
BEAdjustOverloadedNilFunction a0 a1 a2 = code {
ccall BEAdjustOverloadedNilFunction "II:V:I"
};
// void BEAdjustOverloadedNilFunction(int functionIndex,int moduleIndex);
// void BEAdjustOverloadedNilFunction (int functionIndex,int moduleIndex);
BEOverloadedConsSymbol :: !Int !Int !Int !Int !BackEnd -> (!BESymbolP,!BackEnd);
BEOverloadedConsSymbol a0 a1 a2 a3 a4 = code {
......@@ -171,7 +170,6 @@ BEOverloadedPushNode a0 a1 a2 a3 a4 a5 = code {
};
// BENodeP BEOverloadedPushNode (int arity,BESymbolP symbol,BEArgP arguments,BENodeIdListP nodeIds,BENodeP decons_node);
BEPredefineConstructorSymbol :: !Int !Int !Int !BESymbKind !BackEnd -> BackEnd;
BEPredefineConstructorSymbol a0 a1 a2 a3 a4 = code {
ccall BEPredefineConstructorSymbol "IIII:V:I"
......@@ -196,11 +194,17 @@ BEVarTypeNode a0 a1 = code {
};
// BETypeNodeP BEVarTypeNode (CleanString name);
BETypeVars :: !BETypeVarP !BETypeVarListP !BackEnd -> (!BETypeVarListP,!BackEnd);
BETypeVarListElem :: !BETypeVarP !BEAttribution !BackEnd -> (!BETypeVarListP,!BackEnd);
BETypeVarListElem a0 a1 a2 = code {
ccall BETypeVarListElem "II:I:I"
};
// BETypeVarListP BETypeVarListElem (BETypeVarP typeVar,BEAttribution attribute);
BETypeVars :: !BETypeVarListP !BETypeVarListP !BackEnd -> (!BETypeVarListP,!BackEnd);
BETypeVars a0 a1 a2 = code {
ccall BETypeVars "II:I:I"
};
// BETypeVarListP BETypeVars (BETypeVarP typeVar,BETypeVarListP typeVarList);
// BETypeVarListP BETypeVars (BETypeVarListP typeVarListElem,BETypeVarListP typeVarList);
BENoTypeVars :: !BackEnd -> (!BETypeVarListP,!BackEnd);
BENoTypeVars a0 = code {
......@@ -220,6 +224,12 @@ BEAnnotateTypeNode a0 a1 a2 = code {
};
// BETypeNodeP BEAnnotateTypeNode (BEAnnotation annotation,BETypeNodeP typeNode);
BEAddForAllTypeVariables :: !BETypeVarListP !BETypeNodeP !BackEnd -> (!BETypeNodeP,!BackEnd);
BEAddForAllTypeVariables a0 a1 a2 = code {
ccall BEAddForAllTypeVariables "II:I:I"
};
// BETypeNodeP BEAddForAllTypeVariables (BETypeVarListP vars,BETypeNodeP type);
BEAttributeTypeNode :: !BEAttribution !BETypeNodeP !BackEnd -> (!BETypeNodeP,!BackEnd);
BEAttributeTypeNode a0 a1 a2 = code {
ccall BEAttributeTypeNode "II:I:I"
......
backend/backendconvert.icl
View file @ 581859e3
implementation module backendconvert
import code from library "backend_library"
import compilerSwitches
import StdEnv
......@@ -8,7 +9,7 @@ import frontend
import backend
import backendsupport, backendpreprocess
//import RWSDebug
import RWSDebug
// trace macro
(-*->) infixl
......@@ -229,6 +230,8 @@ beUpdateNode
:== beFunction1 BEUpdateNode
beNormalTypeNode
:== beFunction2 BENormalTypeNode
beAddForAllTypeVariables
:== beFunction2 BEAddForAllTypeVariables
beVarTypeNode name
:== beFunction0 (BEVarTypeNode name)
beRuleAlt lineNumber
......@@ -313,6 +316,8 @@ beTypeVars
:== beFunction2 BETypeVars
beTypeVar name
:== beFunction0 (BETypeVar name)
beTypeVarListElem
:== beFunction2 BETypeVarListElem
beExportType dclTypeIndex iclTypeIndex
:== beApFunction0 (BEExportType dclTypeIndex iclTypeIndex)
beExportConstructor dclConstructorIndex iclConstructorIndex
......@@ -895,9 +900,9 @@ convertTypeVars :: [ATypeVar] -> BEMonad BETypeVarListP
convertTypeVars typeVars
= sfoldr (beTypeVars o convertTypeVar) beNoTypeVars typeVars
convertTypeVar :: ATypeVar -> BEMonad BETypeVarP
convertTypeVar :: ATypeVar -> BEMonad BETypeVarListP
convertTypeVar typeVar
= beTypeVar typeVar.atv_variable.tv_name.id_name
= beTypeVarListElem (beTypeVar typeVar.atv_variable.tv_name.id_name) (convertAttribution typeVar.atv_attribute)
defineType :: ModuleIndex {#ConsDef} {#SelectorDef} Index CheckedTypeDef *BackEndState -> *BackEndState
defineType moduleIndex constructors _ typeIndex {td_name, td_args, td_rhs=AlgType constructorSymbols} be
......@@ -1434,7 +1439,7 @@ convertAttribution TA_Anonymous
convertAttribution (TA_Var attrVar)
= convertAttributeVar attrVar
convertAttribution (TA_RootVar attrVar)
= convertAttributeVar attrVar
= PA_BUG (return BENoUniAttr) (convertAttributeVar attrVar)
convertAttribution TA_MultiOfPropagatingConsVar
= return BENoUniAttr
// FIXME
......@@ -1482,8 +1487,10 @@ convertTypeNode (a :@: b)
= beNormalTypeNode (beBasicSymbol BEApplySymb) (convertTypeArgs [{at_attribute=TA_Multi, at_annotation=AN_None, at_type = consVariableToType a} : b])
convertTypeNode TE
= beNormalTypeNode beDontCareDefinitionSymbol beNoTypeArgs
convertTypeNode (TFA vars type)
= beAddForAllTypeVariables (convertTypeVars vars) (convertTypeNode type)
convertTypeNode typeNode
= abort "convertTypeNode" // <<- ("backendconvert, convertTypeNode: unknown type node", typeNode)
= abort "convertTypeNode" <<- ("backendconvert, convertTypeNode: unknown type node", typeNode)
consVariableToType :: ConsVariable -> Type
consVariableToType (CV typeVar)
......
backendC/CleanCompilerSources/backend.c
View file @ 581859e3
......@@ -1334,6 +1334,7 @@ BEVarTypeNode (CleanString name)
node->type_node_arity = 0;
node->type_node_annotation = NoAnnot;
node->type_node_attribute = NoUniAttr;
node->type_for_all_vars = NULL;
return (node);
} /* BEVarTypeNode */
......@@ -1351,6 +1352,7 @@ BENormalTypeNode (BESymbolP symbol, BETypeArgP args)
node->type_node_attribute = NoUniAttr;
node->type_node_symbol = symbol;
node->type_node_arguments = args;
node->type_for_all_vars = NULL;
return (node);
} /* BENormalTypeNode */
......@@ -1431,6 +1433,15 @@ BEAnnotateTypeNode (BEAnnotation annotation, BETypeNodeP typeNode)
return (typeNode);
} /* BEAnnotateTypeNode */
BETypeNodeP
BEAddForAllTypeVariables (BETypeVarListP vars, BETypeNodeP type)
{
Assert (type->type_for_all_vars == NULL);
type->type_for_all_vars = vars;
return (type);
} /* BEAddForAllTypeVariables */
BETypeArgP
BENoTypeArgs (void)
{
......@@ -2647,12 +2658,23 @@ BETypeVar (CleanString name)
} /* BETypeVar */
BETypeVarListP
BETypeVars (BETypeVarP typeVar, BETypeVarListP typeVarList)
BETypeVarListElem (BETypeVarP typeVar, BEAttribution attribute)
{
TypeVarList typeVarListElement;
typeVarListElement = ConvertAllocType (struct type_var_list);
typeVarListElement->tvl_elem = typeVar;
typeVarListElement->tvl_elem = typeVar;
typeVarListElement->tvl_attribute = attribute;
typeVarListElement->tvl_next = NULL;
return (typeVarListElement);
} /* BETypeVarListElem */
BETypeVarListP
BETypeVars (BETypeVarListP typeVarListElement, BETypeVarListP typeVarList)
{
Assert (typeVarListElement->tvl_next == NULL);
typeVarListElement->tvl_next = typeVarList;
return (typeVarListElement);
......
backendC/CleanCompilerSources/backend.h
View file @ 581859e3
......@@ -244,8 +244,11 @@ Clean (BEBasicSymbol :: Int BackEnd -> (BESymbolP, BackEnd))
BETypeNodeP BEVarTypeNode (CleanString name);
Clean (BEVarTypeNode :: String BackEnd -> (BETypeNodeP, BackEnd))
BETypeVarListP BETypeVars (BETypeVarP typeVar, BETypeVarListP typeVarList);
Clean (BETypeVars :: BETypeVarP BETypeVarListP BackEnd -> (BETypeVarListP, BackEnd))
BETypeVarListP BETypeVarListElem (BETypeVarP typeVar, BEAttribution attribute);
Clean (BETypeVarListElem :: BETypeVarP BEAttribution BackEnd -> (BETypeVarListP, BackEnd))
BETypeVarListP BETypeVars (BETypeVarListP typeVarListElem, BETypeVarListP typeVarList);
Clean (BETypeVars :: BETypeVarListP BETypeVarListP BackEnd -> (BETypeVarListP, BackEnd))
BETypeVarListP BENoTypeVars (void);
Clean (BENoTypeVars :: BackEnd -> (BETypeVarListP, BackEnd))
......@@ -256,6 +259,9 @@ Clean (BENormalTypeNode :: BESymbolP BETypeArgP BackEnd -> (BETypeNodeP, BackEnd
BETypeNodeP BEAnnotateTypeNode (BEAnnotation annotation, BETypeNodeP typeNode);
Clean (BEAnnotateTypeNode :: BEAnnotation BETypeNodeP BackEnd -> (BETypeNodeP, BackEnd))
BETypeNodeP BEAddForAllTypeVariables (BETypeVarListP vars, BETypeNodeP type);
Clean (BEAddForAllTypeVariables :: BETypeVarListP BETypeNodeP BackEnd -> (BETypeNodeP, BackEnd))
BETypeNodeP BEAttributeTypeNode (BEAttribution attribution, BETypeNodeP typeNode);
Clean (BEAttributeTypeNode :: BEAttribution BETypeNodeP BackEnd -> (BETypeNodeP, BackEnd))
......
backendC/CleanCompilerSources/syntax_tree_types.h
View file @ 581859e3
......@@ -401,6 +401,9 @@ struct type_node
short type_node_arity;
Annotation type_node_annotation;
unsigned char type_node_is_var:1;
# ifdef CLEAN2
TypeVarList type_for_all_vars;
# endif
};
#define type_node_symbol type_node_contents.contents_symbol
......
backendC/CleanCompilerSources/typeconv_2.c
View file @ 581859e3
......@@ -429,6 +429,28 @@ static void PrintArguments (TypeArgs args, char separator, Bool brackets, Bool s
} /* PrintArguments */
#ifdef CLEAN2
static void PrintTypeVarList (TypeVarList type_vars)
{
for (; type_vars != NULL; type_vars = type_vars -> tvl_next)
{
/* RWS:
Printing the attributes currently works because the attributes for
universally quantified type variables can only be none, '*' or '.'.
For attribute variables something should probably done with the
CurrentARC_Info administration, but I don't understand how this works.
*/
if (type_vars -> tvl_attribute != NoUniAttr)
PrintAttribute (type_vars -> tvl_attribute, cDoPrintColon);
FPutS (type_vars -> tvl_elem -> tv_ident -> ident_name, StdListTypes);
if (type_vars -> tvl_next != NULL)
FPutC (' ', StdListTypes);
}
}
#endif
static void PrintNode (TypeNode node, Bool brackets, Bool strict_context, Bool print_annot)
{
......@@ -449,6 +471,14 @@ static void PrintNode (TypeNode node, Bool brackets, Bool strict_context, Bool p
(node -> type_node_symbol -> symb_kind == fun_type || node -> type_node_symbol -> symb_kind == apply_symb))
brackets = True;
}
#ifdef CLEAN2
if (node -> type_for_all_vars != NULL)
{ FPutS ("(A.", StdListTypes);
PrintTypeVarList (node -> type_for_all_vars);
FPutC (':', StdListTypes);
brackets = False;
}
#endif
switch (node -> type_node_symbol -> symb_kind)
{
case tuple_type:
......@@ -546,6 +576,10 @@ static void PrintNode (TypeNode node, Bool brackets, Bool strict_context, Bool p
break;
}
#ifdef CLEAN2
if (node -> type_for_all_vars != NULL)
FPutC (')', StdListTypes);
#endif
} /* PrintNode */
static void PrintAttributeEquations (UniVarEquations attr_equas)
......
backendC/backend.link
View file @ 581859e3
......@@ -13,14 +13,23 @@
/EXPORT: BEDontCareDefinitionSymbol
/EXPORT: BEBoolSymbol
/EXPORT: BELiteralSymbol
/EXPORT: BEPredefineListConstructorSymbol
/EXPORT: BEPredefineListTypeSymbol
/EXPORT: BEAdjustStrictListConsInstance
/EXPORT: BEAdjustUnboxedListDeconsInstance
/EXPORT: BEAdjustOverloadedNilFunction
/EXPORT: BEOverloadedConsSymbol
/EXPORT: BEOverloadedPushNode
/EXPORT: BEPredefineConstructorSymbol
/EXPORT: BEPredefineTypeSymbol
/EXPORT: BEBasicSymbol
/EXPORT: BEVarTypeNode
/EXPORT: BETypeVarListElem
/EXPORT: BETypeVars
/EXPORT: BENoTypeVars
/EXPORT: BENormalTypeNode
/EXPORT: BEAnnotateTypeNode
/EXPORT: BEAddForAllTypeVariables
/EXPORT: BEAttributeTypeNode
/EXPORT: BEAttributeKind
/EXPORT: BENoAttributeKinds
......@@ -110,10 +119,3 @@
/EXPORT: BESetMainDclModuleN
/EXPORT: BEDeclareDynamicTypeSymbol
/EXPORT: BEDynamicTempTypeSymbol
/EXPORT: BEPredefineListTypeSymbol
/EXPORT: BEPredefineListConstructorSymbol
/EXPORT: BEAdjustStrictListConsInstance
/EXPORT: BEAdjustUnboxedListDeconsInstance
/EXPORT: BEAdjustOverloadedNilFunction
/EXPORT: BEOverloadedConsSymbol
/EXPORT: BEOverloadedPushNode
backendC/backend.rc
View file @ 581859e3
......@@ -14,7 +14,7 @@
# define kFileFlags VS_FF_DEBUG | VS_FF_PRERELEASE
# define kFileFlagsMask VS_FF_DEBUG | VS_FF_PRERELEASE
# define kFileVersionString "2.0.d.8"
# define kFileVersionString "2.0.d.9"
VS_VERSION_INFO VERSIONINFO
FILEVERSION kFileVersion
......@@ -37,7 +37,7 @@ BEGIN
VALUE "LegalTrademarks", "\0"
VALUE "OriginalFilename","backend.dll\0"
VALUE "ProductName", "Clean System"
VALUE "ProductVersion", "2.0.d.8"
VALUE "ProductVersion", "2.0.d.9"
VALUE "OLESelfRegister", "\0"
END
......
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