.
"
COPYRIGHT (c) 1988 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 flags selectorArray methodArray
otherSuperclasses instSize'
classVariableNames:'SubclassInfo'
poolDictionaries:''
category:'Kernel-Classes'
!
Behavior comment:'
COPYRIGHT (c) 1988 by Claus Gittinger
All Rights Reserved
$Header: /cvs/stx/stx/libbasic/Behavior.st,v 1.45 1995-08-08 00:45:54 claus Exp $
'!
!Behavior class methodsFor:'documentation'!
copyright
"
COPYRIGHT (c) 1988 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.
"
!
version
"
$Header: /cvs/stx/stx/libbasic/Behavior.st,v 1.45 1995-08-08 00:45:54 claus Exp $
"
!
documentation
"
Every class in the system inherits from Behavior (via Class, ClassDescription);
so here is where most of the class messages end up being implemented.
(to answer a FAQ: 'Point basicNew' will be done here :-)
Beginners should keep in mind, that all classes are instances (of subclasses)
of Behavior, therefore you will find the above mentioned 'basicNew:' method
under the 'instance'-methods of Behavior - NOT under the class methods
('Behavior new' will create and return a new class, while sending 'new' to
any instance of Behavior (i.e. any class) will return an instance of that class).
Behavior provides minimum support for all classes - additional stuff is
found in ClassDescription and Class. Behaviors provides all mechanisms needed
to create instances, and send messages to those. However, Behavior does not provide
all the (symbolic) information needed to compile methods for a class or to get
useful information in inspectors.
In contrast to other ST implementations, the methods have been separated
from the selectors (there is no Dictionary, but two separate Arrays)
- this avoids the need for knowledge about Dictionaries in the runtime library (VM)
(lookup and search in these is seldom anyway, so the added benefit from using a
hashed dictionary is almost void).
For ST-80 compatibility, this will be replaced by a single instance of
MethodDictionary (which will NOT be a true dictionary, but an Array with
alternating selector/method entries).
To be prepared for this change, please do NOT directly use the methodArray
and selectorArray instVars.
Instance variables:
superclass <Class> the receivers superclass
otherSuperclasses <Array of Class> experimental: other superclasses
a hook for experimental multiple inheritance
implementations
selectorArray <Array of Symbol> the selectors for which inst-methods are defined here
methodArray <Array of Method> the inst-methods corresponding to the selectors
instSize <SmallInteger> the number of instance variables
flags <SmallInteger> special flag bits coded in a number
not for application use
flag bits (see stc.h):
NOTICE: layout known by compiler and runtime system; be careful when changing
"
!
virtualMachineRelationship
"
NOTICE:
the stuff described below may not be available on other
Smalltalk implementations; be aware that these error mechanisms
are ST/X specials and applications using these (tricks) may
not be portable to other systems.
WARNING:
do not try the examples below on (some) other smalltalk systems;
it has been reported, that some crash badly when doing this .... ;-)
Instances of Behavior and subclasses (i.e. in sloppy words: classes)
play a special role w.r.t. the VM. Only objects whose class-slot is marked
as being behaviorLike (in the flag-instvar) are considered to be classLike
and a message lookup will be done for it in the well known way.
Thus, if an object has a class for which its class does NOT have
this flag bit set, the VM will trigger an error on a message send.
Why is this so:
the above lets every object play the role of a class,
which has been flagged as behaviorLike in its class's flag.
Thus, you can create arbitrary new classLike objects and have the VM
play with them.
This may offer the flexibility to create a totally different object scheme
on top of ST/X (for example: Self like objects) where any object can play
a classRole for another object.
However, the VM trusts the isBehaviorLike flag - if it is set for some
object, it expects the object selector and methodDictionaries to be found
at the instance positions as defined here.
(i.e. instanceVariables with contents and semantic corresponding to
superclass flags selectorArray methodArray
must be present and have the same instVar-index as here).
The VM (and the system) may crash badly, if this is not the case.
Since every class in the system derives from Behavior, the flag setting
(and instance variable layout) is correct for all 'normal' classes.
If you experiment by creating new behaviorLike objects, please take
care of this flag. If you want to use the VM's lookup function, the
instVars 'superclass', 'selectorArray' and 'methodArray' are required
and have to be at the same instVar index.
(we suggest, you subclass Behavior, to make certain)
You do not have to care about the above details if you are a 'normal'
ST-programmer, though.
Examples (only of theoretical interrest):
take away the behaviorLike-flag from a class.
-> The instances will not understand any messages, since the VM will
not recognize its class as being a class ...
|newMeta notRecognizedAsClass someInstance|
newMeta := Metaclass new.
newMeta flags:0.
notRecognizedAsClass := newMeta new.
someInstance := notRecognizedAsClass new.
someInstance perform:#isNil
Of course, this is an exception which can be handled ...:
Example:
|newMeta notRecognizedAsClass someInstance|
newMeta := Metaclass new.
newMeta flags:0.
notRecognizedAsClass := newMeta new.
someInstance := notRecognizedAsClass new.
Object errorSignal handle:[:ex |
ex return
] do:[
someInstance perform:#isNil
]
likewise, a doesNotUnderstand-notUnderstood can be handled:
Example:
|newMeta funnyClass someInstance|
newMeta := Metaclass new.
funnyClass := newMeta new.
funnyClass setSuperclass:nil.
someInstance := funnyClass new.
Object errorSignal handle:[:ex |
ex return
] do:[
someInstance perform:#isNil
]
more examples, which try to trick the VM ;-):
badly playing around with a classes internals ...
|newClass someInstance|
newClass := Class new.
newClass setSelectorArray:nil.
someInstance := newClass new.
someInstance inspect
|newClass someInstance|
newClass := Class new.
newClass setSuperclass:nil.
someInstance := newClass new.
someInstance inspect
|newClass someInstance|
newClass := Class new.
newClass setSuperclass:newClass.
someInstance := newClass new.
someInstance inspect
|newClass someInstance|
newClass := Class new.
newClass setSuperclass:1.
someInstance := newClass new.
someInstance inspect
Example:
creating totally anonymous classes:
|newClass someInstance|
newClass := Class new.
someInstance := newClass new.
someInstance inspect
Example:
creating totally anonymous metaclasses:
|newMeta newClass someInstance|
newMeta := Metaclass new.
newClass := newMeta new.
someInstance := newClass new.
someInstance inspect
PS: if you experiment with new behaviorLike objects, you may want
to turn off the VM's debugPrintouts
with:
'Smalltalk debugPrinting:false'
and:
'Smalltalk infoPrinting:false'
"
! !
!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 behavior (which is like a class,
but without the symbolic & name information).
Not for normal applications.
Sending the returned behavior the #new message gives you
an instance if it.
Notice: the returned class is given a superclass of Object;
this allows for its new instances to be inspected and the like."
|newClass|
newClass := self basicNew.
newClass setSuperclass:Object
selectors:#() "/ (Array new:0)
methods:#() "/ (Array new:0)
instSize:0
flags:(self flagBehavior).
^ newClass
"
Behavior new <- a new behavior
Behavior new new <- an instance of it
ClassDescription new <- a new classDescription
ClassDescription new new <- an instance of it
Class new <- a new class
Class new new <- an instance of it
Metaclass new <- a new metaclass
Metaclass new new <- an instance (i.e. a class) of it
Metaclass new new new <- an instance of this new class
"
! !
!Behavior class methodsFor:'private '!
subclassInfo
|d|
SubclassInfo notNil ifTrue:[^ SubclassInfo].
d := IdentityDictionary new.
Smalltalk allClassesDo:[:aClass |
|superCls|
aClass isMeta not ifTrue:[
superCls := aClass superclass.
superCls notNil ifTrue:[
(d includesKey: superCls) ifFalse:[
d at:superCls put:(Set with:aClass).
] ifTrue:[
(d at:superCls ) add:aClass
]
]
].
].
SubclassInfo := d.
^ d
"
Class subclassInfo
"
!
flushSubclassInfo
SubclassInfo := nil.
"
Class flushSubclassInfo
"
! !
!Behavior methodsFor:'initialization'!
initialize
"to catch initialize for classes which do not"
^ self
!
postAutoload
"for autoloaded classes, gives them a second chance"
^ self
!
reinitialize
"to catch reinitialize for classes which do not"
^ self
! !
!Behavior methodsFor:'copying'!
deepCopy
"return a deep copy of the receiver
- return the receiver here - time will show if this is ok"
^ self
!
deepCopyUsing:aDictionary
"return a deep copy of the receiver
- return the receiver here - time will show if this is ok"
^ self
!
simpleDeepCopy
"return a deep copy of the receiver
- return the receiver here - time will show if this is ok"
^ self
! !
!Behavior methodsFor:'creating an instance of myself'!
uninitializedNew
"create an instance of myself with uninitialized contents.
For all classes except ByteArray, this is the same as new."
^ self basicNew
!
uninitializedNew:anInteger
"create an instance of myself with uninitialized contents.
For all classes except ByteArray, this is the same as new."
^ self basicNew:anInteger
!
niceBasicNew:anInteger
"same as basicNew:anInteger, but tries to avoid long pauses
due to garbage collection. This method checks to see if
allocation is possible without a pause, and does a background
incremental garbage collect first if there is not enough memory
available at the moment for fast allocation.
This is useful in low-priority background processes which like to
avoid disturbing any higher priority foreground process while allocating
big amounts of memory. Of course, using this method only makes
sense for big or huge objects (say > 200k).
EXPERIMENTAL: this is a non-standard interface and should only
be used for special applications. There is no guarantee, that this
method will be available in future ST/X releases."
|size|
size := self sizeOfInst:anInteger.
(ObjectMemory checkForFastNew:size) ifFalse:[
"
incrementally collect garbage
"
ObjectMemory incrementalGC.
].
^ 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 -
i.e. 'aClass basicNew' is equivalent to 'aClass basicNew:0'.
** Do not redefine this method in any class **"
%{ /* NOCONTEXT */
REGISTER OBJ newobj;
REGISTER char *nextPtr;
unsigned int instsize;
REGISTER unsigned int nInstVars;
extern OBJ __new();
/*
* the following ugly code is nothing more than a __new() followed
* by a nilling of the new instance.
* Unrolled for a bit more speed since this is one of the central object
* allocation methods in the system
*/
nInstVars = _intVal(_INST(instSize));
instsize = OHDR_SIZE + __OBJS2BYTES__(nInstVars);
newobj = (OBJ) newNextPtr;
nextPtr = ((char *)newobj) + instsize;
/*
* dont argue about the goto and the arrangement below - it saves
* an extra nil-compare and branch in the common case ...
* (i.e. if no GC is needed, we fall through without a branch)
*/
if (nextPtr < newEndPtr) {
_objPtr(newobj)->o_size = instsize;
/* o_allFlags(newobj) = 0; */
/* _objPtr(newobj)->o_space = newSpace; */
o_setAllFlags(newobj, newSpace);
#ifdef ALIGN4
newNextPtr = nextPtr;
#else
if (instsize & (ALIGN-1)) {
newNextPtr = (char *)newobj + (instsize & ~(ALIGN-1)) + ALIGN;
} else {
newNextPtr = nextPtr;
}
#endif
ok:
_InstPtr(newobj)->o_class = self;
__qSTORE(newobj, self);
if (nInstVars) {
#if defined(FAST_OBJECT_MEMSET4) || defined(FAST_MEMSET4)
memset4(_InstPtr(newobj)->i_instvars, nil, nInstVars);
#else
REGISTER OBJ *op;
op = _InstPtr(newobj)->i_instvars;
# if !defined(NEGATIVE_ADDRESSES)
/*
* knowing that nil is 0
*/
# if defined(FAST_OBJECT_MEMSET_DOUBLES_UNROLLED)
if (nInstVars > 8) {
*op++ = nil; /* for alignment */
nInstVars--;
while (nInstVars >= 8) {
*(double *)op = 0.0;
((double *)op)[1] = 0.0;
((double *)op)[2] = 0.0;
((double *)op)[3] = 0.0;
op += 8;
nInstVars -= 8;
}
}
while (nInstVars != 0) {
*op++ = 0;
nInstVars--;
}
# else
# if defined(FAST_OBJECT_MEMSET_LONGLONG_UNROLLED)
if (nInstVars > 8) {
*op++ = nil; /* for alignment */
nInstVars--;
while (nInstVars >= 8) {
*(long long *)op = 0;
((long long *)op)[1] = 0;
((long long *)op)[2] = 0;
((long long *)op)[3] = 0;
op += 8;
nInstVars -= 8;
}
}
while (nInstVars != 0) {
*op++ = 0;
nInstVars--;
}
# else
# if defined(FAST_OBJECT_MEMSET_WORDS_UNROLLED)
while (nInstVars >= 8) {
*op = nil;
*(op+1) = nil;
*(op+2) = nil;
*(op+3) = nil;
*(op+4) = nil;
*(op+5) = nil;
*(op+6) = nil;
*(op+7) = nil;
op += 8;
nInstVars -= 8;
}
while (nInstVars != 0) {
*op++ = nil;
nInstVars--;
}
# else
# if defined(FAST_MEMSET)
memset(_InstPtr(newobj)->i_instvars, 0, instsize-OHDR_SIZE);
# else
do {
*op++ = nil;
nInstVars--;
} while (nInstVars != 0);
# endif
# endif
# endif
# endif
# else /* nil could be ~~ 0 */
while (nInstVars >= 8) {
*op = nil;
*(op+1) = nil;
*(op+2) = nil;
*(op+3) = nil;
*(op+4) = nil;
*(op+5) = nil;
*(op+6) = nil;
*(op+7) = nil;
op += 8;
nInstVars -= 8;
}
while (nInstVars != 0) {
*op++ = nil;
nInstVars--;
}
# endif
#endif
}
RETURN ( newobj );
}
/*
* the slow case - a GC will occur
*/
PROTECT_CONTEXT
newobj = __new(instsize);
UNPROTECT_CONTEXT
if (newobj != nil) goto ok;
%}
.
"
memory allocation failed.
When we arrive here, there was no memory, even after
a garbage collect.
This means, that the VM wanted to get some more memory from the
Operatingsystem, which was not kind enough to give it.
Bad luck - you should increase the swap space on your machine.
"
^ 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;
unsigned INT instsize, nInstVars;
INT nindexedinstvars;
unsigned INT flags;
#if ! defined(FAST_ARRAY_MEMSET) || defined(NEGATIVE_ADDRESSES)
REGISTER char *cp;
short *sp;
long *lp;
#endif
REGISTER OBJ *op;
float *fp;
double *dp;
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 + nindexedinstvars;
if (nInstVars == 0) {
if (_CanDoQuickNew(instsize)) {
/*
* the most common case
*/
_qCheckedNew(newobj, instsize);
_InstPtr(newobj)->o_class = self;
#if defined(FAST_ARRAY_MEMSET4) || defined(FAST_MEMSET4)
nInstVars = nindexedinstvars >> 2;
if (nindexedinstvars & 3) nInstVars++;
memset4(_InstPtr(newobj)->i_instvars, 0, nInstVars);
#else
# if defined(FAST_ARRAY_MEMSET) && ! defined(NEGATIVE_ADDRESSES)
memset(_InstPtr(newobj)->i_instvars, 0, nindexedinstvars);
# else
cp = (char *)_InstPtr(newobj)->i_instvars;
while (nindexedinstvars >= sizeof(long)) {
*(long *)cp = 0;
cp += sizeof(long);
nindexedinstvars -= sizeof(long);
}
while (nindexedinstvars--)
*cp++ = '\0';
# endif
#endif
RETURN ( newobj );
}
} else {
instsize += __OBJS2BYTES__(nInstVars);
}
PROTECT_CONTEXT
_qNew(newobj, instsize, SENDER);
UNPROTECT_CONTEXT
if (newobj == nil) {
break;
}
_InstPtr(newobj)->o_class = self;
__qSTORE(newobj, self);
#if defined(FAST_ARRAY_MEMSET4) || defined(FAST_MEMSET4)
nInstVars = (instsize-OHDR_SIZE) >> 2;
if (instsize & 3) nInstVars++;
memset4(_InstPtr(newobj)->i_instvars, 0, nInstVars);
#else
# if defined(FAST_ARRAY_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
#endif
RETURN ( newobj );
break;
case WORDARRAY:
instsize = OHDR_SIZE +
__OBJS2BYTES__(nInstVars) +
nindexedinstvars * sizeof(short);
PROTECT_CONTEXT
_qNew(newobj, instsize, SENDER);
UNPROTECT_CONTEXT
if (newobj == nil) {
break;
}
_InstPtr(newobj)->o_class = self;
__qSTORE(newobj, self);
#if defined(FAST_ARRAY_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 +
__OBJS2BYTES__(nInstVars) +
nindexedinstvars * sizeof(long);
PROTECT_CONTEXT
_qAlignedNew(newobj, instsize, SENDER);
UNPROTECT_CONTEXT
if (newobj == nil) {
break;
}
_InstPtr(newobj)->o_class = self;
__qSTORE(newobj, self);
#if defined(FAST_ARRAY_MEMSET4) || defined(FAST_MEMSET4)
/*
* knowing that nil is 0
*/
memset4(_InstPtr(newobj)->i_instvars, 0, nInstVars + nindexedinstvars);
#else
# if defined(FAST_ARRAY_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 = sizeof(struct __floatArray) +
__OBJS2BYTES__(nInstVars) +
(nindexedinstvars - 1) * sizeof(float);
PROTECT_CONTEXT
_qNew(newobj, instsize, SENDER);
UNPROTECT_CONTEXT
if (newobj == nil) {
break;
}
_InstPtr(newobj)->o_class = self;
__qSTORE(newobj, self);
op = _InstPtr(newobj)->i_instvars;
# if defined(mips) /* knowin that float 0.0 is all-zeros */
memset(_InstPtr(newobj)->i_instvars, 0, instsize - OHDR_SIZE);
# else
while (nInstVars--)
*op++ = nil;
fp = (float *)op;
while (nindexedinstvars--)
*fp++ = 0.0;
# endif
RETURN ( newobj );
break;
case DOUBLEARRAY:
instsize = sizeof(struct __doubleArray) +
__OBJS2BYTES__(nInstVars) +
(nindexedinstvars - 1) * sizeof(double);
PROTECT_CONTEXT
_qAlignedNew(newobj, instsize, SENDER);
UNPROTECT_CONTEXT
if (newobj == nil) {
break;
}
_InstPtr(newobj)->o_class = self;
__qSTORE(newobj, self);
op = _InstPtr(newobj)->i_instvars;
while (nInstVars--)
*op++ = nil;
#ifdef NEED_DOUBLE_ALIGN
/*
* care for double alignment
*/
if ((INT)op & (ALIGN-1)) {
*op++ = nil;
}
#endif
dp = (double *)op;
while (nindexedinstvars--)
*dp++ = 0.0;
RETURN ( newobj );
break;
case WKPOINTERARRAY:
case POINTERARRAY:
nInstVars += nindexedinstvars;
instsize = OHDR_SIZE + __OBJS2BYTES__(nInstVars);
PROTECT_CONTEXT
_qAlignedNew(newobj, instsize, SENDER);
UNPROTECT_CONTEXT
if (newobj == nil) {
break;
}
_InstPtr(newobj)->o_class = self;
__qSTORE(newobj, self);
#if defined(FAST_ARRAY_MEMSET4) || defined(FAST_MEMSET4)
memset4(_InstPtr(newobj)->i_instvars, nil, nInstVars);
#else
# if !defined(NEGATIVE_ADDRESSES)
/*
* knowing that nil is 0
*/
#ifdef XXmips
# undef FAST_ARRAY_MEMSET_DOUBLES_UNROLLED
# undef FAST_ARRAY_MEMSET_LONGLONG_UNROLLED
/* seems to be slightly faster */
# define FAST_ARRAY_MEMSET
#endif
#ifdef sparc
# define FAST_ARRAY_MEMSET_DOUBLES_UNROLLED
#endif
# if defined(FAST_ARRAY_MEMSET_DOUBLES_UNROLLED)
op = _InstPtr(newobj)->i_instvars;
if (nInstVars > 8) {
*op++ = nil; /* for alignment */
nInstVars--;
while (nInstVars >= 8) {
*(double *)op = 0.0;
((double *)op)[1] = 0.0;
((double *)op)[2] = 0.0;
((double *)op)[3] = 0.0;
op += 8;
nInstVars -= 8;
}
}
while (nInstVars) {
*op++ = 0;
nInstVars--;
}
# else
# if defined(FAST_ARRAY_MEMSET_LONGLONG_UNROLLED)
op = _InstPtr(newobj)->i_instvars;
if (nInstVars > 8) {
*op++ = nil; /* for alignment */
nInstVars--;
while (nInstVars >= 8) {
*(long long *)op = 0;
((long long *)op)[1] = 0;
((long long *)op)[2] = 0;
((long long *)op)[3] = 0;
op += 8;
nInstVars -= 8;
}
}
while (nInstVars) {
*op++ = 0;
nInstVars--;
}
# else
# if defined(FAST_ARRAY_MEMSET)
memset(_InstPtr(newobj)->i_instvars, 0, instsize - OHDR_SIZE);
# else
op = _InstPtr(newobj)->i_instvars;
while (nInstVars--)
*op++ = nil;
# endif
# endif
# endif
# 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 + __OBJS2BYTES__(nInstVars);
PROTECT_CONTEXT
_qAlignedNew(newobj, instsize, SENDER);
UNPROTECT_CONTEXT
if (newobj == nil) {
break;
}
_InstPtr(newobj)->o_class = self;
__qSTORE(newobj, self);
if (nInstVars) {
#if defined(FAST_OBJECT_MEMSET4) || defined(FAST_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;
}
}
}
%}.
"
arrive here if something went wrong ...
figure out what it was
"
(anInteger isMemberOf:SmallInteger) ifFalse:[
"
the argument is either not an integer,
or a LargeInteger (which means that its definitely too big)
"
self error:'argument to new: must be Integer'.
^ nil
].
(anInteger < 0) ifTrue:[
"
the argument is negative,
"
self error:'bad (negative) argument to new:'.
^ nil
].
self isVariable ifFalse:[
"
this class does not have any indexed instance variables
"
self error:'class has no indexed instvars - cannot create with new:'.
^ nil
].
"
memory allocation failed.
When we arrive here, there was no memory, even after
a garbage collect.
This means, that the VM wanted to get some more memory from the
Operatingsystem, which was not kind enough to give it.
Bad luck - you should increase the swap space on your machine.
"
^ ObjectMemory allocationFailureSignal raise.
!
readFrom:aStream
"read an objects printed representation from the argument, aStream
and return it.
The read object must be a kind of myself if its not, an error is raised.
This is the reverse operation to 'storeOn:'.
WARNING: storeOn: does not handle circular references and multiple
references to the same object.
Use #storeBinary:/readBinaryFrom: for this."
^ self readFrom:aStream onError:[self error:'expected: ' , self name]
"
|s|
s := WriteStream on:String new.
#(1 2 3 4) storeOn:s.
Object readFrom:(ReadStream on:s contents)
"
!
readFrom:aStream onError:exceptionBlock
"read an objects printed representation from the argument, aStream
and return it (i.e. the stream should contain some representation of
the object which was created using #storeOn:).
The read object must be a kind of myself if its not, the value of
exceptionBlock is returned.
To get any object, use 'Object readFrom:...',
To get any number, use 'Number readFrom:...' and so on.
This is the reverse operation to 'storeOn:'.
WARNING: storeOn: does not handle circular references and multiple
references to the same object.
Use #storeBinary:/readBinaryFrom: for this."
|newObject|
ErrorSignal handle:[:ex |
ex return
] do:[
newObject := self evaluatorClass evaluate:aStream.
].
(newObject isKindOf:self) ifFalse:[^ exceptionBlock value].
^ newObject
"
|s|
s := WriteStream on:String new.
#(1 2 3 4) storeOn:s.
Transcript showCr:(
Array readFrom:(ReadStream on:s contents) onError:'not an Array'
)
"
"
|s|
s := WriteStream on:String new.
#[1 2 3 4] storeOn:s.
Transcript showCr:(
Array readFrom:(ReadStream on:s contents) onError:'not an Array'
)
"
!
readFromString:aString
"create an object from its printed representation.
For most classes, the string is expected to be in a format created by
storeOn: or storeString; however, some (Time, Date) expect a user
readable string here.
See comments in Behavior>>readFromString:onError:,
Behavior>>readFrom: and Behavior>>readFrom:onError:"
^ self readFromString:aString onError:[self error:'expected: ' , self name]
"
Integer readFromString:'12345678901234567890'
Point readFromString:'1@2'
Point readFromString:'1'
"
!
readFromString:aString onError:exceptionBlock
"create an object from its printed representation.
Here, the string is expected to be in a format created by
storeOn: or storeString; however, some classes (Time, Date) may redefine
it to expect a user readable string here.
See comments in Behavior>>readFrom: and Behavior>>readFrom:onError:"
^ self readFrom:(ReadStream on:aString) onError:exceptionBlock
"
Integer readFromString:'12345678901234567890'
Integer readFromString:'abc'
Integer readFromString:'abc' onError:0
Point readFromString:'1@2'
Point readFromString:'0'
Point readFromString:'0' onError:[0@0]
"
! !
!Behavior methodsFor:'autoload check'!
isLoaded
"return true, if the class has been loaded;
redefined in Autoload; see comment there"
^ true
!
autoload
"force autoloading - do nothing here;
redefined in Autoload; see comment there"
^ self
! !
!Behavior methodsFor:'snapshots'!
preSnapshot
"sent by ObjectMemory, before a snapshot is written.
Nothing done here."
!
postSnapshot
"sent by ObjectMemory, after a snapshot has been written.
Nothing done here."
! !
!Behavior class methodsFor:'flag bit constants'!
flagNotIndexed
"return the flag code for non-indexed instances.
You have to mask the flag value with indexMask when comparing
it with flagNotIndexed."
^ 0
!
flagBytes
"return the flag code for byte-valued indexed instances.
You have to mask the flag value with indexMask when comparing
it with flagBytes."
%{ /* NOCONTEXT */
/* this is defined as a primitive to get defines from stc.h */
RETURN ( _MKSMALLINT(BYTEARRAY) );
%}
"
Behavior flagBytes
"
!
flagWords
"return the flag code for word-valued indexed instances (i.e. 2-byte).
You have to mask the flag value with indexMask when comparing
it with flagWords."
%{ /* NOCONTEXT */
/* this is defined as a primitive to get defines from stc.h */
RETURN ( _MKSMALLINT(WORDARRAY) );
%}
"
Behavior flagWords
"
!
flagLongs
"return the flag code for long-valued indexed instances (i.e. 4-byte).
You have to mask the flag value with indexMask when comparing
it with flagLongs."
%{ /* NOCONTEXT */
/* this is defined as a primitive to get defines from stc.h */
RETURN ( _MKSMALLINT(LONGARRAY) );
%}
"
Behavior flagLongs
"
!
flagFloats
"return the flag code for float-valued indexed instances (i.e. 4-byte reals).
You have to mask the flag value with indexMask when comparing
it with flagFloats."
%{ /* NOCONTEXT */
/* this is defined as a primitive to get defines from stc.h */
RETURN ( _MKSMALLINT(FLOATARRAY) );
%}
"
Behavior flagFloats
"
!
flagDoubles
"return the flag code for double-valued indexed instances (i.e. 8-byte reals).
You have to mask the flag value with indexMask when comparing
it with flagDoubles."
%{ /* NOCONTEXT */
/* this is defined as a primitive to get defines from stc.h */
RETURN ( _MKSMALLINT(DOUBLEARRAY) );
%}
"
Behavior flagDoubles
"
!
flagPointers
"return the flag code for pointer indexed instances (i.e. Array of object).
You have to mask the flag value with indexMask when comparing
it with flagPointers."
%{ /* NOCONTEXT */
/* this is defined as a primitive to get defines from stc.h */
RETURN ( _MKSMALLINT(POINTERARRAY) );
%}
"
Behavior flagPointers
"
!
flagWeakPointers
"return the flag code for weak pointer indexed instances (i.e. WeakArray).
You have to mask the flag value with indexMask when comparing
it with flagWeakPointers."
%{ /* NOCONTEXT */
/* this is defined as a primitive to get defines from stc.h */
RETURN ( _MKSMALLINT(WKPOINTERARRAY) );
%}
!
maskIndexType
"return a mask to extract all index-type bits"
%{ /* NOCONTEXT */
/* this is defined as a primitive to get defines from stc.h */
RETURN ( _MKSMALLINT(ARRAYMASK) );
%}
!
flagBehavior
"return the flag code which marks Behavior-like instances.
You have to check this single bit in the flag value when
checking for behaviors."
%{ /* NOCONTEXT */
/* this is defined as a primitive to get defines from stc.h */
RETURN ( _MKSMALLINT(BEHAVIOR_INSTS) );
%}
"consistency check:
all class-entries must be behaviors;
all behaviors must be flagged so (in its class's flags)
(otherwise, VM will bark)
all non-behaviors may not be flagged
|bit|
bit := Class flagBehavior.
ObjectMemory allObjectsDo:[:o|
o isBehavior ifTrue:[
(o class flags bitTest:bit) ifFalse:[
self halt
].
] ifFalse:[
(o class flags bitTest:bit) ifTrue:[
self halt
].
].
o class isBehavior ifFalse:[
self halt
] ifTrue:[
(o class class flags bitTest:bit) ifFalse:[
self halt
]
]
]
"
!
flagBlock
"return the flag code which marks Block-like instances.
You have to check this single bit in the flag value when
checking for blocks."
%{ /* NOCONTEXT */
/* this is defined as a primitive to get defines from stc.h */
RETURN ( _MKSMALLINT(BLOCK_INSTS) );
%}
!
flagMethod
"return the flag code which marks Method-like instances.
You have to check this single bit in the flag value when
checking for methods."
%{ /* NOCONTEXT */
/* this is defined as a primitive to get defines from stc.h */
RETURN ( _MKSMALLINT(METHOD_INSTS) );
%}
!
flagNonObjectInst
"return the flag code which marks instances which have a
non-object instance variable (in slot 1).
(these are ignored by the garbage collector)"
%{ /* NOCONTEXT */
/* this is defined as a primitive to get defines from stc.h */
RETURN ( _MKSMALLINT(NONOBJECT_INSTS) );
%}
!
flagContext
"return the flag code which marks Context-like instances.
You have to check this single bit in the flag value when
checking for contexts."
%{ /* NOCONTEXT */
/* this is defined as a primitive to get defines from stc.h */
RETURN ( _MKSMALLINT(CONTEXT_INSTS) );
%}
!
flagBlockContext
"return the flag code which marks BlockContext-like instances.
You have to check this single bit in the flag value when
checking for blockContexts."
%{ /* NOCONTEXT */
/* this is defined as a primitive to get defines from stc.h */
RETURN ( _MKSMALLINT(BCONTEXT_INSTS) );
%}
!
flagFloat
"return the flag code which marks Float-like instances.
You have to check this single bit in the flag value when
checking for floats."
%{ /* NOCONTEXT */
/* this is defined as a primitive to get defines from stc.h */
RETURN ( _MKSMALLINT(FLOAT_INSTS) );
%}
!
flagSymbol
"return the flag code which marks Symbol-like instances.
You have to check this single bit in the flag value when
checking for symbols."
%{ /* NOCONTEXT */
/* this is defined as a primitive to get defines from stc.h */
RETURN ( _MKSMALLINT(SYMBOL_INSTS) );
%}
! !
!Behavior methodsFor:'accessing'!
name
"although behaviors have no name, we return something
useful here - there are many places (inspectors) where
a classes name is asked for.
Implementing this message here allows anonymous classes
and instances of them to be inspected."
^ 'someBehavior'
!
displayString
"although behaviors have no name, we return something
useful here - there are many places (inspectors) where
a classes name is asked for.
Implementing this message here allows instances of anonymous classes
to show a reasonable name."
^ 'someBehavior'
!
category
"return the category of the class.
Returning nil here, since Behavior does not define a category
(only ClassDescriptions do)."
^ nil
"
Point category
Behavior new category
"
!
superclass
"return the receivers superclass"
^ superclass
!
selectorArray
"return the receivers selector array.
Notice: this is not compatible with ST-80."
^ selectorArray
!
selectors
"return the receivers selector array.
Notice: this may not compatible with ST-80.
(should we return a Set ?)"
^ selectorArray asOrderedCollection
!
methodArray
"return the receivers method array.
Notice: this is not compatible with ST-80."
^ methodArray
!
methodDictionary
"return the receivers method dictionary.
Since no dictionary is actually present, create one for ST-80 compatibility."
|dict n "{ Class: SmallInteger }"|
dict := IdentityDictionary new.
n := selectorArray size.
1 to:n do:[:index |
dict at:(selectorArray at:index) put:(methodArray at:index)
].
^ dict
!
implicit_methodDict
"ST-80 compatibility.
This allows subclasses to assume there is an instance variable
named methodDict."
^ self methodDictionary
!
implicit_methodDict:aDictionary
"ST-80 compatibility.
This allows subclasses to assume there is an instance variable
named methodDict."
^ self error:'not allowed to set the methodDictionary'
!
instSize
"return the number of instance variables of the receiver.
This includes all superclass instance variables."
^ instSize
!
flags
"return the receivers flag bits"
^ flags
!
superclass:aClass
"set the superclass - this actually creates a new class,
recompiling all methods for the new one. The receiving class stays
around anonymous to allow existing instances some life.
This may change in the future (adjusting existing instances)"
SubclassInfo := nil.
"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
!
addSuperclass:aClass
"EXPERIMENTAL MI support: add aClass to the set of classes, from which instances
inherit protocol."
"first, check if the class is abstract -
allows abstract mixins are allowed in the current implementation"
aClass instSize == 0 ifFalse:[
self error:'only abstract mixins allowed'.
^ self
].
otherSuperclasses isNil ifTrue:[
otherSuperclasses := Array with:aClass
] ifFalse:[
otherSuperclasses := otherSuperclasses copyWith:aClass
].
SubclassInfo := nil.
ObjectMemory flushCaches
!
removeSuperclass:aClass
"EXPERIMENTAL MI support: remove aClass from the set of classes, from which instances
inherit protocol."
otherSuperclasses notNil ifTrue:[
otherSuperclasses := otherSuperclasses copyWithout:aClass.
otherSuperclasses isEmpty ifTrue:[
otherSuperclasses := nil
].
SubclassInfo := nil.
ObjectMemory flushCaches
].
!
selectors:newSelectors methods:newMethods
"set both selector array and method array of the receiver,
and flush caches"
ObjectMemory flushCaches.
selectorArray := newSelectors.
methodArray := newMethods
!
addSelector:newSelector withMethod:newMethod
"add the method given by 2nd argument under the selector given by
1st argument to the methodDictionary. Flush all caches."
|nargs|
(self primAddSelector:newSelector withMethod:newMethod) ifFalse:[^ false].
self changed:#methodDictionary with:newSelector.
"
if I have no subclasses, all we have to flush is cached
data for myself ... (actually, in any case all that needs
to be flushed is info for myself and all of my subclasses)
"
"
problem: this is slower; since looking for all subclasses is (currently)
a bit slow :-(
We need the hasSubclasses-info bit in Behavior; now
self withAllSubclassesDo:[:aClass |
ObjectMemory flushInlineCachesFor:aClass withArgs:nargs.
ObjectMemory flushMethodCacheFor:aClass
].
"
"
actually, we would do better with less flushing ...
"
nargs := newSelector numArgs.
ObjectMemory flushMethodCache.
ObjectMemory flushInlineCachesWithArgs:nargs.
^ true
!
addSelector:newSelector withLazyMethod:newMethod
"add the method given by 2nd argument under the selector given by
1st argument to the methodDictionary. Since it does not flush
any caches, this is only allowed for lazy methods."
newMethod isLazyMethod ifFalse:[
self error:'operation only allowed for lazy methods'.
^ false
].
"/ oops: we must flush, if this method already exists ...
(selectorArray includes:newSelector) ifTrue:[
ObjectMemory flushCaches
].
(self primAddSelector:newSelector withMethod:newMethod) ifTrue:[
self changed:#methodDictionary with:newSelector.
^ true
].
^ false
!
removeSelector:aSelector
"remove the selector, aSelector and its associated method
from the methodDictionary"
|index oldSelectorArray oldMethodArray newSelectorArray newMethodArray|
index := selectorArray identityIndexOf:aSelector startingAt:1.
(index == 0) ifTrue:[^ false].
newSelectorArray := selectorArray copyWithoutIndex:index.
newMethodArray := methodArray copyWithoutIndex:index.
oldSelectorArray := selectorArray.
oldMethodArray := methodArray.
selectorArray := newSelectorArray.
methodArray := newMethodArray.
"
[
|nargs|
nargs := aSelector numArgs.
ObjectMemory flushMethodCache.
ObjectMemory flushInlineCachesWithArgs:nargs.
] value
"
"
actually, we would do better with less flushing ...
"
ObjectMemory flushCaches.
^ true
! !
!Behavior methodsFor:'queries'!
sizeOfInst:n
"return the number of bytes required for an instance of
myself with n indexed instance variables. The argument n
should be zero for classes without indexed instance variables.
See Behavior>>niceNew: for an application of this."
|nInstvars|
nInstvars := self instSize.
%{
int nBytes;
nBytes = _intVal(nInstvars) * sizeof(OBJ) + OHDR_SIZE;
if (__isSmallInteger(n)) {
int nIndex;
nIndex = _intVal(n);
switch (_intVal(_INST(flags)) & ARRAYMASK) {
case BYTEARRAY:
nBytes += nIndex;
if (nBytes & (ALIGN - 1)) {
nBytes = (nBytes & ~(ALIGN - 1)) + ALIGN;
}
break;
case WORDARRAY:
nBytes += nIndex * sizeof(short);
if (nBytes & (ALIGN - 1)) {
nBytes = (nBytes & ~(ALIGN - 1)) + ALIGN;
}
break;
case LONGARRAY:
nBytes += nIndex * sizeof(long);
break;
case FLOATARRAY:
nBytes += nIndex * sizeof(float);
break;
case DOUBLEARRAY:
nBytes += nIndex * sizeof(double);
break;
default:
nBytes += nIndex * sizeof(OBJ);
break;
}
}
RETURN (_MKSMALLINT(nBytes));
%}
!
isVariable
"return true, if instances have indexed instance variables"
"this could also be defined as:
^ (flags bitAnd:(Behavior maskIndexType)) ~~ 0
"
%{ /* NOCONTEXT */
RETURN ( (_intVal(_INST(flags)) & ARRAYMASK) ? true : false );
%}
!
isFixed
"return true, if instances do not have indexed instance variables"
"this could also be defined as:
^ self isVariable not
"
%{ /* NOCONTEXT */
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 ST-80 code using isBits are probably
not prepared to handle them correctly."
%{ /* NOCONTEXT */
REGISTER int flags;
RETURN ( (((flags = (_intVal(_INST(flags)) & ARRAYMASK)) == BYTEARRAY)
|| (flags == WORDARRAY)) ? true : false );
%}
!
isBytes
"return true, if instances have indexed byte instance variables"
"this could also be defined as:
^ (flags bitAnd:(Behavior maskIndexType)) == Behavior flagBytes
"
%{ /* NOCONTEXT */
RETURN ( ((_intVal(_INST(flags)) & ARRAYMASK) == BYTEARRAY) ? true : false );
%}
!
isWords
"return true, if instances have indexed short instance variables"
"this could also be defined as:
^ (flags bitAnd:(Behavior maskIndexType)) == Behavior flagWords
"
%{ /* NOCONTEXT */
RETURN ( ((_intVal(_INST(flags)) & ARRAYMASK) == WORDARRAY) ? true : false );
%}
!
isLongs
"return true, if instances have indexed long instance variables"
"this could also be defined as:
^ (flags bitAnd:(Behavior maskIndexType)) == Behavior flagLongs
"
%{ /* NOCONTEXT */
RETURN ( ((_intVal(_INST(flags)) & ARRAYMASK) == LONGARRAY) ? true : false );
%}
!
isFloats
"return true, if instances have indexed float instance variables"
"this could also be defined as:
^ (flags bitAnd:(Behavior maskIndexType)) == Behavior flagFloats
"
%{ /* NOCONTEXT */
RETURN ( ((_intVal(_INST(flags)) & ARRAYMASK) == FLOATARRAY) ? true : false );
%}
!
isDoubles
"return true, if instances have indexed double instance variables"
"this could also be defined as:
^ (flags bitAnd:(Behavior maskIndexType)) == Behavior flagDoubles
"
%{ /* 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 );
}
%}
!
isBehavior
"return true, if the receiver is describing another objects behavior,
i.e. is a class. Defined to avoid the need to use isKindOf:"
^ true
"
True isBehavior
true isBehavior
"
!
canBeSubclassed
"return true, if its allowed to create subclasses of the receiver.
This method is redefined in SmallInteger and UndefinedObject, since
instances are detected by their pointer-fields, i.e. they do not have
a class entry (you dont have to understand this :-)"
^ true
!
hasMultipleSuperclasses
"Return true, if this class inherits from other classes
(beside its primary superclass).
This method is a preparation for a future multiple inheritance extension
- currently it is not supported by the VM"
^ otherSuperclasses notNil
!
superclasses
"return a collection of the receivers immediate superclasses.
This method is a preparation for a future multiple inheritance extension
- currently it is not supported by the VM"
|a|
a := Array with:superclass.
otherSuperclasses notNil ifTrue:[
^ a , otherSuperclasses
].
^ a
"
String superclasses
"
!
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
"
String allSuperclasses
"
!
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
"
String withAllSuperclasses
"
!
subclasses
"return a collection of the direct subclasses of the receiver"
|newColl|
SubclassInfo notNil ifTrue:[
newColl := SubclassInfo at:self ifAbsent:nil.
newColl notNil ifTrue:[^ newColl asOrderedCollection]
].
newColl := OrderedCollection new.
self subclassesDo:[:aClass |
newColl add:aClass
].
^ newColl
"
Collection subclasses
"
!
allSubclasses
"return a collection of all subclasses (direct AND indirect) of
the receiver. There will be no specific order, in which entries
are returned."
|newColl|
newColl := OrderedCollection new.
self allSubclassesDo:[:aClass |
newColl add:aClass
].
^ newColl
"
Collection allSubclasses
"
!
allSubclassesInOrder
"return a collection of all subclasses (direct AND indirect) of
the receiver. Higher level subclasses will come before lower ones."
|newColl|
newColl := OrderedCollection new.
self allSubclassesInOrderDo:[:aClass |
newColl add:aClass
].
^ newColl
"
Collection allSubclassesInOrder
"
!
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
"
Collection withAllSubclasses
"
!
isSubclassOf:aClass
"return true, if I am a subclass of the argument, aClass"
|theClass|
theClass := superclass.
[theClass notNil] whileTrue:[
(theClass == aClass) ifTrue:[^ true].
%{
if (__isBehaviorLike(theClass)) {
theClass = __ClassInstPtr(theClass)->c_superclass;
} else {
theClass = nil;
}
%}.
"/ theClass := theClass superclass.
].
^ false
"
String isSubclassOf:Collection
LinkedList isSubclassOf:Array
1 isSubclassOf:Number <- will fail since 1 is no class
"
!
allInstVarNames
"return a collection of all the instance variable name-strings
this includes all superclass-instance variables.
Since Behavior has no idea of instvar-names, return an empty collection
here. Redefined in ClassDescription."
^ #()
!
allClassVarNames
"return a collection of all the class variable name-strings
this includes all superclass-class variables.
Since Behavior has no idea of classvar-names, return an empty collection
here. Redefined in ClassDescription."
^ #()
!
allInstances
"return a collection of all my instances"
"Read the documentation on why there seem to be no
instances of SmallInteger and UndefinedObject"
|coll|
coll := OrderedCollection new:100.
self allInstancesDo:[:anObject |
coll add:anObject
].
^ coll
"
ScrollBar allInstances
"
!
allSubInstances
"return a collection of all instances of myself and
instances of all subclasses of myself."
|coll|
coll := OrderedCollection new:100.
self allSubInstancesDo:[:anObject |
(anObject isKindOf:self) ifTrue:[
coll add:anObject
]
].
^ coll
"
View allSubInstances
"
!
allDerivedInstances
"return a collection of all instances of myself and
instances of all subclasses of myself.
This method is going to be removed for protocol compatibility with
other STs; use allSubInstances"
self obsoleteMethodWarning:'please use #allSubInstances'.
^ self allSubInstances
!
hasInstances
"return true, if there are any instances of myself"
"Read the documentation on why there seem to be no
instances of SmallInteger and UndefinedObject"
"/ ObjectMemory allObjectsDo:[:anObject |
"/ (anObject class == self) ifTrue:[
"/ ^ true
"/ ]
"/ ].
ObjectMemory allInstancesOf:self do:[:anObject |
^ true
].
^ false
"
Object hasInstances
SequenceableCollection hasInstances
Float hasInstances
SmallInteger hasInstances
"
!
instanceCount
"return the number of instances of myself."
"Read the documentation on why there seem to be no
instances of SmallInteger and UndefinedObject"
|count|
count := 0.
"/ ObjectMemory allObjectsDo:[:anObject |
"/ (anObject class == self) ifTrue:[
"/ count := count + 1
"/ ]
"/ ].
ObjectMemory allInstancesOf:self do:[:anObject |
count := count + 1
].
^ count
"
View instanceCount
Object instanceCount
Float instanceCount
SequenceableCollection instanceCount
SmallInteger instanceCount .... mhmh - hear, hear
"
!
derivedInstanceCount
"return the number of instances of myself and of subclasses"
|count|
count := 0.
ObjectMemory allObjectsDo:[:anObject |
(anObject isKindOf:self) ifTrue:[
count := count + 1
]
].
^ count
"
View derivedInstanceCount
SequenceableCollection derivedInstanceCount
"
!
selectorIndex:aSelector
"return the index in the arrays for given selector aSelector"
^ selectorArray identityIndexOf:aSelector startingAt:1
!
includesSelector:aSelector
"for ST-80 compatibility"
^ self implements:aSelector
!
compiledMethodAt:aSelector
"return the method for given selector aSelector or nil.
Only methods in the receiver - not in the superclass chain are tested."
|index|
selectorArray isNil ifTrue:[
('oops: nil selectorArray in ' , self name) errorPrintNL.
^ nil
].
index := selectorArray identityIndexOf:aSelector startingAt:1.
(index == 0) ifTrue:[^ nil].
^ methodArray at:index
"
Object compiledMethodAt:#==
(Object compiledMethodAt:#==) category
"
!
sourceCodeAt:aSelector
"return the methods source for given selector aSelector or nil.
Only methods in the receiver - not in the superclass chain are tested."
|method|
method := self compiledMethodAt:aSelector.
method isNil ifTrue:[^ nil].
^ method source
"
True sourceCodeAt:#ifTrue:
Object sourceCodeAt:#==
Behavior sourceCodeAt:#sourceCodeAt:
"
!
lookupMethodFor:aSelector
"return the method, which would be executed if aSelector was sent to
an instance of the receiver. I.e. the selector arrays of the receiver
and all of its superclasses are searched for aSelector.
Return the method, or nil if instances do not understand aSelector.
EXPERIMENTAL: take care of multiple superclasses."
|m cls|
cls := self.
[cls notNil] whileTrue:[
m := cls compiledMethodAt:aSelector.
m notNil ifTrue:[^ m].
cls hasMultipleSuperclasses ifTrue:[
cls superclasses do:[:aSuperClass |
m := aSuperClass lookupMethodFor:aSelector.
m notNil ifTrue:[^ m].
].
^ nil
] ifFalse:[
cls := cls superclass
]
].
^ nil
!
cachedLookupMethodFor:aSelector
"return the method, which would be executed if aSelector was sent to
an instance of the receiver. I.e. the selector arrays of the receiver
and all of its superclasses are searched for aSelector.
Return the method, or nil if instances do not understand aSelector.
This interface provides exactly the same information as #lookupMethodFor:,
but uses the lookup-cache in the VM for faster search.
However, keep in mind, that doing a lookup through the cache also adds new
entries and can thus slow down the system by polluting the cache with
irrelevant entries. (do NOT loop over all objects calling this method).
Does NOT (currently) handle MI"
%{ /* NOCONTEXT */
extern OBJ __lookup();
RETURN ( __lookup(self, aSelector, SENDER) );
%}
"
String cachedLookupMethodFor:#=
String cachedLookupMethodFor:#asOrderedCollection
"
!
hasMethods
"return true, if there are any (local) methods in this class"
^ (methodArray size ~~ 0)
"
True hasMethods
True class hasMethods
"
!
implements:aSelector
"return true, if the receiver implements aSelector.
(i.e. implemented in THIS class - NOT in a superclass).
Dont use this method to check if someone responds to a message -
use #canUnderstand: on the class or #respondsTo: on the instance
to do this."
^ (selectorArray identityIndexOf:aSelector startingAt:1) ~~ 0
"
True implements:#ifTrue:
True implements:#==
"
!
canUnderstand:aSelector
"return true, if the receiver or one of its superclasses implements aSelector.
(i.e. true if my instances understand aSelector)"
^ (self lookupMethodFor:aSelector) notNil
"
True canUnderstand:#ifTrue:
True canUnderstand:#==
True canUnderstand:#do:
"
!
whichClassImplements:aSelector
"obsolete interface;
use whichClassIncludesSelector: for ST-80 compatibility."
^ self whichClassIncludesSelector:aSelector
!
whichClassIncludesSelector:aSelector
"return the class in the inheritance chain, which implements the method
for aSelector; return nil if none.
EXPERIMENTAL: handle multiple superclasses"
|cls|
cls := self.
[cls notNil] whileTrue:[
(cls implements:aSelector) ifTrue:[^ cls].
cls hasMultipleSuperclasses ifTrue:[
cls superclasses do:[:aSuperClass |
|implementingClass|
implementingClass := aSuperClass whichClassIncludesSelector:aSelector.
implementingClass notNil ifTrue:[^ implementingClass].
].
^ nil
] ifFalse:[
cls := cls superclass
]
].
^ nil
"
String whichClassIncludesSelector:#==
String whichClassIncludesSelector:#collect:
"
!
inheritsFrom:aClass
"return true, if the receiver inherits methods from aClass"
^ self isSubclassOf:aClass
"
True inheritsFrom:Object
LinkedList inheritsFrom:Array
"
!
selectorAtMethod:aMethod ifAbsent:failBlock
"return the selector for given method aMethod
or the value of failBlock, if not found."
|index|
index := methodArray identityIndexOf:aMethod startingAt:1.
(index == 0) ifTrue:[^ failBlock value].
^ selectorArray at:index
"
|m|
m := Object compiledMethodAt:#copy.
Object selectorAtMethod:m ifAbsent:['oops'].
"
"
|m|
m := Object compiledMethodAt:#copy.
Fraction selectorAtMethod:m ifAbsent:['oops'].
"
!
selectorAtMethod:aMethod
"Return the selector for given method aMethod."
^ self selectorAtMethod:aMethod ifAbsent:[nil]
"
|m|
m := Object compiledMethodAt:#copy.
Fraction selectorAtMethod:m.
"
"
|m|
m := Object compiledMethodAt:#copy.
Object selectorAtMethod:m.
"
!
containsMethod:aMethod
"Return true, if the argument, aMethod is a method of myself"
methodArray isNil ifTrue:[^ false]. "degenerated class"
^ (methodArray identityIndexOf:aMethod startingAt:1) ~~ 0
! !
!Behavior methodsFor:'private accessing'!
setSuperclass:sup selectors:sels methods:m instSize:i flags:f
"set some inst vars.
this method is for special uses only - there will be no recompilation
and no change record is written here. Also, if the receiver class has
already been in use, future operation of the system is not guaranteed to
be correct, since no caches are flushed.
Therefore: do NOT use it; use Behavior>>superclass: (or flush the caches, at least)"
SubclassInfo := nil.
superclass := sup.
selectorArray := sels.
methodArray := m.
instSize := i.
flags := f
!
setSuperclass:aClass
"set the superclass of the receiver.
this method is for special uses only - there will be no recompilation
and no change record written here. Also, if the receiver class has
already been in use, future operation of the system is not guaranteed to
be correct, since no caches are flushed.
Therefore: do NOT use it; use Behavior>>superclass: (or flush the caches, at least)"
SubclassInfo := nil.
superclass := aClass
!
setOtherSuperclasses:anArrayOfClasses
"EXPERIMENTAL: set the other superclasses of the receiver.
this method is for special uses only - there will be no recompilation
and no change record written here;
Do NOT use it."
SubclassInfo := nil.
otherSuperclasses := anArrayOfClasses
!
instSize:aNumber
"set the instance size.
this method is for special uses only - there will be no recompilation
and no change record written here;
Do NOT use it."
instSize := aNumber
!
flags:aNumber
"set the flags.
this method is for special uses only - there will be no recompilation
and no change record written here;
Do NOT use it."
flags := aNumber
!
setSelectors:sels methods:m
"set some inst vars.
this method is for special uses only - there will be no recompilation
and no change record written here;
Do NOT use it."
selectorArray := sels.
methodArray := m.
!
setSelectorArray:anArray
"set the selector array of the receiver.
this method is for special uses only - there will be no recompilation
and no change record written here.
NOT for general use."
selectorArray := anArray
!
setMethodArray:anArray
"set the method array of the receiver.
this method is for special uses only - there will be no recompilation
and no change record written here.
NOT for general use."
methodArray := anArray
!
setMethodDictionary:aDictionary
"set the receivers method dictionary.
Since no dictionary is actually used, decompose into selector- and
method arrays and set those. For ST-80 compatibility.
NOT for general use."
|n newSelectorArray newMethodArray idx|
n := aDictionary size.
newSelectorArray := Array basicNew:n.
newMethodArray := Array basicNew:n.
idx := 1.
aDictionary keysAndValuesDo:[:sel :method |
newSelectorArray at:idx put:sel.
newMethodArray at:idx put:method.
idx := idx + 1
].
selectorArray := newSelectorArray.
methodArray := newMethodArray
!
primAddSelector:newSelector withMethod:newMethod
"add the method given by 2nd argument under the selector given by
the 1st argument to the methodDictionary.
Does NOT flush any caches, does NOT write a change record.
Do not use this in normal situations, strange behavior will be
the consequence.
I.e. executing obsolete methods, since the old method will still
be executed out of the caches."
|index oldSelectorArray oldMethodArray newSelectorArray newMethodArray|
(newSelector isMemberOf:Symbol) ifFalse:[
self error:'invalid selector'.
^ false
].
newMethod isNil ifTrue:[
self error:'invalid method'.
^ false
].
index := selectorArray identityIndexOf:newSelector startingAt:1.
(index == 0) ifTrue:[
"
a new selector
"
newSelectorArray := selectorArray copyWith:newSelector.
newMethodArray := methodArray copyWith:newMethod.
"
keep a reference so they wont go away ...
mhmh: this is no longer needed - try without
"
oldSelectorArray := selectorArray.
oldMethodArray := methodArray.
selectorArray := newSelectorArray.
methodArray := newMethodArray
] ifFalse:[
methodArray at:index put:newMethod
].
^ true
! !
!Behavior methodsFor:'compiler interface'!
compiler
"return the compiler to use for this class.
OBSOLETE: This is the old ST/X interface, kept for migration.
Dont use it - it will vanish."
^ self compilerClass
!
compilerClass
"return the compiler to use for this class -
this can be redefined in special classes, to get classes with
Lisp, Prolog, ASN1, Basic :-) or whatever syntax."
^ Compiler
!
evaluatorClass
"return the compiler to use for expression evaluation for this class -
this can be redefined in special classes, to get classes with
Lisp, Prolog, ASN1, Basic :-) or whatever syntax."
^ Compiler
! !
!Behavior methodsFor:'enumerating'!
allInstancesDo:aBlock
"evaluate aBlock for all of my instances"
"/ ObjectMemory allObjectsDo:[:anObject |
"/ (anObject class == self) ifTrue:[
"/ aBlock value:anObject
"/ ]
"/ ]
ObjectMemory allInstancesOf:self do:[:anObject |
aBlock value:anObject
]
"
StandardSystemView allInstancesDo:[:v | Transcript showCr:(v name)]
"
!
allDerivedInstancesDo:aBlock
"evaluate aBlock for all of my instances and all instances of subclasses.
This method is going to be removed for protocol compatibility with
other STs; use allSubInstancesDo:"
self obsoleteMethodWarning:'please use #allSubInstancesDo:'.
self allSubInstancesDo:aBlock
"
StandardSystemView allDerivedInstancesDo:[:v | Transcript showCr:(v name)]
"
!
allSubInstancesDo:aBlock
"evaluate aBlock for all of my instances and all instances of subclasses"
ObjectMemory allObjectsDo:[:anObject |
(anObject isKindOf:self) ifTrue:[
aBlock value:anObject
]
]
"
StandardSystemView allSubInstancesDo:[:v | Transcript showCr:(v name)]
"
!
subclassesDo:aBlock
"evaluate the argument, aBlock for all immediate subclasses.
This will only enumerate globally known classes - for anonymous
behaviors, you have to walk over all instances of Behavior."
|coll|
SubclassInfo isNil ifTrue:[
Behavior subclassInfo
].
SubclassInfo notNil ifTrue:[
coll := SubclassInfo at:self ifAbsent:nil.
coll notNil ifTrue:[
coll do:aBlock.
].
^ self
].
Smalltalk allBehaviorsDo:[:aClass |
(aClass superclass == self) ifTrue:[
aBlock value:aClass
]
]
"
Collection subclassesDo:[:c | Transcript showCr:(c name)]
"
!
allSubclassesDo:aBlock
"evaluate aBlock for all of my subclasses.
There is no specific order, in which the entries are enumerated.
This will only enumerate globally known classes - for anonymous
behaviors, you have to walk over all instances of Behavior."
Smalltalk allBehaviorsDo:[:aClass |
(aClass isSubclassOf:self) ifTrue:[
aBlock value:aClass
]
]
"
Collection allSubclassesDo:[:c | Transcript showCr:(c name)]
"
!
allSubclassesInOrderDo:aBlock
"evaluate aBlock for all of my subclasses.
Higher level subclasses will be enumerated before the deeper ones,
so the order in which aBlock gets called is ok to fileOut classes in
correct order for later fileIn.
This will only enumerate globally known classes - for anonymous
behaviors, you have to walk over all instances of Behavior"
self subclassesDo:[:aClass |
aBlock value:aClass.
aClass allSubclassesInOrderDo:aBlock
]
"
Collection allSubclassesInOrderDo:[:c | Transcript showCr:(c name)]
"
!
allSuperclassesDo:aBlock
"evaluate aBlock for all of my superclasses"
|theClass|
theClass := superclass.
[theClass notNil] whileTrue:[
aBlock value:theClass.
theClass := theClass superclass
]
"
String allSuperclassesDo:[:c | Transcript showCr:(c name)]
"
! !
!Behavior methodsFor:'binary storage'!
storeBinaryDefinitionOn: stream manager: manager
"binary store of a classes definition.
Classes will store the name only and restore by looking for
that name in the Smalltalk dictionary."
| myName |
myName := self name.
stream nextNumber:4 put:self signature.
stream nextNumber:2 put:0.
stream nextNumber:2 put:myName size.
myName do:[:c|
stream nextPut:c asciiValue
]
"
|s|
s := WriteStream on:ByteArray new.
#(1 2 3 4) storeBinaryOn:s.
Object readBinaryFrom:(ReadStream on:s contents)
|s|
s := WriteStream on:ByteArray new.
Rectangle storeBinaryOn:s.
Object readBinaryFrom:(ReadStream on:s contents)
"
!
readBinaryFrom:aStream
"read an objects binary representation from the argument,
aStream and return it.
The read object must be a kind of myself, otherwise an error is raised.
To get any object, use 'Object readBinaryFrom:...',
To get any number, use 'Number readBinaryFrom:...' and so on.
This is the reverse operation to 'storeBinaryOn:'. "
^ self readBinaryFrom:aStream onError:[self error:('expected ' , self name)]
"
|s|
s := WriteStream on:(ByteArray new).
#(1 2 3 4) storeBinaryOn:s.
Object readBinaryFrom:(ReadStream on:s contents)
"
"
|s|
s := 'testFile' asFilename writeStream binary.
#(1 2 3 4) storeBinaryOn:s.
'hello world' storeBinaryOn:s.
s close.
s := 'testFile' asFilename readStream binary.
Transcript showCr:(Object readBinaryFrom:s).
Transcript showCr:(Object readBinaryFrom:s).
s close.
"
!
readBinaryFrom:aStream onError:exceptionBlock
"read an objects binary representation from the argument,
aStream and return it.
The read object must be a kind of myself, otherwise the value of
the exceptionBlock is returned.
To get any object, use 'Object readBinaryFrom:...',
To get any number, use 'Number readBinaryFrom:...' and so on.
This is the reverse operation to 'storeBinaryOn:'. "
|newObject|
newObject := (BinaryInputManager new:1024) readFrom:aStream.
(newObject isKindOf:self) ifFalse:[^ exceptionBlock value].
^ newObject
"
|s|
s := WriteStream on:(ByteArray new).
#(1 2 3 4) storeBinaryOn:s.
Object readBinaryFrom:(ReadStream on:s contents) onError:['oops']
"
"
|s|
s := WriteStream on:(ByteArray new).
#[1 2 3 4] storeBinaryOn:s.
Array readBinaryFrom:(ReadStream on:s contents) onError:['oops']
"
!
binaryDefinitionFrom:stream manager:manager
"sent during a binary read by the input manager.
Read the definition on an empty instance (of my class) from stream.
All pointer instances are left nil, while all bits are read in here.
return the new object."
|obj t
basicSize "{ Class: SmallInteger }" |
self isPointers ifTrue: [
"/
"/ inst size not needed - if you uncomment the line below,
"/ also uncomment the corresponding line in
"/ Object>>storeBinaryDefinitionOn:manager:
"/
"/ stream next. "skip instSize"
self isVariable ifTrue: [
^ self basicNew:(stream nextNumber:3)
].
^ self basicNew
].
"
an object with bit-valued instance variables.
These are read here.
"
basicSize := stream nextNumber:4.
obj := self basicNew:basicSize.
self isBytes ifTrue: [
stream nextBytes:basicSize into:obj
] 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: [
"could do it in one big read on machines which use IEEE floats ..."
t := Float basicNew.
1 to:basicSize do:[:i |
Float readBinaryIEEESingleFrom:stream into:t.
obj basicAt:i put: t
]
] ifFalse:[
self isDoubles ifTrue: [
"could do it in one big read on machines which use IEEE doubles ..."
t := Float basicNew.
1 to:basicSize do:[:i |
Float readBinaryIEEEDoubleFrom:stream into:t.
obj basicAt:i put: t
]
]
]
]
]
].
^obj
!
canCloneFrom:anObject
"return true, if this class can clone an obsolete object as retrieved
by a binary load. Subclasses which do not want to have obsolete objects
be converted, should redefine this method to return false.
(However, conversion is never done silently in a binary load; you
have to have a handler for the binaryload errors and for the conversion
request signal.)"
^ true
!
cloneFrom:aPrototype
"return an instance of myself with variables initialized from
a prototype. This is used when instances of obsolete classes are
binary loaded and a conversion is done on the obsolete object.
UserClasses may redefine this for better conversions."
|newInst indexed myInfo otherInfo varIndexAssoc|
indexed := false.
aPrototype class isVariable ifTrue:[
self isVariable ifTrue:[
indexed := true.
].
"otherwise, these are lost ..."
].
indexed ifTrue:[
newInst := self basicNew:aPrototype basicSize
] ifFalse:[
newInst := self basicNew
].
myInfo := self instanceVariableOffsets.
otherInfo := aPrototype class instanceVariableOffsets.
myInfo keysAndValuesDo:[:name :index |
varIndexAssoc := otherInfo at:name ifAbsent:[].
varIndexAssoc notNil ifTrue:[
newInst instVarAt:index put:(aPrototype instVarAt:(varIndexAssoc value))
]
].
indexed ifTrue:[
1 to:aPrototype basicSize do:[:index |
newInst basicAt:index put:(aPrototype basicAt:index)
].
].
^ newInst
"
Class updateChanges:false.
Point subclass:#Point3D
instanceVariableNames:'z'
classVariableNames:''
poolDictionaries:''
category:'testing'.
(Point3D cloneFrom:1@2) inspect.
Class updateChanges:true.
"
"
Class updateChanges:false.
Point variableSubclass:#Point3D
instanceVariableNames:'z'
classVariableNames:''
poolDictionaries:''
category:'testing'.
(Point3D cloneFrom:#(1 2 3)) inspect.
Class updateChanges:true.
"
"
|someObject|
Class updateChanges:false.
Object subclass:#TestClass1
instanceVariableNames:'foo bar'
classVariableNames:''
poolDictionaries:''
category:'testing'.
someObject := TestClass1 new.
someObject instVarAt:1 put:'foo'; instVarAt:2 put:'bar'.
Object subclass:#TestClass2
instanceVariableNames:'bar foo'
classVariableNames:''
poolDictionaries:''
category:'testing'.
(TestClass2 cloneFrom:someObject) inspect.
Class updateChanges:true.
"
! !