--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/compiler/extensions.st Sun Oct 26 01:03:31 2014 +0000
@@ -0,0 +1,858 @@
+"{ Package: 'stx:goodies/petitparser/compiler' }"!
+
+!Character methodsFor:'*petitcompiler'!
+
+ppcPrintable
+ ^ self asInteger > 31 and: [ self asInteger < 127 ]
+! !
+
+!Object methodsFor:'*petitcompiler'!
+
+isInlinedMethod
+ ^ false
+! !
+
+!PPActionParser methodsFor:'*petitcompiler'!
+
+asCompilerNode
+ ^ PPCActionNode new
+ name: self name;
+ block: block;
+ child: parser;
+ yourself
+! !
+
+!PPActionParser methodsFor:'*petitcompiler'!
+
+compileWith: aPetitCompiler
+ block isSymbol ifTrue: [
+ ^ aPetitCompiler compileSymbolBlock: block for: self
+ ].
+ ^ aPetitCompiler compileBlock: block for: self
+! !
+
+!PPAndParser methodsFor:'*petitcompiler'!
+
+asCompilerNode
+ ^ PPCAndNode new
+ name: self name;
+ child: parser;
+ yourself
+! !
+
+!PPCharSetPredicate methodsFor:'*petitcompiler'!
+
+block
+ ^ block
+! !
+
+!PPCharSetPredicate methodsFor:'*petitcompiler'!
+
+classification
+ ^ classification
+! !
+
+!PPCharSetPredicate methodsFor:'*petitcompiler'!
+
+equals: anotherPredicate
+ self == anotherPredicate ifTrue: [ ^ true ].
+ self class == anotherPredicate class ifFalse: [ ^ false ].
+
+ ^ classification = anotherPredicate classification.
+! !
+
+!PPChoiceParser methodsFor:'*petitcompiler'!
+
+asCompilerNode
+ ^ PPCChoiceNode new
+ name: self name;
+ children: parsers;
+ yourself
+! !
+
+!PPChoiceParser methodsFor:'*petitcompiler'!
+
+compileWith: aPetitCompiler
+ ^ aPetitCompiler compileChoice: self
+! !
+
+!PPContext methodsFor:'*petitcompiler'!
+
+asCompiledParserContext
+ ^ PPCContext new
+ stream: stream;
+ yourself
+
+! !
+
+!PPContext methodsFor:'*petitcompiler'!
+
+comment
+ ^ self globalAt: #comment ifAbsent: [ nil ].
+! !
+
+!PPContext methodsFor:'*petitcompiler'!
+
+comment: value
+ ^ self globalAt: #comment put: value
+! !
+
+!PPContext methodsFor:'*petitcompiler'!
+
+compiledParser
+ ^ self globalAt: #compiledParser
+! !
+
+!PPContext methodsFor:'*petitcompiler'!
+
+compiledParser: aPPParser
+ ^ self globalAt: #compiledParser put: aPPParser
+! !
+
+!PPContext methodsFor:'*petitcompiler'!
+
+lastTokenResult
+ ^ scanner lastResult
+! !
+
+!PPContext methodsFor:'*petitcompiler'!
+
+lwRemember
+ ^ self position
+! !
+
+!PPContext methodsFor:'*petitcompiler'!
+
+lwRestore: position
+ ^ self position: position
+! !
+
+!PPContext methodsFor:'*petitcompiler'!
+
+matchToken: id
+ ^ scanner matchToken: id
+! !
+
+!PPContext methodsFor:'*petitcompiler'!
+
+nextToken
+ scanner next
+! !
+
+!PPContext methodsFor:'*petitcompiler'!
+
+nextToken: id
+ ^ scanner next: id
+! !
+
+!PPContext methodsFor:'*petitcompiler'!
+
+peek: anInteger
+ ^ stream peek: anInteger
+! !
+
+!PPContext methodsFor:'*petitcompiler'!
+
+whitespace
+ ^ self globalAt: #whitespace ifAbsent: [ nil ].
+! !
+
+!PPContext methodsFor:'*petitcompiler'!
+
+whitespace: value
+ ^ self globalAt: #whitespace put: value
+! !
+
+!PPDelegateParser methodsFor:'*petitcompiler'!
+
+asCompilerNode
+ self class == PPDelegateParser ifTrue: [
+ ^ PPCForwardNode new
+ name: self name;
+ child: parser;
+ yourself
+ ].
+ ^ super asCompilerNode
+! !
+
+!PPDelegateParser methodsFor:'*petitcompiler'!
+
+compileWith: aPetitCompiler
+ (self class == PPDelegateParser) ifTrue: [
+ (self name notNil and: [ parser name isNil ]) ifTrue: [
+ parser name: self name.
+ ^ parser compileWith: aPetitCompiler.
+ ].
+
+ (self name notNil and: [ parser name notNil ]) ifTrue: [
+ ^ aPetitCompiler compileDelegate: self.
+ ]
+ ].
+ ^ super compileWith: aPetitCompiler.
+! !
+
+!PPEpsilonParser methodsFor:'*petitcompiler'!
+
+asCompilerNode
+ ^ PPCNilNode new
+! !
+
+!PPEpsilonParser methodsFor:'*petitcompiler'!
+
+compileWith: aPetitCompiler
+ ^ aPetitCompiler compileNil
+! !
+
+!PPFailure methodsFor:'*petitcompiler'!
+
+context: aPPContext
+ context := aPPContext
+! !
+
+!PPFailure methodsFor:'*petitcompiler'!
+
+message: text
+ message := text
+! !
+
+!PPFailure methodsFor:'*petitcompiler'!
+
+position: anInteger
+ position := anInteger
+! !
+
+!PPLiteralObjectParser methodsFor:'*petitcompiler'!
+
+asCompilerNode
+ ^ PPCCharacterNode new
+ character: literal;
+ name: self name;
+ yourself
+! !
+
+!PPLiteralObjectParser methodsFor:'*petitcompiler'!
+
+compileWith: aPetitCompiler
+ ^ aPetitCompiler compileCharacter: literal.
+! !
+
+!PPLiteralObjectParser methodsFor:'*petitcompiler'!
+
+firstCharParser
+ ^ self
+! !
+
+!PPLiteralParser methodsFor:'*petitcompiler'!
+
+id
+ ^ literal printString
+! !
+
+!PPLiteralSequenceParser methodsFor:'*petitcompiler'!
+
+asCompilerNode
+ ^ PPCLiteralNode new
+ literal: literal;
+ name: self name;
+ yourself
+! !
+
+!PPLiteralSequenceParser methodsFor:'*petitcompiler'!
+
+compileWith: aPetitCompiler
+ ^ aPetitCompiler compileLiteral: literal.
+! !
+
+!PPLiteralSequenceParser methodsFor:'*petitcompiler'!
+
+firstCharParser
+ ^ literal first asParser
+! !
+
+!PPNotParser methodsFor:'*petitcompiler'!
+
+asCompilerNode
+ ^ PPCNotNode new
+ child: parser;
+ name: self name;
+ yourself
+! !
+
+!PPNotParser methodsFor:'*petitcompiler'!
+
+compileWith: aPetitCompiler
+ ^ aPetitCompiler compileNot: self
+! !
+
+!PPNotParser methodsFor:'*petitcompiler'!
+
+firstCharParser
+ ^ parser firstCharParser not
+! !
+
+!PPOptionalParser methodsFor:'*petitcompiler'!
+
+asCompilerNode
+ ^ PPCOptionalNode new
+ name: self name;
+ child: parser;
+ yourself
+
+" ^ super asCompilerNode "
+! !
+
+!PPOptionalParser methodsFor:'*petitcompiler'!
+
+compileWith: aPetitCompiler
+ ^ aPetitCompiler compileOptional: self
+! !
+
+!PPParser methodsFor:'*petitcompiler'!
+
+asCompilerNode
+ ^ PPCUnknownNode new
+ parser: self;
+ name: self name;
+ yourself
+! !
+
+!PPParser methodsFor:'*petitcompiler'!
+
+asCompilerTree
+ ^ self transform: [ :p | p asCompilerNode ]
+! !
+
+!PPParser methodsFor:'*petitcompiler'!
+
+bridge
+ ^ self
+! !
+
+!PPParser methodsFor:'*petitcompiler'!
+
+cached
+ "Faster way of memoizing --- it ignores context information, therefore it is not suitable for context-sensitive rules"
+
+ ^ PPCachingParser on: self
+! !
+
+!PPParser methodsFor:'*petitcompiler'!
+
+compile
+ ^ self compile: #PPGeneratedParser
+! !
+
+!PPParser methodsFor:'*petitcompiler'!
+
+compile: name
+ ^ self compile: name parameters: #()
+! !
+
+!PPParser methodsFor:'*petitcompiler'!
+
+compile: name andParse: input
+ ^ (self compile: name) parse: input
+! !
+
+!PPParser methodsFor:'*petitcompiler'!
+
+compile: name parameters: params
+ ^ (PPCCompiler new parameters: params; compile: self as: name) new
+! !
+
+!PPParser methodsFor:'*petitcompiler'!
+
+compileWith: aPetitCompiler
+ | compiled |
+ self children do: [ :child |
+ compiled := child compileWith: aPetitCompiler.
+ self replace: child with: compiled bridge.
+ ].
+ ^ aPetitCompiler compileBridgeTo: self
+! !
+
+!PPParser methodsFor:'*petitcompiler'!
+
+compileWithParameters: params
+ ^ self compile: #PPGeneratedParser parameters: params
+! !
+
+!PPParser methodsFor:'*petitcompiler'!
+
+first
+ first ifNil: [
+ first := self firstSet
+ ].
+ ^ first
+! !
+
+!PPParser methodsFor:'*petitcompiler'!
+
+first: firstSet
+ first := firstSet
+! !
+
+!PPParser methodsFor:'*petitcompiler'!
+
+firstSetSuchThat: block
+ ^ self firstSetSuchThat: block into: (OrderedCollection new) openSet: IdentitySet new.
+! !
+
+!PPParser methodsFor:'*petitcompiler'!
+
+firstSetSuchThat: block into: aCollection openSet: aSet
+ (aSet includes: self) ifTrue: [ ^ aCollection ].
+ aSet add: self.
+
+ (block value: self) ifTrue: [aCollection add: self. ^ aCollection ].
+ self children do: [ :child |
+ child firstSetSuchThat: block into: aCollection openSet: aSet
+ ].
+ ^ aCollection
+! !
+
+!PPParser methodsFor:'*petitcompiler'!
+
+id
+ self name ifNotNil: [ ^ self name ].
+ ^ self hash asString
+! !
+
+!PPParser methodsFor:'*petitcompiler'!
+
+isCompiled
+ ^ false
+! !
+
+!PPParser methodsFor:'*petitcompiler'!
+
+isContextFree
+ ^ self propertyAt: #isContextFree ifAbsentPut:
+ [ self allParsers allSatisfy: [ :p | p isContextFreePrim ] ].
+
+! !
+
+!PPParser methodsFor:'*petitcompiler'!
+
+isContextFreePrim
+ ^ true
+! !
+
+!PPParser methodsFor:'*petitcompiler'!
+
+isToken
+ ^ false
+! !
+
+!PPParser methodsFor:'*petitcompiler'!
+
+isTokenParser
+ ^ false
+! !
+
+!PPParser methodsFor:'*petitcompiler'!
+
+optimize
+ ^ self copy
+! !
+
+!PPParser methodsFor:'*petitcompiler'!
+
+optimized
+ ^ self copy
+! !
+
+!PPParser methodsFor:'*petitcompiler'!
+
+trimmingToken
+ | ws |
+ ws := #space asParser star.
+ ^ ((ws, (PPTokenParser on: self), ws) ==> #second)
+ name: 'trimmingToken';
+ yourself
+! !
+
+!PPPluggableParser methodsFor:'*petitcompiler'!
+
+acceptsEpsilon
+ ^ true
+! !
+
+!PPPluggableParser methodsFor:'*petitcompiler'!
+
+asCompilerNode
+ ^ PPCPluggableNode new
+ block: block;
+ name: self name;
+ yourself
+! !
+
+!PPPossessiveRepeatingParser methodsFor:'*petitcompiler'!
+
+asCompilerNode
+ ((self min = 0) and: [ self max = SmallInteger maxVal ]) ifTrue: [
+ ^ PPCStarNode new
+ name: self name;
+ child: parser;
+ yourself
+ ].
+
+ ((self min = 1) and: [ self max = SmallInteger maxVal ]) ifTrue: [
+ ^ PPCPlusNode new
+ name: self name;
+ child: parser;
+ yourself
+ ].
+ ^ super asCompilerNode
+! !
+
+!PPPossessiveRepeatingParser methodsFor:'*petitcompiler'!
+
+compileWith: aPetitCompiler
+ ((self min = 1) and: [ self max = SmallInteger maxVal ]) ifTrue: [
+ ^ aPetitCompiler compilePlus: self.
+ ].
+ ((self min = 0) and: [ self max = SmallInteger maxVal ]) ifTrue: [
+ ^ aPetitCompiler compileStar: self.
+ ].
+
+ ^ super compileWith: aPetitCompiler.
+! !
+
+!PPPossessiveRepeatingParser methodsFor:'*petitcompiler'!
+
+optimized
+ ^ (PPFastPossessiveRepeatingParser on: parser)
+ setMin: min;
+ setMax: max;
+ yourself
+! !
+
+!PPPredicateObjectParser methodsFor:'*petitcompiler'!
+
+asCompilerNode
+ ^ PPCPredicateNode new
+ name: self name;
+ predicate: predicate;
+ yourself
+! !
+
+!PPPredicateObjectParser methodsFor:'*petitcompiler'!
+
+compileWith: aPetitCompiler
+ (predicateMessage = 'input expected') ifTrue: [
+ ^ aPetitCompiler compileAny.
+ ].
+ ^ aPetitCompiler compilePredicate: predicate.
+! !
+
+!PPPredicateObjectParser methodsFor:'*petitcompiler'!
+
+firstCharParser
+ ^ self
+! !
+
+!PPSequenceParser methodsFor:'*petitcompiler'!
+
+asCompilerNode
+ ^ PPCSequenceNode new
+ children: parsers;
+ name: self name;
+ yourself
+! !
+
+!PPSequenceParser methodsFor:'*petitcompiler'!
+
+checkFirst: context
+ first isEmpty ifTrue: [ ^ true ].
+
+ first do: [ :elem |
+ (context matchToken: elem id) ifTrue: [ ^ true ].
+ ].
+ ^ false
+! !
+
+!PPSequenceParser methodsFor:'*petitcompiler'!
+
+compileWith: aPetitCompiler
+ ^ aPetitCompiler compileSequence: self.
+! !
+
+!PPSequenceParser methodsFor:'*petitcompiler'!
+
+firstSetSuchThat: block into: aCollection openSet: aSet
+ (aSet includes: self) ifTrue: [ ^ aCollection ].
+ aSet add: self.
+
+ (block value: self) ifTrue: [ aCollection add: self. ^ aCollection ].
+
+ self children do: [ :child |
+ child firstSetSuchThat: block into: aCollection openSet: aSet.
+ child acceptsEpsilon ifFalse: [ ^ aCollection ]
+ ].
+ ^ aCollection
+! !
+
+!PPSequenceParser methodsFor:'*petitcompiler'!
+
+optimized
+ ^ PPFastSequenceParser withAll: parsers
+! !
+
+!PPSmalltalkGrammar methodsFor:'*petitcompiler'!
+
+comment
+ ^ $" asParser, $" asParser negate star, $" asParser.
+! !
+
+!PPSmalltalkGrammar methodsFor:'*petitcompiler'!
+
+updateContext: aPPContext
+ super updateContext: aPPContext.
+"
+ aPPContext globalAt: #comment ifAbsentPut: [ self comment ].
+ aPPContext globalAt: #whitespace ifAbsentPut: [ PPSmalltalkWhitespaceParser new ].
+"
+! !
+
+!PPSmalltalkGrammar methodsFor:'*petitcompiler'!
+
+whitespace
+ ^ #space asParser plus
+! !
+
+!PPSmalltalkGrammar methodsFor:'*petitcompiler'!
+
+whitespaceOld
+ ^ #space asParser plus
+! !
+
+!PPSmalltalkGrammar methodsFor:'*petitcompiler'!
+
+whitespaceX
+ whitespace ifNil: [
+ whitespace := PPSmalltalkWhitespaceParser new
+ ].
+ ^ whitespace
+! !
+
+!PPSmalltalkTokenParser methodsFor:'*petitcompiler'!
+
+compileWith: aPetitCompiler
+
+ ^ aPetitCompiler compileSmalltalkToken: self.
+! !
+
+!PPSmalltalkTokenParser methodsFor:'*petitcompiler'!
+
+parseOnX: aPPContext
+ | memento comments token |
+
+ memento := aPPContext remember.
+ comments := self
+ parseComments: #()
+ on: aPPContext.
+ token := super parseOn: aPPContext.
+ token isPetitFailure ifTrue: [
+ aPPContext restore: memento.
+ ^ token ].
+ comments := self
+ parseComments: comments
+ on: aPPContext.
+ ^ token comments: comments
+! !
+
+!PPSmalltalkTokenParser methodsFor:'*petitcompiler'!
+
+updateContext: aPPContext
+ aPPContext globalAt: #whitespace ifAbsentPut: PPSmalltalkWhitespaceParser new
+! !
+
+!PPSmalltalkTokenParser methodsFor:'*petitcompiler'!
+
+whitespace
+ ^ PPSmalltalkWhitespaceParser new
+! !
+
+!PPSmalltalkWhitespaceParser methodsFor:'*petitcompiler'!
+
+acceptsEpsilon
+ ^ true
+! !
+
+!PPSmalltalkWhitespaceParser methodsFor:'*petitcompiler'!
+
+acceptsEpsilonOpenSet: set
+ ^ true
+! !
+
+!PPSmalltalkWhitespaceParser methodsFor:'*petitcompiler'!
+
+firstCharParser
+ ^ PPFailingParser new
+! !
+
+!PPStream methodsFor:'*petitcompiler'!
+
+peek: anInteger
+ | endPosition |
+ endPosition := position + anInteger min: readLimit.
+ ^ collection copyFrom: position+1 to: endPosition.
+! !
+
+!PPToken methodsFor:'*petitcompiler'!
+
+= anObject
+ ^ self class = anObject class and: [ self inputValue = anObject inputValue ]
+! !
+
+!PPToken methodsFor:'*petitcompiler'!
+
+hash
+ ^ self inputValue hash
+! !
+
+!PPToken methodsFor:'*petitcompiler'!
+
+isToken
+ ^ true
+! !
+
+!PPTokenParser methodsFor:'*petitcompiler'!
+
+asCompilerNode
+ ^ PPCTokenNode new
+ name: self name;
+ tokenClass: self tokenClass;
+ child: parser;
+ yourself
+! !
+
+!PPTokenParser methodsFor:'*petitcompiler'!
+
+displayName
+ ^ 'TOKEN[', parser displayName, ']'
+! !
+
+!PPTokenParser methodsFor:'*petitcompiler'!
+
+firstSets: aFirstDictionary into: aSet
+ "Or keep empty, if token is a terminal"
+ ^ super firstSets: aFirstDictionary into: aSet
+! !
+
+!PPTokenParser methodsFor:'*petitcompiler'!
+
+id
+ id ifNil: [
+ id := ('TOK[', parser id, ']') asSymbol
+ ].
+ ^ id
+! !
+
+!PPTokenParser methodsFor:'*petitcompiler'!
+
+isFirstSetTerminal
+ ^ false
+! !
+
+!PPTokenParser methodsFor:'*petitcompiler'!
+
+isTokenParser
+ ^ true
+! !
+
+!PPTokenParser methodsFor:'*petitcompiler'!
+
+isUnique
+ unique ifNil: [
+ unique := parser firstSet size = 1 and: [ (parser firstSet anyOne isKindOf: PPLiteralParser) ]
+ ].
+ ^ unique
+! !
+
+!PPTokenParser methodsFor:'*petitcompiler'!
+
+optimize
+ ^ self transform: [ :each | each optimized ]
+! !
+
+!PPTokenParser methodsFor:'*petitcompiler'!
+
+parseOnX: aPPContext
+ (aPPContext matchToken: self id) ifTrue: [
+ ^ aPPContext nextToken: self id.
+ ].
+ ^ PPFailure message: self id, ' not found' context: aPPContext.
+! !
+
+!PPTokenParser methodsFor:'*petitcompiler'!
+
+parser
+ ^ parser
+! !
+
+!PPTokenParser methodsFor:'*petitcompiler'!
+
+startsWith: aCharacter
+ self first do: [:first | (first startsWith: aCharacter) ifTrue: [ ^ true ] ].
+ ^ false
+! !
+
+!PPTokenParser methodsFor:'*petitcompiler'!
+
+whitespace
+ ^ self class whitespace
+! !
+
+!PPTrimmingParser methodsFor:'*petitcompiler'!
+
+asCompilerNode
+ ^ PPCTrimNode new
+ child: parser;
+ name: self name;
+ yourself
+! !
+
+!PPTrimmingParser methodsFor:'*petitcompiler'!
+
+compileWith: aPetitCompiler
+ ^ aPetitCompiler compileTrim: self.
+! !
+
+!PPTrimmingParser methodsFor:'*petitcompiler'!
+
+firstSets: aFirstDictionary into: aSet
+ super firstSets: aFirstDictionary into: aSet
+! !
+
+!UndefinedObject methodsFor:'*petitcompiler'!
+
+asInteger
+ ^ 256
+! !
+
+!UndefinedObject methodsFor:'*petitcompiler'!
+
+isAlphaNumeric
+ ^ false
+! !
+
+!UndefinedObject methodsFor:'*petitcompiler'!
+
+isDigit
+ ^ false
+! !
+
+!UndefinedObject methodsFor:'*petitcompiler'!
+
+isLetter
+ ^ false
+! !
+
+!stx_goodies_petitparser_compiler class methodsFor:'documentation'!
+
+extensionsVersion_HG
+
+ ^ '$Changeset: <not expanded> $'
+! !