Merge pull request #208 from moosetechnology/new-patch

New patch

Author: uNouss

src/EsopeImporter-Tests/IASTToFamixVisitorTest.class.st

@@ -25,6 +25,12 @@ IASTToFamixVisitorTest >> anchorFrom: startPoint to: endPoint [
 		  yourself
 ]
 
+{ #category : 'tests-esope' }
+IASTToFamixVisitorTest >> attribute: symbol for: famixEntity [
+
+	^ famixEntity attributeAt: symbol ifAbsent: [ nil ]
+]
+
 { #category : 'running' }
 IASTToFamixVisitorTest >> defaultAnchor [
 
@@ -481,6 +487,42 @@ IASTToFamixVisitorTest >> testFamixEsopePointerAccess [
 		(acc attributeAt: #entity ifAbsent: ["impossible"]) entityName = 'att']).
 ]
 
+{ #category : 'tests-esope' }
+IASTToFamixVisitorTest >> testFamixEsopePointerAccessWithSegment [
+	"SUBROUTINE sub
+      ptr.att = 5
+      END
+	"
+
+	| accesses iastVar segment access |
+	iastVar := self defaultVarAccess: 'ptr' isWrite: true.
+	iastVar dereferencedVariable: (self defaultVarAccess: 'att' isWrite: false).
+	
+	visitor model: FamixEsopeModel new.
+	segment := (visitor model newSegment name: 'foo').
+	segment addAttribute: (visitor model newAttributeNamed: 'att').
+	(visitor model newVariableNamed: 'ptr') declaredType: segment.
+
+	programFile body: { IASTSubroutine new
+		entityName: 'sub';
+		body: { iastVar } ;
+		yourself
+	}.
+
+	programFile accept: visitor.
+
+	accesses := visitor model allAccesses.
+	self assert: accesses size equals: 2.
+
+	access := accesses detect: [:each | 
+		(self attribute: #entity for: each) ~= iastVar ].
+
+	self assert: (self attribute: #parentAccess for: access) isNotNil.
+
+	access := self attribute: #parentAccess for: access.
+	self assert:  (self attribute: #entity for: access) entityName equals: 'ptr'.
+]
+
 { #category : 'tests-esope' }
 IASTToFamixVisitorTest >> testFamixEsopePointerDeclaration [
 "      program main

src/EsopeImporter/FamixF77Model.extension.st

@@ -0,0 +1,21 @@
+Extension { #name : 'FamixF77Model' }
+
+{ #category : '*EsopeImporter' }
+FamixF77Model >> initialize [
+
+	super initialize.
+	self name: 'F77MooseModel'.
+	self attributeAt: #instrinsicTypes put: self intrinsicTypes.
+	self attributeAt: #unknownType put: [ self newTypeUnknown ]
+]
+
+{ #category : '*EsopeImporter' }
+FamixF77Model >> intrinsicTypes [
+	^ {
+		  (#integer -> (self newTypeIntrinsic name: #integer)).
+		  (#real -> (self newTypeIntrinsic name: #real)).
+		  (#complex -> (self newTypeIntrinsic name: #complex)).
+		  (#logical -> (self newTypeIntrinsic name: #logical)).
+		  (#character -> (self newTypeIntrinsic name: #character)) 
+	} asDictionary
+]

src/EsopeImporter/IASTAbstractFamixVisitor.class.st

@@ -72,7 +72,8 @@ IASTAbstractFamixVisitor >> model [
 { #category : 'accessing' }
 IASTAbstractFamixVisitor >> model: anObject [
 
-	model := anObject
+	model := anObject.
+	self setIntrinsicTypes
 ]
 
 { #category : 'private-creation' }
@@ -83,33 +84,30 @@ IASTAbstractFamixVisitor >> newEntity: aClass [
 		  yourself
 ]
 
-{ #category : 'initialization' }
-IASTAbstractFamixVisitor >> retrieveType: aTypeName from: aMooseModel [
-
-	^ (aMooseModel
-		attributeAt: #instrinsicTypes
-		ifAbsent: [
-		   aMooseModel
-			   attributeAt: #unknownType
-			   ifAbsent: self typeNotFoundBlock.
-		]
-	 ) at: aTypeName ifAbsent: self typeNotFoundBlock.
-]
-
 { #category : 'initialization' }
 IASTAbstractFamixVisitor >> retrieveTypeFrom: aName [
 
+	| typeNotFoundBlock |
+	typeNotFoundBlock := [ self newEntity: FamixF77TypeUnknown ].
+
 	^ (self model 
 		attributeAt: #instrinsicTypes
 		ifAbsent: [
 		   self model
 			   attributeAt: #unknownType
-			   ifAbsent: self typeNotFoundBlock.
+			   ifAbsent: typeNotFoundBlock.
 		]
-	 ) at: aName ifAbsent: self typeNotFoundBlock.
+	 ) at: aName ifAbsent: typeNotFoundBlock.
 ]
 
-{ #category : 'as yet unclassified' }
+{ #category : 'private - helpers' }
+IASTAbstractFamixVisitor >> setIntrinsicTypes [
+
+	model attributeAt: #instrinsicTypes put: model intrinsicTypes.
+	model attributeAt: #unknownType put: [ model newTypeUnknown ]
+]
+
+{ #category : 'spawn' }
 IASTAbstractFamixVisitor >> spawn: aVisitorClass [
 	^aVisitorClass new
 		model: self model ;
@@ -129,26 +127,20 @@ IASTAbstractFamixVisitor >> stack: anObject [
 	stack := anObject
 ]
 
-{ #category : 'as yet unclassified' }
+{ #category : 'symbols resolution' }
 IASTAbstractFamixVisitor >> symbolTable: anEntity at: key [
 
 	^ anEntity attributeAt: key asSymbol ifAbsent: [  ]
 ]
 
-{ #category : 'as yet unclassified' }
+{ #category : 'symbols resolution' }
 IASTAbstractFamixVisitor >> symbolTable: anEntity at: key put: value [
 
 	(self symbolTable: anEntity at: #symbolTable)
 		at: key asSymbol
 		put: value
 ]
 
-{ #category : 'initialization' }
-IASTAbstractFamixVisitor >> typeNotFoundBlock [
-
-	^ [ self newEntity: FamixF77TypeUnknown ]
-]
-
 { #category : 'visiting' }
 IASTAbstractFamixVisitor >> visitIASTParameter: aParameter [
 
@@ -183,21 +175,25 @@ IASTAbstractFamixVisitor >> visitIASTVarAccess: aVarAccess [
 	- dereferencedVariable for example: deref.var(...) "
 
 	"Distinguish external accesses from other accesses"
+	
+	| mainAccess |
+	mainAccess := (self createFamixF77Access: aVarAccess).
+	mainAccess isWrite: aVarAccess isWrite.
 
 	aVarAccess indices deepFlatten
 		do: [ :indice |
-
 			(indice class = IASTVarAccess and: [ (indice entityName asLowercase = 's__') not ])
 				ifTrue: [ (self createFamixF77Access: indice) isWrite: indice isWrite  ] 
 		].
 
 	aVarAccess dereferencedVariable 
 		ifNotNil: [ :dereferencedVariable | 
-			(self createFamixF77Access: dereferencedVariable) isWrite: dereferencedVariable isWrite
+			(self createFamixF77Access: dereferencedVariable) 
+				isWrite: dereferencedVariable isWrite;
+				attributeAt: #parentAccess put: mainAccess
 		].
 
-
-	^(self createFamixF77Access: aVarAccess) isWrite: aVarAccess isWrite
+	^ mainAccess 
 ]
 
 { #category : 'visiting' }