eliot@cs.qmw.ac.uk (Eliot Miranda) (03/23/91)
This set of files comprises
a) as complete set of bug fixes for Smalltalk-80 V2.3 multiple
inheritance as I have collected and developed.
b) an extension to the multiple inheritance system
Bug Fixes:
The bug fixes are in
MIKernel.fixes: fixes for Behavior, Metaclass & MetaclassForMultipleInheritance
MISupport.fixes: fixes for ChangeScanner, ChangeSet, MethodDescription & Symbol
Some of these fixes were posted by Colin Kendall (but I have changed some).
Most of these fixes were posted by Bill Burdick (and again I have changed some of these).
My major fix is to avoid loosing code defined in a class when it is redefined as
a class with multiple superclasses. Care should be taken when filing these fixes into a ParcPlace 2.3 system. Some methods send flushCacheEntries: & should be modified to send flushCache. (My version 2.3.2t contains flushCacheEntries: & some people use it).
Inheritance Annotations:
The extension is in
MIAnnotation.changes
and is more interesting. Often when you use St-80 multiple inheritance, the new class will inherit from two classes A & B that have a set of methods that provide similar functionality but conflict. Consider the following example:
Class named: #OrderedCollectionModel
superclasses: 'OrderedCollection Model '
instanceVariableNames: ''
classVariableNames: ''
category: 'Examples-MultipleInheritance'
Instances of OrderedCollectionModel are intended to be OrderedCollections that use Model's implementation of the dependency mechanism. That is, I intend instances of OrderedCollectionModel to be OrderedCollections that use Model's implementation of dependents access rather than Object's.
When this class is constructed three groups of conflicting selectors are compiled as conflicting inherited methods:
a) the protocol defined in Object and OrderedCollection:
comparing = hash
copying shallowCopy
accessing at: at:put: size
user interface inspect
printing printOn: storeOn:
Object implements these with suitable defaults for most objects.
OrderedCollection redefines these as a Collection and
SequenceableCollection and to support efficiently dequeue
functionality.
b) the protocol defined in Object and Model:
copying copy
updating broadcast: broadcast:with:
dependents access addDependent: dependents removeDependent:
changing changed:with: changeRequest changeRequest: changeRequestFrom
private breakDependents
Object implements these with an IdentityDictionary mapping
object to dependents and this implementation is a cause of much
isolated key garbage during program development. Model
reimplements these with an instance variable to hold the
dependents neatly avoiding the garbage collection problem.
c) the protocol defined in Behavior (inherited by Object class)
and defined in OrderedCollection class:
instance creation new new:
Behavior implements these with suitable defaults for most
objects. OrderedCollection redefines these to correctly
initialize new instances.
Clearly I would like to inherit protocol a) from OrderedCollection, overriding
Object. Similarly, I would like b) from Model, overriding Object and c) from
OrderedCollection class overriding Object class. In the 'standard' multiple
inheritance system I would have to define methods for group a) looking like:
OrderedCollectionModel methods for comparing
= anObject
^self OrderedCollection.= anObject
or more efficiently, since OrderedCollection is on OrderedCollectionModel's
dynamic inheritance chain:
= anObject
^super = anObject
or even more efficiently since "= anObject ^super = anObject" is a no-op,
OrderedCollectionModel removeSelectorSimply: #=
Similarly for group b) I would have to implement methods looking like:
OrderedCollectionModel methods for dependents access
dependents
^self Model.dependents
Similarly for group c.
This manual definition is very tedious, and its hard to derive the intension
from the code. Far neater would be to state that methods from OrderedCollection
should override methods for Object and that methods from Model should override
Object, which is what my extension allows one to do:
Class named: #OrderedCollectionModel
superclasses: 'OrderedCollection Model '
inheritanceAnnotation: 'OrderedCollection overrides: Object,
Model overrides: Object'
instanceVariableNames: ''
classVariableNames: ''
category: 'Examples-MultipleInheritance'
In this scheme, if A overrides B then each method that is a conflicting
inherited method inherited from only A and B (possibly indirectly) and no
others, will be reimplemented to invoke the method inherited from A. Conflicts
involving more than two methods will not be resolved. A overrides B implies
A class overrides B class., hence in the above example there is no need to
state that OrderedCollection class overrides Object class.
I an terribly ignorant of other systems supporting multiple inheritance and
too lazy to read up on them all. I am sure I have reinvented a wheel.
I would be very interested to hear about similar schemes from people who know
about other systems. That said, I hope the following will be useful to people
using Smalltalk-80 multiple inheritance.
The implementation of "inheritance annotations" is flexible and should support
other modifiers than 'overrides:'. Look at Class>inheritanceAnnotation: for
how this works. Care is taken to avoid filing out selectors that have been
overriden, and to remember overriden selectors that have been removed.
This allows the implementation to remove conflict methods that are overriden
by a class on the dynamic inheritance chain.
Filing In:
First carefully file in the fixes. If you are using ParcPlace 2.3 you will have to rewrite methods that use block temporaries and string Symbol literals (2.3.2t supports block temps & 2.5-style symbol literals). Then file in MIAnnotations.changes. To assure yourself that the system works file in OrderedCollectionModel.st. You should observe that
a) OrderedCollectionModel implements
('dependents access' addDependent: dependents removeDependent:)
('updating' broadcast: broadcast:with:)
('copying' copy)
('changing' changed:with: changeRequest changeRequest: changeRequestFrom:)
('private' breakDependents)
all of which are of the form
copy
^self model.copy
b) OrderedCollectionModel's overridenSelectorSet is:
OrderedCollectionModel overridenSelectorSet associations asSortedCollection
=->remove
addDependent:->add
at:->remove
at:put:->remove
breakDependents->add
broadcast:->add
broadcast:with:->add
changed:with:->add
changeRequest->add
changeRequest:->add
changeRequestFrom:->add
copy->add
dependents->add
diagramFigureClass->remove
hash->remove
inspect->remove
printOn:->remove
removeDependent:->add
shallowCopy->remove
size->remove
storeOn:->remove
c) OrderedCollectionModel class's overridenSelectorSet is:
OrderedCollectionModel class overridenSelectorSet
IdentityDictionary (new:->remove new->remove )
d) Filing out OrderedCollectionModel produces (apart from differences in the header)
precisely the following (& no removeSelector doits)
'From BrouHaHa Smalltalk-80, Version 2.3.2t of 27 February 1990 on 22 March 1991 7:33:25 pm'!
Class named: #OrderedCollectionModel
superclasses: 'OrderedCollection Model '
inheritanceAnnotation: 'OrderedCollection overrides: Object, Model overrides: Object'
instanceVariableNames: ''
classVariableNames: ''
category: 'Examples-MultipleInheritance'!
Since this code is essentially a derivative work from Smalltalk-80 Version 2.0
I cannot publish it under the GPL. Consequently I submit this code to the net
for any purpose what-so-ever (but try not to waste trees!).
Remember to post comp.lang.smalltalk and/or comp.object about multiple
inheritance conflict resolution schemes you know about!
Share and Enjoy.
Eliot Miranda email: eliot@cs.qmw.ac.uk
Dept of Computer Science Tel: 071 975 5229 (+44 71 975 5229)
Queen Mary Westfield College ARPA: eliot%cs.qmw.ac.uk@nsf.ac.uk
Mile End Road UUCP: eliot@qmw-cs.uucp
LONDON E1 4NS
---- Cut Here and unpack ----
#!/bin/sh
# xshar: Shell Archiver (v1.22)
#
# Remove the header and type "sh filename" to create:
# README
# MIKernel.fixes
# MISupport.fixes
# MIAnnotation.changes
# OrderedCollectionModel.st
#
echo "x - extracting README (Text)"
sed 's/^X//' << 'SHAR_EOF' > README &&
XThis set of files comprises
X a) as complete set of bug fixes for Smalltalk-80 V2.3 multiple inheritance as I have
X collected and developed.
X b) an extension to the multiple inheritance system
X
X
XBug Fixes:
XThe bug fixes are in
X MIKernel.fixes: fixes for Behavior, Metaclass & MetaclassForMultipleInheritance
X MISupport.fixes: fixes for ChangeScanner, ChangeSet, MethodDescription & Symbol
XSome of these fixes were posted by Colin Kendall (but I have changed some).
XMost of these fixes were posted by Bill Burdick (and again I have changed some of these).
XMy major fix is to avoid loosing code defined in a class when it is redefined as
Xa class with multiple superclasses. Care should be taken when filing these fixes into a ParcPlace 2.3 system. Some methods send flushCacheEntries: & should be modified to send flushCache. (My version 2.3.2t contains flushCacheEntries: & some people use it).
X
X
XInheritance Annotations:
XThe extension is in
X MIAnnotation.changes
Xand is more interesting. Often when you use St-80 multiple inheritance, the new class will inherit from two classes A & B that have a set of methods that provide similar functionality but conflict. Consider the following example:
X
X Class named: #OrderedCollectionModel
X superclasses: 'OrderedCollection Model '
X instanceVariableNames: ''
X classVariableNames: ''
X category: 'Examples-MultipleInheritance'
X
XInstances of OrderedCollectionModel are intended to be OrderedCollections that use Model's implementation of the dependency mechanism. That is, I intend instances of OrderedCollectionModel to be OrderedCollections that use Model's implementation of dependents access rather than Object's.
X
XWhen this class is constructed three groups of conflicting selectors are compiled as conflicting inherited methods:
X a) the protocol defined in Object and OrderedCollection:
X comparing = hash
X copying shallowCopy
X accessing at: at:put: size
X user interface inspect
X printing printOn: storeOn:
X Object implements these with suitable defaults for most objects.
X OrderedCollection redefines these as a Collection, SequenceableCollection and to
X support efficiently dequeue functionality.
X
X b) the protocol defined in Object and Model:
X copying copy
X updating broadcast: broadcast:with:
X dependents access addDependent: dependents removeDependent:
X changing changed:with: changeRequest changeRequest: changeRequestFrom
X private breakDependents
X Object implements these with an IdentityDictionary mapping object to dependents
X and this implementation is a cause of much isolated key garbage during program
X development. Model reimplements these with an instance variable to hold the
X dependents neatly avoiding the garbage collection problem.
X
X c) the protocol defined in Behavior (inherited by Object class) and defined in
X OrderedCollection class:
X instance creation new new:
X Behavior implements these with suitable defaults for most objects. OrderedCollection
X redefines these to correctly initialize new instances.
X
XClearly I would like to inherit protocol a) from OrderedCollection, overriding Object.
XSimilarly, I would like b) from Model, overriding Object and c) from OrderedCollection class
Xoverriding Object class. In the 'standard' multiple inheritance system I would have to define
Xmethods for group a) looking like:
X OrderedCollectionModel methods for comparing
X = anObject
X ^self OrderedCollection.= anObject
Xor more efficiently, since OrderedCollection is on OrderedCollectionModel's dynamic
Xinheritance chain:
X = anObject
X ^super = anObject
Xor even more efficiently since "= anObject ^super = anObject" is a no-op,
X OrderedCollectionModel removeSelectorSimply: #=
X
XSimilarly for group b) I would have to implement methods looking like:
X OrderedCollectionModel methods for dependents access
X dependents
X ^self Model.dependents
X
XSimilarly for group c.
X
XThis manual definition is very tedious, and its hard to derive the intension from the code.
XFar neater would be to state that methods from OrderedCollection should override methods
Xfor Object and that methods from Model should override Object, which is what my extension
Xallows one to do:
X
X Class named: #OrderedCollectionModel
X superclasses: 'OrderedCollection Model '
X inheritanceAnnotation: 'OrderedCollection overrides: Object, Model overrides: Object'
X instanceVariableNames: ''
X classVariableNames: ''
X category: 'Examples-MultipleInheritance'
X
XIn this scheme, if A overrides B then each method that is a conflicting inherited method inherited from only A and B (possibly indirectly) and no others, will be reimplemented to
Xinvoke the method inherited from A. Conflicts involving more than two methods will not
Xbe resolved. A overrides B implies A class overrides B class., hence in the above example
Xthere is no need to state that OrderedCollection class overrides Object class.
X
XI an terribly ignorant of other systems supporting multiple inheritance and too lazy to
Xread up on them all. I am sure I have reinvented the wheel. I would be interested to
Xhear about similar schemes from people who know about other systems. That said, I hope
Xthe following will be useful to people using Smalltalk-80 multiple inheritance.
X
XThe implementation of "inheritance annotations" is flexible and should support other modifiers
Xthan 'overrides:'. Look at Class>inheritanceAnnotation: for how this works. Care is taken
Xto avoid filing out selectors that have been overriden, and to remember overriden selectors
Xthat have been removed. This allows the implementation to remove conflict methods that are overriden by a class on the dynamic inheritance chain.
X
X
XFiling In:
XFirst carefully file in the fixes. If you are using ParcPlace 2.3 you will have to rewrite methods that use block temporaries and string Symbol literals (2.3.2t supports block temps & 2.5-style symbol literals). Then file in MIAnnotations.changes. To assure yourself that the system works file in OrderedCollectionModel.st. You should observe that
X a) OrderedCollectionModel implements
X ('dependents access' addDependent: dependents removeDependent:)
X ('updating' broadcast: broadcast:with:)
X ('copying' copy)
X ('changing' changed:with: changeRequest changeRequest: changeRequestFrom:)
X ('private' breakDependents)
X all of which are of the form
X copy
X ^self model.copy
X
X b) OrderedCollectionModel's overridenSelectorSet is:
X OrderedCollectionModel overridenSelectorSet associations asSortedCollection
X =->remove
X addDependent:->add
X at:->remove
X at:put:->remove
X breakDependents->add
X broadcast:->add
X broadcast:with:->add
X changed:with:->add
X changeRequest->add
X changeRequest:->add
X changeRequestFrom:->add
X copy->add
X dependents->add
X diagramFigureClass->remove
X hash->remove
X inspect->remove
X printOn:->remove
X removeDependent:->add
X shallowCopy->remove
X size->remove
X storeOn:->remove
X
X c) OrderedCollectionModel class's overridenSelectorSet is:
X OrderedCollectionModel class overridenSelectorSet
X IdentityDictionary (new:->remove new->remove )
X
X d) Filing out OrderedCollectionModel produces (apart from differences in the header)
X precisely the following (& no removeSelector doits)
X 'From BrouHaHa Smalltalk-80, Version 2.3.2t of 27 February 1990 on 22 March 1991 7:33:25 pm'!
X
X Class named: #OrderedCollectionModel
X superclasses: 'OrderedCollection Model '
X inheritanceAnnotation: 'OrderedCollection overrides: Object, Model overrides: Object'
X instanceVariableNames: ''
X classVariableNames: ''
X category: 'Examples-MultipleInheritance'!
X
X
XSince this code is essentially a derivative work from Smalltalk-80 Version 2.0 I cannot
Xpublish it under the GPL. Consequently I submit this code to the net for any purpose
Xwhat-so-ever (but try not to waste trees!).
X
XRemember to post comp.lang.smalltalk and/or comp.object about multiple inheritance
Xconflict resolution schemes you know about!
X
XShare and Enjoy.
X
XEliot Miranda email: eliot@cs.qmw.ac.uk
XDept of Computer Science Tel: 071 975 5229 (+44 71 975 5229)
XQueen Mary Westfield College ARPA: eliot%cs.qmw.ac.uk@nsf.ac.uk
XMile End Road UUCP: eliot@qmw-cs.uucp
XLONDON E1 4NS
SHAR_EOF
chmod 0644 README || echo "restore of README fails"
set `wc -c README`;Sum=$1
if test "$Sum" != "8221"
then echo original size 8221, current size $Sum;fi
echo "x - extracting MIKernel.fixes (Text)"
sed 's/^X//' << 'SHAR_EOF' > MIKernel.fixes &&
X!Behavior methodsFor: 'private'!
X
XconflictCodeFor: sel
X "return some code that indicates a conflicting definition.
X Conflicts could be between classes not on the dynamic inheritance path
X so handle non-implementedness."
X | descr code |
X descr _ self dynamicMethodDescriptionAt: sel.
X descr isMethodNotImplemented
X ifTrue: [
X | stream numArgs keywords |
X stream _ WriteStream on: (String new: 16).
X stream nextPutAll: sel.
X (numArgs _ sel numArgs) > 0 ifTrue: [
X keywords _ sel keywords.
X 1 to: keywords size do: [:n|
X stream
X nextPutAll: (keywords at: n);
X nextPutAll: ' t';
X print: n]].
X code _ stream contents]
X ifFalse: [
X | parser |
X code _ descr sourceCode.
X (parser _ self parserClass new) parseSelector: code.
X code _ code copyFrom: 1 to: (parser endOfLastToken min: code size)].
X ^code, (String with: Character cr), ' ^self conflictingInheritanceError'! !
X
X!Behavior methodsFor: 'printing'!
X
XprintHierarchy
X "Answer a description containing the names and instance variable
X names of all of the subclasses and superclasses of the receiver."
X
X | aStream index supers |
X index _ 0.
X aStream _ WriteStream on: (String new: 16).
X self allDynamicSuperclasses reverseDo: [:aClass |
X aStream crtab: index.
X index _ index + 1.
X aStream nextPutAll: aClass name.
X aStream space.
X aStream print: aClass instVarNames.
X supers _ aClass superclasses.
X supers size > 1 ifTrue: [
X | instVars |
X instVars _ aClass superclass allInstVarNames.
X aStream nextPutAll: ' [also'.
X (supers copyFrom: 2 to: supers size) do: [:s |
X aStream space; nextPutAll: s name; nextPutAll: ' ('.
X s allInstVarNames do: [:n|
X (instVars includes: n) ifFalse: [aStream print: n; space]].
X aStream nextPut: $)].
X aStream nextPut: $] ]].
X aStream cr.
X self printSubclassesOn: aStream callingSuperclass: self dynamicSuperclass level: index.
X ^aStream contents! !
X
X!Behavior methodsFor: 'creating method dictionary'!
X
XremoveSelectorUnchecked: selector
X "Assuming that the message selector is in the receiver's method dictionary,
X remove it. If the selector is not in the method dictionary, DON'T create an
X error, since the multiple inheritance implementation takes advantage of this.
X Do not check for effect on (multiple) inheritance."
X
X methodDict removeKey: selector ifAbsent: [].
X self flushCacheEntries: selector! !
X
X!Behavior methodsFor: 'compiling'!
X
XcompileBroadcastCodeFor: selector
X "compile code that invokes ALL methods for 'selector' in my inheritance hierarchy"
X | implementors strm keywords argNames |
X implementors _ self allSuperclasses select:
X [:each | each includesSelector: selector].
X argNames _ Array new: selector numArgs.
X 1 to: argNames size do: [:i | argNames at: i put: 'arg' , i printString].
X strm _ WriteStream on: (String new: 500).
X strm nextPutAll: 'all.'.
X argNames size=0
X ifTrue: [strm nextPutAll: selector]
X ifFalse: [keywords _ selector keywords.
X 1 to: argNames size do:
X [:i | strm nextPutAll: (keywords at: i); space;
X nextPutAll: (argNames at: i); space]].
X implementors do:
X [:each | strm cr; tab; nextPutAll: 'self '; nextPutAll: each name; nextPut: $. .
X argNames size=0
X ifTrue: [strm nextPutAll: selector]
X ifFalse: [keywords _ selector keywords.
X 1 to: argNames size do:
X [:i | strm nextPutAll: (keywords at: i); space;
X nextPutAll: (argNames at: i); space]].
X strm nextPut: $.].
X self compileUnchecked: strm contents! !
X
X!Behavior methodsFor: 'creating method dictionary'!
X
XremoveSelector: selector
X "Assuming that the message selector is in the receiver's method dictionary,
X remove it. If the selector is not in the method dictionary, create an error
X notification. Also check for conflicts due to multiple inheritance."
X
X methodDict removeKey: selector.
X self flushCacheEntries: selector.
X self checkChangeSelector: selector.
X (self checkMethodFor: selector) ifFalse: [
X Transcript cr; show: 'conflicting methods for ' , selector, ' in ', self name]! !
X
X!Behavior methodsFor: 'private'!
X
XprintSubclassesOn: aStream callingSuperclass: whichSuper level: level
X "As part of the algorithm for printing a description of the receiver, print the
X subclass on the file stream, aStream, indenting level times."
X | subs supers |
X aStream crtab: level.
X aStream nextPutAll: self name.
X aStream space; print: self instVarNames.
X supers _ self superclasses.
X supers size > 1 ifTrue: [
X | instVars |
X instVars _ superclass allInstVarNames.
X aStream nextPutAll: ' [also'.
X (supers copyWithout: whichSuper) do: [:s |
X aStream space; nextPutAll: s name; nextPutAll: ' ('.
X s allInstVarNames do: [:n|
X (instVars includes: n) ifFalse: [
X aStream print: n; space.
X instVars addLast: n]].
X aStream nextPut: $)].
X aStream nextPut: $] ].
X subs _ self subclasses.
X self == Class ifTrue:
X [aStream crtab: level+1; nextPutAll: '... all the Metaclasses ...'.
X subs _ subs reject: [:sub | sub isMeta]].
X "Print subclasses in alphabetical order"
X (subs asSortedCollection: [:x :y | x name < y name]) do:
X [:sub |
X sub printSubclassesOn: aStream callingSuperclass: self level: level + 1]! !
X
X!Metaclass methodsFor: 'class hierarchy'!
X
Xname: newName inEnvironment: environ subclassOf: sup and: others instanceVariableNames: instVarString variable: v words: w pointers: p classVariableNames: classVarString poolDictionaries: poolString category: categoryName comment: commentString changed: changed
X "Create a new metaclass from the information provided in the arguments.
X Create an error if the name does not begin with an uppercase letter or if a
X class of the same name already exists."
X
X | wasPresent oldClass newClass invalidFields invalidMethods |
X newName first isUppercase ifFalse: [
X self error: 'Class names must be capitalized'.
X ^false].
X (wasPresent _ environ includesKey: newName)
X ifTrue: [
X oldClass _ environ at: newName.
X (oldClass isKindOf: Behavior)
X ifTrue: [newClass _ self newNamed: newName otherSupers: others]
X ifFalse: [
X self error: newName , ' already exists, and is not a class!! Proceed will store over it'.
X wasPresent _ false.
X oldClass _ self newNamed: newName otherSupers: others.
X newClass _ oldClass copy]]
X ifFalse: [
X oldClass _ self newNamed: newName otherSupers: others.
X newClass _ oldClass copy].
X invalidFields _
X changed | (newClass
X subclassOf: sup
X oldClass: oldClass
X instanceVariableNames: instVarString
X variable: v
X words: w
X pointers: p
X ifBad: [^false]).
X newClass class setOtherSuperclasses: others.
X invalidFields ifFalse: [newClass obsolete. newClass _ oldClass].
X invalidMethods _ invalidFields | (newClass declare: classVarString) | (newClass sharing: poolString).
X commentString == nil ifFalse: [newClass comment: commentString].
X (environ includesKey: newName)
X ifFalse:
X [environ declare: newName from: Undeclared.
X environ at: newName put: newClass].
X SystemOrganization classify: newClass name under: categoryName asSymbol.
X "Check for possible conflicting method definitions in superclasses"
X invalidFields ifTrue:
X [newClass copyMethods.
X newClass class copyMethods].
X (((SelectorsOfConflictMethods at: #instVarAt:put: ifAbsent: [#()]),
X (SelectorsOfConflictMethods at: #basicAt:put: ifAbsent: [#()]),
X (SelectorsOfConflictMethods at: #become: ifAbsent: [#()])
X includes: newClass)
X and: [oldClass instanceCount > 0])
X ifTrue: [self notify:
X'Some of the class ', newName, '''s instVarAt:put:, basicAt:put:
Xand become: methods have conflicting inherited definitions.
XCannot update instances from old to new definition'].
X "Update instances to new class & copy methods to new class"
X newClass
X validateFrom: oldClass
X in: environ
X instanceVariableNames: invalidFields
X methods: invalidMethods.
X "update subclass lists"
X newClass superclassesDo: [:superClass |
X superClass removeSubclass: oldClass; addSubclass: newClass].
X "Update Changes"
X wasPresent
X ifTrue: [Smalltalk changes changeClass: newClass]
X ifFalse: [Smalltalk changes addClass: newClass].
X ^newClass! !
X
X
X!MetaclassForMultipleInheritance methodsFor: 'class hierarchy'!
X
XhasMultipleSuperclasses
X ^true! !SHAR_EOF
chmod 0644 MIKernel.fixes || echo "restore of MIKernel.fixes fails"
set `wc -c MIKernel.fixes`;Sum=$1
if test "$Sum" != "8160"
then echo original size 8160, current size $Sum;fi
echo "x - extracting MISupport.fixes (Text)"
sed 's/^X//' << 'SHAR_EOF' > MISupport.fixes &&
X!Symbol methodsFor: 'system primitives'!
X
XisInfix
X "Answer whether the receiver is an infix message selector."
X
X ^(self at: 1) isLetter not or: [self isCompound and: [self selectorPart isInfix]]! !
X
X!ChangeScanner methodsFor: 'expression scanning'!
X
XscanClassExpression: class do: aBlock
X "Scan an expression beginning with a class name. This might be a class
X definition, a class removal, a class comment change, a class initialization,
X a method removal, or a doIt."
X
X | firstToken selector newName |
X firstToken _ token.
X self scanToken.
X firstToken = 'removeSelector:'
X ifTrue:
X [(tokenType == #literal and: [token isKindOf: Symbol]) ifTrue:
X [selector _ token.
X self scanToken.
X ^aBlock value: (MethodOtherChange new className: class; selector: selector; type: #remove)]].
X firstToken = 'rename:'
X ifTrue:
X [(tokenType == #literal and: [token isKindOf: Symbol]) ifTrue:
X [newName _ token.
X self scanToken.
X aBlock value: (ClassOtherChange new className: class; type: #rename).
X ^aBlock value: (ClassOtherChange new className: newName; type: 'rename to' asSymbol)]].
X firstToken = 'comment:'
X ifTrue:
X [tokenType == #string
X ifTrue:
X [self scanToken.
X ^aBlock value: (ClassCommentChange new className: class)]].
X (#('subclass:' 'variableSubclass:' 'variableByteSubclass:' 'variableWordSubclass:' 'immediateSubclass:') includes: firstToken)
X ifTrue:
X [^self scanClassDefinition: firstToken className: class do: aBlock].
X firstToken = 'named:'
X ifTrue:
X [^self scanMultipleInheritanceClassDefinition: firstToken className: class do: aBlock].
X firstToken = 'initialize'
X ifTrue:
X [^aBlock value: (ClassOtherChange new className: class; type: #initialize)].
X firstToken = 'removeFromSystem'
X ifTrue:
X [^aBlock value: (ClassOtherChange new className: class; type: #remove)].
X firstToken = 'instanceVariableNames:'
X ifTrue:
X [tokenType == #string
X ifTrue:
X [self scanToken.
X ^aBlock value: (ClassOtherChange new className: class; type: 'inst vars for' asSymbol)]].
X ^nil!
X
XscanMultipleInheritanceClassDefinition: classType className: definingClassName do: aBlock
X "Scan a presumed multiple inheritance class definition."
X | newName superclasses parameters |
X (tokenType == #literal and: [token isKindOf: Symbol]) ifFalse: [^nil].
X newName _ token.
X parameters _ #('superclasses:' 'instanceVariableNames:' 'classVariableNames:' 'category:') collect:
X [:keyword |
X self scanToken.
X (tokenType == #keyword and: [token = keyword]) ifFalse: [^nil].
X self scanToken.
X tokenType == #string ifFalse: [^nil].
X token].
X self scanToken.
X ^aBlock value: (ClassDefinitionChange new className: newName;
X superclassName: (parameters first copyUpTo: Character space)
X classType: classType
X otherParameters: parameters)! !
X
X!MethodDescription methodsFor: 'accessing'!
X
XsourceCode
X "Change all occurances of the pseudovariable 'super' so that
X the new context is accounted for"
X
X | outStream prev pos code myClass newCode |
X code _ whichClass sourceCodeAt: selector.
X prev _ 1.
X outStream _ WriteStream on: (String new: code size).
X myClass _ whichClass isMeta
X ifTrue: [whichClass soleInstance]
X ifFalse: [whichClass].
X myClass superclass isNil ifTrue: [^code].
X newCode _ self
X replace: 'super'
X with: [:char | 'self ' , myClass superclass name , '.']
X in: code
X before: [:char | char isSeparator].
X newCode _ self
X replace: 'super.'
X with: [:char | myClass name , '.super.' , (Array with: char)]
X in: newCode
X before: [:char | char tokenish].
X newCode _ self
X replace: 'all.'
X with: [:char | myClass name , '.all.' , (Array with: char)]
X in: newCode
X before: [:char | char tokenish].
X ^newCode! !
X
X!MethodDescription methodsFor: 'private'!
X
Xreplace: string with: replBlock in: code before: aBlock
X | outStream prev pos |
X prev _ 1.
X outStream _ WriteStream on: (String new: code size).
X
X [pos _ code findString: string startingAt: prev.
X pos > 0]
X whileTrue:
X [prev to: pos - 1 do: [:index | outStream nextPut: (code at: index)].
X ((pos = 1 or: [(code at: pos - 1) tokenish not])
X & (pos + string size <= code size) and: [aBlock value: (code at: pos + string size)])
X ifTrue:
X [outStream nextPutAll: (replBlock value: (code at: pos + string size)).
X prev _ pos + string size + 1]
X ifFalse:
X [outStream nextPutAll: string.
X prev _ pos + string size]].
X prev to: code size do: [:index | outStream nextPut: (code at: index)].
X ^outStream contents! !
X
X!ChangeSet class methodsFor: 'fileIn/Out'!
X
XsuperclassOrder: classes
X "Arrange the classes in the collection, classes, in superclass
X order so the classes can be properly filed in. Class A must
X come before class B if A is a superclass of B, or if B is A's
X metaclass. "
X "Changed this to handle multiple inheritence -- Bill"
X
X | order left |
X left _ IdentitySet new.
X left addAll: classes.
X order _ OrderedCollection new.
X [left isEmpty]
X whileFalse: [left do: [:c | ((c superclasses detect: [:aSuperclass | left includes: aSuperclass]
X ifNone: []) notNil or: [(c isKindOf: Metaclass)
X and: [left includes: c soleInstance]])
X ifFalse:
X [order addLast: c.
X left remove: c]]].
X ^order! !
X
SHAR_EOF
chmod 0644 MISupport.fixes || echo "restore of MISupport.fixes fails"
set `wc -c MISupport.fixes`;Sum=$1
if test "$Sum" != "5223"
then echo original size 5223, current size $Sum;fi
echo "x - extracting MIAnnotation.changes (Text)"
sed 's/^X//' << 'SHAR_EOF' > MIAnnotation.changes &&
X'From BrouHaHa Smalltalk-80, Version 2.3.2t of 27 February 1990 on 22 March 1991 7:37:46 pm'!
X
X
X
X!Browser methodsFor: 'class list'!
X
XclassMenu
X "Browser flushMenus"
X
X className == nil ifTrue: [^nil].
X ClassMenu == nil ifTrue: [
X ClassMenu _ ActionMenu
X labels:
X'file out\print out\print out interface\spawn\spawn hierarchy
Xhierarchy\definition\comment\protocols\interface
Xinst var refs\inst var assigns\class var refs\class refs
Xsubclass responsibilities\conflicting inherited methods\find method
Xrename\remove' withCRs
X lines: #(5 10 14 17)
X selectors: #(fileOutClass printOutClass printOutClassInterface spawnClass spawnHierarchy
XshowHierarchy editClass editComment editProtocols showInterface
XbrowseFieldReferences browseFieldAssignments browseClassVariables browseClassReferences
XbrowseSubclassResponsibilities browseConflictingInheritedMethods findMethodAndSelectAlphabetic
XrenameClass removeClass )].
X ^ClassMenu! !
X
X!Browser methodsFor: 'class functions'!
X
XbrowseConflictingInheritedMethods
X "Browse methods defined in superclasses which are conflicting inherited
X methods of the selected class"
X
X BrowserView
X openListBrowserOn:
X ((self selectedClass conflictingInheritedMethods
X collect: [:ea | ea listBrowserString]) asSortedCollection: [:s1 :s2|
X (s1 copyFrom: (s1 lastIndexOf: Character space ifAbsent: [1]) to: s1 size) <= (s1 copyFrom: (s1 lastIndexOf: Character space ifAbsent: [1]) to: s1 size)])
X label: 'Conflicting Inherited Methods For ' ,
X self selectedClass name
X initialSelection: nil! !
X
X
X!SequenceableCollection methodsFor: 'accessing'!
X
XlastIndexOf: anElement ifAbsent: exceptionBlock
X "Answer the last index of anElement within the receiver.
X If the receiver does not contain anElement, answer the result
X of evaluating the exceptionBlock."
X
X | i |
X i _ self size.
X [(self at: i) = anElement ifTrue: [^i].
X (i _ i - 1) > 0] whileTrue.
X ^exceptionBlock value! !
X
X
X!Behavior methodsFor: 'accessing method dictionary'!
X
XconflictingInheritedMethods
X "Return a set of MethodDescriptions for all my conflictingInheritedMethods"
X | superclasses conflicts |
X superclasses _ self superclasses.
X conflicts _ Set new.
X self selectors do: [:selector|
X ((SelectorsOfConflictMethods at: selector ifAbsent: [#()])
X includes: self) ifTrue: [
X superclasses do: [:sclass|
X (sclass canUnderstand: selector) ifTrue: [
X conflicts add: (sclass methodDescriptionAt: selector)]]]].
X ^conflicts! !
XMetaclass subclass: #MetaclassForMultipleInheritance
X instanceVariableNames: 'otherSuperclasses inheritanceAnnotation overridenSelectorSets '
X classVariableNames: ''
X poolDictionaries: ''
X category: 'Kernel-Classes'!
X
XMetaclassForMultipleInheritance comment:
X'This metaclass has an additional field and protocol to support multiple inheritance.
XThe field, otherSupers, contains a collection of additional superclasses (other than the normal dynamic one) from which traits are to be inherited. Since the otherSupers appears in the metaclass, classes must ask their metas for other supers (sort of the way metas ask their thisClasses for subs).
X
XIt would have been more natural to put otherSupers into a class ClassWithMultSupers, but this would have had to inherit both the multiple supers AND the normal metaclass
Xinheritance, thus posing a bootstrapping need for multiple inheritance.
X
XThe field inheritanceAnnotation is a string of comma-separated inheritance modifications, currently only the overrides: modifier is implemented. See ClassDescription inheritanceAnnotation: and ClassDescription inheritance:overrides:.
X
XThe field overridenSelectorSets records the status of overriden selectors for thisClass and the receiver.'!
X
X!MetaclassForMultipleInheritance reorganize!
X('class hierarchy' hasMultipleSuperclasses instHasMultipleSuperclasses otherSuperclasses setOtherSuperclasses: superclasses)
X('enumerating' superclassesDo:)
X('inheritance annotation' inheritanceAnnotation inheritanceAnnotationString:)
X('overriden selectors' instanceOverridenSelectorSet isOverriden: isOverridenInInstance: isRemovedOverriden: isRemovedOverridenInInstance: overridenSelectorSet overridenSelectorSets)
X!
X
X
X
X!MetaclassForMultipleInheritance methodsFor: 'inheritance annotation'!
X
XinheritanceAnnotation
X "Return the string specifying my inheritance annotation
X or nil if none exists"
X ^inheritanceAnnotation!
X
XinheritanceAnnotationString: aString
X "Set the string specifying my inheritance annotation."
X inheritanceAnnotation _ aString copy! !
X
X!MetaclassForMultipleInheritance methodsFor: 'overriden selectors'!
X
XinstanceOverridenSelectorSet
X "Return my instance's overriden selector set"
X ^self overridenSelectorSets at: 1!
X
XisOverriden: selector
X "Answer whether selector is overriden in the receiver"
X ^overridenSelectorSets notNil
X and: [(self overridenSelectorSet at: selector ifAbsent: [^false]) ~~ #change]!
X
XisOverridenInInstance: selector
X "Answer whether selector is overriden in the receiver's instance"
X ^overridenSelectorSets notNil
X and: [(self instanceOverridenSelectorSet at: selector ifAbsent: [^false]) ~~ #change]!
X
XisRemovedOverriden: selector
X "Answer whether selector is overriden and removed in the receiver"
X ^overridenSelectorSets notNil
X and: [(self overridenSelectorSet at: selector ifAbsent: [^false]) == #remove]!
X
XisRemovedOverridenInInstance: selector
X "Answer whether selector is overriden and has been removed in the receiver's instance"
X ^overridenSelectorSets notNil
X and: [(self instanceOverridenSelectorSet at: selector ifAbsent: [^false]) == #remove]!
X
XoverridenSelectorSet
X "Return my overriden selector set"
X ^self overridenSelectorSets at: 2!
X
XoverridenSelectorSets
X "Return my overriden selector sets"
X overridenSelectorSets isNil ifTrue: [
X overridenSelectorSets _ Array
X with: IdentityDictionary new
X with: IdentityDictionary new].
X ^overridenSelectorSets! !
X
X
X!ChangeScanner methodsFor: 'expression scanning'!
X
XscanMultipleInheritanceClassDefinition: classType className: definingClassName do: aBlock
X "Scan a presumed multiple inheritance class definition."
X | newName superclasses keywords parameters parameter |
X (tokenType == #literal and: [token isKindOf: Symbol]) ifFalse: [^nil].
X newName _ token.
X keywords _ #('superclasses:' 'inheritanceAnnotation:' 'instanceVariableNames:' 'classVariableNames:' 'category:') asOrderedCollection.
X parameters _ OrderedCollection new.
X [keywords isEmpty] whileFalse: [
X self scanToken.
X (tokenType == #keyword and: [keywords includes: token]) ifFalse: [^nil].
X [keywords isEmpty or: [keywords removeFirst = token]] whileFalse.
X parameter _ token.
X self scanToken.
X tokenType == #string ifFalse: [^nil].
X parameters addLast: parameter, ' ', token printString].
X self scanToken.
X ^aBlock value: (ClassDefinitionChange new className: newName;
X superclassName: (parameters first copyUpTo: Character space)
X classType: classType
X otherParameters: parameters)! !
X
X
X!MethodDescription methodsFor: 'printing'!
X
XlistBrowserString
X "Return a string defining the receiver in the format expected by a list browser"
X ^whichClass name, ' ', selector! !
X
X!ClassDescription reorganize!
X('initialize-release' obsolete subclassOf:oldClass:instanceVariableNames:variable:words:pointers:ifBad: updateInstancesFrom: validateFrom:in:instanceVariableNames:methods:)
X('accessing' comment comment: commentTemplate name)
X('copying' copy:from: copy:from:classified: copyAll:from: copyAll:from:classified: copyAllCategoriesFrom: copyCategory:from: copyCategory:from:classified:)
X('testing' isClassDescription isMeta)
X('printing' basicPrintOn: classVariablesString definition instanceVariablesString printOn: sharedPoolsString storeOn: superclassesString)
X('instance variables' addInstVarName: instVarNames removeInstVarName:)
X('method dictionary' checkChangeSelector: removeCategory: removeSelector:)
X('organization' category category: logOrganizationChange organization reorganize selectorsInCategory: whichCategoryIncludesSelector:)
X('compiling' compile:classified: compile:classified:notifying: compile:notifying:remoteString:ifFail: compileAllFrom:)
X('fileIn/Out' fileOutCategory: fileOutCategory:on:moveSource:toFile: fileOutChangedMessages:on: fileOutChangedMessages:on:moveSource:toFile: fileOutMessage: fileOutMessage:fileName: fileOutMessage:on:moveSource:toFile: fileOutOn: fileOutOn:moveSource:toFile: fileOutOrganizationOn: kindOfSubclass methodsFor: moveChangesTo: printCategoryChunk:on: printMethodChunk:on:moveSource:toFile: printOutCategory: printOutCategory:on: printOutCategoryInterface:on: printOutInterfaceOn: printOutMessage: printOutOn:)
X('private' errorCategoryName)
X('binary storage' binaryDefinitionFrom:manager: preBinaryStorage removeHiddenMethods storeBinaryClassDefinitionOn:manager:)
X('inheritance annotation' conflictResolutionSelectorsFor:overriding: inheritanceAnnotation inheritanceAnnotation:overrides:)
X('overriden selectors' addOverridenSelector: changeOverridenSelector: isOverriden: isRemovedOverriden: overridenSelectorSet removeOverridenSelector:)
X!
X
X
X
X!ClassDescription methodsFor: 'printing'!
X
Xdefinition
X "Answer a string that defines the receiver."
X | aStream |
X aStream _ WriteStream on: (String new: 300).
X self hasMultipleSuperclasses
X ifTrue:
X [aStream nextPutAll: 'Class named: '.
X self name storeOn: aStream.
X aStream cr; tab; nextPutAll: 'superclasses: '.
X self superclassesString printOn: aStream.
X self inheritanceAnnotation notNil ifTrue: [
X aStream cr; tab; nextPutAll: 'inheritanceAnnotation: '.
X self inheritanceAnnotation printOn: aStream].
X aStream cr; tab; nextPutAll: 'instanceVariableNames: '.
X self instanceVariablesString printOn: aStream.
X aStream cr; tab; nextPutAll: 'classVariableNames: '.
X self classVariablesString printOn: aStream]
X ifFalse:
X [aStream nextPutAll: (superclass == nil ifTrue: ['nil'] ifFalse: [superclass name]).
X aStream nextPutAll: self kindOfSubclass.
X self name storeOn: aStream.
X aStream cr; tab; nextPutAll: 'instanceVariableNames: '.
X self instanceVariablesString printOn: aStream.
X aStream cr; tab; nextPutAll: 'classVariableNames: '.
X self classVariablesString printOn: aStream.
X aStream cr; tab; nextPutAll: 'poolDictionaries: '.
X self sharedPoolsString printOn: aStream].
X aStream cr; tab; nextPutAll: 'category: '.
X (SystemOrganization categoryOfElement: self name) asString printOn: aStream.
X ^aStream contents! !
X
X!ClassDescription methodsFor: 'method dictionary'!
X
XcheckChangeSelector: selector
X "In addition to Behavior's checking we should check for the
X selector being in the override set"
X (self isOverriden: selector) ifTrue: [
X (methodDict includesKey: selector)
X ifTrue: [self changeOverridenSelector: selector]
X ifFalse: [self removeOverridenSelector: selector]].
X super checkChangeSelector: selector.
X ((SelectorsOfCopiedMethods at: selector ifAbsent: [#()]) includes: self)
X ifTrue: [
X self organization classify: selector under: #'conflicting inherited methods']!
X
XremoveSelector: aSymbol
X "Remove the message whose selector is aSymbol from the method
X dictionary of the receiver, if it is there. Answer nil otherwise."
X
X (methodDict includesKey: aSymbol) ifFalse: [^nil].
X (self isOverriden: aSymbol)
X ifTrue: [
X self removeOverridenSelector: aSymbol.
X super removeSelectorSimply: aSymbol]
X ifFalse: [super removeSelector: aSymbol].
X self organization removeElement: aSymbol.
X Smalltalk changes removeSelector: aSymbol class: self.
X Smalltalk logChange: self name , ' removeSelector: #' , aSymbol! !
X
X!ClassDescription methodsFor: 'compiling'!
X
XcompileAllFrom: oldClass
X "Compile all the methods in oldClass's method dictionary. Gracefully
X cope with methods which are defined in oldClass but not in the
X receiver. This situation may arise when validating a multiple inheriting
X class with conflicting methods. See recompile:from: regarding oldClass,
X which is normally just self."
X
X oldClass selectors do: [:sel | | category |
X (sel isCompound
X or: [(SelectorsOfCopiedMethods at: sel ifAbsent: [#()]) includes: oldClass])
X ifFalse: [
X self recompile: sel from: oldClass.
X category _ oldClass organization categoryOfElement: sel.
X self organization
X classify: sel
X under: (category notNil
X ifTrue: [category]
X ifFalse: [ClassOrganizer defaultProtocol])]]! !
X
X!ClassDescription methodsFor: 'fileIn/Out'!
X
XfileOutCategory: aString on: aFileStream moveSource: moveSource toFile: fileIndex
X "File a description of the receiver's category, aString, onto aFileStream. If
X the boolean argument, moveSource, is true, then set the trailing bytes to the position
X of aFileStream and to fileIndex in order to indicate where to find the source code."
X
X | selectors |
X selectors _ (self organization listAtCategoryNamed: aString) reject: [:selector |
X self isOverriden: selector].
X selectors isEmpty ifFalse: [
X self printCategoryChunk: aString on: aFileStream.
X selectors do: [:sel |
X self
X printMethodChunk: sel
X on: aFileStream
X moveSource: moveSource
X toFile: fileIndex].
X aFileStream nextChunkPut: ' ']!
X
XfileOutOn: aFileStream moveSource: moveSource toFile: fileIndex
X "file me out on aFileStream"
X aFileStream emphasis: 5. "Meant to be 12 point bold font."
X aFileStream nextChunkPut: self definition.
X self organization
X putCommentOnFile: aFileStream
X numbered: fileIndex
X moveSource: moveSource.
X aFileStream cr.
X self organization categories do: [:heading |
X self
X fileOutCategory: heading
X on: aFileStream
X moveSource: moveSource
X toFile: fileIndex].
X self overridenSelectorSet isNil ifFalse: [
X | dynamicSuperclasses |
X dynamicSuperclasses _ self allDynamicSuperclasses.
X self overridenSelectorSet keysDo: [:selector|
X "Must explicitly add removeSelector: doits for removed conflict selectors
X so they will be removed on file-in"
X ((self isRemovedOverriden: selector)
X "The implementation automatically elides overrides taken from the dynamic
X inheritance chain so we should avoid removing these."
X and: [(dynamicSuperclasses includes: (self whichClassIncludesSelector: selector)) not]) ifTrue: [
X aFileStream cr; nextChunkPut: self name, ' removeSelector: ', selector]]]! !
X
X!ClassDescription methodsFor: 'inheritance annotation'!
X
XconflictResolutionSelectorsFor: classA overriding: classB
X "Return those selectors that would resolve conflicts if methods in classA were to override methods in classB"
X
X | superclassSet overridingClassSet |
X (classA inheritsFrom: classB) ifFalse: [
X self notify: classA printString, ' can''t override ', classB printString, ' because ', classA printString, ' does not inherit from ', classB printString].
X
X (self inheritsFrom: classA) ifFalse: [
X self notify: classA printString, ' is not one of my superclasses'].
X (self inheritsFrom: classB) ifFalse: [
X self notify: classB printString, ' is not one of my superclasses'].
X
X "The overriding class set comprises classA and all its
X superclasses upto but not including classB, since it is
X all the messages implemented by classA and its superclasses
X upto but not including classB that may override classB"
X overridingClassSet _ classA withAllSuperclasses.
X overridingClassSet removeAll: classB withAllSuperclasses.
X superclassSet _ self superclasses asSet.
X
X "The set of selectors to override are those selectors
X that are conflicting inherited methods of the receiver
X iff they are
X understood by classA and understood by classB
X and implemented by classA or a superclass of classA that
X is a subclass of classB, and understood by no other
X superclasses of the receiver."
X
X ^self selectors select: [:selector| | implementors |
X (self methodDescriptionAt: selector) isConflictingMethods
X and: [implementors _ (superclassSet select: [:sclass| sclass canUnderstand: selector])
X collect: [:sclass| sclass whichClassIncludesSelector: selector].
X implementors size = 2
X and: [(implementors
X detect: [:implementor|
X overridingClassSet includes: implementor]
X ifNone: []) ~~ nil
X and: [(implementors
X detect: [:implementor|
X implementor == classB
X or: [classB inheritsFrom: implementor]]
X ifNone: []) ~~ nil]]]]!
X
XinheritanceAnnotation
X "Inheritance annotations are only relevant to multiple inheritance.
X Return my annotation (stored in my metaclass) or nil if I don't have
X multiple superclasses."
X
X ^self hasMultipleSuperclasses ifTrue: [
X self class inheritanceAnnotation]!
X
XinheritanceAnnotation: classA overrides: classB
X "Inherit conflict methods between classA and classB from classA. Note that this also implies classA class overriding classB class."
X
X | useSuperSend |
X "Implement the overriding by compiling a method for each selector
X that uses either a compound selector to access the overriding method,
X or a super send if the method is on the dynamic inheritance chain."
X useSuperSend _ self allDynamicSuperclasses includes: classA.
X
X "The following ifTrue: code is used for efficiency reasons. Get rid of it if it
X offends too much."
X useSuperSend "and: [self desperateNotToWasteSpace :-)]"
X ifTrue: [
X (self conflictResolutionSelectorsFor: classA overriding: classB) do: [:sel|
X self addOverridenSelector: sel.
X self removeSelector: sel]]
X ifFalse: [
X (self conflictResolutionSelectorsFor: classA overriding: classB) do: [:sel|
X | code parser messagePattern |
X code _ (classA whichClassIncludesSelector: sel) sourceCodeAt: sel.
X (parser _ self parserClass new) parseSelector: code.
X messagePattern _ code copyFrom: 1 to: (parser endOfLastToken min: code size).
X code _ WriteStream on: (String new: 32).
X code nextPutAll: messagePattern; crtab.
X useSuperSend ifTrue: [code nextPut: $"].
X code nextPutAll: '^self '; nextPutAll: (classA isMeta
X ifTrue: [classA soleInstance]
X ifFalse: [classA]) name;
X nextPut: $.;
X nextPutAll: messagePattern.
X useSuperSend ifTrue: [
X code
X nextPut: $";
X crtab;
X nextPutAll: '^super ';
X nextPutAll: messagePattern].
X self compile: code contents
X classified: ((classA whichClassIncludesSelector: sel) organization categoryOfElement: sel).
X self addOverridenSelector: sel.
X Smalltalk changes removeSelectorChanges: sel class: self]].
X
X ((self organization categories includes: #'conflicting inherited methods')
X and: [(self organization listAtCategoryNamed: #'conflicting inherited methods') isEmpty]) ifTrue: [
X Transcript cr; show: self name, '''s conflicts have been fully resolved'.
X self organization removeCategory: #'conflicting inherited methods'].
X self isMeta ifFalse: [
X self class inheritanceAnnotation: classA class overrides: classB class]! !
X
X!ClassDescription methodsFor: 'overriden selectors'!
X
XaddOverridenSelector: selector
X "The selector has been added as an override; mark it as such in the overriden set"
X self overridenSelectorSet at: selector put: #add!
X
XchangeOverridenSelector: selector
X "The selector has been changed as an override; mark it as such in the overriden set"
X self overridenSelectorSet at: selector put: #change!
X
XisOverriden: selector
X "Answer whether the selector is overriden in the receiver"
X ^self hasMultipleSuperclasses
X and: [self class isOverridenInInstance: selector]!
X
XisRemovedOverriden: selector
X "Answer whether the selector is overriden and removed in the receiver"
X ^self hasMultipleSuperclasses
X and: [self class isRemovedOverridenInInstance: selector]!
X
XoverridenSelectorSet
X "If I have multiple superclasses I may also have an overriden selector set"
X ^self hasMultipleSuperclasses ifTrue: [
X self class instanceOverridenSelectorSet]!
X
XremoveOverridenSelector: selector
X "The selector has been removed as an override; mark it as such in the overriden set"
X self overridenSelectorSet at: selector put: #remove! !
X
X!Class reorganize!
X('initialize-release' declare: obsolete removeFromSystem sharing: superclass:methodDict:format:name:organization:instVarNames:classPool:sharedPools: validateFrom:in:instanceVariableNames:methods:)
X('accessing' classPool name smashName:)
X('accessing class hierarchy' hasMultipleSuperclasses isObsolete)
X('testing method dictionary' hasMethods)
X('copying' copy copyForValidation)
X('class name' rename:)
X('instance variables' addInstVarName: removeInstVarName:)
X('class variables' addClassVarName: allClassVarNames classVarNames initialize removeClassVarName:)
X('pool variables' addSharedPool: allSharedPools removeSharedPool: sharedPools)
X('compiling' compileAllFrom: poolHas:ifTrue:)
X('subclass creation' immediateSubclass:instanceVariableNames:classVariableNames:poolDictionaries:category: subclass:instanceVariableNames:classVariableNames:poolDictionaries:category: subclass:otherSupers:instanceVariableNames:classVariableNames:category: variableByteSubclass:instanceVariableNames:classVariableNames:poolDictionaries:category: variableSubclass:instanceVariableNames:classVariableNames:poolDictionaries:category: variableSubclass:otherSupers:instanceVariableNames:classVariableNames:category:
variableWordSubclass:instanceVariableNames:classVariableNames:poolDictionaries:category:)
X('fileIn/Out' fileOut fileOutOn:moveSource:toFile: printOut printOutInterfaceOn: printOutOn: removeFromChanges)
X('binary storage' addGlobalsTo: globallySharedVariableNames storeBinaryDefinitionOf:on:manager: storeHierarchyUpto:)
X('inheritance annotation' inheritanceAnnotation:)
X!
X
X
X
X!Class methodsFor: 'inheritance annotation'!
X
XinheritanceAnnotation: aString
X "aString is a comma-separated list of inheritance modifiers that specify
X changes to the default multiple inheritance. Currently, only the
X overrides: modifier is implemented. The overrides: modifier specifies that
X when inheriting methods that conflict, methods in the overriding class
X are to be inherited rather than those in the overriden class, thereby
X resolving the inheritance conflicts from the overriding and overriden
X class. e.g. if a class inherits from ClassA and ClassB and these classes
X have conflicting method definitions then the inheritance annotation
X 'ClassA overrides: ClassB'
X will cause the receiver to inherit those methods from ClassA which
X conflict with methods from ClassB, rather than have conflicting
X inherited methods"
X
X "The annotation scheme is implemented in an extensible way. Each
X comma-separated modifier should be a Smalltalk expression that will be
X prefixed by 'self inheritanceAnnotation: ', so that e.g. ClassA overrides:
X ClassB will result in the exectution of the message
X self inheritanceAnnotation: ClassA overrides: ClassB"
X
X | stream expr |
X self hasMultipleSuperclasses ifFalse: [
X ^self notify: 'only multiple inheritance classes have annotations'].
X aString isNil ifFalse: [
X stream _ aString readStream.
X [stream atEnd] whileFalse: [
X expr _ 'self inheritanceAnnotation: ' , (stream upTo: $,).
X Compiler evaluate: expr for: self logged: false]].
X self class inheritanceAnnotationString: aString! !
X
X
X!Class class methodsFor: 'instance creation'!
X
Xnamed: newClassName superclasses: newSuperNames inheritanceAnnotation: annotation instanceVariableNames: myInstVarNames classVariableNames: classVarNames category: cat
X | supers |
X "find the superclasses corresponding to the superclass names"
X supers _ self getSuperclasses: newSuperNames.
X supers size=1 ifTrue:
X [^(supers first "if there's only one superclass, just use old code"
X subclass: newClassName
X instanceVariableNames: myInstVarNames
X classVariableNames: classVarNames
X poolDictionaries: ''
X category: cat) inheritanceAnnotation: annotation].
X ^(supers first
X subclass: newClassName
X otherSupers: (supers copyFrom: 2 to: supers size)
X instanceVariableNames: myInstVarNames
X classVariableNames: classVarNames
X category: cat)
X inheritanceAnnotation: annotation! !
SHAR_EOF
chmod 0644 MIAnnotation.changes || echo "restore of MIAnnotation.changes fails"
set `wc -c MIAnnotation.changes`;Sum=$1
if test "$Sum" != "23753"
then echo original size 23753, current size $Sum;fi
echo "x - extracting OrderedCollectionModel.st (Text)"
sed 's/^X//' << 'SHAR_EOF' > OrderedCollectionModel.st &&
X'From BrouHaHa Smalltalk-80, Version 2.3.2t of 27 February 1990 on 22 March 1991 3:41:49 pm'!
X
XClass named: #OrderedCollectionModel
X superclasses: 'OrderedCollection Model '
X inheritanceAnnotation: 'OrderedCollection overrides: Object, Model overrides: Object'
X instanceVariableNames: ''
X classVariableNames: ''
X category: 'Examples-MultipleInheritance'!SHAR_EOF
chmod 0644 OrderedCollectionModel.st || echo "restore of OrderedCollectionModel.st fails"
set `wc -c OrderedCollectionModel.st`;Sum=$1
if test "$Sum" != "354"
then echo original size 354, current size $Sum;fi
exit 0
--
Eliot Miranda email: eliot@cs.qmw.ac.uk
Dept of Computer Science Tel: 071 975 5229 (+44 71 975 5229)
Queen Mary Westfield College ARPA: eliot%cs.qmw.ac.uk@nsf.ac.uk
Mile End Road UUCP: eliot@qmw-cs.uucp
LONDON E1 4NS