"
COPYRIGHT (c) 1988-93 by Claus Gittinger
All Rights Reserved
This software is furnished under a license and may be used
only in accordance with the terms of that license and with the
inclusion of the above copyright notice. This software may not
be provided or otherwise made available to, or used by, any
other person. No title to or ownership of the software is
hereby transferred.
"
Object subclass:#Behavior
instanceVariableNames:'superclass selectors methods
instSize flags'
classVariableNames:''
poolDictionaries:''
category:'Kernel-Classes'
!
Behavior comment:'
COPYRIGHT (c) 1988-93 by Claus Gittinger
All Rights Reserved
this class provides minimum support for all classes - additional stuff is
found in Class; Behaviors stuff has been extracted to make generation of
compact binaries possible.
(these do not need all of the functionality in Class)
Instance variables:
superclass <Class> the classes superclass
selectors <Array> the selectors for which inst-methods are defined here
methods <Array> the inst-methods corresponding to the selectors
instSize <SmallInteger> the number of instance variables
flags <SmallInteger> special flag bits coded in a number
NOTICE: layout known by compiler and runtime system; be careful when changing
$Header: /cvs/stx/stx/libbasic/Behavior.st,v 1.3 1993-10-13 00:14:49 claus Exp $
written Dec 88 by claus
'!
!Behavior class methodsFor:'queries'!
isBuiltInClass
"this class is known by the run-time-system"
^ true
! !
!Behavior class methodsFor:'creating new classes'!
new
"creates and return a new class"
|newClass|
newClass := self basicNew.
newClass setSuperclass:Object
selectors:(Array new:0)
methods:(Array new:0)
instSize:0
flags:0.
^ newClass
! !
!Behavior methodsFor:'initialization'!
initialize
"to catch initialize for classes which do not"
^ self
!
reinitialize
"to catch reinitialize for classes which do not"
^ self
! !
!Behavior methodsFor:'creating an instance of myself'!
uninitializedNew
"same as new - only redefined in ByteArray"
^ self basicNew
!
uninitializedNew:anInteger
"same as new:anInteger - only redefined in ByteArray"
^ self basicNew:anInteger
!
new
"return an instance of myself without indexed variables"
^ self basicNew
!
new:anInteger
"return an instance of myself with anInteger indexed variables"
^ self basicNew:anInteger
!
basicNew
"return an instance of myself without indexed variables
If the receiver-class has indexed instvars, the new object will have
a basicSize of zero.
** Do not redefine this method in any class **"
%{ /* NOCONTEXT */
extern char *newNextPtr, *newEndPtr;
OBJ newobj;
int instsize;
REGISTER int nInstVars;
#if !defined(memset4)
# if !defined(FAST_MEMSET) || defined(NEGATIVE_ADDRESSES)
REGISTER OBJ *op;
# endif
#endif
nInstVars = _intVal(_INST(instSize));
instsize = OHDR_SIZE + nInstVars * sizeof(OBJ);
PROTECT(self);
_qAlignedNew(newobj, instsize, SENDER);
UNPROTECT(self);
if (newobj != nil) {
_InstPtr(newobj)->o_class = self;
if (nInstVars) {
#if defined(memset4)
memset4(_InstPtr(newobj)->i_instvars, nil, nInstVars);
#else
# if defined(FAST_MEMSET) && ! defined(NEGATIVE_ADDRESSES)
/*
* knowing that nil is 0
*/
memset(_InstPtr(newobj)->i_instvars, 0, instsize - OHDR_SIZE);
# else
op = _InstPtr(newobj)->i_instvars;
do {
*op++ = nil;
} while (--nInstVars);
# endif
#endif
}
RETURN ( newobj );
}
%}
.
ObjectMemory allocationFailureSignal raise
!
basicNew:anInteger
"return an instance of myself with anInteger indexed variables.
If the receiver-class has no indexed instvars, this is only allowed
if the argument, anInteger is zero.
** Do not redefine this method in any class **"
%{ /* NOCONTEXT */
OBJ newobj;
INT instsize, nInstVars, nindexedinstvars;
INT flags;
#if ! defined(FAST_MEMSET) || defined(NEGATIVE_ADDRESSES)
REGISTER char *cp;
short *sp;
long *lp;
#endif
REGISTER OBJ *op;
float *fp;
double *dp;
extern OBJ new();
if (_isSmallInteger(anInteger)) {
nindexedinstvars = _intVal(anInteger);
if (nindexedinstvars >= 0) {
nInstVars = _intVal(_INST(instSize));
flags = _intVal(_INST(flags)) & ARRAYMASK;
switch (flags) {
case BYTEARRAY:
instsize = OHDR_SIZE + nInstVars * sizeof(OBJ) + nindexedinstvars * sizeof(char);
PROTECT(self);
_qNew(newobj, instsize, SENDER);
UNPROTECT(self);
if (newobj == nil) {
break;
}
_InstPtr(newobj)->o_class = self;
#if defined(FAST_MEMSET) && ! defined(NEGATIVE_ADDRESSES)
/*
* knowing that nil is 0
*/
memset(_InstPtr(newobj)->i_instvars, 0, instsize - OHDR_SIZE);
#else
op = _InstPtr(newobj)->i_instvars;
while (nInstVars--)
*op++ = nil;
cp = (char *)op;
while (nindexedinstvars >= sizeof(long)) {
*(long *)cp = 0;
cp += sizeof(long);
nindexedinstvars -= sizeof(long);
}
while (nindexedinstvars--)
*cp++ = '\0';
#endif
RETURN ( newobj );
break;
case WORDARRAY:
instsize = OHDR_SIZE + nInstVars * sizeof(OBJ) + nindexedinstvars * sizeof(short);
PROTECT(self);
_qNew(newobj, instsize, SENDER);
UNPROTECT(self);
if (newobj == nil) {
break;
}
_InstPtr(newobj)->o_class = self;
#if defined(FAST_MEMSET) && ! defined(NEGATIVE_ADDRESSES)
/*
* knowing that nil is 0
*/
memset(_InstPtr(newobj)->i_instvars, 0, instsize - OHDR_SIZE);
#else
op = _InstPtr(newobj)->i_instvars;
while (nInstVars--)
*op++ = nil;
sp = (short *)op;
while (nindexedinstvars--)
*sp++ = 0;
#endif
RETURN ( newobj );
break;
case LONGARRAY:
instsize = OHDR_SIZE + nInstVars * sizeof(OBJ) + nindexedinstvars * sizeof(long);
PROTECT(self);
_qAlignedNew(newobj, instsize, SENDER);
UNPROTECT(self);
if (newobj == nil) {
break;
}
_InstPtr(newobj)->o_class = self;
#if defined(memset4) && ! defined(NEGATIVE_ADDRESSES)
/*
* knowing that nil is 0
*/
memset4(_InstPtr(newobj)->i_instvars, 0, nInstVars + nindexedinstvars);
#else
# if defined(FAST_MEMSET) && ! defined(NEGATIVE_ADDRESSES)
/*
* knowing that nil is 0
*/
memset(_InstPtr(newobj)->i_instvars, 0, instsize - OHDR_SIZE);
# else
op = _InstPtr(newobj)->i_instvars;
while (nInstVars--)
*op++ = nil;
lp = (long *)op;
while (nindexedinstvars--)
*lp++ = 0;
# endif
#endif
RETURN ( newobj );
break;
case FLOATARRAY:
instsize = OHDR_SIZE + nInstVars * sizeof(OBJ) + nindexedinstvars * sizeof(float);
PROTECT(self);
_qNew(newobj, instsize, SENDER);
UNPROTECT(self);
if (newobj == nil) {
break;
}
_InstPtr(newobj)->o_class = self;
op = _InstPtr(newobj)->i_instvars;
while (nInstVars--)
*op++ = nil;
fp = (float *)op;
while (nindexedinstvars--)
*fp++ = 0.0;
RETURN ( newobj );
break;
case DOUBLEARRAY:
instsize = OHDR_SIZE + nInstVars * sizeof(OBJ) + nindexedinstvars * sizeof(double);
PROTECT(self);
_qNew(newobj, instsize, SENDER);
UNPROTECT(self);
if (newobj == nil) {
break;
}
_InstPtr(newobj)->o_class = self;
op = _InstPtr(newobj)->i_instvars;
while (nInstVars--)
*op++ = nil;
dp = (double *)op;
while (nindexedinstvars--)
*dp++ = 0.0;
RETURN ( newobj );
break;
case WKPOINTERARRAY:
case POINTERARRAY:
nInstVars += nindexedinstvars;
instsize = OHDR_SIZE + nInstVars * sizeof(OBJ);
PROTECT(self);
_qAlignedNew(newobj, instsize, SENDER);
UNPROTECT(self);
if (newobj == nil) {
break;
}
_InstPtr(newobj)->o_class = self;
#if defined(memset4)
memset4(_InstPtr(newobj)->i_instvars, nil, nInstVars);
#else
# if defined(FAST_MEMSET) && ! defined(NEGATIVE_ADDRESSES)
/*
* knowing that nil is 0
*/
memset(_InstPtr(newobj)->i_instvars, 0, instsize - OHDR_SIZE);
# else
op = _InstPtr(newobj)->i_instvars;
while (nInstVars--)
*op++ = nil;
# endif
#endif
RETURN ( newobj );
break;
default:
/*
* new:n for non-variable classes only allowed if
* n == 0
*/
if (nindexedinstvars == 0) {
instsize = OHDR_SIZE + nInstVars * sizeof(OBJ);
PROTECT(self);
_qAlignedNew(newobj, instsize, SENDER);
UNPROTECT(self);
if (newobj == nil) {
break;
}
_InstPtr(newobj)->o_class = self;
if (nInstVars) {
#if defined(memset4)
memset4(_InstPtr(newobj)->i_instvars, nil, nInstVars);
#else
# if defined(FAST_MEMSET) && ! defined(NEGATIVE_ADDRESSES)
/*
* knowing that nil is 0
*/
memset(_InstPtr(newobj)->i_instvars, 0, instsize - OHDR_SIZE);
# else
op = _InstPtr(newobj)->i_instvars;
do {
*op++ = nil;
} while (--nInstVars);
# endif
#endif
}
RETURN ( newobj );
}
break;
}
}
}
%}
.
(anInteger isMemberOf:SmallInteger) ifFalse:[
self error:'argument to new: must be Integer'
] ifTrue:[
(anInteger >= 0) ifTrue:[
"sorry but this class has no indexed instvars - need 'new' "
self isVariable ifFalse:[
self error:'not indexed - cannot create with new:'
] ifTrue:[
ObjectMemory allocationFailureSignal raise
]
] ifFalse:[
self error:'bad (negative) argument to new'
]
]
! !
!Behavior methodsFor:'accessing'!
superclass
"return the receivers superclass"
^ superclass
!
selectors
"return the receivers selector array"
^ selectors
!
methods
"return the receivers method array"
^ methods
!
methodDictionary
"return the receivers method dictionary - since no dictionary is
used (for now) just return the method array"
^ methods
!
instSize
"return the number of instance variables of the receiver"
^ instSize
!
flags
"return the receivers flag bits"
^ flags
!
isVariable
"return true, if instances have indexed instance variables"
"this used to be defined as:
^ (flags bitAnd:16r0F) ~~ 0
but then, changes in stc.h would not affect us here. Therefore:"
%{ /* NOCONTEXT */
/* this is defined as a primitive to get defines from stc.h */
RETURN ( (_intVal(_INST(flags)) & ARRAYMASK) ? true : false );
%}
!
isFixed
"return true, if instances do not have indexed instance variables"
%{ /* NOCONTEXT */
/* this is defined as a primitive to get defines from stc.h */
RETURN ( (_intVal(_INST(flags)) & ARRAYMASK) ? false : true );
%}
!
isBits
"return true, if instances have indexed byte or short instance variables.
Ignore long, float and double arrays, since classes using isBits are probably
not prepared to handle them correctly."
%{ /* NOCONTEXT */
/* this is defined as a primitive to get defines from stc.h */
REGISTER int flags;
RETURN ( (((flags = (_intVal(_INST(flags)) & ARRAYMASK)) == BYTEARRAY)
|| (flags == WORDARRAY)) ? true : false );
%}
!
isBytes
"return true, if instances have indexed byte instance variables"
%{ /* NOCONTEXT */
/* this is defined as a primitive to get defines from stc.h */
RETURN ( ((_intVal(_INST(flags)) & ARRAYMASK) == BYTEARRAY) ? true : false );
%}
!
isWords
"return true, if instances have indexed short instance variables"
%{ /* NOCONTEXT */
/* this is defined as a primitive to get defines from stc.h */
RETURN ( ((_intVal(_INST(flags)) & ARRAYMASK) == WORDARRAY) ? true : false );
%}
!
isLongs
"return true, if instances have indexed long instance variables"
%{ /* NOCONTEXT */
/* this is defined as a primitive to get defines from stc.h */
RETURN ( ((_intVal(_INST(flags)) & ARRAYMASK) == LONGARRAY) ? true : false );
%}
!
isFloats
"return true, if instances have indexed float instance variables"
%{ /* NOCONTEXT */
RETURN ( ((_intVal(_INST(flags)) & ARRAYMASK) == FLOATARRAY) ? true : false );
%}
!
isDoubles
"return true, if instances have indexed double instance variables"
%{ /* NOCONTEXT */
RETURN ( ((_intVal(_INST(flags)) & ARRAYMASK) == DOUBLEARRAY) ? true : false );
%}
!
isPointers
"return true, if instances have pointer instance variables
i.e. are either non-indexed or have indexed pointer variables"
"question: should we ignore WeakPointers ?"
%{ /* NOCONTEXT */
REGISTER int flags;
flags = _intVal(_INST(flags)) & ARRAYMASK;
switch (flags) {
default:
/* normal objects */
RETURN ( true );
case BYTEARRAY:
case WORDARRAY:
case LONGARRAY:
case FLOATARRAY:
case DOUBLEARRAY:
RETURN (false );
case WKPOINTERARRAY:
/* what about those ? */
RETURN (true );
}
%}
!
superclass:aClass
"set the superclass - this actually creates a new class,
recompiling all methods."
"must flush caches since lookup chain changes"
ObjectMemory flushCaches.
"
superclass := aClass
"
"for correct recompilation, just create a new class ..."
aClass subclass:(self name)
instanceVariableNames:(self instanceVariableString)
classVariableNames:(self classVariableString)
poolDictionaries:''
category:self category
!
selectors:selectorArray methods:methodArray
"set both selector array and method array of the receiver,
and flush caches"
ObjectMemory flushCaches.
selectors := selectorArray.
methods := methodArray
! !
!Behavior methodsFor:'queries'!
isBehavior
"return true, if the receiver describing another objecs behavior
i.e. is a class."
^ true
!
hasMultipleSuperclasses
"NO multiple inheritance in this system"
^ false
!
superclasses
"return a collection of the receivers immediate superclasses
- since we have NO multiple inheritance, there is only one"
^ Array with:superclass
!
allSuperclasses
"return a collection of the receivers accumulated superclasses"
|aCollection theSuperClass|
theSuperClass := superclass.
theSuperClass notNil ifTrue:[
aCollection := OrderedCollection new.
[theSuperClass notNil] whileTrue:[
aCollection add:theSuperClass.
theSuperClass := theSuperClass superclass
]
].
^ aCollection
!
withAllSuperclasses
"return a collection containing the receiver and all
of the receivers accumulated superclasses"
|aCollection theSuperClass|
aCollection := OrderedCollection with:self.
theSuperClass := superclass.
[theSuperClass notNil] whileTrue:[
aCollection add:theSuperClass.
theSuperClass := theSuperClass superclass
].
^ aCollection
!
subclasses
"return a collection of the direct subclasses of the receiver"
|newColl|
newColl := OrderedCollection new.
self subclassesDo:[:aClass |
newColl add:aClass
].
^ newColl
!
allSubclasses
"return a collection of all subclasses (direct AND indirect) of
the receiver"
|newColl|
newColl := OrderedCollection new.
self allSubclassesDo:[:aClass |
newColl add:aClass
].
^ newColl
!
withAllSubclasses
"return a collection containing the receiver and
all subclasses (direct AND indirect) of the receiver"
|newColl|
newColl := OrderedCollection with:self.
self allSubclassesDo:[:aClass |
newColl add:aClass
].
^ newColl
!
isSubclassOf:aClass
"return true, if I am a subclass of the argument, aClass"
|theClass|
theClass := superclass.
[theClass notNil] whileTrue:[
(theClass == aClass) ifTrue:[^ true].
theClass := theClass superclass
].
^ false
!
allInstances
"return a collection of all my instances"
|coll|
coll := OrderedCollection new.
ObjectMemory allObjectsDo:[:anObject |
(anObject class == self) ifTrue:[
coll add:anObject
]
].
^ coll asArray
!
instanceCount
"return the number of instances of myself"
|count|
count := 0.
ObjectMemory allObjectsDo:[:anObject |
(anObject class == self) ifTrue:[
count := count + 1
]
].
^ count
!
selectorIndex:aSelector
"return the index in the arrays for given selector aSelector"
^ selectors identityIndexOf:aSelector startingAt:1
!
compiledMethodAt:aSelector
"return the method for given selector aSelector"
|index|
index := selectors identityIndexOf:aSelector startingAt:1.
(index == 0) ifTrue:[^ nil].
^ methods at:index
!
sourceCodeAt:aSelector
"return the methods source for given selector aSelector"
|method|
method := self compiledMethodAt:aSelector.
method isNil ifTrue:[^ nil].
^ method source
"True sourceCodeAt:#ifTrue:"
!
hasMethods
"return true, if there are any (local) methods in this class"
^ (methods size ~~ 0)
!
implements:aSelector
"Return true, if I implement selector.
(i.e. implemented in this class - not in a superclass)"
^ (selectors identityIndexOf:aSelector startingAt:1) ~~ 0
"True implements:#ifTrue:"
"True implements:#=="
!
canUnderstand:aSelector
"Return true, if I or one of my superclasses implements selector.
(i.e. my instances understand aSelector)"
|classToLookAt|
classToLookAt := self.
[classToLookAt notNil] whileTrue:[
(classToLookAt implements:aSelector) ifTrue:[^ true].
classToLookAt := classToLookAt superclass
].
^ false
!
whichClassImplements:aSelector
"Return the class (the receiving class or a superclass)
which implements given selector aSelector, if none, return nil"
|classToLookAt|
classToLookAt := self.
[classToLookAt notNil] whileTrue:[
(classToLookAt implements:aSelector) ifTrue:[^ classToLookAt].
classToLookAt := classToLookAt superclass
].
^ nil
"True whichClassImplements:#ifTrue:"
"True whichClassImplements:#=="
!
inheritsFrom:aClass
"return true, if I inherit methods from aClass"
^ self isSubclassOf:aClass
!
selectorForMethod:aMethod
"Return the selector for given method aMethod"
|index|
index := methods identityIndexOf:aMethod startingAt:1.
(index == 0) ifTrue:[^ nil].
^ selectors at:index
!
containsMethod:aMethod
"Return true, if aMethod is a method of myself"
^ (methods identityIndexOf:aMethod startingAt:1) ~~ 0
! !
!Behavior methodsFor:'private accessing'!
setSuperclass:sup selectors:sels methods:m instSize:i flags:f
"set some inst vars (private use only)"
superclass := sup.
selectors := sels.
methods := m.
instSize := i.
flags := f
!
setSuperclass:aClass
"set the superclass of the receiver - no recompilation"
superclass := aClass
!
instSize:aNumber
"set the instance size"
instSize := aNumber
!
flags:aNumber
"set the flags"
flags := aNumber
!
setSelectors:anArray
"set the selector array of the receiver"
selectors := anArray
!
setMethodDictionary:anArray
"set the method array of the receiver"
methods := anArray
! !
!Behavior methodsFor:'enumeration'!
allInstancesDo:aBlock
"evaluate a block for all of my instances"
ObjectMemory allObjectsDo:[:anObject |
(anObject class == self) ifTrue:[
aBlock value:anObject
]
]
!
subclassesDo:aBlock
"evaluate the argument, aBlock for all immediate subclasses"
Smalltalk allBehaviorsDo:[:aClass |
(aClass superclass == self) ifTrue:[
aBlock value:aClass
]
]
!
allSubclassesDo:aBlock
"evaluate a block for all of my subclasses"
Smalltalk allBehaviorsDo:[:aClass |
(aClass isSubclassOf:self) ifTrue:[
aBlock value:aClass
]
]
!
allSubclassesInOrderDo:aBlock
"evaluate a block for all of my subclasses where superclasses come
first"
self subclassesDo:[:aClass |
aBlock value:aClass.
aClass allSubclassesInOrderDo:aBlock
]
!
allSuperclassesDo:aBlock
"evaluate a block for all of my superclasses"
|theClass|
theClass := superclass.
[theClass notNil] whileTrue:[
aBlock value:theClass.
theClass := theClass superclass
]
! !
!Behavior methodsFor: 'binary storage'!
binaryDefinitionFrom: stream manager: manager
| obj basicSize i |
self isPointers ifTrue: [
stream next. "skip instSize"
self isVariable ifTrue: [
^ self basicNew: (stream nextNumber: 3)
].
^ self basicNew
].
obj _ self basicNew: (basicSize _ stream nextNumber: 4).
i _ 0.
self isBytes ifTrue: [
[(i _ i + 1) <= basicSize] whileTrue: [
obj basicAt: i put: stream next
]
] ifFalse: [
[(i _ i + 1) <= basicSize] whileTrue: [
obj basicAt: i put: stream "nextWord" nextNumber:2
]
].
^obj
!
storeBinaryDefinitionOn: stream manager: manager
| myName |
stream
"nextWordPut: (format bitAnd: 16rFFFF);"
"nextWordPut:" nextNumber:2 put: (myName _ self name) size.
myName do: [:c| stream nextPut: c asciiValue]
!
XXbinaryDefinitionFrom: stream manager: manager
| obj t
basicSize "{ Class: SmallInteger }" |
self isPointers ifTrue: [
stream next. "skip instSize"
self isVariable ifTrue: [
^ self basicNew: (stream nextNumber: 3)
].
^ self basicNew
].
basicSize _ stream nextNumber: 4.
obj _ self basicNew:basicSize.
self isBytes ifTrue: [
1 to:basicSize do:[:i |
obj basicAt: i put: stream next
]
] ifFalse: [
self isWords ifTrue: [
1 to:basicSize do:[:i |
obj basicAt: i put: stream nextNumber:2
]
] ifFalse:[
self isLongs ifTrue: [
1 to:basicSize do:[:i |
obj basicAt: i put: stream nextNumber:4
]
] ifFalse:[
self isFloats ifTrue: [
1 to:basicSize do:[:i |
t := Float basicNew.
stream nextBytes:4 into:t.
obj basicAt: i put: t
]
] ifFalse:[
1 to:basicSize do:[:i |
t := Float basicNew.
stream nextBytes:8 into:t.
obj basicAt: i put: t
]
]
]
]
].
^obj
!
XXstoreBinaryDefinitionOn: stream manager: manager
| myName |
stream
"nextNumber:2 put: (format bitAnd: 16rFFFF);"
nextNumber:2 put: (myName _ self name) size.
myName do: [:c| stream nextPut: c asciiValue]
! !