Adding extra packages. With current pacakge the minimal test is working as inteded but may need a clean up for a more minimal load.

software/PetitParser/BlockClosure.extension.st

@@ -0,0 +1,8 @@
+Extension { #name : 'BlockClosure' }
+
+{ #category : '*petitparser-core-converting' }
+BlockClosure >> asParser [
+	"Answer a parser implemented in the receiving one-argument block."
+
+	^ PPPluggableParser on: self
+]

software/PetitParser/Character.extension.st

@@ -0,0 +1,8 @@
+Extension { #name : 'Character' }
+
+{ #category : '*petitparser-core-converting' }
+Character >> asParser [
+	"Answer a parser that accepts the receiving character."
+	
+	^ PPLiteralObjectParser on: self
+]

software/PetitParser/Collection.extension.st

@@ -0,0 +1,30 @@
+Extension { #name : 'Collection' }
+
+{ #category : '*petitparser-core-converting' }
+Collection >> asChoiceParser [
+	^ PPChoiceParser withAll: (self collect: [ :each | each asParser ])
+]
+
+{ #category : '*petitparser-converting' }
+Collection >> asParser [    
+	"Create a range of characters between start and stop."
+
+	(self allSatisfy: [ :e | e isCharacter ]) ifTrue: [ 
+		| charSet |
+		charSet := PPCharSetPredicate on: [ :char | self includes: char ] .
+     	^ PPPredicateObjectParser on: charSet message: 'One of these charactes expected: ', self printString.
+	].
+
+
+	^ super asParser
+	"
+		($a to:$f) asParser parse:'a'
+		($a to:$f) asParser parse:'g'
+	"
+
+]
+
+{ #category : '*petitparser-core-converting' }
+Collection >> asSequenceParser [
+	^ PPSequenceParser withAll: (self collect: [ :each | each asParser ])
+]

software/PetitParser/Interval.extension.st

@@ -0,0 +1,16 @@
+Extension { #name : 'Interval' }
+
+{ #category : '*petitparser-core-converting' }
+Interval >> asParser [    
+	"Create a range of characters between start and stop."
+
+    self assert:start isCharacter.
+    self assert:stop isCharacter.
+    self assert:step == 1.
+    ^ PPPredicateObjectParser between: start and: stop
+
+    "
+		($a to: $f) asParser parse: 'a'
+		($a to: $f) asParser parse: 'g'
+    "
+]

software/PetitParser/Object.extension.st

@@ -0,0 +1,23 @@
+Extension { #name : 'Object' }
+
+{ #category : '*petitparser-core-converting' }
+Object >> asParser [
+	"Answer a parser accepting the receiving object."
+
+	^ PPPredicateObjectParser expect: self
+]
+
+{ #category : '*petitparser-core-testing' }
+Object >> isPetitFailure [
+	^ false
+]
+
+{ #category : '*petitparser-core-testing' }
+Object >> isPetitParser [
+	^ false
+]
+
+{ #category : '*PetitParser' }
+Object >> isPetitToken [
+	^ false
+]

software/PetitParser/PPActionParser.class.st

@@ -0,0 +1,40 @@
+"
+A parser that performs an action block with the successful parse result of the delegate.
+
+Instance Variables:
+	block	<BlockClosure>	The action block to be executed.
+
+"
+Class {
+	#name : 'PPActionParser',
+	#superclass : 'PPDelegateParser',
+	#instVars : [
+		'block'
+	],
+	#category : 'PetitParser-Parsers'
+}
+
+{ #category : 'instance creation' }
+PPActionParser class >> on: aParser block: aBlock [
+	^ (self on: aParser) setBlock: aBlock
+]
+
+{ #category : 'accessing' }
+PPActionParser >> block [
+	"Answer the action block of the receiver."
+
+	^ block
+]
+
+{ #category : 'parsing' }
+PPActionParser >> parseOn: aPPContext [
+	| element |
+	^ (element := parser parseOn: aPPContext) isPetitFailure
+		ifFalse: [ block value: element ]
+		ifTrue: [ element ]
+]
+
+{ #category : 'initialization' }
+PPActionParser >> setBlock: aBlock [
+	block := aBlock
+]

software/PetitParser/PPAndParser.class.st

@@ -0,0 +1,22 @@
+"
+The and-predicate, a parser that succeeds whenever its delegate does, but does not consume the input stream [Parr 1994, 1995].
+"
+Class {
+	#name : 'PPAndParser',
+	#superclass : 'PPDelegateParser',
+	#category : 'PetitParser-Parsers'
+}
+
+{ #category : 'operators' }
+PPAndParser >> and [
+	^ self
+]
+
+{ #category : 'parsing' }
+PPAndParser >> parseOn: aPPContext [
+	| element memento |
+	memento := aPPContext remember.
+	element := parser parseOn: aPPContext.
+	aPPContext restore: memento.
+	^ element
+]

software/PetitParser/PPCharSetPredicate.class.st

@@ -0,0 +1,46 @@
+"
+I am a predicate allowing to check if a character is included in the set of char described by the Block this object is initialized with.
+
+I work efficiently on characters for which the code point is between 1 and 255 using a lookup table.
+
+For example,
+[[[
+charSetPredicate := PPCharSetPredicate on: [ :char | #($a $b $c) includes: char ].
+charSetPredicate value: $a. ""true""
+charSetPredicate value: $z. ""false""
+]]]
+"
+Class {
+	#name : 'PPCharSetPredicate',
+	#superclass : 'Object',
+	#instVars : [
+		'block',
+		'classification'
+	],
+	#category : 'PetitParser-Tools'
+}
+
+{ #category : 'instance creation' }
+PPCharSetPredicate class >> on: aBlock [
+	^ self basicNew initializeOn: aBlock
+]
+
+{ #category : 'initialization' }
+PPCharSetPredicate >> initializeOn: aBlock [
+	block := aBlock.
+	classification := Array new: 255.
+	1 to: classification size do: [ :index |
+		classification at: index put: (block
+			value: (Character codePoint: index)) ]
+]
+
+{ #category : 'evaluating' }
+PPCharSetPredicate >> value: aCharacter [
+	| index |
+	index := aCharacter asInteger.
+	index == 0
+		ifTrue: [ ^ block value: aCharacter ].
+	index > 255
+		ifTrue: [ ^ block value: aCharacter ].
+	^ classification at: index
+]

software/PetitParser/PPChoiceParser.class.st

@@ -0,0 +1,26 @@
+"
+A parser that uses the first parser that succeeds.
+"
+Class {
+	#name : 'PPChoiceParser',
+	#superclass : 'PPListParser',
+	#category : 'PetitParser-Parsers'
+}
+
+{ #category : 'operators' }
+PPChoiceParser >> / aRule [ 
+	^ self copyWith: aRule
+]
+
+{ #category : 'parsing' }
+PPChoiceParser >> parseOn: aPPContext [
+	"This is optimized code that avoids unnecessary block activations, do not change. When all choices fail, the last failure is answered."
+
+	| element |
+	1 to: parsers size do: [ :index |
+		element := (parsers at: index)
+			parseOn: aPPContext.
+		element isPetitFailure
+			ifFalse: [ ^ element ] ].
+	^ element
+]

software/PetitParser/PPCompositeParser.class.st

@@ -0,0 +1,150 @@
+"
+A PPCompositeParser is composed parser built from various primitive parsers. 
+
+Every production in the receiver is specified as a method that returns its parser. Note that every production requires an instance variable of the same name, otherwise the production is not cached and cannot be used in recursive grammars. Productions should refer to each other by reading the respective inst-var. Note: these inst-vars are typically not written, as the assignment happens in the initialize method using reflection.
+
+The start production is defined in the method start. It is aliased to the inst-var parser defined in the superclass of PPCompositeParser.
+"
+Class {
+	#name : 'PPCompositeParser',
+	#superclass : 'PPDelegateParser',
+	#instVars : [
+		'dependencies'
+	],
+	#category : 'PetitParser-Tools'
+}
+
+{ #category : 'accessing' }
+PPCompositeParser class >> dependencies [
+	"Answer a collection of PPCompositeParser classes that this parser directly dependends on. Override this method in subclasses to declare dependent parsers. The default implementation does not depend on other PPCompositeParser."
+
+	^ #()
+]
+
+{ #category : 'accessing' }
+PPCompositeParser class >> ignoredNames [
+	"Answer a collection of instance-variables that should not be automatically initialized with productions, but that are used internal to the composite parser."
+
+	^ PPCompositeParser allInstVarNames
+]
+
+{ #category : 'instance creation' }
+PPCompositeParser class >> new [
+	"Answer a new parser starting at the default start symbol."
+
+	^ self newStartingAt: self startSymbol
+]
+
+{ #category : 'instance creation' }
+PPCompositeParser class >> newStartingAt: aSymbol [
+	"Answer a new parser starting at aSymbol. The code makes sure to resolve all dependent parsers correctly."
+
+	| parsers remaining |
+	parsers := IdentityDictionary new.
+	remaining := OrderedCollection with: self.
+	[ remaining isEmpty ] whileFalse: [
+		| dependency |
+		dependency := remaining removeLast.
+		(parsers includesKey: dependency) ifFalse: [
+			parsers at: dependency put: dependency basicNew.
+			remaining addAll: dependency dependencies ] ].
+	parsers keysAndValuesDo: [ :class :parser |
+		| dependencies |
+		dependencies := IdentityDictionary new.
+		class dependencies 
+			do: [ :dependency | dependencies at: dependency put: (parsers at: dependency) ].
+		parser 
+			initializeStartingAt: (class == self
+				ifTrue: [ aSymbol ]
+				ifFalse: [ class startSymbol ]) 
+			dependencies: dependencies ].
+	parsers keysAndValuesDo: [ :class :parser |
+		parser setParser: (parser perform: parser children first name).
+		parser productionNames keysAndValuesDo: [ :key :value |
+			(parser instVarAt: key) setParser: (parser perform: value) ] ].
+	^ parsers at: self
+]
+
+{ #category : 'parsing' }
+PPCompositeParser class >> parse: anObject [
+	^ self parse: anObject startingAt: self startSymbol
+]
+
+{ #category : 'parsing' }
+PPCompositeParser class >> parse: anObject onError: aBlock [
+	^ self parse: anObject startingAt: self startSymbol onError: aBlock
+]
+
+{ #category : 'parsing' }
+PPCompositeParser class >> parse: anObject startingAt: aSymbol [
+	^ (self newStartingAt: aSymbol) parse: anObject
+]
+
+{ #category : 'parsing' }
+PPCompositeParser class >> parse: anObject startingAt: aSymbol onError: aBlock [
+	^ (self newStartingAt: aSymbol) parse: anObject onError: aBlock
+]
+
+{ #category : 'accessing' }
+PPCompositeParser class >> startSymbol [
+	"Answer the method that represents the default start symbol."
+
+	^ #start
+]
+
+{ #category : 'querying' }
+PPCompositeParser >> dependencyAt: aClass [
+	"Answer the dependent parser aClass. Throws an error if this parser class is not declared in the method #dependencies on the class-side of the receiver."
+	
+	^ dependencies at: aClass ifAbsent: [ self error: 'Undeclared dependency in ' , self class name , ' to ' , aClass name ]
+]
+
+{ #category : 'initialization' }
+PPCompositeParser >> initializeStartingAt: aSymbol dependencies: aDictionary [
+	self initialize.
+	parser := PPDelegateParser named: aSymbol.
+	self productionNames keysAndValuesDo: [ :key :value |
+		self instVarAt: key put: (PPDelegateParser named: value) ].
+	dependencies := aDictionary
+]
+
+{ #category : 'querying' }
+PPCompositeParser >> productionAt: aSymbol [
+	"Answer the production named aSymbol."
+	
+	^ self productionAt: aSymbol ifAbsent: [ nil ]
+]
+
+{ #category : 'querying' }
+PPCompositeParser >> productionAt: aSymbol ifAbsent: aBlock [
+	"Answer the production named aSymbol, if there is no such production answer the result of evaluating aBlock."
+	
+	(self class ignoredNames includes: aSymbol asString)
+		ifTrue: [ ^ aBlock value ].
+	(self class startSymbol = aSymbol)
+		ifTrue: [ ^ parser ].
+	^ self instVarAt: (self class allInstVarNames
+		indexOf: aSymbol asString
+		ifAbsent: [ ^ aBlock value ])
+]
+
+{ #category : 'querying' }
+PPCompositeParser >> productionNames [
+	"Answer a dictionary of slot indexes and production names."
+	
+	| productionNames ignoredNames |
+	productionNames := Dictionary new.
+	ignoredNames := self class ignoredNames
+		collect: [ :each | each asSymbol ].
+	self class allInstVarNames keysAndValuesDo: [ :key :value |
+		(ignoredNames includes: value asSymbol)
+			ifFalse: [ productionNames at: key put: value asSymbol ] ].
+	^ productionNames
+]
+
+{ #category : 'accessing' }
+PPCompositeParser >> start [
+	"Answer the production to start this parser with."
+	
+	self subclassResponsibility
+]

software/PetitParser/PPConditionalParser.class.st

@@ -0,0 +1,35 @@
+"
+A PPConditionalParser is a delegate parser that evaluates a block and if that returns true, the delegate parser is invoked and its result returned. If the block evaluates to false, the PPFailure is returned.
+
+The block accepts one argument, context.
+
+E.g.
+    ('a' asParser if: [ :ctx | (ctx propertyAt: #myProperty) isNotNil ]) parse: 'a'
+"
+Class {
+	#name : 'PPConditionalParser',
+	#superclass : 'PPDelegateParser',
+	#instVars : [
+		'block'
+	],
+	#category : 'PetitParser-Parsers'
+}
+
+{ #category : 'instance creation' }
+PPConditionalParser class >> on: aPPParser block: block [
+	^ (PPConditionalParser on: aPPParser)
+		block: block;
+		yourself
+]
+
+{ #category : 'accessing' }
+PPConditionalParser >> block: aBlock [
+	block := aBlock
+]
+
+{ #category : 'parsing' }
+PPConditionalParser >> parseOn: aPPContext [
+	^ (block value: aPPContext) 
+		ifTrue: [ parser parseOn: aPPContext ]
+		ifFalse: [ PPFailure message: block asString, ' was not evaluated to true.' context: aPPContext ]
+]

software/PetitParser/PPContext.class.st

@@ -0,0 +1,430 @@
+"
+A PPContext is provides contextual information to the parsing function.
+
+Instance Variables
+	globals:		<Dictionary>
+	properties:		<Dictionar>
+	root:		<PPParser>
+	stream:		<PPStream>
+
+globals
+	- properties that are not restored after backtracking
+
+properties
+	- properties that are restored after backtracking
+
+root
+	- the root parser
+
+stream
+	- input stream
+
+"
+Class {
+	#name : 'PPContext',
+	#superclass : 'Object',
+	#instVars : [
+		'stream',
+		'root',
+		'properties',
+		'globals',
+		'furthestFailure'
+	],
+	#category : 'PetitParser-Core'
+}
+
+{ #category : 'stream mimicry' }
+PPContext >> atEnd [
+	^ stream atEnd
+]
+
+{ #category : 'stream mimicry' }
+PPContext >> back [
+	^ stream back
+]
+
+{ #category : 'checking' }
+PPContext >> checkMementoStreamIsSameAsMine: aPPContextMemento [
+	aPPContextMemento stream == stream ifFalse: [ 
+		self error: 'The stream held by the PPContextMemento must be identity-equals to the stream I hold.' ]
+]
+
+{ #category : 'stream mimicry' }
+PPContext >> collection [
+	^ stream collection  
+]
+
+{ #category : 'stream mimicry' }
+PPContext >> contents [ 
+	^ stream contents
+]
+
+{ #category : 'failures' }
+PPContext >> furthestFailure [
+	" the furthest failure encountered while parsing the input stream "
+	
+	"^ self globalAt: #furthestFailure ifAbsent: [ nil ]"
+	"performance optimization:"
+	^ furthestFailure
+]
+
+{ #category : 'accessing-globals' }
+PPContext >> globalAt: aKey [
+	"Answer the global property value associated with aKey."
+	
+	^ self globalAt: aKey ifAbsent: [ self error: 'Property not found' ]
+]
+
+{ #category : 'accessing-globals' }
+PPContext >> globalAt: aKey ifAbsent: aBlock [
+	"Answer the global property value associated with aKey or, if aKey isn't found, answer the result of evaluating aBlock."
+	
+	^ globals isNil
+		ifTrue: [ aBlock value ]
+		ifFalse: [ globals at: aKey ifAbsent: aBlock ]
+]
+
+{ #category : 'accessing-globals' }
+PPContext >> globalAt: aKey ifAbsentPut: aBlock [
+	"Answer the global property associated with aKey or, if aKey isn't found store the result of evaluating aBlock as new value."
+	
+	^ self globalAt: aKey ifAbsent: [ self globalAt: aKey put: aBlock value ]
+]
+
+{ #category : 'accessing-globals' }
+PPContext >> globalAt: aKey put: anObject [
+	"Set the global property at aKey to be anObject. If aKey is not found, create a new entry for aKey and set is value to anObject. Answer anObject."
+
+	^ (globals ifNil: [ globals := Dictionary new: 1 ])
+		at: aKey put: anObject
+]
+
+{ #category : 'accessing-globals' }
+PPContext >> globals [
+	^ globals
+]
+
+{ #category : 'accessing-globals' }
+PPContext >> hasGlobal: aKey [
+	"Test if the global property aKey is present."
+	
+	^ globals notNil and: [ globals includesKey: aKey ]
+]
+
+{ #category : 'accessing-properties' }
+PPContext >> hasProperty: aKey [
+	"Test if the property aKey is present."
+	
+	^ properties notNil and: [ properties includesKey: aKey ]
+]
+
+{ #category : '*PetitParser-Ruby-Parser' }
+PPContext >> heredocId [
+	^ self globalAt: #heredocId ifAbsent: nil
+]
+
+{ #category : '*PetitParser-Ruby-Parser' }
+PPContext >> heredocId: value [
+	self globalAt: #heredocId put: value
+]
+
+{ #category : 'memoization' }
+PPContext >> identifier [
+	"
+		I provide an identifier that is used by memoizing parser to figure out if the
+		cache should be flushed or not.
+	"
+	^ stream
+]
+
+{ #category : 'initialization' }
+PPContext >> initialize [
+	stream := nil.
+]
+
+{ #category : 'initialization' }
+PPContext >> initializeFor: parser [
+	root := parser.
+]
+
+{ #category : 'stream mimicry' }
+PPContext >> isEndOfLine [
+	^ stream isEndOfLine
+]
+
+{ #category : 'stream mimicry' }
+PPContext >> isStartOfLine [
+	^ stream isStartOfLine
+]
+
+{ #category : 'stream mimicry' }
+PPContext >> next [
+	^ stream next
+]
+
+{ #category : 'stream mimicry' }
+PPContext >> next: anInteger [
+	^ stream next: anInteger
+]
+
+{ #category : 'failures' }
+PPContext >> noteFailure: aPPFailure [
+	"record the furthest failure encountered while parsing the input stream "
+
+	( furthestFailure isNil or: [ aPPFailure position > furthestFailure position ]) 
+		ifTrue: [ furthestFailure := aPPFailure ].
+]
+
+{ #category : 'stream mimicry' }
+PPContext >> peek [
+	^ stream peek
+]
+
+{ #category : 'stream mimicry' }
+PPContext >> peekTwice [
+	^ stream peekTwice
+]
+
+{ #category : '*PetitParser-Ruby-Parser' }
+PPContext >> percentStringEnd [
+	^ self globalAt: #percentStringEnd ifAbsent: nil
+]
+
+{ #category : '*PetitParser-Ruby-Parser' }
+PPContext >> percentStringStart: value [
+	| endValue |
+	endValue := value.
+	(value == $[) ifTrue: [ endValue := $] ].
+	(value == $() ifTrue: [ endValue := $) ].
+	(value == ${) ifTrue: [ endValue := $} ].
+
+	self globalAt: #percentStringStart put: value.
+	self globalAt: #percentStringEnd put: endValue
+]
+
+{ #category : 'stream mimicry' }
+PPContext >> position [
+	^ stream position
+]
+
+{ #category : 'stream mimicry' }
+PPContext >> position: anInteger [
+	^ stream position: anInteger
+]
+
+{ #category : 'initialization' }
+PPContext >> postCopy [
+	super postCopy.
+	globals := globals copy.
+	
+]
+
+{ #category : 'printing' }
+PPContext >> printOn: aStream [
+	super printOn: aStream.
+	aStream nextPut: $:.
+	aStream nextPut: $ .
+	stream printOn: aStream
+]
+
+{ #category : 'accessing-properties' }
+PPContext >> properties [
+	^ properties 
+]
+
+{ #category : 'accessing-properties' }
+PPContext >> propertyAt: aKey [
+	"Answer the property value associated with aKey."
+	
+	^ self propertyAt: aKey ifAbsent: [ self error: 'Property not found' ]
+]
+
+{ #category : 'accessing-properties' }
+PPContext >> propertyAt: aKey ifAbsent: aBlock [
+	"Answer the property value associated with aKey or, if aKey isn't found, answer the result of evaluating aBlock."
+	
+	^ properties isNil
+		ifTrue: [ aBlock value ]
+		ifFalse: [ properties at: aKey ifAbsent: aBlock ]
+]
+
+{ #category : 'accessing-properties' }
+PPContext >> propertyAt: aKey ifAbsentPut: aBlock [
+	"Answer the property associated with aKey or, if aKey isn't found store the result of evaluating aBlock as new value."
+	
+	^ self propertyAt: aKey ifAbsent: [ self propertyAt: aKey put: aBlock value ]
+]
+
+{ #category : 'accessing-properties' }
+PPContext >> propertyAt: aKey put: anObject [
+	"Set the property at aKey to be anObject. If aKey is not found, create a new entry for aKey and set is value to anObject. Answer anObject."
+
+	^ (properties ifNil: [ properties := Dictionary new: 1 ])
+		at: aKey put: anObject
+]
+
+{ #category : 'memoization' }
+PPContext >> remember [
+	| memento |
+	memento := PPContextMemento new
+		stream: stream;
+		position: stream position;
+		yourself.
+		
+	self rememberProperties: memento.
+	^ memento
+]
+
+{ #category : 'memoization' }
+PPContext >> rememberProperties: aPPContextMemento [
+	properties ifNil: [ ^ self ].
+	
+	properties keysAndValuesDo: [ :key :value |
+		aPPContextMemento propertyAt: key put: value
+	].
+]
+
+{ #category : 'accessing-globals' }
+PPContext >> removeGlobal: aKey [
+	"Remove the property with aKey. Answer the property or raise an error if aKey isn't found."
+	
+	^ self removeGlobal: aKey ifAbsent: [ self error: 'Property not found' ]
+]
+
+{ #category : 'accessing-globals' }
+PPContext >> removeGlobal: aKey ifAbsent: aBlock [
+	"Remove the global property with aKey. Answer the value or, if aKey isn't found, answer the result of evaluating aBlock."
+	
+	| answer |
+	globals isNil ifTrue: [ ^ aBlock value ].
+	answer := globals removeKey: aKey ifAbsent: aBlock.
+	globals isEmpty ifTrue: [ globals := nil ].
+	^ answer
+]
+
+{ #category : 'accessing-properties' }
+PPContext >> removeProperty: aKey [
+	"Remove the property with aKey. Answer the property or raise an error if aKey isn't found."
+	
+	^ self removeProperty: aKey ifAbsent: [ self error: 'Property not found' ]
+]
+
+{ #category : 'accessing-properties' }
+PPContext >> removeProperty: aKey ifAbsent: aBlock [
+	"Remove the property with aKey. Answer the value or, if aKey isn't found, answer the result of evaluating aBlock."
+	
+	| answer |
+	properties isNil ifTrue: [ ^ aBlock value ].
+	answer := properties removeKey: aKey ifAbsent: aBlock.
+	properties isEmpty ifTrue: [ properties := nil ].
+	^ answer
+]
+
+{ #category : 'initialization' }
+PPContext >> reset [
+	properties := nil.
+	globals := nil.
+]
+
+{ #category : 'memoization' }
+PPContext >> restore: aPPContextMemento [
+	aPPContextMemento stream == stream ifFalse: [ self error: 'Oops!' ].
+
+	stream position: aPPContextMemento position.
+	self restoreProperties: aPPContextMemento.
+]
+
+{ #category : 'memoization' }
+PPContext >> restoreProperties: aPPContextMemento [
+	aPPContextMemento stream == stream ifFalse: [ self error: 'Oops!' ].
+	
+	properties ifNil: [ ^ self ].
+	
+	properties keysDo: [ :key |
+		(aPPContextMemento hasProperty: key)
+			ifTrue: [ properties at: key put: (aPPContextMemento propertyAt: key) ]
+			ifFalse: [ properties removeKey: key  ]. 
+	].
+
+	aPPContextMemento keysAndValuesDo: [ :key :value |
+		properties at: key put: value
+	]
+]
+
+{ #category : 'acessing' }
+PPContext >> root [
+	^ root 
+]
+
+{ #category : 'memoization' }
+PPContext >> size [
+	^ stream size
+]
+
+{ #category : 'stream mimicry' }
+PPContext >> skip: anInteger [ 
+	^ stream skip: anInteger 
+]
+
+{ #category : 'stream mimicry' }
+PPContext >> skipTo: anObject [ 
+	^ stream skipTo: anObject 
+]
+
+{ #category : 'stream mimicry' }
+PPContext >> skipToAll: aString [
+	"Set the access position of the receiver to be past the next occurrence of the subCollection. Answer whether subCollection is found.  No wildcards, and case does matter."
+	| pattern startMatch |
+	pattern := aString readStream.
+	startMatch := nil.
+	[ pattern atEnd ] whileFalse: 
+		[ stream atEnd ifTrue: [ ^ false ].
+		stream next = pattern next 
+			ifTrue: [ pattern position = 1 ifTrue: [ startMatch := stream position ] ]
+			ifFalse: 
+				[ pattern position: 0.
+				startMatch ifNotNil: 
+					[ stream position: startMatch.
+					startMatch := nil ] ] ].
+	^ true
+]
+
+{ #category : 'stream mimicry' }
+PPContext >> skipToAnyOf: aCharacterSet [ 
+	"Set the access position of the receiver to be past the next occurrence of
+	a character in the character set. Answer whether a fitting character is found."
+
+	[stream atEnd]
+		whileFalse: [ (aCharacterSet includes: stream next) ifTrue: [^true]].
+	^false
+]
+
+{ #category : 'acessing' }
+PPContext >> stream [
+	^ stream
+]
+
+{ #category : 'acessing' }
+PPContext >> stream: aStream [
+	stream := aStream.
+]
+
+{ #category : 'stream mimicry' }
+PPContext >> uncheckedPeek [
+	^ stream uncheckedPeek
+]
+
+{ #category : 'stream mimicry' }
+PPContext >> upTo: anObject [
+	^ stream upTo: anObject
+]
+
+{ #category : 'stream mimicry' }
+PPContext >> upToAll: whatever [
+	^ stream upToAll: whatever
+]
+
+{ #category : 'stream mimicry' }
+PPContext >> upToAnyOf: whatever [
+	^ stream upToAnyOf: whatever
+]

software/PetitParser/PPContext.extension.st

@@ -0,0 +1,28 @@
+Extension { #name : 'PPContext' }
+
+{ #category : '*PetitParser-Ruby-Parser' }
+PPContext >> heredocId [
+	^ self globalAt: #heredocId ifAbsent: nil
+]
+
+{ #category : '*PetitParser-Ruby-Parser' }
+PPContext >> heredocId: value [
+	self globalAt: #heredocId put: value
+]
+
+{ #category : '*PetitParser-Ruby-Parser' }
+PPContext >> percentStringEnd [
+	^ self globalAt: #percentStringEnd ifAbsent: nil
+]
+
+{ #category : '*PetitParser-Ruby-Parser' }
+PPContext >> percentStringStart: value [
+	| endValue |
+	endValue := value.
+	(value == $[) ifTrue: [ endValue := $] ].
+	(value == $() ifTrue: [ endValue := $) ].
+	(value == ${) ifTrue: [ endValue := $} ].
+
+	self globalAt: #percentStringStart put: value.
+	self globalAt: #percentStringEnd put: endValue
+]

software/PetitParser/PPContextMemento.class.st

@@ -0,0 +1,137 @@
+"
+I am an implementation of the memento design pattern.
+
+My goal is to remember the state of a PPContext to eventually be able to restore its state later.
+
+I should be instantiated using PPContext>>#memorize method.
+
+A PPContext can restore its state by providing the memento to PPContext>>#restore:.
+"
+Class {
+	#name : 'PPContextMemento',
+	#superclass : 'Object',
+	#instVars : [
+		'stream',
+		'position',
+		'properties'
+	],
+	#category : 'PetitParser-Core'
+}
+
+{ #category : 'comparing' }
+PPContextMemento >> = anObject [
+	
+	(self == anObject) ifTrue: [ ^ true ].
+	(anObject class = PPContextMemento) ifFalse: [ ^ false ].
+	
+	(anObject stream == stream) ifFalse: [ ^ false ].
+	(anObject position == position) ifFalse: [ ^ false ].
+	
+	(self propertiesSize == anObject propertiesSize) ifFalse: [ ^ false ].
+
+	self keysAndValuesDo: [ :key :value |
+		(anObject hasProperty: key) ifFalse: [ ^ false ].
+		((anObject propertyAt: key) = value) ifFalse: [ ^ false ]. 
+ 	].
+	
+	^ true.
+
+]
+
+{ #category : 'accessing - properties' }
+PPContextMemento >> hasProperty: aKey [
+	"Test if the property aKey is present."
+	
+	^ properties notNil and: [ properties includesKey: aKey ]
+]
+
+{ #category : 'comparing' }
+PPContextMemento >> hash [
+	^ (position hash bitXor: stream hash) bitXor: properties hash.
+]
+
+{ #category : 'accessing - properties' }
+PPContextMemento >> keysAndValuesDo: aBlock [
+	properties ifNil: [ ^ self ].
+	properties keysAndValuesDo: [ :key :value | aBlock value: key value: value copy ] 
+]
+
+{ #category : 'accessing' }
+PPContextMemento >> position [
+	^ position
+]
+
+{ #category : 'accessing' }
+PPContextMemento >> position: anInteger [
+	position := anInteger 
+]
+
+{ #category : 'accessing - properties' }
+PPContextMemento >> propertiesSize [
+	properties ifNil: [ ^ 0 ].
+	^ properties size.
+]
+
+{ #category : 'accessing - properties' }
+PPContextMemento >> propertyAt: aKey [
+	"Answer the property value associated with aKey."
+	
+	^ self propertyAt: aKey ifAbsent: [ self error: 'Property not found' ]
+]
+
+{ #category : 'accessing - properties' }
+PPContextMemento >> propertyAt: aKey ifAbsent: aBlock [
+	"Answer the property value associated with aKey or, if aKey isn't found, answer the result of evaluating aBlock."
+	
+	properties isNil
+		ifTrue: [ ^ aBlock value ]
+		ifFalse: [ 
+			(properties includesKey: aKey) ifTrue: [ 
+				^ (properties at: aKey) copy
+			].
+			^ aBlock value
+		]
+]
+
+{ #category : 'accessing - properties' }
+PPContextMemento >> propertyAt: aKey ifAbsentPut: aBlock [
+	"Answer the property associated with aKey or, if aKey isn't found store the result of evaluating aBlock as new value."
+	
+	^ self propertyAt: aKey ifAbsent: [ self propertyAt: aKey put: aBlock value ]
+]
+
+{ #category : 'accessing - properties' }
+PPContextMemento >> propertyAt: aKey put: anObject [
+	"Set the property at aKey to be anObject. If aKey is not found, create a new entry for aKey and set is value to anObject. Answer anObject."
+
+	^ (properties ifNil: [ properties := Dictionary new: 1 ])
+		at: aKey put: (anObject copy)
+]
+
+{ #category : 'accessing - properties' }
+PPContextMemento >> removeProperty: aKey [
+	"Remove the property with aKey. Answer the property or raise an error if aKey isn't found."
+	
+	^ self removeProperty: aKey ifAbsent: [ self error: 'Property not found' ]
+]
+
+{ #category : 'accessing - properties' }
+PPContextMemento >> removeProperty: aKey ifAbsent: aBlock [
+	"Remove the property with aKey. Answer the value or, if aKey isn't found, answer the result of evaluating aBlock."
+	
+	| answer |
+	properties isNil ifTrue: [ ^ aBlock value ].
+	answer := properties removeKey: aKey ifAbsent: aBlock.
+	properties isEmpty ifTrue: [ properties := nil ].
+	^ answer
+]
+
+{ #category : 'accessing' }
+PPContextMemento >> stream [
+	^ stream
+]
+
+{ #category : 'accessing' }
+PPContextMemento >> stream: aStream [
+	stream := aStream
+]

software/PetitParser/PPDelegateParser.class.st

@@ -0,0 +1,34 @@
+"
+A parser that delegates to another parser.
+
+Instance Variables:
+	parser	<PPParser>	The parser to delegate to.
+"
+Class {
+	#name : 'PPDelegateParser',
+	#superclass : 'PPParser',
+	#instVars : [
+		'parser'
+	],
+	#category : 'PetitParser-Parsers'
+}
+
+{ #category : 'instance creation' }
+PPDelegateParser class >> on: aParser [
+	^ self new setParser: aParser
+]
+
+{ #category : 'accessing' }
+PPDelegateParser >> children [
+	^ Array with: parser
+]
+
+{ #category : 'parsing' }
+PPDelegateParser >> parseOn: aPPContext [
+	^ parser parseOn: aPPContext
+]
+
+{ #category : 'initialization' }
+PPDelegateParser >> setParser: aParser [
+	parser := aParser
+]

software/PetitParser/PPEndOfFileParser.class.st

@@ -0,0 +1,29 @@
+"
+A PPEndOfFileParser is parser that will will return true if the stream position is at the end, returns failure otherwise.
+
+The diffirenece between PPEndOfFIleParser and PPEndOfInputParser is:
+ - PPEndOfFileParser can be created using #eof asParser
+ - PPEndOfInputParser can be created by using parser end
+ - PPEndOfFileParser does not delegate to any other parser
+ - PPEndOfInputParser parsers its delegate and then decides if the input is at the end.
+
+The PPEndOfFileParser can be used to accept some input only if it is at the end of the input, e.g:
+
+   ('a' asParser, #eof asParser) parse: 'a'
+   ('a' asParser, #eof asParser) parse: 'aa'
+
+"
+Class {
+	#name : 'PPEndOfFileParser',
+	#superclass : 'PPParser',
+	#category : 'PetitParser-Parsers'
+}
+
+{ #category : 'parsing' }
+PPEndOfFileParser >> parseOn: aPPContext [
+	(aPPContext atEnd) ifFalse:
+	[
+		^ PPFailure message: 'end of input expected' context: aPPContext.
+	].
+	^ #'end-of-input'
+]

software/PetitParser/PPEndOfInputParser.class.st

@@ -0,0 +1,27 @@
+"
+A parser that succeeds only at the end of the input stream.
+"
+Class {
+	#name : 'PPEndOfInputParser',
+	#superclass : 'PPDelegateParser',
+	#category : 'PetitParser-Parsers'
+}
+
+{ #category : 'operators' }
+PPEndOfInputParser >> end [
+	^ self
+]
+
+{ #category : 'parsing' }
+PPEndOfInputParser >> parseOn: aPPContext [
+	| memento result |
+	memento := aPPContext remember.
+	result := parser parseOn: aPPContext.
+	(result isPetitFailure or: [ aPPContext stream atEnd ])
+		ifTrue: [ ^ result ].
+	result := PPFailure
+		message: 'end of input expected'
+		context: aPPContext.
+	aPPContext restore: memento.
+	^ result
+]

software/PetitParser/PPEndOfLineParser.class.st

@@ -0,0 +1,16 @@
+"
+A PPEndOfLineParser is a parser that does not fail, if the stream position is at the end of a line. It does not consume anything.
+"
+Class {
+	#name : 'PPEndOfLineParser',
+	#superclass : 'PPParser',
+	#category : 'PetitParser-Parsers'
+}
+
+{ #category : 'parsing' }
+PPEndOfLineParser >> parseOn: aPPContext [
+	(aPPContext isEndOfLine) ifTrue: [ 
+		^ #endOfLine
+	].
+	^ PPFailure message: 'End of line expected' context: aPPContext at: aPPContext position
+]

software/PetitParser/PPEpsilonParser.class.st

@@ -0,0 +1,13 @@
+"
+A parser that consumes nothing and always succeeds.
+"
+Class {
+	#name : 'PPEpsilonParser',
+	#superclass : 'PPParser',
+	#category : 'PetitParser-Parsers'
+}
+
+{ #category : 'parsing' }
+PPEpsilonParser >> parseOn: aStream [
+	^ nil
+]

software/PetitParser/PPExpressionParser.class.st

@@ -0,0 +1,155 @@
+"
+A PPExpressionParser is a parser to conveniently define an expression grammar with prefix, postfix, and left- and right-associative infix operators.
+
+The following code initializes a parser for arithmetic expressions. First we instantiate an expression parser, a simple parser for expressions in parenthesis and a simple parser for integer numbers.
+
+	expression := PPExpressionParser new.
+	parens := $( asParser token trim , expression , $) asParser token trim 
+		==> [ :nodes | nodes second ].
+	integer := #digit asParser plus token trim
+		==> [ :token | token value asInteger ].
+	
+Then we define on what term the expression grammar is built on:
+
+	expression term: parens / integer.
+	
+Finally we define the operator-groups in descending precedence. Note, that the action blocks receive both, the terms and the parsed operator in the order they appear in the parsed input. 
+	
+	expression
+		group: [ :g |
+			g prefix: $- asParser token trim do: [ :op :a | a negated ] ];
+		group: [ :g |
+			g postfix: '++' asParser token trim do: [ :a :op | a + 1 ].
+			g postfix: '--' asParser token trim do: [ :a :op | a - 1 ] ];
+		group: [ :g |
+			g right: $^ asParser token trim do: [ :a :op :b | a raisedTo: b ] ];
+		group: [ :g |
+			g left: $* asParser token trim do: [ :a :op :b | a * b ].
+			g left: $/ asParser token trim do: [ :a :op :b | a / b ] ];
+		group: [ :g |
+			g left: $+ asParser token trim do: [ :a :op :b | a + b ].
+			g left: $- asParser token trim do: [ :a :op :b | a - b ] ].
+		
+After evaluating the above code the 'expression' is an efficient parser that evaluates examples like:
+
+	expression parse: '-8++'.
+	expression parse: '1+2*3'.
+	expression parse: '1*2+3'.
+	expression parse: '(1+2)*3'.
+	expression parse: '8/4/2'.
+	expression parse: '8/(4/2)'.
+	expression parse: '2^2^3'.
+	expression parse: '(2^2)^3'.
+	
+Instance Variables:
+	operators	<Dictionary>	The operators defined in the current group.
+"
+Class {
+	#name : 'PPExpressionParser',
+	#superclass : 'PPDelegateParser',
+	#instVars : [
+		'operators'
+	],
+	#category : 'PetitParser-Tools'
+}
+
+{ #category : 'private' }
+PPExpressionParser >> build: aParser left: aChoiceParser [
+	^ (aParser separatedBy: aChoiceParser) foldLeft: [ :a :op :b | op first value: a value: op second value: b ]
+]
+
+{ #category : 'private' }
+PPExpressionParser >> build: aParser postfix: aChoiceParser [
+	^ aParser , aChoiceParser star map: [ :term :ops | ops inject: term into: [ :result :operator | operator first value: result value: operator second ] ]
+]
+
+{ #category : 'private' }
+PPExpressionParser >> build: aParser prefix: aChoiceParser [
+	^ aChoiceParser star , aParser map: [ :ops :term | ops reverse inject: term into: [ :result :operator | operator first value: operator second value: result ] ]
+]
+
+{ #category : 'private' }
+PPExpressionParser >> build: aParser right: aChoiceParser [
+	^ (aParser separatedBy: aChoiceParser) foldRight: [ :a :op :b | op first value: a value: op second value: b ]
+]
+
+{ #category : 'private' }
+PPExpressionParser >> buildOn: aParser [
+	^ self buildSelectors inject: aParser into: [ :term :selector |
+		| list |
+		list := operators at: selector ifAbsent: [ #() ].
+		list isEmpty
+			ifTrue: [ term ]
+			ifFalse: [
+				self
+					perform: selector with: term 
+					with: (list size = 1
+						ifTrue: [ list first first ==> [ :operator | Array with: list first second with: operator ] ]
+						ifFalse: [ 
+							list
+								inject: PPChoiceParser new
+								into: [ :choice :each | choice / (each first ==> [ :operator | Array with: each second with: operator ]) ] ]) ] ]
+]
+
+{ #category : 'private' }
+PPExpressionParser >> buildSelectors [
+	^ #(build:prefix: build:postfix: build:right: build:left:)
+]
+
+{ #category : 'specifying' }
+PPExpressionParser >> group: aOneArgumentBlock [
+	"Defines a priority group by evaluating aOneArgumentBlock."
+	
+	operators := Dictionary new.
+	parser := [ 
+		aOneArgumentBlock value: self.
+	 	self buildOn: parser ]
+			ensure: [ operators := nil ]
+]
+
+{ #category : 'specifying' }
+PPExpressionParser >> left: aParser do: aThreeArgumentBlock [
+	"Define an operator aParser that is left-associative. Evaluate aThreeArgumentBlock with the first term, the operator, and the second term."
+	
+	self operator: #build:left: parser: aParser do: aThreeArgumentBlock
+]
+
+{ #category : 'private' }
+PPExpressionParser >> operator: aSymbol parser: aParser do: aBlock [
+	parser isNil
+		ifTrue: [ ^ self error: 'You did not specify a term when creating the receiver.' ].
+	operators isNil
+		ifTrue: [ ^ self error: 'Use #group: to define precedence groups in descending order.' ].
+	(operators at: aSymbol ifAbsentPut: [ OrderedCollection new ])
+		addLast: (Array with: aParser asParser with: aBlock)
+]
+
+{ #category : 'specifying' }
+PPExpressionParser >> postfix: aParser do: aTwoArgumentBlock [
+	"Define a postfix operator aParser. Evaluate aTwoArgumentBlock with the term and the operator."
+
+	self operator: #build:postfix: parser: aParser do: aTwoArgumentBlock
+]
+
+{ #category : 'specifying' }
+PPExpressionParser >> prefix: aParser do: aTwoArgumentBlock [
+	"Define a prefix operator aParser. Evaluate aTwoArgumentBlock with the operator and the term."
+
+	self operator: #build:prefix: parser: aParser do: aTwoArgumentBlock
+]
+
+{ #category : 'specifying' }
+PPExpressionParser >> right: aParser do: aThreeArgumentBlock [
+	"Define an operator aParser that is right-associative. Evaluate aThreeArgumentBlock with the first term, the operator, and the second term."
+	
+	self operator: #build:right: parser: aParser do: aThreeArgumentBlock
+]
+
+{ #category : 'specifying' }
+PPExpressionParser >> term: aParser [
+	"Defines the initial term aParser of the receiver."
+	
+	parser isNil
+		ifTrue: [ parser := aParser ]
+		ifFalse: [ self error: 'Unable to redefine the term.' ]
+]

software/PetitParser/PPFailingParser.class.st

@@ -0,0 +1,43 @@
+"
+A parser that consumes nothing and always fails.
+
+Instance Variables:
+	message <String>	The failure message.
+
+"
+Class {
+	#name : 'PPFailingParser',
+	#superclass : 'PPParser',
+	#instVars : [
+		'message'
+	],
+	#category : 'PetitParser-Parsers'
+}
+
+{ #category : 'instance creation' }
+PPFailingParser class >> message: aString [
+	^ self new setMessage: aString
+]
+
+{ #category : 'accessing' }
+PPFailingParser >> message [
+	"Answer the error message of the receiving parser."
+
+	^ message
+]
+
+{ #category : 'pp-context' }
+PPFailingParser >> parseOn: aPPContext [
+	^ PPFailure message: message context: aPPContext
+]
+
+{ #category : 'printing' }
+PPFailingParser >> printNameOn: aStream [
+	super printNameOn: aStream.
+	aStream nextPutAll: ', '; print: message
+]
+
+{ #category : 'initialization' }
+PPFailingParser >> setMessage: aString [
+	message := aString
+]

software/PetitParser/PPFailure.class.st

@@ -0,0 +1,95 @@
+"
+The failure object in PetitParser. It is the only class that responds to #isPetitFailure with true. It contains an error message and a position of the occurrence of the failure.
+
+Instance Variables:
+	message	<String>	The error message of this failure.
+	position	<Integer>	The position of this failure in the input stream.
+
+"
+Class {
+	#name : 'PPFailure',
+	#superclass : 'Object',
+	#instVars : [
+		'message',
+		'context',
+		'position'
+	],
+	#category : 'PetitParser-Core'
+}
+
+{ #category : 'instance creation' }
+PPFailure class >> message: aString [
+	^ self basicNew initializeMessage: aString 
+]
+
+{ #category : 'instance creation' }
+PPFailure class >> message: aString at: anInteger [
+	"One should not use this method if the furthest failure is supposed to be reported correctly"
+	^ self basicNew initializeMessage: aString at: anInteger
+]
+
+{ #category : 'instance creation' }
+PPFailure class >> message: aString context: aPPContext [
+	^ self basicNew initializeMessage: aString context: aPPContext
+]
+
+{ #category : 'instance creation' }
+PPFailure class >> message: aString context: aPPContext at: position [
+	^ self basicNew initializeMessage: aString context: aPPContext position: position
+]
+
+{ #category : 'initialization' }
+PPFailure >> initializeMessage: aString [	
+	message := aString.
+
+]
+
+{ #category : 'initialization' }
+PPFailure >> initializeMessage: aString at: anInteger [
+	"One should not use this method if the furthest failure is supposed to be reported correctly"
+	message := aString.
+	position := anInteger.
+]
+
+{ #category : 'initialization' }
+PPFailure >> initializeMessage: aString context: aPPContext [
+	self initializeMessage: aString context:  aPPContext position: aPPContext position
+]
+
+{ #category : 'initialization' }
+PPFailure >> initializeMessage: aString context: aPPContext position: anInteger [
+	message := aString.
+	context := aPPContext.
+	position := anInteger.
+	
+	"record the furthest failure encountered while parsing the input stream "
+	aPPContext noteFailure: self.	
+]
+
+{ #category : 'testing' }
+PPFailure >> isPetitFailure [
+	"I am the only class that should implement this method to return true."
+
+	^ true
+]
+
+{ #category : 'accessing' }
+PPFailure >> message [
+	"Answer a human readable error message of this parse failure."
+	
+	^ message
+]
+
+{ #category : 'accessing' }
+PPFailure >> position [
+	"Answer the position in the source string that caused this parse failure."
+
+	^ position
+]
+
+{ #category : 'printing' }
+PPFailure >> printOn: aStream [
+	aStream 
+		nextPutAll: (self message ifNil: ['<message not specified>']); 
+		nextPutAll: ' at '; print: self position
+]

software/PetitParser/PPFlattenParser.class.st

@@ -0,0 +1,22 @@
+"
+A parser that answers a flat copy of the range my delegate parses.
+"
+Class {
+	#name : 'PPFlattenParser',
+	#superclass : 'PPDelegateParser',
+	#category : 'PetitParser-Parsers'
+}
+
+{ #category : 'private' }
+PPFlattenParser >> on: aCollection start: aStartInteger stop: aStopInteger value: anObject [
+	^ aCollection copyFrom: aStartInteger to: aStopInteger
+]
+
+{ #category : 'parsing' }
+PPFlattenParser >> parseOn: aPPContext [
+	| start element |
+	start := aPPContext position.
+	element := parser parseOn: aPPContext.
+	element isPetitFailure ifTrue: [ ^ element ].
+	^ self on: aPPContext stream collection start: start + 1 stop: aPPContext position value: element
+]

software/PetitParser/PPGreedyRepeatingParser.class.st

@@ -0,0 +1,46 @@
+"
+A greedy repeating parser, commonly seen in regular expression implementations. It aggressively consumes as much input as possible and then backtracks to meet the 'limit' condition.
+
+This class essentially implements the iterative version of the following recursive parser composition:
+
+	| parser |
+	parser := PPChoiceParser new.
+	parser setParsers: (Array
+		with: (self , parser map: [ :each :rest | rest addFirst: each; yourself ])
+		with: (limit and ==> [ :each | OrderedCollection new ])).
+	^ parser ==> [ :rest | rest asArray ]
+"
+Class {
+	#name : 'PPGreedyRepeatingParser',
+	#superclass : 'PPLimitedRepeatingParser',
+	#category : 'PetitParser-Parsers'
+}
+
+{ #category : 'parsing' }
+PPGreedyRepeatingParser >> parseOn: aPPContext [
+	| memento element elements positions |
+	memento := aPPContext remember.
+	elements := OrderedCollection new.
+	[ elements size < min ] whileTrue: [ 
+		(element := parser parseOn: aPPContext) isPetitFailure ifTrue: [ 
+			aPPContext restore: memento.
+			^ element ].
+		elements addLast: element ].
+	positions := OrderedCollection with: aPPContext remember.
+	[ elements size < max and: [ (element := parser parseOn: aPPContext) isPetitFailure not ] ] whileTrue: [
+		elements addLast: element.
+		positions addLast: aPPContext remember ].
+	[ positions isEmpty ] whileFalse: [
+		aPPContext restore: positions last.
+		element := limit parseOn: aPPContext.
+		element isPetitFailure ifFalse: [
+			aPPContext restore: positions last.
+			^ elements asArray ].
+		elements isEmpty ifTrue: [
+			aPPContext restore: memento.
+			^ element ].
+		elements removeLast.
+		positions removeLast ].
+	aPPContext restore: memento.
+	^ PPFailure message: 'overflow' context: aPPContext at: memento position
+]

software/PetitParser/PPLazyRepeatingParser.class.st

@@ -0,0 +1,39 @@
+"
+A lazy repeating parser, commonly seen in regular expression implementations. It limits its consumption to meet the 'limit' condition as early as possible.
+
+This class essentially implements the iterative version of the following recursive parser composition:
+
+	| parser |
+	parser := PPChoiceParser new.
+	parser setParsers: (Array
+		with: (limit and ==> [ :each | OrderedCollection new ])
+		with: (self , parser map: [ :each :rest | rest addFirst: each; yourself ])).
+	^ parser ==> [ :rest | rest asArray ]
+"
+Class {
+	#name : 'PPLazyRepeatingParser',
+	#superclass : 'PPLimitedRepeatingParser',
+	#category : 'PetitParser-Parsers'
+}
+
+{ #category : 'parsing' }
+PPLazyRepeatingParser >> parseOn: aPPContext [
+	| memento element elements |
+	memento := aPPContext remember.
+	elements := OrderedCollection new.
+	[ elements size < min ] whileTrue: [
+		(element := parser parseOn: aPPContext) isPetitFailure ifTrue: [
+			aPPContext restore: memento.
+			^ element ].
+		elements addLast: element ].
+	[ self matchesLimitOn: aPPContext ] whileFalse: [
+		elements size < max ifFalse: [
+			aPPContext restore: memento.
+			^ PPFailure message: 'overflow' context: aPPContext at: memento position ].
+		element := parser parseOn: aPPContext.
+		element isPetitFailure ifTrue: [
+			aPPContext restore: memento.
+			^ element ].
+		elements addLast: element ].
+	^ elements asArray
+]

software/PetitParser/PPLimitedChoiceParser.class.st

@@ -0,0 +1,72 @@
+"
+A PPLimitedChoiceParser is similar to the choice parser except for the fact, that limit must pass if one of the choices passes. This is similar strategy as with the PPLimitedRepeatingParsers.
+
+This way, one can implement choices that successfully parse this (if limit is filled with 'a'):
+
+('aa' // 'a') 'a' parse: 'aa'
+
+The limit can be automatically filled using elements from either follow or next set (see methods  PPParser>>followSets or PPParser>>nextSets).
+
+Limit is by default epsilon and therefore it behaves as an ordinary ordered choice.
+
+Instance Variables
+	limit:		<Object>
+
+limit
+	- xxxxx
+
+"
+Class {
+	#name : 'PPLimitedChoiceParser',
+	#superclass : 'PPChoiceParser',
+	#instVars : [
+		'limit'
+	],
+	#category : 'PetitParser-Parsers'
+}
+
+{ #category : 'operators' }
+PPLimitedChoiceParser >> // aRule [ 
+	^ self copyWith: aRule
+]
+
+{ #category : 'initialization' }
+PPLimitedChoiceParser >> initialize [
+	limit := nil asParser
+]
+
+{ #category : 'accessing' }
+PPLimitedChoiceParser >> limit [
+	
+	^ limit
+]
+
+{ #category : 'accessing' }
+PPLimitedChoiceParser >> limit: anObject [
+	
+	limit := anObject
+]
+
+{ #category : 'parsing' }
+PPLimitedChoiceParser >> parseOn: aPPContext [
+	"This is optimized code that avoids unnecessary block activations, do not change. When all choices fail, the last failure is answered."
+
+	| element limitResult memento |
+	"self halt."
+	1 to: parsers size do: [ :index |
+		memento := aPPContext remember.
+		
+		element := (parsers at: index)
+			parseOn: aPPContext.
+		
+		(element isPetitFailure not) ifTrue: [ 
+			"check limit"
+			limitResult := limit parseOn: aPPContext.
+			limitResult isPetitFailure ifTrue: [ 
+				element := PPFailure message: 'limit failed' at: aPPContext position .
+				aPPContext restore: memento.
+			] ifFalse: [ ^ element ].
+		].
+	].	
+	^ element
+]

software/PetitParser/PPLimitedRepeatingParser.class.st

@@ -0,0 +1,45 @@
+"
+An abstract parser that repeatedly parses between 'min' and 'max' instances of my delegate and that requires the input to be completed with a specified parser 'limit'. Subclasses provide repeating behavior as typically seen in regular expression implementations (non-blind).
+
+Instance Variables:
+	limit	<PPParser>	The parser to complete the input with.
+"
+Class {
+	#name : 'PPLimitedRepeatingParser',
+	#superclass : 'PPRepeatingParser',
+	#instVars : [
+		'limit'
+	],
+	#category : 'PetitParser-Parsers'
+}
+
+{ #category : 'instance creation' }
+PPLimitedRepeatingParser class >> on: aParser limit: aLimitParser [
+	^ (self on: aParser) setLimit: aLimitParser
+]
+
+{ #category : 'accessing' }
+PPLimitedRepeatingParser >> children [
+	^ Array with: parser with: limit
+]
+
+{ #category : 'accessing' }
+PPLimitedRepeatingParser >> limit [
+	"Answer the parser that limits (or ends) this repetition."
+	
+	^ limit
+]
+
+{ #category : 'parsing' }
+PPLimitedRepeatingParser >> matchesLimitOn: aPPContext [
+	| element position |
+	position := aPPContext remember.
+	element := limit parseOn: aPPContext.
+	aPPContext restore: position.
+	^ element isPetitFailure not
+]
+
+{ #category : 'initialization' }
+PPLimitedRepeatingParser >> setLimit: aParser [
+	limit := aParser
+]

software/PetitParser/PPListParser.class.st

@@ -0,0 +1,58 @@
+"
+Abstract parser that parses a list of things in some way (to be specified by the subclasses).
+
+Instance Variables:
+	parsers	<SequenceableCollection of: PPParser>	A sequence of other parsers to delegate to.
+
+"
+Class {
+	#name : 'PPListParser',
+	#superclass : 'PPParser',
+	#instVars : [
+		'parsers'
+	],
+	#category : 'PetitParser-Parsers'
+}
+
+{ #category : 'instance creation' }
+PPListParser class >> with: aParser [
+	^ self withAll: (Array with: aParser)
+]
+
+{ #category : 'instance creation' }
+PPListParser class >> with: aFirstParser with: aSecondParser [
+	^ self withAll: (Array with: aFirstParser with: aSecondParser)
+]
+
+{ #category : 'instance creation' }
+PPListParser class >> withAll: aCollection [
+	^ self basicNew initialize;
+		setParsers: aCollection
+]
+
+{ #category : 'accessing' }
+PPListParser >> children [
+	^ parsers
+]
+
+{ #category : 'copying' }
+PPListParser >> copyWith: aParser [
+	^ self species withAll: (parsers copyWith: aParser)
+]
+
+{ #category : 'initialization' }
+PPListParser >> initialize [
+	super initialize.
+	self setParsers: #()
+]
+
+{ #category : 'copying' }
+PPListParser >> postCopy [
+	super postCopy.
+	parsers := parsers copy
+]
+
+{ #category : 'initialization' }
+PPListParser >> setParsers: aCollection [
+	parsers := aCollection asArray
+]

software/PetitParser/PPLiteralObjectParser.class.st

@@ -0,0 +1,28 @@
+"
+A parser that accepts a single literal object, such as a character. This is the same as the predicate parser 'PPPredicateParser expect: literal' but slightly more efficient.
+"
+Class {
+	#name : 'PPLiteralObjectParser',
+	#superclass : 'PPLiteralParser',
+	#category : 'PetitParser-Parsers'
+}
+
+{ #category : 'operators' }
+PPLiteralObjectParser >> caseInsensitive [
+	"Answer a parser that can parse the receiver case-insensitive."
+	
+	literal asUppercase = literal asLowercase ifTrue: [ ^ self ].
+	^ PPPredicateObjectParser on: [ :value | literal sameAs: value ] message: message
+]
+
+{ #category : 'operators' }
+PPLiteralObjectParser >> negate [
+	^ (PPPredicateObjectParser expect: literal message: message) negate
+]
+
+{ #category : 'parsing' }
+PPLiteralObjectParser >> parseOn: aPPContext [
+	^ (aPPContext stream atEnd not and: [ literal = aPPContext stream uncheckedPeek ])
+		ifFalse: [ PPFailure message: message context: aPPContext ]
+		ifTrue: [ aPPContext next ]
+]

software/PetitParser/PPLiteralParser.class.st

@@ -0,0 +1,61 @@
+"
+Abstract literal parser that parses some kind of literal type (to be specified by subclasses).
+
+Instance Variables:
+	literal	<Object>	The literal object to be parsed.
+	message	<String>	The error message to be generated.
+
+
+"
+Class {
+	#name : 'PPLiteralParser',
+	#superclass : 'PPParser',
+	#instVars : [
+		'literal',
+		'message'
+	],
+	#category : 'PetitParser-Parsers'
+}
+
+{ #category : 'instance creation' }
+PPLiteralParser class >> on: anObject [
+	^ self on: anObject message: anObject printString , ' expected'
+]
+
+{ #category : 'instance creation' }
+PPLiteralParser class >> on: anObject message: aString [
+	^ self new initializeOn: anObject message: aString
+]
+
+{ #category : 'operators' }
+PPLiteralParser >> caseInsensitive [
+	"Answer a parser that can parse the receiver case-insensitive."
+	
+	self subclassResponsibility
+]
+
+{ #category : 'initialization' }
+PPLiteralParser >> initializeOn: anObject message: aString [
+	literal := anObject.
+	message := aString
+]
+
+{ #category : 'accessing' }
+PPLiteralParser >> literal [
+	"Answer the parsed literal."
+
+	^ literal
+]
+
+{ #category : 'accessing' }
+PPLiteralParser >> message [
+	"Answer the failure message."
+	
+	^ message
+]
+
+{ #category : 'printing' }
+PPLiteralParser >> printNameOn: aStream [
+	super printNameOn: aStream.
+	aStream nextPutAll: ', '; print: literal
+]

software/PetitParser/PPLiteralSequenceParser.class.st

@@ -0,0 +1,42 @@
+"
+A parser accepts a sequence of literal objects, such as a String. This is an optimization to avoid having to compose longer sequences from PPSequenceParser.
+"
+Class {
+	#name : 'PPLiteralSequenceParser',
+	#superclass : 'PPLiteralParser',
+	#instVars : [
+		'size'
+	],
+	#category : 'PetitParser-Parsers'
+}
+
+{ #category : 'operators' }
+PPLiteralSequenceParser >> caseInsensitive [
+	"Answer a parser that can parse the receiver case-insensitive."
+	
+	literal asUppercase = literal asLowercase ifTrue: [ ^ self ].
+	^ PPPredicateSequenceParser on: [ :value | literal sameAs: value ] message: message size: size
+]
+
+{ #category : 'initialization' }
+PPLiteralSequenceParser >> initializeOn: anObject message: aString [
+	super initializeOn: anObject message: aString.
+	size := literal size
+]
+
+{ #category : 'parsing' }
+PPLiteralSequenceParser >> parseOn: aPPContext [
+	| memento result |
+	memento := aPPContext remember.
+	result := aPPContext next: size.
+	literal = result ifTrue: [ ^ result ].
+	aPPContext restore: memento.
+	^ PPFailure message: message context: aPPContext
+]
+
+{ #category : 'accessing' }
+PPLiteralSequenceParser >> size [
+	"Answer the sequence size of the receiver."
+
+	^ size
+]

software/PetitParser/PPMemento.class.st

@@ -0,0 +1,60 @@
+"
+PPMemento is an internal class used by PPMemoizedParser to cache results and detect left-recursive calls.
+
+Instance Variables:
+	result	<Object>	The cached result.
+	count	<Integer>	The number of recursive cycles followed.
+	
+"
+Class {
+	#name : 'PPMemento',
+	#superclass : 'Object',
+	#instVars : [
+		'result',
+		'count',
+		'context'
+	],
+	#category : 'PetitParser-Core'
+}
+
+{ #category : 'instance creation' }
+PPMemento class >> new [
+	^ self basicNew initialize
+]
+
+{ #category : 'accessing' }
+PPMemento >> contextMemento [
+	^ context
+]
+
+{ #category : 'accessing' }
+PPMemento >> contextMemento: aPPContextMemento [
+	context  := aPPContextMemento 
+
+]
+
+{ #category : 'accessing-readonly' }
+PPMemento >> count [
+	^ count
+]
+
+{ #category : 'actions' }
+PPMemento >> increment [
+	count := count + 1
+]
+
+{ #category : 'initialization' }
+PPMemento >> initialize [
+	count := 0
+	
+]
+
+{ #category : 'accessing' }
+PPMemento >> result [
+	^ result
+]
+
+{ #category : 'accessing' }
+PPMemento >> result: anObject [
+	result := anObject
+]

software/PetitParser/PPMemoizedParser.class.st

@@ -0,0 +1,60 @@
+"
+A memoized parser, for refraining redundant computations.
+
+Instance Variables:
+	stream	<PositionableStream>	The stream of the associated memento objects.
+	buffer	<Array of: PPMemento>	The buffer of memento objects.
+
+"
+Class {
+	#name : 'PPMemoizedParser',
+	#superclass : 'PPDelegateParser',
+	#instVars : [
+		'buffer',
+		'identifier'
+	],
+	#category : 'PetitParser-Parsers'
+}
+
+{ #category : 'parsing' }
+PPMemoizedParser >> check: aPPContext [
+	(identifier == aPPContext identifier)
+		ifFalse: [ self reset: aPPContext ].
+]
+
+{ #category : 'operators' }
+PPMemoizedParser >> memoized [
+	"Ther is no point in memoizing more than once."
+
+	^ self
+]
+
+{ #category : 'operators' }
+PPMemoizedParser >> nonMemoized [
+	^ parser
+]
+
+{ #category : 'parsing' }
+PPMemoizedParser >> parseOn: aPPContext [
+	| memento contextMemento  aStream |
+	"TODO: JK memoizing needs review!"
+	self check: aPPContext.
+	contextMemento := aPPContext remember.
+	memento := (buffer at: contextMemento ifAbsentPut: [ PPMemento new ]).
+	
+	memento contextMemento isNil
+		ifTrue: [
+			aStream := aPPContext stream.
+			memento result: (aStream size - aStream position + 2 < memento count
+				ifTrue: [ PPFailure message: 'overflow' context: aPPContext ]
+				ifFalse: [ memento increment. parser parseOn: aPPContext ]).
+			memento contextMemento: aPPContext remember ]
+		ifFalse: [ aPPContext restore: memento contextMemento ].
+	^ memento result.
+]
+
+{ #category : 'parsing' }
+PPMemoizedParser >> reset: aPPContext [
+	buffer := Dictionary new.
+	identifier := aPPContext identifier.
+]

software/PetitParser/PPNotParser.class.st

@@ -0,0 +1,18 @@
+"
+The not-predicate, a parser that succeeds whenever its delegate does not, but consumes no input [Parr 1994, 1995].
+"
+Class {
+	#name : 'PPNotParser',
+	#superclass : 'PPDelegateParser',
+	#category : 'PetitParser-Parsers'
+}
+
+{ #category : 'parsing' }
+PPNotParser >> parseOn: aPPContext [
+	| element memento |
+	memento := aPPContext remember.
+	element := parser parseOn: aPPContext.
+	aPPContext restore: memento.
+	^ element isPetitFailure
+		ifFalse: [ PPFailure message: '' context: aPPContext ]
+]

software/PetitParser/PPOptionalParser.class.st

@@ -0,0 +1,15 @@
+"
+A parser that optionally parsers its delegate, or answers nil.
+"
+Class {
+	#name : 'PPOptionalParser',
+	#superclass : 'PPDelegateParser',
+	#category : 'PetitParser-Parsers'
+}
+
+{ #category : 'parsing' }
+PPOptionalParser >> parseOn: aPPContext [
+	| element |
+	element := parser parseOn: aPPContext.
+	^ element isPetitFailure ifFalse: [ element ]
+]

software/PetitParser/PPParser.class.st

@@ -0,0 +1,710 @@
+"
+An abstract parser for all parsers in PetitParser. Subclasses implement #parseOn: to perform the actual recursive-descent parsing. All parsers support a variety of methods to perform an actual parse, see the methods in the #parsing protocol. Parsers are combined with a series of operators that can be found in the #operations protocol.
+
+Instance Variables:
+	properties	<Dictionary>	Stores additional state in the parser object.
+
+"
+Class {
+	#name : 'PPParser',
+	#superclass : 'Object',
+	#instVars : [
+		'properties'
+	],
+	#category : 'PetitParser-Parsers'
+}
+
+{ #category : 'instance creation' }
+PPParser class >> named: aString [
+	^ self new name: aString
+]
+
+{ #category : 'instance creation' }
+PPParser class >> new [
+	^ self basicNew initialize
+]
+
+{ #category : 'operators' }
+PPParser >> , aParser [ 
+	"Answer a new parser that parses the receiver followed by aParser."
+
+	^ PPSequenceParser with: self with: aParser
+]
+
+{ #category : 'operators' }
+PPParser >> / aParser [ 
+	"Answer a new parser that parses the receiver, if the receiver fails try with aParser (ordered-choice)."
+	
+	^ PPChoiceParser with: self with: aParser
+]
+
+{ #category : 'operators' }
+PPParser >> // aParser [ 
+	"
+		Answer a new parser that parses the receiver, if the receiver fails try with aParser (ordered-choice).
+		If the receiver passes, limit must pass as well.
+	"
+	
+	^ PPLimitedChoiceParser with: self with: aParser
+]
+
+{ #category : 'operators-mapping' }
+PPParser >> ==> aBlock [
+	"Answer a new parser that performs aBlock as action handler on success."
+
+	^ PPActionParser on: self block: aBlock
+]
+
+{ #category : 'operators-mapping' }
+PPParser >> >=> aBlock [
+	"Answer a new parser that wraps the receiving parser with a two argument block. The first argument is the parsed stream, the second argument a continuation block on the delegate parser."
+
+	^ PPWrappingParser on: self block: aBlock
+]
+
+{ #category : 'enumerating' }
+PPParser >> allParsers [
+	"Answer all the parse nodes of the receiver."
+
+	| result |
+	result := OrderedCollection new.
+	self allParsersDo: [ :parser | result addLast: parser ].
+	^ result
+]
+
+{ #category : 'enumerating' }
+PPParser >> allParsersDo: aBlock [
+	"Iterate over all the parse nodes of the receiver."
+
+	self allParsersDo: aBlock seen: IdentitySet new
+]
+
+{ #category : 'enumerating' }
+PPParser >> allParsersDo: aBlock seen: aSet [
+	"Iterate over all the parse nodes of the receiver, do not visit and follow the ones contained in aSet."
+
+	(aSet includes: self)
+		ifTrue: [ ^ self ].
+	aSet add: self.
+	aBlock value: self.
+	self children
+		do: [ :each | each allParsersDo: aBlock seen: aSet ]
+]
+
+{ #category : 'operators' }
+PPParser >> and [
+	"Answer a new parser (logical and-predicate) that succeeds whenever the receiver does, but never consumes input."
+
+	^ PPAndParser on: self
+]
+
+{ #category : 'operators-mapping' }
+PPParser >> answer: anObject [
+	"Answer a new parser that always returns anObject from a successful parse."
+
+	^ self ==> [ :nodes | anObject ]
+]
+
+{ #category : 'converting' }
+PPParser >> asParser [
+	"Answer the receiving parser."
+	
+	^ self
+]
+
+{ #category : 'accessing' }
+PPParser >> child [
+	self assert: (self children size == 1).
+	^ self children first
+]
+
+{ #category : 'accessing' }
+PPParser >> children [
+	"Answer a set of child parsers that could follow the receiver."
+
+	^ #()
+]
+
+{ #category : 'operators' }
+PPParser >> def: aParser [
+	"Redefine the receiver as the argument aParser. This method is useful when defining recursive parsers: instantiate a PPUnresolvedParser and later redefine it with another one."
+
+	^ self becomeForward: (aParser name: self name)
+]
+
+{ #category : 'operators-convenience' }
+PPParser >> delimitedBy: aParser [
+	"Answer a new parser that parses the receiver one or more times, separated and possibly ended by aParser."
+	
+	^ (self separatedBy: aParser) , (aParser optional) ==> [ :node |
+		node second isNil
+			ifTrue: [ node first ]
+			ifFalse: [ node first copyWith: node second ] ]
+]
+
+{ #category : 'operators' }
+PPParser >> end [
+	"Answer a new parser that succeeds at the end of the input and return the result of the receiver."
+
+	^ PPEndOfInputParser on: self
+]
+
+{ #category : 'operators-mapping' }
+PPParser >> flatten [
+	"Answer a new parser that flattens the underlying collection."
+	
+	^ PPFlattenParser on: self
+]
+
+{ #category : 'operators-mapping' }
+PPParser >> foldLeft: aBlock [
+	"Answer a new parser that that folds the result of the receiver from left-to-right into aBlock. The argument aBlock must take two or more arguments."
+	
+	| size args |
+	size := aBlock numArgs.
+	args := Array new: size.
+	^ self ==> [ :nodes |
+		args at: 1 put: nodes first.
+		2 to: nodes size by: size - 1 do: [ :index |
+			args
+				replaceFrom: 2 to: size with: nodes startingAt: index;
+				at: 1 put: (aBlock valueWithArguments: args) ].
+		args first ]
+]
+
+{ #category : 'operators-mapping' }
+PPParser >> foldRight: aBlock [
+	"Answer a new parser that that folds the result of the receiver from right-to-left into aBlock. The argument aBlock must take two or more arguments."
+
+	| size args |
+	size := aBlock numArgs.
+	args := Array new: size.
+	^ self ==> [ :nodes |
+		args at: size put: nodes last.
+		nodes size - size + 1 to: 1 by: 1 - size do: [ :index |
+			args
+				replaceFrom: 1 to: size - 1 with: nodes startingAt: index;
+				at: size put: (aBlock valueWithArguments: args) ].
+		args at: size ]
+]
+
+{ #category : 'accessing-properties' }
+PPParser >> hasProperty: aKey [
+	"Test if the property aKey is present."
+	
+	^ properties notNil and: [ properties includesKey: aKey ]
+]
+
+{ #category : 'operators' }
+PPParser >> if: aBlock [
+	^ PPConditionalParser on: self block: aBlock
+]
+
+{ #category : 'initialization' }
+PPParser >> initialize [
+]
+
+{ #category : 'testing' }
+PPParser >> isPetitParser [
+	^ true
+]
+
+{ #category : 'testing' }
+PPParser >> isUnresolved [
+	^ false
+]
+
+{ #category : 'operators-mapping' }
+PPParser >> map: aBlock [
+	"Answer a new parser that works on the receiving sequence an passes in each element as a block argument."
+	
+	^ aBlock numArgs = 1
+		ifTrue: [ self ==> aBlock ]
+		ifFalse: [ self error: aBlock numArgs asString , ' arguments expected.' ]
+
+]
+
+{ #category : 'parsing' }
+PPParser >> matches: anObject [
+	"Answer if anObject can be parsed by the receiver."
+	
+	^ (self parse: anObject) isPetitFailure not
+]
+
+{ #category : 'parsing' }
+PPParser >> matchesIn: anObject [
+	"Search anObject repeatedly for the matches of the receiver. Answered an OrderedCollection of the matched parse-trees."
+
+	| result |
+	result := OrderedCollection new.
+	self 
+		matchesIn: anObject
+		do: [ :each | result addLast: each ].
+	^ result
+]
+
+{ #category : 'parsing' }
+PPParser >> matchesIn: anObject do: aBlock [
+	"Search anObject repeatedly for the matches of the receiver. Evaluate aBlock for each match with the matched parse-tree as the argument. Make sure to always consume exactly one character with each step, to not miss any match."
+
+	((self and ==> aBlock , #any asParser) / #any asParser) star parse: anObject
+]
+
+{ #category : 'parsing' }
+PPParser >> matchesSkipIn: anObject [
+	"Search anObject repeatedly for the matches of the receiver. Answer an OrderedCollection of the matched parse-trees. Skip over matches."
+
+	| result |
+	result := OrderedCollection new.
+	self 
+		matchesSkipIn: anObject
+		do: [ :each | result addLast: each ].
+	^ result
+]
+
+{ #category : 'parsing' }
+PPParser >> matchesSkipIn: anObject do: aBlock [
+	"Search anObject repeatedly for the matches of the receiver. Evaluate aBlock for each match with the matched parse-tree as the argument. Skip over matches."
+
+	(self ==> aBlock / #any asParser) star parse: anObject
+]
+
+{ #category : 'parsing' }
+PPParser >> matchingRangesIn: anObject [
+	"Search anObject repeatedly for the matches of the receiver. Answer an OrderedCollection of ranges of each match (index of first character to: index of last character)."
+	
+	| result |
+	result := OrderedCollection new.
+	self
+		matchingRangesIn: anObject
+		do: [ :value | result addLast: value ].
+	^ result
+]
+
+{ #category : 'parsing' }
+PPParser >> matchingRangesIn: anObject do: aBlock [
+	"Search anObject repeatedly for the matches of the receiver. Evaluate aBlock with the range of each match (index of first character to: index of last character)."
+
+	self token
+		matchesIn: anObject
+		do: [ :token | aBlock value: (token start to: token stop) ]
+]
+
+{ #category : 'parsing' }
+PPParser >> matchingSkipRangesIn: anObject [
+	"Search anObject repeatedly for the matches of the receiver. Skip over matches. Answer an OrderedCollection of ranges of each match (index of first character to: index of last character)."
+	
+	| result |
+	result := OrderedCollection new.
+	self
+		matchingSkipRangesIn: anObject
+		do: [ :value | result addLast: value ].
+	^ result
+]
+
+{ #category : 'parsing' }
+PPParser >> matchingSkipRangesIn: anObject do: aBlock [
+	"Search anObject repeatedly for the matches of the receiver. Skip over matches. Evaluate aBlock with the range of each match (index of first character to: index of last character)."
+	
+	self token
+		matchesSkipIn: anObject
+		do: [ :token | aBlock value: (token start to: token stop) ]
+]
+
+{ #category : 'operators-repeating' }
+PPParser >> max: anInteger [
+	"Answer a new parser that parses the receiver at most anInteger times."
+	
+	^ self star setMax: anInteger
+]
+
+{ #category : 'operators-repeating' }
+PPParser >> max: anInteger greedy: aParser [
+	"Answer a new parser that parses the receiver at most anInteger times until it reaches aParser. This is a greedy non-blind implementation. aParser is not consumed."
+	
+	^ (self starGreedy: aParser) setMax: anInteger
+]
+
+{ #category : 'operators-repeating' }
+PPParser >> max: anInteger lazy: aParser [
+	"Answer a new parser that parses the receiver at most anInteger times until it reaches aParser. This is a lazy non-blind implementation. aParser is not consumed."
+	
+	^ (self starLazy: aParser) setMax: anInteger
+]
+
+{ #category : 'operators' }
+PPParser >> memoized [
+	"Answer a new memoized parser, for refraining redundant computations. This ensures polynomial time O(n^4) for left-recursive grammars and O(n^3) for non left-recursive grammars in the worst case. Not necessary for most grammars that are carefully written and in O(n) anyway."
+	
+	^ PPMemoizedParser on: self
+]
+
+{ #category : 'operators-repeating' }
+PPParser >> min: anInteger [
+	"Answer a new parser that parses the receiver at least anInteger times."
+	
+	^ self star setMin: anInteger
+]
+
+{ #category : 'operators-repeating' }
+PPParser >> min: anInteger greedy: aParser [
+	"Answer a new parser that parses the receiver at least anInteger times until it reaches aParser. This is a greedy non-blind implementation. aParser is not consumed."
+	
+	^ (self starGreedy: aParser) setMin: anInteger
+]
+
+{ #category : 'operators-repeating' }
+PPParser >> min: anInteger lazy: aParser [
+	"Answer a new parser that parses the receiver at least anInteger times until it reaches aParser. This is a lazy non-blind implementation. aParser is not consumed."
+	
+	^ (self starLazy: aParser) setMin: anInteger
+]
+
+{ #category : 'operators-repeating' }
+PPParser >> min: aMinInteger max: aMaxInteger [
+	"Answer a new parser that parses the receiver at least aMinInteger and at most aMaxInteger times."
+	
+	^ self star setMin: aMinInteger; setMax: aMaxInteger
+]
+
+{ #category : 'operators-repeating' }
+PPParser >> min: aMinInteger max: aMaxInteger greedy: aParser [
+	"Answer a new parser that parses the receiver at least aMinInteger and at most aMaxInteger times until it reaches aParser. This is a greedy non-blind implementation. aParser is not consumed."
+	
+	^ (self starGreedy: aParser) setMin: aMinInteger; setMax: aMaxInteger
+]
+
+{ #category : 'operators-repeating' }
+PPParser >> min: aMinInteger max: aMaxInteger lazy: aParser [
+	"Answer a new parser that parses the receiver at least aMinInteger and at most aMaxInteger times until it reaches aParser. This is a greedy non-blind implementation. aParser is not consumed."
+	
+	^ (self starLazy: aParser) setMin: aMinInteger; setMax: aMaxInteger
+]
+
+{ #category : 'accessing' }
+PPParser >> name [
+	"Answer the production name of the receiver."
+	
+	^ self propertyAt: #name ifAbsent: [ nil ]
+]
+
+{ #category : 'accessing' }
+PPParser >> name: aString [
+	self propertyAt: #name put: aString
+]
+
+{ #category : 'operators' }
+PPParser >> negate [
+	"Answer a new parser consumes any input token but the receiver."
+	
+	^ self not , #any asParser ==> #second
+]
+
+{ #category : 'operators' }
+PPParser >> nonMemoized [
+	^ self
+]
+
+{ #category : 'operators' }
+PPParser >> not [
+	"Answer a new parser (logical not-predicate) that succeeds whenever the receiver fails, but never consumes input."
+
+	^ PPNotParser on: self
+]
+
+{ #category : 'operators' }
+PPParser >> optional [
+	"Answer a new parser that parses the receiver, if possible."
+
+	^ PPOptionalParser on: self
+]
+
+{ #category : 'parsing' }
+PPParser >> parse: anObject [
+	"Parse anObject with the receiving parser and answer the parse-result or an instance of PPFailure."
+
+	^ self parse: anObject withContext: PPContext new
+]
+
+{ #category : 'parsing' }
+PPParser >> parse: anObject onError: aBlock [
+	"Parse anObject with the receiving parser and answer the parse-result or answer the result of evaluating aBlock. Depending on the number of arguments of the block it is simply evaluated, evaluated with the failure object, or evaluated with the error message and position."
+	
+	| result |
+	result := self parse: anObject.
+	result isPetitFailure
+		ifFalse: [ ^ result ].
+	aBlock numArgs = 0
+		ifTrue: [ ^ aBlock value ].
+	aBlock numArgs = 1
+		ifTrue: [ ^ aBlock value: result ].
+	^ aBlock value: result message value: result position
+]
+
+{ #category : 'context' }
+PPParser >> parse: anObject withContext: aPPContext [
+	"Parse anObject with the receiving parser and answer the parse-result or an instance of PPFailure."
+
+	aPPContext stream: anObject asPetitStream.
+	^ self parseWithContext: aPPContext.
+
+]
+
+{ #category : 'parsing' }
+PPParser >> parseOn: aPPContext [
+	"Parse aStream with the receiving parser and answer the parse-result or an instance of PPFailure. Override this method in subclasses to specify custom parse behavior. Do not call this method from outside, instead use #parse:."
+	
+	self subclassResponsibility
+]
+
+{ #category : 'context' }
+PPParser >> parseWithContext: context [
+	| result |
+	context initializeFor: self.
+	result := self parseOn: context.
+	
+	"Return the furthest failure, it gives better results than the last failure"
+	(result isPetitFailure and: [ context furthestFailure notNil]) 
+		ifTrue: [ ^ context furthestFailure ].
+	^ result
+	
+]
+
+{ #category : 'operators-repeating' }
+PPParser >> plus [
+	"Answer a new parser that parses the receiver one or more times."
+
+	^ self star setMin: 1
+]
+
+{ #category : 'operators-repeating' }
+PPParser >> plusGreedy: aParser [
+	"Answer a new parser that parses the receiver one or more times until it reaches aParser. This is a greedy non-blind implementation of the star operator. aParser is not consumed."
+	
+	^ (self starGreedy: aParser) setMin: 1
+]
+
+{ #category : 'operators-repeating' }
+PPParser >> plusLazy: aParser [
+	"Answer a new parser that parses the receiver one or more times until it reaches aParser. This is a lazy non-blind implementation of the star operator. aParser is not consumed."
+	
+	^ (self starLazy: aParser) setMin: 1
+]
+
+{ #category : 'copying' }
+PPParser >> postCopy [
+	super postCopy.
+	properties := properties copy
+]
+
+{ #category : 'printing' }
+PPParser >> printNameOn: aStream [
+	self name isNil
+		ifTrue: [ aStream print: self hash ]
+		ifFalse: [ aStream nextPutAll: self name ]
+]
+
+{ #category : 'printing' }
+PPParser >> printOn: aStream [
+	super printOn: aStream.
+	aStream nextPut: $(.
+	self printNameOn: aStream.
+	aStream nextPut: $)
+]
+
+{ #category : 'accessing-properties' }
+PPParser >> properties [
+	^ properties
+]
+
+{ #category : 'accessing-properties' }
+PPParser >> propertyAt: aKey [
+	"Answer the property value associated with aKey."
+	
+	^ self propertyAt: aKey ifAbsent: [ self error: 'Property not found' ]
+]
+
+{ #category : 'accessing-properties' }
+PPParser >> propertyAt: aKey ifAbsent: aBlock [
+	"Answer the property value associated with aKey or, if aKey isn't found, answer the result of evaluating aBlock."
+	
+	^ properties isNil
+		ifTrue: [ aBlock value ]
+		ifFalse: [ properties at: aKey ifAbsent: aBlock ]
+]
+
+{ #category : 'accessing-properties' }
+PPParser >> propertyAt: aKey ifAbsentPut: aBlock [
+	"Answer the property associated with aKey or, if aKey isn't found store the result of evaluating aBlock as new value."
+	
+	^ self propertyAt: aKey ifAbsent: [ self propertyAt: aKey put: aBlock value ]
+]
+
+{ #category : 'accessing-properties' }
+PPParser >> propertyAt: aKey put: anObject [
+	"Set the property at aKey to be anObject. If aKey is not found, create a new entry for aKey and set is value to anObject. Answer anObject."
+
+	^ (properties ifNil: [ properties := Dictionary new: 1 ])
+		at: aKey put: anObject
+]
+
+{ #category : 'accessing-properties' }
+PPParser >> removeProperty: aKey [
+	"Remove the property with aKey. Answer the property or raise an error if aKey isn't found."
+	
+	^ self removeProperty: aKey ifAbsent: [ self error: 'Property not found' ]
+]
+
+{ #category : 'accessing-properties' }
+PPParser >> removeProperty: aKey ifAbsent: aBlock [
+	"Remove the property with aKey. Answer the value or, if aKey isn't found, answer the result of evaluating aBlock."
+	
+	| answer |
+	properties isNil ifTrue: [ ^ aBlock value ].
+	answer := properties removeKey: aKey ifAbsent: aBlock.
+	properties isEmpty ifTrue: [ properties := nil ].
+	^ answer
+]
+
+{ #category : 'operators-convenience' }
+PPParser >> separatedBy: aParser [
+	"Answer a new parser that parses the receiver one or more times, separated by aParser."
+	
+	^ (PPSequenceParser with: self with: (PPSequenceParser with: aParser with: self) star) ==> [ :nodes |
+		| result |
+		result := Array new: 2 * nodes second size + 1.
+		result at: 1 put: nodes first.
+		nodes second 
+			keysAndValuesDo: [ :index :pair | result replaceFrom: 2 * index to: 2 * index + 1 with: pair startingAt: 1 ].
+		result ]
+]
+
+{ #category : 'operators-repeating' }
+PPParser >> star [
+	"Answer a new parser that parses the receiver zero or more times. This is a greedy and blind implementation that tries to consume as much input as possible and it does not consider what comes afterwards."
+
+	^ PPPossessiveRepeatingParser on: self
+]
+
+{ #category : 'operators-repeating' }
+PPParser >> starGreedy: aParser [
+	"Answer a new parser that parses the receiver zero or more times until it reaches aParser. This is a greedy non-blind implementation of the star operator. aParser is not consumed."
+	
+	^ PPGreedyRepeatingParser on: self limit: aParser
+]
+
+{ #category : 'operators-repeating' }
+PPParser >> starLazy: aParser [
+	"Answer a new parser that parses the receiver zero or more times until it reaches aParser. This is a lazy non-blind implementation of the star operator. aParser is not consumed."
+	
+	^ PPLazyRepeatingParser on: self limit: aParser
+]
+
+{ #category : 'operators-repeating' }
+PPParser >> times: anInteger [
+	"Answer a new parser that parses the receiver exactly anInteger times."
+	
+	^ self min: anInteger max: anInteger
+]
+
+{ #category : 'operators-mapping' }
+PPParser >> token [
+	"Answer a new parser that transforms the input to a token."
+	
+	^ PPTokenParser on: self
+]
+
+{ #category : 'operators-mapping' }
+PPParser >> token: aTokenClass [
+	"Answer a new parser that transforms the input to a token of class aTokenClass."
+	
+	^ self token tokenClass: aTokenClass
+]
+
+{ #category : 'operators-mapping' }
+PPParser >> trim [
+	"Answer a new parser that consumes spaces before and after the receiving parser."
+	
+	^ self trimSpaces
+]
+
+{ #category : 'operators-mapping' }
+PPParser >> trim: aParser [
+	"Answer a new parser that consumes and ignores aParser repeatedly before and after the receiving parser."
+	
+	^ PPTrimmingParser on: self trimmer: aParser
+]
+
+{ #category : 'operators-mapping' }
+PPParser >> trimBlanks [
+	"Answer a new parser that consumes blanks before and after the receiving parser."
+	
+	^ self trim: #blank asParser
+]
+
+{ #category : 'operators-mapping' }
+PPParser >> trimLeft [
+	"Answer a new parser that consumes spaces before the receiving parser."
+	
+	^ self trimSpacesLeft
+]
+
+{ #category : 'operators-mapping' }
+PPParser >> trimRight [
+	"Answer a new parser that consumes spaces after the receiving parser."
+	
+	^ self trimSpacesRight
+]
+
+{ #category : 'operators-mapping' }
+PPParser >> trimRight: trimmer [
+	"Answer a new parser that consumes spaces after the receiving parser."
+	
+	^ (self, trimmer star) ==> #first
+]
+
+{ #category : 'operators-mapping' }
+PPParser >> trimSpaces [
+	"Answer a new parser that consumes spaces before and after the receiving parser."
+	
+	^ self trim: #space asParser
+]
+
+{ #category : 'operators-mapping' }
+PPParser >> trimSpacesLeft [
+	"Answer a new parser that consumes spaces before the receiving parser."
+	
+	^ (#space asParser star, self) ==> #second
+]
+
+{ #category : 'operators-mapping' }
+PPParser >> trimSpacesRight [
+	"Answer a new parser that consumes spaces after the receiving parser."
+	
+	^ (self, #space asParser star) ==> #first
+]
+
+{ #category : 'operators-convenience' }
+PPParser >> withoutSeparators [
+	"Filters out the separators from a parse result produced by one of the productions #delimitedBy: or #separatedBy:."
+	
+	^ self ==> [ :items |
+		| result |
+		result := Array new: items size + 1 // 2.
+		1 to: result size do: [ :index | result at: index put: (items at: 2 * index - 1) ].
+		result ]
+]
+
+{ #category : 'operators' }
+PPParser >> wrapped [
+	"Answer a new parser that is simply wrapped."
+	
+	^ PPDelegateParser on: self
+]
+
+{ #category : 'operators' }
+PPParser >> | aParser [
+	"Answer a new parser that either parses the receiver or aParser. Fail if both pass or fail (exclusive choice, unordered choice)."
+
+	^ (self not , aParser) / (aParser not , self) ==> #second
+]

software/PetitParser/PPPluggableParser.class.st

@@ -0,0 +1,43 @@
+"
+A pluggable parser that passes the parser stream into a block. This enables users to perform manual parsing or to embed other parser frameworks into PetitParser.
+
+Instance Variables:
+	block	<BlockClosure>	The pluggable one-argument block.
+
+
+"
+Class {
+	#name : 'PPPluggableParser',
+	#superclass : 'PPParser',
+	#instVars : [
+		'block'
+	],
+	#category : 'PetitParser-Parsers'
+}
+
+{ #category : 'instance creation' }
+PPPluggableParser class >> on: aBlock [
+	^ self new initializeOn: aBlock
+]
+
+{ #category : 'accessing' }
+PPPluggableParser >> block [
+	"Answer the pluggable block."
+
+	^ block
+]
+
+{ #category : 'initialization' }
+PPPluggableParser >> initializeOn: aBlock [
+	block := aBlock
+]
+
+{ #category : 'parsing' }
+PPPluggableParser >> parseOn: aPPContext [
+	| memento result |
+	memento := aPPContext remember.
+	result := block value: aPPContext.
+	result isPetitFailure
+		ifTrue: [ aPPContext restore: memento ].
+	^ result
+]

software/PetitParser/PPPossessiveRepeatingParser.class.st

@@ -0,0 +1,25 @@
+"
+The default repeating parser with standard PEG semantics (i.e. possessive, blind, eager).
+"
+Class {
+	#name : 'PPPossessiveRepeatingParser',
+	#superclass : 'PPRepeatingParser',
+	#category : 'PetitParser-Parsers'
+}
+
+{ #category : 'parsing' }
+PPPossessiveRepeatingParser >> parseOn: aPPContext [
+	| memento element elements |
+	memento := aPPContext remember.
+	elements := OrderedCollection new.
+	[ elements size < min ] whileTrue: [
+		(element := parser parseOn: aPPContext) isPetitFailure ifTrue: [
+			aPPContext restore: memento.
+			^ element ].
+		elements addLast: element ].
+	[ elements size < max ] whileTrue: [
+	 	(element := parser parseOn: aPPContext) isPetitFailure
+			ifTrue: [ ^ elements asArray ].
+		elements addLast: element ].
+	^ elements asArray
+]

software/PetitParser/PPPredicateObjectParser.class.st

@@ -0,0 +1,238 @@
+"
+A parser that accepts if a given predicate on one element of the input sequence holds.
+"
+Class {
+	#name : 'PPPredicateObjectParser',
+	#superclass : 'PPPredicateParser',
+	#classInstVars : [
+		'cache'
+	],
+	#category : 'PetitParser-Parsers'
+}
+
+{ #category : 'factory-objects' }
+PPPredicateObjectParser class >> any [
+	^self
+		cacheAt: #'any'
+		ifAbsentPut: [ self
+			on: [ :each | true ] message: 'input expected'
+			negated: [ :each | false ] message: 'no input expected' ]
+]
+
+{ #category : 'factory-objects' }
+PPPredicateObjectParser class >> anyExceptAnyOf: aCollection [
+	^ self
+		on: [ :each | (aCollection includes: each) not ] message: 'any except ' , aCollection printString , ' expected'
+		negated: [ :each | aCollection includes: each ] message: aCollection printString ,  ' not expected'
+]
+
+{ #category : 'factory-objects' }
+PPPredicateObjectParser class >> anyOf: aCollection [
+	^ self
+		on: [ :each | aCollection includes: each ] message: 'any of ' , aCollection printString , ' expected'
+		negated: [ :each | (aCollection includes: each) not ] message: 'none of ' , aCollection printString ,  'expected'
+]
+
+{ #category : 'factory-objects' }
+PPPredicateObjectParser class >> between: min and: max [
+	^ self
+		on: [ :each | each >= min and: [ each <= max ] ] message: min printString , '..' , max printString , ' expected'
+		negated: [ :each | each < min or: [ each > max ] ] message: min printString , '..' , max printString , ' not expected'
+]
+
+{ #category : 'factory-chars' }
+PPPredicateObjectParser class >> blank [
+	^self
+		cacheAt: #'blank'
+		ifAbsentPut: [ self
+			chars: (String with: Character space with: Character tab) message: 'blank expected' ]
+]
+
+{ #category : 'cache' }
+PPPredicateObjectParser class >> cacheAt: aSymbol ifAbsentPut: aBlock [
+
+	cache ifNil: [ cache := Dictionary new ].
+	^(cache
+		at: aSymbol
+		ifAbsentPut: aBlock) copy
+]
+
+{ #category : 'factory-chars' }
+PPPredicateObjectParser class >> char: aCharacter [
+	^ self expect: aCharacter message: (String with: $" with: aCharacter with: $") , ' expected'
+]
+
+{ #category : 'factory-chars' }
+PPPredicateObjectParser class >> char: aCharacter message: aString [
+	^ self expect: aCharacter message: aString
+]
+
+{ #category : 'factory-chars' }
+PPPredicateObjectParser class >> chars: aCollection message: aString [
+	^ self on: (PPCharSetPredicate on: [ :char | aCollection includes: char ]) message: aString
+]
+
+{ #category : 'factory-chars' }
+PPPredicateObjectParser class >> cr [
+	^self
+		cacheAt: #'cr'
+		ifAbsentPut: [ self char: (Character codePoint: 13) message: 'carriage return expected' ]
+]
+
+{ #category : 'factory-chars' }
+PPPredicateObjectParser class >> digit [
+	^self
+		cacheAt: #'digit'
+		ifAbsentPut: [ self on: (PPCharSetPredicate on: [ :char | char isDigit ]) message: 'digit expected' ]
+]
+
+{ #category : 'factory-objects' }
+PPPredicateObjectParser class >> endOfLine [
+	
+	^ PPEndOfLineParser new.
+]
+
+{ #category : 'factory-objects' }
+PPPredicateObjectParser class >> eof [
+	
+	^ PPEndOfFileParser new
+]
+
+{ #category : 'factory-objects' }
+PPPredicateObjectParser class >> expect: anObject [
+	^ self expect: anObject message: anObject printString , ' expected'
+]
+
+{ #category : 'factory-objects' }
+PPPredicateObjectParser class >> expect: anObject message: aString [
+	^ self 
+		on: [ :each | each = anObject ] message: aString
+		negated: [ :each | each ~= anObject ] message: 'no ' , aString
+]
+
+{ #category : 'factory-chars' }
+PPPredicateObjectParser class >> hex [
+	^self
+		cacheAt: #'hex'
+		ifAbsentPut: [ self
+		on: (PPCharSetPredicate on: [ :char | 
+			(char between: $0 and: $9) 
+				or: [ (char between: $a and: $f) 
+				or: [ (char between: $A and: $F) ] ] ])
+		message: 'hex digit expected' ]
+]
+
+{ #category : 'factory-chars' }
+PPPredicateObjectParser class >> letter [
+	^self
+		cacheAt: #'letter'
+		ifAbsentPut: [ self on: (PPCharSetPredicate on: [ :char | char isLetter ]) message: 'letter expected' ]
+]
+
+{ #category : 'factory-chars' }
+PPPredicateObjectParser class >> lf [
+	^self
+		cacheAt: #'lf'
+		ifAbsentPut: [ self char: (Character codePoint: 10) ]
+]
+
+{ #category : 'factory-chars' }
+PPPredicateObjectParser class >> lowercase [
+	^self
+		cacheAt: #'lowercase'
+		ifAbsentPut: [ self on: (PPCharSetPredicate on: [ :char | char isLowercase ]) message: 'lowercase letter expected' ]
+]
+
+{ #category : 'factory-chars' }
+PPPredicateObjectParser class >> newline [
+	^self
+		cacheAt: #'newline'
+		ifAbsentPut: [ self chars: (String with: (Character codePoint: 13) with: (Character codePoint: 10)) message: 'newline expected' ]
+]
+
+{ #category : 'instance creation' }
+PPPredicateObjectParser class >> on: aBlock message: aString [
+	^ self on: aBlock message: aString negated: [ :each | (aBlock value: each) not ] message: 'no ' , aString
+]
+
+{ #category : 'instance creation' }
+PPPredicateObjectParser class >> on: aBlock message: aString negated: aNegatedBlock message: aNegatedString [
+	^ self new initializeOn: aBlock message: aString negated: aNegatedBlock message: aNegatedString
+]
+
+{ #category : 'factory-chars' }
+PPPredicateObjectParser class >> punctuation [
+	^self
+		cacheAt: #'punctuation'
+		ifAbsentPut: [ self chars: '.,"''?!;:#$%&()*+-/<>=@[]\^_{}|~' message: 'punctuation expected' ]
+]
+
+{ #category : 'factory-chars' }
+PPPredicateObjectParser class >> space [
+	^self
+		cacheAt: #'space'
+		ifAbsentPut: [ self on: (PPCharSetPredicate on: [ :char | char isSeparator ]) message: 'separator expected' ]
+]
+
+{ #category : 'factory-objects' }
+PPPredicateObjectParser class >> startOfLine [
+	
+	^ PPStartOfLineParser new.
+]
+
+{ #category : 'factory-objects' }
+PPPredicateObjectParser class >> startOfLogicalLine [
+	
+	^ PPStartOfLogicalLineParser new.
+]
+
+{ #category : 'factory-objects' }
+PPPredicateObjectParser class >> startOfWord [
+	
+	^ PPStartOfWordParser new.
+]
+
+{ #category : 'factory-chars' }
+PPPredicateObjectParser class >> tab [
+	^self
+		cacheAt: #'tab'
+		ifAbsentPut: [ self char: Character tab message: 'tab expected' ]
+]
+
+{ #category : 'factory-chars' }
+PPPredicateObjectParser class >> uppercase [
+	^self
+		cacheAt: #'uppercase'
+		ifAbsentPut: [ self on: (PPCharSetPredicate on: [ :char | char isUppercase ]) message: 'uppercase letter expected' ]
+]
+
+{ #category : 'factory-chars' }
+PPPredicateObjectParser class >> word [
+	^self
+		cacheAt: #'word'
+		ifAbsentPut: [ self on: (PPCharSetPredicate on: [ :char | char isAlphaNumeric ]) message: 'letter or digit expected' ]
+]
+
+{ #category : 'initialization' }
+PPPredicateObjectParser >> initializeOn: aBlock message: aString negated: aNegatedBlock message: aNegatedString [
+	predicate := aBlock.
+	predicateMessage := aString.
+	negated := aNegatedBlock.
+	negatedMessage := aNegatedString
+]
+
+{ #category : 'operators' }
+PPPredicateObjectParser >> negate [
+	"Answer a parser that is the negation of the receiving predicate parser."
+	
+	^ self class 
+		on: negated message: negatedMessage 
+		negated: predicate message: predicateMessage
+]
+
+{ #category : 'parsing' }
+PPPredicateObjectParser >> parseOn: aPPContext [
+	^ (aPPContext atEnd not and: [ predicate value: aPPContext uncheckedPeek ])
+		ifFalse: [ PPFailure message: predicateMessage context: aPPContext ]
+		ifTrue: [ aPPContext next ]
+]

software/PetitParser/PPPredicateParser.class.st

@@ -0,0 +1,40 @@
+"
+An abstract parser that accepts if a given predicate holds.
+
+Instance Variables:
+	predicate	<BlockClosure>	The block testing for the predicate.
+	predicateMessage	<String>	The error message of the predicate.
+	negated	<BlockClosure>	The block testing for the negation of the predicate.
+	negatedMessage	<String>	The error message of the negated predicate.
+"
+Class {
+	#name : 'PPPredicateParser',
+	#superclass : 'PPParser',
+	#instVars : [
+		'predicate',
+		'predicateMessage',
+		'negated',
+		'negatedMessage'
+	],
+	#category : 'PetitParser-Parsers'
+}
+
+{ #category : 'accessing' }
+PPPredicateParser >> block [
+	"Answer the predicate block of the receiver."
+	
+	^ predicate
+]
+
+{ #category : 'accessing' }
+PPPredicateParser >> message [
+	"Answer the failure message."
+	
+	^ predicateMessage
+]
+
+{ #category : 'printing' }
+PPPredicateParser >> printNameOn: aStream [
+	super printNameOn: aStream.
+	aStream nextPutAll: ', '; print: predicateMessage
+]

software/PetitParser/PPPredicateSequenceParser.class.st

@@ -0,0 +1,62 @@
+"
+A parser that accepts if a given predicate on an arbitrary number of elements of the input sequence holds.
+
+Instance Variables:
+	size	<Integer>	The number of elements to consume.
+
+"
+Class {
+	#name : 'PPPredicateSequenceParser',
+	#superclass : 'PPPredicateParser',
+	#instVars : [
+		'size'
+	],
+	#category : 'PetitParser-Parsers'
+}
+
+{ #category : 'instance creation' }
+PPPredicateSequenceParser class >> on: aBlock message: aString negated: aNegatedBlock message: aNegatedString size: anInteger [ 
+	^ self new initializeOn: aBlock message: aString negated: aNegatedBlock message: aNegatedString size: anInteger
+]
+
+{ #category : 'instance creation' }
+PPPredicateSequenceParser class >> on: aBlock message: aString size: anInteger [
+	^ self on: aBlock message: aString negated: [ :each | (aBlock value: each) not ] message: 'no ' , aString size: anInteger 
+]
+
+{ #category : 'initialization' }
+PPPredicateSequenceParser >> initializeOn: aBlock message: aString negated: aNegatedBlock message: aNegatedString size: anInteger [
+	predicate := aBlock.
+	predicateMessage := aString.
+	negated := aNegatedBlock.
+	negatedMessage := aNegatedString.
+	size := anInteger 
+]
+
+{ #category : 'operators' }
+PPPredicateSequenceParser >> negate [
+	"Answer a parser that is the negation of the receiving predicate parser."
+	
+	^ self class 
+		on: negated message: negatedMessage
+		negated: predicate message: predicateMessage
+		size: size
+]
+
+{ #category : 'parsing' }
+PPPredicateSequenceParser >> parseOn: aPPContext [
+	| memento result |
+	memento := aPPContext remember.
+	result := aPPContext stream next: size.
+	(result size = size and: [ predicate value: result ])
+		ifTrue: [ ^ result ].
+	aPPContext restore: memento.
+	^ PPFailure message: predicateMessage context: aPPContext
+]
+
+{ #category : 'accessing' }
+PPPredicateSequenceParser >> size [
+	"Answer the sequence size of the receiver."
+
+	^ size
+]

software/PetitParser/PPRepeatingParser.class.st

@@ -0,0 +1,53 @@
+"
+An abstract parser that repeatedly parses between 'min' and 'max' instances of its delegate. The default configuration parses an infinite number of elements, as 'min' is set to 0 and 'max' to infinity (SmallInteger maxVal).
+
+Instance Variables:
+	min	<Integer>	The minimum number of repetitions.
+	max	<Integer>	The maximum number of repetitions.
+"
+Class {
+	#name : 'PPRepeatingParser',
+	#superclass : 'PPDelegateParser',
+	#instVars : [
+		'min',
+		'max'
+	],
+	#category : 'PetitParser-Parsers'
+}
+
+{ #category : 'initialization' }
+PPRepeatingParser >> initialize [
+	super initialize.
+	self setMin: 0; setMax: SmallInteger maxVal
+]
+
+{ #category : 'accessing' }
+PPRepeatingParser >> max [
+	"Answer the maximum number of repetitions."
+
+	^ max
+]
+
+{ #category : 'accessing' }
+PPRepeatingParser >> min [
+	"Answer the minimum number of repetitions."
+	
+	^ min
+]
+
+{ #category : 'printing' }
+PPRepeatingParser >> printOn: aStream [
+	super printOn: aStream.
+	aStream nextPutAll: ' ['; print: min; nextPutAll: ', '; nextPutAll: (max = SmallInteger maxVal
+		ifTrue: [ '*' ] ifFalse: [ max printString ]); nextPut: $]
+]
+
+{ #category : 'initialization' }
+PPRepeatingParser >> setMax: anInteger [
+	max := anInteger
+]
+
+{ #category : 'initialization' }
+PPRepeatingParser >> setMin: anInteger [
+	min := anInteger
+]

software/PetitParser/PPSequenceParser.class.st

@@ -0,0 +1,40 @@
+"
+A parser that parses a sequence of parsers.
+"
+Class {
+	#name : 'PPSequenceParser',
+	#superclass : 'PPListParser',
+	#category : 'PetitParser-Parsers'
+}
+
+{ #category : 'operators' }
+PPSequenceParser >> , aRule [
+	^ self copyWith: aRule
+]
+
+{ #category : 'parsing' }
+PPSequenceParser >> parseOn: aPPContext [
+	"This is optimized code that avoids unnecessary block activations, do not change."
+	
+	| memento elements element |
+	memento := aPPContext remember.
+	elements := Array new: parsers size.
+	1 to: parsers size do: [ :index |
+		element := (parsers at: index) 
+			parseOn: aPPContext.
+		element isPetitFailure ifTrue: [
+			aPPContext restore: memento.
+			^ element ].
+		elements at: index put: element ].
+	^ elements
+]
+
+{ #category : 'operators-mapping' }
+PPSequenceParser >> permutation: anArrayOfIntegers [
+	"Answer a permutation of the receivers sequence."
+	
+	anArrayOfIntegers do: [ :index |
+		(index isInteger and: [ index between: 1 and: parsers size ])
+			ifFalse: [ self error: 'Invalid permutation index: ' , index printString ] ].
+	^ self ==> [ :nodes | anArrayOfIntegers collect: [ :index | nodes at: index ] ]
+]

software/PetitParser/PPStartOfLineParser.class.st

@@ -0,0 +1,17 @@
+"
+A PPStartOfLineParser is that does not fail, if the stream position is at the beginning of a line. It does not consume anything.
+
+"
+Class {
+	#name : 'PPStartOfLineParser',
+	#superclass : 'PPParser',
+	#category : 'PetitParser-Parsers'
+}
+
+{ #category : 'parsing' }
+PPStartOfLineParser >> parseOn: aPPContext [
+	(aPPContext isStartOfLine) ifTrue: [ 
+		^ #startOfLine
+	].
+	^ PPFailure message: 'Start of line expected' context: aPPContext at: aPPContext position
+]

software/PetitParser/PPStartOfLogicalLineParser.class.st

@@ -0,0 +1,34 @@
+"
+A PPStartOfLogicalLineParser is that does not fail, if the stream position is at the first non-blank character of a line. It does not consume anything.
+
+"
+Class {
+	#name : 'PPStartOfLogicalLineParser',
+	#superclass : 'PPParser',
+	#category : 'PetitParser-Parsers'
+}
+
+{ #category : 'testing' }
+PPStartOfLogicalLineParser >> isBlank: character [
+	^ (character == Character space or: [character == Character tab])
+
+]
+
+{ #category : 'parsing' }
+PPStartOfLogicalLineParser >> parseOn: aPPContext [
+	aPPContext peek isAlphaNumeric ifFalse: [ 
+		^ PPFailure message: 'Start of logical line expected' context: aPPContext 
+	].
+
+	aPPContext isStartOfLine ifTrue: [ ^ #startOfLogicalLine ].
+	
+	
+	[ aPPContext position ~= 0 ] whileTrue: [  
+		aPPContext back.
+		(self isBlank: aPPContext peek) ifFalse: [ 
+			^ PPFailure message: 'Start of logical line expected' context: aPPContext
+		].
+		aPPContext isStartOfLine ifTrue: [ ^ #startOfLogicalLine ].
+	]
+
+]

software/PetitParser/PPStartOfWordParser.class.st

@@ -0,0 +1,44 @@
+"
+A PPStartOfWordParser is that matches a word boundary.
+
+I return success if no word character preceeds my position and if word chracter succeeds my position.
+
+Word characters are any alphanumeric characters.
+"
+Class {
+	#name : 'PPStartOfWordParser',
+	#superclass : 'PPParser',
+	#category : 'PetitParser-Parsers'
+}
+
+{ #category : 'testing' }
+PPStartOfWordParser >> acceptsEpsilon [
+	^ false
+]
+
+{ #category : 'parsing' }
+PPStartOfWordParser >> parseOn: aPPContext [
+	aPPContext atEnd ifTrue: [  
+		^ PPFailure message: 'Start of word expected' context: aPPContext at: aPPContext position 
+	].
+
+	(aPPContext position == 0) ifTrue: [ 
+		(aPPContext peek isAlphaNumeric) ifTrue: [ 
+			^ #startOfWord
+		] ifFalse: [ 
+			^ PPFailure message: 'Start of word expected' context: aPPContext at: aPPContext position 
+	 	]
+	].
+
+	aPPContext back.
+	aPPContext peek isAlphaNumeric ifTrue: [
+		^ PPFailure message: 'Start of word expected' context: aPPContext at: aPPContext position 
+	].
+	aPPContext next.
+	
+	^ aPPContext peek isAlphaNumeric ifTrue: [ #startOfWord ] ifFalse: [ 
+		PPFailure message: 'Start of word expected' context: aPPContext at: aPPContext position 
+	]
+	
+
+]

software/PetitParser/PPStream.class.st

@@ -0,0 +1,162 @@
+"
+A positional stream implementation used for parsing. It overrides some methods for optimization reasons.
+"
+Class {
+	#name : 'PPStream',
+	#superclass : 'ReadStream',
+	#instVars : [
+		'newlines'
+	],
+	#category : 'PetitParser-Core'
+}
+
+{ #category : 'converting' }
+PPStream >> asPetitStream [
+	^ self
+]
+
+{ #category : 'accessing' }
+PPStream >> collection [
+	"Answer the underlying collection."
+	
+	^ collection
+]
+
+{ #category : 'positioning' }
+PPStream >> column [
+	^ self column: position.
+]
+
+{ #category : 'positioning' }
+PPStream >> column: pos [
+	| nl |
+	(pos = -1) ifTrue: [  ^ 0 ].
+	(pos > readLimit) ifTrue: [ ^ self error: 'Out of limit' ].
+	
+	nl := self newlines.
+	1 to: nl size do: [ :index | 
+		((nl at: index) > pos) ifTrue: [ ^ pos - (nl at: (index - 1)) + 1 ]
+	].
+"	nl keysAndValuesDo: [ :index :value |
+		(value > pos) ifTrue: [ ^ pos - (nl at: (index - 1)) + 1]
+	].	
+"
+	^ pos - (nl at: (nl size )) + 1
+]
+
+{ #category : 'positioning' }
+PPStream >> fillNewlines [
+	| tmp line |
+	newlines := OrderedCollection new.	
+	
+	tmp := position.
+	line := 0.
+	
+	(0 to: readLimit) do: [:index |
+		position := index.
+		self isStartOfLine ifTrue: [ newlines add: position ]
+	].
+	position := tmp.
+	newlines := newlines asArray.
+	^ newlines
+]
+
+{ #category : 'queries' }
+PPStream >> insideCRLF [
+	(position < 1) ifTrue: [ ^ false ].
+	
+	^ (self peek = (Character codePoint: 10)) and: [ self peekBack = (Character codePoint: 13) ]
+]
+
+{ #category : 'queries' }
+PPStream >> isEndOfLine [
+	self atEnd ifTrue: [ ^ true ].
+	self insideCRLF ifTrue: [ ^ false ].
+	^ (self peek = (Character codePoint: 13) or: [ self peek = (Character codePoint: 10)]).
+]
+
+{ #category : 'queries' }
+PPStream >> isStartOfLine [
+	(position = 0) ifTrue: [ ^ true ].
+
+	self insideCRLF ifTrue: [ ^ false ].
+	
+	^ (self peekBack = (Character codePoint: 13)) or: [ self peekBack = (Character codePoint: 10)].
+]
+
+{ #category : 'positioning' }
+PPStream >> line [
+	^ self line: position
+]
+
+{ #category : 'positioning' }
+PPStream >> line: pos [
+	| nl |
+	(pos = -1) ifTrue: [  ^ 0 ].
+	(pos > readLimit) ifTrue: [ ^ self error: 'Out of limit' ].
+	
+	nl := self newlines.
+	nl keysAndValuesDo: [ :index :value |
+		(value > pos) ifTrue: [ ^ (index - 1)]
+	].	
+
+	^ nl size
+]
+
+{ #category : 'positioning' }
+PPStream >> newlines [
+	^ newlines ifNil: [ 
+		newlines := self fillNewlines.
+	]
+]
+
+{ #category : 'accessing' }
+PPStream >> next: anInteger [ 
+	"Answer up to anInteger elements of my collection. Overridden for efficiency."
+
+	| answer endPosition |
+	endPosition := position + anInteger min: readLimit.
+	answer := collection copyFrom: position + 1 to: endPosition.
+	position := endPosition.
+	^ answer
+]
+
+{ #category : 'accessing' }
+PPStream >> peek [
+	"An improved version of peek, that is slightly faster than the built in version."
+
+	^ self atEnd ifFalse: [ collection at: position + 1 ]
+]
+
+{ #category : 'accessing' }
+PPStream >> position: anInteger [
+	"The receiver does not check for invalid arguments passed to this method, as it is solely used with valid indexes for backtracking."
+
+	position := anInteger
+]
+
+{ #category : 'printing' }
+PPStream >> printOn: aStream [
+	collection isString
+		ifFalse: [ ^ super printOn: aStream ].
+	aStream
+		nextPutAll: (collection copyFrom: 1 to: position);
+		nextPutAll: '·';
+		nextPutAll: (collection copyFrom: position + 1 to: readLimit)
+]
+
+{ #category : 'accessing' }
+PPStream >> size [
+	"
+		The same implementation as a ReadStream. Implemented here for compatibility with Smalltalk/X
+		that has different implementation in a ReadStream
+	"
+	^readLimit
+]
+
+{ #category : 'accessing' }
+PPStream >> uncheckedPeek [
+	"An unchecked version of peek that throws an error if we try to peek over the end of the stream, even faster than #peek."
+
+	^ collection at: position + 1
+]

software/PetitParser/PPToken.class.st

@@ -0,0 +1,162 @@
+"
+PPToken represents a parsed part of the input stream. Contrary to a simple String it remembers where it came from, the original collection and its start and stop position.
+
+Instance Variables:
+	collection	<SequenceableCollection>	The collection this token comes from.
+	start	<Integer>	The start position in the collection.
+	stop	<Integer>	The stop position in the collection.
+"
+Class {
+	#name : 'PPToken',
+	#superclass : 'Object',
+	#instVars : [
+		'collection',
+		'start',
+		'stop',
+		'value'
+	],
+	#classVars : [
+		'NewLineParser'
+	],
+	#category : 'PetitParser-Core'
+}
+
+{ #category : 'initialization' }
+PPToken class >> initialize [
+	"Platform independent newline sequence. LF: Unix, CR+LF: Windows, and CR: Apple."
+	| cr lf |
+	cr := Character codePoint: 13.
+	lf := Character codePoint: 10.
+	NewLineParser := lf asParser / (cr asParser , lf asParser optional)
+]
+
+{ #category : 'instance creation' }
+PPToken class >> new [
+	self error: 'Token can only be created using a dedicated constructor.'
+]
+
+{ #category : 'instance creation' }
+PPToken class >> on: aSequenceableCollection [
+	^ self on: aSequenceableCollection start: 1 stop: aSequenceableCollection size value: nil
+]
+
+{ #category : 'instance creation' }
+PPToken class >> on: aSequenceableCollection start: aStartInteger stop: aStopInteger value: anObject [
+	^ self basicNew 
+		initializeOn: aSequenceableCollection
+		start: aStartInteger stop: aStopInteger
+		value: anObject
+]
+
+{ #category : 'comparing' }
+PPToken >> = anObject [
+	^ self class = anObject class and: [ self inputValue = anObject inputValue ]
+]
+
+{ #category : 'accessing' }
+PPToken >> collection [
+	"Answer the underlying collection of this token."
+
+	^ collection
+]
+
+{ #category : 'querying' }
+PPToken >> column [
+	"Answer the column number of this token in the underlying collection."
+	
+	| position |
+	position := 0.
+	(NewLineParser , [ :stream |
+		start <= stream position
+			ifTrue: [ ^ start - position ].
+		position := stream position ] asParser
+		/ #any asParser) star
+			parse: collection.
+	 ^ start - position
+]
+
+{ #category : 'copying' }
+PPToken >> copyFrom: aStartInteger to: aStopInteger [
+	^ self class on: collection start: start + aStartInteger - 1 stop: stop + aStopInteger - 3 value: value
+]
+
+{ #category : 'comparing' }
+PPToken >> hash [
+	^ self inputValue hash
+]
+
+{ #category : 'initialization' }
+PPToken >> initializeOn: aSequenceableCollection start: aStartInteger stop: aStopInteger value: anObject [
+	collection := aSequenceableCollection.
+	start := aStartInteger.
+	stop := aStopInteger.
+	value := anObject
+]
+
+{ #category : 'accessing-values' }
+PPToken >> inputValue [
+	"Answer the consumed input of this token."
+
+	^ collection copyFrom: start to: stop
+]
+
+{ #category : 'testing' }
+PPToken >> isPetitToken [
+	^ true
+]
+
+{ #category : 'querying' }
+PPToken >> line [
+	"Answer the line number of this token in the underlying collection."
+	
+	| line |
+	line := 1.
+	(NewLineParser , [ :stream |
+		start <= stream position
+			ifTrue: [ ^ line ].
+		line := line + 1 ] asParser
+		/ #any asParser) star
+			parse: collection.
+	^ line
+]
+
+{ #category : 'accessing-values' }
+PPToken >> parsedValue [
+	"Answer the parsed value of this token."
+
+	^ value
+]
+
+{ #category : 'printing' }
+PPToken >> printOn: aStream [
+	super printOn: aStream.
+	aStream nextPut: $[; print: self start; nextPut: $,; print: self stop; nextPut: $].
+	aStream nextPut: $(; print: self inputValue; nextPut: $)
+]
+
+{ #category : 'accessing' }
+PPToken >> size [
+	"Answer the size of this token in the underlying collection."
+
+	^ stop - start + 1
+]
+
+{ #category : 'accessing' }
+PPToken >> start [
+	"Answer the start position of this token in the underlying collection."
+
+	^ start
+]
+
+{ #category : 'accessing' }
+PPToken >> stop [
+	"Answer the stop position of this token in the underlying collection."
+	
+	^ stop
+]
+
+{ #category : 'accessing-values' }
+PPToken >> value [
+	self notify: 'Token>>#value is no longer supported. Instead use Token>>#inputValue'.
+	^ self inputValue
+]

software/PetitParser/PPTokenParser.class.st

@@ -0,0 +1,40 @@
+"
+A parser that answers a token with the value of my delegate parses.
+
+Instance Variables:
+	tokenClass	<PPToken class>	The token sub-class to be used.
+"
+Class {
+	#name : 'PPTokenParser',
+	#superclass : 'PPFlattenParser',
+	#instVars : [
+		'tokenClass'
+	],
+	#category : 'PetitParser-Parsers'
+}
+
+{ #category : 'private' }
+PPTokenParser >> defaultTokenClass [
+	^ PPToken
+]
+
+{ #category : 'initialization' }
+PPTokenParser >> initialize [
+	tokenClass := self defaultTokenClass
+	
+]
+
+{ #category : 'private' }
+PPTokenParser >> on: aCollection start: aStartInteger stop: aStopInteger value: anObject [
+	^ self tokenClass on: aCollection start: aStartInteger stop: aStopInteger value: anObject
+]
+
+{ #category : 'accessing' }
+PPTokenParser >> tokenClass [
+	^ tokenClass
+]
+
+{ #category : 'accessing' }
+PPTokenParser >> tokenClass: aTokenClass [
+	tokenClass := aTokenClass
+]

software/PetitParser/PPTrimmingParser.class.st

@@ -0,0 +1,24 @@
+"
+A parser that silently consumes spaces before and after the delegate parser.
+"
+Class {
+	#name : 'PPTrimmingParser',
+	#superclass : 'PPDelegateParser',
+	#instVars : [
+		'trimmer'
+	],
+	#category : 'PetitParser-Parsers'
+}
+
+{ #category : 'instance creation' }
+PPTrimmingParser class >> on: aParser trimmer: aTrimParser [
+	^ self new
+		setParser: aParser;
+		setTrimmer: aTrimParser;
+		yourself
+]
+
+{ #category : 'initialization' }
+PPTrimmingParser >> setTrimmer: aParser [
+	trimmer := aParser
+]

software/PetitParser/PPUnresolvedParser.class.st

@@ -0,0 +1,18 @@
+"
+This is a temporary placeholder or forward reference to a parser that has not been defined yet. If everything goes well it will eventually be replaced with the real parser instance.
+"
+Class {
+	#name : 'PPUnresolvedParser',
+	#superclass : 'PPParser',
+	#category : 'PetitParser-Tools'
+}
+
+{ #category : 'testing' }
+PPUnresolvedParser >> isUnresolved [
+	^ true
+]
+
+{ #category : 'parsing' }
+PPUnresolvedParser >> parseOn: aStream [
+	self error: self printString , ' need to be resolved before execution.'
+]

software/PetitParser/PPWrappingParser.class.st

@@ -0,0 +1,13 @@
+"
+A parser that performs an action block upon activation with the stream and a continuation block.
+"
+Class {
+	#name : 'PPWrappingParser',
+	#superclass : 'PPActionParser',
+	#category : 'PetitParser-Parsers'
+}
+
+{ #category : 'parsing' }
+PPWrappingParser >> parseOn: aPPContext [
+	^ block value: aPPContext value: [ parser parseOn: aPPContext ]
+]

software/PetitParser/PositionableStream.extension.st

@@ -0,0 +1,28 @@
+Extension { #name : 'PositionableStream' }
+
+{ #category : '*petitparser-core-converting' }
+PositionableStream >> asPetitStream [
+	"Some of my subclasses do not use the instance-variables collection, position and readLimit but instead have a completely different internal representation. In these cases just use the super implementation that is inefficient but should work in all cases."
+
+"
+	Disabled until we agree on some way how to optimize this
+
+	^ (collection isNil or: [ position isNil or: [ readLimit isNil ] ])
+		ifFalse: [ PPStream on: collection from: ( position + 1 ) to: readLimit ]
+      ifTrue: [ super asPetitStream ]
+"
+	^ super asPetitStream
+]
+
+{ #category : '*petitparser-core' }
+PositionableStream >> peekTwice [
+	"Answer what would be returned if the message next were sent to the 
+	receiver. If the receiver is at the end, answer nil."
+
+	| array |
+	self atEnd 
+		ifTrue: [^Array with: nil with: nil].
+	array := Array with: (self next) with: (self peek).
+	position := position - 1.
+	^array
+]

software/PetitParser/SequenceableCollection.extension.st

@@ -0,0 +1,6 @@
+Extension { #name : 'SequenceableCollection' }
+
+{ #category : '*petitparser-core-converting' }
+SequenceableCollection >> asPetitStream [
+	^ PPStream on: self
+]

software/PetitParser/Stream.extension.st

@@ -0,0 +1,6 @@
+Extension { #name : 'Stream' }
+
+{ #category : '*petitparser-core-converting' }
+Stream >> asPetitStream [
+	^ self contents asPetitStream
+]

software/PetitParser/String.extension.st

@@ -0,0 +1,8 @@
+Extension { #name : 'String' }
+
+{ #category : '*petitparser-core-converting' }
+String >> asParser [
+	"Answer a parser that accepts the receiving string."
+
+	^ PPLiteralSequenceParser on: self
+]

software/PetitParser/Symbol.extension.st

@@ -0,0 +1,8 @@
+Extension { #name : 'Symbol' }
+
+{ #category : '*petitparser-core-converting' }
+Symbol >> asParser [
+	"Answer a predicate parser named after the receiving symbol. Possible symbols are the method selectors on the class-side of PPPredicateObjectParser."
+
+	^ PPPredicateObjectParser perform: self
+]

software/PetitParser/Text.extension.st

@@ -0,0 +1,6 @@
+Extension { #name : 'Text' }
+
+{ #category : '*petitparser-core-converting' }
+Text >> asPetitStream [
+	^ string asPetitStream
+]

software/PetitParser/UndefinedObject.extension.st

@@ -0,0 +1,8 @@
+Extension { #name : 'UndefinedObject' }
+
+{ #category : '*petitparser-converting' }
+UndefinedObject >> asParser [
+	"Answer a parser that succeeds and does not consume anything."
+	
+	^ PPEpsilonParser new
+]

software/PetitParser/package.st

@@ -0,0 +1 @@
+Package { #name : 'PetitParser' }

software/PetitTests/PPAbstractParserTest.class.st

@@ -0,0 +1,102 @@
+Class {
+	#name : 'PPAbstractParserTest',
+	#superclass : 'TestCase',
+	#category : 'PetitTests-Core'
+}
+
+{ #category : 'testing' }
+PPAbstractParserTest class >> isAbstract [
+	^ self name = #PPAbstractParserTest
+]
+
+{ #category : 'accessing' }
+PPAbstractParserTest class >> packageNamesUnderTest [
+	^ #('PetitParser' 'PetitTests')
+]
+
+{ #category : 'utilities' }
+PPAbstractParserTest >> assert: aParser fail: aCollection [
+	^ self assert: aParser fail: aCollection end: 0
+]
+
+{ #category : 'utilities' }
+PPAbstractParserTest >> assert: aParser fail: aCollection end: anInteger [
+	| stream result context |
+	self 
+		assert: aParser isPetitParser
+		description: 'Parser invalid'.
+	stream := aCollection asPetitStream.
+	context := self context.
+	
+	
+	result := aParser parse: stream withContext: context.
+	self 
+		assert: result isPetitFailure
+		description: 'Parser did not fail'.
+	self
+		assert: context position = anInteger
+		description: 'Parser failed at wrong position'.
+	^ result
+]
+
+{ #category : 'utilities' }
+PPAbstractParserTest >> assert: string1 includesSubstring: string2 [
+	"Support portability by using ANSI search method"
+
+	self assert: (string1 notEmpty and: [string2 notEmpty and: [0 < (string1 indexOfSubCollection: string2 startingAt: 1)]])
+]
+
+{ #category : 'utilities' }
+PPAbstractParserTest >> assert: aParser parse: aCollection [
+	^ self assert: aParser parse: aCollection to: nil end: aCollection size 
+]
+
+{ #category : 'utilities' }
+PPAbstractParserTest >> assert: aParser parse: aCollection end: anInteger [
+	^ self assert: aParser parse: aCollection to: nil end: anInteger
+]
+
+{ #category : 'utilities' }
+PPAbstractParserTest >> assert: aParser parse: aCollection to: anObject [
+	^ self assert: aParser parse: aCollection to: anObject end: aCollection size 
+]
+
+{ #category : 'utilities' }
+PPAbstractParserTest >> assert: aParser parse: aCollection to: aTargetObject end: anInteger [
+	| stream result context |
+
+	self assert: aParser isPetitParser description: 'Parser invalid'.
+	stream := aCollection asPetitStream.
+	context := self context.
+	
+	result := aParser parse: stream withContext: context.
+	aTargetObject isNil
+		ifTrue: [ self deny: result isPetitFailure ]
+		ifFalse: [ self assert: result equals: aTargetObject ].
+	self assert: context position = anInteger description: 'Parser accepted at wrong position'.
+	^ result
+]
+
+{ #category : 'utilities' }
+PPAbstractParserTest >> assert: aParser parse: aCollection toToken: aStartInteger stop: aStopInteger [
+	^ self assert: aParser parse: aCollection toToken: aStartInteger stop: aStopInteger end: aCollection size
+]
+
+{ #category : 'utilities' }
+PPAbstractParserTest >> assert: aParser parse: aParserObject toToken: aStartInteger stop: aStopInteger end: anEndInteger [
+	| token |
+	token := self
+		assert: aParser
+		parse: aParserObject
+		to: nil
+		end: anEndInteger.
+	self assert: (token isKindOf: PPToken).
+	self assert: token start equals: aStartInteger.
+	self assert: token stop equals: aStopInteger.
+	^ token
+]
+
+{ #category : 'context' }
+PPAbstractParserTest >> context [
+	^ PPContext new
+]

software/PetitTests/PPArithmeticParser.class.st

@@ -0,0 +1,65 @@
+Class {
+	#name : 'PPArithmeticParser',
+	#superclass : 'PPCompositeParser',
+	#instVars : [
+		'terms',
+		'addition',
+		'factors',
+		'multiplication',
+		'power',
+		'primary',
+		'parentheses',
+		'number'
+	],
+	#category : 'PetitTests-Examples'
+}
+
+{ #category : 'grammar' }
+PPArithmeticParser >> addition [
+	^ (factors separatedBy: ($+ asParser / $- asParser) trim) 
+		foldLeft: [ :a :op :b | a perform: op asSymbol with: b ]
+]
+
+{ #category : 'grammar' }
+PPArithmeticParser >> factors [
+	^ multiplication / power
+]
+
+{ #category : 'grammar' }
+PPArithmeticParser >> multiplication [
+	^ (power separatedBy: ($* asParser / $/ asParser) trim)
+		foldLeft: [ :a :op :b | a perform: op asSymbol with: b ]
+]
+
+{ #category : 'grammar' }
+PPArithmeticParser >> number [
+	^ ($- asParser optional , #digit asParser plus , ($. asParser , #digit asParser plus) optional) flatten trim 
+		==> [ :value | value asNumber ]
+]
+
+{ #category : 'grammar' }
+PPArithmeticParser >> parentheses [
+	^ $( asParser trim , terms , $) asParser trim
+		==> [ :nodes | nodes at: 2 ]
+]
+
+{ #category : 'grammar' }
+PPArithmeticParser >> power [
+	^ (primary separatedBy: $^ asParser trim)
+		foldRight: [ :a :op :b | a raisedTo: b ]
+]
+
+{ #category : 'grammar' }
+PPArithmeticParser >> primary [
+	^ number / parentheses
+]
+
+{ #category : 'accessing' }
+PPArithmeticParser >> start [
+	^ terms end
+]
+
+{ #category : 'grammar' }
+PPArithmeticParser >> terms [
+	^ addition / factors
+]

software/PetitTests/PPArithmeticParserTest.class.st

@@ -0,0 +1,124 @@
+Class {
+	#name : 'PPArithmeticParserTest',
+	#superclass : 'PPCompositeParserTest',
+	#category : 'PetitTests-Tests'
+}
+
+{ #category : 'accessing' }
+PPArithmeticParserTest >> parserClass [
+	^ PPArithmeticParser
+]
+
+{ #category : 'testing-operations' }
+PPArithmeticParserTest >> testAdd [
+	self assert: '1 + 2' is: 3.
+	self assert: '2 + 1' is: 3.
+	self assert: '1 + 2.3' is: 3.3.
+	self assert: '2.3 + 1' is: 3.3.
+	self assert: '1 + -2' is: -1.
+	self assert: '-2 + 1' is: -1
+]
+
+{ #category : 'testing-operations' }
+PPArithmeticParserTest >> testAddMany [
+	self assert: '1' is: 1.
+	self assert: '1 + 2' is: 3.
+	self assert: '1 + 2 + 3' is: 6.
+	self assert: '1 + 2 + 3 + 4' is: 10.
+	self assert: '1 + 2 + 3 + 4 + 5' is: 15
+]
+
+{ #category : 'testing-expression' }
+PPArithmeticParserTest >> testBrackets [
+	self assert: '(1)' is: 1.
+	self assert: '(1 + 2)' is: 3.
+	
+	self assert: '((1))' is: 1.
+	self assert: '((1 + 2))' is: 3.
+
+	self assert: '2 * (3 + 4)' is: 14.
+	self assert: '(2 + 3) * 4' is: 20.
+	self assert: '6 / (2 + 4)' is: 1.
+	self assert: '(2 + 6) / 2' is: 4
+]
+
+{ #category : 'testing-operations' }
+PPArithmeticParserTest >> testDiv [
+	self assert: '12 / 3' is: 4.
+	self assert: '-16 / -4' is: 4
+]
+
+{ #category : 'testing-operations' }
+PPArithmeticParserTest >> testDivMany [
+	self assert: '100 / 2' is: 50.
+	self assert: '100 / 2 / 2' is: 25.
+	self assert: '100 / 2 / 2 / 5' is: 5.
+	self assert: '100 / 2 / 2 / 5 / 5' is: 1
+	
+]
+
+{ #category : 'testing-operations' }
+PPArithmeticParserTest >> testMul [
+	self assert: '2 * 3' is: 6.
+	self assert: '2 * -4' is: -8
+]
+
+{ #category : 'testing-operations' }
+PPArithmeticParserTest >> testMulMany [
+	self assert: '1 * 2' is: 2.
+	self assert: '1 * 2 * 3' is: 6.
+	self assert: '1 * 2 * 3 * 4' is: 24.
+	self assert: '1 * 2 * 3 * 4 * 5' is: 120
+]
+
+{ #category : 'testing' }
+PPArithmeticParserTest >> testNum [
+	self assert: '0' is: 0.
+	self assert: '0.0' is: 0.0.
+	self assert: '1' is: 1.
+	self assert: '1.2' is: 1.2.
+	self assert: '34' is: 34.
+	self assert: '56.78' is: 56.78.
+	self assert: '-9' is: -9.
+	self assert: '-9.9' is: -9.9
+]
+
+{ #category : 'testing-operations' }
+PPArithmeticParserTest >> testPow [
+	self assert: '2 ^ 3' is: 8.
+	self assert: '-2 ^ 3' is: -8.
+	self assert: '-2 ^ -3' is: -0.125
+]
+
+{ #category : 'testing-operations' }
+PPArithmeticParserTest >> testPowMany [
+	self assert: '4 ^ 3' is: 64.
+	self assert: '4 ^ 3 ^ 2' is: 262144.
+	self assert: '4 ^ 3 ^ 2 ^ 1' is: 262144.
+	self assert: '4 ^ 3 ^ 2 ^ 1 ^ 0' is: 262144
+]
+
+{ #category : 'testing-expression' }
+PPArithmeticParserTest >> testPriority [
+	self assert: '2 * 3 + 4' is: 10.
+	self assert: '2 + 3 * 4' is: 14.
+	self assert: '6 / 3 + 4' is: 6.
+	self assert: '2 + 6 / 2' is: 5
+]
+
+{ #category : 'testing-operations' }
+PPArithmeticParserTest >> testSub [
+	self assert: '1 - 2' is: -1.
+	self assert: '1.2 - 1.2' is: 0.
+	self assert: '1 - -2' is: 3.
+	self assert: '-1 - -2' is: 1
+]
+
+{ #category : 'testing-operations' }
+PPArithmeticParserTest >> testSubMany [
+	self assert: '1' is: 1.
+	self assert: '1 - 2' is: -1.
+	self assert: '1 - 2 - 3' is: -4.
+	self assert: '1 - 2 - 3 - 4' is: -8.
+	self assert: '1 - 2 - 3 - 4 - 5' is: -13
+]

software/PetitTests/PPComposedTest.class.st

@@ -0,0 +1,410 @@
+Class {
+	#name : 'PPComposedTest',
+	#superclass : 'PPAbstractParserTest',
+	#category : 'PetitTests-Tests'
+}
+
+{ #category : 'accessing' }
+PPComposedTest >> comment [
+	^ ($" asParser , $" asParser negate star , $" asParser) flatten
+]
+
+{ #category : 'accessing' }
+PPComposedTest >> identifier [
+	^ (#letter asParser , #word asParser star) flatten
+]
+
+{ #category : 'accessing' }
+PPComposedTest >> number [
+	^ ($- asParser optional , #digit asParser plus , ($. asParser , #digit asParser plus) optional) flatten
+]
+
+{ #category : 'testing-examples' }
+PPComposedTest >> testComment [
+	self assert: self comment parse: '""' to: '""'.
+	self assert: self comment parse: '"a"' to: '"a"'.
+	self assert: self comment parse: '"ab"' to: '"ab"'.
+	self assert: self comment parse: '"abc"' to: '"abc"'.
+
+	self assert: self comment parse: '""a' to: '""' end: 2.
+	self assert: self comment parse: '"a"a' to: '"a"' end: 3.
+	self assert: self comment parse: '"ab"a' to: '"ab"' end: 4.
+	self assert: self comment parse: '"abc"a' to: '"abc"' end: 5.
+
+	self assert: self comment fail: '"'.
+	self assert: self comment fail: '"a'.
+	self assert: self comment fail: '"aa'.
+	self assert: self comment fail: 'a"'.
+	self assert: self comment fail: 'aa"'
+]
+
+{ #category : 'testing' }
+PPComposedTest >> testDoubledString [
+	| parser |
+	parser := ($' asParser , (($' asParser , $' asParser) / $' asParser negate) star flatten , $' asParser) 
+		==> [ :nodes | nodes second copyReplaceAll: '''''' with: '''' ].
+
+	self assert: parser parse: '''''' to: ''.
+	self assert: parser parse: '''a''' to: 'a'.
+	self assert: parser parse: '''ab''' to: 'ab'.
+	self assert: parser parse: '''a''''b''' to: 'a''b'.
+	self assert: parser parse: '''a''''''''b''' to: 'a''''b'
+]
+
+{ #category : 'testing' }
+PPComposedTest >> testEvenNumber [
+	"Create a grammar that parses an even number of a's and b's."
+	
+	| a as b bs s |
+	a := $a asParser ==> [ :char | as := as + 1 ].
+	b := $b asParser ==> [ :char | bs := bs + 1 ].
+	s := (a / b) star >=> [ :stream :cc |
+		as := bs := 0.
+		cc value.
+		(as even and: [ bs even ])
+			ifFalse: [ PPFailure message: 'Even number of a and b expected' context: stream at: 0 ] ].
+
+	self assert: s fail: 'a' end: 1.
+	self assert: s fail: 'b' end: 1.
+	self assert: s fail: 'ab' end: 2.
+	self assert: s fail: 'ba' end: 2.
+	self assert: s fail: 'aaa' end: 3.
+	self assert: s fail: 'bbb' end: 3.
+	self assert: s fail: 'aab' end: 3.
+	self assert: s fail: 'abb' end: 3.
+	
+	self assert: s parse: ''.
+	self assert: s parse: 'aa'.
+	self assert: s parse: 'bb'.
+	self assert: s parse: 'aaaa'.
+	self assert: s parse: 'aabb'.
+	self assert: s parse: 'abab'.
+	self assert: s parse: 'baba'.
+	self assert: s parse: 'bbaa'.
+	self assert: s parse: 'bbbb'
+]
+
+{ #category : 'testing-examples' }
+PPComposedTest >> testIdentifier [
+	self assert: self identifier parse: 'a' to: 'a'.
+	self assert: self identifier parse: 'a1' to: 'a1'.
+	self assert: self identifier parse: 'a12' to: 'a12'.
+	self assert: self identifier parse: 'ab' to: 'ab'.
+	self assert: self identifier parse: 'a1b' to: 'a1b'.
+
+	self assert: self identifier parse: 'a_' to: 'a' end: 1.
+	self assert: self identifier parse: 'a1-' to: 'a1' end: 2.
+	self assert: self identifier parse: 'a12+' to: 'a12' end: 3.
+	self assert: self identifier parse: 'ab^' to: 'ab' end: 2.
+	self assert: self identifier parse: 'a1b*' to: 'a1b' end: 3.
+
+	self assert: self identifier fail: ''.
+	self assert: self identifier fail: '1'.
+	self assert: self identifier fail: '1a'
+]
+
+{ #category : 'testing' }
+PPComposedTest >> testIfThenElse [
+	"S ::= if C then S else S | if C then S | X"
+
+	| start if then else cond expr parser |
+	start := PPDelegateParser new.
+	if := 'if' asParser token trim.
+	then := 'then' asParser token trim.
+	else := 'else' asParser token trim.
+	cond := 'C' asParser token trim.
+	expr := 'X' asParser token trim.
+	start setParser: (if , cond , then , start , else , start) / (if , cond , then , start) / expr.
+	parser := start end.
+	self assert: parser parse: 'X'.
+	self assert: parser parse: 'if C then X'.
+	self assert: parser parse: 'if C then X else X'.
+	self assert: parser parse: 'if C then if C then X'.
+	self assert: parser parse: 'if C then if C then X else if C then X'.
+	self assert: parser parse: 'if C then if C then X else X else if C then X'.
+	self assert: parser parse: 'if C then if C then X else X else if C then X else X'.
+	self assert: parser fail: 'if C'.
+	self assert: parser fail: 'if C else X'.
+	self assert: parser fail: 'if C then if C'
+]
+
+{ #category : 'testing' }
+PPComposedTest >> testLeftRecursion [
+	"S ::= S 'x' S / '1'"
+	
+	| parser |
+	parser := PPDelegateParser new.
+	parser setParser: ((parser , $x asParser , parser) / $1 asParser) memoized flatten.
+
+	self assert: parser parse: '1' to: '1'.
+	self assert: parser parse: '1x1' to: '1x1'.
+	self assert: parser parse: '1x1x1' to: '1x1x1'.
+	self assert: parser parse: '1x1x1x1' to: '1x1x1x1'.
+	self assert: parser parse: '1x1x1x1x1' to: '1x1x1x1x1'.
+	self assert: parser parse: '1x1x1x1x1x1' to: '1x1x1x1x1x1'
+]
+
+{ #category : 'testing' }
+PPComposedTest >> testListOfIntegers [
+	"S ::= S , number | number"
+	
+	| number list parser |
+	number := #digit asParser plus flatten trim
+		==> [ :node | node asInteger ].
+	list := (number separatedBy: $, asParser token trim)
+		==> [ :node | node select: [ :each | each isKindOf: Integer ] ].
+	parser := list end.
+
+	self assert: parser parse: '1' to: (1 to: 1) asArray.
+	self assert: parser parse: '1,2' to: (1 to: 2) asArray.
+	self assert: parser parse: '1,2,3' to: (1 to: 3) asArray.
+	self assert: parser parse: '1,2,3,4' to: (1 to: 4) asArray.
+	self assert: parser parse: '1,2,3,4,5' to: (1 to: 5) asArray.
+
+	self assert: parser parse: '1' to: (1 to: 1) asArray.
+	self assert: parser parse: '1, 2' to: (1 to: 2) asArray.
+	self assert: parser parse: '1, 2, 3' to: (1 to: 3) asArray.
+	self assert: parser parse: '1, 2, 3, 4' to: (1 to: 4) asArray.
+	self assert: parser parse: '1, 2, 3, 4, 5' to: (1 to: 5) asArray.
+
+	self assert: parser parse: '1' to: (1 to: 1) asArray.
+	self assert: parser parse: '1 ,2' to: (1 to: 2) asArray.
+	self assert: parser parse: '1 ,2 ,3' to: (1 to: 3) asArray.
+	self assert: parser parse: '1 ,2 ,3 ,4' to: (1 to: 4) asArray.
+	self assert: parser parse: '1 ,2 ,3 ,4 ,5' to: (1 to: 5) asArray.
+	
+	self assert: parser fail: ''.
+	self assert: parser fail: ','.
+	self assert: parser fail: '1,'.
+	self assert: parser fail: '1,,2'
+]
+
+{ #category : 'testing' }
+PPComposedTest >> testNestedComments [
+	"C ::= B I* E"
+	"I ::= !E (C | T)"
+	"B ::= /*"
+	"E ::= */"
+	"T ::= ."
+	
+	| begin end any inside parser |
+	begin := '/*' asParser.
+	end := '*/' asParser.
+	any := #any asParser.
+	
+	parser := PPDelegateParser new.
+	inside := end not , (parser / any).
+	parser setParser: begin , inside star , end.
+	
+	self assert: parser parse: '/*ab*/cd' end: 6.
+	self assert: parser parse: '/*a/*b*/c*/'.
+	self assert: parser fail: '/*a/*b*/c'
+]
+
+{ #category : 'testing-examples' }
+PPComposedTest >> testNumber [
+	self assert: self number parse: '1' to: '1'.
+	self assert: self number parse: '12' to: '12'.
+	self assert: self number parse: '12.3' to: '12.3'.
+	self assert: self number parse: '12.34' to: '12.34'.
+
+	self assert: self number parse: '1..' to: '1' end: 1.
+	self assert: self number parse: '12-' to: '12' end: 2.
+	self assert: self number parse: '12.3.' to: '12.3' end: 4.
+	self assert: self number parse: '12.34.' to: '12.34' end: 5.
+	
+	self assert: self number parse: '-1' to: '-1'.
+	self assert: self number parse: '-12' to: '-12'.
+	self assert: self number parse: '-12.3' to: '-12.3'.
+	self assert: self number parse: '-12.34' to: '-12.34'.
+	
+	self assert: self number fail: ''.
+	self assert: self number fail: '-'.
+	self assert: self number fail: '.'.
+	self assert: self number fail: '.1'
+]
+
+{ #category : 'testing' }
+PPComposedTest >> testPalindrome [
+	"S0 ::= a S1 a | b S1 b | ...
+	 S1 ::= S0 | epsilon"
+	
+	| s0 s1 parser |
+	s0 := PPDelegateParser new.
+	s1 := PPDelegateParser new.
+	s0 setParser: ($a asParser , s1 , $a asParser)
+		/ ($b asParser , s1 , $b asParser)
+		/ ($c asParser , s1 , $c asParser).	
+	s1 setParser: s0 / nil asParser.
+	parser := s0 flatten end.
+
+	self assert: parser parse: 'aa' to: 'aa'.
+	self assert: parser parse: 'bb' to: 'bb'.
+	self assert: parser parse: 'cc' to: 'cc'.
+	
+	self assert: parser parse: 'abba' to: 'abba'.
+	self assert: parser parse: 'baab' to: 'baab'.
+
+	self assert: parser parse: 'abccba' to: 'abccba'.
+	self assert: parser parse: 'abaaba' to: 'abaaba'.
+	self assert: parser parse: 'cbaabc' to: 'cbaabc'.
+
+	self assert: parser fail: 'a'.
+	self assert: parser fail: 'ab'.
+	self assert: parser fail: 'aab'.
+	self assert: parser fail: 'abccbb'
+]
+
+{ #category : 'testing' }
+PPComposedTest >> testParseAaaBbb [
+	"S0 ::= a S1 b
+	 S1 ::= S0 | epsilon"
+	
+	| s0 s1 parser |
+	s0 := PPDelegateParser new.
+	s1 := PPDelegateParser new.
+	s0 setParser: $a asParser , s1 , $b asParser.
+	s1 setParser: s0 / nil asParser.
+	parser := s0 flatten.
+
+	self assert: parser parse: 'ab' to: 'ab'.
+	self assert: parser parse: 'aabb' to: 'aabb'.
+	self assert: parser parse: 'aaabbb' to: 'aaabbb'.
+	self assert: parser parse: 'aaaabbbb' to: 'aaaabbbb'.
+
+	self assert: parser parse: 'abb' to: 'ab' end: 2.
+	self assert: parser parse: 'aabbb' to: 'aabb' end: 4.
+	self assert: parser parse: 'aaabbbb' to: 'aaabbb' end: 6.
+	self assert: parser parse: 'aaaabbbbb' to: 'aaaabbbb' end: 8.
+
+	self assert: parser fail: 'a'.
+	self assert: parser fail: 'b'.
+	self assert: parser fail: 'aab'.
+	self assert: parser fail: 'aaabb'
+]
+
+{ #category : 'testing' }
+PPComposedTest >> testParseAaaaaa [
+	"S ::= a a S | epsilon"
+	
+	| s0 s1 parser |
+	s0 := PPDelegateParser new.
+	s1 := $a asParser , $a asParser , s0.
+	s0 setParser: s1 / nil asParser.
+	parser := s0 flatten.
+
+	self assert: parser parse: '' to: ''.
+	self assert: parser parse: 'aa' to: 'aa'.
+	self assert: parser parse: 'aaaa' to: 'aaaa'.
+	self assert: parser parse: 'aaaaaa' to: 'aaaaaa'.
+
+	self assert: parser parse: 'a' to: '' end: 0.
+	self assert: parser parse: 'aaa' to: 'aa' end: 2.
+	self assert: parser parse: 'aaaaa' to: 'aaaa' end: 4.
+	self assert: parser parse: 'aaaaaaa' to: 'aaaaaa' end: 6
+]
+
+{ #category : 'testing' }
+PPComposedTest >> testParseAbAbAb [
+	"S ::= (A B)+"
+	
+	| parser |
+	parser := ($a asParser , $b asParser) plus flatten.
+
+	self assert: parser parse: 'ab' to: 'ab'.
+	self assert: parser parse: 'abab' to: 'abab'.
+	self assert: parser parse: 'ababab' to: 'ababab'.
+	self assert: parser parse: 'abababab' to: 'abababab'.
+
+	self assert: parser parse: 'abb' to: 'ab' end: 2.
+	self assert: parser parse: 'ababa' to: 'abab' end: 4.
+	self assert: parser parse: 'abababb' to: 'ababab' end: 6.
+	self assert: parser parse: 'ababababa' to: 'abababab' end: 8.
+	
+	self assert: parser fail: ''.
+	self assert: parser fail: 'a'.
+	self assert: parser fail: 'bab'
+]
+
+{ #category : 'testing' }
+PPComposedTest >> testParseAbabbb [
+	"S ::= (A | B)+"
+
+	| parser |
+	parser := ($a asParser / $b asParser) plus flatten.
+
+	self assert: parser parse: 'a' to: 'a'.
+	self assert: parser parse: 'b' to: 'b'.
+	self assert: parser parse: 'ab' to: 'ab'.
+	self assert: parser parse: 'ba' to: 'ba'.
+	self assert: parser parse: 'aaa' to: 'aaa'.
+	self assert: parser parse: 'aab' to: 'aab'.
+	self assert: parser parse: 'aba' to: 'aba'.
+	self assert: parser parse: 'baa' to: 'baa'.
+	self assert: parser parse: 'abb' to: 'abb'.
+	self assert: parser parse: 'bab' to: 'bab'.
+	self assert: parser parse: 'bba' to: 'bba'.
+	self assert: parser parse: 'bbb' to: 'bbb'.
+
+	self assert: parser parse: 'ac' to: 'a' end: 1.
+	self assert: parser parse: 'bc' to: 'b' end: 1.
+	self assert: parser parse: 'abc' to: 'ab' end: 2.
+	self assert: parser parse: 'bac' to: 'ba' end: 2.
+	
+	self assert: parser fail: ''.
+	self assert: parser fail: 'c'
+]
+
+{ #category : 'testing' }
+PPComposedTest >> testParseAnBnCn [
+	"PEGs for a non context- free language: 
+		
+		a^n , b^n , c^n
+		
+	S <- &P1 P2 
+	P1 <- AB 'c' 
+	AB <- 'a' AB 'b' / epsilon
+	P2 <- 'a'* BC end
+	BC <- 'b' BC 'c' / epsilon"
+	
+	| s p1 ab p2 bc |
+	s := PPDelegateParser new.
+	p1 := PPDelegateParser new.
+	ab := PPDelegateParser new.
+	p2 := PPDelegateParser new.
+	bc := PPDelegateParser new.
+	
+	s setParser: (p1 and , p2 end) flatten.
+	p1 setParser: ab , $c asParser.
+	ab setParser: ($a asParser , ab , $b asParser) optional.
+	p2 setParser: $a asParser star , bc.
+	bc setParser: ($b asParser , bc , $c asParser) optional.
+	
+	self assert: s parse: 'abc' to: 'abc'.
+	self assert: s parse: 'aabbcc' to: 'aabbcc'.
+	self assert: s parse: 'aaabbbccc' to: 'aaabbbccc'.
+
+	self assert: s fail: 'bc'.
+	self assert: s fail: 'ac'.
+	self assert: s fail: 'ab'.
+	self assert: s fail: 'abbcc'.
+	self assert: s fail: 'aabcc'.
+	self assert: s fail: 'aabbc'
+]
+
+{ #category : 'testing-examples' }
+PPComposedTest >> testReturn [
+	| number spaces return |
+	number := #digit asParser plus flatten.
+	spaces := #space asParser star.
+	return := (spaces , $^ asParser token , spaces , number)
+		==> [ :nodes | Array with: #return with: (nodes at: 4) ].
+
+	self assert: return parse: '^1' to: #(return '1').
+	self assert: return parse: '^12' to: #(return '12').
+	self assert: return parse: '^ 123' to: #(return '123').
+	self assert: return parse: '^  1234' to: #(return '1234').
+	
+	self assert: return fail: '1'.
+	self assert: return fail: '^'
+]

software/PetitTests/PPCompositeParserTest.class.st

@@ -0,0 +1,130 @@
+Class {
+	#name : 'PPCompositeParserTest',
+	#superclass : 'PPAbstractParserTest',
+	#instVars : [
+		'parser',
+		'result',
+		'debugResult'
+	],
+	#category : 'PetitTests-Core'
+}
+
+{ #category : 'testing' }
+PPCompositeParserTest class >> isAbstract [
+	^ self name = #PPCompositeParserTest
+]
+
+{ #category : 'accessing' }
+PPCompositeParserTest class >> resources [
+	^ Array with: PPParserResource
+]
+
+{ #category : 'utilities' }
+PPCompositeParserTest >> assert: aCollection is: anObject [
+	self parse: aCollection.
+	self
+		assert: result = anObject
+		description: 'Got: ' , result printString , '; Expected: ' , anObject printString
+		resumable: true
+]
+
+{ #category : 'parsing' }
+PPCompositeParserTest >> debug: aString [ 
+	^ self debug: aString rule: #start
+]
+
+{ #category : 'parsing' }
+PPCompositeParserTest >> debug: aString rule: aSymbol [
+	| production context |
+	production := self parserInstanceFor: aSymbol.
+	context := self context.
+	
+	debugResult := production end enableDebug parse: aString withContext: context.
+	result := debugResult children first result.
+	
+	self
+		deny: result isPetitFailure
+		description: 'Unable to parse ' , aString printString.	
+	
+	^ debugResult
+]
+
+{ #category : 'parsing' }
+PPCompositeParserTest >> fail: aString rule: aSymbol [ 
+	| production context |
+	production := self parserInstanceFor: aSymbol.
+	context := self context.
+	
+	result := production end parse: aString withContext: context.
+	
+	self
+		assert: result isPetitFailure
+		description: 'Able to parse ' , aString printString.
+	^ result
+]
+
+{ #category : 'parsing' }
+PPCompositeParserTest >> parse: aString [ 
+	^ self parse: aString rule: #start
+]
+
+{ #category : 'parsing' }
+PPCompositeParserTest >> parse: aString rule: aSymbol [
+	| production context |
+	production := self parserInstanceFor: aSymbol.
+	context := self context.
+	
+	result := production end parse: aString withContext: context.
+	self
+		deny: result isPetitFailure
+		description: 'Unable to parse ' , aString printString.
+	^ result
+]
+
+{ #category : 'parsing' }
+PPCompositeParserTest >> parse: aString rule: aSymbol to: expectedResult end: end [
+	| production context |
+	production := self parserInstanceFor: aSymbol.
+	context := self context.
+	
+	result := production parse: aString withContext: context.
+	self
+		deny: result isPetitFailure
+		description: 'Unable to parse ' , aString printString.
+	
+	self assert: expectedResult = result.
+	self assert: context position = end.
+	^ result
+]
+
+{ #category : 'accessing' }
+PPCompositeParserTest >> parserClass [
+	self subclassResponsibility
+]
+
+{ #category : 'accessing' }
+PPCompositeParserTest >> parserInstance [
+	^ PPParserResource current parserAt: self parserClass
+]
+
+{ #category : 'accessing' }
+PPCompositeParserTest >> parserInstanceFor: aSymbol [
+	^ aSymbol = #start
+		ifTrue: [ self parserInstance ]
+		ifFalse: [
+			self parserInstance
+				productionAt: aSymbol 
+				ifAbsent: [ self error: 'Production ' , self parserClass name , '>>' , aSymbol printString , ' not found.' ] ]
+]
+
+{ #category : 'running' }
+PPCompositeParserTest >> setUp [
+	super setUp.
+	parser := self parserInstance
+]
+
+{ #category : 'running' }
+PPCompositeParserTest >> tearDown [
+	super tearDown.
+	parser := result := nil
+]

software/PetitTests/PPConditionalParserTest.class.st

@@ -0,0 +1,52 @@
+Class {
+	#name : 'PPConditionalParserTest',
+	#superclass : 'PPAbstractParserTest',
+	#instVars : [
+		'context'
+	],
+	#category : 'PetitTests-Tests'
+}
+
+{ #category : 'as yet unclassified' }
+PPConditionalParserTest >> context [
+	^ context
+]
+
+{ #category : 'as yet unclassified' }
+PPConditionalParserTest >> setUp [
+	super setUp.
+	context := PPContext new
+]
+
+{ #category : 'as yet unclassified' }
+PPConditionalParserTest >> testConditionCtxAccess [
+	| parser |
+
+	parser := ('a' asParser if: [ :ctx | (ctx propertyAt: #foo) = #bar ]).
+	
+	context propertyAt: #foo put: #bar.
+	self assert: parser parse: 'a' .
+
+
+	context propertyAt: #foo put: #zorg.
+	self assert: parser fail: 'a' .
+
+]
+
+{ #category : 'as yet unclassified' }
+PPConditionalParserTest >> testConditionFalse [
+	| parser |
+	parser := ('a' asParser if: [ :ctx | false ]).
+	
+	self assert: parser fail: 'a'.
+	self assert: parser fail: 'b'.
+]
+
+{ #category : 'as yet unclassified' }
+PPConditionalParserTest >> testConditionTrue [
+	| parser |
+	parser := ('a' asParser if: [ :ctx | true ]).
+	
+	self assert: parser parse: 'a'.
+	self assert: parser fail: 'b'.
+]

software/PetitTests/PPConditionalParserTests.class.st

@@ -0,0 +1,52 @@
+Class {
+	#name : 'PPConditionalParserTests',
+	#superclass : 'PPAbstractParserTest',
+	#instVars : [
+		'context'
+	],
+	#category : 'PetitTests-Tests'
+}
+
+{ #category : 'as yet unclassified' }
+PPConditionalParserTests >> context [
+	^ context
+]
+
+{ #category : 'as yet unclassified' }
+PPConditionalParserTests >> setUp [
+	super setUp.
+	context := PPContext new
+]
+
+{ #category : 'as yet unclassified' }
+PPConditionalParserTests >> testConditionCtxAccess [
+	| parser |
+
+	parser := ('a' asParser if: [ :ctx | (ctx propertyAt: #foo) = #bar ]).
+	
+	context propertyAt: #foo put: #bar.
+	self assert: parser parse: 'a' .
+
+
+	context propertyAt: #foo put: #zorg.
+	self assert: parser fail: 'a' .
+
+]
+
+{ #category : 'as yet unclassified' }
+PPConditionalParserTests >> testConditionFalse [
+	| parser |
+	parser := ('a' asParser if: [ :ctx | false ]).
+	
+	self assert: parser fail: 'a'.
+	self assert: parser fail: 'b'.
+]
+
+{ #category : 'as yet unclassified' }
+PPConditionalParserTests >> testConditionTrue [
+	| parser |
+	parser := ('a' asParser if: [ :ctx | true ]).
+	
+	self assert: parser parse: 'a'.
+	self assert: parser fail: 'b'.
+]

software/PetitTests/PPContextMementoTest.class.st

@@ -0,0 +1,123 @@
+Class {
+	#name : 'PPContextMementoTest',
+	#superclass : 'TestCase',
+	#instVars : [
+		'memento'
+	],
+	#category : 'PetitTests-Tests'
+}
+
+{ #category : 'accessing' }
+PPContextMementoTest >> memento [
+	^ PPContextMemento new
+]
+
+{ #category : 'running' }
+PPContextMementoTest >> setUp [
+	super setUp.
+	memento := self memento.
+]
+
+{ #category : 'tests' }
+PPContextMementoTest >> testEquality [
+	| m1 m2  |
+	m1 := self memento.
+	m2 := self memento.
+	
+	self assert: m1 = m2.
+	
+	m1 propertyAt: #foo put: #bar.
+	self assert: (m1 = m2) not.
+	
+	m2 propertyAt: #foo put: #bar.
+	self assert: m1 = m2.
+
+]
+
+{ #category : 'tests' }
+PPContextMementoTest >> testEquality2 [
+	| m1 m2  |
+	m1 := self memento.
+	m2 := self memento.
+	
+	self assert: m1 = m2.
+	
+	m1 propertyAt: #foo put: #bar.
+	self assert: (m1 = m2) not.
+	
+	m2 propertyAt: #bar put: #foo.
+	self assert: (m1 = m2) not.
+
+]
+
+{ #category : 'tests' }
+PPContextMementoTest >> testGetProperty [
+	
+	| c retval retval2 |
+	c := OrderedCollection new.
+	
+	memento propertyAt: #foo put: c.
+	
+	retval := memento propertyAt: #foo.
+	self assert: retval size = c size.
+	self assert: (retval == c) not.
+	self assert: retval = c.
+	
+	c add: #element.
+	self assert: (retval = c) not.
+
+	retval2 := memento propertyAt: #foo.
+	self assert: (retval = retval2).
+	self assert: (retval == retval2) not.
+	
+	retval add: #element.
+	self assert: (retval = retval2) not.
+
+]
+
+{ #category : 'tests' }
+PPContextMementoTest >> testKeysAndValuesDo [
+	|   |
+	memento keysAndValuesDo: [ :key :value |
+		self signalFailure: 'Should not be called'
+	].
+]
+
+{ #category : 'tests' }
+PPContextMementoTest >> testKeysAndValuesDo2 [
+	| c1 c2   |
+	c1 := OrderedCollection new.
+	c2 := OrderedCollection new.
+
+	memento propertyAt: #foo put: c1.
+	memento propertyAt: #bar put: c2.
+
+	memento keysAndValuesDo: [ :key :value |
+		self assert: (value == c1) not.
+		self assert: (value == c2) not.
+	].
+]
+
+{ #category : 'tests' }
+PPContextMementoTest >> testPutProperty [
+	| c retval  |
+	c := OrderedCollection new.
+	self assert: (memento hasProperty: #foo) not.
+	self assert: (memento hasProperty: #bar) not.	
+	
+	self should: [ memento propertyAt: #foo ] raise: Error.
+	self assert: (memento propertyAt: #foo ifAbsent: [ c ]) == c.
+	
+	retval := memento propertyAt: #foo ifAbsentPut: [ c ].
+	self assert: retval size = c size.	
+	self assert: (retval == c) not.
+	self assert: retval = c.
+	self assert: (memento hasProperty: #foo).
+	
+	retval := memento propertyAt: #bar put: c.
+	self assert: retval size = c size.	
+	self assert: (retval == c) not.
+	self assert: retval = c.
+	self assert: (memento hasProperty: #foo).	
+
+]

software/PetitTests/PPContextTest.class.st

@@ -0,0 +1,205 @@
+Class {
+	#name : 'PPContextTest',
+	#superclass : 'TestCase',
+	#instVars : [
+		'context'
+	],
+	#category : 'PetitTests-Tests'
+}
+
+{ #category : 'as yet unclassified' }
+PPContextTest >> context [
+	^ PPContext new
+]
+
+{ #category : 'as yet unclassified' }
+PPContextTest >> setUp [
+	super setUp.
+	context := self context.
+]
+
+{ #category : 'tests' }
+PPContextTest >> testFurthestFailure [
+	| f1 f2 |
+	
+	f1 := PPFailure message: #foo context: context at: 1.
+	self assert: context furthestFailure = f1.	
+	f2 := PPFailure message: #foo context: context at: 1.
+	self assert: context furthestFailure = f1.	
+	f2 := PPFailure message: #foo context: context at: 3.
+	self assert: context furthestFailure = f2.
+]
+
+{ #category : 'tests' }
+PPContextTest >> testMemoization [
+	| stream memento memento2 collection |
+	stream := 'abc' asPetitStream.
+	context := context stream: stream.
+	collection := OrderedCollection new.
+
+	context propertyAt: #foo put: collection.
+	
+	memento := context remember.
+	
+	self assert: memento isNil not.
+	
+	context next.
+	collection add: #element.
+	self assert: (context propertyAt: #foo) size = 1. 	
+
+	memento2 := context remember.
+
+	context restore: memento.
+	self assert: (context propertyAt: #foo) size = 0. 
+	self assert: context position = 0.
+	
+	context restore: memento2.
+	self assert: (context propertyAt: #foo) size = 1. 
+	self assert: context position = 1.
+
+]
+
+{ #category : 'tests' }
+PPContextTest >> testMemoization2 [
+	| stream memento |
+	stream := 'abc' asPetitStream.
+	context := context stream: stream.
+	
+	memento := context remember.
+	
+	context next.
+	self assert: context position = 1.
+	
+	context restore: memento.
+	self assert: context position = 0.
+
+]
+
+{ #category : 'tests' }
+PPContextTest >> testMemoization3 [
+	| stream memento memento2 collection |
+	stream := 'abc' asPetitStream.
+	context := context stream: stream.
+	collection := OrderedCollection new.
+
+	memento := context remember.
+	context propertyAt: #foo put: collection.
+	memento2 := context remember.
+	
+	context restore: memento.
+	self assert: (context hasProperty: #foo) not.
+	
+	context restore: memento2.
+	self assert: (context hasProperty: #foo).
+]
+
+{ #category : 'tests' }
+PPContextTest >> testPutGlobals [
+	self assert: (context hasGlobal: #foo) not.
+	self assert: (context hasGlobal: #bar) not.	
+	
+	self should: [ context globalAt: #foo ] raise: Error.
+	self assert: (context globalAt: #foo ifAbsent: [ #bar ]) = #bar.
+	
+	self assert: (context globalAt: #foo ifAbsentPut: [ #bar ]) = #bar.	
+	self assert: (context hasGlobal: #foo).
+	self assert: (context hasGlobal: #bar) not.	
+	self assert: (context globalAt: #foo) = #bar.
+	
+	self assert: (context globalAt: #foo ifAbsentPut: [ #zorg ]) = #bar.	
+	self assert: (context hasGlobal: #foo).
+	self assert: (context hasGlobal: #bar) not.	
+	self assert: (context globalAt: #foo) = #bar.
+	
+	self assert: (context globalAt: #foo put: #zorg) = #zorg.	
+	self assert: (context hasGlobal: #foo).
+	self assert: (context hasGlobal: #bar) not.	
+	self assert: (context globalAt: #foo) = #zorg.
+	
+	self should: [ context globalAt: #bar ] raise: Error.
+	self assert: (context globalAt: #bar put: #foo) = #foo.
+	self assert: (context globalAt: #foo) = #zorg.
+	self assert: (context globalAt: #bar) = #foo.
+
+
+]
+
+{ #category : 'tests' }
+PPContextTest >> testPutProperties [
+	self assert: (context hasProperty: #foo) not.
+	self assert: (context hasProperty: #bar) not.	
+	
+	self should: [ context propertyAt: #foo ] raise: Error.
+	self assert: (context propertyAt: #foo ifAbsent: [ #bar ]) = #bar.
+	
+	self assert: (context propertyAt: #foo ifAbsentPut: [ #bar ]) = #bar.	
+	self assert: (context hasProperty: #foo).
+	self assert: (context hasProperty: #bar) not.	
+	self assert: (context propertyAt: #foo) = #bar.
+	
+	self assert: (context propertyAt: #foo ifAbsentPut: [ #zorg ]) = #bar.	
+	self assert: (context hasProperty: #foo).
+	self assert: (context hasProperty: #bar) not.	
+	self assert: (context propertyAt: #foo) = #bar.
+	
+	self assert: (context propertyAt: #foo put: #zorg) = #zorg.	
+	self assert: (context hasProperty: #foo).
+	self assert: (context hasProperty: #bar) not.	
+	self assert: (context propertyAt: #foo) = #zorg.
+	
+	self should: [ context propertyAt: #bar ] raise: Error.
+	self assert: (context propertyAt: #bar put: #foo) = #foo.
+	self assert: (context propertyAt: #foo) = #zorg.
+	self assert: (context propertyAt: #bar) = #foo.
+
+
+]
+
+{ #category : 'tests' }
+PPContextTest >> testRemoveGlobals [
+	context globalAt: #foo put: #zorg.
+	context globalAt: #bar put: #qwark.	
+
+	self assert: (context removeGlobal: #foo) = #zorg.
+	self assert: (context removeGlobal: #bar) = #qwark.
+	
+	self should: [context removeGlobal: #foo] raise: Error.
+	self assert: (context removeGlobal: #bar ifAbsent: [ #foobar ]) = #foobar.
+
+]
+
+{ #category : 'tests' }
+PPContextTest >> testRemoveProperties [
+	context propertyAt: #foo put: #zorg.
+	context propertyAt: #bar put: #qwark.	
+
+	self assert: (context removeProperty: #foo) = #zorg.
+	self assert: (context removeProperty: #bar) = #qwark.
+	
+	self should: [context removeProperty: #foo] raise: Error.
+	self assert: (context removeProperty: #bar ifAbsent: [ #foobar ]) = #foobar.
+
+]
+
+{ #category : 'tests' }
+PPContextTest >> testStreamProtocol [
+	context stream: 'hi there' asPetitStream.
+	
+	self assert: context position = 0.
+	self assert: context peek = $h.
+	self assert: context uncheckedPeek = $h.
+
+	self assert: context next = $h.
+	self assert: context peek = $i.
+	self assert: context uncheckedPeek = $i.
+	self assert: context position = 1.
+	
+	context skip: 2.
+	self assert: context position = 3.
+	self assert: context peek = $t.
+	self assert: context atEnd not.
+	
+	self assert: (context next: 5) = 'there'.
+	self assert: context position = 8.
+	self assert: context atEnd.
+]

software/PetitTests/PPExpressionParserTest.class.st

@@ -0,0 +1,66 @@
+Class {
+	#name : 'PPExpressionParserTest',
+	#superclass : 'PPArithmeticParserTest',
+	#category : 'PetitTests-Tests'
+}
+
+{ #category : 'testing' }
+PPExpressionParserTest class >> shouldInheritSelectors [
+	^ true
+]
+
+{ #category : 'accessing' }
+PPExpressionParserTest >> parserInstance [
+	| expression parens number |
+	expression := PPExpressionParser new.
+	parens := $( asParser trim , expression , $) asParser trim
+		==> [ :value | value second ].
+	number := (#digit asParser plus , ($. asParser , #digit asParser plus) optional) flatten trim
+		==> [ :value | value asNumber ].
+	expression term: parens / number.
+	expression
+		group: [ :g |
+			g prefix: $- asParser trim do: [ :op :a | a negated ] ];
+		group: [ :g |
+			g postfix: '++' asParser trim do: [ :a :op | a + 1 ].
+			g postfix: '--' asParser trim do: [ :a :op | a - 1 ] ];
+		group: [ :g |
+			g right: $^ asParser trim do: [ :a :op :b | a raisedTo: b ] ];
+		group: [ :g |
+			g left: $* asParser trim do: [ :a :op :b | a * b ].
+			g left: $/ asParser trim do: [ :a :op :b | a / b ] ];
+		group: [ :g |
+			g left: $+ asParser trim do: [ :a :op :b | a + b ].
+			g left: $- asParser trim do: [ :a :op :b | a - b ] ].
+	^ expression end
+]
+
+{ #category : 'testing' }
+PPExpressionParserTest >> testPostfixAdd [
+	self assert: '0++' is: 1.
+	self assert: '0++++' is: 2.
+	self assert: '0++++++' is: 3.
+
+	self assert: '0+++1' is: 2.
+	self assert: '0+++++1' is: 3.
+	self assert: '0+++++++1' is: 4
+]
+
+{ #category : 'testing' }
+PPExpressionParserTest >> testPostfixSub [
+	self assert: '1--' is: 0.
+	self assert: '2----' is: 0.
+	self assert: '3------' is: 0.
+
+	self assert: '2---1' is: 0.
+	self assert: '3-----1' is: 0.
+	self assert: '4-------1' is: 0.
+]
+
+{ #category : 'testing' }
+PPExpressionParserTest >> testPrefixNegate [
+	self assert: '1' is: 1.
+	self assert: '-1' is: -1.
+	self assert: '--1' is: 1.
+	self assert: '---1' is: -1
+]

software/PetitTests/PPExtensionTest.class.st

@@ -0,0 +1,121 @@
+Class {
+	#name : 'PPExtensionTest',
+	#superclass : 'PPAbstractParserTest',
+	#category : 'PetitTests-Tests'
+}
+
+{ #category : 'testing-parser' }
+PPExtensionTest >> testCharacter [
+	| parser |
+	parser := $a asParser.
+	self assert: parser parse: 'a' to: $a.
+	self assert: parser fail: 'b'
+]
+
+{ #category : 'testing-parser' }
+PPExtensionTest >> testChoice [
+	| parser |
+	parser := #(1 2) asChoiceParser.
+	self assert: parser parse: #(1) to: 1.
+	self assert: parser parse: #(2) to: 2.
+	self assert: parser parse: #(1 2) to: 1 end: 1.
+	self assert: parser parse: #(2 1) to: 2 end: 1.
+	self assert: parser fail: #().
+	self assert: parser fail: #(3)
+]
+
+{ #category : 'testing-parser' }
+PPExtensionTest >> testClosure [
+	| parser |
+	parser := [ :stream | stream upTo: $s ] asParser.
+	self assert: parser parse: '' to: ''.
+	self assert: parser parse: 'a' to: 'a'.
+	self assert: parser parse: 'aa' to: 'aa'.
+	self assert: parser parse: 's' to: ''.
+	self assert: parser parse: 'as' to: 'a'.
+	self assert: parser parse: 'aas' to: 'aa'.
+	self assert: parser parse: 'sa' to: '' end: 1.
+	self assert: parser parse: 'saa' to: '' end: 1.
+	
+	parser := [ :stream | stream upTo: $s. PPFailure message: 'stream' context: stream ] asParser.
+	self assert: parser fail: ''.
+	self assert: parser fail: 's'.
+	self assert: parser fail: 'as'
+	
+]
+
+{ #category : 'testing-parser' }
+PPExtensionTest >> testEpsilon [
+	| parser |
+	parser := nil asParser.
+	self assert: parser asParser equals: parser
+]
+
+{ #category : 'testing-parser' }
+PPExtensionTest >> testParser [
+	| parser |
+	parser := $a asParser.
+	self assert: parser asParser equals: parser
+]
+
+{ #category : 'testing-parser' }
+PPExtensionTest >> testRange [
+	| parser |
+	parser := ($a to: $c) asParser.
+	self assert: parser parse: 'a' to: $a.
+	self assert: parser parse: 'b' to: $b.
+	self assert: parser parse: 'c' to: $c.
+	self assert: parser fail: 'd'
+]
+
+{ #category : 'testing-parser' }
+PPExtensionTest >> testSequence [
+	| parser |
+	parser := #(1 2) asSequenceParser.
+	self assert: parser parse: #(1 2) to: #(1 2).
+	self assert: parser parse: #(1 2 3) to: #(1 2) end: 2.
+	self assert: parser fail: #().
+	self assert: parser fail: #(1).
+	self assert: parser fail: #(1 1).
+	self assert: parser fail: #(1 1 2)
+]
+
+{ #category : 'testing-stream' }
+PPExtensionTest >> testStream [
+	| dot stream |
+	dot := (Character codePoint: 183) asString.
+	stream := 'abc' readStream asPetitStream.
+	self assert: stream class equals: PPStream.
+	self assert: stream printString equals: dot , 'abc'.
+	self assert: stream peek equals: $a.
+	self assert: stream uncheckedPeek equals: $a.
+	self assert: stream next equals: $a.
+	self assert: stream printString equals: 'a' , dot , 'bc'.
+	self assert: stream asPetitStream equals: stream
+]
+
+{ #category : 'testing-parser' }
+PPExtensionTest >> testString [
+	| parser |
+	parser := 'ab' asParser.
+	self assert: parser parse: 'ab' to: 'ab'.
+	self assert: parser parse: 'aba' to: 'ab' end: 2.
+	self assert: parser parse: 'abb' to: 'ab' end: 2.
+	self assert: parser fail: 'a'.
+	self assert: parser fail: 'ac'
+]
+
+{ #category : 'testing-parser' }
+PPExtensionTest >> testSymbol [
+	| parser |
+	parser := #any asParser.
+	self assert: parser parse: 'a'.
+	self assert: parser fail: ''
+]
+
+{ #category : 'testing-stream' }
+PPExtensionTest >> testText [
+	| stream |
+	stream := 'abc' asText asPetitStream.
+	self assert: stream class equals: PPStream
+]

software/PetitTests/PPLambdaParser.class.st

@@ -0,0 +1,68 @@
+Class {
+	#name : 'PPLambdaParser',
+	#superclass : 'PPCompositeParser',
+	#instVars : [
+		'expression',
+		'abstraction',
+		'application',
+		'variable'
+	],
+	#category : 'PetitTests-Examples'
+}
+
+{ #category : 'curch-booleans' }
+PPLambdaParser class >> and [
+	^ self parse: '\p.\q.((p q) p)'
+]
+
+{ #category : 'curch-booleans' }
+PPLambdaParser class >> false [
+	^ self parse: '\x.\y.y'
+]
+
+{ #category : 'curch-booleans' }
+PPLambdaParser class >> ifthenelse [
+	^ self parse: '\p.p'
+]
+
+{ #category : 'curch-booleans' }
+PPLambdaParser class >> not [
+	^ self parse: '\p.\a.\b.((p b) a)'
+]
+
+{ #category : 'curch-booleans' }
+PPLambdaParser class >> or [
+	^ self parse: '\p.\q.((p p) q)'
+]
+
+{ #category : 'curch-booleans' }
+PPLambdaParser class >> true [
+	^ self parse: '\x.\y.x'
+]
+
+{ #category : 'productions' }
+PPLambdaParser >> abstraction [
+	^ $\ asParser trim , variable , $. asParser trim , expression 
+		==> [ :node | Array with: (node at: 2) with: (node at: 4) ]
+]
+
+{ #category : 'productions' }
+PPLambdaParser >> application [
+	^ $( asParser trim , expression , expression , $) asParser trim 
+			==> [ :node | Array with: (node at: 2) with: (node at: 3) ]
+]
+
+{ #category : 'productions' }
+PPLambdaParser >> expression [
+	^ variable / abstraction / application
+]
+
+{ #category : 'accessing' }
+PPLambdaParser >> start [
+	^ expression end
+]
+
+{ #category : 'productions' }
+PPLambdaParser >> variable [
+	^ (#letter asParser , #word asParser star) flatten trim
+]

software/PetitTests/PPLambdaParserTest.class.st

@@ -0,0 +1,73 @@
+Class {
+	#name : 'PPLambdaParserTest',
+	#superclass : 'PPCompositeParserTest',
+	#category : 'PetitTests-Tests'
+}
+
+{ #category : 'accessing' }
+PPLambdaParserTest >> parserClass [
+	^ PPLambdaParser
+]
+
+{ #category : 'testing' }
+PPLambdaParserTest >> testAbstraction [
+	self assert: '\x.y' is: #('x' 'y').
+	self assert: '\x.\y.z' is: #('x' ('y' 'z'))
+]
+
+{ #category : 'testing-curch' }
+PPLambdaParserTest >> testAnd [
+	self assert: self parserClass and equals: #('p' #('q' #(#('p' 'q') 'p')))
+]
+
+{ #category : 'testing' }
+PPLambdaParserTest >> testApplication [
+	self assert: '(x x)' is: #('x' 'x').
+	self assert: '(x y)' is: #('x' 'y').
+	self assert: '((x y) z)' is: #(('x' 'y') 'z').
+	self assert: '(x (y z))' is: #('x' ('y' 'z'))
+]
+
+{ #category : 'testing-curch' }
+PPLambdaParserTest >> testFalse [
+	self assert: self parserClass false equals: #('x' #('y' 'y'))
+]
+
+{ #category : 'testing-curch' }
+PPLambdaParserTest >> testIfThenElse [
+	self assert: self parserClass ifthenelse equals: #('p' 'p')
+]
+
+{ #category : 'testing-curch' }
+PPLambdaParserTest >> testNot [
+	self assert: self parserClass not equals: #('p' #('a' #('b' #(#('p' 'b') 'a'))))
+]
+
+{ #category : 'testing-curch' }
+PPLambdaParserTest >> testOr [
+	self assert: self parserClass or equals: #('p' #('q' #(#('p' 'p') 'q')))
+]
+
+{ #category : 'testing-utilities' }
+PPLambdaParserTest >> testProductionAt [
+	self assert: (parser productionAt: #foo) isNil.
+	self assert: (parser productionAt: #foo ifAbsent: [ true ]).
+	
+	self assert: (parser productionAt: #start) notNil.
+	self assert: (parser productionAt: #start ifAbsent: [ true ]) notNil.
+	
+	self assert: (parser productionAt: #variable) notNil.
+	self assert: (parser productionAt: #variable ifAbsent: [ true ]) notNil
+]
+
+{ #category : 'testing-curch' }
+PPLambdaParserTest >> testTrue [
+	self assert: self parserClass true equals: #('x' #('y' 'x'))
+]
+
+{ #category : 'testing' }
+PPLambdaParserTest >> testVariable [
+	self assert: 'x' is: 'x'.
+	self assert: 'xy' is: 'xy'.
+	self assert: 'x12' is: 'x12'
+]

software/PetitTests/PPMappingTest.class.st

@@ -0,0 +1,83 @@
+Class {
+	#name : 'PPMappingTest',
+	#superclass : 'PPAbstractParserTest',
+	#category : 'PetitTests-Tests'
+}
+
+{ #category : 'as yet unclassified' }
+PPMappingTest >> testFoldLeft2 [
+	| parser |
+	parser := #any asParser star 
+		foldLeft: [ :a :b | Array with: a with: b ].
+
+	self assert: parser parse: #(a) to: #a.
+	self assert: parser parse: #(a b) to: #(a b).
+	self assert: parser parse: #(a b c) to: #((a b) c).
+	self assert: parser parse: #(a b c d) to: #(((a b) c) d).
+	self assert: parser parse: #(a b c d e) to: #((((a b) c) d) e)
+
+]
+
+{ #category : 'as yet unclassified' }
+PPMappingTest >> testFoldLeft3 [
+	| parser |
+	parser := #any asParser star 
+		foldLeft: [ :a :b :c | Array with: a with: b with: c ].
+
+	self assert: parser parse: #(a) to: #a.
+	self assert: parser parse: #(a b c) to: #(a b c).
+	self assert: parser parse: #(a b c d e) to: #((a b c) d e)
+
+]
+
+{ #category : 'as yet unclassified' }
+PPMappingTest >> testFoldRight2 [
+	| parser |
+	parser := #any asParser star 
+		foldRight: [ :a :b | Array with: a with: b ].
+
+	self assert: parser parse: #(a) to: #a.
+	self assert: parser parse: #(a b) to: #(a b).
+	self assert: parser parse: #(a b c) to: #(a (b c)).
+	self assert: parser parse: #(a b c d) to: #(a (b (c d))).
+	self assert: parser parse: #(a b c d e) to: #(a (b (c (d e))))
+]
+
+{ #category : 'as yet unclassified' }
+PPMappingTest >> testFoldRight3 [
+	| parser |
+	parser := #any asParser star 
+		foldRight: [ :a :b :c | Array with: a with: b with: c ].
+
+	self assert: parser parse: #(a) to: #a.
+	self assert: parser parse: #(a b c) to: #(a b c).
+	self assert: parser parse: #(a b c d e) to: #(a b (c d e))
+]
+
+{ #category : 'as yet unclassified' }
+PPMappingTest >> testMap1 [
+	| parser |
+	parser := #any asParser 
+		map: [ :a | Array with: a ].
+
+	self assert: parser parse: #(a) to: #(a)
+]
+
+{ #category : 'as yet unclassified' }
+PPMappingTest >> testMap2 [
+	| parser |
+	parser := (#any asParser , #any asParser) 
+		map: [ :a :b | Array with: b with: a ].
+
+	self assert: parser parse: #(a b) to: #(b a)
+]
+
+{ #category : 'as yet unclassified' }
+PPMappingTest >> testMap3 [
+	| parser |
+	parser := (#any asParser , #any asParser , #any asParser)
+		map: [ :a :b :c | Array with: c with: b with: a ].
+
+	self assert: parser parse: #(a b c) to: #(c b a)
+
+]

software/PetitTests/PPObjectTest.class.st

@@ -0,0 +1,74 @@
+Class {
+	#name : 'PPObjectTest',
+	#superclass : 'PPAbstractParserTest',
+	#category : 'PetitTests-Tests'
+}
+
+{ #category : 'parsers' }
+PPObjectTest >> integer [
+	^ PPPredicateObjectParser
+		on: [ :each | each isKindOf: Integer ]
+		message: 'integer expected'
+]
+
+{ #category : 'parsers' }
+PPObjectTest >> string [
+	^ PPPredicateObjectParser
+		on: [ :each | each isKindOf: String ]
+		message: 'string expected'
+]
+
+{ #category : 'testing-operators' }
+PPObjectTest >> testChoice [
+	| parser |
+	parser := self integer / self string.
+	self assert: parser parse: #(123) to: 123.
+	self assert: parser parse: #('abc') to: 'abc'
+]
+
+{ #category : 'testing-fancy' }
+PPObjectTest >> testFibonacci [
+	"This parser accepts fibonacci sequences with arbitrary start pairs."
+	
+	| parser |
+	parser := ((self integer , self integer) end ==> [ :pair | pair first + pair last ])
+		/ (self integer , (self integer , self integer) and >=> [ :stream :continuation |
+			| result |
+			result := continuation value.
+			(result isPetitFailure or: [ result first + result last first ~= result last last ])
+				ifFalse: [ parser parseOn: stream ]
+				ifTrue: [ PPFailure message: 'invalid fibonacci sequence' context: stream ] ]).
+	self assert: parser parse: #(1 1) to: 2.
+	self assert: parser parse: #(1 1 2) to: 3.
+	self assert: parser parse: #(1 1 2 3) to: 5.
+	self assert: parser parse: #(1 1 2 3 5) to: 8.
+	self assert: parser parse: #(1 1 2 3 5 8) to: 13.
+	self assert: parser parse: #(1 1 2 3 5 8 13) to: 21.
+	self assert: parser fail: #().
+	self assert: parser fail: #(1).
+	self assert: parser fail: #(1 2 3 4) end: 2
+	
+]
+
+{ #category : 'testing' }
+PPObjectTest >> testInteger [
+	self assert: self integer parse: #(123) to: 123.
+	self assert: self integer fail: #('abc')
+]
+
+{ #category : 'testing-operators' }
+PPObjectTest >> testSequence [
+	| parser |
+	parser := self integer , self string.
+	self assert: parser parse: #(123 'abc') to: #(123 'abc').
+	self assert: parser fail: #(123 456).
+	self assert: parser fail: #('abc' 'def').
+	self assert: parser fail: #('abc' 123)
+	
+]
+
+{ #category : 'testing' }
+PPObjectTest >> testString [
+	self assert: self string parse: #('abc') to: 'abc'.
+	self assert: self string fail: #(123)
+]

software/PetitTests/PPParserResource.class.st

@@ -0,0 +1,21 @@
+Class {
+	#name : 'PPParserResource',
+	#superclass : 'TestResource',
+	#instVars : [
+		'parsers'
+	],
+	#category : 'PetitTests-Core'
+}
+
+{ #category : 'accessing' }
+PPParserResource >> parserAt: aParserClass [
+	"Answer a cached instance of aParserClass."
+	
+	^ parsers at: aParserClass name ifAbsentPut: [ aParserClass new ]
+]
+
+{ #category : 'running' }
+PPParserResource >> setUp [
+	super setUp.
+	parsers := Dictionary new
+]

software/PetitTests/PPPredicateTest.class.st

@@ -0,0 +1,401 @@
+Class {
+	#name : 'PPPredicateTest',
+	#superclass : 'PPAbstractParserTest',
+	#category : 'PetitTests-Tests'
+}
+
+{ #category : 'utilities' }
+PPPredicateTest >> assertCharacterSets: aParser [
+	"Assert the character set of aParser does not overlap with the character set with the negated parser, and that they both cover the complete character space."
+
+	| positives negatives |
+	positives := self parsedCharacterSet: aParser.
+	negatives := self parsedCharacterSet: aParser negate.
+	self charactersDo: [ :char | 
+		| positive negative |
+		positive := positives includes: char.
+		negative := negatives includes: char.
+		self 
+			assert: ((positive and: [ negative not ])
+				or: [ positive not and: [ negative ] ])
+			description: char printString , ' should be in exactly one set' ]
+]
+
+{ #category : 'private' }
+PPPredicateTest >> charactersDo: aBlock [
+	1 to: 256 do: [ :index | aBlock value: (Character codePoint: index) ]
+]
+
+{ #category : 'utilities' }
+PPPredicateTest >> parsedCharacterSet: aParser [
+	| result |
+	result := WriteStream on: String new.
+	self charactersDo: [ :char |
+		(aParser matches: (char asString))
+			ifTrue: [ result nextPut: char ] ].
+	^ result contents
+]
+
+{ #category : 'testing-objects' }
+PPPredicateTest >> testAny [
+	| parser |
+	parser := #any asParser.
+	self assertCharacterSets: parser.
+	self assert: parser parse: ' ' to: $ .
+	self assert: parser parse: '1' to: $1.
+	self assert: parser parse: 'a' to: $a.
+	self assert: parser fail: ''
+]
+
+{ #category : 'testing-objects' }
+PPPredicateTest >> testAnyExceptAnyOf [
+	| parser |
+	parser := PPPredicateObjectParser anyExceptAnyOf: #($: $,).
+	self assertCharacterSets: parser.
+	self assert: parser parse: 'a' to: $a.
+	self assert: parser parse: 'z' to: $z.
+	self assert: parser fail: ':'.
+	self assert: parser fail: ','
+]
+
+{ #category : 'testing-objects' }
+PPPredicateTest >> testAnyOf [
+	| parser |
+	parser := PPPredicateObjectParser anyOf: #($a $z).
+	self assertCharacterSets: parser.
+	self assert: parser parse: 'a' to: $a.
+	self assert: parser parse: 'z' to: $z.
+	self assert: parser fail: 'x'
+]
+
+{ #category : 'testing-objects' }
+PPPredicateTest >> testBetweenAnd [
+	| parser |
+	parser := PPPredicateObjectParser between: $b and: $d.
+	self assertCharacterSets: parser.
+	self assert: parser fail: 'a'.
+	self assert: parser parse: 'b' to: $b.
+	self assert: parser parse: 'c' to: $c.
+	self assert: parser parse: 'd' to: $d.
+	self assert: parser fail: 'e'
+]
+
+{ #category : 'testing-chars' }
+PPPredicateTest >> testBlank [
+	| parser |
+	parser := #blank asParser.
+	self assertCharacterSets: parser.
+	self assert: parser parse: (String with: Character space) to: Character space.
+	self assert: parser parse: (String with: Character tab) to: Character tab.
+	self assert: parser fail: ''.
+	self assert: parser fail: '1'.
+	self assert: parser fail: (String with: Character cr)
+]
+
+{ #category : 'testing-chars' }
+PPPredicateTest >> testChar [
+	| parser |
+	parser := $* asParser.
+	self assertCharacterSets: parser.
+	self assert: parser parse: '*' to: $*.
+	self assert: parser parse: '**' to: $* end: 1.
+	self assert: parser fail: ''.
+	self assert: parser fail: '1'.
+	self assert: parser fail: 'a'
+]
+
+{ #category : 'testing-chars' }
+PPPredicateTest >> testCr [
+	| parser |
+	parser := #cr asParser.
+	self assertCharacterSets: parser.
+	self assert: parser parse: (String with: (Character codePoint: 13)) to: (Character codePoint: 13)
+]
+
+{ #category : 'testing-chars' }
+PPPredicateTest >> testDigit [
+	| parser |
+	parser := #digit asParser.
+	self assertCharacterSets: parser.
+	self assert: parser parse: '0' to: $0.
+	self assert: parser parse: '9' to: $9.
+	self assert: parser fail: ''.
+	self assert: parser fail: 'a'
+]
+
+{ #category : 'testing-chars' }
+PPPredicateTest >> testEndOfFile [
+	| parser |
+	parser := (#letter asParser / #blank asParser) star, #eof asParser.
+	
+	self assert: parser parse: 'lorem ipsum'.
+	
+	parser := #any asParser, #eof asParser, #any asParser star.
+	self assert: parser fail: 'a', Character cr asString, 'b'.
+	self assert: parser fail: Character cr asString , Character lf asString.
+	self assert: parser parse: 'a'.
+
+]
+
+{ #category : 'testing-chars' }
+PPPredicateTest >> testEndOfLine [
+	| cr crlf lf parser |
+	cr := Character cr asString.
+	crlf := Character cr asString , Character lf asString.
+	lf := Character lf asString.
+	parser := (#letter asParser / #blank asParser) star, #endOfLine asParser.
+	
+	self assert: parser parse: 'lorem ipsum'.
+	
+	parser := #any asParser, #endOfLine asParser, #any asParser star.
+	self assert: parser parse: 'a', cr, 'b'.
+	self assert: parser fail: crlf.
+	self assert: parser fail: 'lorem ipsum'.
+	
+	parser := #endOfLine asParser, #any asParser, #endOfLine asParser negate star, #endOfLine asParser.
+	self assert: parser parse: cr, 'lorem ipsum'.
+	self assert: parser parse: lf, 'lorem ipsum'.	
+	self assert: parser parse: crlf, 'lorem ipsum'.	
+	
+	self assert: parser parse: crlf.
+	self assert: parser parse: cr.
+	self assert: parser parse: lf.
+	
+	parser := #endOfLine asParser negate star, #endOfLine asParser, #any asParser star.
+	self assert: parser parse: crlf, 'lorem ipsum'.
+	self assert: parser parse: crlf.
+
+]
+
+{ #category : 'testing-objects' }
+PPPredicateTest >> testExpect [
+	| parser |
+	parser := PPPredicateObjectParser expect: $a.
+	self assertCharacterSets: parser.
+	self assert: parser parse: 'a' to: $a.
+	self assert: parser fail: 'b'.
+	self assert: parser fail: ''
+]
+
+{ #category : 'testing-chars' }
+PPPredicateTest >> testHex [
+	| parser |
+	parser := #hex asParser.
+	self assertCharacterSets: parser.
+	self assert: parser parse: '0' to: $0.
+	self assert: parser parse: '5' to: $5.
+	self assert: parser parse: '9' to: $9.
+	self assert: parser parse: 'A' to: $A.
+	self assert: parser parse: 'D' to: $D.
+	self assert: parser parse: 'F' to: $F.
+	self assert: parser parse: 'a' to: $a.
+	self assert: parser parse: 'e' to: $e.
+	self assert: parser parse: 'f' to: $f.
+	self assert: parser fail: ''.
+	self assert: parser fail: 'g'
+]
+
+{ #category : 'testing-chars' }
+PPPredicateTest >> testLetter [
+	| parser |
+	parser := #letter asParser.
+	self assertCharacterSets: parser.
+	self assert: parser parse: 'a' to: $a.
+	self assert: parser parse: 'Z' to: $Z.
+	self assert: parser fail: ''.
+	self assert: parser fail: '0'
+]
+
+{ #category : 'testing-chars' }
+PPPredicateTest >> testLf [
+	| parser |
+	parser := #lf asParser.
+	self assertCharacterSets: parser.
+	self assert: parser parse: (String with: Character lf) to: Character lf
+]
+
+{ #category : 'testing-chars' }
+PPPredicateTest >> testLowercase [
+	| parser |
+	parser := #lowercase asParser.
+	self assertCharacterSets: parser.
+	self assert: parser parse: 'a' to: $a.
+	self assert: parser parse: 'z' to: $z.
+	self assert: parser fail: ''.
+	self assert: parser fail: 'A'.
+	self assert: parser fail: '0'
+]
+
+{ #category : 'testing-chars' }
+PPPredicateTest >> testNewline [
+	| parser |
+	parser := #newline asParser.
+	self assertCharacterSets: parser.
+	self assert: parser parse: (String with: Character cr) to: Character cr.
+	self assert: parser parse: (String with: Character lf) to: Character lf.
+	self assert: parser fail: ' '
+]
+
+{ #category : 'testing' }
+PPPredicateTest >> testOnMessage [
+	| block parser |
+	block := [ :char | char = $* ].
+	parser := PPPredicateObjectParser on: block message: 'starlet'.
+	self assert: parser block equals: block.
+	self assert: parser message equals: 'starlet'.
+	self assertCharacterSets: parser.
+	self assert: parser parse: '*' to: $*.
+	self
+		assert: parser
+		parse: '**'
+		to: $*
+		end: 1.
+	self assert: parser fail: ''.
+	self assert: parser fail: '1'.
+	self assert: parser fail: 'a'
+]
+
+{ #category : 'testing-chars' }
+PPPredicateTest >> testPunctuation [
+	| parser |
+	parser := #punctuation asParser.
+	self assertCharacterSets: parser.
+	self assert: parser parse: '.' to: $..
+	self assert: parser parse: ',' to: $,.
+	self assert: parser fail: ''.
+	self assert: parser fail: 'a'.
+	self assert: parser fail: '1'
+]
+
+{ #category : 'testing-sequence' }
+PPPredicateTest >> testSequenceParser [
+	| parser |
+	parser := PPPredicateSequenceParser
+		on: [ :value | value first isUppercase ]
+		message: 'uppercase 3 letter words'
+		size: 3.
+	self assert: parser size equals: 3.
+	self assert: parser parse: 'Abc'.
+	self assert: parser parse: 'ABc'.
+	self assert: parser parse: 'ABC'.
+	self assert: parser fail: 'abc'.
+	self assert: parser fail: 'aBC'.
+	self assert: parser fail: 'Ab'.
+	parser := parser negate.
+	self assert: parser size equals: 3.
+	self assert: parser fail: 'Abc'.
+	self assert: parser fail: 'ABc'.
+	self assert: parser fail: 'ABC'.
+	self assert: parser parse: 'abc'.
+	self assert: parser parse: 'aBC'.
+	self assert: parser fail: 'Ab'
+]
+
+{ #category : 'testing-chars' }
+PPPredicateTest >> testSpace [
+	| parser |
+	parser := #space asParser.
+	self assertCharacterSets: parser.
+	self assert: parser parse: (String with: Character tab) to: Character tab.
+	self assert: parser parse: ' ' to: Character space.
+	self assert: parser fail: ''.
+	self assert: parser fail: 'a'
+]
+
+{ #category : 'testing-chars' }
+PPPredicateTest >> testStartOfLine [
+	| cr crlf lf parser |
+	cr := Character cr asString.
+	crlf := Character cr asString , Character lf asString.
+	lf := Character lf asString.
+	parser := #startOfLine asParser, #any asParser star.
+	
+	self assert: parser parse: 'lorem ipsum'.
+	
+	parser := #any asParser, #startOfLine asParser, #any asParser star.
+	self assert: parser fail: 'lorem ipsum'.
+	
+	parser := #startOfLine asParser, #any asParser, #startOfLine asParser, #any asParser star.
+	self assert: parser parse: cr, 'lorem ipsum'.
+	self assert: parser parse: lf, 'lorem ipsum'.	
+	self assert: parser fail: crlf, 'lorem ipsum'.	
+	
+	self assert: parser fail: crlf.
+	self assert: parser parse: cr.
+	self assert: parser parse: lf.
+	
+	parser := #startOfLine asParser, #any asParser, #any asParser, #startOfLine asParser, #any asParser star.
+	self assert: parser parse: crlf, 'lorem ipsum'.
+	self assert: parser parse: crlf.
+
+
+]
+
+{ #category : 'testing-chars' }
+PPPredicateTest >> testStartOfLogicalLine [
+	| parser |
+	parser := #startOfLogicalLine asParser, #any asParser star.
+	
+	self assert: parser parse: 'lorem'.
+	self assert: parser fail: ' lorem'.
+	
+	parser := #any asParser, #startOfLogicalLine asParser, #any asParser star.
+	self assert: parser fail: 'lorem'.
+	self assert: parser fail: '        lorem'.
+	self assert: parser parse: ' lorem'.
+	self assert: parser parse: '	lorem'.
+]
+
+{ #category : 'testing-chars' }
+PPPredicateTest >> testStartOfWord [
+	| parser |
+	parser := #startOfWord asParser, #word asParser plus.
+	
+	self assert: parser parse: 'lorem'.
+	
+	parser := #any asParser, #startOfWord asParser, #word asParser plus.
+	self assert: parser fail: 'lorem'.
+	self assert: parser fail: '1234'.
+	
+	self assert: parser parse: ' lorem'.	
+	self assert: parser parse: ' 123'.
+	self assert: parser parse: ')lorem'.
+	self assert: parser parse: ':lorem'.
+	
+	parser := #startOfWord asParser, #any asParser optional.
+	self assert: parser fail: ''.
+	self assert: parser parse: 'a'.
+	self assert: parser fail: '.'.
+]
+
+{ #category : 'testing-chars' }
+PPPredicateTest >> testTab [
+	| parser |
+	parser := #tab asParser.
+	self assertCharacterSets: parser.
+	self assert: parser parse: (String with: Character tab) to: Character tab
+]
+
+{ #category : 'testing-chars' }
+PPPredicateTest >> testUppercase [
+	| parser |
+	parser := #uppercase asParser.
+	self assertCharacterSets: parser.
+	self assert: parser parse: 'A' to: $A.
+	self assert: parser parse: 'Z' to: $Z.
+	self assert: parser fail: ''.
+	self assert: parser fail: 'a'.
+	self assert: parser fail: '0'
+]
+
+{ #category : 'testing-chars' }
+PPPredicateTest >> testWord [
+	| parser |
+	parser := #word asParser.
+	self assertCharacterSets: parser.
+	self assert: parser parse: 'a' to: $a.
+	self assert: parser parse: 'A' to: $A.
+	self assert: parser parse: '0' to: $0.
+	self assert: parser fail: ''.
+	self assert: parser fail: '-'
+]

software/PetitTests/PPScriptingTest.class.st

@@ -0,0 +1,110 @@
+"
+These are some simple demo-scripts of parser combinators for the compiler construction course.
+http://www.iam.unibe.ch/~scg/Teaching/CC/index.html
+"
+Class {
+	#name : 'PPScriptingTest',
+	#superclass : 'PPAbstractParserTest',
+	#category : 'PetitTests-Tests'
+}
+
+{ #category : 'examples' }
+PPScriptingTest >> expressionInterpreter [
+	"Same as #expressionInterpreter but with semantic actions."
+	
+	| mul prim add dec |
+	add := PPUnresolvedParser new.
+	mul := PPUnresolvedParser new.
+	prim := PPUnresolvedParser new.
+	dec := ($0 to: $9) asParser ==> [ :token | token codePoint - $0 codePoint ].
+	add def: ((mul , $+ asParser , add) ==> [ :nodes | (nodes at: 1) + (nodes at: 3) ])
+		/ mul.
+	mul def: ((prim , $* asParser , mul) ==> [ :nodes | (nodes at: 1) * (nodes at: 3) ])
+		/ prim.
+	prim def: (($( asParser , add , $) asParser) ==> [ :nodes | nodes at: 2 ])
+		/ dec.
+	^ add end
+]
+
+{ #category : 'examples' }
+PPScriptingTest >> expressionParser [
+	"Simple demo of scripting an expression parser."
+	
+	| mul prim add dec |
+	add := PPUnresolvedParser new.
+	mul := PPUnresolvedParser new.
+	prim := PPUnresolvedParser new.
+	dec := ($0 to: $9) asParser.
+	add def: (mul , $+ asParser , add)
+		/ mul.
+	mul def: (prim , $* asParser , mul)
+		/ prim.
+	prim def: ($( asParser , add , $) asParser)
+		/ dec.
+	^ add end
+]
+
+{ #category : 'examples' }
+PPScriptingTest >> straightLineParser [
+	| goal stm stmList id char dec exp expList mulExp primExp nonzero num lower upper |
+	goal := PPUnresolvedParser new.
+	stmList := PPUnresolvedParser new.
+	stm := PPUnresolvedParser new.
+	exp := PPUnresolvedParser new.
+	expList := PPUnresolvedParser new.
+	mulExp := PPUnresolvedParser new.
+	primExp := PPUnresolvedParser new.
+	
+	lower := ($a to: $z) asParser.
+	upper := ($A to: $Z) asParser.
+	char := lower / upper.
+	nonzero := ($1 to: $9) asParser.
+	dec := ($0 to: $9) asParser.
+	id := char, ( char / dec ) star.
+	num := $0 asParser / ( nonzero, dec star).
+
+	goal def: stmList end.
+	stmList def: stm , ( $; asParser, stm ) star.
+	stm def: ( id, ':=' asParser, exp )
+		/ ( 'print' asParser, $( asParser, expList, $) asParser ). 
+	exp def: mulExp, ( ( $+ asParser / $- asParser ), mulExp ) star.
+	expList def: exp, ( $, asParser, exp ) star.
+	mulExp def: primExp, ( ( $* asParser / $/ asParser ), primExp ) star.
+	primExp def: id
+		/ num
+		/ ( $( asParser, stmList, $, asParser, exp, $) asParser ).
+	^ goal
+
+]
+
+{ #category : 'tests' }
+PPScriptingTest >> testExpressionInterpreter [
+	self 
+		assert: self expressionInterpreter
+		parse: '2*(3+4)'
+		to: 14
+]
+
+{ #category : 'tests' }
+PPScriptingTest >> testExpressionParser [
+	self
+		assert: self expressionParser
+		parse: '2*(3+4)'
+		to: #($2 $* ($( ($3 $+ $4) $)))
+]
+
+{ #category : 'tests' }
+PPScriptingTest >> testSLassign [
+	
+	self assert: self straightLineParser
+		parse: 'abc:=1'
+		to: #(#($a #($b $c) ':=' #(#(#($1 #()) #()) #())) #())
+]
+
+{ #category : 'tests' }
+PPScriptingTest >> testSLprint [
+	self 
+		assert: self straightLineParser
+		parse: 'print(3,4)'
+		to: #(('print' $( ((($3 ()) ()) () (($, ((($4 ()) ()) ())))) $)) ())
+]

software/PetitTests/PPTokenTest.class.st

@@ -0,0 +1,128 @@
+Class {
+	#name : 'PPTokenTest',
+	#superclass : 'PPAbstractParserTest',
+	#category : 'PetitTests-Tests'
+}
+
+{ #category : 'accessing' }
+PPTokenTest >> identifier [
+	^ #word asParser plus token
+]
+
+{ #category : 'utilities' }
+PPTokenTest >> parse: aString using: aParser [
+	^ aParser parse: aString
+]
+
+{ #category : 'testing' }
+PPTokenTest >> testCollection [
+	| input result |
+	input := 'foo    '.
+	result := self parse: input using: self identifier.
+	self assert: result collection equals: input.
+	self assert: result collection == input
+]
+
+{ #category : 'testing-querying' }
+PPTokenTest >> testColumn [
+	| input parser result |
+	input := '1' , (String with: (Character codePoint: 13)) , '12' , (String with: (Character codePoint: 13) with: (Character codePoint: 10)) , '123'
+		, (String with: (Character codePoint: 10)) , '1234'.
+	parser := #any asParser token star.
+	result := parser parse: input.
+	result with: #(1 2 1 2 3 4 1 2 3 4 1 2 3 4) do: [ :token :line | self assert: token column equals: line ]
+]
+
+{ #category : 'testing-copying' }
+PPTokenTest >> testCopyFromTo [
+	| result other |
+	result := PPToken on: 'abc'.
+	other := result copyFrom: 2 to: 2.
+	self assert: other size equals: 1.
+	self assert: other start equals: 2.
+	self assert: other stop equals: 2.
+	self assert: other collection equals: result collection
+]
+
+{ #category : 'testing-comparing' }
+PPTokenTest >> testEquality [
+	| token1 token2 |
+	token1 := self parse: 'foo' using: self identifier.
+	token2 := self parse: 'foo' using: self identifier.
+	self deny: token1 == token2.
+	self assert: token1 equals: token2.
+	self assert: token1 hash equals: token2 hash
+]
+
+{ #category : 'testing' }
+PPTokenTest >> testInitialize [
+	PPToken initialize
+]
+
+{ #category : 'testing-values' }
+PPTokenTest >> testInputValue [
+	| input result |
+	input := 'foo'.
+	result := self parse: input using: self identifier.
+	self assert: result inputValue equals: input.
+	self deny: result inputValue == input
+]
+
+{ #category : 'testing-querying' }
+PPTokenTest >> testLine [
+	| input parser result |
+	input := '1' , (String with: (Character codePoint: 13)) , '12' , (String with: (Character codePoint: 13) with: (Character codePoint: 10)) , '123'
+		, (String with: (Character codePoint: 10)) , '1234'.
+	parser := #any asParser token star.
+	result := parser parse: input.
+	result with: #(1 1 2 2 2 2 3 3 3 3 4 4 4 4) do: [ :token :line | self assert: token line equals: line ]
+]
+
+{ #category : 'testing' }
+PPTokenTest >> testNew [
+	self should: [ PPToken new ] raise: Error.
+	
+]
+
+{ #category : 'testing-values' }
+PPTokenTest >> testParsedValue [
+	| input result |
+	input := 'foo'.
+	result := self parse: input using: self identifier.
+	self assert: result parsedValue equals: #($f $o $o)
+]
+
+{ #category : 'testing' }
+PPTokenTest >> testPrinting [
+	| result |
+	result := PPToken on: 'var'.
+	self assert: result printString includesSubstring: 'PPToken[1,3]'
+]
+
+{ #category : 'testing' }
+PPTokenTest >> testSize [
+	| result |
+	result := self parse: 'foo' using: self identifier.
+	self assert: result size equals: 3
+]
+
+{ #category : 'testing' }
+PPTokenTest >> testStart [
+	| result |
+	result := self parse: 'foo' using: self identifier.
+	self assert: result start equals: 1
+]
+
+{ #category : 'testing' }
+PPTokenTest >> testStop [
+	| result |
+	result := self parse: 'foo' using: self identifier.
+	self assert: result stop equals: 3
+]
+
+{ #category : 'testing' }
+PPTokenTest >> testValue [
+	| result |
+	result := PPToken on: 'var'.
+	self should: [ result value ] raise: Notification
+]

software/PetitTests/package.st

@@ -0,0 +1 @@
+Package { #name : 'PetitTests' }

software/petitcompiler/PEGFsa.class.st

@@ -0,0 +1,900 @@
+Class {
+	#name : 'PEGFsa',
+	#superclass : 'Object',
+	#instVars : [
+		'states',
+		'startState',
+		'name',
+		'distances',
+		'priorities'
+	],
+	#category : 'PetitCompiler-FSA'
+}
+
+{ #category : 'instance creation' }
+PEGFsa class >> new [
+	"return an initialized instance"
+
+	^ self basicNew initialize.
+]
+
+{ #category : 'comparing' }
+PEGFsa >> = anotherFsa [
+	"
+		Please note what the compare does. IMO nothing useful for now.
+		
+		For comparing if two FSA's are equivalent, use isIsomorphicTo:
+	"
+
+	(self == anotherFsa)  ifTrue: [ ^ true ].
+	(self class == anotherFsa class) ifFalse: [ ^ false ].
+	
+	(startState = anotherFsa startState) ifFalse: [ ^ false ].
+	(name = anotherFsa name) ifFalse: [ ^ false ].
+	
+	(states size = anotherFsa states size) ifFalse: [ ^ false ].
+	states do: [:s |
+		(anotherFsa states contains: [ :e | e = s ]) ifFalse: [ ^ false ].
+	].
+	^ true
+]
+
+{ #category : 'modifications' }
+PEGFsa >> addState: state [
+	self assert: (states includes: state) not.
+	states add: state
+]
+
+{ #category : 'modifications' }
+PEGFsa >> addTransitionFrom: fromState to: toState [ 
+	| transition |
+	self assert: (states includes: fromState).
+	self assert: (states includes: toState).
+	
+	transition := PEGFsaEpsilonTransition new 
+		destination: toState;
+		priority: 0;
+		yourself.
+		
+	fromState addTransition: transition.
+]
+
+{ #category : 'modifications' }
+PEGFsa >> addTransitionFrom: fromState to: toState on: character [
+	self addTransitionFrom: fromState to: toState on: character priority: 0
+]
+
+{ #category : 'modifications' }
+PEGFsa >> addTransitionFrom: fromState to: toState on: character priority: priority [
+	| transition |
+	transition := PEGFsaCharacterTransition new 
+		addCharacter: character;
+		destination: toState;
+		priority: priority;
+		yourself.
+		
+	fromState addTransition: transition
+]
+
+{ #category : 'modifications' }
+PEGFsa >> addTransitionFrom: fromState to: toState onCharacterSet: characterSet [
+	self addTransitionFrom: fromState to: toState onCharacterSet: characterSet priority: 0
+]
+
+{ #category : 'modifications' }
+PEGFsa >> addTransitionFrom: fromState to: toState onCharacterSet: characterSet priority: priority [
+	| transition |
+	transition := PEGFsaCharacterTransition new 
+		characterSet: characterSet;
+		destination: toState;
+		priority: priority;
+		yourself.
+
+	fromState addTransition: transition
+]
+
+{ #category : 'modifications' }
+PEGFsa >> addTransitionFrom: fromState to: toState onPredicate: block priority: priority [
+	| transition |
+	transition := PEGFsaPredicateTransition new 
+		predicate: block;
+		destination: toState;
+		priority: priority;
+		yourself.
+		
+	fromState addTransition: transition
+]
+
+{ #category : 'modifications' }
+PEGFsa >> addTransitionFrom: fromState to: toState priority: priority [
+	| transition |
+	"should not use minus priority epsilons any more"
+	self assert: (priority == 0).	
+	self assert: (states includes: fromState).
+	self assert: (states includes: toState).
+	
+	transition := PEGFsaEpsilonTransition new 
+		destination: toState;
+		priority: priority;
+		yourself.
+		
+	fromState addTransition: transition.
+]
+
+{ #category : 'modifications' }
+PEGFsa >> adopt: fsa [
+	states addAll: fsa reachableStates.
+]
+
+{ #category : 'accessing' }
+PEGFsa >> allTransitions [
+	^ self allTransitions: IdentitySet new
+]
+
+{ #category : 'accessing' }
+PEGFsa >> allTransitions: collection [
+	self states do: [ :s | collection addAll: s transitions  ].
+	^ collection
+]
+
+{ #category : 'printing' }
+PEGFsa >> asString [
+	| stream  |
+	stream := WriteStream on: ''.
+	
+	self topologicalOrder do: [ :state |
+		state printOn: stream.
+		stream nextPutAll: '> '.
+		
+		(self transitionsFor: state) do: [ :transition |
+			stream nextPut: (Character codePoint: 13).
+			stream nextPut: (Character codePoint: 9).
+			transition printOn: stream.
+		].
+		stream nextPut: (Character codePoint: 13).
+	].
+	
+"	stream nextPutAll: 'finals: '.
+	(states select: [:s | s isFinal ]) do: [:e | e printOn: stream ].
+	stream nextPut: (Character codePoint: 13).
+"
+	^ stream contents.
+]
+
+{ #category : 'analysis' }
+PEGFsa >> backTransitions [
+	|  transitionSet |
+	transitionSet := IdentitySet new.
+	self computeDistances.
+	
+	self backTransitionsFrom: startState openSet: IdentitySet new transitionSet: transitionSet.
+	^ transitionSet
+]
+
+{ #category : 'analysis' }
+PEGFsa >> backTransitionsFrom: state openSet: openSet transitionSet: transitionSet [
+	(openSet includes: state) ifTrue: [  
+		^ self
+	].
+	openSet add: state.
+	
+	state transitions do: [ :t | 
+		((openSet includes: t destination) and: [self is: state furtherThan: t destination]) ifTrue: [  
+			transitionSet add: t		
+		].
+		self backTransitionsFrom: t destination openSet: openSet copy transitionSet: transitionSet
+	]
+]
+
+{ #category : 'testing' }
+PEGFsa >> canHavePPCId [
+	^ true
+]
+
+{ #category : 'testing' }
+PEGFsa >> checkConsistency [
+	self assert: (states includes: startState).
+	
+	states do: [ :s | s transitions do: [ :t |
+		self assert: (states includes: t destination).
+	] ].
+	^ true
+]
+
+{ #category : 'testing' }
+PEGFsa >> checkFinalStatesPriorities [
+	self assert: (self finalStates allSatisfy: #hasPriority)
+]
+
+{ #category : 'testing' }
+PEGFsa >> checkSanity [
+	self checkConsistency.
+	self checkTransitionsIdentity.
+	self checkTransitionsPriority.
+	self checkFinalStatesPriorities.
+]
+
+{ #category : 'testing' }
+PEGFsa >> checkTransitionsIdentity [
+	| bag set |
+	bag := IdentityBag new.
+	set := IdentitySet new.
+	bag := self allTransitions: bag.
+	set := self allTransitions: set.	
+	
+	self assert: bag size == set size.
+]
+
+{ #category : 'testing' }
+PEGFsa >> checkTransitionsPriority [
+	self finalStates do: [ :fs |
+		fs isMultivalue ifFalse: [ 
+			fs transitions allSatisfy: [ :t | fs priority >= t priority ]
+		]
+	]
+]
+
+{ #category : 'transformations' }
+PEGFsa >> compact [
+	self error: 'deprecated?'
+]
+
+{ #category : 'analysis' }
+PEGFsa >> computeDistances [
+	| queue openSet |
+	distances := IdentityDictionary new.
+	queue := OrderedCollection with: startState.
+	openSet := IdentitySet new.
+
+	distances at: startState put: 0.
+	
+	[ queue isEmpty not ] whileTrue: [ 
+		| state |
+		state := queue removeFirst.
+		openSet add: state.
+		
+		state transitions do: [ :t |
+			(openSet includes: (t destination)) ifFalse: [ 
+				distances at: (t destination ) put: ((distances at: state) + 1).
+				queue addLast: (t destination)
+			]
+		]
+	].
+
+	^ distances
+]
+
+{ #category : 'modifications' }
+PEGFsa >> decreasePriority [
+	^ self decreasePriorityBy: 1
+]
+
+{ #category : 'modifications' }
+PEGFsa >> decreasePriorityBy: value [
+	self states select: [ :s | s hasPriority ] thenDo: [ :s |
+		s decreasePriorityBy: value.
+	].
+
+	self allTransitions do: [ :t |
+		t decreasePriorityBy: value
+	]
+]
+
+{ #category : 'ids' }
+PEGFsa >> defaultName [
+	^ #fsa
+]
+
+{ #category : 'modifications - determinization' }
+PEGFsa >> determinize [
+	^ PEGFsaSequenceDeterminizator new determinize: self.
+
+]
+
+{ #category : 'modifications - determinization' }
+PEGFsa >> determinize: joinDictionary [
+	self error: 'deprecated'.
+	
+	self removeEpsilons.
+	self removeUnreachableStates.
+	self removeLowPriorityTransitions.
+	self mergeTransitions.
+	
+	
+	states := self topologicalOrder asOrderedCollection.
+	
+	states do: [ :state |
+		state determinize: joinDictionary.
+	].
+	
+	states	 := startState reachableStates.
+
+	self removeUnreachableStates.
+	self removeLowPriorityTransitions.
+	self mergeTransitions.
+	
+
+]
+
+{ #category : 'modifications - determinization' }
+PEGFsa >> determinizeChoice [
+	^ PEGFsaChoiceDeterminizator new determinize: self.
+
+]
+
+{ #category : 'modifications - determinization' }
+PEGFsa >> determinizeStandard [
+	^ PEGFsaDeterminizator new determinize: self.
+
+]
+
+{ #category : 'analysis' }
+PEGFsa >> epsilonDestinationsFrom: state [
+	| openSet |
+	openSet := IdentitySet new.
+	self epsilonDestinationsFrom: state openSet: openSet.
+	^ openSet
+]
+
+{ #category : 'analysis' }
+PEGFsa >> epsilonDestinationsFrom: state openSet: openSet [
+	(openSet includes: state) ifTrue: [ 
+		^ self 
+	].
+
+	openSet add: state.
+	
+	((self transitionsFor: state) select: [ :t | t isEpsilon ]) do: [ :t |
+		self epsilonDestinationsFrom: t destination openSet: openSet
+	]
+	
+]
+
+{ #category : 'modifications' }
+PEGFsa >> finalState: state [
+	self assert: state isFinal not.
+	state final: true.
+	state priority: 0.
+]
+
+{ #category : 'analysis' }
+PEGFsa >> finalStates [
+	^ self states select: [ :s | s isFinal ]
+]
+
+{ #category : 'modifications' }
+PEGFsa >> fixFinalStatePriorities [
+	self finalStates do: [ :s |
+		s hasPriority ifFalse: [ s priority: 0 ]
+	]
+]
+
+{ #category : '*PetitCompiler-GUI' }
+PEGFsa >> gtGraphViewIn: composite [
+	<gtInspectorPresentationOrder: 0>
+	composite roassal2
+		title: 'Graph'; 
+		initializeView: [ RTMondrian new ];
+		painting: [ :view |
+			self viewGraphOn: view.	
+		].
+]
+
+{ #category : '*PetitCompiler-GUI' }
+PEGFsa >> gtStringViewIn: composite [
+	<gtInspectorPresentationOrder: 40>
+
+	composite text
+			title: 'Textual Representation';
+			display: [ :fsa | fsa asString  ]
+]
+
+{ #category : 'analysis' }
+PEGFsa >> hasDistinctRetvals [
+	| finalStates retvals |
+	finalStates := self finalStates.
+
+	(finalStates anySatisfy: [ :s | s isMultivalue  ]) ifTrue: [ ^ false ].
+	retvals := finalStates collect: [:s | s retval].
+
+		
+	(finalStates size == 1) ifTrue: [ ^ true ].
+
+
+	(retvals asSet size == 1) ifTrue: [ ^ true ].
+	"final states leads only to final states with the same retval"
+	(finalStates allSatisfy: [ :s | 
+		(self statesReachableFrom: s) allSatisfy: [ :rs | rs retval value isNil or: [ rs retval value == s retval value ] ]
+	]) ifTrue: [ ^ true ].
+	
+	^ false
+]
+
+{ #category : 'ids' }
+PEGFsa >> hasName [
+	^ name isNil not
+]
+
+{ #category : 'analysis' }
+PEGFsa >> hasNoRetvals [
+	^ self finalStates isEmpty
+
+
+]
+
+{ #category : 'comparing' }
+PEGFsa >> hash [
+	^ states hash bitXor: (startState hash bitXor: name hash)
+]
+
+{ #category : 'initialization' }
+PEGFsa >> initialize [
+	states := IdentitySet new.
+]
+
+{ #category : 'analysis' }
+PEGFsa >> is: state furtherThan: anotherState [
+
+	^ (distances at: state) >= (distances at: anotherState)
+]
+
+{ #category : 'analysis' }
+PEGFsa >> isBackTransition: t [
+	^ self backTransitions includes: t
+]
+
+{ #category : 'testing' }
+PEGFsa >> isDeterministic [
+	self reachableStates do: [ :state |
+		state transitionPairs do: [ :pair | 
+			((pair first intersection: pair second) includes: true) ifTrue: [ 					
+				^ false
+			] 
+		]
+	].
+	^ true
+]
+
+{ #category : 'comparing' }
+PEGFsa >> isIsomorphicTo: anotherFsa [
+	| topologicalOrder anotherTopologicalOrder  |
+	
+	"
+		Please not that this version of comparison is sensitive to the order
+		in which the transitions in state are ordered.
+	"
+	
+	topologicalOrder := self topologicalOrder.
+	anotherTopologicalOrder := anotherFsa topologicalOrder.
+	
+	topologicalOrder size == anotherTopologicalOrder size ifFalse: [ ^ false ].
+	
+	topologicalOrder with: anotherTopologicalOrder do: [ :s1 :s2 |
+		(s1 canBeIsomorphicTo: s2) ifFalse: [ ^ false ]
+	].
+	
+	^ true
+"	
+	transitions := topologicalOrder flatCollect: [ :s | s transitions ].
+	anotherTransitions := anotherTopologicalOrder flatCollect: [ :s | s transitions ].
+"	
+
+]
+
+{ #category : 'testing' }
+PEGFsa >> isReachableState: state [
+	^ self reachableStates includes: state
+]
+
+{ #category : 'testing' }
+PEGFsa >> isStartState: state [
+	^ startState == state
+]
+
+{ #category : 'testing' }
+PEGFsa >> isWithoutEpsilons [
+	self reachableStates do: [ :state | 
+		state transitions do: [ :t | 
+			t isEpsilon ifTrue: [ ^ false ]
+		]
+	].
+	^ true
+]
+
+{ #category : 'analysis' }
+PEGFsa >> isWithoutPriorities [
+	^ self states allSatisfy: [ :s | 
+		s hasPriority not or: [ 
+			s stateInfos allSatisfy: [ :i | i priority == 0 ]
+		] 
+	].
+]
+
+{ #category : 'transformations' }
+PEGFsa >> mergeTransitions [
+	|  |
+	self reachableStates do: [ :state |
+		state mergeTransitions.
+	]
+
+]
+
+{ #category : 'modifications' }
+PEGFsa >> minimize [
+	^ PEGFsaMinimizator new minimize: self
+]
+
+{ #category : 'accessing' }
+PEGFsa >> name [
+	^ name 
+]
+
+{ #category : 'accessing' }
+PEGFsa >> name: anObject [
+	
+	name := anObject
+]
+
+{ #category : 'analysis' }
+PEGFsa >> nonFinalStates [
+	^ self states reject: [ :s | s isFinal ]
+]
+
+{ #category : 'copying' }
+PEGFsa >> postCopy [
+	| map |
+	super postCopy.
+	
+	map := IdentityDictionary new.
+	states do: [ :s |
+		map at: s put: s copy.
+	].
+	
+	states := map values asIdentitySet.
+	startState isNil ifFalse: [ 
+		startState := map at: startState.
+	].
+	
+	states do: [ :s |
+		s transitions do: [:t |
+			t destination: (map at: t destination)
+		]
+	]
+]
+
+{ #category : 'ids' }
+PEGFsa >> prefix [
+	^ 'scan'
+]
+
+{ #category : 'analysis' }
+PEGFsa >> reachableStates [
+	^ self statesReachableFrom: startState
+]
+
+{ #category : 'modifications - epsilons' }
+PEGFsa >> removeEpsilonTransition: transition source: state [
+	^ self removeEpsilonTransition: transition source: state openSet: IdentitySet new
+]
+
+{ #category : 'modifications - epsilons' }
+PEGFsa >> removeEpsilonTransition: transition source: source openSet: openSet [
+	| destination |
+	(openSet includes: transition) ifTrue: [ self error: 'loop in epsilons?!' ].
+	openSet add: transition.
+	
+	destination := transition destination.
+	
+	"First Remove Recursively"
+	((self transitionsFor: destination ) select: [ :t | t isEpsilon  ]) do: [ :t |
+		self removeEpsilonTransition: t source: destination openSet: openSet
+	].
+
+	self assert: transition isEpsilon.
+	self assert: transition priority = 0.
+	
+	(destination transitions) do: [ :t |
+		source addTransition: (t copy)
+	].
+
+	source mergeInfo: destination into: source.
+
+	destination isFinal ifTrue: [ 
+		source final: true.
+		source retval: destination retval.
+	].
+
+	source removeTransition: transition.
+]
+
+{ #category : 'modifications - epsilons' }
+PEGFsa >> removeEpsilons [
+	"First, remove the negative values from epsilons"
+	self removeNegativeEpsilons.
+	
+	states do: [ :state |
+		self removeEpsilonsFor: state
+	]
+]
+
+{ #category : 'modifications - epsilons' }
+PEGFsa >> removeEpsilonsFor: state [
+	(self transitionsFor: state) copy do: [ :t |
+		(t isEpsilon and: [ t destination isStub not ]) ifTrue: [ 
+			self removeEpsilonTransition: t source: state
+		]
+	]
+]
+
+{ #category : 'modifications' }
+PEGFsa >> removeFinals [
+	self finalStates do: [ :s |
+		s final: false
+	]
+]
+
+{ #category : 'transformations' }
+PEGFsa >> removeLowPriorityTransitions [
+	states do: [ :state |
+		self removeLowPriorityTransitionsFor: state
+	]
+]
+
+{ #category : 'transformations' }
+PEGFsa >> removeLowPriorityTransitionsFor: state [
+	| transitions |
+	state hasPriority ifFalse: [ ^ self ].
+	state isFinal ifFalse: [ ^ self ].
+	"TODO JK: I can probably cut some transitions from multivalu as well"
+	state isMultivalue ifTrue: [ ^ self ].
+
+	transitions := state transitions copy.
+	transitions do: [ :t |
+		(t priority < state priority) ifTrue: [ 
+			state removeTransition: t
+		]
+	]
+]
+
+{ #category : 'modifications - epsilons' }
+PEGFsa >> removeNegativeEpsilonTransition: transition source: state [
+	^ self removeNegativeEpsilonTransition: transition source: state openSet: IdentitySet new
+]
+
+{ #category : 'modifications - epsilons' }
+PEGFsa >> removeNegativeEpsilonTransition: transition source: source openSet: openSet [
+	| destination |
+	(openSet includes: transition) ifTrue: [ self error: 'loop in epsilons?!' ].
+	openSet add: transition.
+	
+	destination := transition destination.
+	
+	"First Remove Recursively"
+	((self transitionsFor: destination ) select: [ :t | t isEpsilon  ]) do: [ :t |
+		self removeNegativeEpsilonTransition: t source: destination openSet: openSet
+	].
+	
+	"JK: Problem alert: if two different epsilons point to the same state,
+		it will decreas the state priority two times! I don't know how to handle
+		this situation properly and I make sure during FSA generation that there
+		are no two paths to one state (except for loops).
+	"
+	(self statesReachableFrom: destination) do: [ :s |
+		s decreasePriorityBy: transition priority abs.
+		s transitions do: [ :t | t decreasePriorityBy: transition priority abs  ]
+	].
+
+	transition priority: 0.
+
+]
+
+{ #category : 'modifications - epsilons' }
+PEGFsa >> removeNegativeEpsilons [
+	"
+		This will remove only negative values from epsilons, the epsilons itself will not
+		be removed!
+	"
+	states do: [ :state |
+		self removeNegativeEpsilonsFor: state
+	]
+]
+
+{ #category : 'modifications - epsilons' }
+PEGFsa >> removeNegativeEpsilonsFor: state [
+	(self transitionsFor: state) copy do: [ :t |
+		t isEpsilon ifTrue: [ 
+			self removeNegativeEpsilonTransition: t source: state
+		]
+	]
+]
+
+{ #category : 'modifications' }
+PEGFsa >> removePriorities [
+	self states select: [ :s| s hasPriority ] thenDo: [ :s |
+		s priority: 0
+	].
+
+	self allTransitions do: [ :t |
+		t priority: 0
+	]
+]
+
+{ #category : 'modifications' }
+PEGFsa >> removeState: state [
+	self assert: (states includes: state).
+	states remove: state.
+]
+
+{ #category : 'transformations' }
+PEGFsa >> removeUnreachableStates [
+	| reachable toRemove |
+	reachable := self reachableStates.
+	toRemove := OrderedCollection new.
+
+	states do: [ :s |
+		(reachable includes: s) ifFalse: [ 
+			toRemove add: s		
+		]
+	].
+
+	toRemove do: [ :s | states remove: s ]
+]
+
+{ #category : 'modifications' }
+PEGFsa >> replace: state with: anotherState [
+	| transitions  |
+	self assert: (state isKindOf: PEGFsaState).
+	self assert: (anotherState isKindOf: PEGFsaState).
+	
+	transitions := self allTransitions.
+
+	transitions do: [ :t |
+		(t destination == state) ifTrue: [ 
+			t destination: anotherState.
+		]
+	].
+
+	state == startState ifTrue: [ startState := anotherState ].
+	states remove: state.
+	states add: anotherState.
+]
+
+{ #category : 'modifications' }
+PEGFsa >> retval: returnValue [
+	self finalStates do: [ :s |
+		self assert: s retval isNil.
+		s retval: returnValue
+	]
+]
+
+{ #category : 'accessing' }
+PEGFsa >> retvals [
+	^ (self finalStates flatCollect: [ :e | e retvals collect: #value ]) asIdentitySet
+]
+
+{ #category : 'accessing' }
+PEGFsa >> startState [
+	self assert: (states includes: startState).
+	^ startState
+]
+
+{ #category : 'modifications' }
+PEGFsa >> startState: state [
+	self assert: (states includes: state).
+	
+	startState := state
+]
+
+{ #category : 'accessing' }
+PEGFsa >> stateNamed: stateName [
+	^ states detect: [ :e | e name = stateName ]
+]
+
+{ #category : 'analysis' }
+PEGFsa >> statePairs [
+	|  pairs ordered |
+	pairs := OrderedCollection new.
+	ordered := self states asOrderedCollection.
+	1 to: (ordered size - 1) do: [ :index1 |
+		(index1 + 1) to: ordered size do: [ :index2 |
+			pairs add: (PEGFsaPair with: (ordered at: index1) with: (ordered at: index2))
+ 		]
+	].
+
+	self assert: (pairs allSatisfy: [ :e | e class == PEGFsaPair ]).
+	^ pairs
+]
+
+{ #category : 'accessing' }
+PEGFsa >> states [
+	^ states
+]
+
+{ #category : 'accessing' }
+PEGFsa >> states: whatever [
+	states := whatever
+]
+
+{ #category : 'analysis' }
+PEGFsa >> statesReachableFrom: state [
+	| openSet |
+	self assert: state isNil not.
+	
+	openSet := IdentitySet new.
+	self statesReachableFrom: state openSet: openSet.
+	^ openSet
+]
+
+{ #category : 'analysis' }
+PEGFsa >> statesReachableFrom: state openSet: openSet [
+	(openSet contains: [:e | e == state]) ifTrue: [ 
+		^ self 
+	].
+
+	openSet add: state.
+	
+	(self transitionsFor: state) do: [ :t |
+		self statesReachableFrom: t destination openSet: openSet
+	]
+	
+
+]
+
+{ #category : 'ids' }
+PEGFsa >> suffix [
+	^ nil
+]
+
+{ #category : 'analysis' }
+PEGFsa >> topologicalOrder [
+	| collection |
+	collection := OrderedCollection new.
+	
+	self statesReachableFrom: startState openSet: collection.
+	^ collection
+]
+
+{ #category : 'accessing' }
+PEGFsa >> transitionFrom: from to: to [
+	^ from transitions detect: [ :t | t destination = to ]
+]
+
+{ #category : 'accessing' }
+PEGFsa >> transitionsFor: state [
+	self assert: (states includes: state).
+	^ state transitions
+]
+
+{ #category : '*PetitCompiler-GUI' }
+PEGFsa >> viewGraphOn: b [
+	b shape circle size: 50.
+	b shape color: Color gray muchLighter muchLighter.
+	b shape withText: #gtName.
+	b nodes: (self nonFinalStates).
+
+	b shape circle size: 50.
+	b shape color: Color gray muchLighter.
+	b shape withText: #gtName.
+	b nodes: (self finalStates).
+
+	b shape arrowedLine.
+	b edges 
+		connectToAll: [ :state | 
+			state transitions 	select: [:t | (self isBackTransition:t)  not] 
+									thenCollect: #destination ]
+		labelled: [ :t | (self transitionFrom: t key to: t value) gtName  ].		
+
+	b shape arrowedLine.
+	b shape color: Color red.
+	b edges 
+		connectToAll: [ :state | 
+			state transitions 	select: [:t | (self isBackTransition: t) ] 
+								thenCollect: #destination ]
+		labelled: [ :t | (self transitionFrom: t key to: t value) gtName  ].
+
+
+	b layout horizontalTree  .
+	b layout layout horizontalGap: 30.
+
+	^ b
+]

software/petitcompiler/PEGFsa.extension.st

@@ -0,0 +1,55 @@
+Extension { #name : 'PEGFsa' }
+
+{ #category : '*PetitCompiler-GUI' }
+PEGFsa >> gtGraphViewIn: composite [
+	<gtInspectorPresentationOrder: 0>
+	composite roassal2
+		title: 'Graph'; 
+		initializeView: [ RTMondrian new ];
+		painting: [ :view |
+			self viewGraphOn: view.	
+		].
+]
+
+{ #category : '*PetitCompiler-GUI' }
+PEGFsa >> gtStringViewIn: composite [
+	<gtInspectorPresentationOrder: 40>
+
+	composite text
+			title: 'Textual Representation';
+			display: [ :fsa | fsa asString  ]
+]
+
+{ #category : '*PetitCompiler-GUI' }
+PEGFsa >> viewGraphOn: b [
+	b shape circle size: 50.
+	b shape color: Color gray muchLighter muchLighter.
+	b shape withText: #gtName.
+	b nodes: (self nonFinalStates).
+
+	b shape circle size: 50.
+	b shape color: Color gray muchLighter.
+	b shape withText: #gtName.
+	b nodes: (self finalStates).
+
+	b shape arrowedLine.
+	b edges 
+		connectToAll: [ :state | 
+			state transitions 	select: [:t | (self isBackTransition:t)  not] 
+									thenCollect: #destination ]
+		labelled: [ :t | (self transitionFrom: t key to: t value) gtName  ].		
+
+	b shape arrowedLine.
+	b shape color: Color red.
+	b edges 
+		connectToAll: [ :state | 
+			state transitions 	select: [:t | (self isBackTransition: t) ] 
+								thenCollect: #destination ]
+		labelled: [ :t | (self transitionFrom: t key to: t value) gtName  ].
+
+
+	b layout horizontalTree  .
+	b layout layout horizontalGap: 30.
+
+	^ b
+]

software/petitcompiler/PEGFsaAbstractDeterminizator.class.st

@@ -0,0 +1,165 @@
+Class {
+	#name : 'PEGFsaAbstractDeterminizator',
+	#superclass : 'Object',
+	#instVars : [
+		'fsa',
+		'joinDictionary'
+	],
+	#category : 'PetitCompiler-FSA'
+}
+
+{ #category : 'as yet unclassified' }
+PEGFsaAbstractDeterminizator class >> new [
+	^ self basicNew initialize
+]
+
+{ #category : 'determinization' }
+PEGFsaAbstractDeterminizator >> determinize [
+	| states |
+"	fsa checkSanity."
+	fsa removeEpsilons.
+	fsa removeUnreachableStates.
+	fsa mergeTransitions.
+	
+	states := fsa topologicalOrder asOrderedCollection.
+	states do: [ :state |
+		self determinizeState: state
+	].
+
+	fsa states:	fsa startState reachableStates.
+	
+	fsa removeUnreachableStates.
+	fsa mergeTransitions.
+]
+
+{ #category : 'determinization' }
+PEGFsaAbstractDeterminizator >> determinize: anFsa [
+	fsa := anFsa.
+	joinDictionary := Dictionary new.
+	
+	self determinize.
+	^ fsa
+]
+
+{ #category : 'determinization' }
+PEGFsaAbstractDeterminizator >> determinizeOverlap: t1 second: t2 state: state [
+	|  t1Prime t2Prime tIntersection |
+	self assert: (state transitions includes: t1).
+	self assert: (state transitions includes: t2).
+	
+	tIntersection := self joinTransition: t1 with: t2.
+
+	t1Prime := PEGFsaCharacterTransition new
+					destination: t1 destination;
+					characterSet: (t1 complement: t2);
+					yourself.
+	t2Prime := PEGFsaCharacterTransition new
+					destination: t2 destination;
+					characterSet: (t2 complement: t1);
+					yourself.					
+									
+								
+	state removeTransition: t1.
+	state removeTransition: t2.
+	
+	tIntersection isEmpty ifFalse: [ state addTransition: tIntersection  ].
+	t1Prime isEmpty ifFalse: [ state addTransition: t1Prime ].
+	t2Prime isEmpty ifFalse: [ state addTransition: t2Prime ].
+]
+
+{ #category : 'determinization' }
+PEGFsaAbstractDeterminizator >> determinizeState: state [
+	| pairs |
+
+	pairs := state transitionPairs asOrderedCollection.
+
+	[pairs isEmpty] whileFalse: [ 
+		| pair |
+		
+		(joinDictionary size > 100) ifTrue: [ self error: 'Oh man, this is really big FSA. Are you sure you want to continue?' ].
+		
+		pair := pairs removeFirst.
+		self assert:((pair first destination = pair second destination) not 
+					or: [pair first isPredicateTransition not 
+					or: [pair second isPredicateTransition not ] ]).
+				
+		self assert: (pair contains: #isEpsilon) not.		
+				
+		(pair first overlapsWith: pair second) ifTrue: [ 
+			self determinizeOverlap: pair first second: pair second state: state.
+			"recompute pairs after the determinization"
+			pairs := state transitionPairs asOrderedCollection.
+		]
+	].
+]
+
+{ #category : 'initialization' }
+PEGFsaAbstractDeterminizator >> initialize [
+	super initialize.
+	joinDictionary := Dictionary new
+]
+
+{ #category : 'accessing - keys' }
+PEGFsaAbstractDeterminizator >> joinKey: key with: anotherKey [
+	^ Set new
+		addAll: key;
+		addAll: anotherKey;
+		yourself.
+
+]
+
+{ #category : 'joining' }
+PEGFsaAbstractDeterminizator >> joinName: state with: anotherState into: newState [
+	newState name: state name asString, '_', anotherState name asString.
+
+]
+
+{ #category : 'joining' }
+PEGFsaAbstractDeterminizator >> joinState: state with: anotherState [
+	| key newState |
+	key := self keyFor: state and: anotherState.
+	(joinDictionary includesKey: key) ifTrue: [ ^ joinDictionary at: key ].
+	
+	newState := PEGFsaState new.
+	joinDictionary at: key put: newState.
+
+	self joinRetval: state with: anotherState into: newState.
+	self joinInfo: state with: anotherState into: newState.
+	self joinName: state with: anotherState into: newState.
+	self joinTransitions: state with: anotherState into: newState.	
+
+	self determinizeState: newState.
+	
+	self assert: ((joinDictionary at: key) == newState).
+	^ newState
+]
+
+{ #category : 'joining' }
+PEGFsaAbstractDeterminizator >> joinTransition: t1 with: t2 [
+	| newDestination newTransition |
+	self assert: t1 isCharacterTransition.
+	self assert: t2 isCharacterTransition.
+	
+	newDestination := self joinState: t1 destination with: t2 destination.
+	
+	newTransition := PEGFsaCharacterTransition new.
+	newTransition destination: newDestination.
+	newTransition characterSet: (t1 intersection: t2).
+	newTransition priority: (t1 priority max: t2 priority).
+	
+	^ newTransition 
+]
+
+{ #category : 'accessing - keys' }
+PEGFsaAbstractDeterminizator >> keyFor: state [
+	^ joinDictionary keyAtIdentityValue: state ifAbsent: [ Set with: state ]
+]
+
+{ #category : 'accessing - keys' }
+PEGFsaAbstractDeterminizator >> keyFor: state and: anotherState [
+	| key anotherKey |
+	key := self keyFor: state.
+	anotherKey := self keyFor: anotherState.
+	
+	^ self joinKey: key with: anotherKey
+]

software/petitcompiler/PEGFsaChoiceDeterminizator.class.st

@@ -0,0 +1,76 @@
+Class {
+	#name : 'PEGFsaChoiceDeterminizator',
+	#superclass : 'PEGFsaAbstractDeterminizator',
+	#category : 'PetitCompiler-FSA'
+}
+
+{ #category : 'determinization' }
+PEGFsaChoiceDeterminizator >> determinize [
+	super determinize.
+
+	fsa removeLowPriorityTransitions.
+	fsa removeUnreachableStates.
+	fsa removePriorities.
+]
+
+{ #category : 'joining' }
+PEGFsaChoiceDeterminizator >> joinInfo: info with: anotherInfo into: newInfo [
+	"Merging into the failure"
+	(info isFsaFailure and: [anotherInfo isFsaFailure not]) ifTrue: [  
+		newInfo final: anotherInfo isFinal.
+		newInfo priority: anotherInfo priority.
+		newInfo failure: false.
+		^ self
+	].
+	
+	(anotherInfo isFsaFailure and: [info isFsaFailure not]) ifTrue: [  
+		newInfo final: info isFinal.
+		newInfo priority: (anotherInfo priority max: info priority).
+		newInfo failure: false.
+		^ self
+	].
+	
+	(info hasEqualPriorityTo: anotherInfo) ifTrue: [ 
+		newInfo final: (info isFinal or: [ anotherInfo isFinal ]).
+		newInfo failure: (info isFsaFailure or: [anotherInfo isFailure]).
+		newInfo priority: info priority.	
+		^ self
+	].
+	
+	(info hasHigherPriorityThan: anotherInfo) ifTrue: [ 
+ 		newInfo priority: info priority.	
+		newInfo failure: info isFsaFailure.
+		newInfo final: info isFinal.
+		^ self
+	].
+
+	newInfo priority: anotherInfo priority.
+	newInfo failure: anotherInfo isFsaFailure.
+	newInfo final: anotherInfo isFinal.
+
+]
+
+{ #category : 'joining' }
+PEGFsaChoiceDeterminizator >> joinRetval: state with: anotherState into: newState [
+	"Different retvals cannot merge their info"
+	self assert: (state hasDifferentRetvalThan: anotherState) not. 
+	self assert: state retval == anotherState retval.
+]
+
+{ #category : 'joining' }
+PEGFsaChoiceDeterminizator >> joinState: state with: anotherState [
+	self assert: state isMultivalue not.
+	self assert: anotherState isMultivalue not.
+
+	^ super joinState: state with: anotherState
+]
+
+{ #category : 'joining' }
+PEGFsaChoiceDeterminizator >> joinTransitions: state with: anotherState into: newState [
+	self assert: newState isMultivalue not.
+	
+	newState transitions addAll: (state transitions collect: #copy).
+	newState transitions addAll: (anotherState transitions collect: #copy).
+	newState mergeTransitions.
+
+]

software/petitcompiler/PEGFsaDeterminizator.class.st

@@ -0,0 +1,58 @@
+Class {
+	#name : 'PEGFsaDeterminizator',
+	#superclass : 'PEGFsaAbstractDeterminizator',
+	#category : 'PetitCompiler-FSA'
+}
+
+{ #category : 'checking' }
+PEGFsaDeterminizator >> checkPriorities [
+	self assert: ((fsa states select: [ :s | s hasPriority  ]) allSatisfy: [ :s | s priority == 0 ]).
+	self assert: (fsa allTransitions allSatisfy: [ :s | s priority == 0 ]).
+]
+
+{ #category : 'determinization' }
+PEGFsaDeterminizator >> determinize [
+	self checkPriorities.
+	super determinize.	
+]
+
+{ #category : 'joining' }
+PEGFsaDeterminizator >> joinInfo: info with: anotherInfo into: newInfo [
+	"nothing to do"
+]
+
+{ #category : 'joining' }
+PEGFsaDeterminizator >> joinRetval: state with: anotherState into: newState [
+	"Different retvals cannot merge their info"
+
+	state retvalsAndInfosDo: [:retval :info |
+		retval isNil ifFalse: [ 
+			newState addInfo: info for: retval.
+		]
+	].
+
+	anotherState retvalsAndInfosDo: [:retval :info |
+		retval isNil ifFalse: [ 
+			self assert: (newState retvals includes: retval) not.
+			newState addInfo: info for: retval.
+		]
+	].
+
+
+]
+
+{ #category : 'joining' }
+PEGFsaDeterminizator >> joinState: state with: anotherState [
+	self assert: state hasZeroPriorityOnly.
+	self assert: anotherState hasZeroPriorityOnly.
+	
+	^ super joinState: state with: anotherState
+]
+
+{ #category : 'joining' }
+PEGFsaDeterminizator >> joinTransitions: state with: anotherState into: newState [
+	newState transitions addAll: (state transitions collect: #copy).
+	newState transitions addAll: (anotherState transitions collect: #copy).
+	^ self
+
+]

software/petitcompiler/PEGFsaFailure.class.st

@@ -0,0 +1,59 @@
+Class {
+	#name : 'PEGFsaFailure',
+	#superclass : 'Object',
+	#instVars : [
+		'retval'
+	],
+	#classInstVars : [
+		'Instance'
+	],
+	#category : 'PetitCompiler-FSA'
+}
+
+{ #category : 'as yet unclassified' }
+PEGFsaFailure class >> on: retval [
+	^ (self new)
+		retval: retval;
+		yourself
+]
+
+{ #category : 'comparing' }
+PEGFsaFailure >> = anotherFailure [
+	(self == anotherFailure) ifTrue: [ ^ true ].
+	self class == anotherFailure class ifFalse: [ ^ false ].
+	
+	^ (self retval == anotherFailure retval)
+]
+
+{ #category : 'comparing' }
+PEGFsaFailure >> hash [
+	^ self retval hash
+]
+
+{ #category : 'testing' }
+PEGFsaFailure >> isFsaFailure [
+	^ true
+]
+
+{ #category : 'printing' }
+PEGFsaFailure >> printOn: aStream [
+	super printOn: aStream.
+	aStream nextPut: $(.
+	retval printOn: aStream.
+	aStream nextPut: $).
+]
+
+{ #category : 'accessing' }
+PEGFsaFailure >> retval [
+	^ retval
+]
+
+{ #category : 'accessing' }
+PEGFsaFailure >> retval: anObject [
+	retval := anObject
+]
+
+{ #category : 'accessing' }
+PEGFsaFailure >> value [
+	^ retval
+]

software/petitcompiler/PPActionParser.extension.st

@@ -0,0 +1,12 @@
+Extension { #name : 'PPActionParser' }
+
+{ #category : '*petitcompiler' }
+PPActionParser >> asCompilerNode [
+	^ PPCActionNode new
+		name: self name;
+		block: block;
+		child: parser;
+		properties: properties;
+		parser: self;
+		yourself
+]

software/petitcompiler/PPAndParser.extension.st

@@ -0,0 +1,9 @@
+Extension { #name : 'PPAndParser' }
+
+{ #category : '*petitcompiler' }
+PPAndParser >> asCompilerNode [
+	^ PPCAndNode new
+		name: self name;
+		child: parser;
+		yourself
+]

software/petitcompiler/PPCASTUtilities.class.st

@@ -0,0 +1,196 @@
+Class {
+	#name : 'PPCASTUtilities',
+	#superclass : 'Object',
+	#category : 'PetitCompiler-Support'
+}
+
+{ #category : 'variables' }
+PPCASTUtilities >> allClassVariableNames: aClass [
+	| variables cls |
+	variables := Set new.
+	cls := aClass.
+	
+	[ cls notNil ] whileTrue:[ 
+		variables addAll: (cls isMeta ifFalse: [ cls classVariables ] ifTrue: [ #() ]).
+		cls := cls superclass.
+	].
+
+	^ variables
+]
+
+{ #category : 'variables' }
+PPCASTUtilities >> allInstanceVariableNames: aClass [
+	| variables cls |
+	variables := Set new.
+	cls := aClass.
+	
+	[ cls notNil ] whileTrue:[ 
+"		cls instanceVariables notNil ifTrue:[
+"			variables addAll: cls instanceVariables.
+"		]. "
+		cls := cls superclass.
+	].
+
+	^ variables
+]
+
+{ #category : 'checks' }
+PPCASTUtilities >> checkNodeIsFunctional: anRBNode inClass: aClass options: aPPCCompilationOptions [
+	"Check whether the given node is purely functional or not. 
+	 If no, raise an erorr. If not, this method is noop.
+
+	 A block is purely functional if and only if:
+	   (i) it does not refer to any instance or class variable or non-local variable
+	  (ii) all self-sends within the block are to 'purely-functional' methods
+		   (transitively)
+	 (iii) contains no super-sends.
+	"
+	self checkNodeVariables: anRBNode inClass: aClass.
+	
+	self withAllSuperNodesOf: anRBNode do: [ :node | 
+		PPCCompilationError new signal: 'code not functional:  contains a super-send. See https://bitbucket.org/janvrany/stx-goodies-petitparser/wiki/Limitations'.
+		^ self
+	].
+
+	self withAllMessageNodesOf: anRBNode sentToSelfDo:[:node |
+		| method |
+		
+		method := aClass lookupSelector: node selector.
+		method isNil ifTrue:[
+			PPCCompilationError new signal: 'code not functional:  contains self-send to non-existent method. See https://bitbucket.org/janvrany/stx-goodies-petitparser/wiki/Limitations'.  
+			^ self
+		].
+		aPPCCompilationOptions allowProperties ifTrue:[
+		"Accessing properties are explicitly allowed"
+			(self propertiesSelectors includes: node selector) ifTrue:[
+				method methodClass == PPParser ifTrue:[
+					^self.
+				].
+				(method methodClass inheritsFrom: PPParser) ifTrue:[
+						PPCCompilationWarning new signal: 'Class ', method methodClass name, ' overrides PPParser>>', node selector storeString.
+					^self.
+				].
+			].
+		].
+		(anRBNode isMethod and: [ anRBNode selector = node selector ]) ifFalse: [
+			self checkNodeIsFunctional: method parseTree inClass: aClass options: aPPCCompilationOptions.
+		] "ifTrue: [ 'method is calling itself ... recursion is happening' ] "
+	].      
+
+
+	"Created: / 27-07-2015 / 12:15:28 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+	"Modified: / 08-09-2015 / 02:48:55 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+]
+
+{ #category : 'checks' }
+PPCASTUtilities >> checkNodeVariables: anRBNode inClass: aClass [
+	" does node refer to any instance or class variable or non-local variable ?"
+	| allDefinedVarNames allInstVarNames allClassVarNames |
+
+	allDefinedVarNames := anRBNode allDefinedVariables.
+	allDefinedVarNames add: 'thisContext'.
+	allInstVarNames := self allInstanceVariableNames: aClass.
+	allClassVarNames := self allClassVariableNames: aClass.
+
+	self withAllVariableNodesOf: anRBNode  do: [ :node | 
+		(allDefinedVarNames includes: node name) ifFalse:[ 
+			(allInstVarNames includes: node name) ifTrue:[
+				PPCCompilationError new signal: 'code not functional: refers to an instance variable named `',node name,'`. See https://bitbucket.org/janvrany/stx-goodies-petitparser/wiki/Limitations'.
+				^ self.
+			].
+			(allClassVarNames includes: node name) ifTrue:[
+				PPCCompilationError new signal: 'code not functional:  refers to a class variable named `',node name,'`. See https://bitbucket.org/janvrany/stx-goodies-petitparser/wiki/Limitations'.
+				^ self.
+			].
+			(Smalltalk includesKey: node name asSymbol) ifFalse:[ 
+				PPCCompilationError new signal: 'code not functional:  refers to an unknown variable named `',node name,'`. See https://bitbucket.org/janvrany/stx-goodies-petitparser/wiki/Limitations'.
+				^ self.                    
+			].
+		]
+	].
+]
+
+{ #category : 'accessing' }
+PPCASTUtilities >> propertiesSelectors [
+	 ^ #(
+				hasProperty:
+				propertyAt:
+				propertyAt:ifAbsent:
+				propertyAt:ifAbsentPut:
+				propertyAt:put:
+				removeProperty:
+				removeProperty:ifAbsent:		
+			)
+]
+
+{ #category : 'enumerating' }
+PPCASTUtilities >> withAllMessageNodesOf: anRBProgramNode do: aBlock [
+	"Enumerate all chilren of `anRBProgramNode` (including itself)
+	 and evaluate `aBlock` for each message node."
+
+	self withAllNodesOf: anRBProgramNode suchThat: [ :node | node isMessage ] do: aBlock.
+
+	"Created: / 18-06-2015 / 22:02:43 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+	"Modified (comment): / 27-07-2015 / 11:26:29 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+]
+
+{ #category : 'enumerating' }
+PPCASTUtilities >> withAllMessageNodesOf: anRBProgramNode sentToSelfDo: aBlock [
+	"Enumerate all chilren of `anRBProgramNode` (including itself)
+	 and evaluate `aBlock` for each message node which sends a message
+	 to self (i.e., for self-sends)."
+
+	self withAllNodesOf: anRBProgramNode suchThat: [ :node | node isMessage and:[node receiver isSelf ] ] do: aBlock.
+
+	"Created: / 27-07-2015 / 14:41:30 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+]
+
+{ #category : 'enumerating' }
+PPCASTUtilities >> withAllNodesOf: node suchThat: predicate do: action [
+	"Enumerate all chilren of `node` (including itself)
+	 and evaluate `aBlock` for each node for which `predicate` returns true."
+
+	(predicate value: node) ifTrue:[ 
+		action value: node.
+	].
+	node children do:[:each | 
+		self withAllNodesOf: each suchThat: predicate do: action
+	].
+
+	"Created: / 18-06-2015 / 22:02:43 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+	"Modified (comment): / 27-07-2015 / 11:26:46 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+]
+
+{ #category : 'enumerating' }
+PPCASTUtilities >> withAllSelfNodesOf: anRBProgramNode do: aBlock [
+	"Enumerate all chilren of `anRBProgramNode` (including itself)
+	 and evaluate `aBlock` for each `self` node."
+
+	self withAllNodesOf: anRBProgramNode suchThat: [ :node | node isSelf ] do: aBlock.
+
+	"Created: / 18-06-2015 / 22:02:43 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+	"Modified (comment): / 27-07-2015 / 11:26:52 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+]
+
+{ #category : 'enumerating' }
+PPCASTUtilities >> withAllSuperNodesOf: anRBProgramNode do: aBlock [
+	"Enumerate all chilren of `anRBProgramNode` (including itself)
+	 and evaluate `aBlock` for each `super` node."
+
+	self withAllNodesOf: anRBProgramNode suchThat: [ :node | node isSuper ] do: aBlock.
+
+	"Created: / 27-07-2015 / 14:42:28 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+]
+
+{ #category : 'enumerating' }
+PPCASTUtilities >> withAllVariableNodesOf: anRBProgramNode do: aBlock [
+	"Enumerate all chilren of `anRBProgramNode` (including itself)
+	 and evaluate `aBlock` for each variable node.
+	 This is a replacement for Smalltalk/X's RBProgramNode>>variableNodesDo:
+	 which is not present in Pharo"
+
+	self withAllNodesOf: anRBProgramNode suchThat: [ :node | node isVariable and:[node isSelf not and:[node isSuper not]]] do: aBlock.
+
+	"Created: / 18-06-2015 / 22:02:43 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+	"Modified (comment): / 27-07-2015 / 11:27:00 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+]

software/petitcompiler/PPCCheckingVisitor.class.st

@@ -0,0 +1,22 @@
+Class {
+	#name : 'PPCCheckingVisitor',
+	#superclass : 'PPCPassVisitor',
+	#category : 'PetitCompiler-Visitors'
+}
+
+{ #category : 'hooks' }
+PPCCheckingVisitor >> beforeAccept: node [
+	| message |
+
+	message := node check.
+	message notNil ifTrue:[ 
+		((message beginsWith: 'WARNING')) ifTrue: [ 
+			context options debug ifTrue: [ Transcript cr; show: message. ].
+		] ifFalse: [ 
+			self error: message 
+		].       
+	].
+	^ node
+
+	"Created: / 07-09-2015 / 13:05:59 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+]

software/petitcompiler/PPCChoiceOptimizationVisitor.class.st

@@ -0,0 +1,34 @@
+Class {
+	#name : 'PPCChoiceOptimizationVisitor',
+	#superclass : 'PPCRewritingVisitor',
+	#category : 'PetitCompiler-Visitors'
+}
+
+{ #category : 'visiting' }
+PPCChoiceOptimizationVisitor >> rejectDuplicateChildren: node [
+	| seen newChildren |
+	seen := IdentitySet new.
+	newChildren := OrderedCollection new.
+	node children do: [ :child | 
+		(seen includes: child) ifFalse: [  
+			newChildren add: child
+		].
+		seen add: child
+	].
+	^ newChildren
+
+]
+
+{ #category : 'visiting' }
+PPCChoiceOptimizationVisitor >> visitChoiceNode: node [
+	self visitChildren: node.
+
+	"Remove the identical children"
+	node children: 	(self rejectDuplicateChildren: node).
+	
+	(node children size = 1) ifTrue: [ 
+		^ node firstChild
+	].
+
+	^ node
+]

software/petitcompiler/PPCClass.class.st

@@ -0,0 +1,393 @@
+"
+I am a basic structure represing a class being compiled.
+
+The CodeGen (or more of them) can operate on me, adding methods.
+
+I keep track of methods, ids, and inlined methods as well as the return variables for code gen.
+
+In the end ClassBuilder can create a Smalltalk class from my data.
+"
+Class {
+	#name : 'PPCClass',
+	#superclass : 'Object',
+	#instVars : [
+		'methodDictionary',
+		'currentMethod',
+		'constants',
+		'idGen',
+		'methodStack',
+		'returnVariable',
+		'properties'
+	],
+	#category : 'PetitCompiler-Compiler-Codegen'
+}
+
+{ #category : 'instance creation' }
+PPCClass class >> new [
+	"return an initialized instance"
+
+	^ self basicNew initialize.
+]
+
+{ #category : 'constants' }
+PPCClass >> addConstant: value as: name [    
+	(constants includesKey: name) ifTrue:[ 
+		(constants at: name) ~= value ifTrue:[ 
+			self error:'Duplicate constant!'.
+		].
+		^ self.
+	].
+	constants at: name put: value
+
+	"Modified: / 29-05-2015 / 07:22:39 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+]
+
+{ #category : 'variables' }
+PPCClass >> allocateReturnVariable [    
+	^ self allocateReturnVariableNamed: 'retval'
+
+	"Created: / 23-04-2015 / 18:03:40 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+	"Modified: / 15-06-2015 / 17:52:56 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+]
+
+{ #category : 'variables' }
+PPCClass >> allocateReturnVariableNamed: name [
+	"Allocate (or return previously allocated one) temporary variable used for
+	 storing a parser's return value (the parsed object)"                 
+	^ currentMethod allocateReturnVariableNamed: name
+
+	"Created: / 15-06-2015 / 18:04:48 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+]
+
+{ #category : 'variables' }
+PPCClass >> allocateTemporaryVariableNamed: preferredName [ 
+	"Allocate a new variable with (preferably) given name.
+	 Returns a real variable name that should be used."
+	
+	^ self currentNonInlineMethod allocateTemporaryVariableNamed: preferredName
+
+	"Created: / 23-04-2015 / 17:33:31 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+]
+
+{ #category : 'ids' }
+PPCClass >> asClassName: string [
+	"e.g. '234znak 43 ) 2' asLegalSelector = #v234znak432"
+	
+	| toUse |
+
+	toUse := string asString select: [:char | char isAlphaNumeric or: [ char = $_ ] ].
+	(toUse isEmpty or: [ toUse first isLetter not ])
+		ifTrue: [ toUse := 'v', toUse ].
+
+	toUse first isLowercase ifTrue: [
+		toUse := toUse copy.
+		toUse at: 1 put: toUse first asUppercase		
+	].
+	^ toUse asSymbol
+
+	"Modified: / 10-05-2015 / 07:29:57 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+]
+
+{ #category : 'ids' }
+PPCClass >> asSelector: string [
+	"e.g. '234znak 43 ) 2' asLegalSelector = #v234znak432"
+	
+	| toUse |
+
+	toUse := string select: [:char | char isAlphaNumeric or: [ char = $_ ] ].
+	(toUse isEmpty or: [ toUse first isLetter not ])
+		ifTrue: [ toUse := 'v', toUse ].
+	toUse first isUppercase ifFalse:[
+		toUse := toUse copy.
+		toUse at: 1 put: toUse first asLowercase
+	].
+	^toUse
+
+	"Modified: / 10-05-2015 / 07:29:57 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+]
+
+{ #category : 'method cache' }
+PPCClass >> cachedMethod: id [
+	^ methodDictionary at: id ifAbsent: [ nil ]
+]
+
+{ #category : 'method cache' }
+PPCClass >> cachedMethod: id ifPresent: aBlock [
+	^ methodDictionary at: id ifPresent: aBlock
+]
+
+{ #category : 'accessing' }
+PPCClass >> classVariables [
+	^ constants keys asArray
+]
+
+{ #category : 'accessing' }
+PPCClass >> constants [
+	^ constants
+]
+
+{ #category : 'accessing' }
+PPCClass >> currentMethod [
+	^ currentMethod 
+]
+
+{ #category : 'accessing' }
+PPCClass >> currentNonInlineMethod [
+	^ methodStack 
+		detect:[:m | m isInline not ] 
+		ifNone:[ self error: 'No non-inlined method']
+
+	"Created: / 23-04-2015 / 17:33:31 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+]
+
+{ #category : 'accessing' }
+PPCClass >> currentReturnVariable [
+	^ currentMethod returnVariable 
+]
+
+{ #category : 'accessing-properties' }
+PPCClass >> hasProperty: aKey [
+	"Test if the property aKey is present."
+	
+	^ properties notNil and: [ properties includesKey: aKey ]
+]
+
+{ #category : 'ids' }
+PPCClass >> idFor: anObject [
+	^ idGen idFor: anObject
+]
+
+{ #category : 'ids' }
+PPCClass >> idFor: anObject defaultName: defaultName [
+	^ idGen idFor: anObject defaultName: defaultName
+]
+
+{ #category : 'accessing' }
+PPCClass >> idGen [
+	^ idGen
+]
+
+{ #category : 'accessing' }
+PPCClass >> idGen: anObject [
+	idGen := anObject
+]
+
+{ #category : 'accessing' }
+PPCClass >> ids [
+	^ idGen ids
+]
+
+{ #category : 'initialization' }
+PPCClass >> initialize [
+	super initialize.
+
+	methodStack := Stack new.
+	methodDictionary := IdentityDictionary new.
+	constants := Dictionary new.
+	idGen := PPCIdGenerator new.
+]
+
+{ #category : 'accessing' }
+PPCClass >> instanceAndClassVariables [
+	| collection |
+	collection := OrderedCollection new.
+	collection addAll: self instanceVariables.
+	collection addAll: self classVariables.
+	^ collection
+]
+
+{ #category : 'accessing' }
+PPCClass >> instanceVariables [
+	^ #()
+]
+
+{ #category : 'accessing' }
+PPCClass >> methodDictionary [
+	^ methodDictionary
+]
+
+{ #category : 'accessing' }
+PPCClass >> name [
+	^ self asClassName: (self propertyAt: #name)
+]
+
+{ #category : 'accessing' }
+PPCClass >> name: value [
+	^ self propertyAt: #name put: value
+]
+
+{ #category : 'ids' }
+PPCClass >> numberIdFor: object [
+	^ idGen numericIdFor: object
+]
+
+{ #category : 'support' }
+PPCClass >> parsedValueOf: aBlock to: aString [
+	| tmpVarirable method |
+
+	self assert:aBlock isBlock.
+	self assert:aString isNil not.
+	
+	tmpVarirable := returnVariable.
+	returnVariable := aString.
+	method := [
+		aBlock value
+	] ensure:[ returnVariable := tmpVarirable ].
+
+	self assert: (method isMethod).	
+	^ method
+]
+
+{ #category : 'support' }
+PPCClass >> pop [
+	| retval |
+	retval := methodStack pop.
+	currentMethod := methodStack isEmpty 
+		ifTrue: [ nil ]
+		ifFalse: [ methodStack top ].
+	^ retval
+
+	"Modified: / 21-11-2014 / 12:27:25 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+]
+
+{ #category : 'accessing-properties' }
+PPCClass >> properties [
+	^ properties
+]
+
+{ #category : 'accessing-properties' }
+PPCClass >> properties: aDictionary [
+	properties := aDictionary 
+]
+
+{ #category : 'accessing-properties' }
+PPCClass >> propertyAt: aKey [ 
+	^ self propertyAt: aKey  ifAbsent: [ nil ]
+]
+
+{ #category : 'accessing-properties' }
+PPCClass >> propertyAt: aKey ifAbsent: aBlock [
+	"Answer the property value associated with aKey or, if aKey isn't found, answer the result of evaluating aBlock."
+	
+	^ properties isNil
+		ifTrue: [ aBlock value ]
+		ifFalse: [ properties at: aKey ifAbsent: aBlock ]
+]
+
+{ #category : 'accessing-properties' }
+PPCClass >> propertyAt: aKey ifAbsentPut: aBlock [
+	"Answer the property associated with aKey or, if aKey isn't found store the result of evaluating aBlock as new value."
+	
+	^ self propertyAt: aKey ifAbsent: [ self propertyAt: aKey put: aBlock value ]
+]
+
+{ #category : 'accessing-properties' }
+PPCClass >> propertyAt: aKey put: anObject [
+	"Set the property at aKey to be anObject. If aKey is not found, create a new entry for aKey and set is value to anObject. Answer anObject."
+
+	^ (properties ifNil: [ properties := Dictionary new: 1 ])
+		at: aKey put: anObject
+]
+
+{ #category : 'support' }
+PPCClass >> push [
+	methodStack push: currentMethod.
+	(methodStack size > 500 )ifTrue: [ self error: 'unless it is very complex grammar, there is an error somewhere' ]
+
+	"Modified: / 21-11-2014 / 12:27:18 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+]
+
+{ #category : 'support' }
+PPCClass >> returnVariable [
+	self error: 'Should never be called and accessed outside this class'.
+	^ returnVariable 
+]
+
+{ #category : 'accessing' }
+PPCClass >> rootMethod [
+	^ self propertyAt: #rootMethod ifAbsent: nil
+
+]
+
+{ #category : 'accessing' }
+PPCClass >> rootMethod: value [
+	^ self propertyAt: #rootMethod put: value
+
+]
+
+{ #category : 'accessing' }
+PPCClass >> selectors [
+	^ methodDictionary keys
+]
+
+{ #category : 'support' }
+PPCClass >> startInline [
+	| indentationLevel |
+	indentationLevel := currentMethod indentationLevel.
+	
+	currentMethod := PPCInlinedMethod new.
+	currentMethod returnVariable: returnVariable.
+	currentMethod indentationLevel: indentationLevel.
+	self push.
+
+	"Modified: / 01-06-2015 / 21:48:35 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+]
+
+{ #category : 'support' }
+PPCClass >> startInline: id [
+	| indentationLevel |
+	(methodDictionary includesKey: id) ifTrue: [ self error: 'OOOUPS!' ].
+	indentationLevel := currentMethod indentationLevel.
+	
+	currentMethod := PPCInlinedMethod new.
+	currentMethod id: id.   
+	currentMethod returnVariable: returnVariable.
+	currentMethod indentationLevel: indentationLevel.
+	self push.
+
+	"Modified: / 01-06-2015 / 21:48:35 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+]
+
+{ #category : 'support' }
+PPCClass >> startMethod: id category: category [
+	(methodDictionary includesKey: id) ifTrue: [ self error: 'OOOUPS!' ].
+
+	currentMethod := PPCMethod new.
+	currentMethod id: id.
+	currentMethod category: category.
+	
+	self push.      
+	self store: currentMethod as: id.
+
+	"Modified: / 01-06-2015 / 21:19:41 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+]
+
+{ #category : 'support' }
+PPCClass >> stopInline [
+	^ self pop.
+
+	"Modified: / 01-06-2015 / 21:37:59 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+]
+
+{ #category : 'support' }
+PPCClass >> stopMethod [
+   self store: currentMethod as: currentMethod methodName.
+	^ self pop.
+
+]
+
+{ #category : 'method cache' }
+PPCClass >> store: method as: id [
+	self assert: (method isKindOf: PPCMethod).
+	methodDictionary at: id put: method.
+]
+
+{ #category : 'accessing' }
+PPCClass >> superclass [
+	^ self propertyAt: #superclass
+]
+
+{ #category : 'accessing' }
+PPCClass >> superclass: value [
+	^ self propertyAt: #superclass put: value
+]

software/petitcompiler/PPCCodeBlock.class.st

@@ -0,0 +1,231 @@
+Class {
+	#name : 'PPCCodeBlock',
+	#superclass : 'Object',
+	#instVars : [
+		'buffer',
+		'indentation',
+		'temporaries'
+	],
+	#category : 'PetitCompiler-Compiler-Codegen'
+}
+
+{ #category : 'instance creation' }
+PPCCodeBlock class >> new [
+	"return an initialized instance"
+
+	^ self basicNew initialize.
+]
+
+{ #category : 'adding' }
+PPCCodeBlock >> add: string [
+	self nl.
+	self codeIndent.
+	self addOnLine: string.
+
+	"Modified: / 01-06-2015 / 22:58:42 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+]
+
+{ #category : 'adding' }
+PPCCodeBlock >> addOnLine: string [
+	buffer nextPutAll: string.
+]
+
+{ #category : 'code generation - variables' }
+PPCCodeBlock >> allocateTemporaryVariableNamed:preferredName [ 
+	"Allocate a new variable with (preferably) given name.
+	 Returns a real variable name that should be used."
+	
+	(temporaries includes:preferredName) ifFalse:[
+		temporaries add:preferredName.
+		^ preferredName
+	] ifTrue:[
+		| name |
+
+		name := preferredName , '_' , (temporaries size + 1) printString.
+		temporaries add:name.
+		^ name
+	].
+
+	"Created: / 23-04-2015 / 17:37:55 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+	"Modified: / 01-06-2015 / 21:03:39 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+]
+
+{ #category : 'code generation' }
+PPCCodeBlock >> code: aStringOrBlockOrRBParseNode [
+	self codeNl.
+	self codeOnLine: aStringOrBlockOrRBParseNode
+	
+	"Created: / 01-06-2015 / 21:07:10 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+	"Modified: / 03-06-2015 / 05:52:39 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+]
+
+{ #category : 'code generation' }
+PPCCodeBlock >> codeIndent [
+	self codeIndent:indentation
+
+	"Created: / 01-06-2015 / 22:58:00 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+]
+
+{ #category : 'code generation' }
+PPCCodeBlock >> codeIndent: level [
+	((Smalltalk respondsTo:#isSmalltalkX) and:[ Smalltalk isSmalltalkX ]) ifTrue:[ 
+		level * 4 timesRepeat: [ buffer nextPut: Character space  ].
+	] ifFalse:[ 
+		level timesRepeat: [ buffer nextPut: Character tab  ].
+	].
+
+	"Created: / 01-06-2015 / 22:58:07 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+]
+
+{ #category : 'code generation' }
+PPCCodeBlock >> codeNl [
+	self add: ''.
+]
+
+{ #category : 'printing and storing' }
+PPCCodeBlock >> codeOn: aStream [
+	"Dumps generated code on given stream"
+
+	temporaries notEmpty ifTrue:[
+		((Smalltalk respondsTo:#isSmalltalkX) and:[ Smalltalk isSmalltalkX ]) ifTrue:[ 
+			indentation * 4 timesRepeat: [ aStream nextPut: Character space  ].
+		] ifFalse:[ 
+			indentation timesRepeat: [ aStream nextPut: Character tab  ].
+		].
+		aStream nextPut: $|.
+		temporaries do:[:e | aStream space; nextPutAll: e  ].
+		aStream space.
+		aStream nextPut: $|. 
+		self nl.
+		"In Smalltalk/X, there should be a blank line after temporaries"
+		((Smalltalk respondsTo:#isSmalltalkX) and:[ Smalltalk isSmalltalkX ]) ifTrue:[ 
+			self nl.
+		].
+	].
+	aStream nextPutAll: buffer contents
+
+	"Created: / 01-06-2015 / 21:26:03 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+]
+
+{ #category : 'code generation' }
+PPCCodeBlock >> codeOnLine: aStringOrBlockOrRBParseNode [
+	aStringOrBlockOrRBParseNode isString ifTrue:[ 
+		self emitCodeAsString: aStringOrBlockOrRBParseNode
+	] ifFalse:[
+		(aStringOrBlockOrRBParseNode isKindOf: RBProgramNode) ifTrue:[ 
+			self emitCodeAsRBNode: aStringOrBlockOrRBParseNode.
+		] ifFalse:[  
+			self emitCodeAsBlock: aStringOrBlockOrRBParseNode
+		].
+	].
+]
+
+{ #category : 'indentation' }
+PPCCodeBlock >> dedent [
+	indentation := indentation - 1
+]
+
+{ #category : 'private' }
+PPCCodeBlock >> emitCodeAsBlock: aBlock [
+	aBlock value
+
+]
+
+{ #category : 'private' }
+PPCCodeBlock >> emitCodeAsRBNode: anRBNode [
+	anRBNode isSequence ifTrue:[
+		anRBNode temporaries do:[:e |  
+			(temporaries includes: e name) ifFalse:[ 
+				temporaries add: e name
+			].
+		].
+		anRBNode statements do:[:e|
+			self 	add: (self formatRBNode: e); 
+					addOnLine: '.'.
+		].
+	] ifFalse:[  
+		buffer nextPutAll: anRBNode formattedCode.  
+	].
+
+
+
+]
+
+{ #category : 'private' }
+PPCCodeBlock >> emitCodeAsString: aString [
+	self addOnLine: aString
+
+]
+
+{ #category : 'private' }
+PPCCodeBlock >> formatRBNode: anRBNode [
+	| formatter |
+	formatter := anRBNode formatterClass new.
+	formatter indent: indentation.
+	^ formatter format: anRBNode 
+]
+
+{ #category : 'indentation' }
+PPCCodeBlock >> indent [ 
+	indentation := indentation + 1
+]
+
+{ #category : 'indentation' }
+PPCCodeBlock >> indentationLevel [
+	^ indentation
+]
+
+{ #category : 'indentation' }
+PPCCodeBlock >> indentationLevel: value [
+	indentation := value
+]
+
+{ #category : 'initialization' }
+PPCCodeBlock >> initialize [
+	"Invoked when a new instance is created."
+
+	buffer := String new writeStream.
+	indentation := 1.
+	temporaries := OrderedCollection new.
+
+	"Modified: / 01-06-2015 / 20:57:08 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+	"Modified (comment): / 18-06-2015 / 06:04:21 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+]
+
+{ #category : 'indent-dedent' }
+PPCCodeBlock >> nl [
+	^ buffer nextPut: Character cr
+]
+
+{ #category : 'printing and storing' }
+PPCCodeBlock >> sourceOn:aStream [ 
+	"Dumps generated code on given stream"
+	
+	temporaries notEmpty ifTrue:[
+		((Smalltalk respondsTo:#isSmalltalkX) and:[ Smalltalk isSmalltalkX ]) ifTrue:[
+			indentation * 4 timesRepeat:[
+				aStream nextPut:Character space
+			].
+		] ifFalse:[
+			indentation timesRepeat:[
+				aStream nextPut:Character tab
+			].
+		].
+		aStream nextPut:$|.
+		temporaries do:[:e | 
+			aStream
+				space;
+				nextPutAll:e
+		].
+		aStream space.
+		aStream nextPut:$|.
+		self nl.
+		 "In Smalltalk/X, there should be a blank line after temporaries"
+		((Smalltalk respondsTo:#isSmalltalkX) and:[ Smalltalk isSmalltalkX ]) ifTrue:[
+			self nl.
+		].
+	].
+	aStream nextPutAll:buffer contents
+
+	"Created: / 01-06-2015 / 21:26:03 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+]

software/petitcompiler/PPCCodeGen.class.st

@@ -0,0 +1,575 @@
+Class {
+	#name : 'PPCCodeGen',
+	#superclass : 'Object',
+	#instVars : [
+		'clazz',
+		'options',
+		'memoizationStrategy'
+	],
+	#category : 'PetitCompiler-Compiler-Codegen'
+}
+
+{ #category : 'instance creation' }
+PPCCodeGen class >> new [
+	"return an initialized instance"
+
+	^ self on: PPCCompilationOptions new
+
+	"Modified: / 07-09-2015 / 10:22:49 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+]
+
+{ #category : 'instance creation' }
+PPCCodeGen class >> on: aPPCArguments [
+	"return an initialized instance"
+
+	^ self basicNew
+		initialize;
+		options: aPPCArguments
+]
+
+{ #category : 'code primitives' }
+PPCCodeGen >> add: string [
+	self error: 'deprecated?'.
+	clazz currentMethod add: string.
+]
+
+{ #category : 'code primitives' }
+PPCCodeGen >> addConstant: value as: name [    
+	clazz addConstant: value as: name
+
+]
+
+{ #category : 'code primitives' }
+PPCCodeGen >> addOnLine: string [
+	self error: 'deprecated'.
+	clazz currentMethod addOnLine: string.
+]
+
+{ #category : 'code primitives' }
+PPCCodeGen >> addVariable: name [
+	^ clazz currentNonInlineMethod addVariable: name
+
+	"Modified: / 23-04-2015 / 17:34:02 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+]
+
+{ #category : 'variables' }
+PPCCodeGen >> allocateReturnVariable [    
+	^ clazz allocateReturnVariableNamed: '__retval'
+
+	"Created: / 23-04-2015 / 18:03:40 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+	"Modified: / 15-06-2015 / 17:52:56 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+]
+
+{ #category : 'variables' }
+PPCCodeGen >> allocateReturnVariableNamed: name [
+	^ clazz allocateReturnVariableNamed: name
+]
+
+{ #category : 'variables' }
+PPCCodeGen >> allocateTemporaryVariableNamed: preferredName [ 
+	"Allocate a new variable with (preferably) given name.
+	 Returns a real variable name that should be used."
+	
+	^ clazz allocateTemporaryVariableNamed: preferredName
+
+	"Created: / 23-04-2015 / 17:33:31 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+]
+
+{ #category : 'caching' }
+PPCCodeGen >> cacheMethod: method as: id [
+	^ clazz store: method as: id
+]
+
+{ #category : 'caching' }
+PPCCodeGen >> cachedMethod: id [
+	^ clazz cachedMethod: id
+]
+
+{ #category : 'caching' }
+PPCCodeGen >> cachedMethod: id ifPresent: aBlock [
+	^ clazz cachedMethod: id ifPresent: aBlock
+]
+
+{ #category : 'code primitives' }
+PPCCodeGen >> call: anotherMethod [
+	self error: 'deprecated?'.
+	clazz currentMethod add: anotherMethod call.
+]
+
+{ #category : 'code primitives' }
+PPCCodeGen >> callOnLine: anotherMethod [
+	self error: 'deprecated?'.
+	clazz currentMethod addOnLine: anotherMethod call.
+]
+
+{ #category : 'accessing' }
+PPCCodeGen >> clazz [
+	^ clazz
+]
+
+{ #category : 'accessing' }
+PPCCodeGen >> clazz: aPPCClass [
+	clazz := aPPCClass
+]
+
+{ #category : 'code' }
+PPCCodeGen >> code: aStringOrBlockOrRBParseNode [
+	clazz currentMethod code: aStringOrBlockOrRBParseNode
+
+	"Created: / 01-06-2015 / 23:49:11 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+]
+
+{ #category : 'code' }
+PPCCodeGen >> codeAssert: aCode [
+	self code: 'self assert: (', aCode, ').'.
+]
+
+{ #category : 'code assignment' }
+PPCCodeGen >> codeAssign: stringOrBlock to: variable [
+	self assert: variable isNil not.
+	
+	stringOrBlock isString ifTrue: [ 
+		^ self codeAssignString: stringOrBlock to: variable
+	].
+
+	(stringOrBlock isKindOf: BlockClosure) ifTrue: [ 
+		^ self codeAssignParsedValueOf: stringOrBlock  to: variable
+	].
+
+	self error: 'unknown argument'.
+]
+
+{ #category : 'code assignment' }
+PPCCodeGen >> codeAssignParsedValueOf:aBlock to: variable [ 
+	|   method |
+	method := clazz parsedValueOf: aBlock to: variable.
+		
+	method isInline ifTrue:[
+		self codeCallOnLine:method
+	] ifFalse:[
+		self codeAssignString: (method call) to: variable.
+	]
+
+	"Created: / 23-04-2015 / 18:21:51 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+]
+
+{ #category : 'code assignment' }
+PPCCodeGen >> codeAssignString: string to: variable [
+	self assert: variable isNil not.
+	
+	"TODO JK: Hack alert, whatever is magic constant!"
+	(variable == #whatever) ifFalse: [ 
+		"Do not assign, if somebody does not care!"
+		self code: variable ,' := ', string.
+	]
+]
+
+{ #category : 'code' }
+PPCCodeGen >> codeBlock: contents [
+	clazz currentMethod codeBlock: contents
+
+	"Created: / 01-06-2015 / 22:35:32 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+]
+
+{ #category : 'code' }
+PPCCodeGen >> codeCall: aMethod [
+	self assert: (aMethod isKindOf: PPCMethod).
+	self code: aMethod call.
+]
+
+{ #category : 'code' }
+PPCCodeGen >> codeCallOnLine: aMethod [
+	self assert: (aMethod isKindOf: PPCMethod).
+	self codeOnLine: aMethod call.
+]
+
+{ #category : 'code error handling' }
+PPCCodeGen >> codeClearError [
+	self code: 'error := false.'.
+
+]
+
+{ #category : 'code debugging' }
+PPCCodeGen >> codeComment: string [
+	self code: '"', (string copyReplaceAll: '"' with: '""'), '"'.
+]
+
+{ #category : 'code' }
+PPCCodeGen >> codeDot [
+	self codeOnLine: '.'.
+
+	"Created: / 16-06-2015 / 06:09:07 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+]
+
+{ #category : 'code error handling' }
+PPCCodeGen >> codeError [
+	self code: 'self parseError: ''message notspecified''.'.
+
+]
+
+{ #category : 'code error handling' }
+PPCCodeGen >> codeError: errorMessage [
+	| escaped |
+	escaped := (errorMessage copyReplaceAll: '''' with: '''''').
+	self code: 'self parseError: ''', escaped, '''.'
+
+]
+
+{ #category : 'code error handling' }
+PPCCodeGen >> codeError: errorMessage at: position [
+	| escaped |
+	escaped := (errorMessage copyReplaceAll: '''' with: '''''').
+	self code: 'self parseError: ''', escaped, ''' at: ', position asString, '.'
+
+]
+
+{ #category : 'code assignment' }
+PPCCodeGen >> codeEvaluate: stringOrBlock [
+	^ self codeEvaluateAndAssign: stringOrBlock to: #whatever
+]
+
+{ #category : 'code assignment' }
+PPCCodeGen >> codeEvaluate: selector argument: argument on: variable [
+	self assert: variable isNil not.
+	
+	"TODO JK: Hack alert, whatever is magic constant!"
+	(variable == #whatever) ifFalse: [ 
+		"Do not assign, if somebody does not care!"
+		self code: variable, ' ', selector,' ', argument.
+ 	] ifTrue: [ 
+		"In case argument has a side effect"
+ 		self code: argument	
+	]
+]
+
+{ #category : 'code assignment' }
+PPCCodeGen >> codeEvaluateAndAssign: stringOrBlock to: variable [
+	"Contrary to codeAssign:to: I always put code onto the stream"
+	stringOrBlock isString ifTrue: [ 
+		self codeEvaluateAndAssignString: stringOrBlock to: variable
+	] ifFalse: [ 
+		self assert: (stringOrBlock isKindOf: BlockClosure).
+		self codeEvaluateAndAssignParsedValueOf: stringOrBlock  to: variable 
+	]
+]
+
+{ #category : 'code assignment' }
+PPCCodeGen >> codeEvaluateAndAssignParsedValueOf: aBlock to: variable [
+	| method |
+	method := clazz parsedValueOf: aBlock to: variable	.
+
+
+	method isInline ifFalse: [ 
+		self codeEvaluateAndAssignString: method call to: variable.
+	] ifTrue: [ 
+		"if inlined, the variable is already filled in, just call it"
+		self code: method call
+	]
+
+]
+
+{ #category : 'code assignment' }
+PPCCodeGen >> codeEvaluateAndAssignString: string to: variable [
+	"Contrary to codeAssign:to: I always put code onto the stream"
+	self assert: string isString.
+	self assert: variable isNil not.
+	
+	"TODO JK: Hack alert, whatever is magic constant!"
+	(variable == #whatever) ifFalse: [ 
+		self codeAssignString: string to: variable
+	] ifTrue: [ 
+		"In case code has a side effect"
+		self code: string.	
+	]
+]
+
+{ #category : 'code debugging' }
+PPCCodeGen >> codeHalt [
+	self code: 'self halt. '
+
+]
+
+{ #category : 'code debugging' }
+PPCCodeGen >> codeHaltIfShiftPressed [
+	options debug ifTrue: [
+		((Smalltalk respondsTo: #isSmalltalkX) and:[Smalltalk isSmalltalkX]) ifFalse:[  
+			self code: 'self haltIf:[Sensor shiftPressed].'
+		]
+	]
+
+	"Modified: / 10-05-2015 / 07:39:47 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+]
+
+{ #category : 'code structures' }
+PPCCodeGen >> codeIf: condition then: then [ 
+	self codeIf: condition then: then else: nil
+
+	"Created: / 16-06-2015 / 06:07:06 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+]
+
+{ #category : 'code structures' }
+PPCCodeGen >> codeIf: condition then: then else: else [
+	self 
+		code: '(';
+		codeOnLine: condition;
+		codeOnLine: ')'.
+	then notNil ifTrue:[ 
+		self 
+			codeOnLine:' ifTrue: ';
+			codeBlock: then.
+	].
+	else notNil ifTrue:[ 
+		self
+			codeOnLine:' ifFalse: ';
+			codeBlock: else.
+	].
+	self codeDot.
+
+	"Created: / 01-06-2015 / 22:43:15 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+	"Modified: / 16-06-2015 / 06:09:33 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+]
+
+{ #category : 'code error handling' }
+PPCCodeGen >> codeIfErrorThen: then [
+	^ self codeIf: 'error' then: then else: nil
+
+	"Created: / 16-06-2015 / 06:06:44 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+]
+
+{ #category : 'code error handling' }
+PPCCodeGen >> codeIfErrorThen: then else: else [
+	^ self codeIf: 'error' then: then else: else
+
+	"Created: / 16-06-2015 / 06:05:56 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+]
+
+{ #category : 'code indentation' }
+PPCCodeGen >> codeIndentPop [
+	self code: 'context indentStack pop'; codeDot
+]
+
+{ #category : 'code' }
+PPCCodeGen >> codeNil [
+	self codeOnLine: 'nil'.
+
+]
+
+{ #category : 'code' }
+PPCCodeGen >> codeNl [
+	self code: ''.
+]
+
+{ #category : 'code' }
+PPCCodeGen >> codeOnLine:aStringOrBlockOrRBParseNode [
+	clazz currentMethod codeOnLine: aStringOrBlockOrRBParseNode
+
+	"Created: / 01-06-2015 / 23:49:11 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+]
+
+{ #category : 'code debugging' }
+PPCCodeGen >> codeProfileStart [
+	self code: 'context methodInvoked: #', clazz currentMethod methodName, '.'
+
+	"Created: / 01-06-2015 / 21:17:19 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+]
+
+{ #category : 'code debugging' }
+PPCCodeGen >> codeProfileStop [
+	self code: 'context methodFinished: #', clazz currentMethod methodName, '.'
+
+	"Created: / 01-06-2015 / 21:19:11 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+]
+
+{ #category : 'code' }
+PPCCodeGen >> codeReturn [
+   clazz currentMethod isInline ifTrue: [
+				"If inlined, the return variable already holds the value"
+		] ifFalse: [
+				options profile ifTrue:[ 
+						self codeProfileStop.
+				]. 
+				self code: '^ ', clazz currentMethod returnVariable  
+		].
+
+				"Created: / 23-04-2015 / 18:01:05 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+				"Modified: / 01-06-2015 / 21:49:04 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+]
+
+{ #category : 'code' }
+PPCCodeGen >> codeReturn: code [
+	" - returns whatever is in code OR
+	  - assigns whatever is in code into the returnVariable"
+	clazz currentMethod isInline ifTrue:[
+		self codeEvaluateAndAssign: code to: clazz currentMethod returnVariable. 
+	] ifFalse: [ 
+		options profile ifTrue:[ 
+			self codeProfileStop.
+		].   
+		self code: '^ '.
+		self codeOnLine: code            
+	]
+
+	"Created: / 23-04-2015 / 18:01:05 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+	"Modified: / 01-06-2015 / 21:48:51 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+]
+
+{ #category : 'code' }
+PPCCodeGen >> codeReturnParsedValueOf: aBlock [ 
+	|   method |
+
+	method := clazz parsedValueOf: aBlock to: clazz currentReturnVariable.
+
+	method isInline ifTrue:[
+		self codeCallOnLine: method.
+		self codeReturn: clazz currentReturnVariable.
+	] ifFalse:[
+		self codeReturn: method call.
+		
+	]
+
+	"Created: / 23-04-2015 / 18:21:51 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+]
+
+{ #category : 'code debugging' }
+PPCCodeGen >> codeTranscriptShow: text [
+	(options debug) ifTrue: [ 
+		self code: 'Transcript show: ', text storeString, '; cr.'.
+	]
+]
+
+{ #category : 'accessing' }
+PPCCodeGen >> currentMethod [
+	^ clazz currentMethod 
+]
+
+{ #category : 'variables' }
+PPCCodeGen >> currentReturnVariable [
+	^ clazz currentReturnVariable 
+]
+
+{ #category : 'accessing - options' }
+PPCCodeGen >> debug [
+	^ options debug
+]
+
+{ #category : 'code primitives' }
+PPCCodeGen >> dedent [
+	clazz currentMethod dedent
+]
+
+{ #category : 'gt' }
+PPCCodeGen >> gtCurrentMethod: composite [
+	<gtInspectorPresentationOrder: 40>
+	
+	composite text
+		title: 'Current Method';
+		display: [ :codeGen | codeGen clazz currentMethod source ]
+	
+]
+
+{ #category : 'ids' }
+PPCCodeGen >> idFor: anObject [
+	^ clazz idFor: anObject
+]
+
+{ #category : 'ids' }
+PPCCodeGen >> idFor: anObject defaultName: defaultName [
+	^ clazz idFor: anObject defaultName: defaultName
+]
+
+{ #category : 'accessing' }
+PPCCodeGen >> idGen [
+	^ clazz idGen
+]
+
+{ #category : 'accessing' }
+PPCCodeGen >> idGen: idGenerator [
+	^ clazz idGen: idGenerator
+]
+
+{ #category : 'accessing' }
+PPCCodeGen >> ids [
+	^ clazz idGen ids
+]
+
+{ #category : 'code primitives' }
+PPCCodeGen >> indent [
+	clazz currentMethod indent
+]
+
+{ #category : 'initialization' }
+PPCCodeGen >> initialize [
+	super initialize.
+
+	clazz := PPCClass new.
+]
+
+{ #category : 'memoization' }
+PPCCodeGen >> memoizationStrategy [
+	memoizationStrategy isNil ifTrue: [ 
+		memoizationStrategy := (options memoizationStrategy asClass new)
+			codeGen: self;
+			yourself
+	].
+
+	^ memoizationStrategy 
+]
+
+{ #category : 'accessing' }
+PPCCodeGen >> methodCategory [
+	^ 'generated'
+]
+
+{ #category : 'ids' }
+PPCCodeGen >> numberIdFor: object [
+	^ clazz numberIdFor: object
+]
+
+{ #category : 'accessing' }
+PPCCodeGen >> options: args [
+	options := args
+]
+
+{ #category : 'code debugging' }
+PPCCodeGen >> profileTokenRead: tokenName [
+	options profile ifTrue: [ 
+		self code: 'context tokenRead: ', tokenName storeString, '.'
+	]
+]
+
+{ #category : 'support' }
+PPCCodeGen >> startInline [
+	^ clazz startInline
+
+	"Modified: / 01-06-2015 / 21:48:35 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+]
+
+{ #category : 'support' }
+PPCCodeGen >> startInline: id [
+	^ clazz startInline: id
+
+	"Modified: / 01-06-2015 / 21:48:35 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+]
+
+{ #category : 'support' }
+PPCCodeGen >> startMethod: id [
+	clazz startMethod: id category: self methodCategory.
+	
+	options profile ifTrue:[ 
+		self codeProfileStart.
+	].
+]
+
+{ #category : 'support' }
+PPCCodeGen >> stopInline [
+	^ clazz stopInline
+
+	"Modified: / 01-06-2015 / 21:37:59 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+]
+
+{ #category : 'support' }
+PPCCodeGen >> stopMethod [
+   ^ clazz stopInline 
+
+		"Modified: / 01-06-2015 / 21:38:05 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+]

software/petitcompiler/PPCContext.class.st

@@ -0,0 +1,428 @@
+Class {
+	#name : 'PPCContext',
+	#superclass : 'PPStream',
+	#instVars : [
+		'root',
+		'properties',
+		'globals',
+		'furthestFailure',
+		'compiledParser',
+		'ws',
+		'waterPosition',
+		'columns'
+	],
+	#category : 'PetitCompiler-Context'
+}
+
+{ #category : 'as yet unclassified' }
+PPCContext class >> new [
+	^ self basicNew initialize
+]
+
+{ #category : 'as yet unclassified' }
+PPCContext class >> on: aPPParser stream: aStream [
+	^ self basicNew 
+		initialize;
+		root: aPPParser;
+		stream: aStream asPetitStream;
+		yourself
+]
+
+{ #category : 'converting' }
+PPCContext >> asCompiledParserContext [
+	^ self
+]
+
+{ #category : 'whitespace' }
+PPCContext >> atWs [
+	^ position == ws
+]
+
+{ #category : 'indentation' }
+PPCContext >> column [
+	^ self columns at: (position + 1)
+]
+
+{ #category : 'indentation' }
+PPCContext >> columns [
+	| column tmpPosition |
+	
+	columns isNil ifTrue: [ 
+		tmpPosition := position.
+		columns := Array new: readLimit + 1.
+		column := 1.
+	
+		0 to: readLimit do: [ :index |
+			position := index.
+			self isStartOfLine ifTrue: [ column := 1 ].
+			columns at: (index + 1) put: column.
+			column := column + 1.
+		].
+	
+		position := tmpPosition.
+	].
+	^ columns
+]
+
+{ #category : 'initialization' }
+PPCContext >> compiledParser [
+	^ compiledParser
+]
+
+{ #category : 'initialization' }
+PPCContext >> compiledParser: anObject [
+	compiledParser := anObject
+]
+
+{ #category : 'failures' }
+PPCContext >> furthestFailure [
+	^ furthestFailure 
+]
+
+{ #category : 'accessing-globals' }
+PPCContext >> globalAt: aKey [
+	"Answer the global property value associated with aKey."
+	
+	^ self globalAt: aKey ifAbsent: [ self error: 'Property not found' ]
+]
+
+{ #category : 'accessing-globals' }
+PPCContext >> globalAt: aKey ifAbsent: aBlock [
+	"Answer the global property value associated with aKey or, if aKey isn't found, answer the result of evaluating aBlock."
+	
+	^ globals isNil
+		ifTrue: [ aBlock value ]
+		ifFalse: [ globals at: aKey ifAbsent: aBlock ]
+]
+
+{ #category : 'accessing-globals' }
+PPCContext >> globalAt: aKey ifAbsentPut: aBlock [
+	"Answer the global property associated with aKey or, if aKey isn't found store the result of evaluating aBlock as new value."
+	
+	^ self globalAt: aKey ifAbsent: [ self globalAt: aKey put: aBlock value ]
+]
+
+{ #category : 'accessing-globals' }
+PPCContext >> globalAt: aKey put: anObject [
+	"Set the global property at aKey to be anObject. If aKey is not found, create a new entry for aKey and set is value to anObject. Answer anObject."
+
+	^ (globals ifNil: [ globals := Dictionary new: 1 ])
+		at: aKey put: anObject
+]
+
+{ #category : 'whitespace' }
+PPCContext >> goUpTo: char [
+	[ position < readLimit ] whileTrue: [ 
+		(collection at: position + 1) == char ifTrue: [ position := position + 1. ^ char ] .
+		position := position + 1.
+	]
+	
+]
+
+{ #category : 'gt' }
+PPCContext >> gtIndentStack: composite [
+	<gtInspectorPresentationOrder: 40>
+	
+	composite list
+		title: 'Indent Stack';
+		display: [ :context | context indentStack contents ]
+]
+
+{ #category : 'gt' }
+PPCContext >> gtProperties: composite [
+	<gtInspectorPresentationOrder: 40>
+	
+	composite table
+		title: 'Properties';
+		column: 'Key' evaluated: [ :each | each key printString ];
+		column: 'Value' evaluated: [ :each | each value printString ];
+		display: [ :node | (node properties ifNil: [ Dictionary new ]) associations ]
+]
+
+{ #category : 'accessing-globals' }
+PPCContext >> hasGlobal: aKey [
+	"Test if the global property aKey is present."
+	
+	^ globals notNil and: [ globals includesKey: aKey ]
+]
+
+{ #category : 'accessing-properties' }
+PPCContext >> hasProperties [
+	^ properties isNil not and: [ properties isEmpty not ]
+]
+
+{ #category : 'accessing-properties' }
+PPCContext >> hasProperty: aKey [
+	"Test if the property aKey is present."
+	
+	^ properties notNil and: [ properties includesKey: aKey ]
+]
+
+{ #category : 'ruby' }
+PPCContext >> heredocId [
+	^ self globalAt: #heredocId ifAbsent: nil
+]
+
+{ #category : 'ruby' }
+PPCContext >> heredocId: value [
+	self globalAt: #heredocId put: value
+]
+
+{ #category : 'memoization' }
+PPCContext >> identifier [
+	^ collection
+]
+
+{ #category : 'indentation' }
+PPCContext >> indentStack [
+	^ self propertyAt: #indentStack ifAbsentPut: [ IndentStack new ]
+]
+
+{ #category : 'initialization' }
+PPCContext >> initialize [
+	super initialize.	
+	rc := 0.
+	"Note a failure at -1"
+	furthestFailure  := PPFailure new position: -1; yourself.
+]
+
+{ #category : 'initialization' }
+PPCContext >> initializeFor: parser [
+	rc := 0.
+	root := parser.
+]
+
+{ #category : 'accessing-globals' }
+PPCContext >> invoke: parser [
+	^ parser parseOn: self
+]
+
+{ #category : 'profiling' }
+PPCContext >> islandInvoke [
+]
+
+{ #category : 'profiling' }
+PPCContext >> islandMemoHit [
+]
+
+{ #category : 'profiling' }
+PPCContext >> islandMemoized [
+]
+
+{ #category : 'memoization' }
+PPCContext >> lwRemember [
+
+	^ position
+]
+
+{ #category : 'memoization' }
+PPCContext >> lwRestore: aPPContextMemento [
+	
+	position := aPPContextMemento.
+]
+
+{ #category : 'failures' }
+PPCContext >> noteFailure: aPPFailure [
+	(aPPFailure position > furthestFailure position)
+		ifTrue: [ furthestFailure := aPPFailure ].
+]
+
+{ #category : 'accessing-globals' }
+PPCContext >> peek2 [
+	position = readLimit ifTrue: [ ^ nil ].
+	^ collection at: (position + 1)
+]
+
+{ #category : 'ruby' }
+PPCContext >> percentStringEnd [
+	^ self globalAt: #percentStringEnd ifAbsent: nil
+]
+
+{ #category : 'ruby' }
+PPCContext >> percentStringStart: value [
+	| endValue |
+	endValue := value.
+	(value == $[) ifTrue: [ endValue := $] ].
+	(value == $() ifTrue: [ endValue := $) ].
+	(value == ${) ifTrue: [ endValue := $} ].
+
+	self globalAt: #percentStringStart put: value.
+	self globalAt: #percentStringEnd put: endValue
+]
+
+{ #category : 'accessing-properties' }
+PPCContext >> properties [
+	^ properties ifNil: [ properties := Dictionary new ]
+]
+
+{ #category : 'accessing-properties' }
+PPCContext >> propertyAt: aKey [
+	"Answer the property value associated with aKey."
+	
+	^ self propertyAt: aKey ifAbsent: [ self error: 'Property not found' ]
+]
+
+{ #category : 'accessing-properties' }
+PPCContext >> propertyAt: aKey ifAbsent: aBlock [
+	"Answer the property value associated with aKey or, if aKey isn't found, answer the result of evaluating aBlock."
+	
+	^ properties isNil
+		ifTrue: [ aBlock value ]
+		ifFalse: [ properties at: aKey ifAbsent: aBlock ]
+]
+
+{ #category : 'accessing-properties' }
+PPCContext >> propertyAt: aKey ifAbsentPut: aBlock [
+	"Answer the property associated with aKey or, if aKey isn't found store the result of evaluating aBlock as new value."
+	
+	^ self propertyAt: aKey ifAbsent: [ self propertyAt: aKey put: aBlock value ]
+]
+
+{ #category : 'accessing-properties' }
+PPCContext >> propertyAt: aKey put: anObject [
+	"Set the property at aKey to be anObject. If aKey is not found, create a new entry for aKey and set is value to anObject. Answer anObject."
+
+	^ (properties ifNil: [ properties := Dictionary new: 1 ])
+		at: aKey put: anObject
+]
+
+{ #category : 'memoization' }
+PPCContext >> remember [
+	| memento |
+	memento := PPCContextMemento new
+		position: position;
+		yourself.
+		
+	self rememberProperties: memento.
+	^ memento
+]
+
+{ #category : 'memoization' }
+PPCContext >> rememberProperties: aPPContextMemento [
+	properties ifNil: [ ^ self ].
+	
+	properties keysAndValuesDo: [ :key :value |
+		aPPContextMemento propertyAt: key put: value
+	].
+]
+
+{ #category : 'accessing-globals' }
+PPCContext >> removeGlobal: aKey [
+	"Remove the property with aKey. Answer the property or raise an error if aKey isn't found."
+	
+	^ self removeGlobal: aKey ifAbsent: [ self error: 'Property not found' ]
+]
+
+{ #category : 'accessing-globals' }
+PPCContext >> removeGlobal: aKey ifAbsent: aBlock [
+	"Remove the global property with aKey. Answer the value or, if aKey isn't found, answer the result of evaluating aBlock."
+	
+	| answer |
+	globals isNil ifTrue: [ ^ aBlock value ].
+	answer := globals removeKey: aKey ifAbsent: aBlock.
+	globals isEmpty ifTrue: [ globals := nil ].
+	^ answer
+]
+
+{ #category : 'accessing-properties' }
+PPCContext >> removeProperty: aKey [
+	"Remove the property with aKey. Answer the property or raise an error if aKey isn't found."
+	
+	^ self removeProperty: aKey ifAbsent: [ self error: 'Property not found' ]
+]
+
+{ #category : 'accessing-properties' }
+PPCContext >> removeProperty: aKey ifAbsent: aBlock [
+	"Remove the property with aKey. Answer the value or, if aKey isn't found, answer the result of evaluating aBlock."
+	
+	| answer |
+	properties isNil ifTrue: [ ^ aBlock value ].
+	answer := properties removeKey: aKey ifAbsent: aBlock.
+	properties isEmpty ifTrue: [ properties := nil ].
+	^ answer
+]
+
+{ #category : 'initialization' }
+PPCContext >> reset [
+	properties := nil.
+	globals := nil.
+	waterPosition := nil.
+	ws := nil
+]
+
+{ #category : 'memoization' }
+PPCContext >> restore: aPPContextMemento [
+"	
+	position := aPPContextMemento.
+"	
+	position := aPPContextMemento position.
+	
+	self restoreProperties: aPPContextMemento.
+			
+]
+
+{ #category : 'memoization' }
+PPCContext >> restoreProperties: aPPContextMemento [
+	properties ifNil: [ ^ self ].
+	
+	properties keysDo: [ :key |
+		(aPPContextMemento hasProperty: key)
+			ifTrue: [ properties at: key put: (aPPContextMemento propertyAt: key) ]
+			ifFalse: [ properties removeKey: key  ]. 
+	].
+
+	aPPContextMemento keysAndValuesDo: [ :key :value |
+		properties at: key put: value
+	]
+]
+
+{ #category : 'acessing' }
+PPCContext >> root [
+	^ root 
+]
+
+{ #category : 'whitespace' }
+PPCContext >> setWs [
+	^ ws := position
+]
+
+{ #category : 'acessing' }
+PPCContext >> stream [
+	^ self
+]
+
+{ #category : 'acessing' }
+PPCContext >> stream: aStream [
+	collection := aStream collection.
+	position := aStream position.
+	readLimit := collection size.
+	newlines := nil.
+	columns := nil.
+	ws := nil.
+]
+
+{ #category : 'islands' }
+PPCContext >> waterPosition [
+	"^ self globalAt:  #waterPosition ifAbsentPut: [ nil ]"
+	^ waterPosition 
+]
+
+{ #category : 'islands' }
+PPCContext >> waterPosition: value [
+"	^ self globalAt:  #waterPosition put: value"
+	waterPosition := value
+]
+
+{ #category : 'profiling' }
+PPCContext >> waterToken [
+]
+
+{ #category : 'whitespace' }
+PPCContext >> ws [
+	^ ws
+]
+
+{ #category : 'whitespace' }
+PPCContext >> ws: anInteger [
+	ws := anInteger
+]

software/petitcompiler/PPCContextAnalysisEnvironment.class.st

@@ -0,0 +1,39 @@
+Class {
+	#name : 'PPCContextAnalysisEnvironment',
+	#superclass : 'Object',
+	#instVars : [
+		'pushSet',
+		'popSet',
+		'changeSet'
+	],
+	#category : 'PetitCompiler-Support'
+}
+
+{ #category : 'instance creation' }
+PPCContextAnalysisEnvironment class >> new [
+	^ self basicNew initialize
+]
+
+{ #category : 'as yet unclassified' }
+PPCContextAnalysisEnvironment >> changes [
+	^ changeSet 
+]
+
+{ #category : 'as yet unclassified' }
+PPCContextAnalysisEnvironment >> initialize [
+	super initialize.
+	
+	pushSet := IdentitySet new.
+	popSet  := IdentitySet new.
+	changeSet := IdentitySet new.
+]
+
+{ #category : 'as yet unclassified' }
+PPCContextAnalysisEnvironment >> pops [
+	^ popSet 
+]
+
+{ #category : 'as yet unclassified' }
+PPCContextAnalysisEnvironment >> pushes [
+	^ pushSet 
+]

software/petitcompiler/PPCContextMemento.class.st

@@ -0,0 +1,115 @@
+Class {
+	#name : 'PPCContextMemento',
+	#superclass : 'Object',
+	#instVars : [
+		'position',
+		'properties'
+	],
+	#category : 'PetitCompiler-Context'
+}
+
+{ #category : 'comparing' }
+PPCContextMemento >> = anObject [
+	
+	(self == anObject) ifTrue: [ ^ true ].
+	(anObject class = PPCContextMemento) ifFalse: [ ^ false ].
+	
+	(anObject position = position) ifFalse: [ ^ false ].
+
+	(self propertiesSize = anObject propertiesSize) ifFalse: [ ^ false ].
+
+	self keysAndValuesDo: [ :key :value |
+		(anObject hasProperty: key) ifFalse: [ ^ false ].
+		((anObject propertyAt: key) = value) ifFalse: [ ^ false ]. 
+ 		].
+	
+	^ true.
+]
+
+{ #category : 'accessing - properties' }
+PPCContextMemento >> hasProperty: aKey [
+	"Test if the property aKey is present."
+	
+	^ properties notNil and: [ properties includesKey: aKey ]
+]
+
+{ #category : 'comparing' }
+PPCContextMemento >> hash [
+	^ position hash bitXor: properties hash.
+]
+
+{ #category : 'accessing - properties' }
+PPCContextMemento >> keysAndValuesDo: aBlock [
+	properties ifNil: [ ^ self ].
+	properties keysAndValuesDo: [ :key :value | aBlock value: key value: value copy ] 
+]
+
+{ #category : 'accessing' }
+PPCContextMemento >> position [
+	^ position
+]
+
+{ #category : 'accessing' }
+PPCContextMemento >> position: anInteger [
+	position := anInteger 
+]
+
+{ #category : 'accessing - properties' }
+PPCContextMemento >> propertiesSize [
+	properties ifNil: [ ^ 0 ].
+	^ properties size.
+]
+
+{ #category : 'accessing - properties' }
+PPCContextMemento >> propertyAt: aKey [
+	"Answer the property value associated with aKey."
+	
+	^ self propertyAt: aKey ifAbsent: [ self error: 'Property not found' ]
+]
+
+{ #category : 'accessing - properties' }
+PPCContextMemento >> propertyAt: aKey ifAbsent: aBlock [
+	"Answer the property value associated with aKey or, if aKey isn't found, answer the result of evaluating aBlock."
+		
+	properties isNil ifFalse: [ 
+		(properties includesKey: aKey) ifTrue: [ 
+			^ (properties at: aKey) copy
+		].
+	].
+	^ aBlock value
+
+	"Modified: / 15-04-2015 / 11:19:20 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+]
+
+{ #category : 'accessing - properties' }
+PPCContextMemento >> propertyAt: aKey ifAbsentPut: aBlock [
+	"Answer the property associated with aKey or, if aKey isn't found store the result of evaluating aBlock as new value."
+	
+	^ self propertyAt: aKey ifAbsent: [ self propertyAt: aKey put: aBlock value ]
+]
+
+{ #category : 'accessing - properties' }
+PPCContextMemento >> propertyAt: aKey put: anObject [
+	"Set the property at aKey to be anObject. If aKey is not found, create a new entry for aKey and set is value to anObject. Answer anObject."
+
+	^ (properties ifNil: [ properties := Dictionary new: 1 ])
+		at: aKey put: (anObject copy)
+]
+
+{ #category : 'accessing - properties' }
+PPCContextMemento >> removeProperty: aKey [
+	"Remove the property with aKey. Answer the property or raise an error if aKey isn't found."
+	
+	^ self removeProperty: aKey ifAbsent: [ self error: 'Property not found' ]
+]
+
+{ #category : 'accessing - properties' }
+PPCContextMemento >> removeProperty: aKey ifAbsent: aBlock [
+	"Remove the property with aKey. Answer the value or, if aKey isn't found, answer the result of evaluating aBlock."
+	
+	| answer |
+	properties isNil ifTrue: [ ^ aBlock value ].
+	answer := properties removeKey: aKey ifAbsent: aBlock.
+	properties isEmpty ifTrue: [ properties := nil ].
+	^ answer
+]

software/petitcompiler/PPCCopyVisitor.class.st

@@ -0,0 +1,23 @@
+"
+As I go, I do the copy of all the nodes
+"
+Class {
+	#name : 'PPCCopyVisitor',
+	#superclass : 'PPCRewritingVisitor',
+	#category : 'PetitCompiler-Visitors'
+}
+
+{ #category : 'as yet unclassified' }
+PPCCopyVisitor >> cache: node value: retval [
+	self cache: node value: retval ifPresent: [ :e | self assert: e == retval ]
+]
+
+{ #category : 'as yet unclassified' }
+PPCCopyVisitor >> visitNode: node [
+	| newNode |
+	self change.
+	newNode := node copy.
+	self cache: node value: newNode.
+	
+	^ super visitNode: newNode.
+]

software/petitcompiler/PPCDeterministicChoiceVisitor.class.st

@@ -0,0 +1,88 @@
+"
+I can recognize the deterministic choices, i.e. the choices, where based on the first token, one can decide if to take the choice or not.
+
+This simplifies the generated code and this migth improve performance as well (not yet implemented, as far as I know..)
+
+I need to be revisited and reimplemented...
+"
+Class {
+	#name : 'PPCDeterministicChoiceVisitor',
+	#superclass : 'PPCRewritingVisitor',
+	#category : 'PetitCompiler-Visitors'
+}
+
+{ #category : 'as yet unclassified' }
+PPCDeterministicChoiceVisitor >> isDeterministicChoice: node [
+	| predicates firstIndexes |
+	
+	predicates := self predicates: node.
+	firstIndexes := OrderedCollection new.
+	predicates do: [ :predicate | 
+		predicate classification withIndexDo: [ :bool :index | 
+			bool ifTrue: [firstIndexes add: index]
+		]
+	].
+
+	
+	^ firstIndexes size = firstIndexes asIdentitySet size
+]
+
+{ #category : 'as yet unclassified' }
+PPCDeterministicChoiceVisitor >> mergeFirstCharSets: firstSet [
+	| firstCharSetsOfFirstSet blocks mergedBlock |
+	firstCharSetsOfFirstSet := firstSet collect: [:e | e firstCharSet ].
+	blocks :=  firstCharSetsOfFirstSet collect: [ :e | e block ].
+	mergedBlock := [ :input | blocks anySatisfy: [ :block | block value: input ] ].
+
+
+	^ PPCharSetPredicate on: mergedBlock.
+]
+
+{ #category : 'as yet unclassified' }
+PPCDeterministicChoiceVisitor >> predicates: node [
+	| firstSets mergedSets |
+	
+	(node startsWithTrimmingTokens) ifTrue: [  
+		| tokensPerChild |
+		tokensPerChild := node children collect: [:child | child firstSetWithTokens "firstSet" ].
+		
+		firstSets := tokensPerChild collect: [ :childTokensOrTerminal | 
+			| firstSet |
+			firstSet := IdentitySet new.
+			childTokensOrTerminal do: [ :tokenOrTerminal | 
+				tokenOrTerminal isTokenNode ifTrue: [ 
+					firstSet addAll: tokenOrTerminal child firstSet 
+				] ifFalse: [  
+					firstSet addAll: tokenOrTerminal firstSet.
+				]
+			].
+			firstSet
+		].
+	] ifFalse: [ 
+		firstSets := node children collect: [:child | child firstSet ].
+	].
+	
+	mergedSets := firstSets collect: [ :fs | self mergeFirstCharSets: fs ].
+	node children with: mergedSets do: [ :child :merged |
+		child mergedFirstCharSet: merged
+	].
+	^ mergedSets
+]
+
+{ #category : 'as yet unclassified' }
+PPCDeterministicChoiceVisitor >> visitChoiceNode: node [
+	self visitChildren: node.
+
+	(self isDeterministicChoice: node) ifTrue: [ 
+		^ PPCDeterministicChoiceNode new
+				children: node children;
+				name: node name;
+				firstFollowCache: node firstFollowCache;
+				properties: node properties;
+				yourself.
+	].
+
+	^ super visitChoiceNode: node.
+	
+
+]