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

"{ NameSpace: Smalltalk }"

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

!PPCGuard class methodsFor:'as yet unclassified'!

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

on: aPPCNode id: id
    ^ self new
        initializeFor: aPPCNode;
        id: id;
        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, ')'
!

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
! !

!PPCGuard methodsFor:'initialization'!

initializeFor: node
    message := #unknown.
    id := nil.
    
    "No Guards for trimming parser so far"
"	((node firstSetSuchThat: [ :e | e isKindOf: PPCTrimNode ]) isEmpty) ifFalse: [ 
        ^ 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
    
! !