[PATCH] SIF parser

SIF was the most useless part of the Smalltalk standard, but it's nice
to have it if it only takes ~200 lines of code, and it helps shaking
bugs in the converter.

For the curious, SIF is yet another variant of the bang-separated
format, and it looks like this:

     Class named: 'A' superclass: 'Object'
         indexedInstanceVariables: #none
         instanceVariableNames: 'a b c'
         classVariableNames: 'D'
         sharedPools: 'SystemExceptions'
         classInstanceVariableNames: 'e'!

     Annotation key: 'comment' value: 'comment'!

     A classMethod!
     initialize ^'a class method'!

     A method!
     initialize ^'a method'!

     Global initializer!
     'an eval' printNl!

     Global variable: 'GlobalX'!
     Global constant: 'GlobalY'!
     Pool named: 'MyPool'!

     GlobalX initializer!
     5!

     GlobalY initializer!
     | a |
     a := Set new.
     a add: 5.
     a!

     MyPool variable: 'MyPoolX'!
     MyPool constant: 'MyPoolY'!

     MyPool initializerFor: 'MyPoolX'!
     5!

     MyPool initializerFor: 'MyPoolY'!
     | a |
     a := Set new.
     a add: 5.
     a!

Paolo

2007-06-27  Paolo Bonzini  <[hidden email]>

        * scripts/Convert.st: Emit Namespace creation when needed.
        Emit form feeds here.

        * compiler/SIFParser.st: New.
        * compiler/SqueakParser.st: Use super.
        * compiler/STFileParser.st: Split part of #parseMethodDefinitionList
        into a separate method.
        * compiler/Exporter.st: Fix indentation of class-instance variables.
        Don't emit form feed character.



--- orig/TODO
+++ mod/TODO
@@ -1,21 +1,24 @@
 * 3.0
 
 ** implement new syntax (being done)
+*** implement GST syntax parser for STClassLoader
+*** option processing for scripts/Convert.st
+*** mega conversion of old source code and bug shaking
 
 ** implement a better packaging system allowing zipped source files with
 XML package descriptions to be delivered and installed.  Investigate
-basing it on the Virtual File System infrastructure.
+basing it on the Virtual File System infrastructure. (being done)
 
 ** faster startup (done)
 
 ** restructure init/pre/kernel files (done)
 
-** upgrade XML parser for package files
-*** support arch-dependent files that are installed in the image path
-
 
 * sometime
 
+** upgrade XML parser for package files
+*** support arch-dependent files that are installed in the image path
+
 ** some kind of sandboxing (partly done)
 
 ** add check in/check out to the browser so that .st files remain
@@ -88,9 +91,6 @@ outside #new and so on).
 
 * other
 
-** follow the implementation lines of compiler/STLoader.st to implement
-SIF file-in.
-
 ** make the smalltalk cpp work - nothing less, nothing more ;-)
 
 ** print entities correctly in the URIResolver.  A file named abc&def



--- orig/compiler/Exporter.st
+++ mod/compiler/Exporter.st
@@ -138,8 +138,7 @@ Object subclass: FileOutExporter [
         outClass environment = self defaultNamespace
         ifTrue: [ ^self fileOutClassBody: aBlock ].
         
-        outStream nextPut: 12 asCharacter; nl;
-                  nextPutAll: 'Namespace current: ';
+        outStream nextPutAll: 'Namespace current: ';
                   store: outClass environment;
                   nextPutAll: ' ['; nl; nl.
                   
@@ -216,10 +215,10 @@ Object subclass: FileOutExporter [
         "class instance varriables"            
         outClass asMetaclass instVarNames isEmpty
             ifFalse: [ outStream nl; space: 4; nextPutAll: outClass name;
-                       nextPutAll: ' class ['; nl; space: 4.
+                       nextPutAll: ' class ['; nl; tab.
                        outStream nextPut: $|; space.
                        self printFormattedSet: outClass asMetaclass instVarNames.
-                       outStream space; nextPut: $|; nl; space: 4.
+                       outStream space; nextPut: $|; nl; tab.
                        outStream nl; space: 4; nextPut: $]; nl ].
         
         "class variables"


--- orig/compiler/STFileParser.st
+++ mod/compiler/STFileParser.st
@@ -75,8 +75,8 @@ endMethodList
 evaluate: node
     "This should be overridden because its result affects the parsing
      process: true means 'start parsing methods', false means 'keep
-     evaluating'. By default, always answer false."
-    ^driver evaluate: node
+     evaluating'."
+    ^node statements size > 0 and: [ driver evaluate: node ]
 ! !
 
 !STFileParser methodsFor: 'utility'!
@@ -156,34 +156,37 @@ parseDoits
  node := self parseStatements.
         scanner stripSeparators.           "gobble doit terminating bang"
         self step.           "gobble doit terminating bang"
- node statements size > 0 and: [ self evaluate: node ]
+ self evaluate: node
     ] whileFalse.
     ^true
 !
 
