Mercurial Mercurial > hg > jv-tea / changeset
summary | shortlog | changelog | graph | tags | bookmarks | branches | files | changeset | raw | zip | gz | bz2 | help
Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Fixes/refactoring of scopes and bindings.
authorJan Vrany <jan.vrany@fit.cvut.cz>
Sun, 20 Sep 2015 12:01:42 +0100
changeset 13 97090c2baa33
parent 12 d716a8181fc1
child 14 fa42d3f1a578
Fixes/refactoring of scopes and bindings. Fixed initialization of scopes and bindings. Make typechecker to seed types.
compiler/TArgumentBinding.st file | annotate | diff | comparison | revisions
compiler/TCompilerContext.st file | annotate | diff | comparison | revisions
compiler/TCompilerExamples.st file | annotate | diff | comparison | revisions
compiler/TConstantBinding.st file | annotate | diff | comparison | revisions
compiler/TScope.st file | annotate | diff | comparison | revisions
compiler/TSemanticAnalyser.st file | annotate | diff | comparison | revisions
compiler/TSemanticAnalyserTests.st file | annotate | diff | comparison | revisions
compiler/TTypechecker.st file | annotate | diff | comparison | revisions
compiler/TVariableBinding.st file | annotate | diff | comparison | revisions 
--- a/compiler/TArgumentBinding.st	Fri Sep 18 06:20:53 2015 +0100
+++ b/compiler/TArgumentBinding.st	Sun Sep 20 12:01:42 2015 +0100
@@ -3,7 +3,7 @@
 "{ NameSpace: Smalltalk }"
 
 TVariableBinding subclass:#TArgumentBinding
-	instanceVariableNames:'index'
+	instanceVariableNames:''
 	classVariableNames:''
 	poolDictionaries:''
 	category:'Languages-Tea-Compiler-Bindings'
@@ -18,8 +18,8 @@
 
 !TArgumentBinding methodsFor:'initialization'!
 
-index:something
-    index := something.
+index:anInteger
+    index := anInteger.
 ! !
 
 !TArgumentBinding methodsFor:'printing & storing'!
--- a/compiler/TCompilerContext.st	Fri Sep 18 06:20:53 2015 +0100
+++ b/compiler/TCompilerContext.st	Sun Sep 20 12:01:42 2015 +0100
@@ -38,6 +38,13 @@
 
 !TCompilerContext methodsFor:'error reporting'!
 
+reportSemanticError: message
+
+    TCompilerError raiseErrorString: message
+
+    "Created: / 20-09-2015 / 06:13:42 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
 reportTypeError: message
 
     TCompilerError raiseErrorString: message
--- a/compiler/TCompilerExamples.st	Fri Sep 18 06:20:53 2015 +0100
+++ b/compiler/TCompilerExamples.st	Sun Sep 20 12:01:42 2015 +0100
@@ -19,6 +19,40 @@
 
 !TCompilerExamples methodsFor:'tests'!
 
+example_factorialI
+    | environment unit compiler|
+
+    environment := TEnvironment new.
+    unit := TSourceReader read:'
+nil subclass: #FactorialI
+    category: ''t-Examples''
+!!
+!!FactorialI class methodsFor:''examples''!!
+factorialI:v <tSIntegerW> <^ tSIntegerW>
+    | result <tSIntegerW> 
+      i <tSIntegerW> |
+
+    result := 0.
+    i := v.
+
+    [ i > 1 ] whileTrue:[ 
+        result := result * i.
+        i := i - 1
+    ].
+    ^ result
+!! !!
+    '.
+
+    compiler := TCompiler new.
+    compiler compile: unit in: environment.
+    self halt.
+    "
+    compiler context module
+    "
+
+    "Created: / 19-09-2015 / 18:29:15 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
 example_if
     | environment unit compiler|
 
--- a/compiler/TConstantBinding.st	Fri Sep 18 06:20:53 2015 +0100
+++ b/compiler/TConstantBinding.st	Sun Sep 20 12:01:42 2015 +0100
@@ -12,10 +12,10 @@
 
 !TConstantBinding class methodsFor:'instance creation'!
 
-value: anObject type: aTType
-    ^ self new initializeWithValue: anObject type: aTType
+value: anObject
+    ^ self new initializeWithValue: anObject
 
-    "Created: / 15-09-2015 / 08:19:32 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+    "Created: / 20-09-2015 / 07:11:25 / Jan Vrany <jan.vrany@fit.cvut.cz>"
 ! !
 
 !TConstantBinding methodsFor:'accessing'!
@@ -37,11 +37,10 @@
 
 !TConstantBinding methodsFor:'initialization'!
 
-initializeWithValue: anObject type: aTType
+initializeWithValue: anObject
     value := anObject.
