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