--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/AmbiguousMessage.st Tue Jun 28 13:04:04 2011 +0200
@@ -0,0 +1,41 @@
+"
+ COPYRIGHT (c) 2006 by eXept Software AG
+ All Rights Reserved
+
+ This software is furnished under a license and may be used
+ only in accordance with the terms of that license and with the
+ inclusion of the above copyright notice. This software may not
+ be provided or otherwise made available to, or used by, any
+ other person. No title to or ownership of the software is
+ hereby transferred.
+"
+"{ Package: 'stx:libbasic' }"
+
+ProceedableError subclass:#AmbiguousMessage
+ instanceVariableNames:''
+ classVariableNames:''
+ poolDictionaries:''
+ category:'Kernel-Extensions'
+!
+
+!AmbiguousMessage class methodsFor:'documentation'!
+
+copyright
+"
+ COPYRIGHT (c) 2006 by eXept Software AG
+ All Rights Reserved
+
+ This software is furnished under a license and may be used
+ only in accordance with the terms of that license and with the
+ inclusion of the above copyright notice. This software may not
+ be provided or otherwise made available to, or used by, any
+ other person. No title to or ownership of the software is
+ hereby transferred.
+"
+! !
+
+!AmbiguousMessage class methodsFor:'documentation'!
+
+version_SVN
+ ^ '$Id: AmbiguousMessage.st,v 1.1 2011-06-28 11:04:04 vrany Exp $'
+! !
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/Annotation.st Tue Jun 28 13:04:04 2011 +0200
@@ -0,0 +1,324 @@
+"
+ COPYRIGHT (c) 2006 by eXept Software AG
+ All Rights Reserved
+
+ This software is furnished under a license and may be used
+ only in accordance with the terms of that license and with the
+ inclusion of the above copyright notice. This software may not
+ be provided or otherwise made available to, or used by, any
+ other person. No title to or ownership of the software is
+ hereby transferred.
+"
+"{ Package: 'stx:libbasic' }"
+
+Object subclass:#Annotation
+ instanceVariableNames:''
+ classVariableNames:''
+ poolDictionaries:''
+ category:'Kernel-Extensions'
+!
+
+Annotation subclass:#NameSpace
+ instanceVariableNames:'nameSpace'
+ classVariableNames:''
+ poolDictionaries:''
+ privateIn:Annotation
+!
+
+Annotation subclass:#Resource
+ instanceVariableNames:'type value'
+ classVariableNames:''
+ poolDictionaries:''
+ privateIn:Annotation
+!
+
+Annotation subclass:#Unknown
+ instanceVariableNames:'key arguments'
+ classVariableNames:''
+ poolDictionaries:''
+ privateIn:Annotation
+!
+
+!Annotation class methodsFor:'documentation'!
+
+copyright
+"
+ COPYRIGHT (c) 2006 by eXept Software AG
+ All Rights Reserved
+
+ This software is furnished under a license and may be used
+ only in accordance with the terms of that license and with the
+ inclusion of the above copyright notice. This software may not
+ be provided or otherwise made available to, or used by, any
+ other person. No title to or ownership of the software is
+ hereby transferred.
+"
+! !
+
+!Annotation class methodsFor:'instance creation'!
+
+key: key arguments: arguments
+
+ ^(self respondsTo: key)
+ ifTrue:
+ [self
+ perform: key
+ withArguments: arguments]
+ ifFalse:
+ [Annotation::Unknown new
+ key: key
+ arguments: arguments]
+
+ "Created: / 19-05-2010 / 16:47:13 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+ "Modified: / 02-07-2010 / 16:22:17 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+namespace: aString
+
+ ^Annotation::NameSpace new nameSpaceName: aString
+
+ "Created: / 19-05-2010 / 16:01:51 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+resource: type
+
+ ^Annotation::Resource new type: type
+
+ "Created: / 16-07-2010 / 11:31:37 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+resource: type value: value
+
+ ^Annotation::Resource new
+ type: type;
+ value: value
+
+ "Created: / 16-07-2010 / 11:31:49 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+! !
+
+!Annotation methodsFor:'accessing'!
+
+first
+
+ ^self key
+
+ "Created: / 10-07-2010 / 21:38:04 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+key
+
+ ^self subclassResponsibility
+
+ "Created: / 19-05-2010 / 16:23:13 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+ "Modified: / 16-07-2010 / 11:29:21 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+! !
+
+!Annotation methodsFor:'printing & storing'!
+
+printOn:aStream
+ "append a printed representation if the receiver to the argument, aStream"
+
+ self storeOn:aStream.
+
+ "Modified: / 19-05-2010 / 16:25:26 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+storeOn:aStream
+
+ self subclassResponsibility
+
+ "Created: / 19-05-2010 / 16:26:02 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+! !
+
+!Annotation methodsFor:'processing'!
+
+annotatesClass: aClass
+
+ ^self subclassResponsibility
+
+ "Created: / 20-05-2010 / 11:15:23 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+annotatesMethod: aMethod
+
+ ^self subclassResponsibility
+
+ "Created: / 20-05-2010 / 11:15:14 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+! !
+
+!Annotation methodsFor:'testing'!
+
+isUnknown
+ ^ false
+! !
+
+!Annotation::NameSpace methodsFor:'accessing'!
+
+key
+
+ ^#namespace:
+
+ "Created: / 19-05-2010 / 16:23:13 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+nameSpace
+ ^ nameSpace
+!
+
+nameSpace:something
+ nameSpace := something.
+! !
+
+!Annotation::NameSpace methodsFor:'initialization'!
+
+nameSpaceName: aString
+
+ self nameSpace: (NameSpace name: aString)
+
+ "Created: / 19-05-2010 / 16:02:30 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+! !
+
+!Annotation::NameSpace methodsFor:'printing & storing'!
+
+storeOn:aStream
+ "superclass Annotation says that I am responsible to implement this method"
+
+ aStream nextPutAll: '(Annotation namespace: '.
+ nameSpace name storeOn: aStream.
+ aStream nextPut:$)
+
+ "Modified: / 19-05-2010 / 16:27:17 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+! !
+
+!Annotation::NameSpace methodsFor:'processing'!
+
+annotatesClass:aClass
+
+ "Nothing to do"
+
+ "Modified: / 20-05-2010 / 11:16:03 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+annotatesMethod:aMethod
+
+ aMethod lookupObject: NamespaceAwareLookup instance
+
+ "Modified: / 20-05-2010 / 11:18:40 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+! !
+
+!Annotation::Resource methodsFor:'accessing'!
+
+key
+ "superclass Annotation says that I am responsible to implement this method"
+
+ ^value
+ ifNil:[#resource:]
+ ifNotNil:[#resource:value:]
+
+ "Modified: / 16-07-2010 / 11:30:47 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+type
+ ^ type
+!
+
+type:something
+ type := something.
+!
+
+value
+ ^ value
+!
+
+value:something
+ value := something.
+! !
+
+!Annotation::Resource methodsFor:'printing & storing'!
+
+storeOn:aStream
+
+ aStream nextPutAll: '(Annotation resource: '.
+ type storeOn: aStream.
+ value ifNotNil:
+ [aStream nextPutAll: ' value: '.
+ value storeOn: aStream].
+ aStream nextPut:$)
+
+ "Modified: / 16-07-2010 / 11:36:13 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+! !
+
+!Annotation::Resource methodsFor:'processing'!
+
+annotatesClass:aClass
+
+ "Nothing to do"
+
+ "Modified: / 16-07-2010 / 11:28:47 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+annotatesMethod:aMethod
+
+ "Nothing to do"
+
+ "Modified: / 16-07-2010 / 11:28:55 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+! !
+
+!Annotation::Unknown methodsFor:'accessing'!
+
+arguments
+ ^ arguments
+!
+
+key
+ ^ key
+! !
+
+!Annotation::Unknown methodsFor:'initialization'!
+
+key:keyArg arguments:argumentsArg
+ key := keyArg.
+ arguments := argumentsArg.
+! !
+
+!Annotation::Unknown methodsFor:'printing & storing'!
+
+storeOn:aStream
+ "superclass Annotation says that I am responsible to implement this method"
+
+ aStream nextPutAll: '(Annotation key: '.
+ key storeOn: aStream.
+ aStream nextPutAll: ' arguments: '.
+ arguments storeOn: aStream.
+ aStream nextPut: $).
+
+ "Modified: / 19-05-2010 / 16:46:05 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+! !
+
+!Annotation::Unknown methodsFor:'processing'!
+
+annotatesClass:aClass
+
+ "Nothing to do"
+
+ "Modified: / 20-05-2010 / 11:15:44 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+annotatesMethod:aMethod
+
+ "Nothing to do"
+
+ "Modified: / 20-05-2010 / 11:15:51 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+! !
+
+!Annotation::Unknown methodsFor:'testing'!
+
+isUnknown
+ ^ true
+! !
+
+!Annotation class methodsFor:'documentation'!
+
+version_SVN
+ ^ '$Id: Annotation.st,v 1.1 2011-06-28 11:04:04 vrany Exp $'
+! !
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/NamespaceAwareLookup.st Tue Jun 28 13:04:04 2011 +0200
@@ -0,0 +1,357 @@
+"
+ COPYRIGHT (c) 2006 by eXept Software AG
+ All Rights Reserved
+
+ This software is furnished under a license and may be used
+ only in accordance with the terms of that license and with the
+ inclusion of the above copyright notice. This software may not
+ be provided or otherwise made available to, or used by, any
+ other person. No title to or ownership of the software is
+ hereby transferred.
+"
+'From Smalltalk/X, Version:6.1.2 on 19-08-2010 at 10:16:13 PM' !
+
+"{ Package: 'stx:libbasic' }"
+
+Lookup subclass:#NamespaceAwareLookup
+ instanceVariableNames:''
+ classVariableNames:'Instance'
+ poolDictionaries:''
+ category:'Kernel-Extensions'
+!
+
+!NamespaceAwareLookup class methodsFor:'documentation'!
+
+copyright
+"
+ COPYRIGHT (c) 2006 by eXept Software AG
+ All Rights Reserved
+
+ This software is furnished under a license and may be used
+ only in accordance with the terms of that license and with the
+ inclusion of the above copyright notice. This software may not
+ be provided or otherwise made available to, or used by, any
+ other person. No title to or ownership of the software is
+ hereby transferred.
+"
+! !
+
+!NamespaceAwareLookup class methodsFor:'initialization'!
+
+initialize
+
+ Instance := self basicNew
+
+ "Created: / 10-07-2010 / 21:12:34 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+! !
+
+!NamespaceAwareLookup class methodsFor:'accessing'!
+
+instance
+
+ ^Instance
+
+ "Created: / 20-05-2010 / 11:18:20 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+ "Modified: / 10-07-2010 / 21:12:48 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+! !
+
+!NamespaceAwareLookup class methodsFor:'lookup'!
+
+lookupMethodForSelector: selector directedTo: initialSearchClass for: receiver withArguments: argArrayOrNil from: sendingContext
+
+ "JV @ 2010-07-24
+ Following C code is just a performance optimization.
+ It is not neccessary, however it speeds things in most
+ cases. Such optimization significantly speeds up the IDE
+ since class browser involves dozens of super-polymorphic
+ sends (> 1000 receiver classes per send-site).
+ "
+
+%{
+ OBJ sendingMthd = __ContextInstPtr(sendingContext)->c_method;
+ if (__Class(sendingMthd) == Method &&
+ __MethodInstPtr(sendingMthd)->m_annotation == nil) {
+ OBJ m = __lookup(initialSearchClass, selector);
+ if (m != nil) RETURN ( m );
+ }
+%}.
+
+ ^Instance lookupMethodForSelector: selector directedTo: initialSearchClass
+ for: receiver withArguments: argArrayOrNil
+ from: sendingContext
+
+! !
+
+!NamespaceAwareLookup methodsFor:'lookup'!
+
+lookupMethodForSelector: selector directedTo: initialSearchClass for: receiver withArguments: argArrayOrNil from: sendingContext
+ "Invoked by the VM to ask me for a method to fire.
+ For details, see comment inLookup>>lookupMethodForSelector:directedTo:for:withArguments:from:"
+
+ | sendingNs sendingMthd queue seen namespaces methods imports |
+
+ "JV @ 2010-07-24
+ Following C code is just a performance optimization.
+ It is not neccessary, however it speeds things in most
+ cases. Such optimization significantly speeds up the IDE
+ since class browser involves dozens of super-polymorphic
+ sends (> 1000 receiver classes per send-site).
+ "
+%{
+ sendingMthd = __ContextInstPtr(sendingContext)->c_method;
+ if (__Class(sendingMthd) == Method &&
+ __MethodInstPtr(sendingMthd)->m_annotation == nil) {
+ OBJ m = __lookup(initialSearchClass, selector);
+ if (m != nil) RETURN ( m );
+ }
+%}.
+ "If you remove C code above, uncomment the line below."
+ "sendingMthd := sendingContext method."
+ sendingNs := sendingMthd isNil
+ ifTrue:[nil]
+ ifFalse:[sendingMthd nameSpace].
+ sendingNs := sendingNs.
+
+ "Second chance to speed up things (in case sending method
+ has resource or so)"
+%{
+ if (sendingNs == nil) {
+ OBJ m = __lookup(initialSearchClass, selector);
+ if (m != nil) RETURN ( m );
+ }
+%}.
+ "
+ Stderr
+ show: 'sel='; show: selector; show: ' ns='; show: sendingNs printString;
+ show: ' method=', sendingMthd printString; cr.
+ "
+
+ sendingNs notNil ifTrue: [
+
+ seen := Set new.
+ namespaces := Array with: sendingNs.
+
+ [namespaces notEmpty] whileTrue:
+ [
+ methods := self
+ lookupMethodsForSelector: selector
+ directedTo: initialSearchClass
+ inNamespaces: namespaces.
+ methods size == 1 ifTrue:
+ [^methods anyOne].
+ methods size > 1 ifTrue:
+ [^self ambiguousMessageSend: selector
+ withArgs: argArrayOrNil].
+ "No method found"
+ seen addAll: namespaces.
+ imports := Set new.
+ namespaces do:
+ [:namespace|
+ namespace notNil ifTrue:
+ [namespace imports do:
+ [:import|
+ (seen includes: import) ifFalse:
+ [imports add: import]]]].
+ namespaces := imports].
+ ].
+
+ methods := self lookupMethodsForSelector: selector
+ directedTo: initialSearchClass.
+ methods size == 1 ifTrue:[^methods anyOne].
+
+ ^nil
+
+ "Modified: / 21-07-2010 / 17:11:07 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+! !
+
+!NamespaceAwareLookup methodsFor:'lookup - helpers'!
+
+lookupMethodsForSelector: selector directedTo: initialSearchClass
+
+ "Searches initialSearchClass for a methods with in any namespace"
+ ^self
+ lookupMethodsForSelector: selector
+ directedTo: initialSearchClass
+ suchThat:[:sel :mthd|true].
+
+ "Created: / 19-07-2010 / 15:37:06 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+lookupMethodsForSelector: selector directedTo: initialSearchClass inNamespaces: namespaces
+
+ "Searches initialSearchClass for a methods with given selector in given namespaces."
+ ^self
+ lookupMethodsForSelector: selector
+ directedTo: initialSearchClass
+ suchThat:[:sel :mthd|namespaces includes: mthd nameSpace].
+
+ "Created: / 19-07-2010 / 15:13:59 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+lookupMethodsForSelector: selector directedTo: initialSearchClass suchThat: block
+
+ "Searches initialSearchClass for a method with given selector in given nameSpace.
+ if no method in given namespace is found, returns nil"
+
+ | searchClass methods seen |
+
+ searchClass := initialSearchClass.
+ methods := Set new.
+ seen := OrderedCollection new.
+ [ searchClass notNil ] whileTrue:
+ [searchClass selectorsAndMethodsDo:
+ [:sel :mthd|
+ (sel selector = selector
+ and:[(seen includes: mthd nameSpace) not
+ and:[block value: sel value: mthd]]) ifTrue:
+ [methods add: mthd.
+ seen add: mthd nameSpace]].
+ searchClass := searchClass superclass].
+ ^methods
+
+ "Created: / 19-07-2010 / 15:34:10 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+ "Modified: / 20-07-2010 / 10:42:52 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+! !
+
+!NamespaceAwareLookup methodsFor:'trampolines'!
+
+ambiguousMessageSend
+
+ ^self ambiguousMessage:
+ (Message
+ selector: #__placeholder__
+ arguments: #()
+ )
+
+ "Created: / 19-08-2010 / 22:05:48 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+ambiguousMessageSend: selector withArgs: argArrayOrNil
+
+ | trampoline |
+
+ trampoline := self class methodDictionary at:
+ (#(" 0"ambiguousMessageSend
+ " 1"ambiguousMessageSendWith:
+ " 2"ambiguousMessageSendWith:with:
+ " 3"ambiguousMessageSendWith:with:with:
+ " 4"ambiguousMessageSendWith:with:with:with:
+ " 5"ambiguousMessageSendWith:with:with:with:with:
+ " 6"ambiguousMessageSendWith:with:with:with:with:with:
+ " 7"ambiguousMessageSendWith:with:with:with:with:with:with:
+ " 8"ambiguousMessageSendWith:with:with:with:with:with:with:with:
+ )
+ at: argArrayOrNil size + 1).
+ trampoline := trampoline asByteCodeMethod.
+ 1 to: trampoline numLiterals do:
+ [:litNr|
+ (trampoline literalAt: litNr) == #__placeholder__
+ ifTrue:[(trampoline literalAt: litNr put: selector)]].
+ ^trampoline
+
+ "Created: / 19-08-2010 / 22:09:24 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+ambiguousMessageSendWith: a1
+
+ ^self ambiguousMessage:
+ (Message
+ selector: #__placeholder__
+ arguments: (Array with: a1)
+ )
+
+ "Created: / 19-08-2010 / 22:06:08 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+ambiguousMessageSendWith: a1 with: a2
+
+ ^self ambiguousMessage:
+ (Message
+ selector: #__placeholder__
+ arguments: (Array with: a1 with: a2)
+ )
+
+ "Created: / 19-08-2010 / 22:06:37 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+ambiguousMessageSendWith: a1 with: a2 with: a3
+
+ ^self ambiguousMessage:
+ (Message
+ selector: #__placeholder__
+ arguments: (Array with: a1 with: a2 with: a3)
+ )
+
+ "Created: / 19-08-2010 / 22:06:48 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+ambiguousMessageSendWith: a1 with: a2 with: a3 with: a4
+
+ ^self ambiguousMessage:
+ (Message
+ selector: #__placeholder__
+ arguments: (Array with: a1 with: a2 with: a3 with: a4)
+ )
+
+ "Created: / 19-08-2010 / 22:06:56 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+ambiguousMessageSendWith: a1 with: a2 with: a3 with: a4
+ with: a5
+
+ ^self ambiguousMessage:
+ (Message
+ selector: #__placeholder__
+ arguments: (Array with: a1 with: a2 with: a3 with: a4
+ with: a5)
+ )
+
+ "Created: / 19-08-2010 / 22:07:15 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+ambiguousMessageSendWith: a1 with: a2 with: a3 with: a4
+ with: a5 with: a6
+
+ ^self ambiguousMessage:
+ (Message
+ selector: #__placeholder__
+ arguments: (Array with: a1 with: a2 with: a3 with: a4
+ with: a5 with: a6)
+ )
+
+ "Created: / 19-08-2010 / 22:07:23 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+ambiguousMessageSendWith: a1 with: a2 with: a3 with: a4
+ with: a5 with: a6 with: a7
+
+ ^self ambiguousMessage:
+ (Message
+ selector: #__placeholder__
+ arguments: (Array with: a1 with: a2 with: a3 with: a4
+ with: a5 with: a6 with: a7)
+ )
+
+ "Created: / 19-08-2010 / 22:07:37 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+ambiguousMessageSendWith: a1 with: a2 with: a3 with: a4
+ with: a5 with: a6 with: a7 with: a8
+
+ ^self ambiguousMessage:
+ (Message
+ selector: #__placeholder__
+ arguments: (Array with: a1 with: a2 with: a3 with: a4
+ with: a5 with: a6 with: a7 with: a8)
+ )
+
+ "Created: / 19-08-2010 / 22:08:03 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+! !
+
+!NamespaceAwareLookup class methodsFor:'documentation'!
+
+version_SVN
+ ^ '$Id: NamespaceAwareLookup.st,v 1.1 2011-06-28 11:04:04 vrany Exp $'
+! !
+
+NamespaceAwareLookup initialize!