-    type := aTType.
 
-    "Created: / 15-09-2015 / 08:19:13 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+    "Created: / 20-09-2015 / 07:11:37 / Jan Vrany <jan.vrany@fit.cvut.cz>"
 ! !
 
 !TConstantBinding methodsFor:'testing'!
--- a/compiler/TScope.st	Fri Sep 18 06:20:53 2015 +0100
+++ b/compiler/TScope.st	Sun Sep 20 12:01:42 2015 +0100
@@ -37,29 +37,24 @@
 
 parent
     ^ parent
+!
+
+variables
+    ^ variables ? #()
+
+    "Modified: / 19-09-2015 / 05:56:30 / Jan Vrany <jan.vrany@fit.cvut.cz>"
 ! !
 
-!TScope methodsFor:'initialization'!
-
-initializeWithNode: n parent: p
-    node := n.
-    parent := p.
+!TScope methodsFor:'adding & removing'!
 
-    "Created: / 25-08-2015 / 22:25:12 / Jan Vrany <jan.vrany@fit.cvut.cz>"
-! !
-
-!TScope methodsFor:'instance creation'!
-
-subScope: methodOrBlockNode
+addSubScope: aTScope
     children isNil ifTrue:[ 
         children := OrderedCollection new: 5.
     ].
-    ^ children add: (self class node: methodOrBlockNode parent: self)
+    children add: aTScope
 
-    "Created: / 25-08-2015 / 22:28:02 / Jan Vrany <jan.vrany@fit.cvut.cz>"
-! !
-
-!TScope methodsFor:'lookup'!
+    "Created: / 19-09-2015 / 06:05:50 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
 
 addVariable: aTVariableBinding
     variables isNil ifTrue:[ 
@@ -68,14 +63,36 @@
     variables add: aTVariableBinding
 
     "Created: / 25-08-2015 / 22:42:29 / Jan Vrany <jan.vrany@fit.cvut.cz>"
-!
+! !
+
+!TScope methodsFor:'initialization'!
+
+initializeWithNode: n parent: p
+    node := n.
+    parent := p.
+    parent notNil ifTrue:[ 
+        parent addSubScope: self.  
+    ].
+
+    "Created: / 25-08-2015 / 22:25:12 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+    "Modified: / 19-09-2015 / 06:06:27 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+! !
+
+!TScope methodsFor:'lookup'!
 
 lookupVariable: name
-    ^ variables 
-        detect:[:binding |  binding name = name ] 
-        ifNone:[ parent notNil ifTrue:[ parent lookupVariable: name ] ifFalse:[ self error:'variable not found' ] ]
+    "Return binding for variable with given name or nil if not found"
+    | variable |
+    variables notNil ifTrue:[ 
+        variable := variables detect:[:binding |  binding name = name ] ifNone:[ nil ].
+    ].
+    (variable isNil and:[parent notNil]) ifTrue:[
+        variable := parent lookupVariable: name.  
+    ].
+    ^ variable
 
     "Created: / 25-08-2015 / 22:58:18 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+    "Modified: / 20-09-2015 / 06:11:23 / Jan Vrany <jan.vrany@fit.cvut.cz>"
 ! !
 
 !TScope methodsFor:'testing'!
--- a/compiler/TSemanticAnalyser.st	Fri Sep 18 06:20:53 2015 +0100
+++ b/compiler/TSemanticAnalyser.st	Sun Sep 20 12:01:42 2015 +0100
@@ -14,10 +14,9 @@
 documentation
 "
     This is the very first pass on the code. Its responsibility is:
-    * initialize bindings including types (except for message sends as those
-      depends on type analysis)
+    * initialize bindings 
     * initialize scopes (i.e, assign scopes and populate them
-      with variables)
+      with variable bindings)
 
     [author:]
         Jan Vrany <jan.vrany@fit.cvut.cz>
@@ -41,13 +40,13 @@
     ] ifFalse:[ 
         binding := TArgumentBinding name:anRBVariableNode name.
         binding index: (anRBVariableNode parent arguments indexOf: anRBVariableNode)                                
-                       + (currentScope isMethodScope ifTrue:[1] ifFalse:[0])     
+                       + (anRBVariableNode parent scope isMethodScope ifTrue:[1] ifFalse:[0])     
     ].
     anRBVariableNode parent scope addVariable: binding.
     super visitArgument: anRBVariableNode.
 
     "Created: / 25-08-2015 / 22:51:40 / Jan Vrany <jan.vrany@fit.cvut.cz>"
-    "Modified: / 02-09-2015 / 08:58:32 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+    "Modified: / 19-09-2015 / 06:17:50 / Jan Vrany <jan.vrany@fit.cvut.cz>"
 ! !
 
 !TSemanticAnalyser methodsFor:'visitor-double dispatching'!
