diff --git a/repository/ViennaTalk-Parser-AST/ViennaMapDomainRestrictedByNode.class.st b/repository/ViennaTalk-Parser-AST/ViennaMapDomainRestrictedByNode.class.st index 3403cab7..4bb5591c 100644 --- a/repository/ViennaTalk-Parser-AST/ViennaMapDomainRestrictedByNode.class.st +++ b/repository/ViennaTalk-Parser-AST/ViennaMapDomainRestrictedByNode.class.st @@ -46,3 +46,18 @@ ViennaMapDomainRestrictedByNode >> paramType2 [ ^ ViennaType any mapTo: ViennaType any ] + +{ #category : #accessing } +ViennaMapDomainRestrictedByNode >> returnTypeFor: aViennaType1 and: aViennaType2 [ + + | setbasetype domainbasetype rangebasetype | + setbasetype := aViennaType1 basetype. + domainbasetype := aViennaType2 keytype. + rangebasetype := aViennaType2 valuetype. + (setbasetype isCompatibleWith: domainbasetype) ifFalse: [ + ^ ViennaTypeError + on: self + signal: 'Tye mismatch: ' , setbasetype printString , ' and ' + , domainbasetype printString ]. + ^ aViennaType2 +] diff --git a/repository/ViennaTalk-Parser-AST/ViennaMapDomainRestrictedToNode.class.st b/repository/ViennaTalk-Parser-AST/ViennaMapDomainRestrictedToNode.class.st index a1f41d55..136e5df2 100644 --- a/repository/ViennaTalk-Parser-AST/ViennaMapDomainRestrictedToNode.class.st +++ b/repository/ViennaTalk-Parser-AST/ViennaMapDomainRestrictedToNode.class.st @@ -34,3 +34,30 @@ ViennaMapDomainRestrictedToNode >> operatorPrecedence [ ^ 34 ] + +{ #category : #accessing } +ViennaMapDomainRestrictedToNode >> paramType1 [ + + ^ ViennaType any set +] + +{ #category : #accessing } +ViennaMapDomainRestrictedToNode >> paramType2 [ + + ^ ViennaType any mapTo: ViennaType any +] + +{ #category : #accessing } +ViennaMapDomainRestrictedToNode >> returnTypeFor: aViennaType1 and: aViennaType2 [ + + | setbasetype domainbasetype rangebasetype | + setbasetype := aViennaType1 basetype. + domainbasetype := aViennaType2 keytype. + rangebasetype := aViennaType2 valuetype. + (setbasetype isCompatibleWith: domainbasetype) ifFalse: [ + ^ ViennaTypeError + on: self + signal: 'Tye mismatch: ' , setbasetype printString , ' and ' + , domainbasetype printString ]. + ^ aViennaType2 +] diff --git a/repository/ViennaTalk-Parser-AST/ViennaMapMergeNode.class.st b/repository/ViennaTalk-Parser-AST/ViennaMapMergeNode.class.st index afafa7f5..dce163ee 100644 --- a/repository/ViennaTalk-Parser-AST/ViennaMapMergeNode.class.st +++ b/repository/ViennaTalk-Parser-AST/ViennaMapMergeNode.class.st @@ -34,3 +34,38 @@ ViennaMapMergeNode >> operatorPrecedence [ ^ 31 ] + +{ #category : #accessing } +ViennaMapMergeNode >> paramType1 [ + + ^ ViennaType any mapTo: ViennaType any +] + +{ #category : #accessing } +ViennaMapMergeNode >> paramType2 [ + + ^ ViennaType any mapTo: ViennaType any +] + +{ #category : #accessing } +ViennaMapMergeNode >> returnTypeFor: aViennaType1 and: aViennaType2 [ + + | domaintype1 domaintype2 domaintype rangetype1 rangetype2 rangetype | + domaintype1 := aViennaType1 keytype. + domaintype2 := aViennaType2 keytype. + domaintype := domaintype1 >= domaintype2 + ifTrue: [ domaintype1 ] + ifFalse: [ + domaintype2 >= domaintype1 + ifTrue: [ domaintype2 ] + ifFalse: [ domaintype1 | domaintype2 ] ]. + rangetype1 := aViennaType1 valuetype. + rangetype2 := aViennaType2 valuetype. + rangetype := rangetype1 >= rangetype2 + ifTrue: [ rangetype1 ] + ifFalse: [ + rangetype2 >= rangetype1 + ifTrue: [ rangetype2 ] + ifFalse: [ rangetype1 | rangetype2 ] ]. + ^ domaintype mapTo: rangetype +] diff --git a/repository/ViennaTalk-Parser-Tests/ViennaMapDomainRestrictedByNodeTest.class.st b/repository/ViennaTalk-Parser-Tests/ViennaMapDomainRestrictedByNodeTest.class.st new file mode 100644 index 00000000..8d0be265 --- /dev/null +++ b/repository/ViennaTalk-Parser-Tests/ViennaMapDomainRestrictedByNodeTest.class.st @@ -0,0 +1,32 @@ +" +A ViennaMapDomainRestrictedByNodeTest is a test class for testing the behavior of ViennaMapDomainRestrictedByNode +" +Class { + #name : #ViennaMapDomainRestrictedByNodeTest, + #superclass : #TestCase, + #category : #'ViennaTalk-Parser-Tests' +} + +{ #category : #tests } +ViennaMapDomainRestrictedByNodeTest >> testTypecheck [ + + | expr | + expr := 's <-: m' asViennaExpressionAst. + + expr expression1 maximalType: ViennaType nat set. + expr expression2 maximalType: (ViennaType nat mapTo: ViennaType char). + self + assert: (expr typecheck: (ViennaType nat mapTo: ViennaType char)) + equals: (ViennaType nat mapTo: ViennaType char). + expr expression1 maximalType: ViennaType nat optional set. + expr expression2 maximalType: + (ViennaType real mapTo: ViennaType char). + self + assert: (expr typecheck: (ViennaType real mapTo: ViennaType char)) + equals: (ViennaType real mapTo: ViennaType char). + expr expression1 maximalType: ViennaType char set. + expr expression2 maximalType: (ViennaType nat mapTo: ViennaType char). + self + should: [ expr typecheck: (ViennaType real mapTo: ViennaType char) ] + raise: ViennaTypeError +] diff --git a/repository/ViennaTalk-Parser-Tests/ViennaMapDomainRestrictedToNodeTest.class.st b/repository/ViennaTalk-Parser-Tests/ViennaMapDomainRestrictedToNodeTest.class.st new file mode 100644 index 00000000..1a845862 --- /dev/null +++ b/repository/ViennaTalk-Parser-Tests/ViennaMapDomainRestrictedToNodeTest.class.st @@ -0,0 +1,29 @@ +Class { + #name : #ViennaMapDomainRestrictedToNodeTest, + #superclass : #TestCase, + #category : #'ViennaTalk-Parser-Tests' +} + +{ #category : #tests } +ViennaMapDomainRestrictedToNodeTest >> testTypecheck [ + + | expr | + expr := 's <: m' asViennaExpressionAst. + + expr expression1 maximalType: ViennaType nat set. + expr expression2 maximalType: (ViennaType nat mapTo: ViennaType char). + self + assert: (expr typecheck: (ViennaType nat mapTo: ViennaType char)) + equals: (ViennaType nat mapTo: ViennaType char). + expr expression1 maximalType: ViennaType nat optional set. + expr expression2 maximalType: + (ViennaType real mapTo: ViennaType char). + self + assert: (expr typecheck: (ViennaType real mapTo: ViennaType char)) + equals: (ViennaType real mapTo: ViennaType char). + expr expression1 maximalType: ViennaType char set. + expr expression2 maximalType: (ViennaType nat mapTo: ViennaType char). + self + should: [ expr typecheck: (ViennaType real mapTo: ViennaType char) ] + raise: ViennaTypeError +] diff --git a/repository/ViennaTalk-Parser-Tests/ViennaMapMergeNodeTest.class.st b/repository/ViennaTalk-Parser-Tests/ViennaMapMergeNodeTest.class.st new file mode 100644 index 00000000..04b95223 --- /dev/null +++ b/repository/ViennaTalk-Parser-Tests/ViennaMapMergeNodeTest.class.st @@ -0,0 +1,38 @@ +" +A ViennaMapMergeNodeTest is a test class for testing the behavior of ViennaMapMergeNode +" +Class { + #name : #ViennaMapMergeNodeTest, + #superclass : #TestCase, + #category : #'ViennaTalk-Parser-Tests' +} + +{ #category : #tests } +ViennaMapMergeNodeTest >> testTypecheck [ + + | expr | + expr := 'm1 munion m2' asViennaExpressionAst. + + expr expression1 maximalType: (ViennaType nat mapTo: ViennaType char). + expr expression2 maximalType: (ViennaType nat mapTo: ViennaType char). + self + assert: (expr typecheck: (ViennaType nat mapTo: ViennaType char)) + equals: (ViennaType nat mapTo: ViennaType char). + + expr expression1 maximalType: + (ViennaType nat optional mapTo: ViennaType char). + expr expression2 maximalType: + (ViennaType nat mapTo: ViennaType char optional). + self + assert: (expr typecheck: + (ViennaType nat optional mapTo: ViennaType char optional)) + equals: (ViennaType nat optional mapTo: ViennaType char optional). + + expr expression1 maximalType: (ViennaType nat mapTo: ViennaType char). + expr expression2 maximalType: (ViennaType char mapTo: ViennaType nat). + self + assert: (expr typecheck: (ViennaType nat | ViennaType char mapTo: + ViennaType nat | ViennaType char)) + equals: (ViennaType nat | ViennaType char mapTo: + ViennaType char | ViennaType nat) +]