Smalltalk/X generator improvements:
- generate C enums as SharedPools with accessors
- generate externa function calls using FFI. Not yet finished!
- CairoMappings improved.
--- a/Cface__Analyser.st Tue May 27 18:55:24 2008 +0000
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,402 +0,0 @@
-"{ Package: 'cvut:fel/cface' }"
-
-"{ NameSpace: Cface }"
-
-Object subclass:#Analyser
- instanceVariableNames:'parseTree referencedNodes typeMapCollector prototypes foreign'
- classVariableNames:''
- poolDictionaries:''
- category:'Cface-Analyser'
-!
-
-!Analyser class methodsFor:'documentation'!
-
-history
-
- "Created: / 02-11-2007 / 10:40:24 / haja"
- "Created: #visitConstNode: / 02-11-2007 / 10:41:30 / haja"
- "Created: #visitArrayNode: / 02-11-2007 / 10:42:06 / haja"
- "Created: #visitEnumFieldNode: / 02-11-2007 / 10:43:07 / haja"
- "Created: #visitEnumNode: / 02-11-2007 / 10:43:33 / haja"
- "Created: #visitFileNode: / 02-11-2007 / 10:43:58 / haja"
- "Created: #visitFunctionNode: / 02-11-2007 / 10:44:22 / haja"
- "Created: #visitPointerNode: / 02-11-2007 / 10:44:49 / haja"
- "Created: #visitStructFieldNode: / 02-11-2007 / 10:45:15 / haja"
- "Created: #visitStructNode: / 02-11-2007 / 10:45:38 / haja"
- "Created: #visitTypeDefNode: / 02-11-2007 / 10:46:04 / haja"
- "Created: #visitUnionFieldNode: / 02-11-2007 / 10:46:27 / haja"
- "Created: #visitUnionNode: / 02-11-2007 / 10:46:48 / haja"
- "Created: #parseTree / 02-11-2007 / 12:41:43 / haja"
- "Created: #parseTree: / 02-11-2007 / 12:41:43 / haja"
- "Created: #on: / 02-11-2007 / 12:43:41 / haja"
- "Created: #visitParseTree: / 02-11-2007 / 12:49:22 / haja"
- "Created: #visitSequenceableCollection:with: / 02-11-2007 / 13:37:03 / haja"
- "Created: #visitIdNode: / 02-11-2007 / 13:58:18 / haja"
- "Created: #findReference: / 02-11-2007 / 15:36:35 / haja"
- "Created: #fundamentalTypes / 02-11-2007 / 15:49:08 / haja"
- "Created: #findInTree: / 02-11-2007 / 16:04:26 / haja"
- "Created: #finder / 02-11-2007 / 16:30:26 / haja"
- "Created: #finder: / 02-11-2007 / 16:30:26 / haja"
- "Created: #initialize / 02-11-2007 / 16:30:40 / haja"
- "Created: #new / 02-11-2007 / 16:30:40 / haja"
- "Deleted: #findInTree: / 02-11-2007 / 16:34:45 / haja"
- "Created: #refFinder / 03-11-2007 / 10:27:32 / haja"
- "Deleted: #finder / 03-11-2007 / 10:27:32 / haja"
- "Created: #refFinder: / 03-11-2007 / 10:27:40 / haja"
- "Deleted: #finder: / 03-11-2007 / 10:27:40 / haja"
- "Created: #references / 05-11-2007 / 00:10:24 / haja"
- "Created: #references: / 05-11-2007 / 00:10:24 / haja"
- "Deleted: #references / 05-11-2007 / 00:14:26 / haja"
- "Deleted: #references: / 05-11-2007 / 00:14:26 / haja"
- "Created: #referenceCol / 05-11-2007 / 00:14:32 / haja"
- "Created: #referenceCol: / 05-11-2007 / 00:14:32 / haja"
- "Deleted: #referenceCol / 05-11-2007 / 00:19:31 / haja"
- "Deleted: #referenceCol: / 05-11-2007 / 00:19:31 / haja"
- "Created: #referenceNames / 05-11-2007 / 00:19:40 / haja"
- "Created: #referenceNames: / 05-11-2007 / 00:19:40 / haja"
- "Created: #removeUseless / 05-11-2007 / 00:21:17 / haja"
- "Deleted: #referenceNames / 05-11-2007 / 01:29:11 / haja"
- "Deleted: #referenceNames: / 05-11-2007 / 01:29:11 / haja"
- "Created: #referencedNodes / 05-11-2007 / 01:29:15 / haja"
- "Created: #referencedNodes: / 05-11-2007 / 01:29:15 / haja"
- "Created: #typeMapCollector / 12-11-2007 / 09:02:27 / haja"
- "Created: #typeMapCollector: / 12-11-2007 / 09:02:27 / haja"
- "Deleted: #refFinder / 12-11-2007 / 09:12:51 / haja"
- "Deleted: #refFinder: / 12-11-2007 / 09:12:52 / haja"
- "Created: #removeUselessDefinitions / 12-11-2007 / 09:14:57 / haja"
- "Deleted: #removeUseless / 12-11-2007 / 09:15:01 / haja"
- "Created: #removeUselessTypeDefs / 14-11-2007 / 15:57:27 / haja"
- "Created: #visitFunctionPrototypeNode: / 15-11-2007 / 00:26:23 / haja"
- "Created: #findLocalReference: / 15-11-2007 / 14:36:27 / haja"
- "Created: #findLocalReferences: / 15-11-2007 / 14:37:06 / haja"
- "Deleted: #findLocalReference: / 15-11-2007 / 14:37:08 / haja"
- "Deleted: #findLocalReferences: / 15-11-2007 / 14:44:21 / haja"
- "Created: #prototypes / 17-11-2007 / 09:13:01 / haja"
- "Created: #prototypes: / 17-11-2007 / 09:13:01 / haja"
- "Created: #addPrototype: / 17-11-2007 / 18:37:22 / haja"
- "Modified: #addPrototype: / 17-11-2007 / 20:42:20 / haja"
- "Modified: #initialize / 19-11-2007 / 10:12:41 / haja"
- "Modified: #visitFunctionNode: / 19-11-2007 / 10:13:33 / haja"
- "Modified: #visitStructNode: / 19-11-2007 / 10:14:10 / haja"
- "Modified: #visitTypeDefNode: / 19-11-2007 / 10:14:19 / haja"
- "Modified: #visitUnionNode: / 19-11-2007 / 10:14:29 / haja"
- "Modified: #visitFunctionPrototypeNode: / 19-11-2007 / 10:30:25 / haja"
-! !
-
-!Analyser class methodsFor:'instance creation'!
-
-new
- ^ self basicNew initialize.
-
- "Created: / 02-11-2007 / 16:30:40 / haja"
-! !
-
-!Analyser methodsFor:'accessing'!
-
-parseTree
- ^ parseTree
-
- "Created: / 02-11-2007 / 12:41:43 / haja"
-!
-
-parseTree:something
- parseTree := something.
-
- "Created: / 02-11-2007 / 12:41:43 / haja"
-!
-
-prototypes
- ^ prototypes
-
- "Created: / 17-11-2007 / 09:13:01 / haja"
-!
-
-prototypes:something
- prototypes := something.
-
- "Created: / 17-11-2007 / 09:13:01 / haja"
-!
-
-referencedNodes
- ^ referencedNodes
-
- "Created: / 05-11-2007 / 01:29:15 / haja"
-!
-
-referencedNodes:something
- referencedNodes := something.
-
- "Created: / 05-11-2007 / 01:29:15 / haja"
-!
-
-typeMapCollector
- ^ typeMapCollector
-
- "Created: / 12-11-2007 / 09:02:27 / haja"
-!
-
-typeMapCollector:something
- typeMapCollector := something.
-
- "Created: / 12-11-2007 / 09:02:27 / haja"
-! !
-
-!Analyser methodsFor:'initialization'!
-
-analyse:aDefNode
- parseTree := aDefNode.
- self removeUselessTypeDefs.
- typeMapCollector on:aDefNode.
- self visit:aDefNode.
- self removeUselessDefinitions.
- ^ prototypes
-
- "Modified: / 17-11-2007 / 09:13:36 / haja"
- "Created: / 08-02-2008 / 08:58:05 / janfrog"
-!
-
-initialize
- "Invoked when a new instance is created."
-
- "/ please change as required (and remove this comment)
- "/ parseTree := nil.
- "/ finder := nil.
-
- "/ super initialize. -- commented since inherited method does nothing
-
- referencedNodes := OrderedCollection new.
- typeMapCollector := TypeCollector new.
- prototypes := OrderedCollection new.
- foreign := false.
-
- "Created: / 02-11-2007 / 16:30:40 / haja"
- "Modified: / 19-11-2007 / 10:12:41 / haja"
- "Modified: / 12-02-2008 / 23:43:10 / janfrog"
-!
-
-on:aDefNode
-
- ^self analyse: aDefNode
-
- "Modified: / 08-02-2008 / 08:58:26 / janfrog"
-! !
-
-!Analyser methodsFor:'private'!
-
-addPrototype:aFunctionPrototypeNode
-
- "don't add same prototypes"
- "C doesn't support function override"
- prototypes do:[:aFunc|
- (aFunctionPrototypeNode name = aFunc name) ifTrue:[
- ^self.
- ].
- ].
-
- prototypes addLast:aFunctionPrototypeNode.
-
- "Created: / 17-11-2007 / 18:37:22 / haja"
- "Modified: / 17-11-2007 / 20:42:20 / haja"
-!
-
-findReference:aNames
-
- self fundamentalTypes do:[:aType| (aType = aNames last) ifTrue:[^nil] ].
-
- ^typeMapCollector find:aNames last.
-
- "Created: / 02-11-2007 / 15:36:35 / haja"
- "Modified: / 12-11-2007 / 09:13:10 / haja"
-!
-
-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: / 02-11-2007 / 15:49:08 / haja"
- "Modified: / 14-11-2007 / 15:20:31 / haja"
-!
-
-removeUselessDefinitions
-
- parseTree defBody do:[:aNode|
- ( (referencedNodes includes:aNode) | (aNode references:Cface::FunctionNode) | (aNode references:Cface::FunctionPrototypeNode) | (aNode isNil) ) ifFalse:[
- parseTree defBody remove:aNode.
- ].
- ].
-
- "Created: / 12-11-2007 / 09:14:57 / haja"
- "Modified: / 15-11-2007 / 00:42:21 / haja"
-!
-
-removeUselessTypeDefs
-
- "remove TypeDefs with name and id"
-
- parseTree defBody do:[:aNode|
- (aNode references:Cface::TypeDefNode) ifTrue:[
- (aNode id references:Cface::idNode) ifTrue:[
- (aNode name = aNode id names last) ifTrue:[
- parseTree defBody remove:aNode.
- ].
- ].
- ].
- ].
-
- "Created: / 14-11-2007 / 15:57:27 / haja"
-! !
-
-!Analyser methodsFor:'visiting'!
-
-visitSequenceableCollection:aCollection with:aParameter
- aCollection do:[:aNode |
- self visit:aNode.
- ].
-
- "Created: / 02-11-2007 / 13:37:03 / haja"
- "Modified: / 08-02-2008 / 09:07:48 / janfrog"
-! !
-
-!Analyser methodsFor:'visiting - parse tree'!
-
-visit:aParseTreeNode
- ^ aParseTreeNode acceptVisitor:self.
-
- "Created: / 08-02-2008 / 09:07:48 / janfrog"
-!
-
-visitCArrayNode:anArrayNode
- self visit:anArrayNode id.
-
- "Modified: / 02-11-2007 / 20:39:21 / haja"
- "Created: / 10-02-2008 / 10:44:35 / janfrog"
-!
-
-visitCConstNode:aConstNode
- self visit:aConstNode id.
-
- "Modified: / 02-11-2007 / 20:12:06 / haja"
- "Created: / 10-02-2008 / 10:44:45 / janfrog"
-!
-
-visitCEnumFieldNode:anEnumFieldError
- "shouldn't reach"
-
- self error.
-
- "Modified: / 14-11-2007 / 11:23:47 / haja"
- "Created: / 10-02-2008 / 10:44:52 / janfrog"
-!
-
-visitCEnumNode:arg
- ^ self
-
- "Modified: / 02-11-2007 / 20:16:23 / haja"
- "Created: / 10-02-2008 / 10:44:59 / janfrog"
-!
-
-visitCFileNode:aFileNode
- self visit:aFileNode defBody.
-
- "Modified: / 02-11-2007 / 20:13:09 / haja"
- "Created: / 10-02-2008 / 10:45:06 / janfrog"
-!
-
-visitCFunctionNode:aFunctionNode
- foreign := false.
- self visit:aFunctionNode arguments.
- self visit:aFunctionNode return.
-
- "Modified: / 19-11-2007 / 10:13:33 / haja"
- "Created: / 10-02-2008 / 10:45:12 / janfrog"
-!
-
-visitCFunctionPrototypeNode:aFunctionPrototypeNode
- foreign ifFalse:[
- self addPrototype:aFunctionPrototypeNode
- ].
- self visit:aFunctionPrototypeNode arguments.
- self visit:aFunctionPrototypeNode return.
-
- "Modified: / 19-11-2007 / 10:30:25 / haja"
- "Created: / 10-02-2008 / 10:45:18 / janfrog"
-!
-
-visitCPointerNode:aPointerNode
- self visit:aPointerNode id.
-
- "Modified: / 02-11-2007 / 13:34:27 / haja"
- "Created: / 10-02-2008 / 10:45:24 / janfrog"
-!
-
-visitCStructFieldNode:aStructFieldNode
- self visit:aStructFieldNode id.
-
- "Modified: / 02-11-2007 / 20:15:28 / haja"
- "Created: / 10-02-2008 / 10:45:36 / janfrog"
-!
-
-visitCStructNode:aStructNode
- foreign := aStructNode foreign.
- self visit:aStructNode fields.
-
- "Modified: / 19-11-2007 / 10:14:10 / haja"
- "Created: / 10-02-2008 / 10:45:43 / janfrog"
-!
-
-visitCTypedefNode:aTypeDefNode
- foreign := aTypeDefNode foreign.
- self visit:aTypeDefNode id.
-
- "Modified: / 19-11-2007 / 10:14:19 / haja"
- "Created: / 10-02-2008 / 10:45:50 / janfrog"
-!
-
-visitCUnionNode:aUnionNode
- foreign := aUnionNode foreign.
- self visit:aUnionNode fields.
-
- "Modified: / 19-11-2007 / 10:14:29 / haja"
- "Created: / 10-02-2008 / 10:46:54 / janfrog"
-!
-
-visitIdNode:anIdNode
-
- | ref |
-
- ref := (self findReference:(anIdNode names)).
-
- anIdNode reference:ref.
- (ref isNil) ifFalse:[
- referencedNodes add:ref.
- ].
-
- "Created: / 02-11-2007 / 13:58:18 / haja"
- "Modified: / 05-11-2007 / 01:28:58 / haja"
-! !
-
-!Analyser class methodsFor:'documentation'!
-
-version
- ^ '$Header: /opt/data/cvs/cvut-fel/cface/Cface__Analyser.st,v 1.1 2008/02/26 18:24:56 vranyj1 Exp $'
-! !
--- a/Cface__CCharNode.st Tue May 27 18:55:24 2008 +0000
+++ b/Cface__CCharNode.st Thu Jul 03 22:00:07 2008 +0000
@@ -12,6 +12,14 @@
!CCharNode methodsFor:'accessing'!
+ffiTypeSymbol
+ "Superclass Cface::CTypeNode says that I am responsible to implement this method"
+
+ ^ #char
+
+ "Created: / 03-07-2008 / 22:54:39 / Jan Vrany <vranyj1@fel.cvut.cz>"
+!
+
smalltalkName
^#Character
--- a/Cface__CDerivedTypeNode.st Tue May 27 18:55:24 2008 +0000
+++ b/Cface__CDerivedTypeNode.st Thu Jul 03 22:00:07 2008 +0000
@@ -3,7 +3,7 @@
"{ NameSpace: Cface }"
CTypeNode subclass:#CDerivedTypeNode
- instanceVariableNames:'smalltalkNamespace'
+ instanceVariableNames:'smalltalkNamespace smalltalkPackage smalltalkCategory'
classVariableNames:''
poolDictionaries:''
category:'Cface-C AST'
@@ -12,6 +12,19 @@
!CDerivedTypeNode methodsFor:'accessing'!
+smalltalkCategory
+ ^ smalltalkCategory ifNil:
+ [self smalltalkNamespace , ' - C Types']
+
+ "Created: / 03-07-2008 / 21:10:35 / Jan Vrany <vranyj1@fel.cvut.cz>"
+!
+
+smalltalkCategory:something
+ smalltalkCategory := something.
+
+ "Created: / 03-07-2008 / 21:10:35 / Jan Vrany <vranyj1@fel.cvut.cz>"
+!
+
smalltalkClass
^self smalltalkName
@@ -26,6 +39,15 @@
"Created: / 17-02-2008 / 20:47:32 / janfrog"
!
+smalltalkClassNameWithNamespace
+
+ ^self smalltalkNamespace isNilOrEmptyCollection
+ ifTrue:[self smalltalkClass]
+ ifFalse:[self smalltalkNamespace , '::' , self smalltalkClass]
+
+ "Created: / 03-07-2008 / 20:29:41 / Jan Vrany <vranyj1@fel.cvut.cz>"
+!
+
smalltalkNamespace
^ smalltalkNamespace
@@ -36,6 +58,18 @@
smalltalkNamespace := something.
"Created: / 17-02-2008 / 20:47:13 / janfrog"
+!
+
+smalltalkPackage
+ ^ smalltalkPackage
+
+ "Created: / 03-07-2008 / 21:10:29 / Jan Vrany <vranyj1@fel.cvut.cz>"
+!
+
+smalltalkPackage:something
+ smalltalkPackage := something.
+
+ "Created: / 03-07-2008 / 21:10:29 / Jan Vrany <vranyj1@fel.cvut.cz>"
! !
!CDerivedTypeNode methodsFor:'printing'!
--- a/Cface__CDoubleNode.st Tue May 27 18:55:24 2008 +0000
+++ b/Cface__CDoubleNode.st Thu Jul 03 22:00:07 2008 +0000
@@ -12,6 +12,14 @@
!CDoubleNode methodsFor:'accessing'!
+ffiTypeSymbol
+ "Superclass Cface::CTypeNode says that I am responsible to implement this method"
+
+ ^ #double
+
+ "Created: / 03-07-2008 / 22:54:39 / Jan Vrany <vranyj1@fel.cvut.cz>"
+!
+
smalltalkName
"Superclass says that I am responsible to implement this method"
--- a/Cface__CEnum.st Tue May 27 18:55:24 2008 +0000
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,28 +0,0 @@
-"{ Package: 'cvut:fel/cface' }"
-
-"{ NameSpace: Cface }"
-
-Object subclass:#CEnum
- instanceVariableNames:''
- classVariableNames:''
- poolDictionaries:''
- category:'Cface-Runtime'
-!
-
-
-!CEnum class methodsFor:'accessing'!
-
-intValue: intValue
-
- ^self allSubclasses
- detect:[:e|e intValue = intValue]
- ifNone:[self error:'No such value!!']
-
- "Created: / 10-02-2008 / 19:00:57 / janfrog"
-! !
-
-!CEnum class methodsFor:'documentation'!
-
-version
- ^ '$Header: /opt/data/cvs/cvut-fel/cface/Cface__CEnum.st,v 1.1 2008/02/26 18:24:02 vranyj1 Exp $'
-! !
--- a/Cface__CEnumNode.st Tue May 27 18:55:24 2008 +0000
+++ b/Cface__CEnumNode.st Thu Jul 03 22:00:07 2008 +0000
@@ -38,6 +38,14 @@
!CEnumNode methodsFor:'accessing'!
+ffiTypeSymbol
+ "Superclass Cface::CTypeNode says that I am responsible to implement this method"
+
+ ^ #int32
+
+ "Created: / 03-07-2008 / 22:54:39 / Jan Vrany <vranyj1@fel.cvut.cz>"
+!
+
foreign
^ foreign
--- a/Cface__CFloatNode.st Tue May 27 18:55:24 2008 +0000
+++ b/Cface__CFloatNode.st Thu Jul 03 22:00:07 2008 +0000
@@ -12,6 +12,14 @@
!CFloatNode methodsFor:'accessing'!
+ffiTypeSymbol
+ "Superclass Cface::CTypeNode says that I am responsible to implement this method"
+
+ ^ #float
+
+ "Created: / 03-07-2008 / 22:54:39 / Jan Vrany <vranyj1@fel.cvut.cz>"
+!
+
smalltalkName
"Superclass says that I am responsible to implement this method"
--- a/Cface__CFunctionNode.st Tue May 27 18:55:24 2008 +0000
+++ b/Cface__CFunctionNode.st Thu Jul 03 22:00:07 2008 +0000
@@ -48,10 +48,16 @@
!
kind:aSymbol
+
+ self
+ assert:(#(static method) includes: aSymbol)
+ message:'kind must be one of #static or #method'.
+
kind := aSymbol.
"Created: / 01-03-2008 / 20:30:22 / janfrog"
"Modified: / 04-03-2008 / 10:57:12 / janfrog"
+ "Modified: / 03-07-2008 / 22:06:53 / Jan Vrany <vranyj1@fel.cvut.cz>"
!
priority
@@ -85,6 +91,16 @@
"Created: / 17-02-2008 / 20:54:34 / janfrog"
!
+smalltalkClassNameWithNamespace
+
+ ^self smalltalkNamespace isNilOrEmptyCollection
+ ifTrue:[self smalltalkClass]
+ ifFalse:[self smalltalkNamespace , '::' , (self smalltalkClass ? #ExternalFunctions)]
+
+ "Created: / 03-07-2008 / 21:27:11 / Jan Vrany <vranyj1@fel.cvut.cz>"
+ "Modified: / 03-07-2008 / 22:57:28 / Jan Vrany <vranyj1@fel.cvut.cz>"
+!
+
smalltalkNamespace
^ smalltalkNamespace
@@ -120,6 +136,9 @@
[stream nextPutAll:';; Class: '; nextPutAll: self smalltalkClass; cr; next: level put: Character tab].
self smalltalkClass ifNotNil:
[stream nextPutAll:';; Selector: '; nextPutAll: self smalltalkSelector; cr; next: level put: Character tab].
+ self smalltalkClass ifNotNil:
+ [stream nextPutAll:';; Kind: '; nextPutAll: self kind; cr; next: level put: Character tab].
+
stream
nextPutAll:'(function '; nextPutAll:self cName; cr;
@@ -137,6 +156,7 @@
"Created: / 18-02-2008 / 14:27:37 / janfrog"
"Modified: / 04-03-2008 / 10:57:11 / janfrog"
+ "Modified: / 03-07-2008 / 22:10:51 / Jan Vrany <vranyj1@fel.cvut.cz>"
! !
!CFunctionNode methodsFor:'testing'!
--- a/Cface__CIntNode.st Tue May 27 18:55:24 2008 +0000
+++ b/Cface__CIntNode.st Thu Jul 03 22:00:07 2008 +0000
@@ -12,6 +12,14 @@
!CIntNode methodsFor:'accessing'!
+ffiTypeSymbol
+ "Superclass Cface::CTypeNode says that I am responsible to implement this method"
+
+ ^ #int16
+
+ "Created: / 03-07-2008 / 22:54:39 / Jan Vrany <vranyj1@fel.cvut.cz>"
+!
+
smalltalkName
"Superclass says that I am responsible to implement this method"
--- a/Cface__CLongNode.st Tue May 27 18:55:24 2008 +0000
+++ b/Cface__CLongNode.st Thu Jul 03 22:00:07 2008 +0000
@@ -10,6 +10,16 @@
!
+!CLongNode methodsFor:'accessing'!
+
+ffiTypeSymbol
+ "Superclass Cface::CModifierNode says that I am responsible to implement this method"
+
+ ^#int32
+
+ "Created: / 03-07-2008 / 23:02:09 / Jan Vrany <vranyj1@fel.cvut.cz>"
+! !
+
!CLongNode methodsFor:'printing'!
printOn: stream indent: indent
--- a/Cface__CModifierNode.st Tue May 27 18:55:24 2008 +0000
+++ b/Cface__CModifierNode.st Thu Jul 03 22:00:07 2008 +0000
@@ -12,6 +12,13 @@
!CModifierNode methodsFor:'accessing'!
+ffiTypeSymbol
+
+ ^self subclassResponsibility
+
+ "Created: / 03-07-2008 / 22:59:10 / Jan Vrany <vranyj1@fel.cvut.cz>"
+!
+
type
^ type
--- a/Cface__CPointerNode.st Tue May 27 18:55:24 2008 +0000
+++ b/Cface__CPointerNode.st Thu Jul 03 22:00:07 2008 +0000
@@ -48,6 +48,16 @@
!CPointerNode methodsFor:'accessing'!
+ffiTypeSymbol
+ "Superclass Cface::CTypeNode says that I am responsible to implement this method"
+
+ ^(type isKindOf: CCharNode)
+ ifTrue:[#charPointer]
+ ifFalse:[#pointer]
+
+ "Created: / 03-07-2008 / 22:54:39 / Jan Vrany <vranyj1@fel.cvut.cz>"
+!
+
type
^ type
--- a/Cface__CStruct.st Tue May 27 18:55:24 2008 +0000
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,17 +0,0 @@
-"{ Package: 'cvut:fel/cface' }"
-
-"{ NameSpace: Cface }"
-
-Object subclass:#CStruct
- instanceVariableNames:''
- classVariableNames:''
- poolDictionaries:''
- category:'Cface-Runtime'
-!
-
-
-!CStruct class methodsFor:'documentation'!
-
-version
- ^ '$Header: /opt/data/cvs/cvut-fel/cface/Cface__CStruct.st,v 1.1 2008/02/26 18:25:38 vranyj1 Exp $'
-! !
--- a/Cface__CStructNode.st Tue May 27 18:55:24 2008 +0000
+++ b/Cface__CStructNode.st Thu Jul 03 22:00:07 2008 +0000
@@ -46,6 +46,14 @@
!CStructNode methodsFor:'accessing'!
+ffiTypeSymbol
+ "Superclass Cface::CTypeNode says that I am responsible to implement this method"
+
+ ^ #struct
+
+ "Created: / 03-07-2008 / 22:54:39 / Jan Vrany <vranyj1@fel.cvut.cz>"
+!
+
fields
^ fields
--- a/Cface__CTypeNode.st Tue May 27 18:55:24 2008 +0000
+++ b/Cface__CTypeNode.st Thu Jul 03 22:00:07 2008 +0000
@@ -10,6 +10,14 @@
!
+!CTypeNode methodsFor:'accessing'!
+
+ffiTypeSymbol
+ ^ self subclassResponsibility
+
+ "Created: / 03-07-2008 / 22:54:39 / Jan Vrany <vranyj1@fel.cvut.cz>"
+! !
+
!CTypeNode methodsFor:'converting'!
resolved
--- a/Cface__CTypedefNode.st Tue May 27 18:55:24 2008 +0000
+++ b/Cface__CTypedefNode.st Thu Jul 03 22:00:07 2008 +0000
@@ -38,6 +38,13 @@
!CTypedefNode methodsFor:'accessing'!
+ffiTypeSymbol
+
+ ^type ffiTypeSymbol
+
+ "Created: / 03-07-2008 / 22:40:25 / Jan Vrany <vranyj1@fel.cvut.cz>"
+!
+
foreign
^ foreign
--- a/Cface__CUnion.st Tue May 27 18:55:24 2008 +0000
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,17 +0,0 @@
-"{ Package: 'cvut:fel/cface' }"
-
-"{ NameSpace: Cface }"
-
-Object subclass:#CUnion
- instanceVariableNames:''
- classVariableNames:''
- poolDictionaries:''
- category:'Cface-Runtime'
-!
-
-
-!CUnion class methodsFor:'documentation'!
-
-version
- ^ '$Header: /opt/data/cvs/cvut-fel/cface/Cface__CUnion.st,v 1.1 2008/02/26 18:25:47 vranyj1 Exp $'
-! !
--- a/Cface__CUnionNode.st Tue May 27 18:55:24 2008 +0000
+++ b/Cface__CUnionNode.st Thu Jul 03 22:00:07 2008 +0000
@@ -55,6 +55,14 @@
!CUnionNode methodsFor:'accessing'!
+ffiTypeSymbol
+ "Superclass Cface::CTypeNode says that I am responsible to implement this method"
+
+ ^ #struct
+
+ "Created: / 03-07-2008 / 22:54:39 / Jan Vrany <vranyj1@fel.cvut.cz>"
+!
+
fields
^ fields
--- a/Cface__CUnsignedNode.st Tue May 27 18:55:24 2008 +0000
+++ b/Cface__CUnsignedNode.st Thu Jul 03 22:00:07 2008 +0000
@@ -10,6 +10,16 @@
!
+!CUnsignedNode methodsFor:'accessing'!
+
+ffiTypeSymbol
+ "Superclass Cface::CModifierNode says that I am responsible to implement this method"
+
+ ^'u', type ffiTypeSymbol
+
+ "Created: / 03-07-2008 / 22:59:26 / Jan Vrany <vranyj1@fel.cvut.cz>"
+! !
+
!CUnsignedNode methodsFor:'printing'!
printOn: stream indent: indent
--- a/Cface__CUserDefinedTypeNode.st Tue May 27 18:55:24 2008 +0000
+++ b/Cface__CUserDefinedTypeNode.st Thu Jul 03 22:00:07 2008 +0000
@@ -73,6 +73,14 @@
!CUserDefinedTypeNode methodsFor:'accessing'!
+ffiTypeSymbol
+ "Superclass Cface::CTypeNode says that I am responsible to implement this method"
+
+ ^type ffiTypeSymbol
+
+ "Created: / 03-07-2008 / 22:55:48 / Jan Vrany <vranyj1@fel.cvut.cz>"
+!
+
type
^ type
--- a/Cface__CVoidNode.st Tue May 27 18:55:24 2008 +0000
+++ b/Cface__CVoidNode.st Thu Jul 03 22:00:07 2008 +0000
@@ -12,6 +12,14 @@
!CVoidNode methodsFor:'accessing'!
+ffiTypeSymbol
+ "Superclass Cface::CTypeNode says that I am responsible to implement this method"
+
+ ^ #void
+
+ "Created: / 03-07-2008 / 22:54:39 / Jan Vrany <vranyj1@fel.cvut.cz>"
+!
+
smalltalkName
"Superclass says that I am responsible to implement this method"
--- a/Cface__CairoMapping.st Tue May 27 18:55:24 2008 +0000
+++ b/Cface__CairoMapping.st Thu Jul 03 22:00:07 2008 +0000
@@ -66,26 +66,24 @@
"Created: / 17-02-2008 / 20:51:26 / janfrog"
!
+smalltalkPackage
+
+ ^#'stx:goodies/libcairo'
+
+ "Created: / 03-07-2008 / 21:14:47 / Jan Vrany <vranyj1@fel.cvut.cz>"
+!
+
smalltalkSelectorForFunction: cFunction
- |cairoName |
-
- cairoName := cFunction cName.
- cFunction arguments size >= 1 ifTrue:
- [|firstArgType|
- firstArgType := cFunction arguments first type.
- (firstArgType isCPointerNode and:[firstArgType type isCStructNode])
- ifTrue:
- [|firstArgTypeName|
- firstArgTypeName := firstArgType type cName.
- firstArgTypeName first = $_ ifTrue:
- [firstArgTypeName := firstArgTypeName copyFrom: 2].
- (cairoName startsWith:firstArgTypeName) ifTrue:
- [cairoName := cairoName copyFrom:firstArgTypeName size + 2]]].
- ^self smalltalkize: cairoName.
+ | selector |
+ selector := super smalltalkSelectorForFunction: cFunction.
+ (cFunction cName startsWith:'cairo_')
+ ifTrue:[selector := (cFunction cName at: 7) asString , (selector copyFrom: 7)].
+ ^selector
"Created: / 17-02-2008 / 22:16:03 / janfrog"
"Modified: / 18-02-2008 / 14:58:43 / janfrog"
+ "Modified: / 03-07-2008 / 22:34:37 / Jan Vrany <vranyj1@fel.cvut.cz>"
! !
!CairoMapping class methodsFor:'documentation'!
--- a/Cface__Generator.st Tue May 27 18:55:24 2008 +0000
+++ b/Cface__Generator.st Thu Jul 03 22:00:07 2008 +0000
@@ -3,9 +3,7 @@
"{ NameSpace: Cface }"
CNodeVisitor subclass:#Generator
- instanceVariableNames:'platform mappings definitions outputFile outputStream cBuilder
- stBuilder parser inputStream parseTree analyser className
- prototypes parentNode nameSpace'
+ instanceVariableNames:'changeset'
classVariableNames:''
poolDictionaries:''
category:'Cface-Generators'
@@ -217,6 +215,16 @@
"Created: #generateStructOrUnionCreateNULLPointerMethod: / 06-01-2008 / 16:09:47 / haja"
! !
+!Generator methodsFor:'initialization'!
+
+initialize
+
+ super initialize.
+ changeset := ChangeSet new
+
+ "Created: / 03-07-2008 / 20:08:58 / Jan Vrany <vranyj1@fel.cvut.cz>"
+! !
+
!Generator class methodsFor:'documentation'!
version
--- a/Cface__GeneratorCommand.st Tue May 27 18:55:24 2008 +0000
+++ b/Cface__GeneratorCommand.st Thu Jul 03 22:00:07 2008 +0000
@@ -10,6 +10,44 @@
!
+!GeneratorCommand class methodsFor:'projects'!
+
+generateCairo
+
+ |cairoDir cairoDefFile cairoPdfDefFile|
+
+ cairoDir := '/home/janfrog/Projects/Cface/libcairo/'.
+ cairoDefFile := cairoDir , 'cairo.h.def'.
+
+ Cface::Platform theInstance generatorCommand
+ definitions: cairoDefFile asFilename;
+ mappings: Cface::CairoMapping new;
+ process.
+
+ cairoPdfDefFile := cairoDir , 'cairo-pdf.h.def'.
+
+ Cface::Platform theInstance generatorCommand
+ definitions: cairoPdfDefFile asFilename;
+ mappings: Cface::CairoMapping new;
+ process
+
+ "Created: / 03-07-2008 / 23:55:14 / Jan Vrany <vranyj1@fel.cvut.cz>"
+!
+
+generateSubversion
+
+ |svnDir svnDefFile|
+
+ svnDir := '/home/janfrog/Projects/Cface/libsvn/'.
+ svnDefFile := svnDir , 'svn_client.h.def'.
+
+ Cface::Platform theInstance generatorCommand
+ definitions: svnDefFile asFilename;
+ process
+
+ "Created: / 03-07-2008 / 23:55:54 / Jan Vrany <vranyj1@fel.cvut.cz>"
+! !
+
!GeneratorCommand methodsFor:'accessing'!
definitions
@@ -72,10 +110,10 @@
self platform typeResolver process: definitions.
self platform typeMapper process: definitions using: self mappings.
- self halt.
+ ^self platform generator process: definitions.
"Created: / 18-02-2008 / 15:25:54 / janfrog"
- "Modified: / 27-05-2008 / 14:23:16 / Jan Vrany <vranyj1@fel.cvut.cz>"
+ "Modified: / 03-07-2008 / 21:00:44 / Jan Vrany <vranyj1@fel.cvut.cz>"
! !
!GeneratorCommand class methodsFor:'documentation'!
--- a/Cface__SmalltalkXGenerator.st Tue May 27 18:55:24 2008 +0000
+++ b/Cface__SmalltalkXGenerator.st Thu Jul 03 22:00:07 2008 +0000
@@ -52,1575 +52,127 @@
"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'!
+!SmalltalkXGenerator methodsFor:'processing'!
-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.
- ].
+process: node
- "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"
-!
+ super process: node.
+ ^changeset
-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"
+ "Created: / 03-07-2008 / 21:01:19 / Jan Vrany <vranyj1@fel.cvut.cz>"
! !
!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|
+visitCEnumNode: cEnumNode
- (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"
-!
+ (changeset add: ClassDefinitionChange new)
+ superClassName:
+ SharedPool fullName;
+ className:
+ cEnumNode smalltalkClassNameWithNamespace;
+ classVariableNames:
+ (String streamContents:
+ [:s|
+ cEnumNode values do:
+ [:cEnumValueNode|
+ s nextPutAll: cEnumValueNode cName; space]]);
+ category:
+ cEnumNode smalltalkCategory;
+ package:
+ cEnumNode smalltalkPackage.
-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"
-!
+ (changeset add: MethodDefinitionChange new)
+ className:
+ cEnumNode smalltalkClassNameWithNamespace, ' class';
+ selector:
+ #initialize;
+ category:
+ #initialization;
+ source:
+ (String streamContents:
+ [:s|
+ s nextPutAll:'initialize' ; cr; cr.
+ cEnumNode values do:
+ [:cEnumValueNode|
+ s
+ tab;
+ nextPutAll: cEnumValueNode cName;
+ nextPutAll: ' := ';
+ nextPutAll: cEnumValueNode intValue;
+ nextPut:$.; cr]]).
-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.
+ cEnumNode values do:
+ [:cEnumValueNode|
+ (changeset add: MethodDefinitionChange new)
+ className:
+ cEnumNode smalltalkClassNameWithNamespace, ' class';
+ selector:
+ cEnumValueNode cName asSymbol;
+ category:
+ #constants;
+ source:
+ (String streamContents:
+ [:s|
+ s nextPutAll: cEnumValueNode cName; cr; cr.
+ s tab; nextPut:$^; nextPutAll: cEnumValueNode cName])]
- "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"
+ "Created: / 03-07-2008 / 20:10:34 / Jan Vrany <vranyj1@fel.cvut.cz>"
+ "Modified: / 03-07-2008 / 22:07:20 / Jan Vrany <vranyj1@fel.cvut.cz>"
!
-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"
-!
+visitCFunctionNode:functionNode
-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.
+ (changeset add: MethodDefinitionChange new)
+ className: functionNode smalltalkClassNameWithNamespace , ' class';
+ category: 'external functions';
+ selector: functionNode smalltalkSelector;
+ source:
+ (String streamContents:
+ [:s|
+ s
+ nextPutAll: functionNode smalltalkSelector; cr; cr; tab;
+ nextPutAll: '<cdecl:';
+ space;
+ nextPutAll: functionNode return ffiTypeSymbol;
+ space;
+ nextPutAll: functionNode cName;
+ space;
+ nextPut:$(;
+ space.
+ functionNode arguments do:
+ [:argument|
+ s nextPutAll: argument type ffiTypeSymbol; space].
+ s
+ nextPut:$);
+ space;
+ nextPut:$>])
- "Modified: / 06-01-2008 / 16:10:11 / haja"
- "Created: / 10-02-2008 / 10:45:43 / janfrog"
+ "Created: / 03-07-2008 / 21:26:42 / Jan Vrany <vranyj1@fel.cvut.cz>"
+ "Modified: / 03-07-2008 / 23:42:47 / Jan Vrany <vranyj1@fel.cvut.cz>"
!
-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'.
- ].
- ].
+visitCStructNode: cStructNode
+
+ cStructNode isAnonymous ifTrue:[^self].
- "Modified: / 19-12-2007 / 17:31:47 / haja"
- "Created: / 10-02-2008 / 10:45:50 / janfrog"
+ (changeset add: ClassDefinitionChange new)
+ superClassName:
+ ExternalStructure fullName;
+ className:
+ cStructNode smalltalkClassNameWithNamespace;
+ category:
+ cStructNode smalltalkCategory;
+ package:
+ cStructNode smalltalkPackage.
+
+ "Created: / 03-07-2008 / 21:31:31 / Jan Vrany <vranyj1@fel.cvut.cz>"
+ "Modified: / 03-07-2008 / 23:42:54 / Jan Vrany <vranyj1@fel.cvut.cz>"
!
-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"
-!
+visitCTypedefNode: typedefNode
-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"
+ "Created: / 03-07-2008 / 22:00:49 / Jan Vrany <vranyj1@fel.cvut.cz>"
! !
!SmalltalkXGenerator class methodsFor:'documentation'!
--- a/Cface__TypeMapper.st Tue May 27 18:55:24 2008 +0000
+++ b/Cface__TypeMapper.st Thu Jul 03 22:00:07 2008 +0000
@@ -66,11 +66,14 @@
cEnum isAnonymous ifFalse:
[cEnum
smalltalkNamespace: mappings smalltalkNamespace;
+ smalltalkPackage: (mappings smalltalkPackage);
smalltalkClass: (mappings smalltalkClassForEnum: cEnum)].
+
super visitCEnumNode: cEnum
"Created: / 17-02-2008 / 20:58:53 / janfrog"
"Modified: / 17-02-2008 / 22:24:58 / janfrog"
+ "Modified: / 03-07-2008 / 21:16:08 / Jan Vrany <vranyj1@fel.cvut.cz>"
!
visitCEnumValueNode: cEnum
@@ -86,12 +89,15 @@
visitCFunctionNode: cFunction
cFunction
+ kind: (mappings kindForFunction:cFunction);
+
smalltalkNamespace: mappings smalltalkNamespace;
smalltalkClass: (mappings smalltalkClassForFunction: cFunction);
smalltalkSelector: (mappings smalltalkSelectorForFunction: cFunction).
super visitCFunctionNode: cFunction
"Created: / 17-02-2008 / 22:10:44 / janfrog"
+ "Modified: / 03-07-2008 / 22:10:24 / Jan Vrany <vranyj1@fel.cvut.cz>"
!
visitCStructFieldNode: cEnum
@@ -108,11 +114,13 @@
cStruct isAnonymous ifFalse:
[cStruct
smalltalkNamespace: mappings smalltalkNamespace;
+ smalltalkPackage: (mappings smalltalkPackage);
smalltalkClass: (mappings smalltalkClassForStruct: cStruct)].
super visitCStructNode: cStruct
"Created: / 17-02-2008 / 21:12:55 / janfrog"
"Modified: / 17-02-2008 / 22:24:51 / janfrog"
+ "Modified: / 03-07-2008 / 21:43:58 / Jan Vrany <vranyj1@fel.cvut.cz>"
!
visitCUnionNode: cUnion
@@ -120,10 +128,12 @@
cUnion isAnonymous ifFalse:
[cUnion
smalltalkNamespace: mappings smalltalkNamespace;
+ smalltalkPackage: (mappings smalltalkPackage);
smalltalkClass: (mappings smalltalkClassForStruct: cUnion)].
super visitCUnionNode: cUnion
"Created: / 17-02-2008 / 22:25:27 / janfrog"
+ "Modified: / 03-07-2008 / 21:16:36 / Jan Vrany <vranyj1@fel.cvut.cz>"
! !
!TypeMapper class methodsFor:'documentation'!
--- a/Cface__TypeMapping.st Tue May 27 18:55:24 2008 +0000
+++ b/Cface__TypeMapping.st Thu Jul 03 22:00:07 2008 +0000
@@ -3,7 +3,7 @@
"{ NameSpace: Cface }"
Object subclass:#TypeMapping
- instanceVariableNames:''
+ instanceVariableNames:'smalltalkPackage'
classVariableNames:''
poolDictionaries:''
category:'Cface-Mappings'
@@ -12,6 +12,25 @@
!TypeMapping methodsFor:'accessing'!
+kindForFunction:cFunction
+
+ |firstArgType|
+
+ cFunction arguments isEmpty ifTrue:[^#static].
+ firstArgType := cFunction arguments first type.
+ ^(firstArgType isCPointerNode and:[firstArgType type isCStructNode])
+ ifTrue:[#method]
+ ifFalse:[#static]
+
+
+
+
+
+ "Answers class which should contain function call"
+
+ "Created: / 03-07-2008 / 22:09:41 / Jan Vrany <vranyj1@fel.cvut.cz>"
+!
+
smalltalkClassForEnum:cEnum
^ self smalltalkClassForType:cEnum
@@ -74,16 +93,34 @@
"Created: / 17-02-2008 / 20:51:05 / janfrog"
!
+smalltalkPackage
+ ^ smalltalkPackage
+
+ "Created: / 03-07-2008 / 21:12:55 / Jan Vrany <vranyj1@fel.cvut.cz>"
+!
+
+smalltalkPackage:package
+ smalltalkPackage := package.
+
+ "Created: / 03-07-2008 / 21:12:55 / Jan Vrany <vranyj1@fel.cvut.cz>"
+!
+
smalltalkSelectorForFunction:cFunction
- ^self smalltalkize: cFunction cName
-
-
-
-
- "Answers class which should contain function call"
+ ^String streamContents:
+ [:s|
+ s nextPutAll:(self smalltalkize: cFunction cName).
+ cFunction arguments size > 1 ifTrue:
+ [s nextPut:$:].
+ cFunction arguments size > 2 ifTrue:
+ [(cFunction arguments copyFrom:2) do:
+ [:argument|
+ s
+ nextPutAll: (self smalltalkize: argument cName);
+ nextPut:$:]]]
"Created: / 17-02-2008 / 22:15:44 / janfrog"
+ "Modified: / 03-07-2008 / 22:30:01 / Jan Vrany <vranyj1@fel.cvut.cz>"
! !
!TypeMapping methodsFor:'private - utilities'!
@@ -102,11 +139,12 @@
^outputStream contents.
"
- Cface::Mappings new smalltalkize:'test'
- Cface::Mappings new smalltalkize:'test_of_smalltalkize'
+ Cface::TypeMapping new smalltalkize:'test'
+ Cface::TypeMapping new smalltalkize:'test_of_smalltalkize'
"
"Created: / 08-02-2008 / 09:34:40 / janfrog"
+ "Modified: / 03-07-2008 / 22:31:24 / Jan Vrany <vranyj1@fel.cvut.cz>"
! !
!TypeMapping class methodsFor:'documentation'!