+parseMethodFromFile
+    | node source start stop |
+    start := currentToken start - 1.
+    tags := nil.
+    node := self parseMethod.
+
+    "One -1 accounts for base-1 vs. base-0 (as above), the
+     other drops the bang because we have a one-token lookahead."
+    stop := currentToken start - 2.
+    source := scanner stream copyFrom: start to: stop.
+    source := MappedCollection collection: source map: (1 - start to: stop).
+    node source: source.
+
+    scanner stripSeparators.
+    self step.           "gobble method terminating bang"
+    ^node!
+
 parseMethodDefinitionList
     "Called after first !, expecting a set of bang terminated
      method definitions, followed by a bang"
 
-    | node source start stop |
     [ scanner atEnd or: [ currentToken isSpecial
    and: [ currentToken value == $! ] ] ] whileFalse: [
 
- start := currentToken start - 1.
-        tags := nil.
-        node := self parseMethod.
-
-        "One -1 accounts for base-1 vs. base-0 (as above), the
-         other drops the bang because we have a one-token lookahead."
- stop := currentToken start - 2.
-        source := scanner stream copyFrom: start to: stop.
- source := MappedCollection collection: source map: (1 - start to: stop).
-        node source: source.
-
-        scanner stripSeparators.
-        self step.           "gobble method terminating bang"
-        self compile: node
-    ].
+ self compile: self parseMethodFromFile ].
+
     scanner stripSeparators.
     self step.
     self endMethodList


--- orig/compiler/SqueakParser.st
+++ mod/compiler/SqueakParser.st
@@ -42,10 +42,10 @@ evaluate: node
      This avoids that the STParsingDriver need to know about other
      dialects."
     | stmt |
-    node statements size == 1 ifFalse: [ ^driver evaluate: node ].
+    node statements size == 1 ifFalse: [ ^super evaluate: node ].
 
     stmt := node statements first.
-    stmt isMessage ifFalse: [ ^driver evaluate: node ].
+    stmt isMessage ifFalse: [ ^super evaluate: node ].
     stmt selector == #addCategory: ifTrue: [ ^false ].
     stmt selector == #commentStamp:prior: ifTrue: [
  stmt arguments: { scanner nextRawChunk }.
@@ -58,7 +58,7 @@ evaluate: node
  stmt arguments: { stmt arguments first }.
  stmt selector: #methodsFor: ].
 
-    ^driver evaluate: node
+    ^super evaluate: node
 ! !
 
 !SqueakFileInParser methodsFor: 'private-parsing'!


--- orig/packages.xml.in
+++ mod/packages.xml.in
@@ -399,6 +399,7 @@
   <filein>STLoaderObjs.st</filein>
   <filein>STLoader.st</filein>
   <filein>SqueakParser.st</filein>
+  <filein>SIFParser.st</filein>
   <filein>Exporter.st</filein>
 
   <test>
@@ -421,6 +422,8 @@
   <file>STLoaderObjs.st</file>
   <file>STSymTable.st</file>
   <file>RewriteTests.st</file>
+  <file>SqueakParser.st</file>
+  <file>SIFParser.st</file>
   <file>Exporter.st</file>
 </package>
 


