gza@mentor.cc.purdue.edu (William R Burdick) (09/04/89)
Use multiple inheritence without fear! I have found multiple inheritence to be an invaluable tool, but in order to use it, I had to fix plenty o' bugs in the implementation, so here is a bug report for all of those who would also like to use it (I got permission to post this from ParcPlace awhile back (some of their code is in this), so don't worry about (c) violations). Right now, I'm using Parcplace Smalltalk version 2.3 -- I don't know how much is fixed in 2.4 or 2.5 -- maybe someone who has 2.5 will update this bunch of fixes. We're getting 2.5 at Purdue in a couple of weeks, so if no one has sent updates for this, I will. There are still some bugs I haven't fixed, but I've been using heavy multiple inheritence for a few months without serious problems... problems: 1) new class methods were not inherited from secondary anscestors 2) class instance variables were not inherited from secondary anscestors. 3) directed methods compiled on-the-fly may cause infinite recursion 4) macro directed methods (all.blah, super.blah) may cause infinite recursion 5) methods which overrode methods defined in secondary superclasses do not get replaced by a copy of the superclass's method when they are removed. 6) classes with multipleinheritence are not always filed out in the correct order. 7) changes do not condense properly example class tree: A G / \ / | B / | | / C D / | / / | / / |/ / E / \ / F (E's primary parent is C and F's primary parent is E) (Do these examples in order if you want to see them work. Also, save your image before you do them...) examples: 1) Add a class method 'duh' to D. evaluate 'E duh'. 2) Add a class instance variable to D. 3) Define initialize in B. Define initialize in D with 'super initialize' as one of the statements. Define initialze in E with 'self D.initialize' as one of the statements. Define new in E class as '^super new initialize'. evaluate F new. 4) Define initialize in G and C. Redefine initialize in E with 'self all.initialize' instead of 'super iniailize'. Define initialize in F with 'self all.initialize' as one of the statements. evaluate F new. 5) Define a method 'Hooble' in D. Define 'Hooble' in E. browse protocols on E. 6) Hard to test, but try (SystemOrganization superclassOrder: #CATEGORY) where CATEGORY is a category with multiply inherited classes. 7) evaluate Smalltalk condenseChanges. why it happens: 1) metaclasses for multiple inheritence respond with 'false' to 'hasMultipleSuperclasses' 2) when a metaclass is recompiled to add class instance variables, the old classes get tangled up during the invokation of become when the instances of the subclasses of the metaclass are recompiled because the value of the variable 'otherSupers' contains those classes which are used in the become. 3) when directed methods are copied, the context of the pseudo-variable 'super' changes, but this is not accounted for by the current software (also, the contexts of the macro methods all.blah and super.blah change). 4) since only one method can be understood as 'all.blah', any previous 'all.blah's are overridden with bad consequences when superclases' methods invoke 'self all.blah'. 5) no call to checkMethodFor: in removeSelector: (defined in Bahavior). 6) superclassOrder: (defined in ChangeSet) only looks at the primary superclasses when ordering the classes. 7) allSubclasses and allSubclassesDo: (defined in Behavior) do not account for multiple inheritence, they must check for duplicates. solutions: Here is a fileIn which (hopefully) fixes those errors... P.S. a directed method is one whose name is like Blah.figgle -- it is 'directed' to a particular class's definition of the method (Blah's in this case). For those not familiar with class instance variables, you might want to look them up in the blue book. Also, I put my name in all of the methods I messed with, so people can send mail to me if they have problems. -- Bill burdick@cello.ecn.purdue.edu --------------------CUT HERE---------------------------- 'From Smalltalk-80, Version 2.3 of 13 June 1988 on 8 August 1989 at 12:11:13 am'! !MetaclassForMultipleInheritance methodsFor: 'class hierarchy'! hasMultipleSuperclasses "added this for consistency -- Bill" ^true! otherSuperclasses "changed this to use metaclasses instead of classes -- Bill" ^ otherSuperclasses collect: [:each | each soleInstance]! superclasses "changed this to use metaclasses instead of classes -- Bill" ^ (Array with: superclass) , otherSuperclasses! setOtherSuperclasses: others "changed this to use metaclasses instead of classes -- Bill" otherSuperclasses _ others collect: [:each | each class]! ! !Behavior methodsFor: 'private'! compoundSelectorsMatching: simple "Changed to handle double-conpound selectors -- Bill" ^self selectors select: [:sel | sel isCompound and: [sel selectorPart = simple or: [sel selectorPart isCompound and: [sel selectorPart selectorPart = simple]]]]! ! !Behavior methodsFor: 'compiling'! compileSimpleCodeFor: aSelector "compile a hook for the macro methods all.blah and super.blah -- Bill" | argNames strm keywords tmp tmpName | argNames _ Array new: aSelector numArgs. 1 to: argNames size do: [:i | argNames at: i put: 'arg' , i printString]. strm _ WriteStream on: (String new: 500). argNames size = 0 ifTrue: [strm nextPutAll: aSelector] ifFalse: [keywords _ aSelector keywords. 1 to: argNames size do: [:i | strm nextPutAll: (keywords at: i); space; nextPutAll: (argNames at: i); space]]. strm nextPutAll: ' | tmp args | tmp _ thisContext sender mclass. tmp isMeta ifTrue: [tmp _ tmp soleinstance]. args _ Array new: '. strm nextPutAll: argNames size printString. strm nextPut: $.; cr. 1 to: argNames size do: [:i | (strm tab) nextPutAll: 'args at: ' , i printString , ' put: ' , (argNames at: i) , '.'; cr]. strm nextPutAll: ' ^self perform: (tmp name, ''' , '.', aSelector , ''') asSymbol withArguments: args'. self compileSortOfUnchecked: strm contents. tmp _ self isMeta ifTrue: [self soleInstance] ifFalse: [self]. tmpName _ (tmp name, '.', aSelector) asSymbol. (self canUnderstand: tmpName) ifFalse: [self tryCopyingCodeFor: tmpName]! compileSortOfUnchecked: code "Compile the argument, code, and install the result in the receiver's method dictionary. Do not check for possible effect on inheritance, since that's what this is doing." "changed addSelectorUnchecked:withMethod to addSelector:withMethod, so that compound selector methods are inherited -- Bill" | selector methodNode | methodNode _ self compilerClass new compile: code in: self notifying: nil ifFail: [^nil]. selector _ methodNode selector. self addSelector: selector withMethod: (methodNode generate). ^selector! compileBroadcastCodeFor: aSelector "compile code that invokes ALL methods for 'selector' in my inheritance hierarchy" "changed 'self withAllSuperClasses' to 'self superclasses' since we are compiling selector in self and we don't want infinite recursion as a result of redefining that method -- Bill" | implementors strm keywords argNames selector classPart class | selector _ aSelector selectorPart selectorPart. class _ Smalltalk at: aSelector classPart ifAbsent: []. (class isKindOf: Class) ifFalse: [^self error: 'could not compile broadcast for ' , aSelector , '; ' , aSelector classPart , ' is not a class.']. classPart _ aSelector classPart , '.' , aSelector selectorPart classPart , '.'. implementors _ class superclasses asSet collect: [:each | each whichClassIncludesSelector: selector]. argNames _ Array new: selector numArgs. 1 to: argNames size do: [:i | argNames at: i put: 'arg' , i printString]. strm _ WriteStream on: (String new: 500). strm nextPutAll: classPart. argNames size = 0 ifTrue: [strm nextPutAll: selector] ifFalse: [keywords _ selector keywords. 1 to: argNames size do: [:i | strm nextPutAll: (keywords at: i); space; nextPutAll: (argNames at: i); space]]. implementors do: [:each | strm cr; tab; nextPutAll: 'self '; nextPutAll: each name; nextPut: $.. argNames size = 0 ifTrue: [strm nextPutAll: selector] ifFalse: [keywords _ selector keywords. 1 to: argNames size do: [:i | strm nextPutAll: (keywords at: i); space; nextPutAll: (argNames at: i); space]]. strm nextPut: $.]. class compileSortOfUnchecked: strm contents! ! !MethodDescription methodsFor: 'accessing'! sourceCode "Change all occurances of the pseudovariable 'super' so that the new context is accounted for" | outStream prev pos code myClass newCode | code _ whichClass sourceCodeAt: selector. prev _ 1. outStream _ WriteStream on: (String new: code size). myClass _ self whichClass isMeta ifTrue: [self whichClass soleInstance] ifFalse: [self whichClass]. myClass superclass isNil ifTrue: [^code]. newCode _ self replace: 'super' with: [:char | 'self ' , myClass superclass name , '.'] in: code before: [:char | char isSeparator]. newCode _ self replace: 'super.' with: [:char | myClass name , '.super.' , (Array with: char)] in: newCode before: [:char | char tokenish]. newCode _ self replace: 'all.' with: [:char | myClass name , '.all.' , (Array with: char)] in: newCode before: [:char | char tokenish]. ^newCode! ! !MethodDescription methodsFor: 'private'! replace: string with: replBlock in: code before: aBlock | outStream prev pos | prev _ 1. outStream _ WriteStream on: (String new: code size). [pos _ code findString: string startingAt: prev. pos > 0] whileTrue: [prev to: pos - 1 do: [:index | outStream nextPut: (code at: index)]. ((pos = 1 or: [(code at: pos - 1) tokenish not]) & (pos + string size <= code size) and: [aBlock value: (code at: pos + string size)]) ifTrue: [outStream nextPutAll: (replBlock value: (code at: pos + string size)). prev _ pos + string size + 1] ifFalse: [outStream nextPutAll: string. prev _ pos + string size]]. prev to: code size do: [:index | outStream nextPut: (code at: index)]. ^outStream contents! ! !Behavior methodsFor: 'creating method dictionary'! removeSelector: selector "Assuming that the message selector is in the receiver's method dictionary, remove it. If the selector is not in the method dictionary, create an error notification. Added call to checkMethodFor: so that removed methods which overrode secondary superclass methods get replaced by the copies -- Bill" methodDict removeKey: selector. self flushCache. self checkChangeSelector: selector. (self superMethodDescriptionAt: selector) isMethodNotImplemented not ifTrue: [self checkMethodFor: selector]! tryCopyingCodeFor: selector "Check if 'selector' is compound, and if so, try to copy down the appropriate code. Return #OK if sucessful, #HierarchyViolation if the class part is not one of my immediate superclasses, or #NotFound if the class part is OK but the selector part is not found in the inheritance hierarchy." | classPart secondClassPart whichClass simpleSelector descr | selector isCompound ifFalse: [^#NotFound]. classPart _ selector classPart. simpleSelector _ selector selectorPart. "check for special class parts" simpleSelector isCompound ifTrue: [secondClassPart _ simpleSelector classPart. simpleSelector _ simpleSelector selectorPart. classPart _ classPart , '.' , secondClassPart. secondClassPart == #all ifTrue: [self compileBroadcastCodeFor: selector. self insertClass: self selector: simpleSelector in: SelectorsOfDirectedMethods. ^#OK]. secondClassPart == #super ifTrue: [descr _ self superMethodDescriptionAt: simpleSelector]] ifFalse: [(#(all super ) includes: classPart) ifTrue: [self compileSimpleCodeFor: selector. self insertClass: self selector: simpleSelector in: SelectorsOfDirectedMethods. ^#BOOT] ifFalse: [whichClass _ Smalltalk at: classPart. "if I'm a metaclass, get the metaclass of whichClass " self isMeta ifTrue: [whichClass _ whichClass class]. "check that whichClass is one of my superclasses " (self inheritsFrom: whichClass) ifFalse: [^#HierarchyViolation]. descr _ whichClass methodDescriptionAt: simpleSelector]]. descr isBad ifTrue: [^#NotFound]. self compileSortOfUnchecked: classPart , '.' , descr sourceCode. self insertClass: self selector: simpleSelector in: SelectorsOfDirectedMethods. ^#OK! ! !Object methodsFor: 'error handling'! doesNotUnderstand: aMessage "First check for a compound selector. If found, try copying down code into the receiver's class. If this is unsuccessful, announce that the receiver does not understand the argument, aMessage, as a message. The default behavior is to create a Notifier containing the appropriate message and to allow the user to open a Debugger. Subclasses can override this message in order to modify this behavior. Use thisContext sender mclass instead of self to save some memory here and there. -- Bill" | status gripe class | class _ thisContext sender mclass. status _ class tryCopyingCodeFor: aMessage selector. status==#OK ifTrue: [^self perform: aMessage selector withArguments: aMessage arguments]. status==#BOOT ifTrue: [class isMeta ifTrue: [class _ class soleInstance]. ^self perform: (class name, '.', aMessage selector) asSymbol withArguments: aMessage arguments]. gripe _ status==#HierarchyViolation ifTrue: [aMessage selector classPart , ' is not one of my superclasses: '] ifFalse: ['Message not understood: ']. NotifierView openContext: thisContext label: gripe , aMessage selector contents: thisContext shortStack. "Try the message again if the programmer decides to proceed." ^self perform: aMessage selector withArguments: aMessage arguments "3 zork."! ! !ChangeSet class methodsFor: 'fileIn/Out'! superclassOrder: classes "Arrange the classes in the collection, classes, in superclass order so the classes can be properly filed in. Class A must come before class B if A is a superclass of B, or if B is A's metaclass. " "Changed this to handle multiple inheritence -- Bill" | order left | left _ IdentitySet new. left addAll: classes. order _ OrderedCollection new. [left isEmpty] whileFalse: [left do: [:c | ((c superclasses detect: [:aSuperclass | left includes: aSuperclass] ifNone: []) notNil or: [(c isKindOf: Metaclass) and: [left includes: c soleInstance]]) ifFalse: [order addLast: c. left remove: c]]]. ^order! ! !Behavior methodsFor: 'accessing class hierarchy'! allSubclasses "Answer an OrderedCollection of the receiver's subclasses and the receiver's ancestor's subclasses in breadth-first order, with the immediate subclasses first. Needed a set to prevent duplication from multiple inheritence -- Bill" | coll set | coll _ OrderedCollection new. coll addAll: self subclasses. set _ coll asSet. self subclasses do: [:eachSubclass | eachSubclass allSubclasses do: [:eachSubSubclass | (set includes: eachSubSubclass) ifFalse: [coll add: eachSubSubclass. set add: eachSubSubclass]]]. ^coll! ! !Behavior methodsFor: 'enumerating'! allSubclassesDo: aBlock "Evaluate the argument, aBlock, for each of the receiver's subclasses. Needed a set to prevent duplication from multiple inheritence" | set | set _ Set new. self oldAllSubclassesDo: [:cl | (set includes: cl) ifFalse: [aBlock value: cl. set add: cl]]! ! !Behavior methodsFor: 'private'! oldAllSubclassesDo: aBlock "Evaluate the argument, aBlock, for each of the receiver's subclasses." self subclasses do: [:cl | aBlock value: cl. cl allSubclassesDo: aBlock]! ! -------------------END OF THE FILEIN------------------