- add test #testHasSelector and #testHasSelectorSpecialSelectorIndex

- recategorize CompiledCodeTest
- implement hasSelector:specialSelectorIndex:  to only iterate the blocks for special selectors

fixes pharo-project#6965

src/Kernel-Tests/CompiledCodeTest.class.st

@@ -4,12 +4,12 @@ Class {
 	#category : #'Kernel-Tests-Classes'
 }
 
-{ #category : #accessing }
+{ #category : #examples }
 CompiledCodeTest >> compiledMethod1 [
 	^ self class >> #method1
 ]
 
-{ #category : #accessing }
+{ #category : #examples }
 CompiledCodeTest >> method1 [
 
 	<pragma1: 123 foo: 'bar' >
@@ -19,7 +19,80 @@ CompiledCodeTest >> method1 [
 	#(#add #at: #remove) do: #printOn:
 ]
 
-{ #category : #accessing }
+{ #category : #'tests-literals' }
+CompiledCodeTest >> testHasSelector [
+
+	| method |
+	method := self class compiler compile: 'method 
+		<pragma: #pragma>
+		test := 1+2.
+		self do: [ 
+		test := 1 - 2.
+		test := #(arrayInBlock).
+		self name ].
+		^#(#array) '.
+	"simpe case: normal send in the method itself"
+	self assert: (method hasSelector: #do:).
+	"special selector in the method"
+	self assert: (method hasSelector: #+).
+	"special selector in the block"
+	self assert: (method hasSelector: #-).
+	"normal selector in the block"
+	self assert: (method hasSelector: #name).
+	"we look into arrays"
+	self assert: (method hasSelector: #array).
+	"we look into arrays in Blocks"
+	self assert: (method hasSelector: #arrayInBlock).
+	"pragmas are covered"
+	self assert: (method hasSelector: #pragma:).
+	"literals as args of pragmas. too"
+	self assert: (method hasSelector: #pragma:).
+	"the method selecto NOT"
+	self deny: (method hasSelector: #method).
+]
+
+{ #category : #'tests-literals' }
+CompiledCodeTest >> testHasSelectorSpecialSelectorIndex [
+
+	| method specialIndex |
+	method := self class compiler compile: 'method 
+		<pragma: #pragma>
+		test := 1+2.
+		self do: [ 
+		test := 1 - 2.
+		test := #(arrayInBlock).
+		self name ].
+		^#(#array) '.
+	"simpe case: normal send in the method itself"
+	specialIndex := Smalltalk specialSelectorIndexOrNil: #do:.
+	self assert: (method hasSelector: #do: specialSelectorIndex: specialIndex).
+	"special selector in the method"
+	specialIndex := Smalltalk specialSelectorIndexOrNil: #+.
+	self assert: (method hasSelector: #+ specialSelectorIndex: specialIndex).
+	"special selector in the block"
+	specialIndex := Smalltalk specialSelectorIndexOrNil: #-.
+	self assert: (method hasSelector: #- specialSelectorIndex: specialIndex).
+	"normal selector in the block"
+	specialIndex := Smalltalk specialSelectorIndexOrNil: #name.
+	self assert: (method hasSelector: #name specialSelectorIndex: specialIndex).
+	"we look into arrays"
+	specialIndex := Smalltalk specialSelectorIndexOrNil: #array.
+	self assert: (method hasSelector: #array specialSelectorIndex: specialIndex).
+	"we look into arrays in Blocks"
+	specialIndex := Smalltalk specialSelectorIndexOrNil: #arrayInBlock.
+	self assert: (method hasSelector: #arrayInBlock specialSelectorIndex: specialIndex).
+	"pragmas are covered"
+	specialIndex := Smalltalk specialSelectorIndexOrNil: #pragma:.
+	self assert: (method hasSelector: #pragma: specialSelectorIndex: specialIndex).
+	"literals as args of pragmas. too"
+	specialIndex := Smalltalk specialSelectorIndexOrNil: #pragma:.
+	self assert: (method hasSelector: #pragma: specialSelectorIndex: specialIndex).
+	"the method selecto NOT"
+	specialIndex := Smalltalk specialSelectorIndexOrNil: #method.
+	self deny: (method hasSelector: #method specialSelectorIndex: specialIndex).
+]
+
+{ #category : #'tests-literals' }
 CompiledCodeTest >> testLiteralsDoesNotContainMethodClass [
 
 	self
@@ -28,83 +101,83 @@ CompiledCodeTest >> testLiteralsDoesNotContainMethodClass [
 				refersToLiteral: (self class environment associationAt: self class name asSymbol))
 ]
 
-{ #category : #accessing }
+{ #category : #'tests-literals' }
 CompiledCodeTest >> testLiteralsDoesNotContainMethodName [
 
 	self deny: (self compiledMethod1 refersToLiteral: #method1)
 ]
 
-{ #category : #accessing }
+{ #category : #'tests-literals' }
 CompiledCodeTest >> testRefersToLiteralsReturnsFalseWhenLiteralNotInMethodPropertiesKey [
 
 	[ self compiledMethod1 propertyAt: #Once put: true.
 	self deny: (self compiledMethod1 refersToLiteral: #Absent) ]
 		ensure: [ self compiledMethod1 removeProperty: #Once ]
 ]
 
-{ #category : #accessing }
+{ #category : #'tests-literals' }
 CompiledCodeTest >> testRefersToLiteralsReturnsTrueWhenLiteralIsArrayOfLiterals [
 
 	self assert: (self compiledMethod1 refersToLiteral: #(#add #at: #remove))
 ]
 
-{ #category : #accessing }
+{ #category : #'tests-literals' }
 CompiledCodeTest >> testRefersToLiteralsReturnsTrueWhenLiteralIsByteString [
 
 	self assert: (self compiledMethod1 refersToLiteral: 'Pharo loves tests')
 ]
 
-{ #category : #accessing }
+{ #category : #'tests-literals' }
 CompiledCodeTest >> testRefersToLiteralsReturnsTrueWhenLiteralIsByteSymbol [
 
 	self assert: (self compiledMethod1 refersToLiteral: #printOn:)
 ]
 
-{ #category : #accessing }
+{ #category : #'tests-literals' }
 CompiledCodeTest >> testRefersToLiteralsReturnsTrueWhenLiteralIsContainedInArrayOfLitterals [
 
 	self assert: (self compiledMethod1 refersToLiteral: #add)
 ]
 
-{ #category : #accessing }
+{ #category : #'tests-literals' }
 CompiledCodeTest >> testRefersToLiteralsReturnsTrueWhenLiteralIsGlobalVariable [
 
 	self assert: (self compiledMethod1
 				refersToLiteral: (self class environment associationAt: #Array))
 ]
 
-{ #category : #accessing }
+{ #category : #'tests-literals' }
 CompiledCodeTest >> testRefersToLiteralsReturnsTrueWhenLiteralIsInMethodPropertiesKey [
 
 	[ self compiledMethod1 propertyAt: #Once put: true.
 	self assert: (self compiledMethod1 refersToLiteral: #Once) ]
 		ensure: [ self compiledMethod1 removeProperty: #Once ]
 ]
 
-{ #category : #accessing }
+{ #category : #'tests-literals' }
 CompiledCodeTest >> testRefersToLiteralsReturnsTrueWhenLiteralIsInMethodPropertiesValue [
 
 	[ self compiledMethod1 propertyAt: #Once put: '123'.
 	self assert: (self compiledMethod1 refersToLiteral: '123') ]
 		ensure: [ self compiledMethod1 removeProperty: #Once ]
 ]
 
-{ #category : #accessing }
+{ #category : #'tests-literals' }
 CompiledCodeTest >> testRefersToLiteralsReturnsTrueWhenLiteralIsInMethodPropertiesValueArray [
 
 	[ self compiledMethod1 propertyAt: #Once put: #(1 2 3).
 	self assert: (self compiledMethod1 refersToLiteral: 1) ]
 		ensure: [ self compiledMethod1 removeProperty: #Once ]
 ]
 
-{ #category : #accessing }
+{ #category : #'tests-literals' }
 CompiledCodeTest >> testRefersToLiteralsReturnsTrueWhenLiteralIsInPragmaArguments [
 
 	self assert: (self compiledMethod1 refersToLiteral: 'bar').
 	self assert: (self compiledMethod1 refersToLiteral: 123)
 ]
 
-{ #category : #accessing }
+{ #category : #'tests-literals' }
 CompiledCodeTest >> testRefersToLiteralsReturnsTrueWhenLiteralIsInPragmaSelector [
 
 	self assert: (self compiledMethod1

src/Kernel/CompiledCode.class.st

@@ -295,15 +295,15 @@ CompiledCode >> hasSelector: selector specialSelectorIndex: specialOrNil [
 	 If you do, you may call this method directly to avoid recomputing 
 	 the special selector index all the time.
 	
-	 I traverse the method and all the compiled blocks in the literals 	 
-	"
-
-	^ self withAllBlocks
-		anySatisfy: [ :aCompiledCode | 
-			(aCompiledCode refersToLiteral: selector)
-				or: [ specialOrNil isNotNil
-						and: [ aCompiledCode
-								scanFor: self encoderClass firstSpecialSelectorByte + specialOrNil ] ] ]
+	 I traverse the method and all the compiled blocks in the literals"
+
+	
+	(self refersToLiteral: selector) ifTrue: [ ^ true ].
+	"refersToLiteral: traverses all blocks, but only for no-special literals"
+	specialOrNil ifNil: [ ^ false ].
+	"if the selector is special, scan all blocks and myself"
+	^ self withAllBlocks anySatisfy: [ :aCompiledCode | aCompiledCode scanFor:
+			self encoderClass firstSpecialSelectorByte + specialOrNil ]
 ]
 
 { #category : #accessing }