--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/compiler/tests/extras/PPCLRPParser.st Thu Jul 30 17:31:18 2015 +0100
@@ -0,0 +1,382 @@
+"{ Package: 'stx:goodies/petitparser/compiler/tests/extras' }"
+
+"{ NameSpace: Smalltalk }"
+
+PPCompositeParser subclass:#PPCLRPParser
+ instanceVariableNames:'program variable block bra ket identifier machine body event
+ transition epsilon wildcard state onentry running onexit comment
+ lineTerminator statebody spawn integer errorNode success failed
+ lastError styler timeoutIdentifier timeoutInteger endOfComment'
+ classVariableNames:''
+ poolDictionaries:''
+ category:'PetitCompiler-Extras-Tests-LRP'
+!
+
+!PPCLRPParser class methodsFor:'accessing'!
+
+ignoredNames
+
+ ^super ignoredNames , #(styler failed lastError)
+! !
+
+!PPCLRPParser methodsFor:'accessing'!
+
+error
+ ^super error
+
+ "Modified: / 30-07-2015 / 17:12:19 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+failed
+ ^failed
+!
+
+lastError
+ ^lastError
+!
+
+start
+ ^program end
+!
+
+styler: aSHStyler
+
+ styler := aSHStyler.
+!
+
+success
+ ^success
+! !
+
+!PPCLRPParser methodsFor:'block creation'!
+
+createSTBlockFrom: aBlockNode withVariables: aDictionary
+ |compiled retval keys|
+
+ keys := OrderedCollection new: aDictionary size.
+ aDictionary associations do: [:asoc|
+ keys add: asoc key.
+ ].
+
+ compiled := (self methodizeBlock: aBlockNode withArguments: keys) compiledMethod.
+ retval := compiled valueWithReceiver: Object new arguments: {aDictionary}.
+
+ ^retval.
+!
+
+methodizeBlock: parsedBlock withArguments: anArray
+
+ |method retval inspoint|
+
+ method := 'captureV: PPCLRPScopeVariables'.
+
+ retval := PPSmalltalkParser new method parse: method , '^[1]'.
+ inspoint := retval body statements first.
+ parsedBlock scope: inspoint value scope.
+ parsedBlock parent: inspoint.
+ inspoint value: parsedBlock.
+ retval source: retval asString.
+
+ anArray do: [:aVarName|
+ retval := retval rewritePPCLRPVarNamedWrite: aVarName.
+ retval := retval rewritePPCLRPVarNamedRead: aVarName.
+ ].
+ ^retval
+! !
+
+!PPCLRPParser methodsFor:'error handing'!
+
+failWithValue: anObject
+
+ failed := true.
+ lastError := anObject.
+! !
+
+!PPCLRPParser methodsFor:'grammar'!
+
+body
+ ^(variable / event / state / transition / timeoutIdentifier / timeoutInteger / epsilon / wildcard / comment / errorNode) star
+!
+
+errorNode
+ ^(bra, (bra/ket)negate star , ket)
+ ==> [ :tokens |
+ PPCLRPErrorNode new start: tokens first start stop: tokens last stop; yourself.
+ ]
+!
+
+event
+ ^ (bra, 'event' asParser trim, identifier, block, ket)
+ ==> [:tokens | | ident |
+ ident := (tokens at: 3).
+ (PPCLRPEvent named: ident inputValue
+ trigger: (tokens at: 4))
+ start: tokens first start stop: tokens last stop;
+ nameRange: (ident start to: ident stop);
+ yourself.
+ ]
+!
+
+integer
+ ^(#digit asParser) plus flatten trim token
+!
+
+machine
+ ^(bra , 'machine' asParser trim , identifier , body , ket)
+ ==> [:tokens | | ident bod stop |
+ ident := (tokens at: 3).
+ bod := (tokens at: 4).
+ bod isEmpty
+ ifTrue: [ stop := tokens last stop - 1 ]
+ ifFalse: [ stop := (bod at: 1) start - 1 ].
+ (PPCLRPMachine name: ident inputValue body: bod)
+ start: (tokens first start) stop: (tokens last stop);
+ nameRange: (ident start to: stop);
+ yourself.
+ ]
+!
+
+onentry
+ ^ (bra, 'onentry' asParser trim, (block/spawn) , ket )
+ ==> [:tokens |
+ (PPCLRPOnEntry block: (tokens at: 3))
+ start: (tokens first start) stop: (tokens last stop);
+ keywordEnd: (tokens at: 3) start -1;
+ yourself.
+ ]
+!
+
+onexit
+ ^ (bra, 'onexit' asParser trim, (block/spawn), ket)
+ ==> [:tokens |
+ (PPCLRPOnExit block: (tokens at: 3))
+ start: (tokens first start) stop: (tokens last stop);
+ keywordEnd: (tokens at: 3) start -1;
+ yourself.
+ ]
+!
+
+program
+ ^ (variable / machine / comment / spawn / errorNode) star
+!
+
+running
+ ^ (bra, 'running' asParser trim, (block/spawn), ket)
+ ==> [:tokens |
+ (PPCLRPRunning block: (tokens at: 3))
+ start: (tokens first start) stop: (tokens last stop);
+ keywordEnd: (tokens at: 3) start -1;
+ yourself.
+ ]
+!
+
+spawn
+ ^(bra , 'spawn' asParser trim , identifier , identifier , ket)
+ ==> [ :tokens |
+ (PPCLRPSpawn
+ machine: (tokens at: 3) parsedValue
+ state: (tokens at: 4) parsedValue)
+ start: (tokens first start) stop: (tokens last stop);
+ nameRange: ((tokens at: 3) start to: (tokens at: 4) stop)
+ yourself.
+ ]
+
+!
+
+state
+ ^(bra , 'state' asParser trim , identifier , statebody , ket)
+ ==> [ :tokens | | ident |
+ ident := (tokens at: 3).
+ (PPCLRPState name: ident inputValue
+ body: (tokens at: 4))
+ start: (tokens first start) stop: (tokens last stop);
+ nameRange: (ident start to: ident stop);
+ yourself.
+ ]
+
+!
+
+statebody
+ ^(onentry / running / onexit / machine / comment / errorNode) star
+
+!
+
+variable
+ ^ (bra , 'var' asParser trim , identifier , ':=' asParser trim , block , ket)
+ ==> [ :tokens | |ident|
+ ident := (tokens at: 3).
+ (PPCLRPVariable name: ident inputValue value: (tokens at: 5))
+ start: (tokens first start) stop: (tokens last stop);
+ nameRange: (ident start to: ident stop);
+ yourself.
+ ]
+! !
+
+!PPCLRPParser methodsFor:'grammar-comments'!
+
+comment
+ ^ ( $; asParser token , (endOfComment negate star) flatten, endOfComment token) trim
+ ==> [ :tokens | |text|
+ text := tokens at: 2.
+ (PPCLRPComment text: (text copyFrom: 1 to: text size -1))
+ start: (tokens first start) stop: (tokens last stop);
+ yourself.
+ ]
+!
+
+endOfComment
+ ^ #eof asParser / lineTerminator
+!
+
+lineTerminator
+
+ ^ (Character lf asParser) / (Character cr asParser , (Character lf asParser ) optional )
+! !
+
+!PPCLRPParser methodsFor:'grammar-common'!
+
+block
+ ^PPSmalltalkParser new block
+!
+
+bra
+ ^ $( asParser token trim
+!
+
+identifier
+ ^(#letter asParser , (#word asParser / $_ asParser) star) flatten token trim
+!
+
+ket
+ ^ $) asParser token trim
+! !
+
+!PPCLRPParser methodsFor:'grammar-transitions'!
+
+epsilon
+ ^ (bra, 'eps' asParser trim, identifier, '->' asParser trim, identifier, identifier optional, ket)
+ ==> [ :tokens | | trans name |
+ name := (tokens at: 6).
+ name ifNil: [name := '' ] ifNotNil: [ name := name inputValue ].
+ trans :=
+ (PPCLRPEpsilonTransition
+ from: (tokens at: 3) inputValue
+ to: (tokens at: 5) inputValue
+ name: name).
+ self setTransitionRangesIn: trans for: tokens withArrowAt: 3.
+ trans
+ ]
+!
+
+timeoutIdentifier
+ ^ (bra, 'ontime' asParser trim, identifier , identifier, '->' asParser trim, identifier, identifier optional, ket)
+ ==> [:tokens | self transitionActionHandlerFor: PPCLRPTimeoutTransition tokens: tokens ].
+
+ "Modified: / 30-07-2015 / 17:14:45 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+timeoutInteger
+ ^ (bra, 'ontime' asParser trim, integer, identifier, '->' asParser trim, identifier, identifier optional, ket)
+ ==> [ :tokens | | trans name |
+ name := (tokens at: 7).
+ name ifNil: [name := '' ] ifNotNil: [ name := name inputValue ].
+ trans :=
+ (PPCLRPTimeoutTransition
+ on: (Integer readFrom: (tokens at: 3) inputValue)
+ from: (tokens at: 4) inputValue
+ to: (tokens at: 6) inputValue
+ name: name).
+ self setTransitionRangesIn: trans for: tokens withArrowAt: 4.
+ trans.
+ ]
+!
+
+transition
+ ^ (bra, 'on' asParser trim, identifier, identifier, '->' asParser trim, identifier, identifier optional , ket)
+ ==> [ :tokens | self transitionActionHandlerFor: PPCLRPTransition tokens: tokens ]
+
+ "Modified: / 30-07-2015 / 17:15:13 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+wildcard
+ ^ (bra, 'on' asParser trim, identifier, '*->' asParser trim, identifier, identifier optional, ket)
+ ==> [ :tokens | | trans name |
+ name := (tokens at: 6).
+ name ifNil: [name := '' ] ifNotNil: [ name := name inputValue ].
+ trans :=
+ (PPCLRPWildcardTransition
+ on: (tokens at: 3) inputValue
+ to: (tokens at: 5) inputValue
+ name: name ).
+ self setTransitionRangesIn: trans for: tokens withArrowAt: 3.
+ trans
+ ]
+
+! !
+
+!PPCLRPParser methodsFor:'parsing'!
+
+parse: aText styleOn: aViewOrMorph
+ |parsedProgram|
+
+ parsedProgram := self parsePPCLRP: aText.
+ self styler view: aViewOrMorph; parser: self; nodes: parsedProgram; style: aText.
+
+ ^parsedProgram.
+!
+
+parsePPCLRP: aString
+
+ |parsedProgram |
+ failed := false.
+ parsedProgram := self parse: aString.
+
+ parsedProgram isPetitFailure ifTrue:[
+ parsedProgram :=
+ {PPCLRPErrorNode new
+ start: 1;
+ stop: aString size;
+ yourself.
+ }
+ ].
+
+ "visit pattern?"
+ parsedProgram do:[:aNode|
+ (aNode onErrorNode: [:anErrorNode| ] parser: self)
+ ].
+
+ ^parsedProgram.
+! !
+
+!PPCLRPParser methodsFor:'transitions'!
+
+setTransitionRangesIn: aTransition for: aTokenArray withArrowAt: index
+ | ident |
+ ident := (aTokenArray at: index + 3).
+ ident
+ ifNil: [ aTransition nameRange: (1 to: 1) ]
+ ifNotNil: [ aTransition nameRange: (ident start to: ident stop) ].
+ aTransition
+ start: (aTokenArray first start) stop: (aTokenArray last stop);
+ arrowRange:
+ ((aTokenArray at: index) stop + 1
+ to: (aTokenArray at: index + 2) start -1);
+ keywordEnd: (aTokenArray at: 3) start -1
+!
+
+transitionActionHandlerFor: class tokens: tokens
+ | trans name|
+ name := (tokens at: 7).
+ name isNil ifTrue:[ name := '' ] ifFalse:[ name := name inputValue ].
+ trans :=
+ (class
+ on: (tokens at: 3) inputValue
+ from: (tokens at: 4) inputValue
+ to: (tokens at: 6) inputValue
+ name: name).
+ self setTransitionRangesIn: trans for: tokens withArrowAt: 4.
+ ^ trans.
+
+ "Created: / 30-07-2015 / 17:12:55 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+! !
+