--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/compiler/PPCompiledParser.st	Sun Oct 26 01:03:31 2014 +0000
@@ -0,0 +1,144 @@
+"{ Package: 'stx:goodies/petitparser/compiler' }"
+
+PPParser subclass:#PPCompiledParser
+	instanceVariableNames:'startSymbol context failure error'
+	classVariableNames:''
+	poolDictionaries:''
+	category:'PetitCompiler-Core'
+!
+
+PPCompiledParser class instanceVariableNames:'parsers constants referringParser'
+
+"
+ No other class instance variables are inherited by this class.
+"
+!
+
+PPCompiledParser comment:''
+!
+
+!PPCompiledParser class methodsFor:'as yet unclassified'!
+
+addConstant: value as: id
+	self constants at: id ifPresent: [ 
+		((self constants at: id) = value) ifFalse: [self error: 'ooups']].	
+	
+	self constants at: id put: value.
+!
+
+addParser: aPPParser as: id
+	
+	"(self parsers includesKey: id) ifTrue: [self error: 'Ooups' ]."
+	self parsers at: id put: aPPParser.
+!
+
+constants
+	constants ifNil: [ constants := IdentityDictionary new ].
+	^ constants
+!
+
+parse: input
+	^ self new parse: input
+!
+
+parsers
+	parsers ifNil: [ parsers := IdentityDictionary new ].
+	^ parsers
+!
+
+referringParser
+	^ referringParser 
+!
+
+referringParser: aPPParser
+	referringParser := aPPParser
+! !
+
+!PPCompiledParser methodsFor:'as yet unclassified'!
+
+callParser: id
+	| retval |
+	retval := (self class parsers at: id) parseOn: context.
+	retval isPetitFailure 	ifTrue: [ self error: retval message at: retval position ]
+									ifFalse: [ self clearError ].
+	^ retval
+!
+
+clearError
+	error := false.
+!
+
+error
+	^ self error: '' at: context position
+!
+
+error: message
+	^ self error: message at: context position
+!
+
+error: aMessage at: position
+	failure position < position ifTrue: [
+		failure message: aMessage.
+		failure position: position
+	].
+	error := true.
+	^ failure
+!
+
+initialize
+	super initialize.
+	
+	self class constants keysAndValuesDo: [ :key :value |
+		self instVarNamed: key put: value.
+	].
+
+	startSymbol := #start.
+
+	
+
+!
+
+isCompiled
+	^ true
+!
+
+isError
+	^ error
+!
+
+parse: input rule: symbol
+	startSymbol := symbol.
+	^ self parse: input.
+!
+
+start
+	^ self subclassResponsibility
+!
+
+startSymbol: aSymbol
+	startSymbol := aSymbol
+!
+
+updateContext: aPPContext
+	self class referringParser allParsersDo: [ :p | p updateContext: aPPContext ].
+! !
+
+!PPCompiledParser methodsFor:'parsing'!
+
+parseOn: aPPContext
+	| retval |
+"	context := aPPContext asCompiledParserContext."
+	context := aPPContext.
+	context compiledParser: self.
+	failure := PPFailure new message: nil; context: context; position: -1.
+	context noteFailure: failure.
+	error := false.
+
+	retval := self perform: startSymbol.
+	(retval isPetitFailure) ifTrue: [ aPPContext noteFailure: failure ].
+	error ifTrue: [ aPPContext noteFailure: failure. retval := failure ].
+	
+"	aPPContext position: context position."
+	^ retval
+! !
+