"{ Package: 'cvut:fel/cface' }"
"{ NameSpace: Cface }"
Generator subclass:#SmalltalkXGenerator
instanceVariableNames:''
classVariableNames:''
poolDictionaries:''
category:'Cface-Generators'
!
!SmalltalkXGenerator class methodsFor:'instance creation'!
generate:aStringOrFilename class:aClass namespace:aNameSpace
|temp|
temp := Generator onFile:aStringOrFilename.
temp
startGeneration:aClass
nameSpace:aNameSpace
toFile:aStringOrFilename , '.st'.
^ temp.
"Created: / 08-02-2008 / 08:55:08 / janfrog"
!
new
^ self basicNew initialize.
"Created: / 08-02-2008 / 08:55:08 / janfrog"
!
on: aStream
|gen|
gen := self new.
gen inputStream: aStream;
parseDef;
analyse.
^gen
"Modified: / 24-11-2007 / 12:20:27 / haja"
"Created: / 08-02-2008 / 08:55:08 / janfrog"
!
onFile: aStringOrFilename
^self on: aStringOrFilename asFilename readStream
"Created: / 08-02-2008 / 08:55:08 / janfrog"
! !
!SmalltalkXGenerator methodsFor:'accessing'!
analyser
^ analyser
"Created: / 08-02-2008 / 08:39:26 / janfrog"
!
analyser:something
analyser := something.
"Created: / 08-02-2008 / 08:39:26 / janfrog"
!
cBuilder
^ cBuilder
"Created: / 08-02-2008 / 08:39:26 / janfrog"
!
cBuilder:something
cBuilder := something.
"Created: / 08-02-2008 / 08:39:26 / janfrog"
!
className
^ className
"Created: / 08-02-2008 / 08:39:26 / janfrog"
!
className:something
className := something.
"Created: / 08-02-2008 / 08:39:26 / janfrog"
!
defaultCBuilder
^CCodeBuilder on:outputStream.
" ^CCodeBuilder on:String new writeStream"
"Created: / 08-02-2008 / 08:39:26 / janfrog"
!
defaultParser
^Parser
"Created: / 08-02-2008 / 08:39:26 / janfrog"
!
defaultStBuilder
^OldSmalltalkCodeBuilder on:outputStream.
" ^CCodeBuilder on:String new writeStream"
"Created: / 08-02-2008 / 08:39:26 / janfrog"
"Modified: / 13-02-2008 / 08:07:12 / janfrog"
!
fundamentalTypes
"
Possible combinations:
char
signed char
unsigned char
int, signed int
short int, short, signed short int, signed short
long int, long, signed long int,signed long
unsigned int, unsigned
unsigned short int, unsigned short
unsigned long int, unsigned long
float
double
long double
"
^#('char' 'short' 'int' 'long' 'float' 'double' 'void' 'signed' 'unsigned').
"Created: / 08-02-2008 / 08:39:26 / janfrog"
!
inputStream
^ inputStream
"Created: / 08-02-2008 / 08:39:26 / janfrog"
!
inputStream:something
inputStream := something.
"Created: / 08-02-2008 / 08:39:26 / janfrog"
!
nameSpace
^ nameSpace
"Created: / 08-02-2008 / 08:39:26 / janfrog"
!
nameSpace:something
nameSpace := something.
"Created: / 08-02-2008 / 08:39:26 / janfrog"
!
outputStream
^ outputStream
"Created: / 08-02-2008 / 08:39:26 / janfrog"
!
outputStream:something
outputStream := something.
"Created: / 08-02-2008 / 08:39:26 / janfrog"
!
parentNode
^ parentNode
"Created: / 08-02-2008 / 08:39:26 / janfrog"
!
parentNode:something
parentNode := something.
"Created: / 08-02-2008 / 08:39:26 / janfrog"
!
parseTree
^ parseTree
"Created: / 08-02-2008 / 08:39:26 / janfrog"
!
parseTree:something
parseTree := something.
"Created: / 08-02-2008 / 08:39:26 / janfrog"
!
parser
^ parser
"Created: / 08-02-2008 / 08:39:26 / janfrog"
!
parser:something
parser := something.
"Created: / 08-02-2008 / 08:39:26 / janfrog"
!
prototypes
^ prototypes
"Created: / 08-02-2008 / 08:39:26 / janfrog"
!
prototypes:something
prototypes := something.
"Created: / 08-02-2008 / 08:39:26 / janfrog"
!
stBuilder
^ stBuilder
"Created: / 08-02-2008 / 08:39:26 / janfrog"
!
stBuilder:something
stBuilder := something.
"Created: / 08-02-2008 / 08:39:26 / janfrog"
!
streamContents
^outputStream streamContents
"Created: / 08-02-2008 / 08:39:26 / janfrog"
! !
!SmalltalkXGenerator methodsFor:'actions'!
analyse
prototypes := analyser on:parseTree.
"Modified: / 17-11-2007 / 09:12:31 / haja"
"Created: / 08-02-2008 / 08:39:26 / janfrog"
!
parseDef
parser := self defaultParser on:inputStream.
parser parse.
parseTree := parser nodeStack first.
"Created: / 08-02-2008 / 08:39:26 / janfrog"
!
startGeneration:aClassName nameSpace:aNameSpace
className := aClassName.
namespace := aNameSpace.
self visit:parseTree.
"Created: / 08-02-2008 / 08:39:26 / janfrog"
!
startGeneration:aClassName nameSpace:aNameSpace toFile:aFileName
className := aClassName.
namespace := aNameSpace.
self visit:parseTree.
self writeToFile:aFileName.
"Created: / 08-02-2008 / 08:39:26 / janfrog"
! !
!SmalltalkXGenerator methodsFor:'generators'!
generateArrayCompositeStructAccessMethod:aStructOrUnionFieldNode in:aStructFieldNode in:aStructNode
self stBuilder
methodFor:aStructNode name
category:'accessing'
with:[
self
nextPutString:aStructFieldNode name , '_' , aStructOrUnionFieldNode name
, 'At:position'.
self cr.
self cr.
self generateCommentFor:aStructFieldNode.
self generateCommentFor:aStructOrUnionFieldNode.
self cr.
self stBuilder declareId:#( 'errorString' ).
self cr.
self cBuilder
primitiveWith:[
self cBuilder
if:[ self nextPutString:'not __isInteger( position )'. ]
then:[
self cBuilder
assign:[
self cBuilder functionCall:'__MKSTRING'
withString:'"Argument position is not integer"'.
]
to:'errorString'.
]
else:[
self cBuilder
declareId:'temp'
asString:(self declarationCString:aStructNode)
init:'__externalAddressVal( self )'.
self cBuilder returnMacro:true
with:[
self cBuilder
functionCall:[ self cBuilder objectCreation:aStructFieldNode id ]
withString:[
self cBuilder struct:'temp'
access:aStructFieldNode name , '[__longIntVal(position)]' , '.'
, aStructOrUnionFieldNode name.
].
].
].
].
self cr.
self stBuilder commentWith:'If reached, primitive code has failed'.
self stBuilder makeIndent.
self nextPutString:'^self primitiveFailed: errorString.'.
self cr.
].
self cr.
self stBuilder
methodFor:'accessing'
category:aStructNode name
with:[
self
nextPutString:aStructFieldNode name , '_' , aStructOrUnionFieldNode name
, 'At:position put:aValue'.
self cr.
self cr.
self generateCommentFor:aStructFieldNode.
self generateCommentFor:aStructOrUnionFieldNode.
self cr.
self stBuilder declareId:#( 'errorString' ).
self cr.
self cBuilder
primitiveWith:[
self cr.
self cBuilder
declareId:'args_ok'
asString:'int '
init:'1'.
self cr.
self cBuilder commentWith:'Checking arguments'.
self cBuilder
if:[
self nextPutString:'args_ok && '.
self cBuilder
parenthesesWith:[ self nextPutString:'not __isInteger( position )'. ].
]
then:[
self cBuilder
assign:[
self cBuilder functionCall:'__MKSTRING'
withString:'"Argument position is not integer"'.
]
to:'errorString'.
self cBuilder assign:'0' to:'args_ok'.
].
self cBuilder
if:[
self nextPutString:'args_ok && '.
self cBuilder
parenthesesWith:[
self nextPutString:'not '.
self cBuilder typeCheck:aStructOrUnionFieldNode id variable:'aValue'.
].
]
then:[
self cBuilder
assign:[
self cBuilder functionCall:'__MKSTRING'
withString:'"Argument aValue is not instance of expected class"'.
]
to:'errorString'.
self cBuilder assign:'0' to:'args_ok'.
].
self cr.
self cBuilder if:'args_ok'
then:[
self cBuilder
declareId:'temp'
asString:(self declarationCString:aStructNode)
init:'__externalAddressVal( self )'.
self cBuilder
assign:[
self cBuilder valueExtraction:aStructOrUnionFieldNode id
variable:'aValue'.
]
to:[
self cBuilder struct:'temp'
access:aStructFieldNode name , '[__longIntVal(position)].'
, aStructOrUnionFieldNode name
].
self cBuilder return.
].
].
self cr.
self stBuilder commentWith:'If reached, primitive code has failed'.
self stBuilder makeIndent.
self nextPutString:'^self primitiveFailed: errorString.'.
self cr.
].
"Modified: / 19-12-2007 / 17:31:13 / haja"
"Created: / 08-02-2008 / 08:39:26 / janfrog"
"Modified: / 10-02-2008 / 11:16:09 / janfrog"
!
generateArrayCompositeStructAccessMethods:aStructFieldNode in:aStructNode
aStructFieldNode id id reference fields do:[:aStructOrUnionFieldNode|
self generateArrayCompositeStructAccessMethod:aStructOrUnionFieldNode in:aStructFieldNode in:aStructNode.
].
"Created: / 08-02-2008 / 08:39:26 / janfrog"
!
generateArrayStructAccessMethod:aStructFieldNode in:aStructNode
self stBuilder
methodFor:aStructNode name
category:'accessing'
with:[
self nextPutString:aStructFieldNode name , 'At:position'.
self cr.
self cr.
self generateCommentFor:aStructFieldNode.
self cr.
self stBuilder declareId:#( 'errorString' ).
self cr.
self cBuilder
primitiveWith:[
self cBuilder
if:[ self nextPutString:'not __isInteger( position )'. ]
then:[
self cBuilder
assign:[
self cBuilder functionCall:'__MKSTRING'
withString:'"Argument position is not integer"'.
]
to:'errorString'.
]
else:[
self cBuilder
declareId:'temp'
asString:(self declarationCString:aStructNode)
init:'__externalAddressVal( self )'.
self cBuilder returnMacro:true
with:[
self cBuilder
functionCall:[ self cBuilder objectCreation:aStructFieldNode id ]
withString:[
self cBuilder struct:'temp'
access:aStructFieldNode name , '[__longIntVal(position)]'.
].
].
].
].
self cr.
self stBuilder commentWith:'If reached, primitive code has failed'.
self stBuilder makeIndent.
self nextPutString:'^self primitiveFailed: errorString.'.
self cr.
].
self cr.
self stBuilder
methodFor:'accessing'
category:aStructNode name
with:[
self nextPutString:aStructFieldNode name , 'At:position put:aValue'.
self cr.
self cr.
self generateCommentFor:aStructFieldNode.
self cr.
self stBuilder declareId:#( 'errorString' ).
self cr.
self cBuilder
primitiveWith:[
self cr.
self cBuilder
declareId:'args_ok'
asString:'int '
init:'1'.
self cr.
self cBuilder commentWith:'Checking arguments'.
self cBuilder
if:[
self nextPutString:'args_ok && '.
self cBuilder
parenthesesWith:[ self nextPutString:'not __isInteger( position )'. ].
]
then:[
self cBuilder
assign:[
self cBuilder functionCall:'__MKSTRING'
withString:'"Argument position is not integer"'.
]
to:'errorString'.
self cBuilder assign:'0' to:'args_ok'.
].
self cBuilder
if:[
self nextPutString:'args_ok && '.
self cBuilder
parenthesesWith:[
self nextPutString:'not '.
self cBuilder typeCheck:aStructFieldNode id variable:'aValue'.
].
]
then:[
self cBuilder
assign:[
self cBuilder functionCall:'__MKSTRING'
withString:'"Argument aValue is not instance of expected class"'.
]
to:'errorString'.
self cBuilder assign:'0' to:'args_ok'.
].
self cr.
self cBuilder if:'args_ok'
then:[
self cBuilder
declareId:'temp'
asString:(self declarationCString:aStructNode)
init:'__externalAddressVal( self )'.
self cBuilder
assign:[ self cBuilder valueExtraction:aStructFieldNode id variable:'aValue'. ]
to:[
self cBuilder struct:'temp'
access:aStructFieldNode name , '[__longIntVal(position)]'
].
self cBuilder return.
].
].
self cr.
self stBuilder commentWith:'If reached, primitive code has failed'.
self stBuilder makeIndent.
self nextPutString:'^self primitiveFailed: errorString.'.
self cr.
].
"Modified: / 19-12-2007 / 17:30:19 / haja"
"Created: / 08-02-2008 / 08:39:26 / janfrog"
"Modified: / 10-02-2008 / 11:16:09 / janfrog"
!
generateBasicStructAccessMethod:aStructFieldNode in:aStructNode
self stBuilder
methodFor:aStructNode name
category:'accessing'
with:[
self nextPutString:aStructFieldNode name.
self cr.
self cr.
self generateCommentFor:aStructFieldNode.
self cr.
self cBuilder
primitiveWith:[
self cBuilder
declareId:'temp'
asString:(self declarationCString:aStructNode)
init:'__externalAddressVal( self )'.
self cBuilder returnMacro:true
with:[
self cBuilder
functionCall:[ self cBuilder objectCreation:aStructFieldNode id ]
withString:[ self cBuilder struct:'temp' access:aStructFieldNode name. ].
].
].
].
self cr.
self stBuilder
methodFor:'accessing'
category:aStructNode name
with:[
self nextPutString:aStructFieldNode name , ':aValue'.
self cr.
self cr.
self generateCommentFor:aStructFieldNode.
self cr.
self stBuilder declareId:#( 'errorString' ).
self cr.
self cBuilder
primitiveWith:[
self cBuilder
if:[
self nextPutString:'not '.
self cBuilder typeCheck:aStructFieldNode id variable:'aValue'.
]
then:[
self cBuilder
assign:[
self cBuilder functionCall:'__MKSTRING'
withString:'"Argument aValue is not instance of expected class"'.
]
to:'errorString'.
]
else:[
self cBuilder
declareId:'temp'
asString:(self declarationCString:aStructNode)
init:'__externalAddressVal( self )'.
self cBuilder
assign:[ self cBuilder valueExtraction:aStructFieldNode id variable:'aValue'. ]
to:[ self cBuilder struct:'temp' access:aStructFieldNode name ].
self cBuilder return.
].
].
self cr.
self stBuilder commentWith:'If reached, primitive code has failed'.
self stBuilder makeIndent.
self nextPutString:'^self primitiveFailed: errorString.'.
self cr.
].
"Modified: / 19-12-2007 / 17:29:02 / haja"
"Created: / 08-02-2008 / 08:39:26 / janfrog"
"Modified: / 10-02-2008 / 11:16:09 / janfrog"
!
generateCallbackCFunction:aFunctionNode
self cBuilder function:(self correctMethodName:aFunctionNode name)
with:aFunctionNode arguments
return:aFunctionNode return
body:[
self cBuilder returnC:aFunctionNode return
with:[
self cBuilder methodCall:(self correctMethodName:aFunctionNode name) on:nameSpace,'::',className withArgsSize:aFunctionNode arguments.
].
].
self cr.
"Modified: / 28-11-2007 / 18:08:17 / haja"
"Created: / 08-02-2008 / 08:39:26 / janfrog"
!
generateCallbackCFunctions
prototypes do:[:aFunctionPrototypeNode|
self generateCallbackCFunction:aFunctionPrototypeNode.
].
"Modified: / 16-11-2007 / 15:26:48 / haja"
"Created: / 08-02-2008 / 08:39:26 / janfrog"
!
generateCallbackSmalltalkMethod:aFunctionPrototypeNode
self stBuilder
methodFor:(className , ' class')
category:(parseTree generatedFrom , ' - Callback Methods')
with:[
self stBuilder
method:(self correctMethodName:aFunctionPrototypeNode name)
withArgsSize:(aFunctionPrototypeNode arguments size).
self cr.
self generateCommentFor:aFunctionPrototypeNode.
].
"Modified: / 28-11-2007 / 18:06:29 / haja"
"Created: / 08-02-2008 / 08:39:26 / janfrog"
"Modified: / 10-02-2008 / 11:16:09 / janfrog"
!
generateCallbackSmalltalkMethods
prototypes do:[:aFunctionPrototypeNode|
self generateCallbackSmalltalkMethod:aFunctionPrototypeNode.
].
"Modified: / 27-11-2007 / 15:58:09 / haja"
"Created: / 08-02-2008 / 08:39:26 / janfrog"
!
generateComment:aType name:aName id:anId
self stBuilder commentWith:[
self nextPutString:aType,' ',aName,' is of type '.
self stBuilder typeDescription:anId.
self cr.
].
"Modified: / 20-12-2007 / 12:04:49 / haja"
"Created: / 08-02-2008 / 08:39:26 / janfrog"
!
generateCommentFor:aNode
(aNode references:CFunctionNode) ifTrue:[
self stBuilder commentWith:[
self cr.
(aNode arguments isEmpty) ifFalse:[
1 to:aNode arguments size do:[:pos |
self stBuilder makeIndent.
self nextPutString:'argument ',(aNode arguments at:pos) name, ' should be boxed '.
self stBuilder typeDescription:(aNode arguments at:pos) id.
self cr.
].
].
self stBuilder makeIndent.
self nextPutString:'function should return boxed '.
self stBuilder typeDescription:aNode return.
self cr.
].
^self.
].
(aNode references:CFunctionPrototypeNode) ifTrue:[
self stBuilder commentWith:[
self cr.
(aNode arguments isEmpty) ifFalse:[
1 to:aNode arguments size do:[:pos |
self stBuilder makeIndent.
self nextPutString:'arg' , pos asString , ' should be boxed '.
self stBuilder typeDescription:(aNode arguments at:pos) id.
self cr.
].
].
self stBuilder makeIndent.
self nextPutString:'function should return boxed '.
self stBuilder typeDescription:aNode return.
self cr.
].
^self.
].
(aNode references:CStructFieldNode) ifTrue:[
self stBuilder commentWith:[
self nextPutString:'structure field ' , aNode name , ' is of type '.
self stBuilder typeDescription:aNode id.
self generateLocalType:(self getIdNode:aNode id) in:parentNode.
self cr.
].
^self
].
(aNode references:CTypedefNode) ifTrue:[
self stBuilder commentWith:[
self nextPutString:'typedef ' , aNode name , ' is of type '.
self stBuilder typeDescription:aNode id.
self cr.
].
^self
].
^self error.
"Modified: / 20-12-2007 / 12:05:37 / haja"
"Created: / 08-02-2008 / 08:39:26 / janfrog"
"Modified: / 10-02-2008 / 10:50:19 / janfrog"
!
generateCompositeStructAccessMethod:aStructOrUnionFieldNode in:aStructFieldNode in:aStructNode
self stBuilder
methodFor:aStructNode name
category:'accessing'
with:[
self
nextPutString:aStructFieldNode name , '_' , aStructOrUnionFieldNode name.
self cr.
self cr.
self generateCommentFor:aStructFieldNode.
self generateCommentFor:aStructOrUnionFieldNode.
self cr.
self cBuilder
primitiveWith:[
self cBuilder
declareId:'temp'
asString:(self declarationCString:aStructNode)
init:'__externalAddressVal( self )'.
self cBuilder returnMacro:true
with:[
self cBuilder
functionCall:[ self cBuilder objectCreation:aStructOrUnionFieldNode id ]
withString:[
self cBuilder struct:'temp'
access:aStructFieldNode name , '.' , aStructOrUnionFieldNode name.
].
].
].
].
self cr.
self stBuilder
methodFor:'accessing'
category:aStructNode name
with:[
self
nextPutString:aStructFieldNode name , '_' , aStructOrUnionFieldNode name
, ':aValue'.
self cr.
self cr.
self generateCommentFor:aStructFieldNode.
self generateCommentFor:aStructOrUnionFieldNode.
self cr.
self stBuilder declareId:#( 'errorString' ).
self cr.
self cBuilder
primitiveWith:[
self cBuilder
if:[
self nextPutString:'not '.
self cBuilder typeCheck:aStructOrUnionFieldNode id variable:'aValue'.
]
then:[
self cBuilder
assign:[
self cBuilder functionCall:'__MKSTRING'
withString:'"Argument aValue is not instance of expected class"'.
]
to:'errorString'.
]
else:[
self cBuilder
declareId:'temp'
asString:(self declarationCString:aStructNode)
init:'__externalAddressVal( self )'.
self cBuilder
assign:[
self cBuilder valueExtraction:aStructOrUnionFieldNode id
variable:'aValue'.
]
to:[
self cBuilder struct:'temp'
access:aStructFieldNode name , '.' , aStructOrUnionFieldNode name
].
self cBuilder return.
].
].
self cr.
self stBuilder commentWith:'If reached, primitive code has failed'.
self stBuilder makeIndent.
self nextPutString:'^self primitiveFailed: errorString.'.
self cr.
].
"Modified: / 19-12-2007 / 17:29:46 / haja"
"Created: / 08-02-2008 / 08:39:26 / janfrog"
"Modified: / 10-02-2008 / 11:16:09 / janfrog"
!
generateCompositeStructAccessMethods:aStructFieldNode in:aStructNode
aStructFieldNode id reference fields do:[:aStructOrUnionFieldNode|
self generateCompositeStructAccessMethod:aStructOrUnionFieldNode in:aStructFieldNode in:aStructNode.
].
"Created: / 08-02-2008 / 08:39:26 / janfrog"
!
generateInclude
self cBuilder makeIndent.
self nextPutString:'#define not !!'.self cr.
self cr.
self cBuilder include:(self includeFromSourceFile:parseTree generatedFrom).
"Modified: / 23-11-2007 / 12:20:59 / haja"
"Created: / 08-02-2008 / 08:39:26 / janfrog"
!
generateLocalType:anIdNode in:aStructOrUnionNode
(anIdNode isNil not) ifTrue:[
aStructOrUnionNode fields do:[:aLocalStructOrUnionNode|
((aLocalStructOrUnionNode references:StructNode) | (aLocalStructOrUnionNode references:UnionNode)) ifTrue:[
(aLocalStructOrUnionNode name = anIdNode names last) ifTrue:[
self stBuilder typeDescription:aLocalStructOrUnionNode.
].
].
].
].
"Modified: / 20-12-2007 / 12:05:44 / haja"
"Created: / 08-02-2008 / 08:39:26 / janfrog"
!
generateStructOrUnionCreateMethod:aStructOrUnionNode
self stBuilder
methodFor:(aStructOrUnionNode name , ' class')
category:'instance creation'
with:[
self stBuilder nextPutString:'create'.
self cr.
self cr.
self stBuilder declareId:#( 'temp' ).
self cr.
self cr.
self cBuilder
primitiveWith:[
self cBuilder
declareId:'temp'
asString:''
init:[
self cBuilder functionCall:'__MKEXTERNALADDRESS'
withString:[
self cBuilder nextPutString:' ('.
self cBuilder nextPutString:aStructOrUnionNode name.
self cBuilder nextPutString:' *) '.
self cBuilder functionCall:'malloc'
withString:[
self cBuilder functionCall:'sizeof' withString:aStructOrUnionNode name.
].
].
].
self cr.
].
self cr.
self stBuilder makeIndent.
self stBuilder nextPutString:'^self newAddress: temp address.'.
self cr.
].
self cr.
"Created: / 08-02-2008 / 08:39:26 / janfrog"
"Modified: / 10-02-2008 / 11:16:09 / janfrog"
!
generateStructOrUnionCreateNULLPointerMethod:aStructOrUnionNode
self stBuilder
methodFor:(aStructOrUnionNode name , ' class')
category:'instance creation'
with:[
self stBuilder nextPutString:'createNULLPointer'.
self cr.
self cr.
self stBuilder makeIndent.
self stBuilder nextPutString:'^self newAddress: 0.'.
self cr.
].
self cr.
"Created: / 08-02-2008 / 08:39:26 / janfrog"
"Modified: / 10-02-2008 / 11:16:09 / janfrog"
!
generateStructOrUnionFreeMethod:aStructOrUnionNode
self stBuilder
methodFor:aStructOrUnionNode name
category:'freeing'
with:[
self stBuilder nextPutString:'free'.
self cr.
self cr.
self cBuilder
primitiveWith:[
self cBuilder
declareId:'temp'
asString:(self declarationCString:aStructOrUnionNode)
init:'__externalAddressVal( self )'.
self cBuilder makeIndent.
self cBuilder functionCall:'free' withString:'temp'.
self cBuilder nextPutString:';'.
self cr.
].
self cr.
self stBuilder makeIndent.
self stBuilder nextPutString:'^self beNull.'.
self cr.
].
self cr.
"Created: / 08-02-2008 / 08:39:26 / janfrog"
"Modified: / 10-02-2008 / 11:16:09 / janfrog"
! !
!SmalltalkXGenerator methodsFor:'initialization'!
initialize
"Invoked when a new instance is created."
"/ please change as required (and remove this comment)
"/ parser := nil.
"/ super initialize. -- commented since inherited method does nothing
outputStream := WriteStream on:''.
cBuilder := self defaultCBuilder.
stBuilder := self defaultStBuilder.
analyser := Analyser new.
prototypes := OrderedCollection new.
"Modified: / 20-12-2007 / 13:03:56 / haja"
"Created: / 08-02-2008 / 08:39:26 / janfrog"
! !
!SmalltalkXGenerator methodsFor:'private'!
correctMethodName:aName
(aName startsWith:'_') ifTrue:[
^'f',aName,'_callback'.
].
^aName,'_callback'.
"Modified: / 25-11-2007 / 10:48:02 / haja"
"Created: / 08-02-2008 / 08:39:26 / janfrog"
!
declarationCString:aNode
((aNode references:CEnumNode) | (aNode references:CStructNode) | (aNode references:CUnionNode)) ifTrue:[
(aNode typedef) ifFalse:[
(aNode references:CEnumNode) ifTrue:[ ^'enum ',aNode name,' *' ].
(aNode references:CStructNode) ifTrue:[ ^'struct ',aNode name,' *' ].
(aNode references:CUnionNode) ifTrue:[ ^'union ',aNode name,' *' ].
] ifTrue:[ ^aNode name,' *' ].
].
^self error.
"must be an instance of EnumNode, StructNode or UnionNode"
"Created: / 08-02-2008 / 08:39:26 / janfrog"
"Modified: / 10-02-2008 / 10:49:15 / janfrog"
!
getIdNode:aNode
^IdNodeGetter on:aNode.
"Created: / 08-02-2008 / 08:39:26 / janfrog"
!
includeFromSourceFile:aFilePath
| tmp |
tmp := aFilePath.
[
(tmp indexOfAny:'/') = 0
] whileFalse:[ tmp := tmp copyFrom:(tmp indexOfAny:'/') + 1 ].
^tmp
"Created: / 08-02-2008 / 08:39:26 / janfrog"
! !
!SmalltalkXGenerator methodsFor:'queries'!
hasLocalDeclaration:aStructOrUnionFieldNode
|anIdNode|
anIdNode := self getIdNode:aStructOrUnionFieldNode id.
(anIdNode notNil) ifTrue:[
(((anIdNode reference) references:StructNode) | ((anIdNode reference) references:UnionNode)) ifTrue:[
^anIdNode reference local
].
].
^false.
"Created: / 08-02-2008 / 08:39:26 / janfrog"
!
hasValidReturn:aReturnNode
(aReturnNode references:Cface::IdNode) ifTrue:[
(aReturnNode names first = 'void') ifTrue:[
^false.
] ifFalse:[
^true.
].
] ifFalse:[
^true.
].
"Created: / 08-02-2008 / 08:39:26 / janfrog"
!
isAnyEnum:aStructOrUnionFieldNode
((aStructOrUnionFieldNode id) references:IdNode) ifTrue:[
(((aStructOrUnionFieldNode id) reference) references:EnumNode) ifTrue:[
^true
].
].
^false.
"Created: / 08-02-2008 / 08:39:26 / janfrog"
!
isAnyStructure:aStructOrUnionFieldNode
((aStructOrUnionFieldNode id) references:IdNode) ifTrue:[
(((aStructOrUnionFieldNode id) reference) references:StructNode) ifTrue:[
^true
].
].
^false.
"Created: / 08-02-2008 / 08:39:26 / janfrog"
!
isAnyUnion:aStructOrUnionFieldNode
((aStructOrUnionFieldNode id) references:IdNode) ifTrue:[
(((aStructOrUnionFieldNode id) reference) references:UnionNode) ifTrue:[
^true
].
].
^false.
"Created: / 08-02-2008 / 08:39:26 / janfrog"
!
isArray:aStructOrUnionFieldNode
((aStructOrUnionFieldNode id) references:ArrayNode) ifTrue:[ ^true]
ifFalse:[ ^false].
"Created: / 08-02-2008 / 08:39:26 / janfrog"
!
isArrayStructure:aStructOrUnionFieldNode
((aStructOrUnionFieldNode id) references:CArrayNode) ifTrue:[
((aStructOrUnionFieldNode id) id references:IdNode) ifTrue:[
(((aStructOrUnionFieldNode id) id reference) references:CStructNode) ifTrue:[
^true
].
].
].
^false.
"Created: / 08-02-2008 / 08:39:26 / janfrog"
"Modified: / 10-02-2008 / 10:49:35 / janfrog"
!
isArrayUnion:aStructOrUnionFieldNode
((aStructOrUnionFieldNode id) references:CArrayNode) ifTrue:[
((aStructOrUnionFieldNode id) id references:IdNode) ifTrue:[
(((aStructOrUnionFieldNode id) id reference) references:CUnionNode) ifTrue:[
^true
].
].
].
^false.
"Created: / 08-02-2008 / 08:39:26 / janfrog"
"Modified: / 10-02-2008 / 10:49:43 / janfrog"
! !
!SmalltalkXGenerator methodsFor:'streaming'!
cr
self nextPut:Character cr
"Created: / 08-02-2008 / 08:39:26 / janfrog"
!
nextPut:aCharacter
outputStream nextPut:aCharacter.
"Created: / 08-02-2008 / 08:39:26 / janfrog"
!
nextPutString:aString
outputStream nextPutAll:aString.
"Created: / 08-02-2008 / 08:39:26 / janfrog"
!
space
self nextPut:Character space
"Created: / 08-02-2008 / 08:39:26 / janfrog"
!
tab
self space;
space.
"Created: / 08-02-2008 / 08:39:26 / janfrog"
!
writeToFile:aFileName
| fileStream |
fileStream := aFileName asFilename writeStream.
fileStream nextPutAll:outputStream contents.
fileStream close.
"Created: / 08-02-2008 / 08:39:27 / janfrog"
! !
!SmalltalkXGenerator methodsFor:'visiting'!
visitCArrayNode:anArrayNode
"shouldn't reach"
self error.
"Modified: / 14-11-2007 / 11:25:12 / haja"
"Created: / 10-02-2008 / 10:44:35 / janfrog"
!
visitCConstNode:aConstNode
"shouldn't reach"
self error.
"Modified: / 14-11-2007 / 11:25:08 / haja"
"Created: / 10-02-2008 / 10:44:45 / janfrog"
!
visitCEnumFieldNode:anEnumFieldNode
|enumClassName enumValueClassName|
(parentNode references:CEnumNode) ifFalse:[
self error.
].
enumClassName := mappings smalltalkClassForEnum:parentNode.
enumValueClassName := mappings smalltalkClassForEnumValue:anEnumFieldNode.
stBuilder
class:enumValueClassName superclass:enumClassName;
methodFor:enumValueClassName , ' class'
category:'accessing'
with:('intValue' , Character cr , Character tab , '^'
, anEnumFieldNode number)
"Modified: / 17-02-2008 / 20:52:26 / janfrog"
!
visitCEnumNode:anEnumNode
|enumClassName|
(anEnumNode foreign) ifTrue:[
^ self
].
enumClassName := mappings smalltalkClassForEnum:anEnumNode.
self stBuilder
class:enumClassName
superclass:'Cface::CEnum'
category:nameSpace , ' - C Enumerations'.
self cr.
parentNode := anEnumNode.
self visit:anEnumNode fields.
"Modified: / 05-12-2007 / 21:42:56 / haja"
"Created: / 10-02-2008 / 10:44:59 / janfrog"
"Modified: / 17-02-2008 / 20:52:00 / janfrog"
!
visitCFileNode:aFileNode
self stBuilder package:'__NoProject__'.
self stBuilder namespace:nameSpace.
self cr.
self stBuilder
class:#CInterface
superclass:'Object'
category:nameSpace , ' - C Interface'.
self cr.
self stBuilder primitiveDefinitionsFor:className
with:[
self cBuilder
definitionPrimitiveWith:[
self cBuilder commentWith:'here place needed include directives'.
self cr.
self generateInclude.
self cr.
(prototypes isEmpty) ifFalse:[
self cBuilder commentWith:'Callbacks'.
(self cBuilder)
commentWith:'If you need one, uncomment it';
cr.
(self cBuilder)
commentWith:[
self cr.
self generateCallbackCFunctions
];
cr.
].
].
].
self cr.
self visit:aFileNode defBody.
self cr.
self generateCallbackSmalltalkMethods.
self cr.
self nextPutString:'!!'.
self cr.
"Modified: / 28-11-2007 / 18:14:53 / haja"
"Created: / 10-02-2008 / 10:45:06 / janfrog"
!
visitCFunctionNode:aFunctionNode
self stBuilder
methodFor:(className , ' class')
category:parseTree generatedFrom
with:[
self stBuilder method:aFunctionNode name
withArgs:(aFunctionNode arguments).
self cr.
self generateCommentFor:aFunctionNode.
self cr.
self stBuilder declareId:#( 'errorString' ).
self cr.
self cBuilder
primitiveWith:[
self cr.
self cBuilder
declareId:'args_ok'
asString:'int '
init:'1'.
self cr.
(aFunctionNode arguments isEmpty) ifFalse:[
self cBuilder commentWith:'Checking arguments'.
1 to:aFunctionNode arguments size do:[:pos |
self cBuilder
if:[
self nextPutString:'args_ok && '.
self cBuilder
parenthesesWith:[
self nextPutString:'not '.
self cBuilder typeCheck:(aFunctionNode arguments at:pos) id
variable:(aFunctionNode arguments at:pos) name.
].
]
then:[
self cBuilder
assign:[
self cBuilder functionCall:'__MKSTRING'
withString:'"Argument ' , (aFunctionNode arguments at:pos) name
, ' is not instance of expected class"'.
]
to:'errorString'.
self cBuilder assign:'0' to:'args_ok'.
].
].
].
self cr.
self cBuilder commentWith:'Calling function'.
self cBuilder if:'args_ok'
then:[
self cBuilder returnMacro:(self hasValidReturn:aFunctionNode return)
with:[
self cBuilder
objectCreation:(self hasValidReturn:aFunctionNode return)
id:(aFunctionNode return)
with:[
self cBuilder functionCall:aFunctionNode name
withArgs:aFunctionNode arguments.
].
].
(self hasValidReturn:aFunctionNode return) ifFalse:[
self cBuilder return.
].
].
].
self cr.
self stBuilder commentWith:'If reached, primitive code has failed'.
self stBuilder makeIndent.
self nextPutString:'^self primitiveFailed: errorString.'.
self cr.
].
self cr.
"Modified: / 19-12-2007 / 15:51:21 / haja"
"Created: / 10-02-2008 / 10:45:12 / janfrog"
!
visitCPointerNode:aPointerNode
"shouldn't reach"
self error.
"Modified: / 14-11-2007 / 11:24:50 / haja"
"Created: / 10-02-2008 / 10:45:24 / janfrog"
!
visitCStructFieldNode:aStructFieldNode
((parentNode references:CStructNode)
or:[(parentNode references:CUnionNode)]) ifFalse:[
self error.
].
(self isArray:aStructFieldNode) ifTrue:[
((self isArrayStructure:aStructFieldNode)
| (self isArrayUnion:aStructFieldNode))
ifTrue:[
^ self generateArrayCompositeStructAccessMethods:aStructFieldNode
in:parentNode.
].
self generateArrayStructAccessMethod:aStructFieldNode in:parentNode.
] ifFalse:[
((self isAnyStructure:aStructFieldNode)
| (self isAnyUnion:aStructFieldNode))
ifTrue:[
^ self generateCompositeStructAccessMethods:aStructFieldNode
in:parentNode.
].
self generateBasicStructAccessMethod:aStructFieldNode in:parentNode.
].
"Modified: / 27-11-2007 / 18:26:51 / haja"
"Created: / 10-02-2008 / 10:45:36 / janfrog"
!
visitCStructNode:aStructNode
(aStructNode foreign | aStructNode local) ifTrue:[
^ self
].
self stBuilder
class:aStructNode name
superclass:'ExternalAddress'
category:nameSpace , ' - C Structures'.
self cr.
self stBuilder primitiveDefinitionsFor:aStructNode name
with:[
self cBuilder
definitionPrimitiveWith:[
self cBuilder commentWith:'here place needed include directives'.
self cr.
self generateInclude.
].
].
self cr.
(aStructNode fields isEmpty) ifFalse:[
self generateStructOrUnionCreateMethod:aStructNode.
self generateStructOrUnionFreeMethod:aStructNode.
].
self generateStructOrUnionCreateNULLPointerMethod:aStructNode.
parentNode := aStructNode.
self visit:aStructNode fields.
"Modified: / 06-01-2008 / 16:10:11 / haja"
"Created: / 10-02-2008 / 10:45:43 / janfrog"
!
visitCTypedefNode:aTypeDefNode
(aTypeDefNode foreign) ifTrue:[
^ self
].
self stBuilder
class:aTypeDefNode name
superclass:'ExternalAddress'
category:nameSpace , ' - C TypeDefs'.
self cr.
self stBuilder primitiveDefinitionsFor:aTypeDefNode name
with:[
self cBuilder
definitionPrimitiveWith:[
self cBuilder commentWith:'here place needed include directives'.
self cr.
self generateInclude.
].
].
self cr.
self stBuilder
methodFor:aTypeDefNode name
category:'accessing'
with:[
self nextPutString:'value'.
self cr.
self cr.
self generateCommentFor:aTypeDefNode.
self cr.
self cBuilder
primitiveWith:[
self cBuilder
declareId:'temp'
asString:aTypeDefNode name , ' *'
init:'__externalAddressVal( self )'.
self cBuilder returnMacro:true
with:[
self cBuilder
functionCall:[ self cBuilder objectCreation:aTypeDefNode id ]
withString:'temp'.
].
].
].
self cr.
self stBuilder
methodFor:aTypeDefNode name
category:'accessing'
with:[
self nextPutString:'value:aValue'.
self cr.
self cr.
self generateCommentFor:aTypeDefNode.
self cr.
self cBuilder
primitiveWith:[
self cBuilder
declareId:'temp'
asString:aTypeDefNode name , ' *'
init:'__externalAddressVal( self )'.
self cBuilder
assign:[ self cBuilder valueExtraction:aTypeDefNode id variable:'aValue'. ]
to:'temp'.
].
].
"Modified: / 19-12-2007 / 17:31:47 / haja"
"Created: / 10-02-2008 / 10:45:50 / janfrog"
!
visitCUnionNode:aUnionNode
(aUnionNode foreign) ifTrue:[
^ self
].
self stBuilder
class:aUnionNode name
superclass:'ExternalAddress'
category:nameSpace , ' - C Unions'.
self cr.
self stBuilder primitiveDefinitionsFor:aUnionNode name
with:[
self cBuilder
definitionPrimitiveWith:[
self cBuilder commentWith:'here place needed include directives'.
self cr.
self generateInclude.
].
].
self cr.
(aUnionNode fields isEmpty) ifFalse:[
self generateStructOrUnionCreateMethod:aUnionNode.
self generateStructOrUnionFreeMethod:aUnionNode.
].
self generateStructOrUnionCreateNULLPointerMethod:aUnionNode.
parentNode := aUnionNode.
self visit:aUnionNode fields.
"Modified: / 06-01-2008 / 16:10:27 / haja"
"Created: / 10-02-2008 / 10:46:54 / janfrog"
!
visitIdNode:anIdNode
"shouldn't reach"
self error.
"Modified: / 14-11-2007 / 11:24:56 / haja"
"Created: / 08-02-2008 / 08:39:26 / janfrog"
!
visitSequenceableCollection:aCollection with:aParameter
aCollection do:[:aNode |
self visit:aNode.
].
"Created: / 08-02-2008 / 08:39:26 / janfrog"
!
visitUnionFieldNode:aUnionFieldNode
(parentNode references:CUnionNode) ifFalse:[
self error.
].
self stBuilder
methodFor:parentNode name
category:'accessing'
with:[
self nextPutString:aUnionFieldNode name.
self cr.
self cr.
self generateCommentFor:aUnionFieldNode.
self cr.
self cBuilder
primitiveWith:[
self cBuilder
declareId:'temp'
asString:(self declarationCString:parentNode)
init:'__externalAddressVal( self )'.
self cBuilder returnMacro:true
with:[
self cBuilder
functionCall:[ self cBuilder objectCreation:aUnionFieldNode id ]
withString:[ self cBuilder struct:'temp' access:aUnionFieldNode name. ].
].
].
].
self cr.
self stBuilder
methodFor:'accessing'
category:parentNode name
with:[
self nextPutString:aUnionFieldNode name , ':aValue'.
self cr.
self cr.
self generateCommentFor:aUnionFieldNode.
self cr.
self cBuilder
primitiveWith:[
self cBuilder
declareId:'temp'
asString:(self declarationCString:parentNode)
init:'__externalAddressVal( self )'.
self cBuilder
assign:[ self cBuilder valueExtraction:aUnionFieldNode id variable:'aValue'. ]
to:[ self cBuilder struct:'temp' access:aUnionFieldNode name ].
].
].
"Modified: / 19-12-2007 / 17:30:01 / haja"
"Created: / 08-02-2008 / 08:39:27 / janfrog"
"Modified: / 10-02-2008 / 11:16:09 / janfrog"
! !
!SmalltalkXGenerator class methodsFor:'documentation'!
version
^ '$Header: /opt/data/cvs/cvut-fel/cface/Cface__SmalltalkXGenerator.st,v 1.1 2008/02/26 18:25:12 vranyj1 Exp $'
! !