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

"{ NameSpace: Smalltalk }"

Object subclass:#PPCGuard
	instanceVariableNames:'node classification id message'
	classVariableNames:''
	poolDictionaries:''
	category:'PetitCompiler-Core'
!

!PPCGuard class methodsFor:'as yet unclassified'!

on: aPPCNode
	^ self new
		initializeFor: aPPCNode;
		yourself
! !

!PPCGuard methodsFor:'accessing'!

classification
	^ classification
!

id
	
	^ id
!

id: anObject
	
	id := anObject
!

message
	(message == #unknown) ifTrue: [ 
		(self testMessage: #isLetter) ifTrue: [ ^ message := #isLetter ].
		(self testMessage: #isAlphaNumeric) ifTrue: [ ^ message := #isAlphaNumeric ].
		(self testMessage: #isDigit) ifTrue: [ ^ message := #isDigit ].
		
		^ message := nil.
	].
	^ message
! !

!PPCGuard methodsFor:'as yet unclassified'!

classificationOn: aBlock
	classification := Array new: 255.
	1 to: classification size do: [ :index |
		classification at: index put: (aBlock
			value: (Character value: index)) ].
!

compileAny: compiler
	compiler add: '(context atEnd not)'.
!

compileCharacter: compiler
	self assert: (classification select: [ :e | e ]) size = 1.
	
	classification keysAndValuesDo: [ :index :value | value ifTrue: [  
		(index > 32 and: [ index < 127 ]) ifTrue: [ 
			compiler add: '(context peek = ', (Character value: index) storeString, ')'
		] ifFalse: [ 
			id := compiler idFor: (Character value: index) prefixed: #character.
			compiler addConstant: (Character value: index) as: id.
			compiler add: '(context peek = ', id, ')'.
	 	] 
	] ].

!

compileGuard: compiler id: symbol
	self id: symbol.
	^ self compileGuard: compiler
!

compileMessage: compiler
	compiler add: '(context peek ', message, ')'
!

initializeFor: aPPCNode
	node := aPPCNode.
	message := #unknown.
	id := nil.
	
	"No Guards for trimming parser so far"
	((node firstSetSuchThat: [ :e | e isKindOf: PPCTrimNode ]) isEmpty not) ifTrue: [ 
		^ self initializeForNoGuard 
	].
	(node acceptsEpsilon) ifTrue: [  
		^ self initializeForEpsilon
	].

	self classificationOn: [:char | node firstSet anySatisfy: [:e | (e firstCharSetCached value: char) ]]

"	self classificationOn: [ :char | node firstSet anySatisfy: [ :e |  (e firstCharParser parse: char asString) isPetitFailure not ] ]"
!

initializeForEpsilon
	classification := nil
	
!

initializeForNoGuard
	classification := nil
	
!

testAny
	^ classification allSatisfy: [ :e | e ].
!

testMessage: selector
 	classification keysAndValuesDo: [:index :element |
		(element = ((Character value: index) perform: selector)) ifFalse: [ 
			^ false 
		]
	].
	^ true
!

testSingleCharacter
	^ (classification select: [ :e | e ]) size = 1
! !

!PPCGuard methodsFor:'code generation'!

compileArray: compiler
	| array |
	self assert: id isNotNil.

	array := ((classification asOrderedCollection) addLast: false; yourself) asArray.
	compiler addConstant: array as: id.
	compiler add: '(', id, ' at: context peek asInteger)'.
!

compileGuard: compiler
	self assert: self makesSense description: 'No Guard could be compiled'.
	self assert: id notNil.
	
	
	self message ifNotNil: [ ^ self compileMessage: compiler ].
	self testAny ifTrue: [ ^ self compileAny: compiler ].
	self testSingleCharacter ifTrue: [ ^ self compileCharacter: compiler ].
	
	^ self compileArray: compiler
!

makesSense
	^ classification isNil not
! !