"====================================================================== | | 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 ! methodsFor: ! " | 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 | << ... | >> 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. ! !