Commits

Ryan Macnak committed 554ae67

Guard against thinking nil is a member of a category; adjust literal traversals so a methods aren't always considered senders of themselves.

Comments (0)

Files changed (2)

 )
 retrieveClasses = (
 
-	^(Smalltalk organization listAtCategoryNamed: model)
-		collect: [:each | Smalltalk at: each ifAbsent: [ SystemMetadata classNamed: each inNamespace: Smalltalk ]]
+	^((Smalltalk organization listAtCategoryNamed: model)
+		collect: [:each | Smalltalk at: each ifAbsent: [ SystemMetadata classNamed: each inNamespace: Smalltalk ]])
+		reject: [:each | each isNil]
 ))
 class ConfigurationPresenter onSubject: s = ProgrammingPresenter onSubject: s (
 "Displays user-configurable system settings (this is the target of the ''Configuration'' link on the Home page). The subject is a ConfigurationSubject."| namePresenter initialsPresenter |)
-Newspeak3
   Copyright 2008 Cadence Design Systems, Inc.
   
   Licensed under the Apache License, Version 2.0 (the ''License''); you may not use this file except in compliance with the License.  You may obtain a copy of the License at  http://www.apache.org/licenses/LICENSE-2.0
+Newspeak3
+'SystemScope'
+class SystemScope usingPlatform: platform = ("
+
+   Copyright 2008 Cadence Design Systems, Inc.
+   
+   Licensed under the Apache License, Version 2.0 (the ''License''); you may not use this file except in compliance with the License.  You may obtain a copy of the License at  http://www.apache.org/licenses/LICENSE-2.0
+"|
+	IdentityDictionary = platform Collections IdentityDictionary.
+	IdentitySet = platform Collections IdentitySet.
+	SystemChangeNotifier = platform System SystemChangeNotifier.
+	theSystemNavigation = platform System SystemNavigation default.
+	Smalltalk = platform Smalltalk.
+	SmalltalkImage = platform System SmalltalkImage.
+	private vmMirror = platform VmMirror SqueakVmMirror usingPlatform: platform.
+	private allLiteralReferences_slot
+|SystemChangeNotifier uniqueInstance notify: self ofAllSystemChangesUsing: #respondToSystemChange)
+('as yet unclassified'
+accessesToInstanceVariableIndex: index <Integer> from: cls <Class> do: action  = (
+	cls methodDict keysAndValuesDo: [ :selector :method |
+		((method readsField: index) or: [method writesField: index]) ifTrue: [
+			action value: cls value: selector]]
+)
+allAccessesToInstanceVariableNamed: varName <String> from: cls <Class> do: action = (
+	| index |
+	index:: vmMirror classUtil indexOfInstanceVariableNamed: varName of: cls ifAbsent: [^self].
+	cls allSuperclassesDo: [ :ea | accessesToInstanceVariableIndex: index from: ea do: action].
+	accessesToInstanceVariableIndex: index from: cls do: action.
+	cls allSubclassesDo: [ :ea | accessesToInstanceVariableIndex: index from: ea do: action].
+)
+allBehaviors ^<Array[Behavior]> = (
+	"Answer an array of all behaviors (both classes and metaclasses) in the scope, in an undefined order."
+	^Array streamContents: [ :s | allBehaviorsDo: [ :cls | s nextPut: cls ]]
+)
+allBehaviorsDo: action <[Behavior]> = (
+	"Enumerate the argument block over all behaviors (classes and metaclasses) in the scope, in an undefined order."
+	^theSystemNavigation allBehaviorsDo:
+		[ :cls <Behavior> | cls isMixinApplication not ifTrue: [ action value: cls ]]
+)
+allClasses ^<Array[Class]> = (
+	"Answer an array of all classes (not metaclasses) in the scope, in an undefined order."
+	^Array streamContents: [ :s | allClassesDo: [ :cls | s nextPut: cls ]]
+)
+allClassesDo: action <[Class]> = (
+	"Enumerate the argument block over all classes (not metaclasses) in the scope, in an undefined order."
+	^allBehaviorsDo: [:each | each isMeta ifFalse: [action value: each]]
+)
+allImplementorsOf: selector <String> = (
+	^Array streamContents:
+		[ :s |
+		allImplementorsOf: selector do:
+			[ :cls <Class> :sel <Symbol> | s nextPut: {cls,sel} ]]
+)
+allImplementorsOf: selector <String> do: action <[Class,Symbol]> = (
+	allBehaviorsDo:
+		[ :cls | (cls includesSelector: selector) ifTrue: [ action value: cls value: selector ]]
+)
+allLiteralReferences = (
+	| map |
+	allLiteralReferences_slot ifNotNil: [ :m | ^m].
+	map:: IdentityDictionary new.
+	allBehaviorsDo: [ :cls |
+		allLiteralsOf: cls do: [ :lit :sender |
+			(map at: (lit isVariableBinding ifTrue: [lit key] ifFalse: [lit]) ifAbsentPut: [IdentitySet new]) add: sender]].
+	allLiteralReferences_slot:: map.
+	^allLiteralReferences_slot
+)
+allLiteralsOf: cls <Behavior> do: action <[Symbol | LookupKey, Class | CompiledMethod]> = (
+	cls superclass ifNotNil: [ :sc | action value: sc theNonMetaClass name value: cls].
+	cls methodDictionary valuesDo: [ :cm <CompiledMethod> |
+		1 to: cm numLiterals - 2 do: [:i |  | lit = cm literalAt: i. |
+			(lit isSymbol or: [lit isVariableBinding]) ifTrue: [
+				action value: lit value: cm]]]
+)
+allReferencesToClass: cls <Class> = (
+
+)
+allReferencesToClass: cls <Class> do: action <[Class,Symbol]> = (
+	halt
+)
+allSendersOf: literalIn <String | Symbol | Association> do: action <[Class,Symbol]> = (
+	"Derived from SystemNavigation class>>allCallsOn:"
+	| thorough special literal byte |
+	thorough:: literalIn isSymbol or: [ literalIn isString ].
+	literal:: thorough
+		ifTrue: [#BOGUS yourself. "Should not require interning" literalIn asSymbol ]
+		ifFalse: [ literalIn ].
+	special:: Smalltalk
+				hasSpecialSelector: literal
+				ifTrueSetByte: [:b | byte:: b].
+	literal isSymbol ifTrue: [
+		(Smalltalk associationAt: literal ifAbsent: []) ifNotNil:
+			[ :assoc | allSendersOf: assoc do: action]].
+	allBehaviorsDo:
+		[ :cls <Class> |
+		(thorough
+				ifTrue: [cls thoroughWhichSelectorsReferTo: literal special: special byte: byte]
+				ifFalse: [cls whichSelectorsReferTo: literal special: special byte: byte])
+			do: [ :sel | action value: cls value: sel ]]
+)
+allSendersOf: selector <String> = (
+	^Array streamContents:
+		[ :s |
+		allSendersOf: selector do:
+			[ :cls <Class> :sel <Symbol> | s nextPut: {cls. sel} ]]
+)
+allSymbolsMatching: pattern <String> = (
+	^Array streamContents:
+		[ :s |
+		allSymbolsMatching: pattern do:
+			[ :cls <Class> :sel <Symbol> | s nextPut: {cls,sel} ]]
+)
+allSymbolsMatching: pattern <String> do: action <[Class,Symbol]> = (
+	halt
+)
+allUndeclared = (
+	^(Smalltalk at: #Undeclared) removeUnreferencedKeys; associations
+)
+allUsersOfUndeclared = (
+	^Array streamContents: [ :s |
+		allUndeclared do: [ :ea |
+			s nextPutAll: (theSystemNavigation allCallsOn: ea)]]
+)
+packagesWithUndeclared = (
+	^(allUsersOfUndeclared
+		collect: [:ea |
+			((Smalltalk at: #PackageOrganizer) default packageOfMethod: ea) packageName])
+				asSet asSortedCollection asArray
+)
+respondToSystemChange = (
+	allLiteralReferences_slot: nil
+)
+systemName = (
+	| vmName i |
+	vmName:: SmalltalkImage current vmVersion.
+	^(vmName last isDigit and: [(i:: vmName lastIndexOf: Character space) > 1])
+		ifTrue: [vmName copyFrom: 1 to: i - 1]
+		ifFalse: [vmName]
+)
+systemVersion = (
+	| vmName i |
+	vmName:: SmalltalkImage current vmVersion.
+	^(vmName last isDigit and: [(i:: vmName lastIndexOf: Character space) > 1])
+		ifTrue: [vmName allButFirst: i]
+		ifFalse: ['?']
+)
+test: selector <String> = ()) : ('as yet unclassified'
+reset = (
+	^(environment at: #Platform) resetTheSystemScope
+)
+soleInstance = (
+	^(environment at: #Platform) theSystemScope
+))