"{ Package: 'stx:goodies/petitparser/compiler/tests' }"

"{ NameSpace: Smalltalk }"

PPAbstractParserTest subclass:#PPCCodeGeneratorTest

	instanceVariableNames:'visitor node result compiler parser context arguments'

	classVariableNames:''

	poolDictionaries:''

	category:'PetitCompiler-Tests-Visitors'

!

!PPCCodeGeneratorTest methodsFor:'as yet unclassified'!

context	

	^ context := PPCProfilingContext new

!

setUp

	arguments := PPCArguments default

		profile: true;

		yourself.	

	compiler := PPCCompiler new.

	compiler arguments: arguments.

	visitor := PPCCodeGenerator new.

	visitor compiler: compiler.

	visitor arguments: arguments.

!

tearDown

	| class |

	class := (Smalltalk at: #PPGeneratedParser ifAbsent: [nil]).

	class notNil ifTrue:[ 

		class removeFromSystem

	].

! !

!PPCCodeGeneratorTest methodsFor:'generating'!

compileTree: root

	| configuration |

	configuration := PPCPluggableConfiguration on: [ :_self | 

		result := (visitor visit: _self ir).

		compiler compileParser.

		compiler compiledParser startSymbol: result methodName.

		parser := compiler compiledParser new.

		_self ir: parser

	].

	parser := configuration compile: root arguments: arguments.

! !

!PPCCodeGeneratorTest methodsFor:'testing'!

assert: whatever parse: input

	result := super assert: whatever parse: input.

!

testActionNode

	node := PPCActionNode new

		block: [ :res | res collect: [:each | each asUppercase ]];

		child: #letter asParser plus asCompilerTree;

		yourself.

	self compileTree: node.

	self assert: parser parse: 'foo' to: { $F . $O . $O}.

	self assert: parser parse: 'bar' to: { $B . $A . $R}.

	self assert: parser fail: ''.

!

testAnyNode

	node := PPCForwardNode new

		child: PPCAnyNode new;

		yourself.

	self compileTree: node.

	self assert: parser class methodDictionary size = 2.

	self assert: parser parse: 'a' to: $a.

	self assert: parser parse: '_' to: $_.

	self assert: parser parse: Character cr asString to: Character cr.

    "Modified: / 23-04-2015 / 12:43:24 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

testAnyNode2

	node := PPCForwardNode new

		child: (PPCAnyNode new markForInline; yourself);

		yourself.

	self compileTree: node.

	self assert: parser class methodDictionary size = 1.

	self assert: parser parse: 'a' to: $a.

	self assert: parser parse: '_' to: $_.

	self assert: parser parse: Character cr asString to: Character cr.

    "Modified: / 23-04-2015 / 12:43:43 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

testCharSetPredicateNode

	| charNode |

	charNode := PPCCharSetPredicateNode new 

		predicate: (PPCharSetPredicate on: [ :e | e = $a ]);

		yourself.

	node := PPCForwardNode new

		child: charNode;

		yourself.

	self compileTree: node.

	self assert: parser class methodDictionary size = 2.

	self assert: parser parse: 'a'  to: $a.

	self assert: parser fail: 'b'.

!

testCharSetPredicateNode2

	| charNode |

	charNode := PPCCharSetPredicateNode new 

		predicate: (PPCharSetPredicate on: [ :e | e = $a ]);

		markForInline;

		yourself.

	node := PPCForwardNode new

		child: charNode;

		yourself.

	self compileTree: node.

	self assert: parser class methodDictionary size = 1.

	self assert: parser parse: 'a'  to: $a.

	self assert: context invocationCount = 1.

	self assert: parser fail: 'b'.

!

testCharacterNode

	| charNode |

	charNode := PPCCharacterNode new 

		character: $a; yourself.

	node := PPCForwardNode new

		child: charNode; yourself.

	self compileTree: node.

	self assert: result class == PPCMethod.

	self assert: parser class methodDictionary size = 2.

	self assert: parser parse: 'a'  to: $a.

	self assert: parser fail: 'b'.

!

testCharacterNode2

	node := (PPCCharacterNode new character: $#; yourself).

	self compileTree: node.

	self assert: parser parse: '#'

!

testCharacterNode3

	node := PPCCharacterNode new character: Character lf; yourself.

	self compileTree: node.

	self assert: parser parse: String lf.

!

testCharacterNode4

	| charNode |

	charNode := PPCCharacterNode new 

		character: $a; 

		markForInline;

		yourself.

	node := PPCForwardNode new

		child: charNode; yourself.

	self compileTree: node.

	self assert: parser class methodDictionary size = 1.

	self assert: parser parse: 'a'  to: $a.

	self assert: parser fail: 'b'.

!

testChoiceNode

	node := PPCChoiceNode new

		children: { #digit asParser asCompilerNode. #letter asParser asCompilerNode };

		yourself.

	self compileTree: node.

	self assert: parser class methodDictionary size = 3.

	self assert: parser parse: '1' to: $1.

	self assert: parser parse: 'a' to: $a.

	self assert: parser fail: '_'.

!

testChoiceNode2

	| digitNode letterNode |

	digitNode := PPCMessagePredicateNode new

		message: #isDigit;

		markForInline;

		yourself.

	letterNode := PPCMessagePredicateNode new

		message: #isLetter;

		markForInline;

		yourself.

	node := PPCChoiceNode new

		children: { digitNode . letterNode };

		yourself.

	self compileTree: node.

	self assert: parser class methodDictionary size = 1.

	self assert: parser parse: '1' to: $1.

	self assert: parser parse: 'a' to: $a.

	self assert: parser fail: '_'.

!

testForwardNode

	| letterNode forwardNode |

	letterNode := PPCMessagePredicateNode new

		message: #isLetter;

		yourself.

	forwardNode := PPCForwardNode new

		child: letterNode;

		yourself.

	node := PPCForwardNode new

		child: forwardNode;

		yourself.

	self compileTree: node.

	self assert: parser class methodDictionary size = 3.

	self assert: parser parse: 'a' to: $a.

	self assert: parser parse: 'bc' to: $b end: 1.

	self assert: parser fail: ''.

!

testForwardNode2

	| letterNode forwardNode |

	letterNode := PPCMessagePredicateNode new

		message: #isLetter;

		markForInline;

		yourself.

	forwardNode := PPCForwardNode new

		child: letterNode;

		yourself.

	node := PPCForwardNode new

		child: forwardNode;

		yourself.

	self compileTree: node.

	self assert: parser class methodDictionary size = 2.

	self assert: parser parse: 'a' to: $a.

	self assert: parser parse: 'bc' to: $b end: 1.

	self assert: parser fail: ''.

!

testForwardNode3

	| letterNode forwardNode |

	letterNode := PPCMessagePredicateNode new

		message: #isLetter;

		yourself.

	forwardNode := PPCForwardNode new

		child: letterNode;

		markForInline;

		yourself.

	node := PPCForwardNode new

		child: forwardNode;

		yourself.

	self compileTree: node.

	self assert: parser class methodDictionary size = 2.

	self assert: parser parse: 'a' to: $a.

	self assert: parser parse: 'bc' to: $b end: 1.

	self assert: parser fail: ''.

!

testForwardNode4

	| letterNode forwardNode |

	letterNode := PPCMessagePredicateNode new

		message: #isLetter;

		markForInline;

		yourself.

	forwardNode := PPCForwardNode new

		child: letterNode;

		markForInline;

		yourself.

	node := PPCForwardNode new

		child: forwardNode;

		yourself.

	self compileTree: node.

	self assert: parser class methodDictionary size = 1.

	self assert: parser parse: 'a' to: $a.

	self assert: parser parse: 'bc' to: $b end: 1.

	self assert: parser fail: ''.

!

testInlinePluggableNode

   "Sadly, on Smalltalk/X blocks cannot be inlined because

	 the VM does not provide enough information to map

	 it back to source code. Very bad indeed!!"          

	((Smalltalk respondsTo:#isSmalltalkX) and:[ Smalltalk isSmalltalkX ]) ifTrue:[

	    self skipIf: true description: 'Blocks cannot be inlined due to a lack of proper VM support'.

	].

	node := PPCSequenceNode new

		children: { 

			PPCPluggableNode new block: [ :ctx | ctx next ]; markForInline; yourself. 

			$a asParser asCompilerNode }.

	self compileTree: node.

	self assert: parser class methodDictionary size = 2.

	self assert: parser parse: 'ba' to: #($b $a).

!

testLiteralNode

	node := PPCLiteralNode new

		literal: 'foo';

		yourself.

	self compileTree: node.

	self assert: result class == PPCMethod.

	self assert: result methodName = 'lit_0'.

	self assert: parser class methodDictionary size = 1.

	self assert: parser parse: 'foo'  to: 'foo'.

	self assert: parser parse: 'foobar'  to: 'foo' end: 3.

	self assert: parser fail: 'boo'.

!

testLiteralNode2

	node := PPCLiteralNode new

		literal: '''''';

		yourself.

	self compileTree: node.

	self assert: parser parse: ''''''  to: ''''''.

!

testLiteralNode3

	| literalNode |

	literalNode := PPCLiteralNode new

		literal: 'foo';

		markForInline;

		yourself.

	node := PPCForwardNode new

		child: literalNode;

		yourself.

	self compileTree: node.

	self assert: parser class methodDictionary size = 1.

	self assert: parser parse: 'foo'  to: 'foo'.

	self assert: parser parse: 'foobar'  to: 'foo' end: 3.

	self assert: parser fail: 'boo'.

!

testMessagePredicate

	| messageNode |

	messageNode := PPCMessagePredicateNode new

		message: #isDigit;

		yourself.

	node := PPCForwardNode new

		child: messageNode;

		yourself.

	self compileTree: node.

	self assert: parser class methodDictionary size = 2.

	self assert: parser parse: '1' to: $1 end: 1.

	self assert: context invocationCount = 2.

	self assert: parser fail: 'a'.

	self assert: parser fail: ''.

!

testMessagePredicate2

	| messageNode |

	messageNode := PPCMessagePredicateNode new

		message: #isDigit;

		markForInline;

		yourself.

	node := PPCForwardNode new

		child: messageNode;

		yourself.

	self compileTree: node.

	self assert: parser class methodDictionary size = 1.

	self assert: parser parse: '1' to: $1 end: 1.

	self assert: context invocationCount = 1.

	self assert: parser fail: 'a'.

	self assert: parser fail: ''.

!

testNilNode

	| nilNode |

	nilNode := PPCNilNode new.

	node := PPCForwardNode new child: nilNode; yourself.

	self compileTree: node.

	self assert: result class = PPCMethod.

	self assert: parser class methodDictionary size = 2.

	self assert: parser parse: 'a' to: nil end: 0.

	self assert: parser parse: '' to: nil end: 0.

!

testNilNode2

	| nilNode |

	nilNode := PPCNilNode new markForInline; yourself.

	node := PPCForwardNode new child: nilNode; yourself.

	self compileTree: node.

	self assert: parser class methodDictionary size = 1.

	self assert: parser parse: 'a' to: nil end: 0.

	self assert: parser parse: '' to: nil end: 0.

!

testNotCharSetPredicateNode

	| charNode |

	charNode := PPCNotCharSetPredicateNode new

		predicate: (PPCharSetPredicate on: [ :e | e = $a ]);

		yourself.

	node := PPCForwardNode new

		child: charNode; yourself.

	self compileTree: node.

	self assert: parser class methodDictionary size = 2.

	self assert: parser parse: 'b' to: nil end: 0.

	self assert: context invocationCount = 2.

	self assert: parser fail: 'a'.

	self assert: parser parse: '' to: nil end: 0.

!

testNotCharSetPredicateNode2

	| charNode |

	charNode := PPCNotCharSetPredicateNode new

		predicate: (PPCharSetPredicate on: [ :e | e = $a ]);

		markForInline;

		yourself.

	node := PPCForwardNode new

		child: charNode; yourself.

	self compileTree: node.

	self assert: parser class methodDictionary size = 1.

	self assert: parser parse: 'b' to: nil end: 0.

	self assert: context invocationCount = 1.

	self assert: parser fail: 'a'.

	self assert: parser parse: '' to: nil end: 0.

!

testNotLiteralNode

	| literalNode |

	literalNode := PPCNotLiteralNode new

		literal: 'foo';

		yourself.

	node := PPCForwardNode new

		child: literalNode; yourself.

	self compileTree: node.

	self assert: parser class methodDictionary size = 2.

	self assert: parser parse: 'bar' to: nil end: 0.

	self assert: context invocationCount = 2.

	self assert: parser fail: 'foo'.

	self assert: parser parse: '' to: nil end: 0.

!

testNotLiteralNode2

	| literalNode |

	literalNode := PPCNotLiteralNode new

		literal: 'foo';

		markForInline;

		yourself.

	node := PPCForwardNode new

		child: literalNode; yourself.

	self compileTree: node.

	self assert: parser class methodDictionary size = 1.

	self assert: parser parse: 'bar' to: nil end: 0.

	self assert: context invocationCount = 1.

	self assert: parser fail: 'foo'.

	self assert: parser parse: '' to: nil end: 0.

!

testNotMessagePredicateNode

	| messageNode |

	messageNode := PPCNotMessagePredicateNode new

		message: #isDigit;

		yourself.

	node := PPCForwardNode new

		child: messageNode;

		yourself.

	self compileTree: node.