[PATCH] New syntax parser

This is the last missing brick to trigger the big conversion to the new
syntax (also a work of Daniele, with only a few minor fixes from me).
Actually since the parser is supposed to be backwards compatible I want
to check that it does convert the kernel sources correctly (in addition
to generating documentation from said sources).

The old parser is still accessible with "-f gst2" to gst-convert.

There are known bugs in the handling of comments, which mysteriously
disappear.  Well, I know why but I don't know how to fix them. :-P

In addition, another blocker for the 3.0 release surfaced, which is the
ability to store class variable initializers somewhere.  For now, I'm
adding an addClassVarName:value: method to which we'll add meat later.
The C parser should also call this same method so that initializers will
be handled properly.

Paolo

2007-08-08  Paolo Bonzini  <[hidden email]>
            Daniele Sciascia  <[hidden email]>

        * kernel/Class.st: Add #addClassVarName:value:.
        * scripts/Convert.st: Add GSTParser support.

packages/stinst/parser:
2007-08-08  Daniele Sciascia  <[hidden email]>

        * RBParser.st: Add #parseMethodInto:.
        * STFileParser.st: Support "self evaluate: nil".  Only skip "!"
        after evaluating.  Add #currentNamespace.
        * STLoader.st: Handle #addClassVarName:value:.
        * STLoaderObjs.st: Add #collectCategories.
        * GSTParser.st: New.


* looking for [hidden email]--2004b/smalltalk--devo--2.2--patch-503 to compare with
* comparing to [hidden email]--2004b/smalltalk--devo--2.2--patch-503
A  packages/stinst/parser/GSTParser.st
M  packages/stinst/parser/STFileParser.st
M  scripts/Convert.st
M  packages/stinst/parser/package.xml
M  packages/stinst/parser/RBParser.st
M  packages/stinst/parser/STLoader.st
M  packages/stinst/parser/STLoaderObjs.st
M  kernel/Class.st

* modified files

--- orig/kernel/Class.st
+++ mod/kernel/Class.st
@@ -96,14 +96,21 @@ superclass: aClass
 !Class methodsFor: 'accessing instances and variables'!
 
 addClassVarName: aString
-    "Add a class variable with the given name to the class pool dictionary"
+    "Add a class variable with the given name to the class pool dictionary."
     | sym |
     sym := aString asClassPoolKey.
-
     (self classPool includesKey: sym)
-        ifTrue: [ SystemExceptions.AlreadyDefined signalOn: aString ].
+        ifFalse: [ self classPool at: sym put: nil ].
 
-    self classPool at: sym put: nil
+    ^self classPool associationAt: sym
+!
+
+addClassVarName: aString value: valueBlock
+    "Add a class variable with the given name to the class pool dictionary,
+     and evaluate valueBlock as its initializer."
+    ^(self addClassVarName: aString)
+        value: valueBlock value;
+ yourself
 !
 
 bindingFor: aString


--- orig/packages/stinst/parser/RBParser.st
+++ mod/packages/stinst/parser/RBParser.st
@@ -292,6 +292,10 @@ parseMessagePattern
 parseMethod
     | methodNode |
     methodNode := self parseMessagePattern.
+    ^self parseMethodInto: methodNode!
+
+parseMethodInto: methodNode
+    tags := nil.
     self parseResourceTag.
     self addCommentsTo: methodNode.
     methodNode body: (self parseStatements: true).


--- orig/packages/stinst/parser/STFileParser.st
+++ mod/packages/stinst/parser/STFileParser.st
@@ -76,7 +76,7 @@ evaluate: node
     "This should be overridden because its result affects the parsing
      process: true means 'start parsing methods', false means 'keep
      evaluating'."
-    ^node statements size > 0 and: [ driver evaluate: node ]
+    ^node notNil and: [ node statements size > 0 and: [ driver evaluate: node ]]
 ! !
 
 !STFileParser methodsFor: 'utility'!
@@ -154,10 +154,11 @@ parseDoits
     [
  self atEnd ifTrue: [ ^false ].
  node := self parseStatements.
-        scanner stripSeparators.           "gobble doit terminating bang"
+        scanner stripSeparators.
  self evaluate: node
     ] whileFalse: [
-        self step            "gobble doit terminating bang"
+        (currentToken isSpecial and: [currentToken value == $!])
+    ifTrue: [ self step ]
     ].
     ^true
 !
@@ -258,6 +259,12 @@ evaluate: node
      process: true means 'start parsing methods', false means 'keep
      evaluating'. By default, always answer false."
     ^false
+!
+
+currentNamespace
+    ^Namespace current
+!
+
 ! !
 
 RBScanner subclass: #STFileScanner


--- orig/packages/stinst/parser/STLoader.st
+++ mod/packages/stinst/parser/STLoader.st
@@ -154,6 +154,9 @@ initialize
 
  toEvaluate: #addClassVarName:
  perform: #doSend:selector:arguments:;
