"====================================================================== | | GNU Smalltalk syntax parser | | ======================================================================" "====================================================================== | | Copyright 2007, 2008, 2009 Free Software Foundation, Inc. | Written by Daniele Sciascia. | | This file is part of the GNU Smalltalk class library. | | The GNU Smalltalk class library is free software; you can redistribute it | and/or modify it under the terms of the GNU Lesser General Public License | as published by the Free Software Foundation; either version 2.1, or (at | your option) any later version. | | The GNU Smalltalk class library 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 Lesser | General Public License for more details. | | You should have received a copy of the GNU Lesser General Public License | along with the GNU Smalltalk class library; see the file COPYING.LIB. | If not, write to the Free Software Foundation, 59 Temple Place - Suite | 330, Boston, MA 02110-1301, USA. | ======================================================================" STInST.STFileInParser subclass: GSTFileInParser [ | taggee class currentDeclaration | parseStatements [ | returnPosition statements node | "Skip temporaries." (currentToken isBinary and: [currentToken value == #|]) ifTrue: [ self step. self parseArgs. self step ]. (currentToken isBinary and: [currentToken value == #||]) ifTrue: [ self step ]. (currentToken isSpecial and: [currentToken value == $!]) ifTrue: [ ^RBSequenceNode statements: #() ]. node := (currentToken isSpecial and: [currentToken value == $^]) ifTrue: [returnPosition := currentToken start. self step. RBReturnNode return: returnPosition value: self parseAssignment] ifFalse: [self parseAssignment]. self addCommentsTo: node. ^RBSequenceNode statements: { node } ] parseDoits [ "Parses the stuff to be executed until a closed bracket." | node | [self atEnd ifTrue: [^false]. (currentToken isSpecial and: [currentToken value == $]]) ifTrue: [^false]. node := self parseDoit. scanner stripSeparators. self evaluate: node] whileFalse: [(currentToken isSpecial and: [currentToken value == $!]) ifTrue: [self step]]. ^true ] parseDoit [ | node | (taggee notNil and: [currentToken value = #<]) ifTrue: [self parseClassTag. ^nil]. node := super parseDoit. (currentToken isSpecial and: [ self skipToken: $[ ]) ifTrue: [self parseDeclaration: node statements first. ^nil]. currentToken isSpecial ifTrue: [ self skipToken: $. ]. ^node ] parseDeclaration: node [ | decl | currentDeclaration := node parent. decl := node. decl isReturn ifTrue: [ decl := decl value ]. decl isMessage ifTrue: [ (decl selectorParts first value = 'subclass:') ifTrue: [self parseClass: decl. ^self]. (decl selectorParts first value = 'extend') ifTrue: [self parseClassExtension: decl. ^self]. ((decl receiver name = 'Namespace') and: [decl selectorParts first value = 'current:' ]) ifTrue: [self parseNamespace: decl. ^self]]. decl isVariable ifTrue: [(decl name = 'Eval') ifTrue: [self parseEval. ^self]]. self parserError: 'expected Eval, Namespace or class definition' ] parseEval [ | stmts | stmts := self parseStatements: false. self skipExpectedToken: $]. self evaluate: stmts. ] parseNamespace: node [ | namespace fullNamespace newNamespace | namespace := RBVariableNode named: self driver currentNamespace name asString. fullNamespace := RBVariableNode named: (self driver currentNamespace nameIn: Smalltalk). newNamespace := node arguments first name asSymbol. (self driver currentNamespace includesKey: newNamespace) ifFalse: [ self evaluateMessageOn: namespace selector: #addSubspace: argument: node arguments first name asSymbol ]. self evaluateStatement: node. taggee := RBVariableNode named: (self driver currentNamespace nameIn: Smalltalk). self parseDoits. self skipExpectedToken: $]. "restore previous namespace" taggee := fullNamespace. node parent: nil. node arguments: { fullNamespace }. self evaluateStatement: node ] parseClassExtension: node [ class := node receiver. self parseClassBody: true. class := nil ] parseClass: node [ self evaluateMessageOn: (node receiver) selector: #subclass: argument: (node arguments first name asSymbol). class := node arguments first. self parseClassBody: false. class := nil. ] parseClassBody: extend [ | addInstVars oldTaggee | oldTaggee := taggee. taggee := class. addInstVars := extend. [ self skipToken: $] ] whileFalse: [ addInstVars := self parseClassBodyElement: addInstVars withinExtend: extend ]. taggee := oldTaggee. ] parseClassBodyElement: addInstVars withinExtend: extend [ | node classNode | "drop comments" scanner getComments. "look for class tag" (currentToken value = #< and: [self nextToken isKeyword]) ifTrue: [self parseClassTag. ^addInstVars]. "look for class variable" (currentToken isIdentifier and: [self nextToken isAssignment]) ifTrue: [self parseClassVariable. ^addInstVars]. "class side" ((currentToken isIdentifier and: [self nextToken isIdentifier]) and: [self nextToken value = 'class']) ifTrue: [classNode := RBVariableNode identifierToken: currentToken. self step. (classNode = class) ifTrue: ["look for class method" (self nextToken value = #>>) ifTrue: [self step. self step. self parseMethodSourceOn: (self makeClassOf: classNode). ^addInstVars ]. "look for metaclass" (self nextToken value = $[) ifTrue: [self parseMetaclass: extend. ^addInstVars ]. self parserError: 'invalid class body element']. "look for overriding class method" self step. (currentToken value = #>>) ifTrue: ["TODO: check that classNode is a superclass of the current class" self step. self parseMethodSourceOn: (self makeClassOf: classNode). ^addInstVars]. self parserError: 'invalid class body element' ]. "look for overriding method" (currentToken isIdentifier and: [self nextToken value = #>>]) ifTrue: ["check that classNode is a superclass of the current class!!!" classNode := RBVariableNode identifierToken: currentToken. self step. self step. self parseMethodSourceOn: classNode. ^addInstVars]. node := self parseMessagePattern. "look for method" (self skipToken: $[) ifTrue: [self parseMethodSource: node. ^addInstVars]. "look for instance variables" (node selectorParts first value = #|) ifTrue: [self parseInstanceVariables: node add: addInstVars. ^true]. self parserError: 'invalid class body element' ] parseClassTag [ | selectors arguments stmt | self skipExpectedToken: #<. (currentToken isKeyword) ifFalse: [self parserError: 'expected keyword']. selectors := OrderedCollection new. arguments := OrderedCollection new. "Consume all keywords and literals of the pragma" [currentToken isKeyword] whileTrue: [ selectors add: currentToken. self step. arguments add: self parsePrimitiveObject. ]. self skipExpectedToken: #>. stmt := RBMessageNode receiver: taggee selectorParts: selectors arguments: arguments. self evaluateStatement: stmt. ] parseClassVariable [ | node stmt name | node := self parseAssignment. node isAssignment ifFalse: [self parserError: 'expected assignment']. (self skipToken: $.) ifFalse: [ (currentToken value = $]) ifFalse: [ self parserError: 'expected . or ]']]. name := RBLiteralNode value: (node variable name asSymbol). node := self makeSequenceNode: node value. node := RBBlockNode body: node. stmt := RBMessageNode receiver: class selector: #addClassVarName:value: arguments: { name . node }. self evaluateStatement: stmt. ] parseMetaclass: extend [ | tmpClass | self step. self step. tmpClass := class. class := self makeClassOf: class. self parseClassBody: extend. class := tmpClass ] parseMethodSource: patternNode [ self parseMethodSource: patternNode on: class ] parseMethodSourceOn: classNode [ | patternNode | "Drop comments before the message pattern" patternNode := self parseMessagePattern. self skipExpectedToken: $[. self parseMethodSource: patternNode on: classNode. ] parseMethodSource: patternNode on: classNode [ | methodNode start stop | start := patternNode selectorParts first start - 1. methodNode := self parseMethodInto: patternNode. stop := currentToken start - 1. self skipExpectedToken: $]. methodNode := self addSourceFrom: start to: stop to: methodNode. self evaluateMessageOn: classNode selector: #methodsFor: argument: nil. self compile: methodNode. self endMethodList. ] parseInstanceVariables: node add: addThem [ | vars | vars := addThem ifTrue: [ (self resolveClass: class) instVarNames fold: [ :a :b | a, ' ', b ] ] ifFalse: [ '' ]. vars := vars, ' ', (node arguments at: 1) name. [currentToken isIdentifier] whileTrue: [vars := vars , ' ' , currentToken value. self step ]. self skipExpectedToken: #|. self evaluateMessageOn: class selector: #instanceVariableNames: argument: vars. ] evaluateMessageOn: rec selector: sel argument: arg [ | stmt | stmt := RBMessageNode receiver: rec selector: sel arguments: { RBLiteralNode value: arg }. self evaluateStatement: stmt. ] evaluateStatement: node [ ^self evaluate: (self makeSequenceNode: node) ] evaluate: seq [ | emptySeq | (currentDeclaration notNil and: [ currentDeclaration comments notEmpty ]) ifTrue: [ seq parent isNil ifTrue: [ seq comments: currentDeclaration comments. seq parent: currentDeclaration parent ] ifFalse: [ emptySeq := self makeSequenceNode. emptySeq comments: currentDeclaration comments. emptySeq parent: currentDeclaration parent. super evaluate: emptySeq ] ]. currentDeclaration := nil. ^super evaluate: seq ] makeSequenceNode [ | seq | seq := RBSequenceNode leftBar: nil temporaries: #() rightBar: nil. seq periods: #(). seq statements: #(). ^seq ] makeSequenceNode: stmt [ ^self makeSequenceNode statements: { stmt }. ] makeClassOf: node [ ^RBMessageNode receiver: node selector: #class arguments: #() ] skipToken: tokenValue [ (currentToken value = tokenValue) ifTrue: [self step. ^true] ifFalse: [^false] ] skipExpectedToken: tokenValue [ (self skipToken: tokenValue) ifFalse: [self parserError: ('expected ' , tokenValue asSymbol)] ] ]