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

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

! !