+
+ toEvaluate: #addClassVarName:value:
+ perform: #doAddClassVarName:selector:arguments:;
 
  toEvaluate: #instanceVariableNames:
  perform: #doSend:selector:arguments:
@@ -266,6 +269,15 @@ doSend: receiver selector: selector argu
     ^false
 !
 
+doAddClassVarName: receiver selector: selector arguments: argumentNodes
+    | class classVarName value |
+    class := self resolveClass: receiver.
+    classVarName := argumentNodes first value asString.
+    value := argumentNodes last.
+    class addClassVarName: classVarName value: value.
+    ^false
+!
+
 doImport: receiver selector: selector arguments: argumentNodes
     | class namespace |
     receiver isMessage ifTrue: [ ^false ].


--- orig/packages/stinst/parser/STLoaderObjs.st
+++ mod/packages/stinst/parser/STLoaderObjs.st
@@ -532,10 +532,21 @@ superclass
 methodDictionary
     methods isNil ifTrue: [ methods := LookupTable new ].
     ^methods
-!
+!
 
 methodDictionary: aDictionary
     methods := aDictionary
+!
+
+collectCategories
+    | categories |
+    self methodDictionary isNil ifTrue: [ ^#() ].
+
+    categories := Set new.
+    self methodDictionary do:
+ [ :method | categories add: (method methodCategory) ].
+
+    ^categories asSortedCollection
 ! !
 
 !PseudoBehavior methodsFor: 'printing'!


--- orig/packages/stinst/parser/package.xml
+++ mod/packages/stinst/parser/package.xml
@@ -17,6 +17,7 @@
   <filein>STLoader.st</filein>
   <filein>SqueakParser.st</filein>
   <filein>SIFParser.st</filein>
+  <filein>GSTParser.st</filein>
   <filein>Exporter.st</filein>
 
   <test>
@@ -39,8 +40,9 @@
   <file>STSymTable.st</file>
   <file>RewriteTests.st</file>
   <file>SqueakParser.st</file>
+  <file>STFileParser.st</file>
   <file>SIFParser.st</file>
+  <file>GSTParser.st</file>
   <file>Exporter.st</file>
-  <file>STFileParser.st</file>
   <file>ChangeLog</file>
 </package>


--- orig/scripts/Convert.st
+++ mod/scripts/Convert.st
@@ -383,7 +383,8 @@ Eval [
     filter := [ :class | true ].
     converter := SyntaxConverter new.
     formats := Dictionary from: {
- 'gst' -> STInST.STFileInParser.
+ 'gst2' -> STInST.STFileInParser.
+ 'gst' -> STInST.GSTFileInParser.
  'squeak' -> STInST.SqueakFileInParser.
  'sif' -> STInST.SIFFileInParser
     }.



* added files

--- /dev/null
+++ mod/packages/stinst/parser/GSTParser.st
@@ -0,0 +1,334 @@
+"======================================================================
+|
+|   GNU Smalltalk syntax parser
+|
+|
+ ======================================================================"
+
+
+"======================================================================
+|
+| Copyright 2007 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 [
+    | class |
+
+    parseStatements [
+        | returnPosition statements node |
+
+        (currentToken isSpecial and: [currentToken value == $!])
+   ifTrue: [ ^RBSequenceNode statements: #() ].
+
+        statements := OrderedCollection new.
+
+        (currentToken isSpecial and: [currentToken value == $^])
+            ifTrue: [returnPosition := currentToken start.  
+                     self step.
+                     node := RBReturnNode return: returnPosition value: self parseAssignment.
+                     self addCommentsTo: node.
+                     statements add: node]
+            ifFalse: [node := self parseAssignment.
+                      self addCommentsTo: node.
+                      statements add: node].
+
+        (currentToken isSpecial and: [self skipToken: $[])
+            ifTrue: [self parseDeclaration: node. ^nil].
+
+        ^RBSequenceNode statements: statements
+    ]
+
+    parseDeclaration: node [
+        node isMessage ifTrue: [
+            (node selectorParts first value = 'subclass:')
+                ifTrue: [self parseClass: node. ^self].
+                
+            ((node receiver name = 'Namespace')
+                and: [node selectorParts first value = 'current:' ])
+                    ifTrue: [self parseNamespace: node. ^self].
+            
+            (node selectorParts first value = 'extend')
+                ifTrue: [self parseClassExtension: node. ^self]].
+        
+        node isVariable
+            ifTrue: [(node 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 |
+        namespace := RBVariableNode
+    named: self driver currentNamespace name asString.
+        fullNamespace := RBVariableNode
+    named: (self driver currentNamespace nameIn: Smalltalk).
+
+        self evaluateMessageOn: namespace
+             selector: #addSubspace:
+             argument: node arguments first name asSymbol.
+          
+        self evaluateStatement: node.      
+        self parseSmalltalk.
+        self skipExpectedToken: $].
+
+        "restore previous namespace"
+        node parent: nil.
+        node arguments: { fullNamespace }.
+        self evaluateStatement: node
+    ]
+    
+    parseClassExtension: node [
+        class := node receiver.
+        self parseClassBody.
+        class := nil
+    ]
+    
+    parseClass: node [
+        self evaluateMessageOn: (node receiver)
+             selector: #subclass:
+             argument: (node arguments first name asSymbol).
+            
+        class := node arguments first.
+        self parseClassBody.
+        class := nil.
+    ]
+    
+    parseClassBody [
+        [ self skipToken: $] ]
+            whileFalse: [ self parseClassBodyElement ]
+    ]
+    
+    parseClassBodyElement [
+        | node classNode |
+        
+        "look for class tag"
+        (currentToken value = #< and: [self nextToken isKeyword])
+            ifTrue: [self parseClassTag. ^self].
+        
+        "look for class variable"
+        (currentToken isIdentifier and: [self nextToken isAssignment])
+            ifTrue: [self parseClassVariable. ^self].
+            
+        "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).
+                                                 ^self ].
+                                            
+                                     "look for metaclass"
+                                     (self nextToken value = $[)
+                                        ifTrue: [self parseMetaclass.
+                                                 ^self ].
+                                        
+                                     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).
+                                     ^self].
+                          
+                          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.
+                     ^self].
+              
+        node := self parseMessagePattern.
+        
+        "look for method"
+        (self skipToken: $[)
+            ifTrue: [self parseMethodSource: node. ^self].
+        
+        "look for instance variables"
+        (node selectorParts first value = #|)
+            ifTrue: [self parseInstanceVariables: node. ^self].
+            
+        self parserError: 'invalid class body element'
+    ]
+    
+    parseClassTag [
+        | selector argument stmt |
+        
+        self skipExpectedToken: #<.
+        
+        (currentToken isKeyword)
+            ifTrue: [selector := currentToken value asSymbol. self step]
+            ifFalse: [self parserError: 'expected keyword'].
+        
+        argument := self parsePrimitiveObject.
+        self skipExpectedToken: #>.
+        
+        argument isVariable
+            ifTrue: [stmt := RBMessageNode
+                         receiver: class
+                         selector: selector
+                         arguments: { argument }.
+                     self evaluateStatement: stmt]
+            ifFalse: [self evaluateMessageOn: class
+                           selector: selector
+                           argument: argument token value]
+    ]
+    
+    parseClassVariable [
+        | node stmt name |
+        
+        node := self parseAssignment.
+        node isAssignment
+            ifFalse: [self parserError: 'expected assignment'].
+        
+        self skipExpectedToken: $. .
+
+        name := RBLiteralNode value: (node variable name asSymbol).
+        node := self makeSequenceNode: node.
+        node := RBBlockNode body: node.
+        
+        stmt := RBMessageNode
+                receiver: class
+                selector: #addClassVarName:value:
+                arguments: { name . node }.
+
+        self evaluateStatement: stmt.
+    ]
+    
+    parseMetaclass [
+        | tmpClass |    
+        
+        self step. self step.
+        tmpClass := class.
+        class := self makeClassOf: class.
+        self parseClassBody.
+        class := tmpClass
+    ]
+    
+    parseMethodSource: patternNode [
+        self parseMethodSource: patternNode on: class
+    ]
+    
+    parseMethodSourceOn: classNode [
+        | patternNode |
+        
+        patternNode := self parseMessagePattern.
+        self skipExpectedToken: $[.
+        self parseMethodSource: patternNode on: classNode.
+    ]
+    
+    parseMethodSource: patternNode on: classNode [
+        "TODO: parse category tag inside methods"
+        | methodNode source start stop |
+        
+        start := patternNode selectorParts first start - 1.
+        methodNode := self parseMethodInto: patternNode.
+        stop := currentToken start - 1.
+        self skipExpectedToken: $].
+        source := scanner stream copyFrom: start to: stop.
+        source := MappedCollection collection: source map: (1 - start to: stop).
+        methodNode source: source.
+        
+        self evaluateMessageOn: classNode
+             selector: #methodsFor:
+             argument: nil.
+        
+        self compile: methodNode
+    ]
+    
+    parseInstanceVariables: node [
+        | 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).
+    ]
+    
+    makeSequenceNode: stmt [
+        | seq |
+ seq := RBSequenceNode
+            leftBar: nil
+            temporaries: #()
+            rightBar: nil.
+        seq statements: { stmt }.
+        seq periods: #().
+ ^seq
+    ]
+    
+    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)]
+    ]
+]


_______________________________________________
help-smalltalk mailing list
[hidden email]
http://lists.gnu.org/mailman/listinfo/help-smalltalk