--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/JavaLookup.st Thu Nov 15 22:10:02 2012 +0000
@@ -0,0 +1,793 @@
+"
+ Copyright (c) 2010-2011 Jan Vrany, Jan Kurs & Marcel Hlopko,
+ SWING Research Group, Czech Technical University
+ in Prague
+
+ Permission is hereby granted, free of charge, to any person
+ obtaining a copy of this software and associated documentation
+ files (the 'Software'), to deal in the Software without
+ restriction, including without limitation the rights to use,
+ copy, modify, merge, publish, distribute, sublicense, and/or sell
+ copies of the Software, and to permit persons to whom the
+ Software is furnished to do so, subject to the following
+ conditions:
+
+ The above copyright notice and this permission notice shall be
+ included in all copies or substantial portions of the Software.
+
+ THE SOFTWARE IS PROVIDED 'AS IS', WITHOUT WARRANTY OF ANY KIND,
+ EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES
+ OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+ NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
+ HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
+ WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
+ FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
+ OTHER DEALINGS IN THE SOFTWARE.
+"
+"{ Package: 'stx:libjava' }"
+
+Lookup subclass:#JavaLookup
+ instanceVariableNames:'s2j j2s'
+ classVariableNames:'Instance'
+ poolDictionaries:''
+ category:'Languages-Java-Interop'
+!
+
+Lookup subclass:#Java2Smalltalk
+ instanceVariableNames:''
+ classVariableNames:''
+ poolDictionaries:''
+ privateIn:JavaLookup
+!
+
+Lookup subclass:#Smalltalk2Java
+ instanceVariableNames:''
+ classVariableNames:''
+ poolDictionaries:''
+ privateIn:JavaLookup
+!
+
+!JavaLookup class methodsFor:'documentation'!
+
+copyright
+"
+ Copyright (c) 2010-2011 Jan Vrany, Jan Kurs & Marcel Hlopko,
+ SWING Research Group, Czech Technical University
+ in Prague
+
+ Permission is hereby granted, free of charge, to any person
+ obtaining a copy of this software and associated documentation
+ files (the 'Software'), to deal in the Software without
+ restriction, including without limitation the rights to use,
+ copy, modify, merge, publish, distribute, sublicense, and/or sell
+ copies of the Software, and to permit persons to whom the
+ Software is furnished to do so, subject to the following
+ conditions:
+
+ The above copyright notice and this permission notice shall be
+ included in all copies or substantial portions of the Software.
+
+ THE SOFTWARE IS PROVIDED 'AS IS', WITHOUT WARRANTY OF ANY KIND,
+ EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES
+ OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+ NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
+ HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
+ WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
+ FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
+ OTHER DEALINGS IN THE SOFTWARE.
+
+"
+! !
+
+!JavaLookup class methodsFor:'instance creation'!
+
+cleanup
+
+ Instance := nil.
+
+ "Modified: / 25-02-2011 / 14:45:03 / kursjan <kursjan@fit.cvut.cz>"
+ "Created: / 19-09-2011 / 23:25:08 / Jan Kurs <kursjan@fit.cvut.cz>"
+ "Modified: / 15-12-2011 / 23:05:37 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+instance
+
+ Instance isNil ifTrue:[
+ Instance := self basicNew initialize
+ ].
+ ^Instance
+
+ "Modified: / 25-02-2011 / 14:45:03 / kursjan <kursjan@fit.cvut.cz>"
+ "Created: / 19-09-2011 / 23:20:49 / Jan Kurs <kursjan@fit.cvut.cz>"
+ "Modified: / 15-12-2011 / 23:05:29 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+new
+ ^ self shouldNeverBeSent.
+
+ "Created: / 25-02-2011 / 14:44:43 / kursjan <kursjan@fit.cvut.cz>"
+ "Modified: / 29-08-2011 / 21:10:12 / Jan Kurs <kursjan@fit.cvut.cz>"
+! !
+
+!JavaLookup methodsFor:'initialization'!
+
+initialize
+ "Invoked when a new instance is created."
+
+ s2j := Smalltalk2Java new.
+ j2s := Java2Smalltalk new.
+
+ "Modified: / 15-12-2011 / 23:06:57 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+! !
+
+!JavaLookup methodsFor:'lookup'!
+
+lookupMethodForSelector: selector directedTo: initialSearchClass
+ "This method performs standard Java lookup as required JVM spec. See
+ - JVM spec, 5.4.2.1 Method overriding
+ - JVM spec, 6.4 invokevirtual
+
+ This is hacky because of those stupid package-private methods. Sigh."
+
+ | method superMethod |
+
+ method := super lookupMethodForSelector: selector directedTo: initialSearchClass.
+ method isNil ifTrue:[ ^ nil ].
+
+ superMethod := super lookupMethodForSelector: selector directedTo: method mclass superclass.
+ [ superMethod notNil ] whileTrue:[
+ (method overrides: superMethod) ifFalse:[
+ method := superMethod
+ ].
+ superMethod := super lookupMethodForSelector: selector directedTo: superMethod mclass superclass.
+ ].
+
+ ^method
+
+ "Created: / 05-07-2012 / 11:06:07 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+lookupMethodForSelector:selector directedTo:initialSearchClass for:aReceiver withArguments:argArrayOrNil from:sendingContext ilc: ilcCache
+
+ "Invoked by the VM to ask me for a method to call.
+ The arguments are: the selector, receiver and arguments,
+ the class to start the search in (for here-, super and directed sends)
+ the sending context and the inline/poly cache (instance of
+ PolymorphicInlineCache). "
+
+
+ "JV@2012-08-21: Following C code speeds up Java<->Smalltalk interop by
+ order of 2 magnitudes. However, it breaks Java reflection.
+
+ This is because it does not handle package private methods correctly.
+ On the other hand, PP methods are not handled correctly when not using
+ reflection anyway, so lets keep the optimization here.
+
+ Once we will have functinal JIT compiler, we can remove it and Java
+ package-private method will be supported correctly in all cases.
+ "
+%{
+ OBJ method;
+ method = __lookup(initialSearchClass, selector);
+ if ( method ) {
+ if ( ilcCache ) {
+ __ilcBind(ilcCache, initialSearchClass, method, selector);
+ }
+ RETURN (method);
+ }
+%}.
+
+ sendingContext programmingLanguage isSmalltalk ifTrue:[
+ aReceiver class theNonMetaclass programmingLanguage isJavaLike ifTrue:[
+ ^s2j lookupMethodForSelector:selector directedTo:initialSearchClass for:aReceiver withArguments:argArrayOrNil from:sendingContext ilc: ilcCache.
+ ].
+ ].
+
+ sendingContext programmingLanguage isJavaLike ifTrue:[
+ initialSearchClass programmingLanguage isSmalltalk ifTrue:[
+ "Java to Smalltalk send"
+ ^j2s lookupMethodForSelector:selector directedTo:initialSearchClass for:aReceiver withArguments:argArrayOrNil from:sendingContext ilc: ilcCache.
+ ].
+ initialSearchClass programmingLanguage isJavaLike ifTrue:[
+ "Java to Java send"
+ | m |
+
+ m := self lookupMethodForSelector: selector directedTo: initialSearchClass.
+ m notNil ifTrue:[
+ ilcCache notNil ifTrue:[ ilcCache bindTo: m forClass: aReceiver class ].
+ ^m.
+ ]
+ ].
+ ].
+
+ ^super lookupMethodForSelector:selector directedTo:initialSearchClass for:aReceiver withArguments:argArrayOrNil from:sendingContext ilc: ilcCache.
+
+ "Created: / 01-10-2011 / 13:18:40 / Jan Kurs <kursjan@fit.cvut.cz>"
+ "Created: / 15-12-2011 / 23:11:45 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+! !
+
+!JavaLookup::Java2Smalltalk methodsFor:'lookup'!
+
+lookupMethodForSelector:selector directedTo:initialSearchClass for:receiver withArguments:argArrayOrNil from:sendingContext ilc: ilc
+
+ | d m |
+
+ d := JavaDescriptor readFrom: (selector readStream skipThrough: $(; backStep; yourself).
+ m := self lookupMethodForSelector: selector directedTo: initialSearchClass numArguments: d numArgs.
+ m notNil ifTrue: [
+ m := self compileProxyWithSelector: selector descriptor: d in: receiver class calling: m.
+ ilc notNil ifTrue:[ilc bindTo: m forClass: receiver class].
+ ^m.
+ ] ifFalse:[
+ ^ nil
+ ]
+
+ "Created: / 06-09-2011 / 22:04:04 / Jan Kurs <kursjan@fit.cvut.cz>"
+ "Modified: / 09-10-2011 / 22:59:18 / kursjan <kursjan@fit.cvut.cz>"
+ "Created: / 19-11-2011 / 12:37:26 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+lookupMethodForSelector:jselector directedTo:initialSearchClass numArguments: nArgs
+
+ | name cls |
+
+ name := jselector upTo: $(.
+
+ "Pass 1: Search for explicitly annotated method"
+ cls := initialSearchClass.
+ [ cls notNil ] whileTrue:[
+ cls methodDictionary keysAndValuesDo:[:sel :mthd|
+ | jdescriptor |
+
+ mthd numArgs == nArgs ifTrue:[
+ (jdescriptor := mthd annotationAt: #javaselector:) notNil ifTrue:[
+ jdescriptor arguments first == jselector ifTrue: [
+ ^mthd
+ ]
+ ].
+ ]
+ ].
+ cls := cls superclass.
+ ].
+
+ "Pass 2: Search for method with matching name"
+ cls := initialSearchClass.
+ [ cls notNil ] whileTrue:[
+ cls methodDictionary keysAndValuesDo:[:sel :mthd|
+ mthd numArgs == nArgs ifTrue:[
+ (sel startsWith: name) ifTrue:[
+ ^mthd
+ ]
+ ]
+ ].
+ cls := cls superclass.
+ ].
+
+ ^nil
+
+ "Created: / 16-12-2011 / 00:00:31 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+! !
+
+!JavaLookup::Java2Smalltalk methodsFor:'utilities'!
+
+addSelector:selector withMethod:proxy toClass:class
+
+ ProxyMethod installProxies ifTrue:[
+ Class withoutUpdatingChangesDo:[
+ class addSelector:selector withMethod:proxy.
+ ]
+ ]
+
+ "Modified: / 23-12-2011 / 13:09:06 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+compileProxyWithSelector:selector descriptor:descriptor in:class calling:callee
+ |compiler proxy body|
+
+ compiler := ProxyMethodCompiler new.
+ body := compiler newJavaMethodInvocation: callee.
+ body descriptor:descriptor.
+ proxy := compiler
+ compile:body
+ arguments:callee numArgs
+ selector: selector.
+"/ JK: do nod add here
+"/ JV: Why?
+ self
+ addSelector:selector
+ withMethod:proxy
+ toClass:class.
+ ^ proxy
+
+ "Created: / 14-12-2011 / 20:48:55 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+ "Modified: / 01-01-2012 / 19:33:45 / kursjan <kursjan@fit.cvut.cz>"
+ "Modified: / 24-02-2012 / 20:36:24 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+! !
+
+!JavaLookup::Smalltalk2Java methodsFor:'lookup'!
+
+lookupMethodForSelector:selector directedTo:initialSearchClass for:receiver withArguments:argArrayOrNil from:sendingContext ilc: ilc
+ "
+ As a courtesy to a Smalltalker, try to map smalltalk selectors to a java ones.
+ Returns JavaMethodDescriptor or nil.
+ "
+ | name nameSizePlusOne candidates finder static cls m |
+
+ name := selector upTo: $:.
+ nameSizePlusOne := name size + 1.
+ static := receiver isBehavior.
+ candidates := OrderedCollection new.
+ finder := [:cls|
+ cls methodDictionary keysAndValuesDo:[:sel :mthd|
+ "candidates may contain a method with same selector ->
+ do not add super-class's method"
+ (candidates contains:[:each|each selector == sel]) ifFalse:[
+ (mthd mclass ~~ ProxyMethod
+ and:[((sel size >= nameSizePlusOne) and:[(sel at: nameSizePlusOne) == $( and:[(sel startsWith: name)]])
+ and:[mthd descriptor numArgs == argArrayOrNil size]]) ifTrue:[
+ candidates add: mthd
+ ]
+ ]
+ ]
+ ].
+
+ "Search class for method candidates"
+ cls := initialSearchClass theNonMetaclass.
+ static ifTrue:[
+ finder value: cls
+ ] ifFalse:[
+ [ cls notNil and:[cls ~~ JavaObject] ] whileTrue:[
+ finder value: cls.
+ cls := cls superclass.
+ ]
+ ].
+
+ candidates notEmpty ifTrue:[
+ m := self compileProxyWithSelector: selector in: receiver class calling: candidates.
+ ilc notNil ifTrue:[ilc bindTo: m forClass: receiver class].
+
+ "Install the proxy"
+ self addSelector: selector withMethod: m toClass: receiver class.
+
+ ^m.
+ ].
+
+ "Hmm, hmm, maybe a public field?"
+ (argArrayOrNil size < 2) ifTrue:[
+ | field |
+
+ field := initialSearchClass theNonMetaclass
+ lookupFieldFor: name
+ static: initialSearchClass isMetaclass
+ onlyPublic: true.
+ field notNil ifTrue:[
+ m := self compileProxyWithSelector: selector in: receiver class accessing: field.
+ ilc notNil ifTrue:[ilc bindTo: m forClass: receiver class].
+
+ "Install the proxy"
+ self addSelector: selector withMethod: m toClass: receiver class.
+
+ ^m.
+ ]
+ ].
+ ^nil
+
+ "Created: / 21-02-2011 / 13:38:55 / kursjan <kursjan@fit.cvut.cz>"
+ "Modified: / 29-08-2011 / 20:38:21 / kursjan"
+ "Modified: / 20-09-2011 / 00:03:48 / Jan Kurs <kursjan@fit.cvut.cz>"
+ "Modified (format): / 25-09-2011 / 21:08:45 / Jan Kurs <kursjan@fit.cvut.cz>"
+ "Created: / 19-11-2011 / 13:03:39 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+ "Modified: / 01-01-2012 / 19:58:59 / kursjan <kursjan@fit.cvut.cz>"
+ "Modified (comment): / 02-01-2012 / 10:35:25 / kursjan <kursjan@fit.cvut.cz>"
+ "Modified: / 17-03-2012 / 17:22:33 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+! !
+
+!JavaLookup::Smalltalk2Java methodsFor:'lookup (old)'!
+
+old_lookupMethodForSelector:selector directedTo:initialSearchClass for:receiver withArguments:argArrayOrNil from:sendingContext ilc: ilc
+ "
+ As a courtesy to a Smalltalker, try to map smalltalk selectors to a java ones.
+ Returns JavaMethodDescriptor or nil.
+ "
+ |descriptor candidate static cls m |
+
+ static := receiver isBehavior.
+ descriptor := JavaMethodDescriptor
+ name: (selector upTo:$:)
+ parameters: (argArrayOrNil ? #() collect:[:a|
+ (a class isString and: [JavaVM booted]) ifTrue:[
+ JavaFieldDescriptorWithUnionType new
+ addDescriptor: (JavaFieldDescriptor javaClass: a class);
+ addDescriptor: (JavaFieldDescriptor javaClass: (Java classForName: 'java.lang.String'));
+ yourself.
+ ] ifFalse:[
+ JavaFieldDescriptor javaClass: a class
+ ]
+ ]).
+ cls := initialSearchClass theNonMetaclass.
+ [ cls notNil and:[cls ~~ JavaObject] ] whileTrue:[
+ cls methodsDo:[:mthd|
+ "/(mthd selector startsWith: 'foo') ifTrue:[self breakPoint: #jv].
+ (mthd class ~~ ProxyMethod and:[mthd isStatic == static and:[descriptor match: mthd descriptor]]) ifTrue:[
+ candidate isNil ifTrue:[
+ candidate := mthd
+ ] ifFalse:[
+ candidate descriptorSymbol ~~ mthd descriptorSymbol ifTrue:[
+ "Hm, hm, two matching methods with different descriptors means
+ ambiguity...raise an error"
+
+ "Bit hacky - NamespaceAwareLookup already has method to generate
+ ambigouous send trampouline..."
+ ^NamespaceAwareLookup instance ambiguousMessageSend: selector withArgs: argArrayOrNil
+ ]
+ ].
+ ]
+ ].
+ cls := cls superclass.
+ ].
+ candidate notNil ifTrue:[
+ m := self compileProxyWithSelector: selector descriptor: descriptor in: receiver class calling: candidate.
+ ilc notNil ifTrue:[ilc bindTo: m forClass: receiver class].
+ ^m.
+ ].
+ ^nil
+
+ "Created: / 21-02-2011 / 13:38:55 / kursjan <kursjan@fit.cvut.cz>"
+ "Modified: / 11-04-2011 / 20:19:50 / kursjan <kursjan@fit.cvut.cz>"
+ "Modified: / 29-08-2011 / 20:38:21 / kursjan"
+ "Modified: / 20-09-2011 / 00:03:48 / Jan Kurs <kursjan@fit.cvut.cz>"
+ "Modified (format): / 25-09-2011 / 21:08:45 / Jan Kurs <kursjan@fit.cvut.cz>"
+ "Created: / 16-12-2011 / 23:05:41 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+! !
+
+!JavaLookup::Smalltalk2Java methodsFor:'matching'!
+
+descriptorForJavaSelector:arg
+ ^ MessageDescription new
+ parserClass: JavaSelectorParser;
+ selector: arg;
+ yourself.
+
+ "Created: / 29-08-2011 / 20:41:48 / Jan Kurs <kursjan@fit.cvut.cz>"
+!
+
+descriptorForSmalltalkSelector:selector arguments: args
+ ^ MessageDescription new
+ parserClass: SmalltalkSelectorParser;
+ runtimeArguments: args;
+ selector: selector;
+ yourself.
+
+ "Created: / 29-08-2011 / 21:44:06 / Jan Kurs <kursjan@fit.cvut.cz>"
+!
+
+findBestMatchOf: smalltalkMethod in: javaMethods
+ | methods |
+ javaMethods size = 1 ifTrue: [
+ ^ javaMethods first.
+ ].
+ javaMethods size = 0 ifTrue: [
+ ^ nil
+ ].
+
+ methods := javaMethods select: [:m |
+ m argSize = smalltalkMethod argSize.
+ ].
+ methods size = 1 ifTrue: [
+ ^ methods first.
+ ].
+
+ methods := methods select: [:m |
+ self javaMatches: m argTypes to: smalltalkMethod args.
+ ].
+ methods size = 1 ifTrue: [
+ ^ methods first.
+ ].
+
+ methods size = 0 ifTrue: [
+ ^ nil.
+ ].
+
+ ^ Error raiseErrorString: 'Ambiguous selector: ', smalltalkMethod name.
+
+ "Created: / 29-08-2011 / 20:50:14 / Jan Kurs <kursjan@fit.cvut.cz>"
+!
+
+javaMatches: jArgs to: sArgs
+
+ 1 to: jArgs size do: [ :i |
+ ((JavaTypeBox typeBoxForJava: (jArgs at: i)) smalltalkType = ((sArgs at: i) className)) ifFalse: [ ^ false ].
+ ].
+ ^ true.
+
+ "Created: / 29-08-2011 / 21:21:37 / Jan Kurs <kursjan@fit.cvut.cz>"
+!
+
+javaSelectorsFor:class
+ | selectors cls static |
+ cls := class.
+ selectors := IdentitySet new.
+ self breakPoint: #jk info: 'determine static based on class'.
+ static := false.
+
+ [cls = JavaObject] whileFalse: [
+ cls methodDictionary keysAndValuesDo: [:k :v |
+ (v isJavaMethod and: [v isStatic = static]) ifTrue: [
+ selectors add: k.
+ ].
+ ].
+ cls := cls superclass.
+ ].
+ ^ selectors.
+
+ "Created: / 06-09-2011 / 22:20:34 / Jan Kurs <kursjan@fit.cvut.cz>"
+! !
+
+!JavaLookup::Smalltalk2Java methodsFor:'utilities'!
+
+addSelector:selector withMethod:proxy toClass:class
+
+ ProxyMethod installProxies ifTrue:[
+ Class withoutUpdatingChangesDo:[
+ class addSelector:selector withMethod:proxy.
+ proxy mclass: class.
+ ]
+ ]
+
+ "Created: / 01-01-2012 / 17:41:46 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+compileProxyWithSelector:selector in:class accessing: field
+ "For given field, create a proxy getter/setter"
+
+
+ |compiler proxy body isSetter |
+
+ class theNonMetaclass classInit.
+ isSetter := selector last == $:.
+ compiler := ProxyMethodCompiler new.
+ isSetter ifTrue:[
+ body := compiler newJavaFieldSetter: field.
+ proxy := compiler
+ compile:body
+ arguments: 1
+ selector:selector.
+ ] ifFalse:[
+ body := compiler newJavaFieldGetter: field.
+ proxy := compiler
+ compile:body
+ arguments: 0
+ selector:selector.
+
+ ].
+
+ ^ proxy
+
+ "Modified: / 30-12-2011 / 14:44:11 / kursjan <kursjan@fit.cvut.cz>"
+ "Created: / 17-03-2012 / 16:54:09 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+compileProxyWithSelector:selector in:class calling:methods
+ "For given set of methods, create a dispatching proxy with given selector.
+ This method performs typechecks on arguments and dispatch to proper method"
+
+ |compiler proxy body fallback|
+
+ compiler := ProxyMethodCompiler new.
+ fallback := self
+ fallbackWithSelector:selector
+ in:class
+ calling:methods
+ compiler:compiler.
+ "Generate and install dispatching tree..."
+ selector numArgs == 0 ifTrue:[
+ "If method has no arguments, no dynamic method dispatch is
+ required. Therefore, no fallback is needed. In theory, there is
+ no need for proxy method at all..."
+ self assert:methods size == 1.
+ body := compiler newJavaMethodInvocation:methods anyOne.
+ ] ifFalse:[
+ "JV@2012-01-01: Based on discussion with JK, if there is no overloaded method
+ DO NOT compile guard, call the method directly. We'll see..."
+ methods size == 1 ifTrue:[
+ body := (compiler newJavaMethodInvocation:methods anElement).
+ ] ifFalse:[
+ "For every method, create a guard and add it"
+ body := fallback.
+ ]
+ ].
+
+ "/Create and install proxy
+
+ proxy := compiler
+ compile:body
+ arguments:methods anyOne descriptor numPhysicalArgs
+ selector:selector.
+
+"/ self halt.
+"/ JK: do NOT install here, just compile and return the proxy. Let someone else to install
+"/ self
+"/ addSelector:selector
+"/ withMethod:proxy
+"/ toClasS:class.
+
+ ^ proxy
+
+ "Created: / 16-12-2011 / 23:21:55 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+ "Modified: / 30-12-2011 / 14:44:11 / kursjan <kursjan@fit.cvut.cz>"
+ "Modified: / 15-02-2012 / 01:07:42 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+compileProxyWithSelector: selector in: class calling: methods receiver: receiver arguments: arguments
+ "For given receiver and arguments, selects apropriate method from methods
+ and compile guard"
+
+ | compiler method proxy condition invocation fallback guard |
+
+ compiler := ProxyMethodCompiler new.
+
+ proxy := class compiledMethodAt: selector.
+ proxy notNil ifTrue:[
+ fallback := proxy body
+ ] ifFalse:[
+ fallback := self fallbackWithSelector: selector in: class calling: methods compiler: compiler.
+ ].
+
+ method := self selectMethodFrom: methods arguments: arguments.
+ invocation := compiler newJavaMethodInvocation:method.
+
+ condition := nil.
+ arguments withIndexDo:[:arg :index|
+ condition isNil ifTrue:[
+ condition := compiler newTypeCheck: arg class argument: index.
+ ] ifFalse:[
+ condition := condition and: (compiler newTypeCheck: arg class argument: index).
+ ].
+ ].
+
+ guard := compiler newGuard
+ condition: condition;
+ action: invocation;
+ fallback: fallback;
+ yourself.
+
+ proxy := compiler
+ compile:guard
+ arguments:methods anyOne descriptor numPhysicalArgs
+ selector:selector.
+
+ self
+ addSelector:selector
+ withMethod:proxy
+ toClass:class.
+
+ "Created: / 03-01-2012 / 22:14:06 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+fallbackWithSelector:selector in:class calling:methods compiler:compiler
+ ^ compiler
+ newJavaBlockInvocation:[:receiver :arguments |
+ self
+ compileProxyWithSelector:selector
+ in:class
+ calling:methods
+ receiver:receiver
+ arguments:arguments.
+ "/self breakPoint:#jv.
+ receiver perform:selector withArguments:arguments.
+ ]
+
+ "Modified: / 04-01-2012 / 21:35:40 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+selectMethodFrom: methods arguments: arguments
+
+ | candidates |
+
+ candidates := methods.
+ arguments withIndexDo:[:arg :index|
+ | cls |
+
+ cls := arg class.
+ candidates := candidates select:[:m|
+ self breakPoint:#mh.
+ self type: cls matches: (m descriptor parameters at: index) javaClass
+ ].
+ ].
+
+ candidates size == 0 ifTrue:[
+ self halt: 'Unfinished - no matching method'
+ ].
+ candidates size == 1 ifTrue:[
+ ^candidates anElement
+ ].
+
+ self halt: 'Unfinished - ambiguous'
+
+ "Created: / 03-01-2012 / 21:40:23 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+ "Modified: / 03-04-2012 / 13:59:13 / Marcel Hlopko <hlopkmar@fel.cvut.cz>"
+ "Modified (format): / 20-04-2012 / 19:58:19 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+type: actual matches: formal
+ "Return true, if actual (parameter) type matches given formal (parameter) type"
+
+ formal isJavaPrimitiveType ifTrue: [
+ actual == SmallInteger ifTrue:[
+ ^formal == Integer or:[actual == formal].
+ ].
+ formal == Boolean ifTrue:[
+ ^actual == True or:[actual == False or:[actual == Boolean]].
+ ].
+ ^ actual == formal.
+ ].
+ actual isJavaPrimitiveType ifTrue: [
+ ^ formal isJavaWrapperClass and: [ formal == actual javaWrapperClass ]
+ ].
+ (actual includesBehavior: String "care about multi-byte strings") ifTrue: [
+ ^ formal name == #'java/lang/String'
+ ].
+ ^ JavaVM canCast: actual to: formal
+
+ "Created: / 03-01-2012 / 22:36:19 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+ "Modified: / 03-04-2012 / 13:59:28 / Marcel Hlopko <hlopkmar@fel.cvut.cz>"
+ "Modified: / 29-10-2012 / 07:28:10 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+! !
+
+!JavaLookup::Smalltalk2Java methodsFor:'utilities (old)'!
+
+old_compileProxyWithSelector: selector descriptor: descriptor in: class calling: callee
+
+ | proxy invocation fallback |
+
+ "This method might (indirectly) be invoked by guarded method itself,
+ when all guards fails and method gets recompiled during fallback action.
+ In that case, we should not throw away existing proxy, but just extend it."
+
+ proxy := class compiledMethodAt: selector.
+ proxy isNil ifTrue:[
+ "No method exists, create one..."
+ proxy := ProxyMethod new.
+ proxy numberOfArgs: callee descriptor numPhysicalArgs.
+ proxy source:'I''m a proxy method, please inspect my body'.
+ "Create default fallback"
+ fallback := ProxyMethod newJavaBlockInvocation: [ self halt: 'Launch recompile, not yet implemented'].
+ "Install it..."
+ Class withoutUpdatingChangesDo:[
+ class addSelector: selector withMethod: proxy.
+ ]
+ ] ifFalse:[
+ "Method already exists, then the fallback is currently
+ installed body"
+ fallback := proxy body.
+ ].
+
+ "Now, create and install a node that invokes given method"
+ callee numArgs == 0 ifTrue:[
+ "If method has no arguments, no dynamic method dispatch is
+ required. Therefore, no fallback is needed. In theory, there is
+ no need for proxy method at all..."
+ self assert: descriptor numArgs size == 0.
+ invocation := ProxyMethod newJavaMethodInvocation: callee.
+ "Install it"
+ proxy body: invocation
+ ] ifFalse:[
+ "Create a guard"
+ invocation := ProxyMethod newGuard.
+ invocation condition: callee descriptor guardCondition.
+ invocation action: (ProxyMethod newJavaMethodInvocation: callee).
+ invocation fallback: fallback.
+ "Install it"
+ proxy addGuard: invocation.
+ ].
+ "/Finally, return the method
+ ^ proxy
+
+ "Created: / 16-12-2011 / 23:06:02 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+! !
+
+!JavaLookup class methodsFor:'documentation'!
+
+version_SVN
+ ^ '$Id$'
+! !