--- orig/scripts/Convert.st
+++ mod/scripts/Convert.st
@@ -140,7 +140,7 @@ EmittedEntity subclass: EmittedEval [
 
 
 STInST.STClassLoader subclass: SyntaxConverter [
-    | stuffToEmit classesToEmit outStream |
+    | stuffToEmit classesToEmit createdNamespaces outStream |
     
     <comment: 'A class loader that creates a set of "EmittedEntity"
     based on the contents of the given file being loaded.
@@ -154,6 +154,11 @@ STInST.STClassLoader subclass: SyntaxCon
         ^self convertStream: in with: STInST.SqueakFileInParser to: out
     ]
     
+    SyntaxConverter class >> convertSIFStream: in to: out [
+        <catogory: 'instance creation'>
+        ^self convertStream: in with: STInST.SIFFileInParser to: out
+    ]
+    
     SyntaxConverter class >> convertStream: in to: out [
         <catogory: 'instance creation'>
         ^self convertStream: in with: STInST.STFileInParser to: out
@@ -172,6 +177,7 @@ STInST.STClassLoader subclass: SyntaxCon
  super initialize.
         stuffToEmit := OrderedSet new.
         classesToEmit := Dictionary new.
+        createdNamespaces := OrderedSet new.
     ]
 
     outStream: out [
@@ -216,9 +222,21 @@ STInST.STClassLoader subclass: SyntaxCon
     ifFalse: [ stuffToEmit add: (EmittedEval new namespace: evalNamespace) ]
     ]
 
+    createNamespaces [
+ createdNamespaces do: [ :each || stmt |
+    stmt := RBMessageNode
+                receiver: (RBVariableNode named: (each superspace nameIn: self currentNamespace))
+                selector: #addSubspace:
+                arguments: { RBLiteralNode value: each name asSymbol }.
+    self lastEval addStatement: stmt
+ ].
+ createdNamespaces := OrderedSet new
+    ]
+
     unknown: node [
         <category: 'collecting entities'>
         
+ self createNamespaces.
  self lastEval addStatement: node.
         ^false
     ]
@@ -228,6 +246,9 @@ STInST.STClassLoader subclass: SyntaxCon
         
         | class emittedClass |
         
+ createdNamespaces remove: self currentNamespace ifAbsent: [ ].
+ self createNamespaces.
+
         class := super defineSubclass: receiver
                        selector: selector
                        arguments: argumentNodes.        
@@ -240,12 +261,20 @@ STInST.STClassLoader subclass: SyntaxCon
         ^false
     ]
     
