Skip to content
GitLab
Projects
Groups
Snippets
/
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in
Toggle navigation
Menu
Open sidebar
clean-compiler-and-rts
compiler
Commits
4d41042c
Commit
4d41042c
authored
May 08, 2001
by
Ronny Wichers Schreur
🏢
Browse files
support for cases in backend
parent
dcea4965
Changes
4
Expand all
Hide whitespace changes
Inline
Side-by-side
backend/Clean System Files/backend_library
View file @
4d41042c
...
...
@@ -31,6 +31,10 @@ BEMatchNode
BETupleSelectNode
BEIfNode
BEGuardNode
BESwitchNode
BECaseNode
BEPushNode
BEDefaultNode
BESelectorNode
BEUpdateNode
BENodeIdNode
...
...
@@ -78,6 +82,9 @@ BENoStrings
BECodeParameter
BECodeParameters
BENoCodeParameters
BENodeIdListElem
BENodeIds
BENoNodeIds
BEAbcCodeBlock
BEAnyCodeBlock
BEDeclareIclModule
...
...
backend/backend.dcl
View file @
4d41042c
...
...
@@ -4,28 +4,30 @@ definition module backend;
from
StdString
import
String
;
//3.1
::
CPtr
:==
Int
;
::
*
UWorld
:==
Int
;
::
*
BackEnd
:==
Int
;
::
BESymbolP
:==
Int
;
::
BETypeNodeP
:==
Int
;
::
BETypeArgP
:==
Int
;
::
BETypeAltP
:==
Int
;
::
BENodeP
:==
Int
;
::
BEArgP
:==
Int
;
::
BERuleAltP
:==
Int
;
::
BEImpRuleP
:==
Int
;
::
BETypeP
:==
Int
;
::
BEFlatTypeP
:==
Int
;
::
BETypeVarP
:==
Int
;
::
BETypeVarListP
:==
Int
;
::
BEConstructorListP
:==
Int
;
::
BEFieldListP
:==
Int
;
::
BENodeIdP
:==
Int
;
::
BENodeDefP
:==
Int
;
::
BEStrictNodeIdP
:==
Int
;
::
BECodeParameterP
:==
Int
;
::
BECodeBlockP
:==
Int
;
::
BEStringListP
:==
Int
;
::
*
BackEnd
;
::
BESymbolP
;
::
BETypeNodeP
;
::
BETypeArgP
;
::
BETypeAltP
;
::
BENodeP
;
::
BEArgP
;
::
BERuleAltP
;
::
BEImpRuleP
;
::
BETypeP
;
::
BEFlatTypeP
;
::
BETypeVarP
;
::
BETypeVarListP
;
::
BEConstructorListP
;
::
BEFieldListP
;
::
BENodeIdP
;
::
BENodeDefP
;
::
BEStrictNodeIdP
;
::
BECodeParameterP
;
::
BECodeBlockP
;
::
BEStringListP
;
::
BENodeIdListP
;
::
BEAnnotation
:==
Int
;
::
BEAttribution
:==
Int
;
::
BESymbKind
:==
Int
;
...
...
@@ -96,6 +98,14 @@ BEIfNode :: !BENodeP !BENodeP !BENodeP !BackEnd -> (!BENodeP,!BackEnd);
// BENodeP BEIfNode (BENodeP cond,BENodeP then,BENodeP elsje);
BEGuardNode
::
!
BENodeP
!
BENodeDefP
!
BEStrictNodeIdP
!
BENodeP
!
BENodeDefP
!
BEStrictNodeIdP
!
BENodeP
!
BackEnd
->
(!
BENodeP
,!
BackEnd
);
// BENodeP BEGuardNode (BENodeP cond,BENodeDefP thenNodeDefs,BEStrictNodeIdP thenStricts,BENodeP then,BENodeDefP elseNodeDefs,BEStrictNodeIdP elseStricts,BENodeP elsje);
BESwitchNode
::
!
BENodeIdP
!
BEArgP
!
BackEnd
->
(!
BENodeP
,!
BackEnd
);
// BENodeP BESwitchNode (BENodeIdP nodeId,BEArgP caseNode);
BECaseNode
::
!
Int
!
BESymbolP
!
BENodeDefP
!
BEStrictNodeIdP
!
BENodeP
!
BackEnd
->
(!
BENodeP
,!
BackEnd
);
// BENodeP BECaseNode (int symbolArity,BESymbolP symbol,BENodeDefP nodeDefs,BEStrictNodeIdP strictNodeIds,BENodeP node);
BEPushNode
::
!
Int
!
BESymbolP
!
BEArgP
!
BENodeIdListP
!
BackEnd
->
(!
BENodeP
,!
BackEnd
);
// BENodeP BEPushNode (int arity,BESymbolP symbol,BEArgP arguments,BENodeIdListP nodeIds);
BEDefaultNode
::
!
BENodeDefP
!
BEStrictNodeIdP
!
BENodeP
!
BackEnd
->
(!
BENodeP
,!
BackEnd
);
// BENodeP BEDefaultNode (BENodeDefP nodeDefs,BEStrictNodeIdP strictNodeIds,BENodeP node);
BESelectorNode
::
!
BESelectorKind
!
BESymbolP
!
BEArgP
!
BackEnd
->
(!
BENodeP
,!
BackEnd
);
// BENodeP BESelectorNode (BESelectorKind selectorKind,BESymbolP fieldSymbol,BEArgP args);
BEUpdateNode
::
!
BEArgP
!
BackEnd
->
(!
BENodeP
,!
BackEnd
);
...
...
@@ -190,6 +200,12 @@ BECodeParameters :: !BECodeParameterP !BECodeParameterP !BackEnd -> (!BECodePara
// BECodeParameterP BECodeParameters (BECodeParameterP parameter,BECodeParameterP parameters);
BENoCodeParameters
::
!
BackEnd
->
(!
BECodeParameterP
,!
BackEnd
);
// BECodeParameterP BENoCodeParameters ();
BENodeIdListElem
::
!
BENodeIdP
!
BackEnd
->
(!
BENodeIdListP
,!
BackEnd
);
// BENodeIdListP BENodeIdListElem (BENodeIdP nodeId);
BENodeIds
::
!
BENodeIdListP
!
BENodeIdListP
!
BackEnd
->
(!
BENodeIdListP
,!
BackEnd
);
// BENodeIdListP BENodeIds (BENodeIdListP nid,BENodeIdListP nids);
BENoNodeIds
::
!
BackEnd
->
(!
BENodeIdListP
,!
BackEnd
);
// BENodeIdListP BENoNodeIds ();
BEAbcCodeBlock
::
!
Bool
!
BEStringListP
!
BackEnd
->
(!
BECodeBlockP
,!
BackEnd
);
// BECodeBlockP BEAbcCodeBlock (int inline,BEStringListP instructions);
BEAnyCodeBlock
::
!
BECodeParameterP
!
BECodeParameterP
!
BEStringListP
!
BackEnd
->
(!
BECodeBlockP
,!
BackEnd
);
...
...
@@ -222,9 +238,9 @@ BEDeclareDynamicTypeSymbol :: !Int !Int !BackEnd -> BackEnd;
// void BEDeclareDynamicTypeSymbol (int typeIndex,int moduleIndex);
BEDynamicTempTypeSymbol
::
!
BackEnd
->
(!
BESymbolP
,!
BackEnd
);
// BESymbolP BEDynamicTempTypeSymbol ();
kBEVersionCurrent
:==
0x0200020
6
;
kBEVersionOldestDefinition
:==
0x0200020
4
;
kBEVersionOldestImplementation
:==
0x0200020
6
;
kBEVersionCurrent
:==
0x0200020
7
;
kBEVersionOldestDefinition
:==
0x0200020
7
;
kBEVersionOldestImplementation
:==
0x0200020
7
;
kBEDebug
:==
1
;
kPredefinedModuleIndex
:==
1
;
BENoAnnot
:==
0
;
...
...
backend/backend.icl
View file @
4d41042c
This diff is collapsed.
Click to expand it.
backend/backendconvert.icl
View file @
4d41042c
...
...
@@ -8,6 +8,7 @@ import frontend
import
backend
import
backendsupport
,
backendpreprocess
import
RWSDebug
import
StdDebug
// trace macro
(-*->)
infixl
...
...
@@ -26,6 +27,11 @@ sfoldr op r l s
foldr
[]
=
r
foldr
[
a
:
x
]
=
op
a
(
foldr
x
)
// fix spelling, this will be removed when cases are implemented in the back end
::
BackEndBody
:==
BackendBody
BackEndBody
x
:==
BackendBody
x
::
BEMonad
a
:==
St
!*
BackEndState
!
a
::
BackEnder
:==
*
BackEndState
->
*
BackEndState
...
...
@@ -180,8 +186,8 @@ beFieldSymbol fieldIndex moduleIndex
:==
beFunction0
(
BEFieldSymbol
fieldIndex
moduleIndex
)
beTypeSymbol
typeIndex
moduleIndex
:==
beFunction0
(
BETypeSymbol
typeIndex
moduleIndex
)
beBasicSymbol
typeS
ymbolIndex
:==
beFunction0
(
BEBasicSymbol
typeS
ymbolIndex
)
beBasicSymbol
s
ymbolIndex
:==
beFunction0
(
BEBasicSymbol
s
ymbolIndex
)
beDontCareDefinitionSymbol
:==
beFunction0
BEDontCareDefinitionSymbol
beNoArgs
...
...
@@ -304,6 +310,20 @@ beDefineImportedObjsAndLibs
:==
beApFunction2
BEDefineImportedObjsAndLibs
beAbsType
:==
beApFunction1
BEAbsType
beSwitchNode
:==
beFunction2
BESwitchNode
beCaseNode
symbolArity
:==
beFunction4
(
BECaseNode
symbolArity
)
bePushNode
symbolArity
:==
beFunction3
(
BEPushNode
symbolArity
)
beDefaultNode
:==
beFunction3
BEDefaultNode
beNoNodeIds
:==
beFunction0
BENoNodeIds
beNodeIds
:==
beFunction2
BENodeIds
beNodeIdListElem
:==
beFunction1
BENodeIdListElem
// temporary hack
beDynamicTempTypeSymbol
:==
beFunction0
BEDynamicTempTypeSymbol
...
...
@@ -335,8 +355,7 @@ backEndConvertModulesH predefs {fe_icl = fe_icl =: {icl_name, icl_functions, icl
= backEnd
# backEnd
= abort "front end abort" backEnd
*/
#!
backEnd
=
appBackEnd
(
BESetMainDclModuleN
main_dcl_module_n
)
backEnd
*/
#!
backEnd
=
appBackEnd
(
BESetMainDclModuleN
main_dcl_module_n
)
backEnd
#!
backEnd
=
appBackEnd
(
BEDeclareModules
(
size
fe_dcls
))
backEnd
#!
backEnd
...
...
@@ -589,6 +608,8 @@ instance declareVars Expression where
declareVars
(
Conditional
{
if_then
,
if_else
})
dvInput
=
declareVars
if_then
dvInput
o`
declareVars
if_else
dvInput
declareVars
(
Case
caseExpr
)
dvInput
=
declareVars
caseExpr
dvInput
declareVars
(
AnyCodeExpr
_
outParams
_)
(_,
varHeap
)
=
foldState
(
declVar
varHeap
)
outParams
where
...
...
@@ -609,6 +630,26 @@ instance declareVars BackendBody where
=
declareVars
bb_args
dvInput
o`
declareVars
bb_rhs
dvInput
instance
declareVars
Case
where
declareVars
{
case_expr
,
case_guards
,
case_default
}
dvInput
=
declareVars
case_guards
dvInput
o`
declareVars
case_default
dvInput
instance
declareVars
CasePatterns
where
declareVars
(
AlgebraicPatterns
_
patterns
)
dvInput
=
declareVars
patterns
dvInput
declareVars
(
BasicPatterns
_
patterns
)
dvInput
=
declareVars
patterns
dvInput
instance
declareVars
AlgebraicPattern
where
declareVars
{
ap_vars
,
ap_expr
}
dvInput
=
declareVars
ap_vars
dvInput
o`
declareVars
ap_expr
dvInput
instance
declareVars
BasicPattern
where
declareVars
{
bp_expr
}
dvInput
=
declareVars
bp_expr
dvInput
::
ModuleIndex
:==
Index
class
declare
a
::
ModuleIndex
!
VarHeap
a
->
BackEnder
...
...
@@ -972,6 +1013,7 @@ adjustArrayFunctions predefs arrayInstancesRange main_dcl_module_n functions dcl
_
->
identity
)
be
adjustIclArrayInstances
::
IndexRange
{#
BEArrayFunKind
}
{#
FunDef
}
->
BackEnder
adjustIclArrayInstances
{
ir_from
,
ir_to
}
mapping
instances
=
foldStateWithIndexRangeA
(
adjustIclArrayInstance
mapping
)
ir_from
ir_to
instances
...
...
@@ -1009,7 +1051,7 @@ convertRules rules main_dcl_module_n aliasDummyId varHeap be
convertRule
::
Ident
(
Int
,
FunDef
)
Int
VarHeap
->
BEMonad
BEImpRuleP
convertRule
aliasDummyId
(
index
,
{
fun_type
=
Yes
type
,
fun_body
=
body
,
fun_pos
,
fun_kind
,
fun_symb
})
main_dcl_module_n
varHeap
=
beRule
index
(
cafness
fun_kind
)
(
convertTypeAlt
index
main_dcl_module_n
(
type
/* ->
> ("convertRule", fun_symb.id_name, index, type)
*/
))
(
convertTypeAlt
index
main_dcl_module_n
(
type
-*-
>
(
"convertRule"
,
fun_symb
.
id_name
,
index
,
type
)))
(
convertFunctionBody
index
(
positionToLineNumber
fun_pos
)
aliasDummyId
body
main_dcl_module_n
varHeap
)
where
cafness
::
DefOrImpFunKind
->
Int
...
...
@@ -1036,7 +1078,9 @@ convertRule aliasDummyId (index, {fun_type=Yes type, fun_body=body, fun_pos, fun
convertTypeAlt
::
Int
ModuleIndex
SymbolType
->
BEMonad
BETypeAltP
convertTypeAlt
functionIndex
moduleIndex
symbol
=:{
st_result
}
=
beTypeAlt
(
beNormalTypeNode
(
beFunctionSymbol
functionIndex
moduleIndex
)
(
convertSymbolTypeArgs
symbol
))
(
convertAnnotTypeNode
st_result
)
=
beTypeAlt
(
beNormalTypeNode
(
beFunctionSymbol
functionIndex
moduleIndex
)
(
convertSymbolTypeArgs
symbol
))
(
convertAnnotTypeNode
st_result
)
convertSymbolTypeArgs
::
SymbolType
->
BEMonad
BETypeArgP
convertSymbolTypeArgs
{
st_args
}
...
...
@@ -1093,13 +1137,10 @@ convertAnnotTypeNode {at_type, at_annotation, at_attribute}
convertTypeNode
::
Type
->
BEMonad
BETypeNodeP
convertTypeNode
(
TB
(
BT_String
type
))
=
convertTypeNode
type
// tempory hack
convertTypeNode
(
TB
BT_Dynamic
)
=
beNormalTypeNode
beDynamicTempTypeSymbol
beNoTypeArgs
convertTypeNode
(
TB
basicType
)
=
beNormalTypeNode
(
beBasicSymbol
(
convertBasicTypeKind
basicType
))
beNoTypeArgs
convertTypeNode
(
TB
basicType
)
=
beNormalTypeNode
(
beBasicSymbol
(
convertBasicTypeKind
basicType
))
beNoTypeArgs
convertTypeNode
(
TA
typeSymbolIdent
typeArgs
)
=
beNormalTypeNode
(
convertTypeSymbolIdent
typeSymbolIdent
)
(
convertTypeArgs
typeArgs
)
convertTypeNode
(
TV
{
tv_name
})
...
...
@@ -1115,7 +1156,7 @@ convertTypeNode (a :@: b)
convertTypeNode
TE
=
beNormalTypeNode
beDontCareDefinitionSymbol
beNoTypeArgs
convertTypeNode
typeNode
=
un
de
f
<<-
(
"backendconvert, convertTypeNode: unknown type node"
,
typeNode
)
=
abort
"convertTypeNo
de
"
<<-
(
"backendconvert, convertTypeNode: unknown type node"
,
typeNode
)
consVariableToType
::
ConsVariable
->
Type
consVariableToType
(
CV
typeVar
)
...
...
@@ -1129,45 +1170,96 @@ convertTypeArgs :: [AType] -> BEMonad BETypeArgP
convertTypeArgs
args
=
sfoldr
(
beTypeArgs
o
convertAnnotTypeNode
)
beNoTypeArgs
args
convertTransformedBody
::
Int
Int
Ident
TransformedBody
Int
VarHeap
->
BEMonad
BERuleAltP
convertTransformedBody
functionIndex
lineNumber
aliasDummyId
body
main_dcl_module_n
varHeap
|
isCodeBlock
body
.
tb_rhs
=
declareVars
body
(
aliasDummyId
,
varHeap
)
o`
convertCodeBody
functionIndex
lineNumber
aliasDummyId
body
main_dcl_module_n
varHeap
// otherwise
=
declareVars
body
(
aliasDummyId
,
varHeap
)
o`
convertBody
functionIndex
lineNumber
aliasDummyId
(
map
FP_Variable
body
.
tb_args
)
body
.
tb_rhs
main_dcl_module_n
varHeap
isCodeBlock
::
Expression
->
Bool
isCodeBlock
(
Case
{
case_expr
=
Var
_,
case_guards
=
AlgebraicPatterns
_
[{
ap_expr
}]})
=
isCodeBlock
ap_expr
isCodeBlock
(
ABCCodeExpr
_
_)
=
True
isCodeBlock
(
AnyCodeExpr
_
_
_)
=
True
isCodeBlock
expr
=
False
convertFunctionBody
::
Int
Int
Ident
FunctionBody
Int
VarHeap
->
BEMonad
BERuleAltP
convertFunctionBody
functionIndex
lineNumber
aliasDummyId
(
Back
e
ndBody
bodies
)
main_dcl_module_n
varHeap
=
convertBack
e
ndBodies
functionIndex
lineNumber
bodies
varHeap
convertFunctionBody
functionIndex
lineNumber
aliasDummyId
(
Back
E
ndBody
bodies
)
main_dcl_module_n
varHeap
=
convertBack
E
ndBodies
functionIndex
lineNumber
bodies
main_dcl_module_n
varHeap
where
convertBackendBodies
::
Int
Int
[
BackendBody
]
VarHeap
->
BEMonad
BERuleAltP
convertBackendBodies
functionIndex
lineNumber
bodies
varHeap
=
sfoldr
(
beRuleAlts
o
(
flip
(
convertBackendBody
functionIndex
lineNumber
))
varHeap
)
beNoRuleAlts
bodies
convertBackEndBodies
::
Int
Int
[
BackEndBody
]
Int
VarHeap
->
BEMonad
BERuleAltP
convertBackEndBodies
functionIndex
lineNumber
bodies
main_dcl_module_n
varHeap
=
sfoldr
(
beRuleAlts
o
convertBackEndBody
functionIndex
lineNumber
aliasDummyId
main_dcl_module_n
varHeap
)
beNoRuleAlts
bodies
where
convertBackEndBody
::
Int
Int
Ident
Int
VarHeap
BackEndBody
->
BEMonad
BERuleAltP
convertBackEndBody
functionIndex
lineNumber
aliasDummyId
main_dcl_module_n
varHeap
body
=
declareVars
body
(
aliasDummyId
,
varHeap
)
o`
convertBody
functionIndex
lineNumber
aliasDummyId
body
.
bb_args
body
.
bb_rhs
main_dcl_module_n
varHeap
convertFunctionBody
functionIndex
lineNumber
aliasDummyId
(
TransformedBody
body
)
main_dcl_module_n
varHeap
=
convertTransformedBody
functionIndex
lineNumber
aliasDummyId
body
main_dcl_module_n
varHeap
convertCodeBody
::
Int
Int
Ident
TransformedBody
Int
VarHeap
->
BEMonad
BERuleAltP
convertCodeBody
functionIndex
lineNumber
aliasDummyId
body
main_dcl_module_n
varHeap
=
convertBody
functionIndex
lineNumber
aliasDummyId
patterns
expr
main_dcl_module_n
varHeap
where
convertBackendBody
::
Int
Int
BackendBody
VarHeap
->
BEMonad
BERuleAltP
convertBackendBody
functionIndex
lineNumber
body
=:{
bb_args
,
bb_rhs
=
ABCCodeExpr
instructions
inline
}
varHeap
=
beNoNodeDefs
==>
\
noNodeDefs
->
declareVars
body
(
aliasDummyId
,
varHeap
)
o`
beCodeAlt
lineNumber
(
convertLhsNodeDefs
bb_args
noNodeDefs
varHeap
)
(
convertBackendLhs
functionIndex
bb_args
varHeap
)
(
beAbcCodeBlock
inline
(
convertStrings
instructions
))
convertBackendBody
functionIndex
lineNumber
body
=:{
bb_args
,
bb_rhs
=
AnyCodeExpr
inParams
outParams
instructions
}
varHeap
=
beNoNodeDefs
==>
\
noNodeDefs
->
declareVars
body
(
aliasDummyId
,
varHeap
)
o`
beCodeAlt
lineNumber
(
convertLhsNodeDefs
bb_args
noNodeDefs
varHeap
)
(
convertBackendLhs
functionIndex
bb_args
varHeap
)
(
beAnyCodeBlock
(
convertCodeParameters
inParams
varHeap
)
(
convertCodeParameters
outParams
varHeap
)
(
convertStrings
instructions
))
convertBackendBody
functionIndex
lineNumber
body
=:{
bb_args
,
bb_rhs
}
varHeap
=
beNoNodeDefs
==>
\
noNodeDefs
->
declareVars
body
(
aliasDummyId
,
varHeap
)
o`
beRuleAlt
lineNumber
(
convertLhsNodeDefs
bb_args
noNodeDefs
varHeap
)
(
convertBackendLhs
functionIndex
bb_args
varHeap
)
(
convertRhsNodeDefs
aliasDummyId
bb_rhs
main_dcl_module_n
varHeap
)
(
convertRhsStrictNodeIds
bb_rhs
varHeap
)
(
convertRootExpr
aliasDummyId
bb_rhs
main_dcl_module_n
varHeap
)
convertBackendLhs
::
Int
[
FunctionPattern
]
VarHeap
->
BEMonad
BENodeP
convertBackendLhs
functionIndex
patterns
varHeap
=
beNormalNode
(
beFunctionSymbol
functionIndex
main_dcl_module_n
)
(
convertPatterns
patterns
varHeap
)
patterns
=
map
(
lookUpVar
body
.
tb_rhs
)
body
.
tb_args
expr
=
codeBlock
body
.
tb_rhs
lookUpVar
::
Expression
FreeVar
->
FunctionPattern
lookUpVar
(
Case
{
case_expr
=
Var
boundVar
,
case_guards
=
AlgebraicPatterns
_
[
ap
]})
freeVar
|
freeVar
.
fv_info_ptr
==
boundVar
.
var_info_ptr
=
FP_Algebraic
ap
.
ap_symbol
subPatterns
No
with
subPatterns
=
map
(
lookUpVar
ap
.
ap_expr
)
ap
.
ap_vars
// otherwise
=
lookUpVar
ap
.
ap_expr
freeVar
lookUpVar
_
freeVar
=
FP_Variable
freeVar
codeBlock
::
Expression
->
Expression
codeBlock
(
Case
{
case_expr
=
Var
(
var_infoPtr
),
case_guards
=
AlgebraicPatterns
_
[{
ap_expr
}]})
=
codeBlock
ap_expr
codeBlock
expr
=
expr
convertBody
::
Int
Int
Ident
[
FunctionPattern
]
Expression
Int
VarHeap
->
BEMonad
BERuleAltP
convertBody
functionIndex
lineNumber
aliasDummyId
args
(
ABCCodeExpr
instructions
inline
)
main_dcl_module_n
varHeap
=
beNoNodeDefs
==>
\
noNodeDefs
->
beCodeAlt
lineNumber
(
convertLhsNodeDefs
args
noNodeDefs
varHeap
)
(
convertBackEndLhs
functionIndex
args
main_dcl_module_n
varHeap
)
(
beAbcCodeBlock
inline
(
convertStrings
instructions
))
convertBody
functionIndex
lineNumber
aliasDummyId
args
(
AnyCodeExpr
inParams
outParams
instructions
)
main_dcl_module_n
varHeap
=
beNoNodeDefs
==>
\
noNodeDefs
->
beCodeAlt
lineNumber
(
convertLhsNodeDefs
args
noNodeDefs
varHeap
)
(
convertBackEndLhs
functionIndex
args
main_dcl_module_n
varHeap
)
(
beAnyCodeBlock
(
convertCodeParameters
inParams
varHeap
)
(
convertCodeParameters
outParams
varHeap
)
(
convertStrings
instructions
))
convertBody
functionIndex
lineNumber
aliasDummyId
args
rhs
main_dcl_module_n
varHeap
=
beNoNodeDefs
==>
\
noNodeDefs
->
beRuleAlt
lineNumber
(
convertLhsNodeDefs
args
noNodeDefs
varHeap
)
(
convertBackEndLhs
functionIndex
args
main_dcl_module_n
varHeap
)
(
convertRhsNodeDefs
aliasDummyId
rhs
main_dcl_module_n
varHeap
)
(
convertRhsStrictNodeIds
rhs
varHeap
)
(
convertRootExpr
aliasDummyId
rhs
main_dcl_module_n
varHeap
)
convertBackEndLhs
::
Int
[
FunctionPattern
]
Int
VarHeap
->
BEMonad
BENodeP
convertBackEndLhs
functionIndex
patterns
main_dcl_module_n
varHeap
=
beNormalNode
(
beFunctionSymbol
functionIndex
main_dcl_module_n
)
(
convertPatterns
patterns
varHeap
)
convertStrings
::
[{#
Char
}]
->
BEMonad
BEStringListP
convertStrings
strings
...
...
@@ -1253,6 +1345,11 @@ convertRootExpr aliasDummyId (Conditional {if_cond=cond, if_then=then, if_else=N
beNoNodeDefs
beNoStrictNodeIds
(
beNormalNode
(
beBasicSymbol
BEFailSymb
)
beNoArgs
)
convertRootExpr
aliasDummyId
(
Case
{
case_expr
,
case_guards
,
case_default
})
main_dcl_module_n
varHeap
=
beSwitchNode
(
convertVar
var
.
var_info_ptr
varHeap
)
(
convertCases
case_guards
aliasDummyId
var
case_default
main_dcl_module_n
varHeap
)
where
var
=
caseVar
case_expr
convertRootExpr
_
expr
main_dcl_module_n
varHeap
=
convertExpr
expr
main_dcl_module_n
varHeap
...
...
@@ -1356,14 +1453,14 @@ convertRhsStrictNodeIds expression varHeap
=
convertStrictNodeIds
(
collectStrictNodeIds
expression
)
varHeap
convertLiteralSymbol
::
BasicValue
->
BEMonad
BESymbolP
convertLiteralSymbol
(
BVI
s
tring
)
=
beLiteralSymbol
BEIntDenot
s
tring
convertLiteralSymbol
(
BVI
intS
tring
)
=
beLiteralSymbol
BEIntDenot
intS
tring
convertLiteralSymbol
(
BVB
bool
)
=
beBoolSymbol
bool
convertLiteralSymbol
(
BVC
s
tring
)
=
beLiteralSymbol
BECharDenot
s
tring
convertLiteralSymbol
(
BVR
s
tring
)
=
beLiteralSymbol
BERealDenot
s
tring
convertLiteralSymbol
(
BVC
charS
tring
)
=
beLiteralSymbol
BECharDenot
charS
tring
convertLiteralSymbol
(
BVR
realS
tring
)
=
beLiteralSymbol
BERealDenot
realS
tring
convertLiteralSymbol
(
BVS
string
)
=
beLiteralSymbol
BEStringDenot
string
...
...
@@ -1391,7 +1488,7 @@ where
convertSymbol
{
symb_kind
=
SK_Constructor
{
glob_module
,
glob_object
}}
=
beConstructorSymbol
glob_module
glob_object
// ->> ("convertSymbol", (glob_module, glob_object))
convertSymbol
symbol
=
undef
<<-
(
"backendconvert, convertSymbol: unknown symbol"
,
symbol
)
=
undef
<<-
(
"backendconvert, convertSymbol: unknown symbol"
)
//
, symbol)
convertExpr
(
Var
var
)
varHeap
=
beNodeIdNode
(
convertVar
var
.
var_info_ptr
varHeap
)
beNoArgs
convertExpr
(
f
@
[
a
])
varHeap
...
...
@@ -1481,12 +1578,12 @@ where
=
beIfNode
(
convertExpr
cond
varHeap
)
(
convertExpr
if_then
varHeap
)
(
convertExpr
else
varHeap
)
convertExpr
expr
_
=
undef
<<-
(
"backendconvert, convertExpr: unknown expression"
,
expr
)
=
undef
<<-
(
"backendconvert, convertExpr: unknown expression"
,
expr
)
convertArgs
::
[
Expression
]
VarHeap
->
BEMonad
BEArgP
convertArgs
exprs
varHeap
=
sfoldr
(
beArgs
o
flip
convertExpr
varHeap
)
beNoArgs
exprs
convertSelections
::
(
BEMonad
BENodeP
)
VarHeap
[(
BESelectorKind
,
Selection
)]
->
(
BEMonad
BENodeP
)
convertSelections
expression
varHeap
selections
=
foldl
(
convertSelection
varHeap
)
expression
selections
...
...
@@ -1512,6 +1609,75 @@ where
dictionary
=
convertExpr
(
Selection
No
(
Var
dictionaryVar
)
dictionarySelections
)
varHeap
caseVar
::
Expression
->
BoundVar
caseVar
(
Var
var
)
=
var
caseVar
expr
=
undef
<<-
(
"backendconvert, caseVar: unknown expression"
,
expr
)
class
convertCases
a
::
a
Ident
BoundVar
(
Optional
Expression
)
Int
VarHeap
->
BEMonad
BEArgP
instance
convertCases
CasePatterns
where
convertCases
(
AlgebraicPatterns
_
patterns
)
aliasDummyId
var
default_case
main_dcl_module_n
varHeap
=
convertCases
patterns
aliasDummyId
var
default_case
main_dcl_module_n
varHeap
convertCases
(
BasicPatterns
_
patterns
)
aliasDummyId
var
default_case
main_dcl_module_n
varHeap
=
convertCases
patterns
aliasDummyId
var
default_case
main_dcl_module_n
varHeap
// +++ other patterns ???
instance
convertCases
[
a
]
|
convertCase
a
where
convertCases
patterns
aliasDummyId
var
optionalCase
main_dcl_module_n
varHeap
=
sfoldr
(
beArgs
o
convertCase
main_dcl_module_n
varHeap
aliasDummyId
var
)
(
convertDefaultCase
optionalCase
aliasDummyId
main_dcl_module_n
varHeap
)
patterns
class
convertCase
a
::
Int
VarHeap
Ident
BoundVar
a
->
BEMonad
BENodeP
instance
convertCase
AlgebraicPattern
where
convertCase
main_dcl_module_n
varHeap
aliasDummyId
var
{
ap_symbol
={
glob_module
,
glob_object
={
ds_index
}},
ap_vars
,
ap_expr
}
|
symbolArity
==
0
=
beCaseNode
0
(
beConstructorSymbol
glob_module
ds_index
)
(
convertRhsNodeDefs
aliasDummyId
ap_expr
main_dcl_module_n
varHeap
)
(
convertRhsStrictNodeIds
ap_expr
varHeap
)
(
convertRootExpr
aliasDummyId
ap_expr
main_dcl_module_n
varHeap
)
// otherwise
=
beCaseNode
symbolArity
(
beConstructorSymbol
glob_module
ds_index
)
(
convertRhsNodeDefs
aliasDummyId
ap_expr
main_dcl_module_n
varHeap
)
(
convertRhsStrictNodeIds
ap_expr
varHeap
)
(
bePushNode
symbolArity
(
beConstructorSymbol
glob_module
ds_index
)
(
beArgs
(
convertExpr
(
Var
var
)
main_dcl_module_n
varHeap
)
(
beArgs
(
convertRootExpr
aliasDummyId
ap_expr
main_dcl_module_n
varHeap
)
beNoArgs
))
(
convertPatternVars
ap_vars
varHeap
))
where
symbolArity
=
length
ap_vars
// curried patterns ???
instance
convertCase
BasicPattern
where
convertCase
main_dcl_module_n
varHeap
aliasDummyId
_
{
bp_value
,
bp_expr
}
=
beCaseNode
0
(
convertLiteralSymbol
bp_value
)
(
convertRhsNodeDefs
aliasDummyId
bp_expr
main_dcl_module_n
varHeap
)
(
convertRhsStrictNodeIds
bp_expr
varHeap
)
(
convertRootExpr
aliasDummyId
bp_expr
main_dcl_module_n
varHeap
)
convertPatternVars
::
[
FreeVar
]
VarHeap
->
BEMonad
BENodeIdListP
convertPatternVars
vars
varHeap
=
sfoldr
(
beNodeIds
o
flip
convertPatternVar
varHeap
)
beNoNodeIds
vars
convertPatternVar
::
FreeVar
VarHeap
->
BEMonad
BENodeIdListP
convertPatternVar
freeVar
varHeap
=
beNodeIdListElem
(
convertVar
freeVar
.
fv_info_ptr
varHeap
)
convertDefaultCase
::
(
Optional
Expression
)
Ident
Int
VarHeap
->
BEMonad
BEArgP
convertDefaultCase
No
_
_
varHeap
=
beNoArgs
convertDefaultCase
(
Yes
expr
)
aliasDummyId
main_dcl_module_n
varHeap
=
beArgs
(
beDefaultNode
(
convertRhsNodeDefs
aliasDummyId
expr
main_dcl_module_n
varHeap
)
(
convertRhsStrictNodeIds
expr
varHeap
)
(
convertRootExpr
aliasDummyId
expr
main_dcl_module_n
varHeap
))
beNoArgs
selectionKindToArrayFunKind
BESelector
=
BEArraySelectFun
selectionKindToArrayFunKind
BESelector_U
...
...
@@ -1536,6 +1702,8 @@ getVariableSequenceNumber varInfoPtr varHeap be
->
(
sequenceNumber
,
be
)
VI_Alias
{
var_info_ptr
}
->
getVariableSequenceNumber
var_info_ptr
varHeap
be
vi
->
abort
"getVariableSequenceNumber"
<<-
vi
markExports
::
DclModule
{#
ClassDef
}
{#
CheckedTypeDef
}
{#
ClassDef
}
{#
CheckedTypeDef
}
(
Optional
{#
Int
})
->
BackEnder
markExports
{
dcl_conversions
=
Yes
conversionTable
}
dclClasses
dclTypes
iclClasses
iclTypes
(
Yes
functionConversions
)
...
...
Write
Preview
Supports
Markdown
0%
Try again
or
attach a new file
.
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment