"======================================================================
|
|   Smalltalk parser definitions.
|
|   $Revision: 1.7.5$
|   $Date: 2000/05/28 16:56:52$
|   $Author: pb$
|
 ======================================================================"


"======================================================================
|
| Copyright 1988-92, 1994-95, 1999, 2000 Free Software Foundation, Inc.
| Written by Steve Byrne.
|
| This file is part of GNU Smalltalk.
|
| GNU Smalltalk is free software; you can redistribute it and/or modify it
| under the terms of the GNU General Public License as published by the Free
| Software Foundation; either version 2, or (at your option) any later version.
| 
| GNU Smalltalk is distributed in the hope that it will be useful, but WITHOUT
| ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
| FOR A PARTICULAR PURPOSE.  See the GNU General Public License for more
| details.
| 
| You should have received a copy of the GNU General Public License along with
| GNU Smalltalk; see the file COPYING.  If not, write to the Free Software
| Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.  
|
 ======================================================================"

Object subclass: #STParser
       instanceVariableNames: 'parseErrorBlock lex tokenBuffer lastNode'
       classVariableNames: 'CurrentParser'
       poolDictionaries: 'VMOtherConstants'
       category: 'System-Compiler'
!

STParser comment:
'My full name is Smalltalk ''Recursive-Descent'' Parser. If you want to
parse some Smalltalk code, ask me.'!

!STParser class methodsFor: 'instance creation'!

on: aFileName
    ^self new init: (STTok on: aFileName)
!

onStream: aStream
    ^self new init: (STTok onStream: aStream)
! !


!STParser methodsFor: 'private'!

init: aStream
    lex := aStream.
    parseErrorBlock := [ :file :line :str |
	^self parseErrorIn: file atLine: line message: str
    ]
! !

!STParser methodsFor: 'tidyness'!

close
    lex close
! !

!STParser methodsFor: 'parsing'!

parseErrorBlock: aBlock
    parseErrorBlock := aBlock
!

parseSmalltalk
    | previousParser |
    previousParser := CurrentParser.
    CurrentParser := self.

    [ self searchMethodListHeader ]
	whileTrue: [ self parseMethodDefinitionList ].

    CurrentParser := previousParser.
    ^self result
!

parseMethodDefinitionList
    "Called after first !, expecting a set of bang terminated
     method definitions, followed by a bang"

    | startPos endPos node selector body source |

    [   self atEnd or: [ self peekTok isSTBangTok ] ] whileFalse: [

	startPos := lex position.
	selector := self parseSelector.
	body := self parseMethodBody.
	endPos := lex position.
	source := lex stream segmentFrom: startPos to: endPos.

	node := lastNode := STMethodDefinitionNode
	    new: selector
	    body: body
	    source: source.

	self record: node source.
	self compile: node
    ].
    self nextTok.
    self endMethodList
!

searchMethodListHeader
    " Parses the stuff to be executed until a
	! <class expression> methodsFor: <category string> ! "

    | startPos endPos node selector body source |

    selector := lastNode := STSelectorNode selector: #Doit args: #().

    [   self atEnd ifTrue: [ ^false ].

	startPos := lex position.
	body := self parseMethodBody.
	endPos := lex position.
	source := lex stream segmentFrom: startPos to: endPos.

	node := lastNode := STMethodDefinitionNode
	    new: selector
	    body: body
	    source: source.

	self record: source.
	self evaluate: node
    ]   whileFalse.
    ^true
!
    
parseSelector
    | t sel | 
    t := self peekTok.
    t isSTIdentifierTok ifTrue: 
	[ ^lastNode := STSelectorNode selector: self nextTok value args: #()].
    
    t isSTKeywordTok ifTrue: [ ^self parseKeywordSelector ].
    t isBinaryOperator ifTrue: 
	[ sel := self nextTok.
	  t := self nextTok.
	  t isSTIdentifierTok ifFalse: 
	      [ ^self parseError: 'expected identifier to follow binary op' ].
	  ^lastNode := STSelectorNode selector: sel value args: (Array with: t value) ].
    ^self parseError: 'invalid method selector'
!

parseKeywordSelector
    | t selector args | 
    selector := ''.
    args := OrderedCollection new.
    [ t := self peekTok.
      t isSTKeywordTok ] whileTrue: 
	  [
	   selector := selector, self nextTok value.
	   t := self nextTok.
	   t isSTIdentifierTok ifFalse:
	       [ ^self parseError: 'expected identifer after keyword' ].
	   args add: t value.
	   ].
    ^lastNode := STSelectorNode selector: selector args: args
!

parseMethodBody
    | t temporaries primitiveIndex statements | 
    t := self peekTok.
    t isSTVerticalBarTok
	ifTrue: [ temporaries := self parseTemporaries.
		  t := self peekTok ]
	ifFalse: [ temporaries := #() ].
    t isSTPrimitiveStartTok
	ifTrue: [ self nextTok.	"gobble primitive start"
		  primitiveIndex := self parsePrimitive.
		  ].
    
    statements := self parseStatements.
    self nextTok.		"gobble method terminating bang"

    ^lastNode := STMethodBodyNode temps: temporaries primIndex: primitiveIndex
		      stmts: statements
!


parseTemporaries
    "Parses 
	 | << <name> <name> ... | >> 
     and returns the list of names"
    | t temps |
    temps := OrderedCollection new.
    self nextTok.	"gobble vertical bar"
    [ t := self peekTok.
      t isSTVerticalBarTok ] whileFalse: 
	  [ temps add: self parseVariableName ].
    self nextTok.		"gobble vertical bar"
    ^temps
!

parseVariableName
    | id |
    id := self nextTok.
    id isSTIdentifierTok
	ifFalse: [ ^self parseError: 'expected identifier' ].

    VMSpecialIdentifiers at: id value ifAbsent: [ ^id value ].
    ^self parseError: 'invalid variable name - ', id value
!

parsePrimitive
    | int t |
    int := self nextTok.
    (int isSTLiteralTok and: [ int value isSmallInteger ])
	ifFalse: [ ^self parseError: 'primitive: must be followed by integer literal' ].
    
    t := self nextTok.

    (t isSTBinopTok and: [ t value = '>' ])
	ifFalse: [ ^self parseError: 'invalid terminator for primitive:, expecting ''>''' ].

    ^int value
!

parseIdentifierNode: aString

    VMSpecialIdentifiers at: aString ifPresent: [ :code |
	^lastNode := STSpecialIdentifierNode id: code
    ].
    ^lastNode := STVariableNode id: aString
!

parsePrimary
    | t |
    t := self peekTok.
    t isSTIdentifierTok ifTrue: [ ^self parseIdentifierNode: self nextTok value ].
    t isSTLiteralTok ifTrue: [ ^lastNode := STConstNode value: self nextTok value].

    t isSTSharpTok ifTrue: [ self nextTok. ^self parseSharpConstant ].
    t isSTOpenBracketTok ifTrue: [ self nextTok. ^self parseBlock ].
    t isSTOpenParenTok ifTrue: [ self nextTok. ^self parseInsideParentheses ].

    (t isSTCloseBracketTok or: [ t isSTBangTok ])
	ifTrue: [ ^nil ].
	 
    ^self parseError: 'Unrecognized expression'
!

parseInsideParentheses
    | expr |
    expr := self parseExpression.
    expr isNil 
	ifTrue: [ ^self parseError: 'Missing parenthesized expression' ].

    ^self nextTok isSTCloseParenTok
	ifTrue: [ lastNode := STExpressionNode expression: expr ]
	ifFalse: [ self parseError: 'Expecting close paren' ].
!

parseSharpConstant
    " Called at
	 # << id or ( lit lit lit ) or [ byte byte byte ] or 'string' >> "
    | t lit |
    t := self nextTok.
    t isSTSymbolTok ifTrue: [ ^lastNode := STConstNode value: t value asSymbol ].
    t isSTStringTok ifTrue: [ ^lastNode := STConstNode value: t value asSymbol ].
    t isSTOpenBracketTok ifTrue: [
	lit := self
	    parseArrayLitUpTo: STCloseBracketTok
	    on: (WriteStream on: (ByteArray new: 30))
	    errorIf: #isGoodByteArrayElement:.
	^lastNode := STConstNode value: lit
    ].
    t isSTOpenParenTok ifTrue: [
	lit := self
	    parseArrayLitUpTo: STCloseParenTok
	    on: (WriteStream on: (Array new: 30))
	    errorIf: #isGoodArrayElement:.
	^lastNode := STConstNode value: lit
    ].
    ^self parseError: 'Unrecognized literal'
!

parseArrayLitUpTo: closeTok on: aStream errorIf: errorSel
    "Called at
	 ( << id or binop or number or char or string
	      or ( array ) or [ bytes ] or empty ) >>"
    | t value |
    [ t := self nextTok.
      t isMemberOf: closeTok ] whileFalse: [
	  value := self parseArrayElement: t.
	  (self perform: errorSel with: value)
	      ifFalse: [ ^self parseError: 'Bad array literal' ].
	  aStream nextPut: value
    ].
    ^aStream contents
!

parseArrayElement: t

    t isSTLiteralTok ifTrue: [ ^t value ].
    t isSTSymbolTok ifTrue: [ ^t value asSymbol ].

    t isSTOpenParenTok ifTrue: [
	^self
	    parseArrayLitUpTo: STCloseParenTok
	    on: (WriteStream on: (Array new: 30))
	    errorIf: #isGoodArrayElement:
    ].
    t isSTOpenBracketTok ifTrue: [
	^self
	    parseArrayLitUpTo: STCloseBracketTok
	    on: (WriteStream on: (ByteArray new: 30))
	    errorIf: #isGoodByteArrayElement:
    ].
    ^self parseError: 'Bad array literal'
!
    

parseBlock
    " Called at
     [ << block_identifiers ... | temporaries statements ] >> 
     "
    | t identifiers temporaries statements |
    t := self peekTok.
    t isSTColonTok
	ifTrue: [ identifiers := self parseBlockIdentifiers.
		  t := self peekTok ].
    t isSTVerticalBarTok
	ifTrue: [ temporaries := self parseTemporaries.
		  t := self peekTok ].

    statements := self parseStatements.
    t := self nextTok.
    t isSTCloseBracketTok
	ifFalse: [ ^self parseError: 'bad block syntax' ].
    ^lastNode := STBlockNode
	parameters: identifiers
	temporaries: temporaries
	statements: statements
!

parseBlockIdentifiers
    "Called at
      [ << :blockparam :blockparam ... | >> "
    | t identifiers |
    identifiers := OrderedCollection new.
    [ t := self nextTok.
      t isSTVerticalBarTok ifTrue: [ ^identifiers ].
      t isSTBinopTok
    ] whileFalse:
	  [ t isSTColonTok
		ifFalse: [ ^self parseError: 'Bad block param syntax' ].
	    t := self nextTok.
	    t isSTIdentifierTok
		ifFalse: [ ^self parseError: 'Bad block param syntax' ].
	    identifiers add: t value
	    ].

    t value = '||' ifFalse: [ ^self parseError: 'Bad block param syntax' ].
    lex putBack: $| .
    ^identifiers
!
    
parseStatements
    | list |
    list := OrderedCollection new.
    [ self parseStatement: list ] whileFalse.
    ^list
!

parseStatement: list
    | expression |
    self peekTok isSTUpArrowTok ifTrue: [
	self nextTok. "skip ^"
	list add: self parseReturnNode.
	^true ].

    expression := self parseExpression.
    expression isNil ifTrue: [ ^true ].

    list add: expression.
    self peekTok isSTDotTok
	ifTrue: [ self nextTok. ^false ]
	ifFalse: [ ^true ]
!

parseReturnNode
    | expression |
    expression := self parseExpression.
    expression isNil ifTrue: [ ^self parseError: 'expected expression' ].

    (self peekTok) isSTDotTok
	ifTrue: [ self nextTok ].
    ^lastNode := STReturnNode expression: expression
!


parseExpression
    | expr assigns t |
    assigns := OrderedCollection new.
    [ expr := self parseSimpleExpression.
      t := self peekTok.
      t isSTAssignTok ] whileTrue:
	  [ self nextTok.
	    (expr isMemberOf: STVariableNode)
		ifFalse: [ ^self parseError: 'Invalid assignment variable' ].
	    assigns add: expr ].
    expr isNil
	ifTrue: [ ^nil ]
	ifFalse: [ ^lastNode := STExpressionNode assign: assigns expression: expr ]
!

parseSimpleExpression
    ^self parseCascadedExpr
!

parseCascadedExpr
    | message expression |
    expression := self parsePrimary.
    "This feels like it should be recursive, but it's not currently"
    [ message := self parseKeywordMessage.
      message notNil ]
	whileTrue: [ expression := lastNode :=
	    STMessageNode receiver: expression message: message ].
    ^self parseCascadedMessage: expression.
!

parseCascadedMessage: expression
    | t message cascadeList | 
    cascadeList := OrderedCollection new.
    
    [ t := self peekTok.
      t isSTSemiTok ]
	whileTrue: 
	    [ self nextTok.	"gobble semicolon"
	      message := self parseKeywordMessage.
	      message isNil 
		  ifTrue: [ ^self parseError: 'Unfinished cascaded expression' ].
		  
	      cascadeList addLast: message.
	].

    cascadeList size == 0
	ifTrue: [ ^expression ]
	ifFalse: [ ^lastNode := STCascadeNode expression: expression cascade: cascadeList ]
!
    

parseKeywordMessage
    | t selector exprs |
    t := self peekTok.
    t isNil ifTrue: [ ^nil ].
    t isSTKeywordTok
	ifTrue: [ selector := WriteStream on: (String new: 15).
		  exprs := OrderedCollection new.
		  [   selector nextPutAll: self nextTok value.
		      exprs add: self parseBinopExpr.
		      t := self peekTok. 
		      t isSTKeywordTok
		  ] whileTrue.
		  ^lastNode := STKeywordNode selector: selector contents
			       expressions: exprs ]
	ifFalse: [ ^self parseBinaryMessage ]
!    

parseBinopExpr
    | t receiver message |
    receiver := self parseUnaryExpr.
    ^self parseBinaryMessage: receiver
!

parseBinaryMessage: expression
    | message |
    message := self parseBinaryMessage.
    message notNil
	ifTrue: [ ^self parseBinaryMessage:
		      (lastNode := STMessageNode receiver: expression
				   message: message) ]
	ifFalse: [ ^expression ]
!

parseBinaryMessage
    | t operand |
    t := self peekTok.
    t isBinaryOperator
	ifTrue: [ self nextTok.
		  operand := self parseUnaryExpr.
		  ^lastNode := STBinaryNode selector: t value
			      expression: operand ]
	ifFalse: [ ^self parseUnaryMessage ]
!


parseUnaryExpr
    | receiver |
    receiver := self parsePrimary.
    ^self parseUnaryMessage: receiver
!

parseUnaryMessage: expression
    | message |
    message := self parseUnaryMessage.
    message notNil
	ifTrue: [ ^self parseUnaryMessage:
		      (lastNode := STMessageNode receiver: expression
				   message: message) ]
	ifFalse: [ ^expression ]
!

parseUnaryMessage
    | t | 
    t := self peekTok.
    t isSTIdentifierTok
	ifTrue: [ ^lastNode := STUnaryNode selector: self nextTok value ]
	ifFalse: [ ^nil ]
! !


!STParser methodsFor: 'private'!

parseError: str
    "Transcript nextPutAll: '
Error encountered
=================

Scan so far was: 
'.
    Transcript nextPutAll: lex resetRecording.
    Transcript nl."

    parseErrorBlock
	value: lex stream name
	value: lex line
	value: str
!

parseWarning: str
    ^self
	parseWarningIn: lex stream name
	atLine: lex line
	message: str
!

isGoodByteArrayElement: val
    ^val isSmallInteger and: [ (val bitAnd: 255) = val ]
!

isGoodArrayElement: val
    ^true
! !

!STParser methodsFor: 'lexical analysis'!

nextTok
    | t |
    tokenBuffer isNil ifFalse: [
        t := tokenBuffer.
        tokenBuffer := nil.
        ^t
    ].
    [ t := lex next. t isSTCommentTok ] whileTrue: [
	self comment: t
    ].
    ^t
!

peekTok
    tokenBuffer isNil ifFalse: [ ^tokenBuffer ].
    [ (tokenBuffer := lex next) isSTCommentTok ] whileTrue: [
	self comment: tokenBuffer
    ].
    ^tokenBuffer
! !

!STParser methodsFor: 'lexical analysis'!

lastNode
    ^lastNode
!

atEnd
    ^tokenBuffer isNil and: [ lex atEnd ]
! !

!STParser methodsFor: 'overrides'!

result
    "This is what #parseSmalltalk answers"
    ^self
!

record: node
    "do nothing by default"
!

parseErrorIn: file atLine: line message: str
    "Called by the default parse error block"
    self error: ('%4%1:%2: %3'
	bindWith: file
	with: line printString
	with: str
	with: Character nl asString).
!

parseWarningIn: file atLine: line message: str
    "Do nothing"
!

comment: commentTok
    "do nothing by default"
!

compile: node
    "do nothing by default"
!

endMethodList
    "do nothing by default"
!

evaluate: node
    "This is not a do-nothing because its result affects the parsing
     process: true means 'start parsing methods', false means 'keep
     evaluating'. "
    self subclassResponsibility
! !


STParser subclass: #STFileInParser
       instanceVariableNames: 'curCategory curClass curCompilerClass evalFor lastResult method'
       classVariableNames: ''
       poolDictionaries: ''
       category: 'System-Compiler'
!

STFileInParser comment:
'I am a STParser that compiles code that you file in.'!

!STFileInParser class methodsFor: 'accessing'!

methodsFor: aString ifTrue: realCompile class: aClass
    CurrentParser isNil ifFalse: [
	^CurrentParser
	    methodsFor: aString 
	    ifTrue: realCompile
	    class: aClass
    ].
    ^aClass basicMethodsFor: aString ifTrue: realCompile
! !

!STFileInParser methodsFor: 'accessing'!

evalFor: anObject
    evalFor := anObject
!

lastResult
    ^lastResult
!

result
    "This is what #parseSmalltalk answers"
    ^method
!

methodsFor: aString ifTrue: realCompile class: aClass
    curCategory := aString.
    curClass := aClass.
    curCompilerClass := realCompile
	ifTrue: [ STCompiler ]
	ifFalse: [ STFakeCompiler ]
! !

!STFileInParser methodsFor: 'overrides'!

compile: node
    method := curCompilerClass
	compile: node
	for: curClass
	classified: curCategory
	parser: self.
!

endMethodList
    curClass := nil
!

evaluate: node
    | selector |
    selector := node selector selector.

    STDoitCompiler
	compile: node
	for: evalFor class
	classified: nil
	parser: self.

    [ lastResult := evalFor perform: selector ] valueWithUnwind.
    "(evalFor class >> selector) inspect."
    evalFor class removeSelector: selector ifAbsent: [ ].
    ^curClass notNil
!

record: string
    "Transcript nextPutAll: string; nl"
! !



STParser subclass:  #STPluggableParser
	  instanceVariableNames: 'callback'
	  classVariableNames: ''
	  poolDictionaries: ''
	  category: 'Graphics-Browser'
!

STPluggableParser comment: 
'I am not only able to understand Smalltalk code, but I can
inform anybody who asks about the token boundaries, telling
them when interesting pieces of code are found.

STPluggableParser gets its abilities just from its superclass
STParser, so every change on STParser may have influence to
STPluggableParser. Since most methods just call the superclass
version and callback at appropriate times, changes to the
Parser are however unlikely to cause troubles. Exceptions are
the code handling message sending syntax and parentheses.

Note *no* callback exists for comments. Instead the syntax
highlighter (where this class was initially born) discard
comments, doing a second pass after the real meat has been
highlighted. It is probably less efficient than finding some
way to use #comment:, and we must also skip around string
literals, but overall it is ok, at least for now. The
#comment: callback defined by STParser isn''t used because it
leads to bugs; for example consider how the syntax highlighter
would behave for:

at: index put: value
    "Store value at the index-th indexed instance variable"

When parsing the method header, after `value'' is read a
token is peeked at to check for another keyword in the
selector; nothing in the header has been highlighted yet.
Instead a comment is found and #comment: is called; but
we would end up highlighting in green (comment)
*everything* from `at:'' to the end of the comment, because
highlighting will start from the beginning of the text.'!

!STPluggableParser methodsFor: 'installing callbacks'!

callback: object
    callback := object
! !

!STPluggableParser methodsFor: 'overrides'!

nextTok
    | t |
    ^(t := super nextTok) isSTSpecialTok
	ifTrue: [ callback foundSpecialChar: t ]
	ifFalse: [ t ]
!

peekTok
    | t |
    ^(t := super peekTok) isSTSpecialTok
	ifTrue: [ callback foundSpecialChar: t ]
	ifFalse: [ t ]
!

searchMethodListHeader
    ^self atEnd not
!

parseSelector
    ^callback foundMethodHeader: super parseSelector
!

parseTemporaries
    ^callback foundTemporaries: super parseTemporaries
!

parsePrimitive
    ^callback foundPrimitive: super parsePrimitive
!

parseIdentifierNode: aString
    callback foundIdentifier: aString.
    ^super parseIdentifierNode: aString
!

parsePrimary
    | t |
    t := self peekTok.
    t isSTLiteralTok ifTrue: [ ^callback foundConstant: super parsePrimary ].
    t isSTSharpTok ifTrue: [ ^callback foundConstant: super parsePrimary ].
    ^super parsePrimary
!

parseBlockIdentifiers
    ^callback foundBlockArgs: super parseBlockIdentifiers
!
    
parseExpression
    | result t |
    result := super parseExpression.
    t := self peekTok.
    ^result
!

parseBinopExpr
    callback foundKeywordMessage: nil.
    ^super parseBinopExpr
!

parseBinaryMessage
    | t operand |
    t := self peekTok.
    ^t isBinaryOperator
	ifTrue: [ callback foundBinaryMessage: nil. super parseBinaryMessage ]
	ifFalse: [ self parseUnaryMessage ]
!

parseUnaryMessage
    | t | 
    t := self peekTok.
    t isSTIdentifierTok ifTrue: [
	^callback foundUnaryMessage: (STUnaryNode selector: self nextTok value)
    ].
    ^nil
! !



!PositionableStream methodsFor: 'compiling'!

name
    "Answer a string that represents what the receiver is streaming on"
    ^'(%1 %2)' bindWith: self species article with: self species name
!

segmentFrom: startPos to: endPos
    "Answer an object that, when sent #asString, will yield the result
     of sending `copyFrom: startPos to: endPos' to the receiver"
    ^self copyFrom: startPos to: endPos
! !

!FileStream methodsFor: 'compiling'!

segmentFrom: startPos to: endPos
    "Answer an object that, when sent #asString, will yield the result
     of sending `copyFrom: startPos to: endPos' to the receiver"
    ^FileSegment
	on: self name
	startingAt: startPos
	for: endPos - startPos + 1.
! !