+    doAddNamespace: receiver selector: selector arguments: argumentNodes [
+ | ns |
+ super doAddNamespace: receiver selector: selector arguments: argumentNodes.
+
+        ns := (self resolveNamespace: receiver) at: argumentNodes first value.
+ createdNamespaces add: ns
+    ]
+
     doEmitStuff [
         <category: 'emitting'>
 
-        stuffToEmit do: [ :each | each emitTo: outStream ].
-        stuffToEmit := OrderedSet new.
-        classesToEmit := Dictionary new
+        stuffToEmit
+    do: [ :each | each emitTo: outStream ]
+    separatedBy: [ outStream nl; nextPut: 12 asCharacter; nl ].
     ]
     
     addMethod: aMethod toLoadedClass: aClass [



* added files

--- /dev/null
+++ /Volumes/disk0s8/devel/gst/,,[hidden email]--2004b/new-files-archive/./compiler/.arch-ids/SIFParser.st.id
@@ -0,0 +1 @@
+Paolo Bonzini <[hidden email]> Tue Jun 26 09:44:12 2007 15063.0
--- /dev/null
+++ /Volumes/disk0s8/devel/gst/,,[hidden email]--2004b/new-files-archive/./compiler/SIFParser.st
@@ -0,0 +1,246 @@
+"======================================================================
+|
+|   SIF input parser
+|
+|
+ ======================================================================"
+
+
+"======================================================================
+|
+| Copyright 2007 Free Software Foundation, Inc.
+| Written by Paolo Bonzini.
+|
+| 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, 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.  
+|
+ ======================================================================"
+
+
+STFileInParser subclass: #SIFFileInParser
+    instanceVariableNames: 'lastClass'
+    classVariableNames: ''
+    poolDictionaries: ''
+    category: 'Refactory-Parser'!
+
+!SIFFileInParser methodsFor: 'parsing'!
+
+parseMethodDefinitionList
+    "Methods are defined one by one in SIF."
+    self compile: self parseMethodFromFile.
+    self endMethodList
+! !
+
+!SIFFileInParser methodsFor: 'evaluating'!
+
+evaluate: node
+    "Convert some SIF messages to GNU Smalltalk file-out syntax.
+     This avoids that the STParsingDriver need to know about other
+     dialects."
+    | stmt |
+    node statements size == 0 ifTrue: [ ^false ].
+    node statements size == 1 ifFalse: [ node printNl. ^self error: 'invalid SIF' ].
+
+    stmt := node statements first.
+    stmt isMessage ifFalse: [ ^super evaluate: node ].
+    stmt selector == #interchangeVersion: ifTrue: [ ^false ].
+
+    stmt selector == #named:superclass:indexedInstanceVariables:instanceVariableNames:classVariableNames:sharedPools:classInstanceVariableNames: ifTrue: [
+ lastClass := self evaluateClass: stmt.
+ ^false ].
+
+    stmt selector == #key:value: ifTrue: [
+ lastClass isNil
+    ifFalse: [ self evaluateAnnotation: stmt to: lastClass ].
+ ^false ].
+
+    stmt selector == #classMethod ifTrue: [
+ lastClass := nil.
+ self evaluateClassMethod: stmt.
+ ^true ].
+
+    stmt selector == #method ifTrue: [
+ lastClass := nil.
+ self evaluateMethod: stmt.
+ ^true ].
+
+    (stmt selector == #initializerFor:) ifTrue: [
+ lastClass := nil.
+ self evaluateInitializer: stmt.
+ ^false ].
+
+    (stmt selector == #initializer) ifTrue: [
+ lastClass := nil.
+ self evaluateGlobalInitializer: stmt.
+ ^false ].
+
+    (stmt selector == #variable: or: [ stmt selector == #constant: ]) ifTrue: [
+ lastClass := nil.
+ self evaluatePoolDefinition: stmt.
+ ^false ].
+
+    stmt selector == #named: ifTrue: [
+ lastClass := nil.
+ self evaluatePool: stmt.
+ ^false ].
+
+    stmt printNl.
+    self error: 'invalid SIF'
+!
+
+evaluateStatement: stmt
+    driver evaluate: (RBSequenceNode new
+ temporaries: #();
+ statements: { stmt })
+!
+
+evaluateClass: stmt
+    "Convert `Class named: ...' syntax to GNU Smalltalk file-out syntax."
+    | name superclass shape ivn cvn sp civn newStmt newClass |
+    name := stmt arguments at: 1.
+    superclass := stmt arguments at: 2.
+    shape := stmt arguments at: 3.
+    ivn := stmt arguments at: 4.
+    cvn := stmt arguments at: 5.
+    sp := stmt arguments at: 6.
+    civn := stmt arguments at: 7.
+
+    shape value = #none
+ ifTrue: [ shape := RBLiteralNode value: nil ].
+    shape value = #object
+ ifTrue: [ shape := RBLiteralNode value: #pointer ].
+
+    newStmt := RBMessageNode
+ receiver: (RBVariableNode named: superclass value)
+ selector: #variable:subclass:instanceVariableNames:classVariableNames:poolDictionaries:category:
+ arguments: {
+ shape. RBLiteralNode value: name value asSymbol.
+ ivn. cvn. sp. RBLiteralNode value: nil }.
+    self evaluateStatement: newStmt.
+
+    newClass := RBVariableNode named: name value.
+    newStmt := RBMessageNode
+    receiver: (self makeClassOf: newClass)
+    selector: #instanceVariableNames:
+    arguments: { civn }.
+    self evaluateStatement: newStmt.
+
+    ^newClass!
+
+makeClassOf: node
+    ^RBMessageNode
+ receiver: node
+ selector: #class
+ arguments: #()!
+
+evaluateAnnotation: stmt to: object
+    "Convert `Annotation key: ...' syntax to GNU Smalltalk file-out syntax."
+    | key value selector newStmt |
+    key := stmt arguments at: 1.
+    value := stmt arguments at: 2.
+    key value = 'package' ifTrue: [ selector := #category: ].
+    key value = 'category' ifTrue: [ selector := #category: ].
+    key value = 'comment' ifTrue: [ selector := #comment: ].
+    selector isNil ifFalse: [
+        newStmt := RBMessageNode
+    receiver: object
+    selector: selector
+    arguments: { value }.
+        self evaluateStatement: newStmt ]!
+
+evaluateClassMethod: stmt
+    "Convert `Foo classMethod' syntax to GNU Smalltalk file-out syntax."
+    stmt receiver: (self makeClassOf: stmt receiver).
+    self evaluateMethod: stmt!
+
+evaluateMethod: stmt
+    "Convert `Foo method' syntax to GNU Smalltalk file-out syntax."
+    | newStmt |
+    newStmt := RBMessageNode
+ receiver: stmt receiver
+ selector: #methodsFor:
+ arguments: { RBLiteralNode value: nil }.
+    self evaluateStatement: newStmt!
+
+evaluateInitializer: stmt
+    "Convert `Foo initializerFor: Bar' syntax to GNU Smalltalk file-out syntax."
+    self
+ evaluateInitializerFor: stmt arguments first value
+ in: stmt receiver!
+
+evaluateGlobalInitializer: stmt
+    "Convert `Foo initializer' syntax to GNU Smalltalk file-out syntax."
+    | node |
+    stmt receiver name = 'Global' ifTrue: [
+ node := self parseStatements.
+        scanner stripSeparators.
+        self step.
+ ^super evaluate: node ].
+
+    self
+ evaluateInitializerFor: stmt receiver name
+ in: (RBVariableNode named: 'Smalltalk')!
+
+evaluateInitializerFor: key in: receiver
+    | position node arg newStmt |
+    position := currentToken start.
+    node := RBOptimizedNode
+                left: position
+                body: self parseStatements
+                right: currentToken start.
+
+    scanner stripSeparators.
+    self step.
+    newStmt := RBMessageNode
+    receiver: receiver
+    selector: #at:put:
+    arguments: { RBLiteralNode value: key asSymbol. node }.
+    self evaluateStatement: newStmt!
+    
+evaluatePoolDefinition: stmt
+    "Convert `Foo variable:/constant: ...' syntax to GNU Smalltalk file-out
+     syntax."
+    | receiver key newStmt |
+    receiver := stmt receiver.
+    receiver name = 'Global' ifTrue: [ receiver := RBVariableNode named: 'Smalltalk' ].
+    key := RBLiteralNode value: stmt arguments first value asSymbol.
+
+    newStmt := RBMessageNode
+    receiver: receiver
+    selector: #at:put:
+    arguments: { key. RBLiteralNode value: nil }.
+
+    self evaluateStatement: newStmt!
+
+evaluatePool: stmt
+    "Convert `Pool named: ...' syntax to GNU Smalltalk file-out syntax."
+    | key newStmt |
+    key := RBLiteralNode value: stmt arguments first value asSymbol .
+    newStmt := RBMessageNode
+    receiver: (RBVariableNode named: 'Smalltalk')
+    selector: #addSubspace:
+    arguments: { key }.
+
+    self evaluateStatement: newStmt!
+! !
+
+!SIFFileInParser methodsFor: 'private-parsing'!
+
+scannerClass
+    "We need a special scanner to convert the double-bangs in strings
+     to single bangs.  Unlike in GNU Smalltalk, all bangs must be
+     `escaped' in Squeak."
+    ^SqueakFileInScanner! !
+


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