@@ -55,15 +54,15 @@
 acceptBlockNode: aBlockNode
     | scope |
     aBlockNode parent isSpecialFormNode ifTrue:[ 
-        scope := currentScope subScope: aBlockNode.
+        scope := TScope node: aBlockNode parent: aBlockNode parent scope
     ] ifFalse:[ 
-        scope := TScope new.
+        scope := TScope node: aBlockNode
     ].
     aBlockNode scope: scope.
     super acceptBlockNode: aBlockNode
 
     "Created: / 25-08-2015 / 22:30:21 / Jan Vrany <jan.vrany@fit.cvut.cz>"
-    "Modified: / 14-09-2015 / 14:04:06 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+    "Modified: / 19-09-2015 / 06:16:41 / Jan Vrany <jan.vrany@fit.cvut.cz>"
 !
 
 acceptLiteralNode: aRBLiteralNode
@@ -72,7 +71,7 @@
     super acceptLiteralNode: aRBLiteralNode.
     value := aRBLiteralNode value.
     value isInteger ifTrue:[ 
-        aRBLiteralNode binding: (TConstantBinding value: value type: (context environment binding lookupClassSIntegerW) type).
+        aRBLiteralNode binding: (TConstantBinding value: value).
         ^ self.
     ].
     value isBoolean ifTrue:[ 
@@ -82,7 +81,7 @@
     self erorr: 'Unsupported constant'.
 
     "Created: / 25-08-2015 / 23:17:30 / Jan Vrany <jan.vrany@fit.cvut.cz>"
-    "Modified: / 15-09-2015 / 08:27:47 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+    "Modified: / 20-09-2015 / 07:12:23 / Jan Vrany <jan.vrany@fit.cvut.cz>"
 !
 
 acceptMethodNode: aMethodNode
@@ -102,10 +101,18 @@
 !
 
 acceptVariableNode: aVariableNode
-    aVariableNode binding: (aVariableNode scope lookupVariable: aVariableNode name).
+    | binding |
+
+    binding := aVariableNode scope lookupVariable: aVariableNode name.      
+    binding isNil ifTrue:[ 
+        context reportSemanticError: ('Undeclared variable %1' bindWith: aVariableNode name).
+        ^ self.
+    ].
+    aVariableNode binding: binding.
     super acceptVariableNode: aVariableNode
 
     "Created: / 25-08-2015 / 23:00:34 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+    "Modified: / 20-09-2015 / 06:14:37 / Jan Vrany <jan.vrany@fit.cvut.cz>"
 ! !
 
 !TSemanticAnalyser class methodsFor:'documentation'!
--- a/compiler/TSemanticAnalyserTests.st	Fri Sep 18 06:20:53 2015 +0100
+++ b/compiler/TSemanticAnalyserTests.st	Sun Sep 20 12:01:42 2015 +0100
@@ -3,21 +3,107 @@
 "{ NameSpace: Smalltalk }"
 
 TestCase subclass:#TSemanticAnalyserTests
-	instanceVariableNames:''
+	instanceVariableNames:'environment'
 	classVariableNames:''
 	poolDictionaries:''
 	category:'Languages-Tea-Compiler-Internals-Tests'
 !
 
+
+!TSemanticAnalyserTests methodsFor:'running'!
+
+setUp
+    super setUp.
+    environment := TEnvironment new
+
+    "Modified: / 19-09-2015 / 05:54:33 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+tearDown
+    environment := nil.
+    super tearDown.
+
+    "Modified: / 19-09-2015 / 05:54:47 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+! !
+
 !TSemanticAnalyserTests methodsFor:'tests'!
 
-test_01
+test_bindings_01
+    | class method tree |
+
+    class := TClassDefinition newClass name: 'tSIntegerW'.
+    method := TMethodDefinition class: class selector: 'foo'.
+    method source: 'foo <^ tSIntegerW> | a <tSIntegerW> | ^ a + 1'.
+    tree := method parseTree.
 
-    "Created: / 29-08-2015 / 14:11:42 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+    TSemanticAnalyser runOn: tree inEnvironment: environment.
+
+    self assert: tree body temporaries first binding isLocalBinding.
+    self assert: tree body statements first"^ node" value receiver"a node" binding == tree body temporaries first binding.
+    self assert: tree body statements first"^ node" value arguments first"1 node" binding isConstantBinding.
+
+    "Created: / 19-09-2015 / 06:33:29 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+    "Modified: / 19-09-2015 / 18:14:34 / Jan Vrany <jan.vrany@fit.cvut.cz>"
 !
 
-test_special_form_01
+test_scopes_01
+    | class method tree |
+
+    class := TClassDefinition newClass name: 'TestClass'.
+    method := TMethodDefinition class: class selector: 'foo'.
+    method source: 'foo <^ TestClass> self do:[ :each <tSIntegerW> | each ]'.
+    tree := method parseTree.
+
+    TSemanticAnalyser runOn: tree inEnvironment: environment.
+
+    self assert: tree scope parent isNil.
+    self assert: tree scope node == tree.
+    self assert: tree scope children isEmptyOrNil.
+    self assert: tree scope variables size == 1"self".
+    self assert: tree body scope == tree scope.
+
+    self assert: tree body statements first arguments first scope parent isNil. "Not an inlined block"
+    self assert: tree body statements first arguments first scope node == tree body statements first arguments first.
+    self assert: tree body statements first arguments first scope children isEmptyOrNil.
+    self assert: tree body statements first arguments first scope variables size == 1"each".
+    self assert: tree body statements first arguments first scope variables anElement name = 'each'.
+
+    "Created: / 19-09-2015 / 05:53:56 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
 
-    "Created: / 14-09-2015 / 12:54:06 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+test_scopes_02
+    | class method tree |
+
+    class := TClassDefinition newClass name: 'TestClass'.
+    method := TMethodDefinition class: class selector: 'foo'.
+    method source: 'foo <^ TestClass> true ifTrue:[ false ifTrue:[ ] ]'.
+    tree := method parseTree.
+
+    TSemanticAnalyser runOn: tree inEnvironment: environment.
+
+    self assert: tree scope parent isNil.
+    self assert: tree scope node == tree.
+    self assert: tree scope children size == 1"ifTrue: scope".
+    self assert: tree scope variables size == 1"self".
+    self assert: tree body scope == tree scope.
+
+    self assert: tree body statements first arguments first scope parent == tree scope. 
+    self assert: tree body statements first arguments first scope node == tree body statements first arguments first.
+    self assert: tree body statements first arguments first scope children size == 1.
+    self assert: tree body statements first arguments first scope variables isEmpty.
+
+    self assert: tree body statements first arguments first "outer block"
+                      body statements first arguments first "inner block" scope parent 
+                 ==
+                 tree body statements first arguments first"outer block" scope.
+
+    "Created: / 19-09-2015 / 06:11:21 / Jan Vrany <jan.vrany@fit.cvut.cz>"
 ! !
 
+!TSemanticAnalyserTests class methodsFor:'documentation'!
+
+version_HG
+
+    ^ '$Changeset: <not expanded> $'
+! !
+
--- a/compiler/TTypechecker.st	Fri Sep 18 06:20:53 2015 +0100
+++ b/compiler/TTypechecker.st	Sun Sep 20 12:01:42 2015 +0100
@@ -9,6 +9,19 @@
 	category:'Languages-Tea-Compiler-Internals'
 !
 
+!TTypechecker methodsFor:'visiting'!
+
+visitArgument: anRBVariableNode
+    | binding |
+
+
+    super visitArgument: anRBVariableNode.
+    binding := anRBVariableNode binding.
+    binding type: (anRBVariableNode typeSpec asType)
+
+    "Created: / 20-09-2015 / 07:19:27 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+! !
+
 !TTypechecker methodsFor:'visitor-double dispatching'!
 
 acceptIfTrueIfFalseNode: node
@@ -38,6 +51,24 @@
     "Created: / 14-09-2015 / 14:18:28 / Jan Vrany <jan.vrany@fit.cvut.cz>"
 !
 
+acceptLiteralNode: aLiteralNode
+    | binding value |
+
+    binding := aLiteralNode binding.
+    value := binding value.
+    value isInteger ifTrue:[ 
+        binding type: (context environment binding lookupClassSIntegerW) type.
+        ^ self
+    ].
+    value isBoolean ifTrue:[ 
+        binding type: (context environment binding lookupClassBoolean) type.
+        ^ self.
+    ].
+    context reportTypeError: 'Unsupported constant type'.
+
+    "Created: / 20-09-2015 / 07:13:45 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
 acceptMessageNode: aMessageNode 
     | receiverType receiverBinding methodBinding |
 
--- a/compiler/TVariableBinding.st	Fri Sep 18 06:20:53 2015 +0100
+++ b/compiler/TVariableBinding.st	Sun Sep 20 12:01:42 2015 +0100
@@ -3,7 +3,7 @@
 "{ NameSpace: Smalltalk }"
 
 TValueBinding subclass:#TVariableBinding
-	instanceVariableNames:'name'
+	instanceVariableNames:'name index'
 	classVariableNames:''
 	poolDictionaries:''
 	category:'Languages-Tea-Compiler-Bindings'
hg/jv-tea