aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--backend/Clean System Files/backend_library6
-rw-r--r--backend/backend.dcl24
-rw-r--r--backend/backend.icl52
-rw-r--r--backend/backendconvert.dcl2
-rw-r--r--backend/backendconvert.icl164
-rw-r--r--backend/backendinterface.dcl2
-rw-r--r--backend/backendinterface.icl12
-rw-r--r--backendC/CleanCompilerSources/backend.c66
-rw-r--r--backendC/CleanCompilerSources/backend.h36
-rw-r--r--backendC/CleanCompilerSources/typeconv_2.c18
-rw-r--r--backendC/backend.link6
-rw-r--r--coclmaindll/backend.dllbin1430912 -> 343692 bytes
-rw-r--r--frontend/syntax.dcl3
-rw-r--r--frontend/syntax.icl2
-rw-r--r--main/compile.icl14
15 files changed, 342 insertions, 65 deletions
diff --git a/backend/Clean System Files/backend_library b/backend/Clean System Files/backend_library
index 6f8e0c7..aa84a37 100644
--- a/backend/Clean System Files/backend_library
+++ b/backend/Clean System Files/backend_library
@@ -23,6 +23,12 @@ BENoTypeVars
BENormalTypeNode
BEAnnotateTypeNode
BEAttributeTypeNode
+BEAttributeKind
+BENoAttributeKinds
+BEAttributeKinds
+BEUniVarEquation
+BENoUniVarEquations
+BEUniVarEquationsList
BENoTypeArgs
BETypeArgs
BETypeAlt
diff --git a/backend/backend.dcl b/backend/backend.dcl
index 3ed50f3..9a398fe 100644
--- a/backend/backend.dcl
+++ b/backend/backend.dcl
@@ -29,6 +29,8 @@ from StdString import String;
:: BEStringListP;
:: BENodeIdListP;
:: BENodeIdRefCountListP;
+:: BEUniVarEquations;
+:: BEAttributeKindList;
:: BEAnnotation :== Int;
:: BEAttribution :== Int;
:: BESymbKind :== Int;
@@ -83,12 +85,24 @@ BEAnnotateTypeNode :: !BEAnnotation !BETypeNodeP !BackEnd -> (!BETypeNodeP,!Back
// BETypeNodeP BEAnnotateTypeNode (BEAnnotation annotation,BETypeNodeP typeNode);
BEAttributeTypeNode :: !BEAttribution !BETypeNodeP !BackEnd -> (!BETypeNodeP,!BackEnd);
// BETypeNodeP BEAttributeTypeNode (BEAttribution attribution,BETypeNodeP typeNode);
+BEAttributeKind :: !BEAttribution !BackEnd -> (!BEAttributeKindList,!BackEnd);
+// BEAttributeKindList BEAttributeKind (BEAttribution attributeKind);
+BENoAttributeKinds :: !BackEnd -> (!BEAttributeKindList,!BackEnd);
+// BEAttributeKindList BENoAttributeKinds ();
+BEAttributeKinds :: !BEAttributeKindList !BEAttributeKindList !BackEnd -> (!BEAttributeKindList,!BackEnd);
+// BEAttributeKindList BEAttributeKinds (BEAttributeKindList elem,BEAttributeKindList list);
+BEUniVarEquation :: !BEAttribution !BEAttributeKindList !BackEnd -> (!BEUniVarEquations,!BackEnd);
+// BEUniVarEquations BEUniVarEquation (BEAttribution demanded,BEAttributeKindList offered);
+BENoUniVarEquations :: !BackEnd -> (!BEUniVarEquations,!BackEnd);
+// BEUniVarEquations BENoUniVarEquations ();
+BEUniVarEquationsList :: !BEUniVarEquations !BEUniVarEquations !BackEnd -> (!BEUniVarEquations,!BackEnd);
+// BEUniVarEquations BEUniVarEquationsList (BEUniVarEquations elem,BEUniVarEquations list);
BENoTypeArgs :: !BackEnd -> (!BETypeArgP,!BackEnd);
// BETypeArgP BENoTypeArgs ();
BETypeArgs :: !BETypeNodeP !BETypeArgP !BackEnd -> (!BETypeArgP,!BackEnd);
// BETypeArgP BETypeArgs (BETypeNodeP node,BETypeArgP nextArgs);
-BETypeAlt :: !BETypeNodeP !BETypeNodeP !BackEnd -> (!BETypeAltP,!BackEnd);
-// BETypeAltP BETypeAlt (BETypeNodeP lhs,BETypeNodeP rhs);
+BETypeAlt :: !BETypeNodeP !BETypeNodeP !BEUniVarEquations !BackEnd -> (!BETypeAltP,!BackEnd);
+// BETypeAltP BETypeAlt (BETypeNodeP lhs,BETypeNodeP rhs,BEUniVarEquations attributeEquations);
BENormalNode :: !BESymbolP !BEArgP !BackEnd -> (!BENodeP,!BackEnd);
// BENodeP BENormalNode (BESymbolP symbol,BEArgP args);
BEMatchNode :: !Int !BESymbolP !BENodeP !BackEnd -> (!BENodeP,!BackEnd);
@@ -247,9 +261,9 @@ BEDeclareDynamicTypeSymbol :: !Int !Int !BackEnd -> BackEnd;
// void BEDeclareDynamicTypeSymbol (int typeIndex,int moduleIndex);
BEDynamicTempTypeSymbol :: !BackEnd -> (!BESymbolP,!BackEnd);
// BESymbolP BEDynamicTempTypeSymbol ();
-kBEVersionCurrent:==0x02000209;
-kBEVersionOldestDefinition:==0x02000204;
-kBEVersionOldestImplementation:==0x02000209;
+kBEVersionCurrent:==0x02000210;
+kBEVersionOldestDefinition:==0x02000210;
+kBEVersionOldestImplementation:==0x02000210;
kBEDebug:==1;
kPredefinedModuleIndex:==1;
BENoAnnot:==0;
diff --git a/backend/backend.icl b/backend/backend.icl
index 3381d4a..2331389 100644
--- a/backend/backend.icl
+++ b/backend/backend.icl
@@ -29,6 +29,8 @@ from StdString import String;
:: BEStringListP :== CPtr;
:: BENodeIdListP :== CPtr;
:: BENodeIdRefCountListP :== CPtr;
+:: BEUniVarEquations :== CPtr;
+:: BEAttributeKindList :== CPtr;
:: BEAnnotation :== Int;
:: BEAttribution :== Int;
:: BESymbKind :== Int;
@@ -180,6 +182,42 @@ BEAttributeTypeNode a0 a1 a2 = code {
};
// BETypeNodeP BEAttributeTypeNode (BEAttribution attribution,BETypeNodeP typeNode);
+BEAttributeKind :: !BEAttribution !BackEnd -> (!BEAttributeKindList,!BackEnd);
+BEAttributeKind a0 a1 = code {
+ ccall BEAttributeKind "I:I:I"
+};
+// BEAttributeKindList BEAttributeKind (BEAttribution attributeKind);
+
+BENoAttributeKinds :: !BackEnd -> (!BEAttributeKindList,!BackEnd);
+BENoAttributeKinds a0 = code {
+ ccall BENoAttributeKinds ":I:I"
+};
+// BEAttributeKindList BENoAttributeKinds ();
+
+BEAttributeKinds :: !BEAttributeKindList !BEAttributeKindList !BackEnd -> (!BEAttributeKindList,!BackEnd);
+BEAttributeKinds a0 a1 a2 = code {
+ ccall BEAttributeKinds "II:I:I"
+};
+// BEAttributeKindList BEAttributeKinds (BEAttributeKindList elem,BEAttributeKindList list);
+
+BEUniVarEquation :: !BEAttribution !BEAttributeKindList !BackEnd -> (!BEUniVarEquations,!BackEnd);
+BEUniVarEquation a0 a1 a2 = code {
+ ccall BEUniVarEquation "II:I:I"
+};
+// BEUniVarEquations BEUniVarEquation (BEAttribution demanded,BEAttributeKindList offered);
+
+BENoUniVarEquations :: !BackEnd -> (!BEUniVarEquations,!BackEnd);
+BENoUniVarEquations a0 = code {
+ ccall BENoUniVarEquations ":I:I"
+};
+// BEUniVarEquations BENoUniVarEquations ();
+
+BEUniVarEquationsList :: !BEUniVarEquations !BEUniVarEquations !BackEnd -> (!BEUniVarEquations,!BackEnd);
+BEUniVarEquationsList a0 a1 a2 = code {
+ ccall BEUniVarEquationsList "II:I:I"
+};
+// BEUniVarEquations BEUniVarEquationsList (BEUniVarEquations elem,BEUniVarEquations list);
+
BENoTypeArgs :: !BackEnd -> (!BETypeArgP,!BackEnd);
BENoTypeArgs a0 = code {
ccall BENoTypeArgs ":I:I"
@@ -192,11 +230,11 @@ BETypeArgs a0 a1 a2 = code {
};
// BETypeArgP BETypeArgs (BETypeNodeP node,BETypeArgP nextArgs);
-BETypeAlt :: !BETypeNodeP !BETypeNodeP !BackEnd -> (!BETypeAltP,!BackEnd);
-BETypeAlt a0 a1 a2 = code {
- ccall BETypeAlt "II:I:I"
+BETypeAlt :: !BETypeNodeP !BETypeNodeP !BEUniVarEquations !BackEnd -> (!BETypeAltP,!BackEnd);
+BETypeAlt a0 a1 a2 a3 = code {
+ ccall BETypeAlt "III:I:I"
};
-// BETypeAltP BETypeAlt (BETypeNodeP lhs,BETypeNodeP rhs);
+// BETypeAltP BETypeAlt (BETypeNodeP lhs,BETypeNodeP rhs,BEUniVarEquations attributeEquations);
BENormalNode :: !BESymbolP !BEArgP !BackEnd -> (!BENodeP,!BackEnd);
BENormalNode a0 a1 a2 = code {
@@ -671,9 +709,9 @@ BEDynamicTempTypeSymbol a0 = code {
ccall BEDynamicTempTypeSymbol ":I:I"
};
// BESymbolP BEDynamicTempTypeSymbol ();
-kBEVersionCurrent:==0x02000209;
-kBEVersionOldestDefinition:==0x02000204;
-kBEVersionOldestImplementation:==0x02000209;
+kBEVersionCurrent:==0x02000210;
+kBEVersionOldestDefinition:==0x02000210;
+kBEVersionOldestImplementation:==0x02000210;
kBEDebug:==1;
kPredefinedModuleIndex:==1;
BENoAnnot:==0;
diff --git a/backend/backendconvert.dcl b/backend/backendconvert.dcl
index 2edcb19..30625e7 100644
--- a/backend/backendconvert.dcl
+++ b/backend/backendconvert.dcl
@@ -3,4 +3,4 @@ definition module backendconvert
from backend import BackEnd
import frontend
-backEndConvertModules :: PredefinedSymbols FrontEndSyntaxTree !Int *VarHeap *BackEnd -> (!*VarHeap,!*BackEnd)
+backEndConvertModules :: PredefinedSymbols FrontEndSyntaxTree !Int *VarHeap *AttrVarHeap *BackEnd -> (!*VarHeap, *AttrVarHeap, !*BackEnd)
diff --git a/backend/backendconvert.icl b/backend/backendconvert.icl
index 92e77b3..b2dcb82 100644
--- a/backend/backendconvert.icl
+++ b/backend/backendconvert.icl
@@ -37,7 +37,7 @@ BackEndBody x :== BackendBody x
:: BackEnder :== *BackEndState -> *BackEndState
//
-:: *BackEndState = {bes_backEnd :: !BackEnd, bes_varHeap :: !*VarHeap}
+:: *BackEndState = {bes_backEnd :: !BackEnd, bes_varHeap :: !*VarHeap, bes_attrHeap :: !*AttrVarHeap, bes_attr_number :: !Int}
appBackEnd f beState
:== {beState & bes_backEnd = bes_backEnd}
@@ -57,6 +57,13 @@ accVarHeap f beState
where
(result, varHeap) = f beState.bes_varHeap
+accAttrHeap f beState
+ :== (result, {beState & bes_attrHeap = attrHeap})
+ where
+ (result, attrHeap) = f beState.bes_attrHeap
+
+
+read_from_var_heap :: VarInfoPtr BackEndState -> (VarInfo, BackEndState)
read_from_var_heap ptr beState
= (result, {beState & bes_varHeap = varHeap})
where
@@ -64,6 +71,14 @@ where
write_to_var_heap ptr v beState
= {beState & bes_varHeap = writePtr ptr v beState.bes_varHeap}
+
+read_from_attr_heap ptr beState
+ = (result, {beState & bes_attrHeap = attrHeap})
+where
+ (result, attrHeap) = readPtr ptr beState.bes_attrHeap
+
+write_to_attr_heap ptr v beState
+ = {beState & bes_attrHeap = writePtr ptr v beState.bes_attrHeap}
/*
read_from_var_heap ptr heap be
= (sreadPtr ptr heap,be)
@@ -219,7 +234,7 @@ beNoRuleAlts
beRuleAlts
:== beFunction2 BERuleAlts
beTypeAlt
- :== beFunction2 BETypeAlt
+ :== beFunction3 BETypeAlt
beRule index isCaf
:== beFunction2 (BERule index isCaf)
beNoRules
@@ -258,8 +273,8 @@ beField fieldIndex moduleIndex
:== beFunction1 (BEField fieldIndex moduleIndex)
beAnnotateTypeNode annotation
:== beFunction1 (BEAnnotateTypeNode annotation)
-beAttributeTypeNode attribution
- :== beFunction1 (BEAttributeTypeNode attribution)
+beAttributeTypeNode
+ :== beFunction2 BEAttributeTypeNode
beDeclareRuleType functionIndex moduleIndex name
:== beApFunction0 (BEDeclareRuleType functionIndex moduleIndex name)
beDefineRuleType functionIndex moduleIndex
@@ -324,6 +339,19 @@ beNodeIds
:== beFunction2 BENodeIds
beNodeIdListElem
:== beFunction1 BENodeIdListElem
+beAttributeKind
+ :== beFunction1 BEAttributeKind
+beNoAttributeKinds
+ :== beFunction0 BENoAttributeKinds
+beAttributeKinds
+ :== beFunction2 BEAttributeKinds
+beUniVarEquation
+ :== beFunction2 BEUniVarEquation
+beNoUniVarEquations
+ :== beFunction0 BENoUniVarEquations
+beUniVarEquationsList
+ :== beFunction2 BEUniVarEquationsList
+
// temporary hack
beDynamicTempTypeSymbol
:== beFunction0 BEDynamicTempTypeSymbol
@@ -332,17 +360,20 @@ notYetImplementedExpr :: Expression
notYetImplementedExpr
= (BasicExpr (BVS "\"error in compiler (something was not implemented by lazy Ronny)\"") BT_Int)
-backEndConvertModules :: PredefinedSymbols FrontEndSyntaxTree !Int *VarHeap *BackEnd -> (!*VarHeap,!*BackEnd)
+backEndConvertModules :: PredefinedSymbols FrontEndSyntaxTree !Int *VarHeap *AttrVarHeap *BackEnd -> (!*VarHeap, *AttrVarHeap, !*BackEnd)
/*
backEndConvertModules p s main_dcl_module_n v be
= (newHeap,backEndConvertModulesH p s v be)
*/
-backEndConvertModules p s main_dcl_module_n var_heap be
- # {bes_varHeap,bes_backEnd} = backEndConvertModulesH p s main_dcl_module_n {bes_varHeap=var_heap,bes_backEnd=be}
- = (bes_varHeap,bes_backEnd)
+backEndConvertModules p s main_dcl_module_n var_heap attr_var_heap be
+ # {bes_varHeap,bes_attrHeap,bes_backEnd} = backEndConvertModulesH p s main_dcl_module_n {bes_varHeap=var_heap,bes_attrHeap=attr_var_heap,bes_backEnd=be, bes_attr_number = 0}
+ = (bes_varHeap,bes_attrHeap,bes_backEnd)
backEndConvertModulesH :: PredefinedSymbols FrontEndSyntaxTree !Int *BackEndState -> *BackEndState
-backEndConvertModulesH predefs {fe_icl = fe_icl =: {icl_name, icl_functions, icl_common,icl_imported_objects,icl_used_module_numbers}, fe_components, fe_dcls, fe_arrayInstances, fe_dclIclConversions, fe_iclDclConversions,fe_globalFunctions} main_dcl_module_n backEnd
+backEndConvertModulesH predefs {fe_icl =
+ fe_icl =: {icl_name, icl_functions, icl_common,icl_imported_objects,icl_used_module_numbers},
+ fe_components, fe_dcls, fe_arrayInstances, fe_dclIclConversions, fe_iclDclConversions,fe_globalFunctions}
+ main_dcl_module_n backEnd
// sanity check ...
// | cIclModIndex <> kIclModuleIndex || cPredefinedModuleIndex <> kPredefinedModuleIndex
// = undef <<- "backendconvert, backEndConvertModules: module index mismatch"
@@ -437,8 +468,6 @@ backEndConvertModulesH predefs {fe_icl = fe_icl =: {icl_name, icl_functions, icl
#! backEnd = removeExpandedTypesFromDclModules fe_dcls icl_used_module_numbers backEnd
= (backEnd -*-> "backend done")
where
- componentCount
- = length functionIndices
functionIndices
= flatten [[(componentIndex, member) \\ member <- group.group_members] \\ group <-: fe_components & componentIndex <- [0..]]
@@ -484,8 +513,8 @@ declareDclModule moduleIndex {dcl_name, dcl_common, dcl_functions, dcl_module_ki
/*
defineCurrentDclModule :: IclModule DclModule {#Int} -> BackEnder
defineCurrentDclModule {icl_common} {dcl_name, dcl_common, dcl_functions, dcl_is_system, dcl_conversions} typeConversions
- = declareCurrentDclModuleTypes icl_common.com_type_defs typeConversions varHeap
- o` defineCurrentDclModuleTypes dcl_common.com_cons_defs dcl_common.com_selector_defs dcl_common.com_type_defs typeConversions varHeap
+ = declareCurrentDclModuleTypes icl_common.com_type_defs typeConversions
+ o` defineCurrentDclModuleTypes dcl_common.com_cons_defs dcl_common.com_selector_defs dcl_common.com_type_defs typeConversions
*/
defineDclModule :: ModuleIndex DclModule -> BackEnder
defineDclModule moduleIndex {dcl_name, dcl_common, dcl_functions,dcl_instances}
@@ -564,7 +593,7 @@ instance declareVars [a] | declareVars a where
= foldState (flip declareVars dvInput) list
instance declareVars (Ptr VarInfo) where
- declareVars varInfoPtr _
+ declareVars varInfoPtr _
= declareVariable BELhsNodeId varInfoPtr "_var???" // +++ name
instance declareVars FreeVar where
@@ -704,7 +733,7 @@ foldStateWithIndexRangeA function frm to array
declareArrayInstances :: IndexRange Int {#FunDef} -> BackEnder
declareArrayInstances {ir_from, ir_to} main_dcl_module_n functions
// | trace_tn ("declareArrayInstances "+++toString ir_from+++" "+++toString ir_to)
- = foldStateWithIndexRangeA declareArrayInstance ir_from ir_to functions
+ = foldStateWithIndexRangeA (declareArrayInstance) ir_from ir_to functions
where
declareArrayInstance :: Index FunDef -> BackEnder
declareArrayInstance index {fun_symb={id_name}, fun_type=Yes type}
@@ -1073,11 +1102,61 @@ convertRule aliasDummyId (index, {fun_type=Yes type, fun_body=body, fun_pos, fun
positionToLineNumber _
= -1
+beautifyAttributes :: SymbolType -> BEMonad SymbolType
+beautifyAttributes st
+ = return st
+// = accAttrHeap (beautifulizeAttributes st)
+
convertTypeAlt :: Int ModuleIndex SymbolType -> BEMonad BETypeAltP
-convertTypeAlt functionIndex moduleIndex symbol=:{st_result}
- = beTypeAlt
- (beNormalTypeNode (beFunctionSymbol functionIndex moduleIndex) (convertSymbolTypeArgs symbol))
+convertTypeAlt functionIndex moduleIndex symbolType
+ = beautifyAttributes (symbolType) ==> \symbolType=:{st_result, st_attr_env, st_attr_vars}
+ -> resetAttrNumbers
+ o` (beTypeAlt
+ (beNormalTypeNode (beFunctionSymbol functionIndex moduleIndex) (convertSymbolTypeArgs symbolType))
(convertAnnotTypeNode st_result)
+ (convertAttributeInequalities (group st_attr_env)))
+ where
+ group :: [AttrInequality] -> [InequalityGroup]
+ group []
+ = []
+ group [{ai_demanded, ai_offered} : t]
+ = grouped ai_demanded [ai_offered] t
+
+ // copied grouped from typesupport.icl, apparently inequalities are already sorted by
+ // offered attributes
+ // grouped takes care that inequalities like [a<=c, b<=c] are printed like [a b <= c]
+ grouped :: AttributeVar [AttributeVar] [AttrInequality] -> [InequalityGroup]
+ grouped group_var accu []
+ = [{ ig_offered = accu, ig_demanded = group_var}]
+ grouped group_var accu [{ai_offered, ai_demanded}:ineqs]
+ | group_var==ai_demanded
+ = grouped group_var [ai_offered:accu] ineqs
+ =[{ ig_offered = accu, ig_demanded = group_var}: grouped ai_demanded [ai_offered] ineqs]
+
+:: InequalityGroup =
+ { ig_offered :: ![AttributeVar]
+ , ig_demanded:: !AttributeVar
+ }
+
+resetAttrNumbers :: *BackEndState -> *BackEndState
+resetAttrNumbers state
+ = {state & bes_attr_number = 0}
+
+convertAttributeInequalities :: [InequalityGroup] -> BEMonad BEUniVarEquations
+convertAttributeInequalities inequalities
+ = sfoldr (beUniVarEquationsList o convertAttributeInequality) beNoUniVarEquations inequalities
+
+convertAttributeInequality :: InequalityGroup -> BEMonad BEUniVarEquations
+convertAttributeInequality {ig_demanded, ig_offered}
+ = beUniVarEquation (convertAttributeVar ig_demanded) (convertAttributeKinds ig_offered)
+
+convertAttributeKinds :: [AttributeVar] -> BEMonad BEAttributeKindList
+convertAttributeKinds vars
+ = sfoldr (beAttributeKinds o convertAttributeKind) beNoAttributeKinds vars
+
+convertAttributeKind :: AttributeVar -> BEMonad BEAttributeKindList
+convertAttributeKind attributeVar
+ = beAttributeKind (convertAttributeVar attributeVar)
convertSymbolTypeArgs :: SymbolType -> BEMonad BETypeArgP
convertSymbolTypeArgs {st_args}
@@ -1108,11 +1187,40 @@ convertAnnotation AN_None
convertAnnotation AN_Strict
= BEStrictAnnot
-convertAttribution :: TypeAttribute -> BEAttribution
+
+nextAttributeNumber :: *BackEndState -> (BEAttribution, *BackEndState)
+nextAttributeNumber state=:{bes_attr_number}
+ = (bes_attr_number + BEFirstUniVarNumber, {state & bes_attr_number = bes_attr_number+1})
+
+convertAttributeVar :: AttributeVar *BackEndState -> (BEAttribution, *BackEndState)
+convertAttributeVar {av_info_ptr, av_name} state=:{bes_attr_number}
+ # (attrInfo, state)
+ = read_from_attr_heap av_info_ptr state
+ = case attrInfo of
+ AVI_SequenceNumber number
+ -> (number, state)
+ _
+ # (attrNumber, state)
+ = nextAttributeNumber state
+ -> (attrNumber, write_to_attr_heap av_info_ptr (AVI_SequenceNumber attrNumber) state)
+
+convertAttribution :: TypeAttribute -> BEMonad BEAttribution
convertAttribution TA_Unique
- = BEUniqueAttr
-convertAttribution _ // +++ uni vars, etc.
- = BENoUniAttr
+ = return BEUniqueAttr
+convertAttribution TA_None
+ = return BENoUniAttr
+convertAttribution TA_Multi
+ = return BENoUniAttr
+convertAttribution TA_Anonymous
+ = nextAttributeNumber
+convertAttribution (TA_Var attrVar)
+ = convertAttributeVar attrVar
+convertAttribution (TA_RootVar attrVar)
+ = convertAttributeVar attrVar
+convertAttribution TA_MultiOfPropagatingConsVar
+ = return BENoUniAttr
+convertAttribution attr
+ = abort "backendconvert, convertAttribution: unknown TypeAttribute" <<- attr
convertAnnotTypeNode :: AType -> BEMonad BETypeNodeP
convertAnnotTypeNode {at_type, at_annotation, at_attribute}
@@ -1139,14 +1247,14 @@ convertTypeNode (TB BT_Dynamic)
convertTypeNode (TB basicType)
= beNormalTypeNode (beBasicSymbol (convertBasicTypeKind basicType)) beNoTypeArgs
convertTypeNode (TA typeSymbolIdent typeArgs)
- = beNormalTypeNode (convertTypeSymbolIdent typeSymbolIdent) (convertTypeArgs typeArgs)
+ = beNormalTypeNode (convertTypeSymbolIdent typeSymbolIdent) (convertTypeArgs typeArgs )
convertTypeNode (TV {tv_name})
= beVarTypeNode tv_name.id_name
convertTypeNode (TempQV n)
= beVarTypeNode ("_tqv" +++ toString n)
convertTypeNode (TempV n)
= beVarTypeNode ("_tv" +++ toString n)
-convertTypeNode (a --> b)
+convertTypeNode (a --> b)
= beNormalTypeNode (beBasicSymbol BEFunType) (convertTypeArgs [a, b])
convertTypeNode (a :@: b)
= beNormalTypeNode (beBasicSymbol BEApplySymb) (convertTypeArgs [{at_attribute=TA_Multi, at_annotation=AN_None, at_type = consVariableToType a} : b])
@@ -1292,8 +1400,8 @@ convertCodeParameter {bind_src, bind_dst}
= beCodeParameter bind_src (convertVar (varInfoPtr bind_dst))
/*
convertTransformedLhs :: Int [FreeVar] -> BEMonad BENodeP
-convertTransformedLhs functionIndex freeVars varHeap
- = beNormalNode (beFunctionSymbol functionIndex cIclModIndex) (convertLhsArgs freeVars varHeap)
+convertTransformedLhs functionIndex freeVars
+ = beNormalNode (beFunctionSymbol functionIndex cIclModIndex) (convertLhsArgs freeVars)
*/
convertPatterns :: [FunctionPattern] -> BEMonad BEArgP
@@ -1341,7 +1449,7 @@ convertRootExpr aliasDummyId (Conditional {if_cond=cond, if_then=then, if_else=Y
(convertRhsNodeDefs aliasDummyId then main_dcl_module_n)
(convertRhsStrictNodeIds then)
(convertRootExpr aliasDummyId then main_dcl_module_n)
- (convertRhsNodeDefs aliasDummyId else main_dcl_module_n)
+ (convertRhsNodeDefs aliasDummyId else main_dcl_module_n )
(convertRhsStrictNodeIds else)
(convertRootExpr aliasDummyId else main_dcl_module_n)
convertRootExpr aliasDummyId (Conditional {if_cond=cond, if_then=then, if_else=No}) main_dcl_module_n
@@ -1577,7 +1685,7 @@ where
convertExpr (Conditional {if_cond=cond, if_then, if_else=Yes else})
= beIfNode (convertExpr cond) (convertExpr if_then) (convertExpr else)
- convertExpr expr
+ convertExpr expr
= undef <<- ("backendconvert, convertExpr: unknown expression" , expr)
convertArgs :: [Expression] -> BEMonad BEArgP
diff --git a/backend/backendinterface.dcl b/backend/backendinterface.dcl
index e25c63a..bfb12e2 100644
--- a/backend/backendinterface.dcl
+++ b/backend/backendinterface.dcl
@@ -2,4 +2,4 @@ definition module backendinterface
import frontend
-backEndInterface :: !{#Char} [{#Char}] !PredefinedSymbols !FrontEndSyntaxTree !Int !*VarHeap !*File !*Files -> (!Bool,!*VarHeap, !*File, !*Files)
+backEndInterface :: !{#Char} [{#Char}] !PredefinedSymbols !FrontEndSyntaxTree !Int !*VarHeap !*AttrVarHeap !*File !*Files -> (!Bool, !*VarHeap, !*AttrVarHeap, !*File, !*Files)
diff --git a/backend/backendinterface.icl b/backend/backendinterface.icl
index fb65d3c..a177a2a 100644
--- a/backend/backendinterface.icl
+++ b/backend/backendinterface.icl
@@ -19,8 +19,8 @@ checkVersion VersionObservedIsTooOld errorFile
= fwrites "[Backend] the back end library is too old\n" errorFile
= (False, errorFile)
-backEndInterface :: !{#Char} [{#Char}] !PredefinedSymbols !FrontEndSyntaxTree !Int !*VarHeap !*File !*Files -> (!Bool,!*VarHeap, !*File, !*Files)
-backEndInterface outputFileName commandLineArgs predef_symbols syntaxTree=:{fe_icl,fe_components} main_dcl_module_n var_heap errorFile files
+backEndInterface :: !{#Char} [{#Char}] !PredefinedSymbols !FrontEndSyntaxTree !Int !*VarHeap !*AttrVarHeap !*File !*Files -> (!Bool, !*VarHeap, !*AttrVarHeap, !*File, !*Files)
+backEndInterface outputFileName commandLineArgs predef_symbols syntaxTree=:{fe_icl,fe_components} main_dcl_module_n var_heap attrHeap errorFile files
# (observedCurrent, observedOldestDefinition, observedOldestImplementation)
= BEGetVersion
observedVersion =
@@ -42,7 +42,7 @@ backEndInterface outputFileName commandLineArgs predef_symbols syntaxTree=:{fe_i
# (compatible, errorFile)
= checkVersion (versionCompare expectedVersion observedVersion) errorFile
| not compatible
- = (False, var_heap,errorFile, files)
+ = (False, var_heap, attrHeap, errorFile, files)
# varHeap
= backEndPreprocess predef_symbols.[PD_DummyForStrictAliasFun].pds_ident functionIndices fe_icl var_heap
with
@@ -54,10 +54,10 @@ backEndInterface outputFileName commandLineArgs predef_symbols syntaxTree=:{fe_i
= BEInit (length commandLineArgs) backEndFiles
# backEnd
= foldState BEArg commandLineArgs backEnd
- # (var_heap,backEnd)
- = backEndConvertModules predef_symbols syntaxTree main_dcl_module_n varHeap backEnd
+ # (var_heap, attrHeap, backEnd)
+ = backEndConvertModules predef_symbols syntaxTree main_dcl_module_n varHeap attrHeap backEnd
# (success, backEnd)
= BEGenerateCode outputFileName backEnd
# backEndFiles
= BEFree backEnd backEndFiles
- = (backEndFiles == 0 && success, var_heap,errorFile, files)
+ = (backEndFiles == 0 && success, var_heap, attrHeap, errorFile, files)
diff --git a/backendC/CleanCompilerSources/backend.c b/backendC/CleanCompilerSources/backend.c
index 726cfd6..49eedca 100644
--- a/backendC/CleanCompilerSources/backend.c
+++ b/backendC/CleanCompilerSources/backend.c
@@ -18,6 +18,8 @@
# include "comsupport.h" /* CurrentModule */
# include "buildtree.h" /* TupleSymbol, ApplySymbol */
+extern void InitARC_Info (void); /* from typeconv.h */
+
# include "backendsupport.h"
# define Clean(ignore)
@@ -1155,6 +1157,7 @@ BENormalTypeNode (BESymbolP symbol, BETypeArgP args)
return (node);
} /* BENormalTypeNode */
+
BETypeNodeP
BEAttributeTypeNode (BEAttribution attribution, BETypeNodeP typeNode)
{
@@ -1164,6 +1167,63 @@ BEAttributeTypeNode (BEAttribution attribution, BETypeNodeP typeNode)
return (typeNode);
} /* BEAttributeTypeNode */
+BEAttributeKindList
+BEAttributeKind (BEAttribution attributeKind)
+{
+ AttributeKindList new;
+
+ new = ConvertAllocType (struct attr_kind_list);
+
+ new->akl_elem = attributeKind;
+ new->akl_next = NULL;
+
+ return (new);
+} /* BEAttributeKind */
+
+BEAttributeKindList
+BENoAttributeKinds (void)
+{
+ return (NULL);
+} /* BENoAttributeKinds */
+
+BEAttributeKindList
+BEAttributeKinds (BEAttributeKindList elem, BEAttributeKindList list)
+{
+ Assert (elem->akl_next == NULL);
+ elem->akl_next = list;
+
+ return (elem);
+} /* BEAttributeKindList */
+
+BEUniVarEquations
+BEUniVarEquation (BEAttribution demanded, BEAttributeKindList offered)
+{
+ UniVarEquations new;
+
+ new = ConvertAllocType (struct uni_var_equats);
+
+ new->uve_demanded = demanded;
+ new->uve_offered = offered;
+ new->uve_next = NULL;
+
+ return (new);
+} /* BEUniVarEquation */
+
+BEUniVarEquations
+BENoUniVarEquations (void)
+{
+ return (NULL);
+} /* BENoUniVarEquations */
+
+BEUniVarEquations
+BEUniVarEquationsList (BEUniVarEquations elem, BEUniVarEquations list)
+{
+ Assert (elem->uve_next == NULL);
+ elem->uve_next = list;
+
+ return (elem);
+} /* BEUniVarEquations */
+
BETypeNodeP
BEAnnotateTypeNode (BEAnnotation annotation, BETypeNodeP typeNode)
{
@@ -1193,7 +1253,7 @@ BETypeArgs (BETypeNodeP node, BETypeArgP nextArgs)
} /* BETypeArgs */
BETypeAltP
-BETypeAlt (BETypeNodeP lhs, BETypeNodeP rhs)
+BETypeAlt (BETypeNodeP lhs, BETypeNodeP rhs, BEUniVarEquations attributeEquations)
{
TypeAlt *alt;
@@ -1203,7 +1263,7 @@ BETypeAlt (BETypeNodeP lhs, BETypeNodeP rhs)
alt->type_alt_rhs = rhs;
alt->type_alt_type_context = NULL; /* used in PrintType */
- alt->type_alt_attr_equations = NULL; /* used in PrintType */
+ alt->type_alt_attr_equations = attributeEquations; /* used in PrintType */
return (alt);
} /* BETypeAlt */
@@ -2380,6 +2440,7 @@ BETypeVar (CleanString name)
ident->ident_tv = typeVar;
typeVar->tv_ident = ident;
+ typeVar->tv_mark = 0;
typeVar->tv_argument_nr = 0; /* ??? */
return (typeVar);
@@ -3200,6 +3261,7 @@ BEInit (int argc)
ClearOpenDefinitionModules ();
+ InitARC_Info ();
InitStatesGen ();
InitCoding ();
InitInstructions ();
diff --git a/backendC/CleanCompilerSources/backend.h b/backendC/CleanCompilerSources/backend.h
index 2198250..c36245c 100644
--- a/backendC/CleanCompilerSources/backend.h
+++ b/backendC/CleanCompilerSources/backend.h
@@ -1,15 +1,15 @@
/* version info */
// increment this for every release
-# define kBEVersionCurrent 0x02000209
+# define kBEVersionCurrent 0x02000210
// change this to the same value as kBEVersionCurrent if the new release is not
// upward compatible (for example when a function is added)
-# define kBEVersionOldestDefinition 0x02000204
+# define kBEVersionOldestDefinition 0x02000210
// change this to the same value as kBEVersionCurrent if the new release is not
// downward compatible (for example when a function is removed)
-# define kBEVersionOldestImplementation 0x02000209
+# define kBEVersionOldestImplementation 0x02000210
# define kBEDebug 1
@@ -88,7 +88,13 @@ Clean (:: BENodeIdListP :== CPtr)
typedef struct node_id_ref_count_list *BENodeIdRefCountListP;
Clean (:: BENodeIdRefCountListP :== CPtr)
-
+
+typedef struct uni_var_equats *BEUniVarEquations;
+Clean (:: BEUniVarEquations :== CPtr)
+
+typedef struct attr_kind_list *BEAttributeKindList;
+Clean (:: BEAttributeKindList :== CPtr)
+
/* constants */
/*
# define kIclModuleIndex 0
@@ -238,14 +244,32 @@ Clean (BEAnnotateTypeNode :: BEAnnotation BETypeNodeP BackEnd -> (BETypeNodeP, B
BETypeNodeP BEAttributeTypeNode (BEAttribution attribution, BETypeNodeP typeNode);
Clean (BEAttributeTypeNode :: BEAttribution BETypeNodeP BackEnd -> (BETypeNodeP, BackEnd))
+BEAttributeKindList BEAttributeKind (BEAttribution attributeKind);
+Clean (BEAttributeKind :: BEAttribution BackEnd -> (BEAttributeKindList, BackEnd))
+
+BEAttributeKindList BENoAttributeKinds (void);
+Clean (BENoAttributeKinds :: BackEnd -> (BEAttributeKindList, BackEnd))
+
+BEAttributeKindList BEAttributeKinds (BEAttributeKindList elem, BEAttributeKindList list);
+Clean (BEAttributeKinds :: BEAttributeKindList BEAttributeKindList BackEnd -> (BEAttributeKindList, BackEnd))
+
+BEUniVarEquations BEUniVarEquation (BEAttribution demanded, BEAttributeKindList offered);
+Clean (BEUniVarEquation ::BEAttribution BEAttributeKindList BackEnd -> (BEUniVarEquations, BackEnd))
+
+BEUniVarEquations BENoUniVarEquations (void);
+Clean (BENoUniVarEquations :: BackEnd -> (BEUniVarEquations, BackEnd))
+
+BEUniVarEquations BEUniVarEquationsList (BEUniVarEquations elem, BEUniVarEquations list);
+Clean (BEUniVarEquationsList ::BEUniVarEquations BEUniVarEquations BackEnd -> (BEUniVarEquations, BackEnd))
+
BETypeArgP BENoTypeArgs (void);
Clean (BENoTypeArgs :: BackEnd -> (BETypeArgP, BackEnd))
BETypeArgP BETypeArgs (BETypeNodeP node, BETypeArgP nextArgs);
Clean (BETypeArgs :: BETypeNodeP BETypeArgP BackEnd -> (BETypeArgP, BackEnd))
-BETypeAltP BETypeAlt (BETypeNodeP lhs, BETypeNodeP rhs);
-Clean (BETypeAlt :: BETypeNodeP BETypeNodeP BackEnd -> (BETypeAltP, BackEnd))
+BETypeAltP BETypeAlt (BETypeNodeP lhs, BETypeNodeP rhs, BEUniVarEquations attributeEquations);
+Clean (BETypeAlt :: BETypeNodeP BETypeNodeP BEUniVarEquations BackEnd -> (BETypeAltP, BackEnd))
BENodeP BENormalNode (BESymbolP symbol, BEArgP args);
Clean (BENormalNode :: BESymbolP BEArgP BackEnd -> (BENodeP, BackEnd))
diff --git a/backendC/CleanCompilerSources/typeconv_2.c b/backendC/CleanCompilerSources/typeconv_2.c
index 7f828f7..f4a82be 100644
--- a/backendC/CleanCompilerSources/typeconv_2.c
+++ b/backendC/CleanCompilerSources/typeconv_2.c
@@ -308,7 +308,7 @@ static Bool PrintAttribute (AttributeKind attr, Bool print_colon)
else if (DoShowAttributes)
{ Bool used_implicitly;
unsigned attr_nr = RetrieveRefCountInfo (attr - FirstUniVarNumber, & used_implicitly);
-
+
if (attr_nr == 0)
{ if (! used_implicitly)
{ FPutC ('.', StdListTypes);
@@ -559,6 +559,7 @@ static void PrintAttributeEquations (UniVarEquations attr_equas)
for (next = attr_equas -> uve_offered ; ; )
{ unsigned off_attr_nr = RetrieveRefCountInfo (next -> akl_elem - FirstUniVarNumber, & used_implicitly);
+
PrintAttributeVariable (off_attr_nr);
if ((next = next -> akl_next))
FPutC (' ', StdListTypes);
@@ -666,3 +667,18 @@ void PrintType (SymbDef tdef, TypeAlts type)
} /* PrintType */
+
+/******
+
+ Routines for printing types
+
+******/
+
+
+void InitARC_Info (void)
+{
+ CurrentARC_Info = CompAllocType (struct attr_ref_count_info);
+ CurrentARC_Info -> arci_next = NULL;
+
+} /* InitARC_Info */
+
diff --git a/backendC/backend.link b/backendC/backend.link
index 36e0664..2408610 100644
--- a/backendC/backend.link
+++ b/backendC/backend.link
@@ -22,6 +22,12 @@
/EXPORT: BENormalTypeNode
/EXPORT: BEAnnotateTypeNode
/EXPORT: BEAttributeTypeNode
+/EXPORT: BEAttributeKind
+/EXPORT: BENoAttributeKinds
+/EXPORT: BEAttributeKinds
+/EXPORT: BEUniVarEquation
+/EXPORT: BENoUniVarEquations
+/EXPORT: BEUniVarEquationsList
/EXPORT: BENoTypeArgs
/EXPORT: BETypeArgs
/EXPORT: BETypeAlt
diff --git a/coclmaindll/backend.dll b/coclmaindll/backend.dll
index ddd3272..5686b3d 100644
--- a/coclmaindll/backend.dll
+++ b/coclmaindll/backend.dll
Binary files differ
diff --git a/frontend/syntax.dcl b/frontend/syntax.dcl
index 107a1f3..d4253bd 100644
--- a/frontend/syntax.dcl
+++ b/frontend/syntax.dcl
@@ -884,7 +884,8 @@ cNonRecursiveAppl :== False
| AVI_CorrespondenceNumber !Int /* auxiliary used in module comparedefimp */
| AVI_Used
| AVI_Count !Int /* auxiliary used in module typesupport */
-
+ | AVI_SequenceNumber !Int // RWS
+
:: AttrVarInfoPtr :== Ptr AttrVarInfo
:: AttrVarHeap :== Heap AttrVarInfo
diff --git a/frontend/syntax.icl b/frontend/syntax.icl
index f6900f9..be57141 100644
--- a/frontend/syntax.icl
+++ b/frontend/syntax.icl
@@ -857,7 +857,7 @@ cNotVarNumber :== -1
| AVI_CorrespondenceNumber !Int /* auxiliary used in module comparedefimp */
| AVI_Used
| AVI_Count !Int /* auxiliary used in module typesupport */
-
+ | AVI_SequenceNumber !Int // RWS
:: AttrVarInfoPtr :== Ptr AttrVarInfo
:: AttrVarHeap :== Heap AttrVarInfo
diff --git a/main/compile.icl b/main/compile.icl
index c4fdd8a..8c55e26 100644
--- a/main/compile.icl
+++ b/main/compile.icl
@@ -214,7 +214,9 @@ compileModule options commandLineArgs {dcl_modules,functions_and_macros,predef_s
| not closed
= abort ("couldn't close out file \"" +++ options.outPath +++ "\"\n")
# var_heap=heaps.hp_var_heap
- # (success,dcl_modules,functions_and_macros,n_functions_and_macros_in_dcl_modules,var_heap,error, files)
+ hp_type_heaps=heaps.hp_type_heaps
+ attrHeap=hp_type_heaps.th_attrs
+ # (success,dcl_modules,functions_and_macros,n_functions_and_macros_in_dcl_modules,var_heap,attrHeap,error, files)
= case optionalSyntaxTree of
Yes syntaxTree
# dcl_modules=syntaxTree.fe_dcls
@@ -231,9 +233,9 @@ compileModule options commandLineArgs {dcl_modules,functions_and_macros,predef_s
-> error <<< "Error: couldn't write ported versions of module "
<<< options.moduleName <<< '\n')
error
- # (success,var_heap,error, files)
- = backEndInterface outputPath (map appendRedirection commandLineArgs) predef_symbols syntaxTree main_dcl_module_n var_heap error files
- -> (success,dcl_modules,functions_and_macros,n_functions_and_macros_in_dcl_modules,var_heap,error, files)
+ # (success, var_heap, attrHeap, error, files)
+ = backEndInterface outputPath (map appendRedirection commandLineArgs) predef_symbols syntaxTree main_dcl_module_n var_heap attrHeap error files
+ -> (success,dcl_modules,functions_and_macros,n_functions_and_macros_in_dcl_modules,var_heap,attrHeap, error, files)
with
appendRedirection arg
= case arg of
@@ -244,12 +246,12 @@ compileModule options commandLineArgs {dcl_modules,functions_and_macros,predef_s
arg
-> arg
No
- -> (False,{},{},0,var_heap,error, files)
+ -> (False,{},{},0,var_heap,attrHeap,error, files)
with
outputPath
// = /* directoryName options.pathName +++ "Clean System Files" +++ {DirectorySeparator} +++ */ baseName options.pathName
= baseName options.pathName
- # heaps = {heaps & hp_var_heap=var_heap}
+ # heaps = {heaps & hp_var_heap=var_heap, hp_type_heaps = {hp_type_heaps & th_attrs = attrHeap}}
# (closed, files)
= fclose error files
| not closed
generated by cgit v1.2.3 (git 2.39.1) at 2025-04-27 23:17:54 +0000