1"====================================================================== 2| 3| GNU Smalltalk syntax parser 4| 5| 6 ======================================================================" 7 8 9"====================================================================== 10| 11| Copyright 2007, 2008, 2009 Free Software Foundation, Inc. 12| Written by Daniele Sciascia. 13| 14| This file is part of the GNU Smalltalk class library. 15| 16| The GNU Smalltalk class library is free software; you can redistribute it 17| and/or modify it under the terms of the GNU Lesser General Public License 18| as published by the Free Software Foundation; either version 2.1, or (at 19| your option) any later version. 20| 21| The GNU Smalltalk class library is distributed in the hope that it will be 22| useful, but WITHOUT ANY WARRANTY; without even the implied warranty of 23| MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser 24| General Public License for more details. 25| 26| You should have received a copy of the GNU Lesser General Public License 27| along with the GNU Smalltalk class library; see the file COPYING.LIB. 28| If not, write to the Free Software Foundation, 59 Temple Place - Suite 29| 330, Boston, MA 02110-1301, USA. 30| 31 ======================================================================" 32 33STInST.STFileInParser subclass: GSTFileInParser [ 34 | taggee class currentDeclaration | 35 36 parseStatements [ 37 | returnPosition statements node | 38 "Skip temporaries." 39 (currentToken isBinary and: [currentToken value == #|]) 40 ifTrue: [ self step. self parseArgs. self step ]. 41 (currentToken isBinary and: [currentToken value == #||]) 42 ifTrue: [ self step ]. 43 44 (currentToken isSpecial and: [currentToken value == $!]) 45 ifTrue: [ ^RBSequenceNode statements: #() ]. 46 47 node := (currentToken isSpecial and: [currentToken value == $^]) 48 ifTrue: [returnPosition := currentToken start. 49 self step. 50 RBReturnNode return: returnPosition value: self parseAssignment] 51 ifFalse: [self parseAssignment]. 52 53 self addCommentsTo: node. 54 ^RBSequenceNode statements: { node } 55 ] 56 57 parseDoits [ 58 "Parses the stuff to be executed until a closed bracket." 59 60 <category: 'private-parsing'> 61 | node | 62 63 [self atEnd ifTrue: [^false]. 64 (currentToken isSpecial and: [currentToken value == $]]) 65 ifTrue: [^false]. 66 67 node := self parseDoit. 68 scanner stripSeparators. 69 self evaluate: node] 70 whileFalse: 71 [(currentToken isSpecial and: [currentToken value == $!]) 72 ifTrue: [self step]]. 73 ^true 74 ] 75 76 parseDoit [ 77 | node | 78 (taggee notNil and: [currentToken value = #<]) ifTrue: 79 [self parseClassTag. ^nil]. 80 node := super parseDoit. 81 (currentToken isSpecial and: [ self skipToken: $[ ]) 82 ifTrue: [self parseDeclaration: node statements first. ^nil]. 83 84 currentToken isSpecial ifTrue: [ self skipToken: $. ]. 85 ^node 86 ] 87 88 parseDeclaration: node [ 89 | decl | 90 currentDeclaration := node parent. 91 decl := node. 92 decl isReturn ifTrue: [ decl := decl value ]. 93 decl isMessage ifTrue: [ 94 (decl selectorParts first value = 'subclass:') 95 ifTrue: [self parseClass: decl. ^self]. 96 97 (decl selectorParts first value = 'extend') 98 ifTrue: [self parseClassExtension: decl. ^self]. 99 100 ((decl receiver name = 'Namespace') 101 and: [decl selectorParts first value = 'current:' ]) 102 ifTrue: [self parseNamespace: decl. ^self]]. 103 104 decl isVariable 105 ifTrue: [(decl name = 'Eval') 106 ifTrue: [self parseEval. ^self]]. 107 108 self parserError: 'expected Eval, Namespace or class definition' 109 ] 110 111 parseEval [ 112 | stmts | 113 stmts := self parseStatements: false. 114 self skipExpectedToken: $]. 115 self evaluate: stmts. 116 ] 117 118 parseNamespace: node [ 119 | namespace fullNamespace newNamespace | 120 namespace := RBVariableNode 121 named: self driver currentNamespace name asString. 122 fullNamespace := RBVariableNode 123 named: (self driver currentNamespace nameIn: Smalltalk). 124 125 newNamespace := node arguments first name asSymbol. 126 (self driver currentNamespace includesKey: newNamespace) 127 ifFalse: [ 128 self evaluateMessageOn: namespace 129 selector: #addSubspace: 130 argument: node arguments first name asSymbol ]. 131 132 self evaluateStatement: node. 133 taggee := RBVariableNode named: 134 (self driver currentNamespace nameIn: Smalltalk). 135 self parseDoits. 136 self skipExpectedToken: $]. 137 138 "restore previous namespace" 139 taggee := fullNamespace. 140 node parent: nil. 141 node arguments: { fullNamespace }. 142 self evaluateStatement: node 143 ] 144 145 parseClassExtension: node [ 146 class := node receiver. 147 self parseClassBody: true. 148 class := nil 149 ] 150 151 parseClass: node [ 152 self evaluateMessageOn: (node receiver) 153 selector: #subclass: 154 argument: (node arguments first name asSymbol). 155 156 class := node arguments first. 157 self parseClassBody: false. 158 class := nil. 159 ] 160 161 parseClassBody: extend [ 162 | addInstVars oldTaggee | 163 oldTaggee := taggee. 164 taggee := class. 165 addInstVars := extend. 166 [ self skipToken: $] ] whileFalse: [ 167 addInstVars := self 168 parseClassBodyElement: addInstVars 169 withinExtend: extend ]. 170 taggee := oldTaggee. 171 ] 172 173 parseClassBodyElement: addInstVars withinExtend: extend [ 174 | node classNode | 175 176 "drop comments" 177 scanner getComments. 178 179 "look for class tag" 180 (currentToken value = #< and: [self nextToken isKeyword]) 181 ifTrue: [self parseClassTag. ^addInstVars]. 182 183 "look for class variable" 184 (currentToken isIdentifier and: [self nextToken isAssignment]) 185 ifTrue: [self parseClassVariable. ^addInstVars]. 186 187 "class side" 188 ((currentToken isIdentifier 189 and: [self nextToken isIdentifier]) 190 and: [self nextToken value = 'class']) 191 ifTrue: [classNode := RBVariableNode identifierToken: currentToken. 192 self step. 193 194 (classNode = class) 195 ifTrue: ["look for class method" 196 (self nextToken value = #>>) 197 ifTrue: [self step. self step. 198 self parseMethodSourceOn: (self makeClassOf: classNode). 199 ^addInstVars ]. 200 201 "look for metaclass" 202 (self nextToken value = $[) 203 ifTrue: [self parseMetaclass: extend. 204 ^addInstVars ]. 205 206 self parserError: 'invalid class body element']. 207 208 "look for overriding class method" 209 self step. 210 (currentToken value = #>>) 211 ifTrue: ["TODO: check that classNode is a superclass of the current class" 212 self step. 213 self parseMethodSourceOn: (self makeClassOf: classNode). 214 ^addInstVars]. 215 216 self parserError: 'invalid class body element' ]. 217 218 "look for overriding method" 219 (currentToken isIdentifier and: [self nextToken value = #>>]) 220 ifTrue: ["check that classNode is a superclass of the current class!!!" 221 classNode := RBVariableNode identifierToken: currentToken. 222 self step. self step. 223 self parseMethodSourceOn: classNode. 224 ^addInstVars]. 225 226 node := self parseMessagePattern. 227 228 "look for method" 229 (self skipToken: $[) 230 ifTrue: [self parseMethodSource: node. ^addInstVars]. 231 232 "look for instance variables" 233 (node selectorParts first value = #|) 234 ifTrue: [self parseInstanceVariables: node add: addInstVars. ^true]. 235 236 self parserError: 'invalid class body element' 237 ] 238 239 parseClassTag [ 240 | selectors arguments stmt | 241 242 self skipExpectedToken: #<. 243 244 (currentToken isKeyword) 245 ifFalse: [self parserError: 'expected keyword']. 246 247 selectors := OrderedCollection new. 248 arguments := OrderedCollection new. 249 250 "Consume all keywords and literals of the pragma" 251 [currentToken isKeyword] whileTrue: [ 252 selectors add: currentToken. self step. 253 arguments add: self parsePrimitiveObject. 254 ]. 255 256 self skipExpectedToken: #>. 257 258 stmt := RBMessageNode 259 receiver: taggee 260 selectorParts: selectors 261 arguments: arguments. 262 self evaluateStatement: stmt. 263 ] 264 265 parseClassVariable [ 266 | node stmt name | 267 268 node := self parseAssignment. 269 node isAssignment 270 ifFalse: [self parserError: 'expected assignment']. 271 272 (self skipToken: $.) ifFalse: [ 273 (currentToken value = $]) ifFalse: [ 274 self parserError: 'expected . or ]']]. 275 276 name := RBLiteralNode value: (node variable name asSymbol). 277 node := self makeSequenceNode: node value. 278 node := RBBlockNode body: node. 279 280 stmt := RBMessageNode 281 receiver: class 282 selector: #addClassVarName:value: 283 arguments: { name . node }. 284 285 self evaluateStatement: stmt. 286 ] 287 288 parseMetaclass: extend [ 289 | tmpClass | 290 291 self step. self step. 292 tmpClass := class. 293 class := self makeClassOf: class. 294 self parseClassBody: extend. 295 class := tmpClass 296 ] 297 298 parseMethodSource: patternNode [ 299 self parseMethodSource: patternNode on: class 300 ] 301 302 parseMethodSourceOn: classNode [ 303 | patternNode | 304 "Drop comments before the message pattern" 305 patternNode := self parseMessagePattern. 306 self skipExpectedToken: $[. 307 self parseMethodSource: patternNode on: classNode. 308 ] 309 310 parseMethodSource: patternNode on: classNode [ 311 | methodNode start stop | 312 313 start := patternNode selectorParts first start - 1. 314 methodNode := self parseMethodInto: patternNode. 315 stop := currentToken start - 1. 316 self skipExpectedToken: $]. 317 methodNode := self addSourceFrom: start to: stop to: methodNode. 318 319 self evaluateMessageOn: classNode 320 selector: #methodsFor: 321 argument: nil. 322 323 self compile: methodNode. 324 self endMethodList. 325 ] 326 327 parseInstanceVariables: node add: addThem [ 328 | vars | 329 330 vars := addThem 331 ifTrue: [ 332 (self resolveClass: class) instVarNames 333 fold: [ :a :b | a, ' ', b ] ] 334 ifFalse: [ '' ]. 335 336 vars := vars, ' ', (node arguments at: 1) name. 337 [currentToken isIdentifier] 338 whileTrue: [vars := vars , ' ' , currentToken value. 339 340 self step ]. 341 342 self skipExpectedToken: #|. 343 self evaluateMessageOn: class 344 selector: #instanceVariableNames: 345 argument: vars. 346 ] 347 348 evaluateMessageOn: rec selector: sel argument: arg [ 349 | stmt | 350 351 stmt := RBMessageNode 352 receiver: rec 353 selector: sel 354 arguments: { RBLiteralNode value: arg }. 355 356 self evaluateStatement: stmt. 357 ] 358 359 evaluateStatement: node [ 360 ^self evaluate: (self makeSequenceNode: node) 361 ] 362 363 evaluate: seq [ 364 | emptySeq | 365 (currentDeclaration notNil and: [ currentDeclaration comments notEmpty ]) 366 ifTrue: [ 367 seq parent isNil 368 ifTrue: [ 369 seq comments: currentDeclaration comments. 370 seq parent: currentDeclaration parent ] 371 ifFalse: [ 372 emptySeq := self makeSequenceNode. 373 emptySeq comments: currentDeclaration comments. 374 emptySeq parent: currentDeclaration parent. 375 super evaluate: emptySeq ] ]. 376 currentDeclaration := nil. 377 ^super evaluate: seq 378 ] 379 380 makeSequenceNode [ 381 | seq | 382 seq := RBSequenceNode 383 leftBar: nil 384 temporaries: #() 385 rightBar: nil. 386 seq periods: #(). 387 seq statements: #(). 388 ^seq 389 ] 390 391 makeSequenceNode: stmt [ 392 ^self makeSequenceNode statements: { stmt }. 393 ] 394 395 makeClassOf: node [ 396 ^RBMessageNode 397 receiver: node 398 selector: #class 399 arguments: #() 400 ] 401 402 skipToken: tokenValue [ 403 (currentToken value = tokenValue) 404 ifTrue: [self step. ^true] 405 ifFalse: [^false] 406 ] 407 408 skipExpectedToken: tokenValue [ 409 (self skipToken: tokenValue) 410 ifFalse: [self parserError: ('expected ' , tokenValue asSymbol)] 411 ] 412] 413