SystemOrganization addCategory: #'AST-Compiler'! RBProgramNodeVisitor subclass: #RBAstTranslator instanceVariableNames: 'encoder' classVariableNames: '' poolDictionaries: '' category: 'AST-Compiler'! !RBAstTranslator classSide methodsFor: 'instance creation' stamp: 'lr 12/15/2009 11:53'! encoder: anEncoder ^ self new encoder: anEncoder; yourself! ! !RBAstTranslator methodsFor: 'visiting' stamp: 'lr 12/15/2009 11:03'! acceptArrayNode: anArrayNode ^ BraceNode new elements: (anArrayNode statements collect: [ :each | self visitNode: each ]) sourceLocations: (anArrayNode statements collect: [ :each | each start ])! ! !RBAstTranslator methodsFor: 'visiting' stamp: 'lr 12/16/2009 20:08'! acceptAssignmentNode: anAssignmentNode | variable value assignment | assignment := AssignmentNode new variable: (self visitNode: anAssignmentNode variable) value: (self visitNode: anAssignmentNode value) from: self encoder sourceRange: anAssignmentNode sourceInterval. assignment variable nowHasDef. ^ assignment! ! !RBAstTranslator methodsFor: 'visiting' stamp: 'lr 12/16/2009 18:47'! acceptBlockNode: aBlockNode | block arguments temporaries statements | block := BlockNode new. arguments := aBlockNode arguments collect: [ :each | self encoder bindBlockArg: each name within: block ]. temporaries := aBlockNode body temporaries collect: [ :each | self encoder bindBlockTemp: each name within: block ]. statements := aBlockNode body statements collect: [ :each | self visitNode: each ]. statements isEmpty ifTrue: [ statements addLast: (arguments isEmpty ifTrue: [ ParseNode classPool at: #NodeNil ] ifFalse: [ self encoder encodeVariable: arguments last name ]) ]. block arguments: arguments statements: statements returns: aBlockNode body lastIsReturn from: self encoder; temporaries: temporaries. block noteSourceRangeStart: aBlockNode start end: aBlockNode stop encoder: self encoder. arguments do: [ :variable | variable scope: -1 ]. temporaries do: [ :variable | variable scope: -1 ]. ^ block! ! !RBAstTranslator methodsFor: 'visiting' stamp: 'lr 12/16/2009 10:41'! acceptCascadeNode: aCascadeNode ^ CascadeNode new receiver: (self visitNode: aCascadeNode receiver) messages: (aCascadeNode messages collect: [ :each | (self visitNode: each) receiver: nil ])! ! !RBAstTranslator methodsFor: 'visiting' stamp: 'lr 12/15/2009 15:10'! acceptLiteralArrayNode: aRBLiteralArrayNode ^ self encoder encodeLiteral: aRBLiteralArrayNode value! ! !RBAstTranslator methodsFor: 'visiting' stamp: 'lr 12/16/2009 10:54'! acceptLiteralNode: aLiteralNode aLiteralNode value == nil ifTrue: [ ^ ParseNode classPool at: #NodeNil ]. aLiteralNode value == true ifTrue: [ ^ ParseNode classPool at: #NodeTrue ]. aLiteralNode value == false ifTrue: [ ^ ParseNode classPool at: #NodeFalse ]. ^ self encoder encodeLiteral: aLiteralNode value! ! !RBAstTranslator methodsFor: 'visiting' stamp: 'lr 12/16/2009 10:40'! acceptMessageNode: aMessageNode ^ MessageNode new receiver: (self visitNode: aMessageNode receiver) selector: aMessageNode selector arguments: (aMessageNode arguments collect: [ :each | self visitNode: each ]) precedence: aMessageNode selector precedence from: self encoder sourceRange: aMessageNode sourceInterval! ! !RBAstTranslator methodsFor: 'visiting' stamp: 'lr 12/16/2009 11:16'! acceptMethodNode: aMethodNode | method properties arguments temporaries pragmas statements block | self encoder selector: aMethodNode selector. method := self encoder methodNodeClass new. method sourceText: aMethodNode source. properties := AdditionalMethodState new. properties selector: aMethodNode selector. arguments := aMethodNode arguments collect: [ :each | (self encoder bindArg: each name) beMethodArg ]. temporaries := aMethodNode body temporaries collect: [ :each | self encoder bindTemp: each name ]. aMethodNode pragmas do: [ :each | properties := properties copyWith: (self visitNode: each ) ]. statements := aMethodNode body statements collect: [ :each | self visitNode: each ]. statements isEmpty ifTrue: [ statements addLast: (self encoder encodeVariable: 'self') ]. block := BlockNode new. block arguments: Array new statements: statements returns: aMethodNode lastIsReturn from: self encoder. block returnSelfIfNoOther: self encoder. ^ method selector: aMethodNode selector arguments: arguments precedence: aMethodNode selector precedence temporaries: temporaries block: block encoder: self encoder primitive: aMethodNode primitiveNumber properties: properties! ! !RBAstTranslator methodsFor: 'visiting' stamp: 'lr 12/16/2009 10:36'! acceptPragmaNode: aPragmaNode | pragma name module | pragma := Pragma keyword: aPragmaNode selector arguments: (aPragmaNode arguments collect: [ :each | each value ]) asArray. (aPragmaNode isPrimitive and: [ pragma arguments first isString ]) ifTrue: [ name := pragma arguments at: 1. module := pragma arguments at: 2 ifAbsent: [ nil ]. self encoder litIndex: (Array with: (module ifNotNil: [ module asSymbol ]) with: name asSymbol with: 0 with: 0) ]. ^ pragma! ! !RBAstTranslator methodsFor: 'visiting' stamp: 'lr 12/15/2009 12:24'! acceptReturnNode: aReturnNode ^ ReturnNode new expr: (self visitNode: aReturnNode value) encoder: self encoder sourceRange: (aReturnNode start isNil ifFalse: [ aReturnNode sourceInterval ])! ! !RBAstTranslator methodsFor: 'visiting' stamp: 'lr 12/16/2009 10:54'! acceptVariableNode: aVariableNode aVariableNode name = 'self' ifTrue: [ ^ ParseNode classPool at: #NodeSelf ]. aVariableNode name = 'super' ifTrue: [ ^ ParseNode classPool at: #NodeSuper ]. aVariableNode name = 'thisContext' ifTrue: [ ^ ParseNode classPool at: #NodeThisContext ]. ^ self encoder encodeVariable: aVariableNode name sourceRange: aVariableNode sourceInterval ifUnknown: [ self error: 'Unknow variable' ]! ! !RBAstTranslator methodsFor: 'accessing' stamp: 'lr 12/15/2009 11:54'! encoder ^ encoder! ! !RBAstTranslator methodsFor: 'accessing' stamp: 'lr 12/15/2009 11:53'! encoder: anEncoder encoder := anEncoder! ! Object subclass: #RBCompiler instanceVariableNames: 'source requestor class category context parser failBlock' classVariableNames: '' poolDictionaries: '' category: 'AST-Compiler'! !RBCompiler methodsFor: 'public' stamp: 'lr 12/15/2009 11:53'! compile: aString in: aClass classified: aCategory notifying: aRequestor ifFail: aBlock | parseTree encoder translator methodNode | self setSource: aString; setClass: aClass; setCategory: aCategory; setRequestor: aRequestor; setFailBlock: aBlock. parseTree := self parserClass parseMethod: source onError: [ :msg :pos | ^ self notify: msg at: pos ]. encoder := self encoderClass new. encoder init: class context: context notifying: requestor. translator := RBAstTranslator encoder: encoder. ^ translator visitNode: parseTree! ! !RBCompiler methodsFor: 'configuration' stamp: 'lr 12/15/2009 11:50'! encoderClass ^ EncoderForV3PlusClosures! ! !RBCompiler methodsFor: 'errors' stamp: 'lr 12/15/2009 11:46'! notify: aString at: anInteger ^ requestor isNil ifTrue: [ SyntaxErrorNotification inClass: class category: category withCode: (source copyReplaceFrom: anInteger to: anInteger - 1 with: aString) doitFlag: false errorMessage: aString location: anInteger ] ifFalse: [ requestor notify: aString at: anInteger in: source ]! ! !RBCompiler methodsFor: 'configuration' stamp: 'lr 12/15/2009 11:31'! parserClass ^ RBParser! ! !RBCompiler methodsFor: 'initialization' stamp: 'lr 12/15/2009 11:38'! setCategory: aSymbol category := aSymbol! ! !RBCompiler methodsFor: 'initialization' stamp: 'lr 12/15/2009 11:41'! setClass: aClass class := aClass! ! !RBCompiler methodsFor: 'initialization' stamp: 'lr 12/15/2009 11:41'! setContext: aContext context := aContext! ! !RBCompiler methodsFor: 'initialization' stamp: 'lr 12/15/2009 11:43'! setFailBlock: aBlock failBlock := aBlock! ! !RBCompiler methodsFor: 'initialization' stamp: 'lr 12/15/2009 11:37'! setRequestor: anObject requestor := anObject! ! !RBCompiler methodsFor: 'initialization' stamp: 'lr 12/15/2009 11:40'! setSource: aStringOrTextOrStream source := aStringOrTextOrStream isText ifTrue: [ aStringOrTextOrStream asString ] ifFalse: [ aStringOrTextOrStream isStream ifTrue: [ aStringOrTextOrStream contents ] ifFalse: [ aStringOrTextOrStream ] ]! ! TestCase subclass: #RBCompilerTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'AST-Compiler'! !RBCompilerTest methodsFor: 'requestor' stamp: 'lr 12/15/2009 15:26'! addWarning: aString Transcript show: aString; cr.! ! !RBCompilerTest methodsFor: 'utilties' stamp: 'lr 12/16/2009 11:05'! assertClass: aClass aClass selectors asSortedCollection do: [ :each | self assertClass: aClass selector: each ] displayingProgress: aClass name! ! !RBCompilerTest methodsFor: 'utilties' stamp: 'lr 12/16/2009 20:00'! assertClass: aClass selector: aSelector | metodNode sourceCode | " skip trait methods, due to a trait bug " (aClass includesLocalSelector: aSelector) ifFalse: [ ^ self ]. " skip the float class, due to a bug in CompiledMethod>>#= " (aClass = Float class or: [ aClass traits notEmpty ]) ifTrue: [ ^ self ]. metodNode := self compilerClass new compile: (aClass sourceCodeAt: aSelector) in: aClass classified: nil notifying: self ifFail: nil. self assert: (aClass compiledMethodAt: aSelector) = metodNode generate description: aClass name , '>>#' , aSelector resumable: true! ! !RBCompilerTest methodsFor: 'utilties' stamp: 'lr 12/15/2009 15:25'! assertImage "self new assertImage" Smalltalk allClasses do: [ :class | self assertClass: class ] displayingProgress: 'Testing all Image' ! ! !RBCompilerTest methodsFor: 'utilties' stamp: 'lr 12/15/2009 12:23'! compilerClass ^ RBCompiler! ! !RBCompilerTest methodsFor: 'requestor' stamp: 'lr 12/15/2009 13:36'! interactive ^ false! ! !RBCompilerTest methodsFor: 'requestor' stamp: 'lr 12/15/2009 14:44'! notify: aString at: anInteger in: aSource self error: aString! ! !RBCompilerTest methodsFor: 'testing' stamp: 'lr 12/15/2009 15:22'! testBoolean Boolean withAllSubclasses do: [ :each | self assertClass: each ]! ! !RBCompilerTest methodsFor: 'testing' stamp: 'lr 12/15/2009 14:02'! testMorph Morph withAllSubclasses do: [ :each | self assertClass: each class; assertClass: each ]! ! !RBCompilerTest methodsFor: 'testing' stamp: 'lr 12/15/2009 15:23'! testNumber Magnitude withAllSubclasses do: [ :each | self assertClass: each ]! !