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
6011f05a
Commit
6011f05a
authored
Nov 01, 2001
by
Ronny Wichers Schreur
🏢
Browse files
pass strictness information from C to Clean, print strict exported and all types in Clean
parent
2d047e80
Changes
18
Hide whitespace changes
Inline
Side-by-side
MacLibraries/CleanCompilerLib
View file @
6011f05a
No preview for this file type
backend/Clean System Files/backend_library
View file @
6011f05a
backend.dll
BEGetVersion
BEInit
BECloseFiles
BEFree
BEArg
BEDeclareModules
...
...
@@ -120,5 +121,7 @@ BEExportField
BEExportFunction
BEDefineImportedObjsAndLibs
BESetMainDclModuleN
BEStrictPositions
BECopyInts
BEDeclareDynamicTypeSymbol
BEDynamicTempTypeSymbol
backend/backend.dcl
View file @
6011f05a
...
...
@@ -42,6 +42,8 @@ BEGetVersion :: (!Int,!Int,!Int);
// void BEGetVersion (int* current,int* oldestDefinition,int* oldestImplementation);
BEInit
::
!
Int
!
UWorld
->
(!
BackEnd
,!
UWorld
);
// BackEnd BEInit (int argc);
BECloseFiles
::
!
BackEnd
->
BackEnd
;
// void BECloseFiles ();
BEFree
::
!
BackEnd
!
UWorld
->
UWorld
;
// void BEFree (BackEnd backEnd);
BEArg
::
!
String
!
BackEnd
->
BackEnd
;
...
...
@@ -280,13 +282,17 @@ BEDefineImportedObjsAndLibs :: !BEStringListP !BEStringListP !BackEnd -> BackEnd
// void BEDefineImportedObjsAndLibs (BEStringListP objs,BEStringListP libs);
BESetMainDclModuleN
::
!
Int
!
BackEnd
->
BackEnd
;
// void BESetMainDclModuleN (int main_dcl_module_n_parameter);
BEStrictPositions
::
!
Int
!
BackEnd
->
(!
Int
,!
Int
,!
BackEnd
);
// void BEStrictPositions (int functionIndex,int* bits,int** positions);
BECopyInts
::
!
Int
!
Int
!
Int
->
Int
;
// int BECopyInts (int cLength,int* ints,int* cleanArray);
BEDeclareDynamicTypeSymbol
::
!
Int
!
Int
!
BackEnd
->
BackEnd
;
// void BEDeclareDynamicTypeSymbol (int typeIndex,int moduleIndex);
BEDynamicTempTypeSymbol
::
!
BackEnd
->
(!
BESymbolP
,!
BackEnd
);
// BESymbolP BEDynamicTempTypeSymbol ();
kBEVersionCurrent
:==
0x0200021
5
;
kBEVersionCurrent
:==
0x0200021
6
;
kBEVersionOldestDefinition
:==
0x02000213
;
kBEVersionOldestImplementation
:==
0x0200021
5
;
kBEVersionOldestImplementation
:==
0x0200021
6
;
kBEDebug
:==
1
;
kPredefinedModuleIndex
:==
1
;
BENoAnnot
:==
0
;
...
...
backend/backend.icl
View file @
6011f05a
...
...
@@ -51,6 +51,12 @@ BEInit a0 a1 = code {
}
;
// BackEnd BEInit (int argc);
BECloseFiles
::
!
BackEnd
->
BackEnd
;
BECloseFiles
a0
=
code {
ccall
BECloseFiles
":V:I"
}
;
// void BECloseFiles ();
BEFree
::
!
BackEnd
!
UWorld
->
UWorld
;
BEFree
a0
a1
=
code {
ccall
BEFree
"I:V:I"
...
...
@@ -765,6 +771,18 @@ BESetMainDclModuleN a0 a1 = code {
}
;
// void BESetMainDclModuleN (int main_dcl_module_n_parameter);
BEStrictPositions
::
!
Int
!
BackEnd
->
(!
Int
,!
Int
,!
BackEnd
);
BEStrictPositions
a0
a1
=
code {
ccall
BEStrictPositions
"I:VII:I"
}
;
// void BEStrictPositions (int functionIndex,int* bits,int** positions);
BECopyInts
::
!
Int
!
Int
!
Int
->
Int
;
BECopyInts
a0
a1
a2
=
code {
ccall
BECopyInts
"III:I"
}
;
// int BECopyInts (int cLength,int* ints,int* cleanArray);
BEDeclareDynamicTypeSymbol
::
!
Int
!
Int
!
BackEnd
->
BackEnd
;
BEDeclareDynamicTypeSymbol
a0
a1
a2
=
code {
ccall
BEDeclareDynamicTypeSymbol
"II:V:I"
...
...
@@ -776,9 +794,9 @@ BEDynamicTempTypeSymbol a0 = code {
ccall
BEDynamicTempTypeSymbol
":I:I"
}
;
// BESymbolP BEDynamicTempTypeSymbol ();
kBEVersionCurrent
:==
0x0200021
5
;
kBEVersionCurrent
:==
0x0200021
6
;
kBEVersionOldestDefinition
:==
0x02000213
;
kBEVersionOldestImplementation
:==
0x0200021
5
;
kBEVersionOldestImplementation
:==
0x0200021
6
;
kBEDebug
:==
1
;
kPredefinedModuleIndex
:==
1
;
BENoAnnot
:==
0
;
...
...
backend/backendinterface.dcl
View file @
6011f05a
...
...
@@ -5,4 +5,4 @@ definition module backendinterface
import
frontend
backEndInterface
::
!{#
Char
}
[{#
Char
}]
!
PredefinedSymbols
!
FrontEndSyntaxTree
!
Int
!*
VarHeap
!*
AttrVarHeap
!*
File
!*
Files
->
(!
Bool
,
!*
VarHeap
,
!*
AttrVarHeap
,
!*
File
,
!*
Files
)
backEndInterface
::
!{#
Char
}
[{#
Char
}]
!
ListTypesOption
!{#
Char
}
!
PredefinedSymbols
!
FrontEndSyntaxTree
!
Int
!*
VarHeap
!*
AttrVarHeap
!*
File
!*
Files
->
(!
Bool
,
!*
VarHeap
,
!*
AttrVarHeap
,
!*
File
,
!*
Files
)
backend/backendinterface.icl
View file @
6011f05a
...
...
@@ -8,7 +8,7 @@ import StdEnv
import
frontend
import
backend
import
backendpreprocess
,
backendsupport
,
backendconvert
import
RWSDebug
,
Version
import
Version
checkVersion
::
VersionsCompatability
*
File
->
(!
Bool
,
!*
File
)
checkVersion
VersionsAreCompatible
errorFile
...
...
@@ -22,8 +22,8 @@ checkVersion VersionObservedIsTooOld errorFile
=
fwrites
"[Backend] the back end library is too old
\n
"
errorFile
=
(
False
,
errorFile
)
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
backEndInterface
::
!{#
Char
}
[{#
Char
}]
!
ListTypesOption
!{#
Char
}
!
PredefinedSymbols
!
FrontEndSyntaxTree
!
Int
!*
VarHeap
!*
AttrVarHeap
!*
File
!*
Files
->
(!
Bool
,
!*
VarHeap
,
!*
AttrVarHeap
,
!*
File
,
!*
Files
)
backEndInterface
outputFileName
commandLineArgs
listTypes
typesPath
predef_symbols
syntaxTree
=:{
fe_icl
,
fe_components
,
fe_dcls
}
main_dcl_module_n
var_heap
attrHeap
errorFile
files
#
(
observedCurrent
,
observedOldestDefinition
,
observedOldestImplementation
)
=
BEGetVersion
observedVersion
=
...
...
@@ -61,6 +61,342 @@ backEndInterface outputFileName commandLineArgs predef_symbols syntaxTree=:{fe_i
=
backEndConvertModules
predef_symbols
syntaxTree
main_dcl_module_n
varHeap
attrHeap
backEnd
#
(
success
,
backEnd
)
=
BEGenerateCode
outputFileName
backEnd
#
backEnd
=
BECloseFiles
backEnd
#
(
attrHeap
,
files
,
backEnd
)
// FIXME: should be type file
=
optionallyPrintFunctionTypes
listTypes
typesPath
(
DictionaryToClassInfo
main_dcl_module_n
fe_icl
fe_dcls
)
fe_components
fe_icl
.
icl_functions
attrHeap
files
backEnd
#
backEndFiles
=
BEFree
backEnd
backEndFiles
=
(
backEndFiles
==
0
&&
success
,
var_heap
,
attrHeap
,
errorFile
,
files
)
import
typesupport
optionallyPrintFunctionTypes
::
ListTypesOption
{#
Char
}
DictionaryToClassInfo
{!
Group
}
{#
FunDef
}
*
AttrVarHeap
*
Files
!*
BackEnd
->
(*
AttrVarHeap
,
*
Files
,
*
BackEnd
)
optionallyPrintFunctionTypes
{
lto_listTypesKind
,
lto_showAttributes
}
typesPath
info
components
functions
attrHeap
files
backEnd
|
lto_listTypesKind
==
ListTypesStrictExports
||
lto_listTypesKind
==
ListTypesAll
#
(
opened
,
typesFile
,
files
)
=
fopen
typesPath
FAppendText
files
|
not
opened
=
abort
(
"couldn't open types file
\"
"
+++
typesPath
+++
"
\"\n
"
)
#
(
attrHeap
,
typesFile
,
backEnd
)
=
printFunctionTypes
(
lto_listTypesKind
==
ListTypesAll
)
lto_showAttributes
info
components
functions
attrHeap
typesFile
backEnd
#
(
closed
,
files
)
=
fclose
typesFile
files
|
not
closed
=
abort
(
"couldn't close types file
\"
"
+++
typesPath
+++
"
\"\n
"
)
=
(
attrHeap
,
files
,
backEnd
)
// otherwise
=
(
attrHeap
,
files
,
backEnd
)
printFunctionTypes
::
Bool
Bool
DictionaryToClassInfo
{!
Group
}
{#
FunDef
}
*
AttrVarHeap
*
File
*
BackEnd
->
(*
AttrVarHeap
,
*
File
,
*
BackEnd
)
printFunctionTypes
all
attr
info
components
functions
attrHeap
file
backEnd
=
foldSt
(
printFunctionType
all
attr
info
)
[(
index
,
functions
.[
index
])
\\
(_,
index
)
<-
functionIndices
]
(
attrHeap
,
file
,
backEnd
)
where
functionIndices
=
flatten
[[(
componentIndex
,
member
)
\\
member
<-
group
.
group_members
]
\\
group
<-:
components
&
componentIndex
<-
[
1
..]]
printFunctionType
::
Bool
Bool
DictionaryToClassInfo
(
Int
,
FunDef
)
(*
AttrVarHeap
,
*
File
,
*
BackEnd
)
->
(*
AttrVarHeap
,
*
File
,
*
BackEnd
)
printFunctionType
all
attr
info
(
functionIndex
,
{
fun_symb
,
fun_type
=
Yes
type
})
(
attrHeap
,
file
,
backEnd
)
|
not
all
&&
functionIndex
>
size
info
.
dtic_dclModules
.[
info
.
dtci_iclModuleIndex
].
dcl_functions
=
(
attrHeap
,
file
,
backEnd
)
#
(
strictnessAdded
,
type
,
backEnd
)
=
addStrictnessFromBackEnd
functionIndex
fun_symb
.
id_name
backEnd
type
|
not
strictnessAdded
&&
not
all
=
(
attrHeap
,
file
,
backEnd
)
// FIXME: shouldn't have to repair the invariant here
#
(
type
,
attrHeap
)
=
collectSymbolTypeAttrVars
type
attrHeap
#
type
=
dictionariesToClasses
info
type
#
(
type
,
attrHeap
)
=
beautifulizeAttributes
type
attrHeap
#
file
=
file
<<<
fun_symb
<<<
" :: "
<::
({
form_properties
=
(
if
attr
cAttributed
0
)
bitor
cAnnotated
,
form_attr_position
=
No
},
type
,
Yes
initialTypeVarBeautifulizer
)
<<<
'\n'
=
(
attrHeap
,
file
,
backEnd
)
addStrictnessFromBackEnd
::
Int
{#
Char
}
*
BackEnd
SymbolType
->
(
Bool
,
SymbolType
,
*
BackEnd
)
addStrictnessFromBackEnd
functionIndex
functionName
backEnd
type
#
(
bitSize
,
strictPositionsC
,
backEnd
)
=
BEStrictPositions
functionIndex
backEnd
|
bitSize
==
0
// short cut
=
(
False
,
type
,
backEnd
)
#
strictPositions
=
copyInts
((
bitSize
+31
)/
32
)
strictPositionsC
// assumes 32 bit ints
#
strictnessInfo
=
{
si_robust_encoding
=
False
,
si_positions
=
strictPositions
,
si_size
=
bitSize
,
si_name
=
functionName
}
offset
=
0
#
(
robust
,
offset
)
=
nextBit
strictnessInfo
offset
strictnessInfo
=
{
strictnessInfo
&
si_robust_encoding
=
robust
}
#
(
anyStrictnessAdded
,
offset
)
=
nextBit
strictnessInfo
offset
#
(
type
,
offset
)
=
addStrictness
strictnessInfo
type
offset
#
type
=
checkFinalOffset
strictnessInfo
offset
type
=
(
anyStrictnessAdded
,
type
,
backEnd
)
::
StrictnessInfo
=
{
si_size
::
!
Int
,
si_positions
::
!
LargeBitvect
,
si_name
::
{#
Char
}
,
si_robust_encoding
::
!
Bool
}
class
addStrictness
a
::
!
StrictnessInfo
!
a
Int
->
(!
a
,
!
Int
)
nextBit
::
StrictnessInfo
Int
->
(
Bool
,
Int
)
nextBit
{
si_size
,
si_positions
,
si_robust_encoding
}
offset
|
offset
<
si_size
=
(
bitvectSelect
offset
si_positions
,
offset
+1
)
// otherwise
|
si_robust_encoding
=
abort
"backendinterface, nextBit: bit vector too small"
// otherwise
=
(
False
,
offset
)
checkStrictness
::
StrictnessInfo
Bool
Int
->
Int
checkStrictness
info
=:{
si_robust_encoding
}
wasStrict
offset
|
si_robust_encoding
#
(
bit
,
offset
)
=
nextBit
info
offset
|
bit
<>
wasStrict
=
abort
"backendinterface, checkStrictness: wrong info for strictness annotation"
=
offset
// otherwise
=
offset
checkType
::
StrictnessInfo
Bool
Int
->
Int
checkType
info
=:{
si_robust_encoding
}
isTuple
offset
|
si_robust_encoding
#
(
bit
,
offset
)
=
nextBit
info
offset
|
bit
<>
isTuple
=
abort
"backendinterface, checkType: wrong type"
=
offset
// otherwise
=
offset
checkFinalOffset
::
StrictnessInfo
Int
a
->
a
checkFinalOffset
info
=:{
si_size
,
si_robust_encoding
}
offset
value
|
offset
<
si_size
||
(
si_robust_encoding
&&
offset
>
si_size
)
=
abort
"backendinterface, checkFinalOffset: wrong offset"
// otherwise
=
value
instance
addStrictness
SymbolType
where
addStrictness
strictPositions
=:{
si_size
}
args
offset
|
offset
>=
si_size
// short cut
=
(
args
,
offset
)
addStrictness
strictPositions
type
=:{
st_args
}
offset
#
(
st_args
,
offset
)
=
addStrictness
strictPositions
st_args
offset
=
({
type
&
st_args
=
st_args
},
offset
)
instance
addStrictness
[
a
]
|
addStrictness
a
where
addStrictness
strictPositions
l
offset
=
mapSt
(
addStrictness
strictPositions
)
l
offset
instance
addStrictness
AType
where
addStrictness
strictPositions
arg
=:{
at_annotation
,
at_type
}
offset
#
(
at_annotation
,
offset
)
=
addStrictness
strictPositions
at_annotation
offset
#
(
at_type
,
offset
)
=
addStrictnessToType
strictPositions
(
at_annotation
==
AN_Strict
)
at_type
offset
=
({
arg
&
at_annotation
=
at_annotation
,
at_type
=
at_type
},
offset
)
instance
addStrictness
Annotation
where
addStrictness
info
annotation
offset
#
offset
=
checkStrictness
info
wasStrict
offset
#
(
strictAdded
,
offset
)
=
nextBit
info
offset
|
strictAdded
|
wasStrict
=
abort
"backendinterface, addStrictness: already strict"
// otherwise
=
(
AN_Strict
,
offset
)
// otherwise
=
(
annotation
,
offset
)
where
wasStrict
=
annotation
==
AN_Strict
addStrictnessToType
::
StrictnessInfo
Bool
Type
Int
->
(
Type
,
Int
)
addStrictnessToType
strictPositions
isStrict
type
=:(
TA
ident
=:{
type_name
,
type_arity
}
args
)
offset
#
offset
=
checkType
strictPositions
isTuple
offset
|
isTuple
&&
isStrict
#
(
args
,
offset
)
=
addStrictness
strictPositions
args
offset
=
(
TA
ident
args
,
offset
)
// otherwise
=
(
type
,
offset
)
where
// FIXME: don't match on name but use predef info
isTuple
=
type_name
.
id_name
==
"_Tuple"
+++
toString
type_arity
addStrictnessToType
strictPositions
_
type
offset
#
offset
=
checkType
strictPositions
False
offset
=
(
type
,
offset
)
collectSymbolTypeAttrVars
::
SymbolType
*
AttrVarHeap
->
(
SymbolType
,
*
AttrVarHeap
)
collectSymbolTypeAttrVars
type
=:{
st_attr_vars
,
st_result
,
st_args
}
attrVarHeap
#
attrVarHeap
=
foldSt
markAttrVarCollected
st_attr_vars
attrVarHeap
#
(
st_attr_vars
,
attrVarHeap
)
=
collectAttrVars
st_result
(
collectAttrVars
st_args
(
st_attr_vars
,
attrVarHeap
))
=
({
type
&
st_attr_vars
=
st_attr_vars
},
attrVarHeap
)
/* maybe should collect st_vars as well (these are not used currently) */
class
collectAttrVars
a
::
a
([
AttributeVar
],
*
AttrVarHeap
)
->
([
AttributeVar
],
*
AttrVarHeap
)
instance
collectAttrVars
AType
where
collectAttrVars
{
at_attribute
,
at_type
}
collect
=
collectAttrVars
at_attribute
(
collectAttrVars
at_type
collect
)
instance
collectAttrVars
TypeAttribute
where
collectAttrVars
(
TA_Var
attrVar
)
collect
=
collectAttrVars
attrVar
collect
collectAttrVars
(
TA_RootVar
attrVar
)
collect
=
collectAttrVars
attrVar
collect
collectAttrVars
(
TA_List
_
attribute
)
collect
=
collectAttrVars
attribute
collect
collectAttrVars
(
TA_Locked
attribute
)
collect
=
collectAttrVars
attribute
collect
collectAttrVars
_
collect
=
collect
instance
collectAttrVars
Type
where
collectAttrVars
(
TA
_
types
)
collect
=
collectAttrVars
types
collect
collectAttrVars
(
type1
-->
type2
)
collect
=
collectAttrVars
type1
(
collectAttrVars
type2
collect
)
collectAttrVars
(
TArrow1
type
)
collect
=
collectAttrVars
type
collect
collectAttrVars
(_
:@:
types
)
collect
=
collectAttrVars
types
collect
collectAttrVars
(
TFA
_
type
)
collect
=
collectAttrVars
type
collect
collectAttrVars
_
collect
=
collect
instance
collectAttrVars
AttributeVar
where
collectAttrVars
attrVar
=:{
av_info_ptr
}
(
attrVars
,
attrVarHeap
)
#
(
info
,
attrVarHeap
)
=
readPtr
av_info_ptr
attrVarHeap
=
case
info
of
AVI_Collected
->
(
attrVars
,
attrVarHeap
)
_
->
([
attrVar
:
attrVars
],
markAttrVarCollected
attrVar
attrVarHeap
)
instance
collectAttrVars
[
a
]
|
collectAttrVars
a
where
collectAttrVars
l
collect
=
foldSt
collectAttrVars
l
collect
markAttrVarCollected
::
AttributeVar
*
AttrVarHeap
->
*
AttrVarHeap
markAttrVarCollected
{
av_info_ptr
}
attrVarHeap
=
writePtr
av_info_ptr
AVI_Collected
attrVarHeap
::
DictionaryToClassInfo
=
{
dtci_iclModuleIndex
::
Int
,
dtci_iclModule
::
IclModule
,
dtic_dclModules
::
{#
DclModule
}
}
DictionaryToClassInfo
iclModuleIndex
iclModule
dclModules
:==
{
dtci_iclModuleIndex
=
iclModuleIndex
,
dtci_iclModule
=
iclModule
,
dtic_dclModules
=
dclModules
}
dictionariesToClasses
::
DictionaryToClassInfo
SymbolType
->
SymbolType
dictionariesToClasses
info
type
=:{
st_args
,
st_arity
,
st_context
=[]}
#
(
reversedTypes
,
reversedContexts
)
=
dictionaryArgsToClasses
info
st_args
([],
[])
=
{
type
&
st_args
=
reverse
reversedTypes
,
st_context
=
reverse
reversedContexts
,
st_arity
=
st_arity
-
length
reversedContexts
}
dictionaryArgsToClasses
::
DictionaryToClassInfo
[
AType
]
([
AType
],
[
TypeContext
])
->
([
AType
],
[
TypeContext
])
dictionaryArgsToClasses
info
args
result
=
foldSt
(
dictionaryArgToClass
info
)
args
result
dictionaryArgToClass
::
DictionaryToClassInfo
AType
([
AType
],
[
TypeContext
])
->
([
AType
],
[
TypeContext
])
dictionaryArgToClass
info
type
=:{
at_type
=
TA
typeSymbol
args
}
(
reversedTypes
,
reversedContexts
)
=
case
typeToClass
info
typeSymbol
of
Yes
klass
->
(
reversedTypes
,
[
context
:
reversedContexts
])
with
context
=
{
tc_class
=
klass
,
tc_types
=
[
at_type
\\
{
at_type
}
<-
args
],
tc_var
=
nilPtr
}
No
->
([
type
:
reversedTypes
],
reversedContexts
)
dictionaryArgToClass
_
type
(
reversedTypes
,
reversedContexts
)
=
([
type
:
reversedTypes
],
reversedContexts
)
typeToClass
::
DictionaryToClassInfo
TypeSymbIdent
->
Optional
(
Global
DefinedSymbol
)
typeToClass
info
{
type_name
,
type_arity
,
type_index
={
glob_module
,
glob_object
}}
=
case
typeIndexToClassIndex
info
glob_module
glob_object
of
Yes
classIndex
->
Yes
{
glob_module
=
glob_module
,
glob_object
=
{
ds_ident
=
type_name
,
ds_arity
=
type_arity
,
ds_index
=
glob_object
}}
No
->
No
where
/*
This how the types are organised (#classes == #dictionaries)
com_classes
+--------(1)-------+--------(2)-------+
| dcl classes | icl classes |
+------------------+------------------+
nDclClasses nIclClasses
com_type_defs
+-----------+--------(1)-------+-----------+--------(2)-------+
| dcl types | dcl dictionaries | icl types | icl dictionaries |
+-----------+------------------+-----------+------------------+
nDclTypes nIclTypes
*/
typeIndexToClassIndex
::
DictionaryToClassInfo
Int
Int
->
Optional
Int
typeIndexToClassIndex
{
dtci_iclModuleIndex
,
dtci_iclModule
,
dtic_dclModules
}
moduleIndex
typeIndex
|
moduleIndex
<>
dtci_iclModuleIndex
||
typeIndex
<
nDclTypes
=
toClassIndex
typeIndex
nDclTypes
nDclClasses
0
// otherwise
=
toClassIndex
(
typeIndex
-
nDclTypes
)
(
nIclTypes
-
nDclTypes
)
(
nIclClasses
-
nDclClasses
)
nDclClasses
where
dclModule
=
dtic_dclModules
.[
moduleIndex
]
nDclTypes
=
size
dclModule
.
dcl_common
.
com_type_defs
nDclClasses
=
size
dclModule
.
dcl_common
.
com_class_defs
nIclTypes
=
size
dtci_iclModule
.
icl_common
.
com_type_defs
nIclClasses
=
size
dtci_iclModule
.
icl_common
.
com_class_defs
toClassIndex
::
Int
Int
Int
Int
->
Optional
Int
toClassIndex
typeIndex
nTypes
nClasses
offset
|
classIndex
<
0
=
No
// otherwise
=
Yes
(
classIndex
+
offset
)
where
classIndex
=
typeIndex
-
(
nTypes
-
nClasses
)
copyInts
::
!
Int
!
Int
->
{#
Int
}
copyInts
length
cArray
=
code {
push_b
0
create_array_
INT
0
1
push_a
0
ccall
BECopyInts
"IIA-I"
pop_b
1
}
backendC/CleanCompilerSources/backend.c
View file @
6011f05a
...
...
@@ -731,6 +731,7 @@ BESpecialArrayFunctionSymbol (BEArrayFunKind arrayFunKind, int functionIndex, in
newTypeAlt
->
type_alt_lhs
=
BENormalTypeNode
(
newFunctionSymbol
,
lhsArgs
);
newTypeAlt
->
type_alt_rhs
=
rhs
;
newTypeAlt
->
type_alt_strict_positions
=
NULL
;
newIdent
->
ident_symbol
=
newFunctionSymbol
;
newIdent
->
ident_name
=
functionName
;
...
...
@@ -820,6 +821,7 @@ CreateLocallyDefinedFunction (int index, char ** abcCode, TypeArgs lhsArgs, Type
typeAlt
->
type_alt_attr_equations
=
NULL
;
/* used in PrintType */
typeAlt
->
type_alt_lhs
=
BENormalTypeNode
(
functionSymbol
,
lhsArgs
);
typeAlt
->
type_alt_rhs
=
rhsType
;
typeAlt
->
type_alt_strict_positions
=
NULL
;
BERule
(
functionIndex
,
BEIsNotACaf
,
typeAlt
,
ruleAlt
);
...
...
@@ -1509,6 +1511,7 @@ BETypeAlt (BETypeNodeP lhs, BETypeNodeP rhs, BEUniVarEquations attributeEquation
alt
->
type_alt_type_context
=
NULL
;
/* used in PrintType */
alt
->
type_alt_attr_equations
=
attributeEquations
;
/* used in PrintType */
alt
->
type_alt_strict_positions
=
NULL
;
return
(
alt
);
}
/* BETypeAlt */
...
...
@@ -3381,6 +3384,57 @@ BEExportFunction (int dclFunctionIndex, int iclFunctionIndex)
dclDef
->
sdef_dcl_icl
=
iclDef
;
}
/* BEExportFunction */
void
BEStrictPositions
(
int
functionIndex
,
int
*
bits
,
int
**
positions
)
{
BEModuleP
module
;
SymbolP
functionSymbol
;
SymbDef
functionDefinition
;
ImpRules
rule
;
TypeAlts
ruleType
;
StrictPositionsP
strict_positions
;
Assert
((
unsigned
int
)
main_dcl_module_n
<
gBEState
.
be_nModules
);
module
=
&
gBEState
.
be_modules
[
main_dcl_module_n
];
Assert
((
unsigned
int
)
functionIndex
<
module
->
bem_nFunctions
);
functionSymbol
=
&
module
->
bem_functions
[
functionIndex
];
Assert
(
functionSymbol
->
symb_kind
==
definition
);
functionDefinition
=
functionSymbol
->
symb_def
;
Assert
(
functionDefinition
->
sdef_kind
==
IMPRULE
);
rule
=
functionDefinition
->
sdef_rule
;
ruleType
=
rule
->
rule_type
;
Assert
(
ruleType
!=
NULL
);
strict_positions
=
ruleType
->
type_alt_strict_positions
;
Assert
(
strict_positions
!=
NULL
);
*
bits
=
strict_positions
->
sp_size
;
*
positions
=
strict_positions
->
sp_bits
;
}
/* BEStrictPositions */
int
BECopyInts
(
int
cLength
,
int
*
ints
,
int
*
cleanArray
)
{
int
cleanLength
,
truncate
;
cleanLength
=
cleanArray
[
-
2
];
truncate
=
cleanLength
<
cLength
;
if
(
truncate
)
cLength
=
cleanLength
;
memcpy
(
cleanArray
,
ints
,
cLength
*
sizeof
(
int
));
Assert
(
!
truncate
);
return
(
!
truncate
);
}
/* BECopyInts */
static
void
CheckBEEnumTypes
(
void
)
{
...
...
@@ -3622,6 +3676,17 @@ BEInit (int argc)
return
((
BackEnd
)
&
gBEState
);
}
/* BEInit */
void
BECloseFiles
(
void
)
{
if
(
StdErrorReopened
)
fclose
(
StdError
);
StdErrorReopened
=
False
;
if
(
StdOutReopened
)
fclose
(
StdOut
);
StdOutReopened
=
False
;
}
/* BECloseFiles */
void
BEFree
(
BackEnd
backEnd
)
{
...
...
@@ -3633,10 +3698,7 @@ BEFree (BackEnd backEnd)
Assert
(
gBEState
.
be_initialised
);
gBEState
.
be_initialised
=
False
;
if
(
StdErrorReopened
)
fclose
(
StdError
);
if
(
StdOutReopened
)
fclose
(
StdOut
);
BECloseFiles
();
}
/* BEFree */
// temporary hack
...
...
backendC/CleanCompilerSources/backend.h
View file @
6011f05a
/* version info */
// increment this for every release
# define kBEVersionCurrent 0x0200021
5
# define kBEVersionCurrent 0x0200021
6
// change this to the same value as kBEVersionCurrent if the new release is
// not upward compatible (for example when a function is added)
...
...
@@ -9,7 +9,7 @@
// change this to the same value as kBEVersionCurrent if the new release is
// not downward compatible (for example when a function is removed)