diff --git a/src/Famix-Value-Entities/FamixValueEntity.class.st b/src/Famix-Value-Entities/FamixValueEntity.class.st index 8a8c1ae..af9a97e 100644 --- a/src/Famix-Value-Entities/FamixValueEntity.class.st +++ b/src/Famix-Value-Entities/FamixValueEntity.class.st @@ -28,6 +28,20 @@ FamixValueEntity class >> metamodel [ ^ FamixValueModel metamodel ] +{ #category : #testing } +FamixValueEntity >> isOfClassReference [ + + + ^ false +] + +{ #category : #testing } +FamixValueEntity >> isOfClosure [ + + + ^ false +] + { #category : #testing } FamixValueEntity >> isOfCollection [ diff --git a/src/Famix-Value-Entities/FamixValueOfClassReference.class.st b/src/Famix-Value-Entities/FamixValueOfClassReference.class.st index 374b509..a5f24ee 100644 --- a/src/Famix-Value-Entities/FamixValueOfClassReference.class.st +++ b/src/Famix-Value-Entities/FamixValueOfClassReference.class.st @@ -27,6 +27,13 @@ FamixValueOfClassReference class >> annotation [ ^ self ] +{ #category : #testing } +FamixValueOfClassReference >> isOfClassReference [ + + + ^ true +] + { #category : #accessing } FamixValueOfClassReference >> value [ "Relation named: #value type: #FamixTClass opposite: #valueReferences" diff --git a/src/Famix-Value-Entities/FamixValueOfClosure.class.st b/src/Famix-Value-Entities/FamixValueOfClosure.class.st index 4f9aa56..74afa41 100644 --- a/src/Famix-Value-Entities/FamixValueOfClosure.class.st +++ b/src/Famix-Value-Entities/FamixValueOfClosure.class.st @@ -43,6 +43,13 @@ FamixValueOfClosure >> addVariable: anObject [ ^ self variables add: anObject ] +{ #category : #testing } +FamixValueOfClosure >> isOfClosure [ + + + ^ true +] + { #category : #accessing } FamixValueOfClosure >> sourceCode [ diff --git a/src/Famix-Value-Entities/FamixValueOfCollection.class.st b/src/Famix-Value-Entities/FamixValueOfCollection.class.st index 97ee143..9d5b523 100644 --- a/src/Famix-Value-Entities/FamixValueOfCollection.class.st +++ b/src/Famix-Value-Entities/FamixValueOfCollection.class.st @@ -36,6 +36,14 @@ FamixValueOfCollection >> addValue: anObject [ ^ self value add: anObject ] +{ #category : #converting } +FamixValueOfCollection >> asPharoInitializationAST [ + + ^ RBMessageNode + receiver: (RBVariableNode named: self type name) + selector: #basicNew +] + { #category : #testing } FamixValueOfCollection >> isOfCollection [ diff --git a/src/Famix-Value-Exporter/FamixValue2PharoVisitor.class.st b/src/Famix-Value-Exporter/FamixValue2PharoVisitor.class.st index 2b91d25..9e0aba4 100644 --- a/src/Famix-Value-Exporter/FamixValue2PharoVisitor.class.st +++ b/src/Famix-Value-Exporter/FamixValue2PharoVisitor.class.st @@ -9,7 +9,8 @@ Class { #name : #FamixValue2PharoVisitor, #superclass : #FamixValue2ASTVisitor, #instVars : [ - 'definedValues' + 'definedValues', + 'vars' ], #category : #'Famix-Value-Exporter-Visitors' } @@ -33,36 +34,10 @@ FamixValue2PharoVisitor >> ensureVisited: value [ value isOfPrimitiveType ifTrue: [ ^ value accept: self ]. ^ self varNameDict at: value - ifPresent: [ :name | - | varName | - varName := RBVariableNode named: name. - (definedValues includes: value) - ifTrue: [ varName ] - ifFalse: [ - definedValues add: value. - RBAssignmentNode - variable: varName - value: value asPharoInitializationAST ] ] + ifPresent: [ :name | self makeVariableNamed: name ] ifAbsent: [ - | name node | - name := self varNameFor: value. - node := value accept: self. - value isReferencedInLoop - ifTrue: [ - (node isCascade and: [ - node messages first receiver isAssignment not ]) - ifTrue: [ "add parenthesis" - | receiver | - receiver := node messages first receiver. - node messages first receiver: (RBAssignmentNode - variable: (RBVariableNode named: name) - value: receiver). - node ] - ifFalse: [ - RBAssignmentNode - variable: (RBVariableNode named: name) - value: node ] ] - ifFalse: [ node ] ] + self varNameFor: value. + value accept: self ] ] { #category : #initialization } @@ -70,7 +45,20 @@ FamixValue2PharoVisitor >> initialize [ super initialize. - definedValues := IdentitySet new + definedValues := IdentitySet new. + vars := IdentityDictionary new +] + +{ #category : #testing } +FamixValue2PharoVisitor >> makeAssignmentFor: aVariableName and: aValue [ + "^ RBAssignmentNode variable: (self makeVariableNamed: aVariableName) value: aValue" + + ^ RBMessageNode + receiver: (RBVariableNode named: 'vars') + selector: #at:put: + arguments: { + (RBLiteralNode value: aVariableName). + aValue } ] { #category : #ast } @@ -85,6 +73,16 @@ FamixValue2PharoVisitor >> makeVariableExpression: value [ ^ RBVariableNode named: (self varNameFor: value) ] +{ #category : #testing } +FamixValue2PharoVisitor >> makeVariableNamed: aString [ + "^ RBVariableNode named: aString" + + ^ RBMessageNode + receiver: (RBVariableNode named: 'vars') + selector: #at: + arguments: { (RBLiteralNode value: aString) } +] + { #category : #accessing } FamixValue2PharoVisitor >> statementBlock [ @@ -98,115 +96,90 @@ FamixValue2PharoVisitor >> visitClassReference: aFamixValueOfClassReference [ ] { #category : #visiting } -FamixValue2PharoVisitor >> visitClosure: object [ - - object variables do: [ :var | - | varNode value newNode | - value := var value. - newNode := self ensureVisited: value. - - (value isOfObject or: [ - value isOfCollection or: [ value isOfDictionary ] ]) - ifTrue: [ - | name | - name := self varNameFor: value. - self statementBlock addNode: (RBAssignmentNode - variable: (RBVariableNode named: name) - value: newNode). - varNode := RBVariableNode named: name ] - ifFalse: [ varNode := newNode ]. - - statementBlock addNodeFirst: (RBAssignmentNode - variable: (RBVariableNode named: var name) - value: varNode) ]. - ^ [ RBParser parseExpression: object sourceCode ] - on: SyntaxErrorNotification - do: [ :error | "TODO: fix reflective opperation on block when metalink is installed" - Transcript crShow: error description. - error pass ] +FamixValue2PharoVisitor >> visitClosure: closure [ + + closure variables do: [ :var | self ensureVisited: var value ]. + + [ + self statementBlock addNode: (self + makeAssignmentFor: (self varNameFor: closure) + and: (RBParser parseExpression: closure sourceCode)) ] + on: SyntaxErrorNotification + do: [ :error | "TODO: fix reflective opperation on block when metalink is installed" + Transcript crShow: error description. + error pass ] ] { #category : #visiting } FamixValue2PharoVisitor >> visitCollection: collection [ - | collectionNode | - collectionNode := RBArrayNode statements: - (collection value collect: [ :element | - | newNode elementNode value | - value := element value. - newNode := self ensureVisited: value. - (value isOfObject or: [ - value isOfCollection or: [ - value isOfDictionary ] ]) - ifTrue: [ - | name | - name := self varNameFor: value. - self statementBlock addNode: - (RBAssignmentNode - variable: (RBVariableNode named: name) - value: newNode). - elementNode := RBVariableNode named: name ] - ifFalse: [ elementNode := newNode ]. - (value isReferencedInLoop and: [ - elementNode isAssignment and: [ - elementNode isVariable not and: [ - elementNode value isLiteralNode not ] ] ]) - ifTrue: [ elementNode addParenthesisToVariable ] - ifFalse: [ elementNode ] ]). - ^ collection type name = 'Array' - ifTrue: [ collectionNode ] - ifFalse: [ - RBMessageNode + | name isArrayed | + name := self varNameFor: collection. + self statementBlock addNode: + (self makeAssignmentFor: name and: (RBMessageNode receiver: (RBVariableNode named: collection type name) - selector: #withAll: - arguments: { collectionNode } ] + selector: #new: + arguments: { (RBLiteralValueNode value: collection value size) })). + collection value ifEmpty: [ ^ self statementBlock statements last ]. + + isArrayed := collection type superclassHierarchy anySatisfy: [ + :superclass | superclass name = 'ArrayedCollection' ]. + collection value withIndexDo: [ :element :index | + | elementNode | + elementNode := self ensureVisited: element value. + (element value isOfPrimitiveType or: [ + element value isOfClassReference ]) ifFalse: [ + elementNode := self makeVariableNamed: + (self varNameFor: element value) ]. + self statementBlock addNode: (isArrayed + ifTrue: [ + RBMessageNode + receiver: (self makeVariableNamed: name) + selector: #at:put: + arguments: { + (RBLiteralValueNode value: index). + elementNode } ] + ifFalse: [ + RBMessageNode + receiver: (self makeVariableNamed: name) + selector: #add: + arguments: { elementNode } ]) ] ] { #category : #visiting } FamixValue2PharoVisitor >> visitDictionary: dictionary [ - ^ RBMessageNode - receiver: (RBVariableNode named: dictionary type name) - selector: #newFrom: - arguments: - { (RBArrayNode statements: (dictionary value collect: [ :assoc | - self visitDictionaryAssociation: assoc ])) } + self statementBlock addNode: (self + makeAssignmentFor: (self varNameFor: dictionary) + and: (RBMessageNode + receiver: (RBVariableNode named: dictionary type name) + selector: #new: + arguments: + { (RBLiteralValueNode value: dictionary value size) })). + dictionary value ifEmpty: [ ^ self statementBlock statements last ]. + dictionary value do: [ :assoc | + self visitDictionaryAssociation: assoc ] ] { #category : #visiting } FamixValue2PharoVisitor >> visitDictionaryAssociation: association [ - | key value keyNode valueNode newNode | + | key value keyNode valueNode | key := association key. value := association value. - - newNode := self ensureVisited: key. - (key isOfObject or: [ key isOfCollection or: [ key isOfDictionary ] ]) - ifTrue: [ - | name | - name := self varNameFor: value. - self statementBlock addNode: (RBAssignmentNode - variable: (RBVariableNode named: name) - value: newNode). - keyNode := RBVariableNode named: name ] - ifFalse: [ keyNode := newNode ]. - - newNode := self ensureVisited: value. - (value isOfObject or: [ - value isOfCollection or: [ value isOfDictionary ] ]) - ifTrue: [ - | name | - name := self varNameFor: value. - self statementBlock addNode: (RBAssignmentNode - variable: (RBVariableNode named: name) - value: newNode). - valueNode := RBVariableNode named: name ] - ifFalse: [ valueNode := newNode ]. - - ^ RBMessageNode - receiver: keyNode - selector: #'->' - arguments: { valueNode } + keyNode := self ensureVisited: key. + valueNode := self ensureVisited: value. + self statementBlock addNode: (RBMessageNode + receiver: + (self makeVariableNamed: (self varNameFor: association dictionary)) + selector: #at:put: + arguments: { + ((key isOfPrimitiveType or: [ key isOfClassReference ]) + ifTrue: [ keyNode ] + ifFalse: [ self makeVariableNamed: (self varNameFor: key) ]). + ((value isOfPrimitiveType or: [ value isOfClassReference ]) + ifTrue: [ valueNode ] + ifFalse: [ self makeVariableNamed: (self varNameFor: value) ]) }) ] { #category : #visiting } @@ -218,62 +191,40 @@ FamixValue2PharoVisitor >> visitEnumValue: enumValue [ { #category : #visiting } FamixValue2PharoVisitor >> visitObject: object [ - | objectNode attributeNodes | - objectNode := object isReferencedInLoop - ifTrue: [ - RBVariableNode named: (self varNameFor: object) ] - ifFalse: [ - RBMessageNode - receiver: (RBVariableNode named: object type name) - selector: #new ]. - attributeNodes := (object value - collect: [ :attribute | - self visitObjectAttribute: attribute ] - as: OrderedCollection) reject: #isNil. - attributeNodes ifEmpty: [ ^ objectNode ]. - attributeNodes first receiver: objectNode. - attributeNodes add: - (RBMessageNode receiver: RBVariableNode new selector: #yourself). - ^ RBCascadeNode messages: attributeNodes + self statementBlock addNode: (self + makeAssignmentFor: (self varNameFor: object) + and: (RBMessageNode + receiver: (RBVariableNode named: object type name) + selector: #basicNew)). + object value ifEmpty: [ ^ self statementBlock statements last ]. + object value do: [ :attribute | self visitObjectAttribute: attribute ] ] { #category : #visiting } FamixValue2PharoVisitor >> visitObjectAttribute: attribute [ - | newNode value attributeNode | + | value attributeNode | attribute attribute ifNil: [ "ignore unknown attributes" ^ nil ]. value := attribute value. - newNode := self ensureVisited: value. - (value isOfObject or: [ - value isOfCollection or: [ value isOfDictionary ] ]) - ifTrue: [ - | name | - name := self varNameFor: value. - self statementBlock addNode: (RBAssignmentNode - variable: (RBVariableNode named: name) - value: newNode). - attributeNode := RBVariableNode named: name ] - ifFalse: [ attributeNode := newNode ]. - (attribute object type findSetterOf: attribute attribute) - ifNotNil: [ :setter | - newNode := RBMessageNode - receiver: RBVariableNode new - selector: setter name - arguments: { attributeNode } ] - ifNil: [ "Use reflectivity" - newNode := RBMessageNode - receiver: RBVariableNode new - selector: #instVarNamed:put: - arguments: { - (RBVariableNode named: '#' , attribute attribute name). - attributeNode } ]. - - (attribute value isReferencedInLoop and: [ - newNode isVariable not and: [ - newNode value isLiteralNode not and: [ - newNode isMessage not and: [ newNode isAssignment ] ] ] ]) - ifTrue: [ ^ newNode addParenthesisToVariable ]. - ^ newNode + attributeNode := self ensureVisited: value. + (value isOfPrimitiveType or: [ value isOfClassReference ]) ifFalse: [ "TODO?" + attributeNode := self makeVariableNamed: (self varNameFor: value) ]. + self statementBlock addNode: + ((attribute object type findSetterOf: attribute attribute) + ifNotNil: [ :setter | + RBMessageNode + receiver: + (self makeVariableNamed: (self varNameFor: attribute object)) + selector: setter name + arguments: { attributeNode } ] + ifNil: [ "Use reflectivity" + RBMessageNode + receiver: + (self makeVariableNamed: (self varNameFor: attribute object)) + selector: #instVarNamed:put: + arguments: { + (RBVariableNode named: '#' , attribute attribute name). + attributeNode } ]) ] { #category : #visiting } diff --git a/src/Famix-Value-Generator/FamixValueGenerator.class.st b/src/Famix-Value-Generator/FamixValueGenerator.class.st index 5000786..a7138f9 100644 --- a/src/Famix-Value-Generator/FamixValueGenerator.class.st +++ b/src/Famix-Value-Generator/FamixValueGenerator.class.st @@ -85,12 +85,12 @@ FamixValueGenerator >> defineClasses [ newClassNamed: #OfDictionaryAssociation comment: 'A key-value pair belonging to a dictionary.'. - classReference := builder - newClassNamed: #OfClassReference - comment: 'A reference to a class.'. - closure := builder - newClassNamed: #OfClosure - comment: 'A lexical closure.'. + classReference := (builder + newClassNamed: #OfClassReference + comment: 'A reference to a class.') withTesting. + closure := (builder + newClassNamed: #OfClosure + comment: 'A lexical closure.') withTesting. closureVariable := builder newClassNamed: #OfClosureVariable comment: