"{ Package: 'stx:goodies/petitparser/parsers/smalltalk' }"
PPCompositeParser subclass:#PPSmalltalkGrammar
instanceVariableNames:'array arrayItem arrayLiteral arrayLiteralArray assignment
assignmentToken binary binaryExpression binaryMessage
binaryMethod binaryPragma binaryToken block blockArgument
blockArguments blockArgumentsWith blockArgumentsWithout blockBody
byteLiteral byteLiteralArray cascadeExpression cascadeMessage
char charLiteral charToken expression falseLiteral falseToken
identifier identifierToken keyword keywordExpression
keywordMessage keywordMethod keywordPragma keywordToken literal
message method methodDeclaration methodSequence multiword
nilLiteral nilToken number numberLiteral numberToken parens
period periodToken pragma pragmaMessage pragmas primary return
sequence startExpression startMethod statements string
stringLiteral stringToken symbol symbolLiteral symbolLiteralArray
temporaries trueLiteral trueToken unary unaryExpression
unaryMessage unaryMethod unaryPragma unaryToken variable'
classVariableNames:''
poolDictionaries:''
category:'PetitSmalltalk-Core'
!
PPSmalltalkGrammar comment:'A parser for Smalltalk methods and expressions.'
!
!PPSmalltalkGrammar class methodsFor:'accessing'!
parseExpression: aString
^ self new parseExpression: aString
!
parseExpression: aString onError: aBlock
^ self new parseExpression: aString onError: aBlock
!
parseMethod: aString
^ self new parseMethod: aString
!
parseMethod: aString onError: aBlock
^ self new parseMethod: aString onError: aBlock
! !
!PPSmalltalkGrammar class methodsFor:'testing'!
allowUnderscoreAssignment
^ (Scanner respondsTo: #allowUnderscoreAsAssignment) and: [ Scanner allowUnderscoreAsAssignment ]
! !
!PPSmalltalkGrammar methodsFor:'accessing'!
start
"Default start production."
^ startMethod
!
startExpression
"Start production for the expression."
^ sequence end
!
startMethod
"Start production for the method."
^ method end
! !
!PPSmalltalkGrammar methodsFor:'grammar'!
array
^ ${ asParser smalltalkToken , (expression delimitedBy: periodToken) optional , $} asParser smalltalkToken
!
assignment
^ variable , assignmentToken
!
expression
^ assignment star , cascadeExpression
!
literal
^ numberLiteral / stringLiteral / charLiteral / arrayLiteral / byteLiteral / symbolLiteral / nilLiteral / trueLiteral / falseLiteral
!
message
^ keywordMessage / binaryMessage / unaryMessage
!
method
^ methodDeclaration , methodSequence
!
methodDeclaration
^ keywordMethod / unaryMethod / binaryMethod
!
methodSequence
^ periodToken star , pragmas , periodToken star , temporaries , periodToken star , pragmas , periodToken star , statements
!
parens
^ $( asParser smalltalkToken , expression , $) asParser smalltalkToken
!
pragma
^ $< asParser smalltalkToken , pragmaMessage , $> asParser smalltalkToken
!
pragmas
^ pragma star
!
primary
^ literal / variable / block / parens / array
!
return
^ $^ asParser smalltalkToken , expression
!
sequence
^ temporaries , periodToken star , statements
!
statements
^ (expression wrapped , ((periodToken plus , statements ==> [ :nodes | nodes first , nodes last ])
/ periodToken star)
==> [ :nodes | (Array with: nodes first) , (nodes last) ])
/ (return , periodToken star
==> [ :nodes | (Array with: nodes first) , (nodes last) ])
/ (periodToken star)
!
temporaries
^ ($| asParser smalltalkToken , variable star , $| asParser smalltalkToken) optional ==> [ :nodes | nodes ifNil: [ #() ] ]
!
variable
^ identifierToken
! !
!PPSmalltalkGrammar methodsFor:'grammar-blocks'!
block
^ $[ asParser smalltalkToken , blockBody , $] asParser smalltalkToken
!
blockArgument
^ $: asParser smalltalkToken , variable
!
blockArguments
^ blockArgumentsWith / blockArgumentsWithout
!
blockArgumentsWith
^ blockArgument plus , ($| asParser smalltalkToken / ($] asParser smalltalkToken and ==> [ :node | nil ]))
!
blockArgumentsWithout
^ nil asParser ==> [ :nodes | Array with: #() with: nil ]
!
blockBody
^ blockArguments , sequence
! !
!PPSmalltalkGrammar methodsFor:'grammar-literals'!
arrayItem
^ literal / symbolLiteralArray / arrayLiteralArray / byteLiteralArray
!
arrayLiteral
^ '#(' asParser smalltalkToken , arrayItem star , $) asParser smalltalkToken
!
arrayLiteralArray
^ $( asParser smalltalkToken , arrayItem star , $) asParser smalltalkToken
!
byteLiteral
^ '#[' asParser smalltalkToken , numberLiteral star , $] asParser smalltalkToken
!
byteLiteralArray
^ $[ asParser smalltalkToken , numberLiteral star , $] asParser smalltalkToken
!
charLiteral
^ charToken
!
falseLiteral
^ falseToken
!
nilLiteral
^ nilToken
!
numberLiteral
^ numberToken
!
stringLiteral
^ stringToken
!
symbolLiteral
"This is totally fucked up: The Pharo compiler allows multiple #, arbitrary spaces between the # and the symbol, as well as comments inbetween. And yes, it is used."
^ $# asParser smalltalkToken plus , symbol smalltalkToken ==> [ :tokens | tokens first copyWith: tokens last ]
!
symbolLiteralArray
^ symbol smalltalkToken
!
trueLiteral
^ trueToken
! !
!PPSmalltalkGrammar methodsFor:'grammar-messages'!
binaryExpression
^ unaryExpression , binaryMessage star
!
binaryMessage
^ (binaryToken , unaryExpression) ==> [ :nodes |
Array
with: (Array with: nodes first)
with: (Array with: nodes second) ]
!
cascadeExpression
^ keywordExpression , cascadeMessage star
!
cascadeMessage
^ $; asParser smalltalkToken , message
!
keywordExpression
^ binaryExpression , keywordMessage optional
!
keywordMessage
^ (keywordToken , binaryExpression) plus ==> [ :nodes |
Array
with: (nodes collect: [ :each | each first ])
with: (nodes collect: [ :each | each second ]) ]
!
unaryExpression
^ primary , unaryMessage star
!
unaryMessage
^ unaryToken ==> [ :node |
Array
with: (Array with: node)
with: Array new ]
! !
!PPSmalltalkGrammar methodsFor:'grammar-methods'!
binaryMethod
^ (binaryToken , variable) ==> [ :nodes |
Array
with: (Array with: nodes first)
with: (Array with: nodes second) ]
!
keywordMethod
^ (keywordToken , variable) plus ==> [ :nodes |
Array
with: (nodes collect: [ :each | each first ])
with: (nodes collect: [ :each | each second ]) ]
!
unaryMethod
^ identifierToken ==> [ :node |
Array
with: (Array with: node)
with: Array new ]
! !
!PPSmalltalkGrammar methodsFor:'grammar-pragmas'!
binaryPragma
^ (binaryToken , arrayItem) ==> [ :nodes |
Array
with: (Array with: nodes first)
with: (Array with: nodes second) ]
!
keywordPragma
^ (keywordToken , arrayItem) plus ==> [ :nodes |
Array
with: (nodes collect: [ :each | each first ])
with: (nodes collect: [ :each | each second ]) ]
!
pragmaMessage
^ keywordPragma / unaryPragma / binaryPragma
!
unaryPragma
^ identifierToken ==> [ :node |
Array
with: (Array with: node)
with: (Array new) ]
! !
!PPSmalltalkGrammar methodsFor:'parsing'!
parseExpression: aString
^ self parseExpression: aString onError: [ :msg :pos | self error: msg ]
!
parseExpression: aString onError: aBlock
^ startExpression parse: aString onError: aBlock
!
parseMethod: aString
^ self parseMethod: aString onError: [ :msg :pos | self error: msg ]
!
parseMethod: aString onError: aBlock
^ startMethod parse: aString onError: aBlock
! !
!PPSmalltalkGrammar methodsFor:'primitives'!
binary
^ (PPPredicateObjectParser anyOf: '!!%&*+,-/<=>?@\|~') plus
!
char
^ $$ asParser , #any asParser
!
identifier
^ self class allowUnderscoreAssignment
ifTrue: [ #letter asParser , #word asParser star ]
ifFalse: [
(PPPredicateObjectParser
on: [ :each | each isLetter or: [ each = $_ ] ]
message: 'letter expected') ,
(PPPredicateObjectParser
on: [ :each | each isAlphaNumeric or: [ each = $_ ] ]
message: 'letter or digit expected') star ]
!
keyword
^ identifier , $: asParser
!
multiword
^ keyword plus
!
number
((Smalltalk respondsTo:#isSmalltalkX) and:[ Smalltalk isSmalltalkX ]) ifTrue:[
^ ($- asParser optional , #digit asParser) and , [ :context |
[ Number readSmalltalkSyntaxFrom: context stream ]
on: Error
do: [ :err | PPFailure message: err messageText at: context position ] ]
asParser
] ifFalse:[
^ ($- asParser optional , #digit asParser) and , [ :context |
[ (NumberParser on: context stream) nextNumber ]
on: Error
do: [ :err | PPFailure message: err messageText at: context position ] ]
asParser
]
"Modified: / 07-10-2014 / 21:50:25 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
period
^ $. asParser
!
string
^ $' asParser , ('''''' asParser / $' asParser negate) star , $' asParser
!
symbol
^ unary / binary / multiword / string
!
unary
^ identifier , $: asParser not
! !
!PPSmalltalkGrammar methodsFor:'token'!
assignmentToken
^ self class allowUnderscoreAssignment
ifTrue: [ (':=' asParser / '_' asParser) smalltalkToken ]
ifFalse: [ ':=' asParser smalltalkToken ]
!
binaryToken
^ binary smalltalkToken
!
charToken
^ char smalltalkToken
!
falseToken
^ ('false' asParser , #word asParser not) smalltalkToken
!
identifierToken
^ identifier smalltalkToken
!
keywordToken
^ keyword smalltalkToken
!
nilToken
^ ('nil' asParser , #word asParser not) smalltalkToken
!
numberToken
^ number smalltalkToken
!
periodToken
^ period smalltalkToken
!
stringToken
^ string smalltalkToken
!
trueToken
^ ('true' asParser , #word asParser not) smalltalkToken
!
unaryToken
^ unary smalltalkToken
! !