--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/compiler/PPCCodeGenerator.st Thu Apr 30 23:43:14 2015 +0200
@@ -0,0 +1,680 @@
+"{ Package: 'stx:goodies/petitparser/compiler' }"
+
+"{ NameSpace: Smalltalk }"
+
+PPCNodeVisitor subclass:#PPCCodeGenerator
+ instanceVariableNames:'compiler'
+ classVariableNames:''
+ poolDictionaries:''
+ category:'PetitCompiler-Visitors'
+!
+
+!PPCCodeGenerator class methodsFor:'as yet unclassified'!
+
+on: aPPCCompiler
+ ^ self new
+ compiler: aPPCCompiler;
+ yourself
+! !
+
+!PPCCodeGenerator methodsFor:'accessing'!
+
+compiler: aPPCCompiler
+ compiler := aPPCCompiler
+! !
+
+!PPCCodeGenerator methodsFor:'hooks'!
+
+afterAccept: node retval: retval
+ "return the method from compiler"
+ ^ self stopMethodForNode: node.
+!
+
+beforeAccept: node
+ self startMethodForNode: node
+!
+
+closedDetected: node
+ ^ node isMarkedForInline ifFalse: [
+ self error: 'Should not happen!!'
+ ]
+!
+
+openDetected: node
+ ^ compiler checkCache: (compiler idFor: node)
+! !
+
+!PPCCodeGenerator methodsFor:'support'!
+
+addGuard: node
+ | guard firsts id |
+ (arguments guards not or: [(guard := PPCGuard on: node) makesSense not]) ifTrue: [ ^ self].
+
+ id := compiler idFor: node.
+ firsts := (node firstSetSuchThat: [ :e | (e isKindOf: PPCTrimmingTokenNode) or: [ e isTerminal ] ]).
+
+
+ (firsts allSatisfy: [ :e | e isKindOf: PPCTrimmingTokenNode ]) ifTrue: [
+ "If we start with trimming, we should invoke the whitespace parser"
+ self compileTokenWhitespace: firsts anyOne.
+
+ compiler add: 'context atEnd ifTrue: [ ^ self error ].'.
+ guard id: id, '_guard'.
+ guard compileGuard: compiler.
+ compiler addOnLine: 'ifFalse: [ ^ self error ].'
+ ].
+
+ (firsts allSatisfy: [ :e | e isTerminal ]) ifTrue: [
+ compiler add: 'context atEnd ifTrue: [ ^ self error ].'.
+ guard id: id, '_guard'.
+ guard compileGuard: compiler.
+ compiler addOnLine: 'ifFalse: [ ^ self error ].'
+ ].
+!
+
+compileTokenWhitespace: node
+ compiler add: 'context atWs ifFalse: ['.
+ compiler indent.
+ compiler call: (self visit: node whitespace).
+ compiler add: 'context setWs.'.
+ compiler dedent.
+ compiler add: '].'.
+!
+
+notCharSetPredicateBody: node
+ | classificationId classification |
+ self error: 'deprecated.'.
+ classification := node extendClassification: node predicate classification.
+ classificationId := (compiler idFor: classification prefixed: #classification).
+ compiler addConstant: classification as: classificationId.
+
+ compiler addOnLine: '(', classificationId, ' at: context peek asInteger)'.
+ compiler indent.
+ compiler add: ' ifTrue: [ self error: '' predicate not expected'' ]'.
+ compiler add: ' ifFalse: [ nil ].'.
+ compiler dedent.
+!
+
+notMessagePredicateBody: node
+ self error: 'deprecated'.
+ compiler addOnLine: '(context peek ', node message, ')'.
+ compiler indent.
+ compiler add: ' ifTrue: [ self error: '' predicate not expected'' ]'.
+ compiler add: ' ifFalse: [ nil ].'.
+ compiler dedent.
+!
+
+predicateBody: node
+ | tmpId |
+ self error:'deprecated'.
+ tmpId := (compiler idFor: node predicate prefixed: #predicate).
+ compiler addConstant: node predicate as: tmpId.
+
+ compiler addOnLine: '(context atEnd not and: [ ', tmpId , ' value: context uncheckedPeek])'.
+ compiler indent.
+ compiler add: 'ifFalse: [ self error: ''predicate not found'' ]'.
+ compiler add: 'ifTrue: [ context next ].'.
+ compiler dedent.
+!
+
+retvalVar
+ ^ compiler currentReturnVariable
+!
+
+startMethodForNode:node
+ node isMarkedForInline ifTrue:[
+ compiler startInline: (compiler idFor: node).
+ compiler addComment: 'BEGIN inlined code of ' , node printString.
+ compiler indent.
+ ] ifFalse:[
+ compiler startMethod: (compiler idFor: node).
+ compiler addComment: 'GENERATED by ' , node printString.
+ compiler allocateReturnVariable.
+ ].
+
+ "Created: / 23-04-2015 / 15:51:06 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+ "Modified: / 23-04-2015 / 19:13:25 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+ "Modified (comment): / 23-04-2015 / 21:31:24 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+stopMethodForNode:aPPCNode
+ ^ aPPCNode isMarkedForInline ifTrue:[
+ compiler dedent.
+ compiler add: '"END inlined code of ' , aPPCNode printString , '"'.
+ compiler stopInline.
+ ] ifFalse:[
+ compiler stopMethod
+ ].
+
+ "Created: / 23-04-2015 / 15:51:09 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+ "Modified: / 23-04-2015 / 18:35:41 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+! !
+
+!PPCCodeGenerator methodsFor:'traversing - caching'!
+
+cache: node value: retval
+ "this is compiler thing, not mine"
+!
+
+cachedDetected: node
+ ^ compiler checkCache: (compiler idFor: node)
+!
+
+isCached: node
+ ^ (compiler checkCache: (compiler idFor: node)) isNil not
+! !
+
+!PPCCodeGenerator methodsFor:'visiting'!
+
+visitActionNode: node
+ compiler addConstant: node block as: (compiler idFor: node).
+
+ compiler addVariable: 'element'.
+ compiler add: 'element := '.
+ compiler callOnLine: (self visit: node child).
+ compiler add: 'error ifFalse: [ ^ ', (compiler idFor: node), ' value: element ].'.
+ compiler add: '^ failure'.
+
+ "Modified: / 23-04-2015 / 15:59:00 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+visitAndNode: node
+ | mementoVar |
+
+ mementoVar := compiler allocateTemporaryVariableNamed: 'memento'.
+ compiler add: (compiler smartRemember: node child to: mementoVar).
+
+ compiler codeStoreValueOf: [ self visit: node child ] intoVariable: self retvalVar.
+ compiler add: (compiler smartRestore: node child from: mementoVar).
+
+ compiler codeReturn.
+
+ "Modified: / 23-04-2015 / 15:59:07 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+visitAnyNode: node
+
+ compiler codeReturn: 'context next ifNil: [ error := true. ].'.
+
+ "Modified: / 23-04-2015 / 20:52:15 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+visitCharSetPredicateNode: node
+
+ | classification classificationId |
+ classification := node extendClassification: node predicate classification.
+ classificationId := compiler idFor: classification prefixed: #classification.
+ compiler addConstant: classification as: classificationId.
+
+ compiler addOnLine: '(', classificationId, ' at: context peek asInteger)'.
+ compiler indent.
+ compiler add: 'ifFalse: [ self error: ''predicate not found'' ]'.
+ compiler add: 'ifTrue: [ '.
+ compiler codeReturn: 'context next'.
+ compiler add: '].'.
+ compiler dedent.
+!
+
+visitCharacterNode: node
+ | chid |
+ node character ppcPrintable ifTrue: [
+ chid := node character storeString
+ ] ifFalse: [
+ chid := compiler idFor: node character prefixed: #char.
+ compiler addConstant: (Character value: node character asInteger) as: chid .
+ ].
+
+ compiler add: '(context peek == ', chid, ')'.
+ compiler indent.
+ compiler add: 'ifFalse: [ self error: ''', node character asInteger asString, ' expected'' at: context position ] '.
+ compiler add: 'ifTrue: [ '.
+ compiler codeReturn: 'context next'.
+ compiler add: '].'.
+ compiler dedent.
+!
+
+visitChild: child of: node
+ | |
+
+ (self isOpen: child) ifTrue: [
+ "already processing..."
+ ^ nil
+ ].
+
+ "TODO JK: this is is wrong,.. to tired now to fix this :("
+" (self isCached: child) ifTrue: [
+ node replace: child with: (self cachedValue: child).
+ ^ nil
+ ].
+"
+ ^ self visit: child.
+!
+
+visitChoiceNode: node
+ | firsts guard whitespaceConsumed |
+
+
+ whitespaceConsumed := false.
+ firsts := (node firstSetSuchThat: [ :e | (e isKindOf: PPCTrimmingTokenNode) or: [ e isTerminal ] ]).
+
+
+ compiler addVariable: 'element'.
+ "If we start with trimming token, we should invoke the whitespace parser"
+ (firsts allSatisfy: [ :e | e isKindOf: PPCTrimmingTokenNode ]) ifTrue: [
+ self compileTokenWhitespace: firsts anyOne.
+ whitespaceConsumed := true.
+ ].
+
+ 1 to: node children size do: [ :idx | |child allowGuard |
+ child := node children at: idx.
+" allowGuard := ((child isKindOf: PPCTrimmingTokenNode) and: [ whitespaceConsumed not ]) not.
+"
+ allowGuard := whitespaceConsumed.
+
+ (allowGuard and: [arguments guards and: [ (guard := PPCGuard on: child) makesSense ]]) ifTrue: [
+ guard id: (compiler idFor: guard prefixed: #guard).
+ guard compileGuard: compiler.
+ compiler add: ' ifTrue: [ '.
+ compiler indent.
+ compiler add: 'self clearError.'.
+ compiler codeStoreValueOf: [self visit: child] intoVariable: 'element'.
+ compiler add: 'error ifFalse: [ ^ element ].'.
+ compiler dedent.
+ compiler add: ' ].'.
+ ] ifFalse: [
+ compiler add: 'self clearError.'.
+ compiler codeStoreValueOf: [self visit: child] intoVariable: 'element'.
+ compiler add: 'error ifFalse: [ ^ element ].'.
+ ]
+ ].
+ compiler add: '^ self error: ''no choice suitable'''.
+
+ "Modified: / 23-04-2015 / 21:40:23 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+visitEndOfFileNode: node
+ compiler codeReturn: 'context atEnd ifTrue: [ #EOF ] ifFalse: [ self error: ''EOF expected!!'' ].'.
+!
+
+visitForwardNode: node
+
+ compiler codeStoreValueOf: [ self visit: node child ] intoVariable: self retvalVar.
+ compiler codeReturn.
+!
+
+visitLiteralNode: node
+ | positionVar encodedLiteral |
+ encodedLiteral := node encodeQuotes: node literal.
+ positionVar := compiler allocateTemporaryVariableNamed: 'position'.
+
+ compiler codeAssign: 'context position.' to: positionVar.
+ compiler add: '((context next: ', node literal size asString, ') = #''', encodedLiteral, ''') ifTrue: ['.
+ compiler codeReturn: '#''', encodedLiteral, ''' '.
+ compiler add: '] ifFalse: ['.
+ compiler add: ' context position: ', positionVar, '.'.
+ compiler add: ' self error: ''', encodedLiteral, ' expected'' at: position'.
+ compiler add: '].'.
+!
+
+visitMessagePredicateNode: node
+ compiler add: '(context peek ', node message, ') ifFalse: ['.
+ compiler add: ' self error: ''predicate not found'''.
+ compiler add: '] ifTrue: [ '.
+ compiler codeReturn: ' context next'.
+ compiler add: '].'.
+
+ "Modified: / 23-04-2015 / 18:39:03 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+visitNilNode: node
+
+ compiler codeReturn: 'nil.'.
+!
+
+visitNotCharSetPredicateNode: node
+ | classificationId classification |
+ classification := node extendClassification: node predicate classification.
+ classificationId := (compiler idFor: classification prefixed: #classification).
+ compiler addConstant: classification as: classificationId.
+
+ compiler addOnLine: '(', classificationId, ' at: context peek asInteger)'.
+ compiler indent.
+ compiler add: ' ifTrue: [ self error: '' predicate not expected'' ]'.
+ compiler add: ' ifFalse: ['.
+ compiler codeReturn: 'nil'.
+ compiler add: '].'.
+ compiler dedent.
+!
+
+visitNotLiteralNode: node
+ | encodedLiteral size |
+ encodedLiteral := node encodeQuotes: node literal.
+ size := node literal size asString.
+
+ compiler add: '((context peek: ', size, ') =#''', encodedLiteral, ''')'.
+ compiler indent.
+ compiler add: 'ifTrue: [ self error: ''', encodedLiteral, ' not expected'' ]'.
+ compiler add: 'ifFalse: [ '.
+ compiler codeReturn: 'nil' .
+ compiler add: '].'.
+ compiler dedent.
+!
+
+visitNotMessagePredicateNode: node
+ compiler addOnLine: '(context peek ', node message, ')'.
+ compiler indent.
+ compiler add: ' ifTrue: [ '.
+ compiler codeError: 'predicate not expected'.
+ compiler add: '] ifFalse: ['.
+ compiler codeReturn: 'nil'.
+ compiler add: ' ].'.
+ compiler dedent.
+!
+
+visitNotNode: node
+
+
+ compiler addVariable: 'memento'.
+ compiler add: (compiler smartRemember: node child).
+
+ compiler call: (self visit: node child).
+ compiler add: (compiler smartRestore: node child).
+
+ compiler add: '^ error ifFalse: [ self error ] ifTrue: [ self clearError. nil ]'.
+!
+
+visitOptionalNode: node
+ compiler codeStoreValueOf: [ self visit: node child ] intoVariable: self retvalVar.
+ compiler add: 'error ifTrue: [ '.
+ compiler add: ' self clearError. '.
+ compiler codeAssign: 'nil.' to: self retvalVar.
+ compiler add: '].'.
+ compiler codeReturn.
+!
+
+visitPluggableNode: node
+ | blockId |
+ blockId := compiler idFor: node block prefixed: #block.
+
+ compiler addConstant: node block as: blockId.
+ compiler codeReturn: blockId, ' value: context.'.
+!
+
+visitPlusNode: node
+ | elementVar |
+
+ elementVar := compiler allocateTemporaryVariableNamed: 'element'.
+
+ compiler codeAssign: 'OrderedCollection new.' to: self retvalVar.
+ compiler codeStoreValueOf: [ self visit: node child ] intoVariable: elementVar.
+
+ compiler add: 'error ifTrue: [ self error: ''at least one occurence expected'' ] ifFalse: ['.
+ compiler indent.
+ compiler add: self retvalVar , ' add: ',elementVar , '.'.
+
+ compiler codeStoreValueOf: [ self visit: node child ] intoVariable: elementVar.
+ compiler add: '[ error ] whileFalse: ['.
+ compiler indent.
+ compiler add: self retvalVar , ' add: ',elementVar , '.'.
+ compiler codeStoreValueOf: [ self visit: node child ] intoVariable: elementVar.
+ compiler dedent.
+ compiler add: '].'.
+ compiler add: 'self clearError.'.
+ compiler codeReturn: self retvalVar , ' asArray.'.
+ compiler dedent.
+ compiler add: '].'.
+
+ "Modified (comment): / 23-04-2015 / 21:30:49 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+visitPredicateNode: node
+ | pid |
+ pid := (compiler idFor: node predicate prefixed: #predicate).
+
+ compiler addConstant: node predicate as: pid.
+
+ compiler add: '(context atEnd not and: [ ', pid , ' value: context uncheckedPeek])'.
+ compiler indent.
+ compiler add: 'ifFalse: [ self error: ''predicate not found'' ]'.
+ compiler add: 'ifTrue: [ ', self retvalVar ,' := context next ].'.
+ compiler dedent.
+ compiler codeReturn.
+
+ "Modified: / 23-04-2015 / 21:48:11 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+visitSequenceNode: node
+
+ | elementVar mementoVar |
+
+ elementVar := compiler allocateTemporaryVariableNamed: 'element'.
+ mementoVar := compiler allocateTemporaryVariableNamed: 'memento'.
+
+ compiler add: (compiler smartRemember: node to: mementoVar).
+ compiler codeAssign: 'Array new: ', node children size asString, '.' to: self retvalVar.
+ self addGuard: node.
+
+ 1 to: (node children size) do: [ :idx | |child|
+ child := node children at: idx.
+ compiler codeStoreValueOf: [ self visit: child ] intoVariable: elementVar.
+
+ compiler add: 'error ifTrue: [ ', (compiler smartRestore: node) ,' ^ failure ].'.
+ compiler add: self retvalVar , ' at: ', idx asString, ' put: ',elementVar,'.'.
+ ].
+ compiler codeReturn
+
+ "Modified: / 23-04-2015 / 22:03:11 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+visitStarAnyNode: node
+
+ compiler addVariable: 'retval size'.
+ compiler add: 'size := context size - context position.'.
+ compiler add: 'retval := Array new: size.'.
+ compiler add: '(1 to: size) do: [ :e | retval at: e put: context next ].'.
+ compiler add: '^ retval'.
+
+!
+
+visitStarCharSetPredicateNode: node
+ | classification classificationId |
+
+
+ classification := node extendClassification: node predicate classification.
+ classificationId := compiler idFor: classification prefixed: #classification.
+ compiler addConstant: classification as: classificationId.
+
+ compiler codeAssign: 'OrderedCollection new.' to: self retvalVar.
+ compiler add: '[ ', classificationId, ' at: context peek asInteger ] whileTrue: ['.
+ compiler indent.
+ compiler add: self retvalVar, ' add: context next.'.
+ compiler dedent.
+ compiler add: '].'.
+ compiler codeReturn: 'retval asArray'.
+!
+
+visitStarMessagePredicateNode: node
+
+ compiler codeAssign: 'OrderedCollection new.' to: self retvalVar.
+ compiler add: '[ context peek ', node message, ' ] whileTrue: ['.
+ compiler indent.
+ compiler add: self retvalVar, ' add: context next.'.
+ compiler dedent.
+ compiler add: '].'.
+ compiler codeReturn: 'retval asArray'.
+!
+
+visitStarNode: node
+ | elementVar |
+
+ elementVar := compiler allocateTemporaryVariableNamed: 'element'.
+
+ compiler codeAssign: 'OrderedCollection new.' to: self retvalVar.
+ compiler codeStoreValueOf: [ self visit: node child ] intoVariable: elementVar.
+ compiler add: '[ error ] whileFalse: ['.
+ compiler indent.
+ compiler add: self retvalVar, ' add: element.'.
+ compiler codeStoreValueOf: [ self visit: node child ] intoVariable: elementVar.
+ compiler dedent.
+ compiler add: '].'.
+ compiler codeClearError.
+ compiler codeReturn: self retvalVar, ' asArray'.
+!
+
+visitSymbolActionNode: node
+ | elementVar |
+
+ elementVar := compiler allocateTemporaryVariableNamed: 'element'.
+ compiler codeStoreValueOf: [ self visit: node child ] intoVariable: elementVar.
+ compiler add: 'error ifFalse: [ '.
+ compiler codeReturn: elementVar, ' ', node block asString, '.'.
+ compiler add: '] ifTrue: ['.
+ compiler codeReturn: 'failure'.
+ compiler add: ']'.
+!
+
+visitTokenActionNode: node
+ "
+ Actually, do nothing, we are in Token mode and the
+ child does not return any result and token takes only
+ the input value.
+ "
+
+ compiler add: '^ '.
+ compiler callOnLine: (node child compileWith: compiler).
+!
+
+visitTokenNode: node
+ | startVar endVar |
+ startVar := compiler allocateTemporaryVariableNamed: 'start'.
+ endVar := compiler allocateTemporaryVariableNamed: 'end'.
+
+ compiler codeAssign: 'context position + 1.' to: startVar.
+ compiler codeStoreValueOf: [ self visit: node child ] intoVariable: #whatever.
+ compiler add: 'error ifFalse: [ '.
+ compiler indent.
+ compiler codeAssign: 'context position.' to: endVar.
+
+ compiler codeReturn: node tokenClass asString, ' on: (context collection)
+ start: ', startVar, '
+ stop: ', endVar, '
+ value: nil.'.
+ compiler dedent.
+ compiler add: '].'.
+!
+
+visitTokenSequenceNode: node
+
+
+ compiler addVariable: 'memento'.
+ compiler add: (compiler smartRemember: node).
+
+" self addGuard: compiler."
+
+ compiler codeStoreValueOf: [ self visit: (node children at: 1) ] intoVariable: #whatever.
+ compiler add: 'error ifTrue: [ ^ failure ].'.
+
+ 2 to: (node children size) do: [ :idx | |child|
+ child := node children at: idx.
+ compiler codeStoreValueOf: [ self visit: child ] intoVariable: #whatever.
+ compiler add: 'error ifTrue: [ ', (compiler smartRestore: node) ,' ^ failure ].'.
+ ].
+!
+
+visitTokenStarMessagePredicateNode: node
+
+ compiler add: '[ context peek ', node message,' ] whileTrue: ['.
+ compiler indent.
+ compiler add: 'context next'.
+ compiler indent.
+ compiler dedent.
+ compiler add: '].'.
+!
+
+visitTokenStarSeparatorNode: node
+
+ compiler add: 'context skipSeparators.'.
+!
+
+visitTrimNode: node
+ | mementoVar |
+ "TODO: This ignores the TrimmingParser trimmer object!!"
+
+ mementoVar := compiler allocateTemporaryVariableNamed: 'memento'.
+
+ compiler add: (compiler smartRemember: node child to: mementoVar).
+ compiler add: 'context skipSeparators.'.
+
+ compiler codeStoreValueOf: [ self visit: node child ] intoVariable: self retvalVar.
+
+ compiler add: 'error ifTrue: [ '.
+ compiler indent.
+ compiler add: (compiler smartRestore: node child from: mementoVar).
+ compiler codeReturn.
+ compiler dedent.
+ compiler add: '] ifFalse: [' .
+ compiler indent.
+ compiler add: 'context skipSeparators.'.
+ compiler codeReturn.
+ compiler dedent.
+ compiler add: '].'.
+!
+
+visitTrimmingTokenNode: node
+ | id guard startVar endVar |
+
+ startVar := compiler allocateTemporaryVariableNamed: 'start'.
+ endVar := compiler allocateTemporaryVariableNamed: 'end'.
+
+ id := compiler idFor: node.
+" (id beginsWith: 'kw') ifTrue: [ self halt. ]."
+ "self compileFirstWhitespace: compiler."
+ self compileTokenWhitespace: node.
+
+ (arguments guards and: [(guard := PPCGuard on: node) makesSense]) ifTrue: [
+ compiler add: 'context atEnd ifTrue: [ ^ self error ].'.
+ guard id: id, '_guard'.
+ guard compileGuard: compiler.
+ compiler addOnLine: 'ifFalse: [ ^ self error ].'
+ ].
+
+ compiler codeAssign: 'context position + 1.' to: startVar.
+ compiler codeStoreValueOf: [ self visit: node child ] intoVariable: #whatever.
+ compiler add: 'error ifFalse: [ '.
+ compiler indent.
+ compiler codeAssign: 'context position.' to: endVar.
+
+" self compileSecondWhitespace: compiler."
+ self compileTokenWhitespace: node.
+
+ compiler codeReturn: node tokenClass asString, ' on: (context collection)
+ start: ', startVar, '
+ stop: ', endVar, '
+ value: nil'.
+ compiler dedent.
+ compiler add: '].'
+!
+
+visitUnknownNode: node
+ | compiledChild compiledParser id |
+
+ id := compiler idFor: node.
+
+ compiledParser := node parser copy.
+ "Compile all the children and call compiled version of them instead of the original one"
+ compiledParser children do: [ :child |
+ compiledChild := self visit: child.
+ compiledParser replace: child with: compiledChild bridge.
+ ].
+
+ compiler addConstant: compiledParser as: id.
+
+ compiler codeClearError.
+ compiler add: '(', self retvalVar, ' := ', id, ' parseOn: context) isPetitFailure'.
+ compiler indent.
+ compiler add: ' ifTrue: [self error: retval message at: ', self retvalVar, ' position ].'.
+ compiler dedent.
+ compiler add: 'error := ', self retvalVar, ' isPetitFailure.'.
+ compiler codeReturn.
+! !
+