"
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.
"
nil subclass:#Object
instanceVariableNames:''
classVariableNames:'ErrorSignal HaltSignal MessageNotUnderstoodSignal
UserInterruptSignal RecursionInterruptSignal
ExceptionInterruptSignal SubscriptOutOfBoundsSignal
IndexNotFoundSignal NonIntegerIndexSignal NotFoundSignal
KeyNotFoundSignal ElementOutOfBoundsSignal UserNotificationSignal
InformationSignal WarningSignal PrimitiveFailureSignal
DeepCopyErrorSignal AbortSignal ErrorRecursion Dependencies
InfoPrinting ActivityNotificationSignal InternalErrorSignal
NonWeakDependencies SynchronizationSemaphores ObjectAttributes
OSSignalInterruptSignal'
poolDictionaries:''
category:'Kernel-Objects'
!
!Object 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.
"
!
dependencies
"
ST/X dependencies are slightly modified from ST-80's
(we think they are better ;-).
One problem occuring very often in ST-80 is that some object
cannot be garbage collected because some dependency is present,
having the object as a dependent of some other object.
In ST-80, this association remains alive (because a Dictionary
is used to hold dependents) - even if no other references exist to
to dependent or the dependee.
This means, that in ST-80, a #release is mandatory in order to
prevent memory leaks.
We think, that this is a bad solution, since after all, exactly that
kind of work should be performed by a garbage collector - you should not
need to care about dependencies.
From a philosophical point of view, why should some object depend on
something that the programmer considers a dead object ?
(well - worse than that: it seems that some ST-80 code even depends on
that behavior)
In order to limit the trouble, ST-80 reimplemented the way dependents
are stored in the model class - this one keeps the dependents locally,
so these dependents go away, once the model is reclaimed.
That may make things even more confusing: with models, no #release is
needed, with general objects it is mandatory.
In ST/X, dependencies are implemented using a WeakDictionary; this means,
that once the dependee dies, the dependency association is removed automatically,
and the dependent can be reclaimed by the garbage collector, if no other
references exist to the dependent.
In order to (at least) provide a mechanism for the old behavior
(in case your application heavily depends on the ST-80 mechanism), complementary
protocol to add nonWeak dependencies is provided
(see #addNonWeakDependent / #removeNonWeakDependent).
Caveat:
since interests are implemented using InterestConverter (which are simply
forwarding messages), these must use the nonWeak mechanism (as done in ST-80
automatically).
The reason is that there are usually no direct references to the converters,
and those would be reclaimed if stored in a weakDictionary.
This means, that those interests MUST be removed with #retractInterest
(which is bug-compatible to ST-80).
We rewrite things to provide a more convenient mechanism in the future ...
I like to hear comments on the above - do you think its better ?
"
!
documentation
"
Object is the superclass of most other classes.
(except for nil-subclasses, which inherit nothing,
to catch any message into their #doesNotUnderstand: method)
Protocol which is common to every object is defined here.
Also some utility stuff (like notify) and error handling is implemented here.
Object has no instance variables (and may not get any added). One reason is, that
UndefinedObject and SmallInteger are also inheriting from Object - these two cannot
have instance variables (due to their implementation).
The other reason is that the runtime system (VM) knows about the layout of some built-in
classes (think of Class, Method, Block and also Integer or Float).
If you were allowed to add instance variables to Object, the VM had to be recompiled
(and also rewritten in some places).
[Class variables:]
ErrorSignal <Signal> Signal raised for error/error: messages
also, parent of all other signals.
HaltSignal <Signal> Signal raised for halt/halt: messages
MessageNotUnderstoodSignal Signals raised for various error conditions
UserInterruptSignal
RecursionInterruptSignal
ExceptionInterruptSignal
SubscriptOutOfBoundsSignal
NonIntegerIndexSignal
NotFoundSignal
KeyNotFoundSignal
ElementOutOfBoundsSignal
InformationSignal
WarningSignal
DeepCopyErrorSignal
InternalErrorSignal
AbortSignal <Signal> Signal raised by debugger, to abort a computation
BUT, the debugger will only raise it if it is handled.
By handling the abortSignal, you can control where the
debuggers abort-function resumes execution in case of
an error.
ErrorRecursion <Boolean> controls behavior when recursive errors occur (i.e.
an error while handling an error).
Dependencies <WeakDependencyDictionary>
keeps track of object dependencies.
InfoPrinting <Boolean> controls weather informational messages
are printed.
ActivityNotificationSignal <QuerySignal>
raised on #activityNotification:
NonWeakDependencies <Dictionary> keeps track of object dependencies.
Dependents stay alive.
SynchronizationSemaphores <WeakIdentityDictionary>
Semaphores for per-object-monitor.
[author:]
Claus Gittinger
"
! !
!Object class methodsFor:'initialization'!
initialize
"called only once - initialize signals"
ErrorSignal isNil ifTrue:[
"/ have a chicken & egg problem here;
"/ signal wants object to be initialized,
"/ Object needs the genericSignal from Signal.
"/ So, make certain that on exists here.
Signal initGenericSignal.
ErrorSignal := Signal genericSignal newSignalMayProceed:true.
ErrorSignal nameClass:self message:#errorSignal.
ErrorSignal notifierString:'error encountered'.
HaltSignal := ErrorSignal newSignalMayProceed:true.
HaltSignal nameClass:self message:#haltSignal.
HaltSignal notifierString:'halt encountered'.
MessageNotUnderstoodSignal := ErrorSignal newSignalMayProceed:true.
MessageNotUnderstoodSignal nameClass:self message:#messageNotUnderstoodSignal.
MessageNotUnderstoodSignal notifierString:'message not understood'.
PrimitiveFailureSignal := ErrorSignal newSignalMayProceed:true.
PrimitiveFailureSignal nameClass:self message:#primitiveFailureSignal.
PrimitiveFailureSignal notifierString:'primitive failed'.
InternalErrorSignal := ErrorSignal newSignalMayProceed:false.
InternalErrorSignal nameClass:self message:#internalError.
InternalErrorSignal notifierString:'VM internal error: '.
"/ UserInterruptSignal := ErrorSignal newSignalMayProceed:true.
UserInterruptSignal := (Signal new) mayProceed:true.
UserInterruptSignal nameClass:self message:#userInterruptSignal.
UserInterruptSignal notifierString:'user Interrupt'.
"/ RecursionInterruptSignal := ErrorSignal newSignalMayProceed:false.
RecursionInterruptSignal := (Signal new) mayProceed:true.
RecursionInterruptSignal nameClass:self message:#recursionInterruptSignal.
RecursionInterruptSignal notifierString:'recursion limit reached'.
ExceptionInterruptSignal := ErrorSignal newSignalMayProceed:true.
ExceptionInterruptSignal nameClass:self message:#exceptionInterruptSignal.
ExceptionInterruptSignal notifierString:'exception Interrupt'.
NotFoundSignal := ErrorSignal newSignalMayProceed:true.
NotFoundSignal nameClass:self message:#notFoundSignal.
NotFoundSignal notifierString:'no such element'.
IndexNotFoundSignal := NotFoundSignal newSignalMayProceed:false.
IndexNotFoundSignal nameClass:self message:#indexNotFoundSignal.
IndexNotFoundSignal notifierString:'bad index: '.
SubscriptOutOfBoundsSignal := IndexNotFoundSignal newSignalMayProceed:false.
SubscriptOutOfBoundsSignal nameClass:self message:#subscriptOutOfBoundsSignal.
SubscriptOutOfBoundsSignal notifierString:'subscript out of bounds: '.
ElementOutOfBoundsSignal := ErrorSignal newSignalMayProceed:false.
ElementOutOfBoundsSignal nameClass:self message:#elementOutOfBoundsSignal.
ElementOutOfBoundsSignal notifierString:'element not appropriate or out of bounds'.
KeyNotFoundSignal := NotFoundSignal newSignalMayProceed:true.
KeyNotFoundSignal nameClass:self message:#keyNotFoundSignal.
KeyNotFoundSignal notifierString:'no such key: '.
NonIntegerIndexSignal := IndexNotFoundSignal newSignalMayProceed:false.
NonIntegerIndexSignal nameClass:self message:#nonIntegerIndexSignal.
NonIntegerIndexSignal notifierString:'index must be integer'.
UserNotificationSignal := QuerySignal new.
UserNotificationSignal nameClass:self message:#userNotificationSignal.
UserNotificationSignal notifierString:'user notifiaction wanted'.
InformationSignal := UserNotificationSignal newSignalMayProceed:true.
InformationSignal nameClass:self message:#informationSignal.
InformationSignal notifierString:'information'.
WarningSignal := UserNotificationSignal newSignalMayProceed:true.
WarningSignal nameClass:self message:#warnungSignal.
WarningSignal notifierString:'warning'.
ActivityNotificationSignal := UserNotificationSignal newSignalMayProceed:true.
ActivityNotificationSignal nameClass:self message:#activityNotificationSignal.
ActivityNotificationSignal notifierString:'activity'.
DeepCopyErrorSignal := ErrorSignal newSignalMayProceed:true.
DeepCopyErrorSignal nameClass:self message:#deepCopyErrorSignal.
DeepCopyErrorSignal notifierString:'object cannot be deepCopy-ed'.
"
AbortSignal is not a child of ErrorSignal -
this would complicate abort from within a signal handler
"
AbortSignal := Signal genericSignal newSignalMayProceed:true.
AbortSignal nameClass:self message:#abortSignal.
AbortSignal notifierString:'unhandled abort signal'.
"
OSSignalInterruptSignal is not a child of ErrorSignal -
it requires explicit catching.
If unhandled, a debugger is entered.
"
OSSignalInterruptSignal := Signal genericSignal newSignalMayProceed:true.
OSSignalInterruptSignal nameClass:self message:#osSignalInterruptSignal.
OSSignalInterruptSignal notifierString:'OS signal interrupt'.
ObjectAttributes isNil ifTrue:[
ObjectAttributes := WeakIdentityDictionary new.
].
Dependencies isNil ifTrue:[
Dependencies := WeakDependencyDictionary new.
].
NonWeakDependencies isNil ifTrue:[
NonWeakDependencies := IdentityDictionary new.
].
SynchronizationSemaphores isNil ifTrue:[
SynchronizationSemaphores := WeakIdentityDictionary new.
].
].
"/ initialize InfoPrinting to the VM's infoPrint setting
"/ (which can be turned off via a command line argument)
InfoPrinting := ObjectMemory infoPrinting.
"Object initialize"
"Modified: / 28.1.1997 / 19:38:58 / stefan"
"Modified: / 22.1.1998 / 21:23:40 / av"
"Modified: / 3.2.1998 / 18:55:09 / cg"
! !
!Object class methodsFor:'ST80 compatibility'!
rootError
"return the signal used for error/error: - handling.
Same as errorSignal for ST80 compatibility."
^ ErrorSignal
"Created: / 15.1.1998 / 23:47:05 / stefan"
! !
!Object class methodsFor:'Signal constants'!
abortSignal
"return the signal used to abort user actions. This signal is only
raised if caught (by the debugger), and will lead way out of the
currently active doIt/printIt or inspectIt. (also some others use
this for a save abort)"
^ AbortSignal
!
activityNotificationSignal
"return the signal used for activity notifications.
A handler for this signal gets all #activityNotification: sends"
^ ActivityNotificationSignal
!
deepCopyErrorSignal
"return the signal raised when a deepcopy is asked for
an object which cannot do this (for example, BlockClosures
or Contexts)."
^ DeepCopyErrorSignal
!
elementOutOfBoundsSignal
"return the signal used for element error reporting
(this signal is used for example when a value not in 0..255 is to
be put into a bytearray)"
^ ElementOutOfBoundsSignal
!
errorSignal
"return the signal used for error/error: - handling"
^ ErrorSignal
!
exceptionInterruptSignal
"return the signal used for exception (display errors) error handling"
^ ExceptionInterruptSignal
!
haltSignal
"return the signal used for halt/halt: - handling"
^ HaltSignal
!
indexNotFoundSignal
"return the signal used for bad index error reporting.
This is also the parentSignal of the nonIntegerIndex- and
subscriptOutOfBoundsSignal"
^ IndexNotFoundSignal
"Created: / 8.11.1997 / 19:15:48 / cg"
!
informationSignal
"return the signal used for informations.
A handler for this signal gets all #information: sends"
^ InformationSignal
!
internalErrorSignal
"return the signal used to report internal (VM-) errors."
^ InternalErrorSignal
!
keyNotFoundSignal
"return the signal used for no such key error reporting"
^ KeyNotFoundSignal
!
messageNotUnderstoodSignal
"return the signal used for doesNotUnderstand: - error handling"
^ MessageNotUnderstoodSignal
!
nonIntegerIndexSignal
"return the signal used for bad subscript error reporting"
^ NonIntegerIndexSignal
!
notFoundSignal
"return the signal used for no element found error reporting"
^ NotFoundSignal
!
osSignalInterruptSignal
"return the signal used for OS-signal error reporting;
This is only raised if handled - otherwise, a debugger is entered."
^ OSSignalInterruptSignal
"Modified: / 12.6.1998 / 16:27:26 / cg"
!
primitiveFailureSignal
"return the signal used for primitiveFailed - error handling"
^ PrimitiveFailureSignal
!
privateMethodSignal
"return the signal used for privateMethod - error handling"
^ MessageNotUnderstoodSignal
!
recursionInterruptSignal
"return the signal used for recursion overflow error handling"
^ RecursionInterruptSignal
!
subscriptOutOfBoundsSignal
"return the signal used for subscript error reporting.
(this signal is used for example when an array is accessed with an
index less than 1 or greater than the array size)"
^ SubscriptOutOfBoundsSignal
!
userInterruptSignal
"return the signal used for ^C interrupts handling"
^ UserInterruptSignal
!
userNotificationSignal
"the parent signal used with information and warnings.
Handling this allows handling of both information- and warning notifications."
^ UserNotificationSignal
!
warningSignal
"return the signal used for warnings.
A handler for this signal gets all #warn: sends"
^ WarningSignal
! !
!Object class methodsFor:'info messages'!
infoPrinting
"return the flag which controls information messages."
^ InfoPrinting
!
infoPrinting:aBoolean
"{ Pragma: +optSpace }"
"turn on/off printing of information messages.
If the argument, aBoolean is false, infoPrint will not output
messages. The default is true."
InfoPrinting := aBoolean
! !
!Object class methodsFor:'queries'!
isBuiltInClass
"return true, if this class is known by the run-time-system,
i.e. you cannot add/remove instance variables without recompiling
the VM.
Here, true is returned for myself, false for subclasses."
^ self == Object
"Modified: 23.4.1996 / 16:00:07 / cg"
! !
!Object methodsFor:'accessing'!
at:index
"return the indexed instance variable with index, anInteger;
this method can be redefined in subclasses."
^ self basicAt:index
!
at:index put:anObject
"store the 2nd arg, anObject as indexed instvar with index, anInteger.
this method can be redefined in subclasses. Returns anObject (sigh)"
^ self basicAt:index put:anObject
"Modified: 19.4.1996 / 11:13:29 / cg"
!
basicAt:index
"return the indexed instance variable with index, anInteger.
Trigger an error if the receiver has no indexed instance variables.
This method should NOT be redefined in any subclass (except with great care, for tuning)"
%{ /* NOCONTEXT */
REGISTER int nbytes, indx;
OBJ myClass;
REGISTER char *pFirst;
unsigned char *cp;
unsigned short *sp;
short *ssp;
#ifdef alpha64
# define int32 int
#else
# define int32 long
#endif
unsigned int32 *lp;
int32 *slp;
unsigned int32 ul;
int32 l;
OBJ *op;
REGISTER int n;
/*
* notice the missing test for self being a nonNilObject -
* this can be done since basicAt: is defined both in UndefinedObject
* and SmallInteger
*/
if (__isSmallInteger(index)) {
myClass = __qClass(self);
indx = __intVal(index) - 1;
n /* nInstVars */ = __intVal(__ClassInstPtr(myClass)->c_ninstvars);
n /* nInstBytes */ = OHDR_SIZE + __OBJS2BYTES__(n /* nInstVars */);
nbytes = __qSize(self) - n /* nInstBytes */;
pFirst = (char *)(__InstPtr(self)) + n /* nInstBytes */;
switch ((INT)(__ClassInstPtr(myClass)->c_flags) & __MASKSMALLINT(ARRAYMASK)) {
case __MASKSMALLINT(POINTERARRAY):
case __MASKSMALLINT(WKPOINTERARRAY):
/*
* pointers
*/
if ((indx >= 0) && (indx < (__BYTES2OBJS__(nbytes)))) {
op = (OBJ *)pFirst + indx;
RETURN ( *op );
}
break;
case __MASKSMALLINT(BYTEARRAY):
/*
* (unsigned) bytes
*/
if ((indx >= 0) && (indx < (nbytes / sizeof(char)))) {
cp = (unsigned char *)pFirst + indx;
RETURN ( __MKSMALLINT(*cp & 0xFF) );
}
break;
case __MASKSMALLINT(FLOATARRAY):
/*
* native floats
*/
if ((indx >= 0) && (indx < (nbytes / sizeof(float)))) {
float *fp;
OBJ v;
fp = (float *)pFirst + indx;
__qMKSFLOAT(v, *fp);
RETURN (v);
}
break;
case __MASKSMALLINT(DOUBLEARRAY):
/*
* native doubles
*/
if ((indx >= 0) && (indx < (nbytes / sizeof(double)))) {
double *dp;
OBJ v;
#ifdef NEED_DOUBLE_ALIGN
/*
* care for filler
*/
pFirst += sizeof(FILLTYPE);
#endif
dp = (double *)pFirst + indx;
__qMKFLOAT(v, *dp);
RETURN (v);
}
break;
case __MASKSMALLINT(WORDARRAY):
/*
* unsigned 16bit ints
*/
if ((indx >= 0) && (indx < (nbytes / sizeof(short)))) {
sp = (unsigned short *)pFirst + indx;
RETURN ( __MKSMALLINT(*sp & 0xFFFF) );
}
break;
case __MASKSMALLINT(SWORDARRAY):
/*
* signed 16bit ints
*/
if ((indx >= 0) && (indx < (nbytes / sizeof(short)))) {
ssp = (short *)pFirst + indx;
RETURN ( __MKSMALLINT(*ssp) );
}
break;
case __MASKSMALLINT(LONGARRAY):
/*
* unsigned native 32bit ints
*/
if ((indx >= 0) && (indx < (nbytes / sizeof(int32)))) {
lp = (unsigned int32 *)pFirst + indx;
ul = *lp;
if (ul <= _MAX_INT)
RETURN ( __MKSMALLINT(ul) );
RETURN ( __MKULARGEINT(ul) );
}
break;
case __MASKSMALLINT(SLONGARRAY):
/*
* signed native 32bit ints
*/
if ((indx >= 0) && (indx < (nbytes / sizeof(int32)))) {
slp = (int32 *)pFirst + indx;
l = *slp;
if ((l >= _MIN_INT) && (l <= _MAX_INT))
RETURN ( __MKSMALLINT(l) );
RETURN ( __MKLARGEINT(l) );
}
break;
}
}
# undef int32
%}.
index isInteger ifFalse:[
^ self indexNotInteger
].
^ self subscriptBoundsError:index
!
basicAt:index put:anObject
"store the 2nd arg, anObject as indexed instvar with index, anInteger.
Returns anObject (sigh).
Trigger an error if the receiver has no indexed instance variables.
This method should NOT be redefined in any subclass (except with great care, for tuning)"
%{ /* NOCONTEXT */
register int nbytes, indx;
OBJ myClass;
register char *pFirst;
char *cp;
unsigned short *sp;
short *ssp;
#ifdef alpha64
# define int32 int
#else
# define int32 long
#endif
unsigned int32 *lp;
int32 *slp;
OBJ *op;
/* int nInstBytes, ninstvars, flags; */
REGISTER int n;
unsigned int u;
int val;
/* notice the missing test for self being a nonNilObject -
this can be done since basicAt: is defined both in UndefinedObject
and SmallInteger */
if (__isSmallInteger(index)) {
indx = __intVal(index) - 1;
myClass = __qClass(self);
n /* ninstvars */ = __intVal(__ClassInstPtr(myClass)->c_ninstvars);
n /* nInstBytes */ = OHDR_SIZE + __OBJS2BYTES__(n /* ninstvars */);
nbytes = __qSize(self) - n /* nInstBytes */;
pFirst = (char *)(__InstPtr(self)) + n /* nInstBytes */;
switch ((INT)(__ClassInstPtr(myClass)->c_flags) & __MASKSMALLINT(ARRAYMASK)) {
case __MASKSMALLINT(POINTERARRAY):
case __MASKSMALLINT(WKPOINTERARRAY):
if ((indx >= 0) && (indx < (__BYTES2OBJS__(nbytes)))) {
op = (OBJ *)pFirst + indx;
*op = anObject;
__STORE(self, anObject);
RETURN ( anObject );
}
break;
case __MASKSMALLINT(BYTEARRAY):
if (__isSmallInteger(anObject)) {
val = __intVal(anObject);
if ((val & ~0xFF) == 0 /* i.e. (val >= 0) && (val <= 255) */) {
if ((indx >= 0) && (indx < (nbytes / sizeof(char)))) {
cp = pFirst + indx;
*cp = val;
RETURN ( anObject );
}
}
}
break;
case __MASKSMALLINT(FLOATARRAY):
if ((indx >= 0) && (indx < (nbytes / sizeof(float)))) {
float *fp;
fp = (float *)pFirst + indx;
if (__isFloatLike(anObject)) {
*fp = (float)(__floatVal(anObject));
RETURN ( anObject );
}
if (__isSmallInteger(anObject)) {
*fp = (float) __intVal(anObject);
RETURN ( anObject );
}
if (__isShortFloat(anObject)) {
*fp = __shortFloatVal(anObject);
RETURN ( anObject );
}
}
break;
case __MASKSMALLINT(DOUBLEARRAY):
if ((indx >= 0) && (indx < (nbytes / sizeof(double)))) {
double *dp;
#ifdef NEED_DOUBLE_ALIGN
/*
* care for filler
*/
pFirst += sizeof(FILLTYPE);
#endif
dp = (double *)pFirst + indx;
if (__isFloatLike(anObject)) {
*dp = __floatVal(anObject);
RETURN ( anObject );
}
if (__isSmallInteger(anObject)) {
*dp = (double) __intVal(anObject);
RETURN ( anObject );
}
if (__isShortFloat(anObject)) {
*dp = (double)__shortFloatVal(anObject);
RETURN ( anObject );
}
}
break;
case __MASKSMALLINT(WORDARRAY):
if (__isSmallInteger(anObject)) {
val = __intVal(anObject);
if ((val >= 0) && (val <= 0xFFFF)) {
if ((indx >= 0) && (indx < (nbytes / sizeof(short)))) {
sp = (unsigned short *)pFirst + indx;
*sp = val;
RETURN ( anObject );
}
}
}
break;
case __MASKSMALLINT(SWORDARRAY):
if (__isSmallInteger(anObject)) {
val = __intVal(anObject);
if ((val >= -32768) && (val < 32768)) {
if ((indx >= 0) && (indx < (nbytes / sizeof(short)))) {
ssp = (short *)pFirst + indx;
*ssp = val;
RETURN ( anObject );
}
}
}
break;
case __MASKSMALLINT(SLONGARRAY):
if ((indx >= 0) && (indx < (nbytes / sizeof(int32)))) {
slp = (int32 *)pFirst + indx;
if (__isSmallInteger(anObject)) {
*slp = __intVal(anObject);
RETURN ( anObject );
}
n = __signedLongIntVal(anObject);
/*
* zero means failure for an int larger than 4 bytes
* (would be a smallInteger)
*/
if (n) {
*slp = n;
RETURN ( anObject );
}
}
break;
case __MASKSMALLINT(LONGARRAY):
if ((indx >= 0) && (indx < (nbytes / sizeof(int32)))) {
lp = (unsigned int32 *)pFirst + indx;
if (anObject == __MKSMALLINT(0)) {
*lp = 0;
RETURN ( anObject );
}
u = __longIntVal(anObject);
/*
* zero means failure for an int larger than 4 bytes
* (would be a smallInteger)
*/
if (u) {
*lp = u;
RETURN ( anObject );
}
}
break;
}
}
# undef int32
%}.
index isInteger ifFalse:[
"
the index should be an integer number
"
^ self indexNotInteger
].
(index between:1 and:self size) ifFalse:[
"
the index is less than 1 or greater than the size of the
receiver collection
"
^ self subscriptBoundsError:index
].
(self class isFloatsOrDoubles) ifTrue:[
anObject isNumber ifTrue:[
^ self basicAt:index put:(anObject asFloat)
]
].
anObject isInteger ifFalse:[
"
the object to put into the receiver collection
should be an integer number
"
^ self elementNotInteger
].
"
the object to put into the receiver collection
is not an instance of the expected element class,
or the value is not within the elements valid range.
"
^ self elementBoundsError
"Modified: 19.4.1996 / 11:14:10 / cg"
!
byteAt:index
"return the byte at index.
This is only allowed for non-pointer indexed objects
(i.e. byteArrays, wordArrays, floatArrays etc.).
The receivers indexed instvars are treated as an uninterpreted
collection of bytes.
Only useful with binary storage."
%{ /* NOCONTEXT */
REGISTER int indx;
int nIndex;
REGISTER OBJ slf;
REGISTER OBJ cls;
if (__isSmallInteger(index)) {
slf = self;
if (__isNonNilObject(slf)) {
cls = __qClass(slf);
switch ((INT)(__ClassInstPtr(cls)->c_flags) & __MASKSMALLINT(ARRAYMASK)) {
case __MASKSMALLINT(BYTEARRAY):
case __MASKSMALLINT(WORDARRAY):
case __MASKSMALLINT(LONGARRAY):
case __MASKSMALLINT(SWORDARRAY):
case __MASKSMALLINT(SLONGARRAY):
case __MASKSMALLINT(FLOATARRAY):
case __MASKSMALLINT(DOUBLEARRAY):
indx = __intVal(index) - 1;
indx += __OBJS2BYTES__(__intVal(__ClassInstPtr(cls)->c_ninstvars));
nIndex = __byteArraySize(slf);
if ((unsigned)indx < (unsigned)nIndex) {
RETURN ( __MKSMALLINT(__ByteArrayInstPtr(slf)->ba_element[indx]) );
}
break;
}
}
}
%}.
"/ index not integer or index out of range
"/ or non-byte indexable receiver
^ self primitiveFailed
"
Point new byteAt:1
(ByteArray with:1 with:2) byteAt:2
(WordArray with:1) byteAt:1
(FloatArray with:1.0) byteAt:2
'hello' byteAt:1
"
!
byteAt:index put:byteValue
"set the byte at index.
This is only allowed for non-pointer indexed objects
(i.e. byteArrays, wordArrays, floatArrays etc.).
The receivers indexed instvars are treated as an uninterpreted
collection of bytes.
Only useful with binary storage."
%{ /* NOCONTEXT */
REGISTER int indx;
int val, nIndex;
REGISTER OBJ slf;
REGISTER OBJ cls;
if (__bothSmallInteger(index, byteValue)) {
val = __intVal(byteValue);
if ((unsigned)(val) <= 0xFF /* i.e. (val >= 0) && (val <= 255) */) {
slf = self;
if (__isNonNilObject(slf)) {
cls = __qClass(slf);
switch ((INT)(__ClassInstPtr(cls)->c_flags) & __MASKSMALLINT(ARRAYMASK)) {
case __MASKSMALLINT(BYTEARRAY):
case __MASKSMALLINT(WORDARRAY):
case __MASKSMALLINT(LONGARRAY):
case __MASKSMALLINT(SWORDARRAY):
case __MASKSMALLINT(SLONGARRAY):
case __MASKSMALLINT(FLOATARRAY):
case __MASKSMALLINT(DOUBLEARRAY):
indx = __intVal(index) - 1;
indx += __OBJS2BYTES__(__intVal(__ClassInstPtr(cls)->c_ninstvars));
nIndex = __byteArraySize(slf);
if ((unsigned)indx < (unsigned)nIndex) {
__ByteArrayInstPtr(slf)->ba_element[indx] = val;
RETURN ( byteValue );
}
break;
}
}
}
}
%}.
"/ index not integer or index out of range
"/ or non-byte indexable receiver
^ self primitiveFailed
"
(ByteArray with:1 with:2) byteAt:2 put:3; yourself
'hello' copy byteAt:1 put:105; yourself
"
!
instVarAt:index
"return a non-indexed instance variable;
peeking into an object this way is not very object oriented
- use with care (needed for copy, inspector etc.)"
%{ /* NOCONTEXT */
OBJ myClass;
int idx, ninstvars;
if (__isSmallInteger(index)) {
myClass = __Class(self);
idx = __intVal(index) - 1;
/*
* do not allow return of non-object fields.
* if subclass did not make privisions for that,
* we wont do so here ...
*/
if (((INT)(__ClassInstPtr(myClass)->c_flags) & __MASKSMALLINT(NONOBJECT_INSTS))) {
if (idx == 0) {
RETURN ( nil )
}
}
ninstvars = __intVal(__ClassInstPtr(myClass)->c_ninstvars);
if ((idx >= 0) && (idx < ninstvars)) {
RETURN ( __InstPtr(self)->i_instvars[idx] );
}
}
%}
.
index isInteger ifFalse:[
^ self indexNotInteger
].
^ self subscriptBoundsError:index
!
instVarAt:index put:value
"change a non-indexed instance variable;
peeking into an object this way is not very object oriented
- use with care (needed for copy, inspector etc.)"
%{ /* NOCONTEXT */
OBJ myClass;
int idx, ninstvars;
if (__isSmallInteger(index)) {
myClass = __Class(self);
idx = __intVal(index) - 1;
ninstvars = __intVal(__ClassInstPtr(myClass)->c_ninstvars);
/*
* do not allow setting of non-object fields.
* if subclass did not make privisions for that,
* we wont do so here ...
*/
if (((INT)(__ClassInstPtr(myClass)->c_flags) & __MASKSMALLINT(NONOBJECT_INSTS))) {
if (idx == 0) {
RETURN ( nil )
}
}
if ((idx >= 0) && (idx < ninstvars)) {
__InstPtr(self)->i_instvars[idx] = value;
__STORE(self, value);
RETURN ( value );
}
}
%}
.
index isInteger ifFalse:[
^ self indexNotInteger
].
^ self subscriptBoundsError:index
!
instVarNamed:name
"return a non-indexed instance variables value by name;
peeking into an object this way is not very object oriented
- use with care if at all (provided for inspectors and memory usage monitor).
Notice, this access is very slow (because the classes instVar-description has to be
parsed ad runtime)"
^ self instVarAt:(self class instVarOffsetOf:name)
"
|p|
p := Point x:10 y:20.
p instVarNamed:'x'
"
"Modified: 19.4.1996 / 11:12:39 / cg"
!
instVarNamed:name ifAbsent:exceptionBlock
"return a non-indexed instance variables value by name,
or the value of exceptionBlock, if there is no such instance variable.
peeking into an object this way is not very object oriented
- use with care if at all (provided for inspectors and memory usage monitor).
Notice, this access is very slow (because the classes instVar-description has to be
parsed ad runtime)"
|idx|
idx := self class instVarOffsetOf:name.
idx isNil ifTrue:[^ exceptionBlock value].
^ self instVarAt:idx
"
|p|
p := Point x:10 y:20.
p instVarNamed:'x'
"
"Created: 6.7.1996 / 23:02:49 / cg"
"Modified: 6.7.1996 / 23:03:41 / cg"
!
instVarNamed:name put:value
"set a non-indexed instance variable by name;
peeking into an object this way is not very object oriented
- if at all, use with care (provided for protocol completeness).
Notice, this access is very slow (because the classes instVar-description has to be
parsed ad runtime)"
^ self instVarAt:(self class instVarOffsetOf:name) put:value
"
|p|
p := Point x:10 y:20.
p instVarNamed:'x' put:30.
p
"
"Modified: 19.4.1996 / 11:12:49 / cg"
! !
!Object methodsFor:'attributes access'!
objectAttributeAt:key
"return the attribute for a given key or nil if not found"
| attrs |
attrs := self objectAttributes.
(attrs notNil and:[attrs size > 0]) ifTrue:[
^ attrs at:key ifAbsent:[]
].
^ nil
"Created: / 22.1.1998 / 21:29:17 / av"
"Modified: / 3.2.1998 / 18:55:55 / cg"
!
objectAttributeAt:key put:anObject
"store the attribute anObject referenced by key into the receiver"
|wasBlocked|
"/ must do this save from interrupts, since the attributes collection
"/ is possibly accessed from multiple threads ...
wasBlocked := OperatingSystem blockInterrupts.
[
| attrs |
attrs := self objectAttributes.
(attrs isNil or:[attrs size == 0]) ifTrue:[
attrs := WeakIdentityDictionary new.
attrs at:key put:anObject.
self objectAttributes:attrs.
] ifFalse:[
attrs at:key put:anObject.
].
] valueNowOrOnUnwindDo:[
wasBlocked ifFalse:[
OperatingSystem unblockInterrupts
]
]
"Attaching additional attributes (slots) to an arbitrary object:
|p|
p := Point new.
p objectAttributeAt:#color put:#green.
p objectAttributeAt:#color
"
"Created: / 22.1.1998 / 21:29:25 / av"
"Modified: / 3.2.1998 / 18:57:58 / cg"
!
objectAttributes
"return a Collection of attributes - nil if there is none.
The default implementation here uses a global WeakDictionary to store
attributes
This may be too slow for high frequency slot access,
therefore, some classes may redefine this for better performance.
Notice the mentioning of a WeakDictionary - read the classes documentation."
^ ObjectAttributes at:self ifAbsent:[#()]
"Created: / 22.1.1998 / 21:29:30 / av"
"Modified: / 3.2.1998 / 18:58:31 / cg"
!
objectAttributes:aCollection
"set the collection of attributes.
The default implementation here uses a global Dictionary to store
attributes which may be too slow for high frequency change&update.
Therefore, some classes may redefine this for better performance."
"/ must do this save from interrupts, since the attributes collection
"/ is possibly accessed from multiple threads.
(OperatingSystem blockInterrupts) ifTrue:[
"/ the common case - already blocked
(aCollection isNil or:[aCollection isEmpty]) ifTrue:[
ObjectAttributes removeKey:self ifAbsent:[]
] ifFalse:[
ObjectAttributes at:self put:aCollection
].
^ self
].
[
(aCollection isNil or:[aCollection isEmpty]) ifTrue:[
ObjectAttributes removeKey:self ifAbsent:[]
] ifFalse:[
ObjectAttributes at:self put:aCollection
].
] valueNowOrOnUnwindDo:[
OperatingSystem unblockInterrupts
]
"Created: / 22.1.1998 / 21:29:35 / av"
"Modified: / 3.2.1998 / 18:58:10 / cg"
!
removeObjectAttribute:anObject
"make the argument, anObject be no attribute of the receiver"
|wasBlocked|
"/ must do this save from interrupts, since the attributes collection
"/ is possibly accessed from multiple threads.
wasBlocked := OperatingSystem blockInterrupts.
[
|attrs n a|
attrs := self objectAttributes.
attrs notNil ifTrue:[
attrs remove:anObject ifAbsent:[].
attrs size == 0 ifTrue:[
self objectAttributes:nil
]
]
] valueNowOrOnUnwindDo:[
wasBlocked ifFalse:[
OperatingSystem unblockInterrupts
]
]
"Created: / 22.1.1998 / 21:29:39 / av"
"Modified: / 3.2.1998 / 18:58:13 / cg"
! !
!Object methodsFor:'binary storage'!
hasSpecialBinaryRepresentation
"return true, if the receiver has a special binary representation;
default here is false, but can be redefined in class which provide
their own storeBinary/readBinary methods.
Normal user classes should not use this, it is meant as a hook for
special classes such as True, False, UndefinedObject or SmallInteger.
If your instances should be stored in a special way, see
#representBinaryOn: and #readBinaryContentsFromdata:manager:."
^ false
!
readBinaryContentsFrom:stream manager:manager
"reconstruct the receivers instance variables by reading a binary
binary representation from stream.
This is a general implementation, walking over instances
and loading each recursively using manager.
Redefined by some classes to read a more compact representations
(see String, SmallInteger etc).
Notice, that the object is already recreated as an empty corps
with instance variables all nil and bit-instances (bytes, words etc.)
already read and restored.
Also notice: this method is not called for if a private representation
has been stored (see representBinaryOn:).
In that case, #readBinaryContentsFromData:manager: is called, which
has to be reimplemented in the objects class."
|size "{ Class: SmallInteger }"
instvarArray|
stream next == 1 ifTrue:[
"/
"/ special representation ...
"/
instvarArray := Array new:(size := stream nextNumber:3).
1 to:size do:[:i |
instvarArray basicAt:i put:(manager nextObject)
].
self readBinaryContentsFromData:instvarArray manager:manager.
^ self
].
"/
"/ standard representation
"/
size := self basicSize.
size ~~ 0 ifTrue:[
self class isPointers ifTrue:[
1 to:size do:[:i |
self basicAt:i put:(manager nextObject)
]
]
].
size := self class instSize.
1 to:size do:[:i |
self instVarAt:i put:(manager nextObject)
].
!
readBinaryContentsFromData:instvarArray manager:manager
"reconstruct the receivers instance variables by filling instance
variables with values from instvarArray. This array contains the instvars
as specified in #representBinaryOn: when the object was stored.
It is the receivers responsibility to set its instance variables in the
same order from that array."
^ self subclassResponsibility
"typical implementation (see also comment in #representBinaryOn:)
(for an object with foo, bar and baz as instance variables,
which did not store baz and wants baz to be reinitialized to
some constant string)
foo := instvarArray at:1.
bar := instvarArray at:2.
baz := 'aConstant'.
"
!
representBinaryOn:manager
"this method is called by the storage manager to ask objects
if they wish to provide their own binary representation.
If they want to do so, they should return an array containing all
instance variables (named & indexed pointer) to be stored.
If not redefined, this method returns nil which means that all
instance variables are to be stored.
It should be redefined in objects which do not want all instance variables
to be stored (for example: objects which keep references to a view etc.).
If this is redefined returning non-nil, the corresponding class needs
a redefined instance method named #readBinaryContentsFromData:manager:
which has to fill the receivers named (and optionally indexed pointer)
instance variables with corresponding values from a data array."
^ nil
"typical implementation:
(see also comment in #readBinaryContentsFromData:manager:)
for an object with foo, bar and baz as instance variables,
which does not want to store baz:
representBinaryOn:manager
|data|
data := Array new:2.
data at:1 put:foo.
data at:2 put:bar.
^ data
"
!
storeBinaryDefinitionBodyOn:stream manager:manager
"append a binary representation of the receivers body onto stream.
This is a general implementation walking over instances storing
each recursively as an ID using manager.
Can be redefined in subclasses."
|basicSize "{ Class: SmallInteger }"
instSize "{ Class: SmallInteger }"
specialSize "{ Class: SmallInteger }"
myClass specialRep pointers|
myClass := self class.
instSize := myClass instSize.
(pointers := myClass isPointers) ifTrue:[
"/
"/ inst size not needed - if you uncomment the line below,
"/ also uncomment the corresponding line in
"/ Object>>binaryDefinitionFrom:manager:
"/
"/ stream nextPut:instSize. "mhmh this limits us to 255 named instvars"
myClass isVariable ifTrue:[
stream nextNumber:3 put:(basicSize := self basicSize)
] ifFalse:[
basicSize := 0
].
] ifFalse: [
stream nextNumber:4 put:(basicSize := self basicSize).
myClass isBytes ifTrue:[
1 to:basicSize do:[:i |
stream nextPut:(self basicAt:i)
]
] ifFalse:[
myClass isWords ifTrue:[
1 to:basicSize do:[:i |
stream nextNumber:2 put:(self basicAt: i)
]
] ifFalse:[
myClass isLongs ifTrue:[
1 to:basicSize do:[:i |
stream nextNumber:4 put:(self basicAt: i)
]
] ifFalse:[
myClass isFloats ifTrue:[
"could do it in one big write on machines which use IEEE floats ..."
1 to:basicSize do:[:i |
Float storeBinaryIEEESingle:(self basicAt:i) on:stream
]
] ifFalse:[
myClass isDoubles ifTrue:[
"could do it in one big write on machines which use IEEE doubles ..."
1 to:basicSize do:[:i |
Float storeBinaryIEEEDouble:(self basicAt:i) on:stream
]
] ifFalse:[
"/ should never be reached ...
1 to:basicSize do:[:i |
manager putIdOf:(self basicAt:i) on:stream
]
]
]
]
]
].
].
(pointers or:[instSize ~~ 0]) ifTrue:[
specialRep := self representBinaryOn:manager.
specialRep notNil ifTrue:[
specialSize := specialRep basicSize.
stream nextPut:1. "/ means: private representation follows
stream nextNumber:3 put:specialSize.
1 to:specialSize do:[:i |
manager putIdOf:(specialRep at:i) on:stream
].
] ifFalse:[
stream nextPut:0. "/ means: normal representation follows
"/ index pointers followed by named instanceVars
pointers ifTrue:[
basicSize ~~ 0 ifTrue:[
1 to:basicSize do:[:i |
manager putIdOf:(self basicAt:i) on:stream
].
].
].
instSize ~~ 0 ifTrue:[
1 to:instSize do:[:i |
manager putIdOf:(self instVarAt:i) on:stream
]
].
]
]
"Modified: / 2.11.1997 / 14:43:29 / cg"
!
storeBinaryDefinitionOn:stream manager:manager
"append a binary representation of the receiver onto stream.
This is an internal interface for binary storage mechanism.
This method first stores the class, then the body, which is done
in a separate method to allow redefinition of the bodies format.
Can be redefined in subclasses to write more compact representations
(see String, SmallInteger etc)."
manager putIdOfClass:(self class) on:stream.
self storeBinaryDefinitionBodyOn:stream manager:manager
"Modified: 23.4.1996 / 09:31:12 / cg"
!
storeBinaryOn:aStreamOrFilename
"Writes a description of the receiver onto aStreamOrFilename, in a way that allows
the object's structure to be reconstructed from the stream's contents"
BinaryOutputManager store:self on:aStreamOrFilename
"
|a s1 s2|
s1 := 'hello'.
s2 := 'world'.
a := Array new:5.
a at:1 put:s1.
a at:2 put:s2.
a at:3 put:s1.
a at:4 put:s2.
a storeBinaryOn:'test.boss'
"
"
(BinaryObjectStorage onOld:'test.boss' asFilename readStream)
next
inspect
"
"Modified: / 1.11.1997 / 21:16:24 / cg"
!
storeBinaryOn:stream manager:manager
"append a binary representation of the receiver onto stream."
manager putIdOf:self on:stream
! !
!Object methodsFor:'change & update'!
broadcast:aSelectorSymbol
"send a message with selector aSelectorSymbol to all my dependents"
self dependentsDo:[:dependent |
dependent perform:aSelectorSymbol
]
!
broadcast:aSelectorSymbol with:anArgument
"send a message with selector aSelectorSymbol with an additional
argument anArgument to all my dependents."
self dependentsDo:[:dependent |
dependent perform:aSelectorSymbol with:anArgument
]
!
changeRequest
"the receiver wants to change - check if all dependents
grant the request, and return true if so"
self dependentsDo:[:dependent |
dependent updateRequest ifFalse:[^ false].
].
^ true
!
changeRequest:aParameter
"the receiver wants to change - check if all dependents
grant the request, and return true if so"
self dependentsDo:[:dependent |
(dependent updateRequest:aParameter) ifFalse:[^ false].
].
^ true
!
changeRequest:aParameter from:anObject
"the receiver wants to change - check if all dependents
except anObject grant the request, and return true if so.
The argument anObject is typically going to be the one who is
about to send the change request."
self dependentsDo:[:dependent |
dependent == anObject ifFalse:[
(dependent updateRequest:aParameter) ifFalse:[^ false].
]
].
^ true
!
changeRequestFrom:anObject
"the receiver wants to change - check if all dependents
except anObject grant the request, and return true if so.
The argument anObject is typically going to be the one who is
about to send the change request."
self dependentsDo:[:dependent |
dependent == anObject ifFalse:[
(dependent updateRequest) ifFalse:[^ false].
]
].
^ true
!
changed
"notify all dependents that the receiver has changed.
Each dependent gets a '#update:'-message with the original
receiver as argument."
self changed:nil
!
changed:aParameter
"notify all dependents that the receiver has changed somehow.
Each dependent gets a '#update:'-message with aParameter
as argument."
self changed:aParameter with:nil
!
changed:aParameter with:anArgument
"notify all dependents that the receiver has changed somehow.
Each dependent gets a '#update:with:from:'-message, with aParameter
and anArgument as arguments."
self dependentsDo:[:dependent |
dependent update:aParameter with:anArgument from:self
]
!
update:aParameter
"the message is sent to a dependent, when one of the objects
on whom the receiver depends, has changed. The argument aParameter
is either the changed object or the argument to the #changed: message.
Default behavior here is to do nothing"
^ self
!
update:aParameter with:anArgument
"dependent is notified of some change -
Default is to try update:"
^ self update:aParameter
!
update:aParameter with:anArgument from:sender
"dependent is notified of some change -
Default is to try update:with:"
^ self update:aParameter with:anArgument
!
updateRequest
"return true, if an update request is granted.
Default here is to grant updates - may be used
to lock updates if someone is making other changes
from within an update. Or if someone has locked its
state and does not want others to change things.
However, these dependents must all honor the
changeRequest - ifTrue - change protocol. I.e. they
must first ask all others via changeRequest, and only do the change
it returns true. The others must decide in updateRequest and
return true if they think a change is ok."
^ true
!
updateRequest:aSymbol
"return true, if an update request is granted.
Default here a simple updateRequest"
^ self updateRequest
! !
!Object methodsFor:'cleanup'!
lowSpaceCleanup
"ignored here - redefined in some classes to
cleanup in low-memory situations"
^ self
! !
!Object methodsFor:'comparing'!
= anObject
"return true, if the receiver and the arg have the same structure.
Notice:
This method is partially open coded (inlined) by the compiler(s)
identical objects are always considered equal.
redefining it may not work as expected."
^ self == anObject
!
== anObject
"return true, if the receiver and the arg are the same object.
Never redefine this in any class.
Notice:
This method is open coded (inlined) by the compiler(s)
- redefining it may not work as expected."
%{ /* NOCONTEXT */
RETURN ( (self == anObject) ? true : false );
%}
!
hash
"return an Integer useful as a hash key for the receiver.
This hash should return same values for objects with same
contents (i.e. use this to hash on structure)"
^ self identityHash
!
identityHash
"return an Integer useful as a hash key for the receiver.
This hash should return same values for the same object (i.e. use
this to hash on identity of objects).
We cannot use the Objects address (as other smalltalks do) since
no object-table exists and the hashval must not change when objects
are moved by the collector. Therefore we assign each object a unique
Id in the object header itself as its hashed upon.
(luckily we have 11 bits spare to do this - unluckily its only 11 bits).
Time will show, if 11 bits are enough; if not, another entry in the
object header will be needed, adding 4 bytes to every object. Alternatively,
hashed-upon objects could add an instvar containing the hash value."
%{ /* NOCONTEXT */
REGISTER unsigned hash;
static unsigned nextHash = 0;
if (__isNonNilObject(self)) {
hash = __GET_HASH(self);
if (hash == 0) {
/* has no hash yet */
if (++nextHash > __MAX_HASH__) {
nextHash = 1;
}
hash = nextHash;
__SET_HASH(self, hash);
}
/*
* now, we got 11 bits for hashing;
* make it as large as possible; since most hashers use the returned
* key and take it modulo some prime number, this will allow for
* better distribution (i.e. bigger empty spaces) in hashed collection.
*/
hash = __MAKE_HASH__(hash);
RETURN ( __MKSMALLINT(hash) );
}
%}.
^ 0 "never reached, since redefined in UndefinedObject and SmallInteger"
!
identityHashForBinaryStore
"hash which is usable if the object does not change its class
and does not #become something else, while the hash is used.
This is only used by the binary storage mechanism, during the
object writing phase."
%{ /* NOCONTEXT */
REGISTER unsigned hash, hash1, hash2, sz;
OBJ o;
static unsigned nextHash = 0;
static unsigned nextClassHash = 0;
if (__isNonNilObject(self)) {
/*
* my own identityHash
*/
hash1 = __GET_HASH(self);
if (hash1 == 0) {
/* has no hash yet */
if (++nextHash > __MAX_HASH__) {
nextHash = 1;
}
hash1 = nextHash;
__SET_HASH(self, hash1);
}
/*
* my classes identityHash
*/
o = __qClass(self);
hash2 = __GET_HASH(o);
if (hash2 == 0) {
/* has no hash yet */
if (++nextClassHash > __MAX_HASH__) {
nextClassHash = 1;
}
hash2 = nextClassHash;
__SET_HASH(o, hash2);
}
/*
* some bits of my size
*/
sz = __qSize(self);
/*
* now, we got 11 + 11 + 8 bits for hashing;
* make it as large as possible; since most hashers use the returned
* key and take it modulo some prime number, this will allow for
* better distribution (i.e. bigger empty spaces) in hashed collection.
*/
hash = (hash1 << 11) | hash2; /* 22 bits */
hash = (hash << 8) | (sz & 0xFC); /* 30 bits */
while ((hash & 0x20000000) == 0) {
hash <<= 1;
}
RETURN ( __MKSMALLINT(hash) );
}
%}.
^ nil "never reached, since UndefinedObject and SmallInteger are not hashed upon in binary storage"
!
isNil
"return true, if the receiver is nil.
Notice:
This method is open coded (inlined) by the compiler(s)
- redefining it may not work as expected."
^ false
!
notNil
"return true, if the receiver is not nil.
Notice:
This method is open coded (inlined) by the compiler(s)
- redefining it may not work as expected."
^ true
!
sameContentsAs:anObject
"return true, if the receiver and the arg have the same contents
in both the named instance vars and any indexed instVars."
|myClass otherClass
sz "{ Class: SmallInteger }" |
myClass := self class.
myClass isVariable ifTrue:[
sz := self basicSize.
"compare the indexed variables"
1 to:sz do:[:i |
(self basicAt:i) ~~ (anObject basicAt:i) ifTrue:[^ false].
]
].
"compare the instance variables"
sz := myClass instSize.
1 to:sz do:[:i |
(self instVarAt:i) ~~ (anObject instVarAt:i) ifTrue:[^ false].
].
^ true
"
#(1 2 3 4) sameContentsAsIn:#[1 2 3 4] asArray
(1@2) sameContentsAsIn:(1->2)
"
"Created: / 21.4.1998 / 15:56:40 / cg"
"Modified: / 21.4.1998 / 15:58:15 / cg"
!
~= anObject
"return true, if the receiver and the arg do not have the same structure.
Notice:
This method is partially open coded (inlined) by the compiler(s)
identical objects are never considered unequal.
redefining it may not work as expected."
^ (self = anObject) not
!
~~ anObject
"return true, if the receiver and the arg are not the same object.
Never redefine this in any class.
Notice:
This method is open coded (inlined) by the compiler(s)
- redefining it may not work as expected."
%{ /* NOCONTEXT */
RETURN ( (self == anObject) ? false : true );
%}
! !
!Object methodsFor:'converting'!
-> anObject
"return an association with the receiver as key and
the argument as value"
^ Association key:self value:anObject
!
asValue
"return a valueHolder for for the receiver"
^ ValueHolder with:self
! !
!Object methodsFor:'copying'!
copy
"return a copy of the receiver - defaults to shallowcopy here.
Notice, that copy does not copy dependents."
^ self shallowCopy postCopy
!
deepCopy
"return a copy of the object with all subobjects also copied.
This method DOES handle cycles/self-refs; however the receivers
class is not copied (to avoid the 'total' copy).
This deepCopy is a bit slower than the old (unsecure) one, since it
keeps track of already copied objects. If you are sure, that your
copied object does not include duplicates (or you do not care) and
no cycles, you can use the old simpleDeepCopy, which avoids this overhead,
but may run into trouble.
Notice, that copy does not copy dependents."
^ self deepCopyUsing:(IdentityDictionary new)
"an example which is not handled by the old deepCopy:
|a|
a := Array new:3.
a at:3 put:a.
a deepCopy inspect
"
"Modified: 27.3.1996 / 16:31:20 / stefan"
!
deepCopyError
"{ Pragma: +optSpace }"
"raise a signal, that deepCopy is not allowed for this object"
^ DeepCopyErrorSignal raise
!
deepCopyUsing:aDictionary
"a helper for deepCopy; return a copy of the object with
all subobjects also copied. If the to-be-copied object is in the dictionary,
use the value found there. The class of the receiver is not copied.
This method DOES handle cycles/self references."
|myClass aCopy
sz "{ Class: SmallInteger }"
iOrig iCopy|
myClass := self class.
myClass isVariable ifTrue:[
sz := self basicSize.
aCopy := myClass basicNew:sz.
] ifFalse:[
sz := 0.
aCopy := myClass basicNew
].
aCopy setHashFrom:self.
aDictionary at:self put:aCopy.
"
copy indexed instvars - if any
"
sz ~~ 0 ifTrue:[
myClass isBits ifTrue:[
"block-copy indexed instvars"
aCopy replaceFrom:1 to:sz with:self startingAt:1
] ifFalse:[
"individual deep copy the indexed variables"
1 to:sz do:[:i |
iOrig := self basicAt:i.
iOrig notNil ifTrue:[
(aDictionary includesKey:iOrig) ifTrue:[
iCopy := aDictionary at:iOrig
] ifFalse:[
iCopy := iOrig deepCopyUsing:aDictionary.
].
aCopy basicAt:i put:iCopy
]
]
]
].
"
copy the instance variables
"
sz := myClass instSize.
sz ~~ 0 ifTrue:[
1 to:sz do:[:i |
iOrig := self instVarAt:i.
iOrig notNil ifTrue:[
(aDictionary includesKey:iOrig) ifTrue:[
iCopy := aDictionary at:iOrig
] ifFalse:[
iCopy := iOrig deepCopyUsing:aDictionary.
].
aCopy instVarAt:i put:iCopy
]
].
].
^ aCopy
!
postCopy
"this is for compatibility with ST-80 code, which uses postCopy for
cleanup after copying, while ST/X passes the original in postCopyFrom:
(see there)"
^ self
!
setHashFrom:anObject
"set my identity-hash key to be the same as anObjects hash key.
This is an ST/X speciality, which is NOT available in other (especially OT based)
Smalltalks, and may not be available in future ST/X versions.
DO NEVER use this for normal application code."
%{ /* NOCONTEXT */
REGISTER unsigned h;
if (__isNonNilObject(self) && __isNonNilObject(anObject)) {
h = __GET_HASH(anObject);
__SET_HASH(self, h);
RETURN (self);
}
%}.
self primitiveFailed "neither receiver not arg may be nil or SmallInteger"
!
shallowCopy
"return a copy of the object with shared subobjects (a shallow copy)
i.e. the copy shares referenced instvars with its original."
%{ /* NOCONTEXT */
int ninsts, spc;
int sz;
OBJ theCopy;
OBJ cls;
int flags;
cls = __qClass(self);
flags = __intVal(__ClassInstPtr(cls)->c_flags);
/*
* bail out for special objects ..
*/
if (((flags & ~ARRAYMASK) == 0)
&& ((flags & ARRAYMASK) != WKPOINTERARRAY)) {
sz = __qSize(self);
__PROTECT__(self);
__qNew(theCopy, sz); /* OBJECT ALLOCATION */
__UNPROTECT__(self);
if (theCopy) {
cls = __qClass(self);
spc = __qSpace(theCopy);
theCopy->o_class = cls; __STORE_SPC(theCopy, cls, spc);
sz = sz - OHDR_SIZE;
if (sz) {
char *src, *dst;
src = (char *)(__InstPtr(self)->i_instvars);
dst = (char *)(__InstPtr(theCopy)->i_instvars);
#ifdef bcopy4
{
/* care for odd-number of longs */
int nW = sz >> 2;
if (sz & 3) {
nW++;
}
bcopy4(src, dst, nW);
}
#else
bcopy(src, dst, sz);
#endif
flags &= ARRAYMASK;
if (flags == POINTERARRAY) {
ninsts = __BYTES2OBJS__(sz);
} else {
ninsts = __intVal(__ClassInstPtr(cls)->c_ninstvars);
}
if (ninsts) {
do {
OBJ el;
el = __InstPtr(theCopy)->i_instvars[ninsts-1];
__STORE_SPC(theCopy, el, spc);
} while (--ninsts);
}
}
RETURN (theCopy);
}
}
%}.
"/ fallBack for special objects & memoryAllocation failure case
^ self slowShallowCopy
!
shallowCopyForFinalization
"this is used to aquire a copy to be used for finalization -
(the copy will get a dispose-notification; see the documentation in the Registry class)
This method can be redefined for more efficient copying - especially for large objects."
^ self shallowCopy
!
simpleDeepCopy
"return a copy of the object with all subobjects also copied.
This method does NOT handle cycles - but is included to allow this
slightly faster copy in situations where it is known that
no recursive references occur (LargeIntegers for example).
NOTICE: you will run into trouble, when trying this with recursive
objects (usually recursionInterrupt or memory-alert).
This method corresponds to the 'traditional' deepCopy found in
the Blue book."
|myClass aCopy
sz "{ Class: SmallInteger }" |
myClass := self class.
myClass isVariable ifTrue:[
sz := self basicSize.
aCopy := myClass basicNew:sz.
"copy the indexed variables"
1 to:sz do:[:i |
aCopy basicAt:i put:((self basicAt:i) simpleDeepCopy)
]
] ifFalse:[
aCopy := myClass basicNew
].
"copy the instance variables"
sz := myClass instSize.
1 to:sz do:[:i |
aCopy instVarAt:i put:((self instVarAt:i) simpleDeepCopy)
].
^ aCopy
"a bad example (but ST/X should survive ...)"
"
|a|
a := Array new:3.
a at:3 put:a.
a simpleDeepCopy
"
!
slowShallowCopy
"return a copy of the object with shared subobjects (a shallow copy)
i.e. the copy shares referenced instvars with its original.
This method is only invoked as a fallback from #shallowCopy."
|myClass aCopy
sz "{ Class: SmallInteger }" |
myClass := self class.
myClass isVariable ifTrue:[
sz := self basicSize.
aCopy := myClass basicNew:sz.
"copy the indexed variables"
1 to:sz do:[:i |
aCopy basicAt:i put:(self basicAt:i)
]
] ifFalse:[
aCopy := myClass basicNew
].
"copy the instance variables"
sz := myClass instSize.
1 to:sz do:[:i |
aCopy instVarAt:i put:(self instVarAt:i)
].
^ aCopy
! !
!Object methodsFor:'debugging'!
basicInspect
"{ Pragma: +optSpace }"
"launch an inspector on the receiver.
this method should NOT be redefined in subclasses."
Inspector isNil ifTrue:[
"
for systems without GUI
"
Transcript showCR:'no Inspector'
] ifFalse:[
Inspector openOn:self
]
"Modified: 18.5.1996 / 15:43:25 / cg"
!
inspect
"{ Pragma: +optSpace }"
"launch an inspector on the receiver.
this method (or better: inspectorClass) can be redefined in subclasses
to start special inspectors."
|cls|
cls := self inspectorClass.
cls isNil ifTrue:[
^ self basicInspect
].
cls openOn:self
"
Object new inspect
(1 @ 2) inspect
Smalltalk inspect
#(1 2 3) asOrderedCollection inspect
(Color red) inspect
(Image fromFile:'bitmaps/garfield.gif') inspect
"
!
inspectorClass
"{ Pragma: +optSpace }"
"return the class to use for inspect.
Can (should) be redefined in classes for which a better inspector is available"
^ Inspector
!
mustBeKindOf:aClass
"for compatibility & debugging support:
check if the receiver isKindOf:aClass and raise an error if not.
Notice:
it is VERY questionable, if it makes sense to add manual
type checks to a dynamically typed language like smalltalk.
It will, at least, slow down performance,
make your code less reusable and clutter your code with stupid sends
of this selector. Also, read the comment in isKindOf:, regarding the
use of isXXX check methods.
You see: The author does not like this at all ..."
(self isKindOf:aClass) ifFalse:[
self error:'argument is not of expected type'
]
!
obsoleteMethodWarning
"{ Pragma: +optSpace }"
"in methods which are going to be obsoleted, a self send to
this method is used to tell programmers that a method is
used which is going to be removed in later ST/X versions.
Find all methods which will be obsolete soon by looking at senders
of this message.
Hopefully, this warning message is annoying enough for you to
change the code ... ;-)"
self obsoleteMethodWarning:nil from:thisContext sender
!
obsoleteMethodWarning:message
"{ Pragma: +optSpace }"
"in methods which are going to be obsoleted, a self send to
this method is used to tell programmers that a method is
used which is going to be removed in later ST/X versions.
Find all methods which will be obsolete soon by looking at senders
of this message.
Hopefully, this warning message is annoying enough for you to
change the code ... ;-)"
self obsoleteMethodWarning:message from:thisContext sender
!
obsoleteMethodWarning:message from:aContext
"{ Pragma: +optSpace }"
"in methods which are going to be obsoleted, a self-send to
this method is used to tell programmers that a method is
used which is going to be removed in later ST/X versions.
Find all methods which will be obsolete soon by looking at senders
of this message.
Hopefully, this warning message is annoying enough for you to
change the code ... ;-)"
|spec|
spec := aContext methodPrintString.
('WARNING: the ''' , spec , ''' method is obsolete.') errorPrintCR.
(' And may not be present in future ST/X versions.') errorPrintCR.
(' called from ' , aContext sender printString) errorPrintCR.
message notNil ifTrue:[
'------> ' errorPrint. message errorPrintCR
]
"
Object obsoleteMethodWarning:'foo' from:thisContext sender sender
"
"Modified: 10.1.1997 / 19:08:42 / cg"
! !
!Object methodsFor:'dependents access'!
addDependent:anObject
"make the argument, anObject be a dependent of the receiver"
|wasBlocked|
"/ must do this save from interrupts, since the dependents collection
"/ is possibly accessed from multiple threads.
"/ Used to use #valueUninterruptably here; inlined that code for slightly
"/ faster execution.
wasBlocked := OperatingSystem blockInterrupts.
[
|deps dep|
deps := self dependents.
"/ to save a fair amount of memory in case of
"/ many dependencies, we store a single dependent in
"/ a WeakArray, and switch to a WeakSet if more dependents are
"/ added.
(deps isNil or:[deps size == 0]) ifTrue:[
self dependents:(WeakArray with:anObject)
] ifFalse:[
deps class == WeakArray ifTrue:[
dep := deps at:1.
dep ~~ anObject ifTrue:[
(dep isNil or:[dep == 0]) ifTrue:[
deps at:1 put:anObject
] ifFalse:[
self dependents:(WeakIdentitySet with:dep with:anObject)
]
]
] ifFalse:[
deps add:anObject
]
]
] valueNowOrOnUnwindDo:[
wasBlocked ifFalse:[
OperatingSystem unblockInterrupts
]
]
"Modified: / 27.10.1997 / 19:35:52 / cg"
!
breakDependents
"remove all dependencies from the receiver"
self dependents:nil.
self nonWeakDependents:nil
"Modified: / 19.4.1996 / 10:55:36 / cg"
"Created: / 27.2.1998 / 11:26:11 / stefan"
!
dependents
"return a Collection of dependents.
The default implementation here uses a global WeakDictionary to store
dependents
This may be too slow for high frequency change&update,
therefore, some classes (Model) redefine this for better performance.
Notice the mentioning of a WeakDictionary - read the classes documentation."
|deps|
(deps := Dependencies at:self ifAbsent:nil) isNil ifTrue:[
^ #().
].
^ deps
"Modified: / 26.1.1998 / 11:18:15 / cg"
!
dependents:aCollection
"set the collection of dependents.
The default implementation here uses a global Dictionary to store
dependents which may be too slow for high frequency change&update.
Therefore, some classes (Model) redefine this for better performance."
"/ must do this save from interrupts, since the dependents collection
"/ is possibly accessed from multiple threads.
"/ Used to use #valueUninterruptably here; inlined that code for slightly
"/ faster execution (and to avoid creation of garbage blocks).
(OperatingSystem blockInterrupts) ifTrue:[
"/ the common case - already blocked
(aCollection isNil or:[aCollection isEmpty]) ifTrue:[
Dependencies removeKey:self ifAbsent:[]
] ifFalse:[
Dependencies at:self put:aCollection
].
^ self
].
[
(aCollection isNil or:[aCollection isEmpty]) ifTrue:[
Dependencies removeKey:self ifAbsent:[]
] ifFalse:[
Dependencies at:self put:aCollection
].
] valueNowOrOnUnwindDo:[
OperatingSystem unblockInterrupts
]
"Modified: 30.1.1997 / 21:22:10 / cg"
!
dependentsDo:aBlock
"evaluate aBlock for all of my dependents"
|deps nwDeps|
deps := self dependents.
deps size ~~ 0 ifTrue:[
deps do:[:d |
(d notNil and:[d ~~ 0]) ifTrue:[
aBlock value:d
]
]
].
nwDeps := self nonWeakDependents.
(nwDeps ~~ deps and:[nwDeps size ~~ 0]) ifTrue:[
nwDeps do:aBlock
].
"Modified: / 30.1.1998 / 14:03:40 / cg"
!
myDependents
"same as dependents - ST-80 compatibility"
^ self dependents
!
release
"remove all references to objects that may refer to self.
Subclasses may redefine this method but should do a 'super release'."
self breakDependents
"Modified: / 27.2.1998 / 11:29:35 / stefan"
!
removeDependent:anObject
"make the argument, anObject be independent of the receiver"
|wasBlocked|
"/ must do this save from interrupts, since the dependents collection
"/ is possibly accessed from multiple threads.
"/ Used to use #valueUninterruptably here; inlined that code for slightly
"/ faster execution.
wasBlocked := OperatingSystem blockInterrupts.
[
|deps n d|
deps := self dependents.
deps size ~~ 0 ifTrue:[
"/ to save a fair amount of memory in case of
"/ many dependencies, we store a single dependent in
"/ a WeakArray, and switch to a WeakSet if more dependents are
"/ added. Here we have to do the inverse ...
deps class == WeakArray ifTrue:[
((d := deps at:1) == anObject
or:[d isNil
or:[d == 0]]) ifTrue:[
self dependents:nil
]
] ifFalse:[
deps remove:anObject ifAbsent:[].
(n := deps size) == 0 ifTrue:[
self dependents:nil
] ifFalse:[
n == 1 ifTrue:[
d := deps firstIfEmpty:nil.
d notNil ifTrue:[
deps := WeakArray with:d
] ifFalse:[
deps := nil
].
self dependents:deps.
]
]
]
]
] valueNowOrOnUnwindDo:[
wasBlocked ifFalse:[
OperatingSystem unblockInterrupts
]
]
"Modified: / 26.1.1998 / 19:51:50 / cg"
! !
!Object methodsFor:'dependents access (nonWeak)'!
addNonWeakDependent:anObject
"make the argument, anObject be a nonWeak dependent of the receiver.
Be careful: this nonWeakDependency will prevent the dependent from being
garbage collected unless the dependency is removed.
This is a private mechanism, for directed dependencies."
|wasBlocked|
"/ must do this save from interrupts, since the dependents collection
"/ is possibly accessed from multiple threads.
"/ Used to use #valueUninterruptably here; inlined that code for slightly
"/ faster execution.
wasBlocked := OperatingSystem blockInterrupts.
[
|deps dep|
deps := self nonWeakDependents.
"/ to save a fair amount of memory in case of
"/ many dependencies, we store a single dependent in
"/ an Array, and switch to a Set if more dependents are
"/ added.
deps size == 0 ifTrue:[
self nonWeakDependents:(Array with:anObject)
] ifFalse:[
deps class == Array ifTrue:[
dep := deps at:1.
dep ~~ anObject ifTrue:[
self nonWeakDependents:(IdentitySet with:dep with:anObject)
]
] ifFalse:[
deps add:anObject
]
]
] valueNowOrOnUnwindDo:[
wasBlocked ifFalse:[
OperatingSystem unblockInterrupts
]
]
"Created: / 19.4.1996 / 10:54:08 / cg"
"Modified: / 30.1.1998 / 14:03:08 / cg"
!
nonWeakDependents
"return a Collection of nonWeakDependents - empty if there is none.
This is a private mechanism for directed dependencies."
NonWeakDependencies isNil ifTrue:[^ #()].
^ NonWeakDependencies at:self ifAbsent:#()
"Created: / 19.4.1996 / 10:55:06 / cg"
"Modified: / 30.1.1998 / 14:06:47 / cg"
!
nonWeakDependents:aCollection
"set the collection of nonWeak dependents.
This is a private helper for directed dependencies."
[
(aCollection isNil or:[aCollection isEmpty]) ifTrue:[
NonWeakDependencies removeKey:self ifAbsent:[]
] ifFalse:[
NonWeakDependencies at:self put:aCollection
]
] valueUninterruptably
"Created: 19.4.1996 / 11:07:47 / cg"
!
removeNonWeakDependent:anObject
"remove a nonWeak dependency from the receiver to the argument, anObject.
(i.e. make it independent of the receiver)"
|wasBlocked|
"/ must do this save from interrupts, since the dependents collection
"/ is possibly accessed from multiple threads.
"/ Used to use #valueUninterruptably here; inlined that code for slightly
"/ faster execution.
wasBlocked := OperatingSystem blockInterrupts.
[
|deps n|
deps := self nonWeakDependents.
deps size ~~ 0 ifTrue:[
deps class == Array ifTrue:[
(deps at:1) == anObject ifTrue:[
self nonWeakDependents:nil
]
] ifFalse:[
deps remove:anObject ifAbsent:[].
(n := deps size) == 0 ifTrue:[
self nonWeakDependents:nil
] ifFalse:[
n == 1 ifTrue:[
self nonWeakDependents:(Array with:(deps first))
]
]
]
]
] valueNowOrOnUnwindDo:[
wasBlocked ifFalse:[
OperatingSystem unblockInterrupts
]
]
"Created: / 19.4.1996 / 11:44:44 / cg"
"Modified: / 30.1.1998 / 14:04:01 / cg"
! !
!Object methodsFor:'displaying'!
displayOn:aGC
"ST-80 Compatibility
display the receiver in a graphicsContext at 0@0
- this method allows for any object to be displayed in some view
(although the fallBack is to display its printString ...)"
^ self displayOn:aGC x:0 y:0.
"Created: 29.5.1996 / 16:28:58 / cg"
!
displayOn:aGC at:aPoint
"ST-80 Compatibility
display the receiver in a graphicsContext - this method allows
for any object to be displayed in a ListView - for example."
^ self displayOn:aGC x:(aPoint x) y:(aPoint y).
!
displayOn:aGC x:x y:y
"display the receiver in a graphicsContext - this method allows
for any object to be displayed in a ListView - for example."
self displayOn:aGC x:x y:y opaque:false
"Modified: 29.5.1996 / 16:29:38 / cg"
!
displayOn:aGc x:x y:y opaque:opaque
"display the receiver in a graphicsContext - this method allows
for any object to be displayed in a ListView - for example.
The fallBack here shows the receivers displayString."
|s|
s := self displayString.
opaque ifTrue:[
aGc displayOpaqueString:s x:x y:y.
] ifFalse:[
aGc displayString:s x:x y:y.
].
"Modified: 29.5.1996 / 16:29:38 / cg"
!
displayOpaqueOn:aGC x:x y:y
"display the receiver in a graphicsContext - this method allows
for any object to be displayed in a ListView - for example."
self displayOn:aGC x:x y:y opaque:true
"Modified: / 29.5.1996 / 16:29:38 / cg"
"Created: / 26.10.1997 / 15:01:36 / cg"
!
displayString
"return a string used when displaying the receiver in a view;
for example an Inspector. This is usually the same as printString,
but sometimes redefined for a better look."
^ self printString
"
#(1 2 3) printString
#(1 2 3) displayString
#(1 2 3) storeString
"
!
heightOn:aGC
"return the height of the receiver, if it is to be displayed on aGC"
^ (aGC font on:aGC device) heightOf:(self displayString)
!
widthOn:aGC
"return the width of the receiver, if it is to be displayed on aGC"
^ (aGC font on:aGC device) widthOf:(self displayString)
! !
!Object methodsFor:'error handling'!
appropriateDebugger:aSelector
"{ Pragma: +optSpace }"
"return an appropriate debugger to use.
If there is already a debugger active on the stack, and it is
the DebugView, return MiniDebugger (as a last chance) otherwise abort."
|context|
"DebugView cannot run without system processes"
(Processor isNil
or:[Processor activeProcessIsSystemProcess]) ifTrue:[
^ MiniDebugger
].
Smalltalk isInitialized ifFalse:[
^ MiniDebugger
].
context := thisContext.
context := context findNextContextWithSelector:aSelector or:nil or:nil.
[context notNil] whileTrue:[
((context receiver class == Debugger)
and:[context selector == aSelector]) ifTrue:[
"we are already in some Debugger"
(Debugger == MiniDebugger) ifTrue:[
"we are already in the MiniDebugger"
ErrorRecursion ifFalse:[
Smalltalk fatalAbort:'recursive error ...'
]
].
MiniDebugger isNil ifTrue:[
Smalltalk fatalAbort:'no debugger'
].
"ok, an error occured while in the graphical debugger;
lets try MiniDebugger"
^ MiniDebugger
].
context := context findNextContextWithSelector:aSelector or:nil or:nil.
].
"not within Debugger - no problem"
^ Debugger
"Modified: / 23.9.1996 / 12:14:52 / stefan"
"Modified: / 27.10.1997 / 19:22:10 / cg"
!
cannotSendMessage:aMessage to:someReceiver
"this message is sent by the runtime system (VM),
when a message is sent to some object, whose class is not
a valid behavior (see documentation in Behavior)."
^ InternalErrorSignal
raiseRequestWith:someReceiver
errorString:('bad class in send of #' , aMessage selector)
"Modified: 23.1.1997 / 00:05:39 / cg"
!
doesNotUnderstand:aMessage
"this message is sent by the runtime system (VM) when
a message is not understood by some object (i.e. there
is no method for that selector). The original message has
been packed into aMessage (i.e. the receiver, selector and
any arguments) and the original receiver is then sent the
#doesNotUnderstand: message.
Here, we raise another signal which usually enters the debugger.
You can of course redefine #doesNotUnderstand: in your classes
to implement message delegation,
or handle the MessageNotUnderstoodSignal gracefully."
|sel errorString cls sender|
sel := aMessage selector printString.
"/ Although sel should always be a symbol,
"/ always use printStrings in the code below.
"/ Non-symbol selector may happen when things go mad in a primitive,
"/ or a method has been called by valueWithReceiver: with a wrong arg.
"/ handle the case of an error during early startup
"/ (output streams not yet initialized)
Stdout isNil ifTrue:[
Smalltalk fatalAbort:'error during init: ' , sel , ' not understood'.
].
"/
"/ extract the class that should have implemented the message.
"/ (in case of a super-send, this is not the receivers class)
"/
sender := thisContext sender.
cls := sender searchClass.
cls isNil ifTrue:[
"it was NOT a super or directed send ..."
cls := self class
].
cls notNil ifTrue:[
"/
"/ displayString is better than 'cls name',
"/ since it appends (obsolete) for outdated classes.
"/ (this happens if you send messages to old instances
"/ after changing a classes definition)
"/
errorString := cls displayString.
] ifFalse:[
errorString := '(** nil-class **)'
].
errorString := errorString , ' does not understand: ' , sel.
"/
"/ this only happens, when YOU play around with my classvars ...
"/ (or an error occurs during very early startup, when signals are not yet set)
"/
MessageNotUnderstoodSignal isNil ifTrue:[
^ MiniDebugger enterWithMessage:'oops - MessageNotUnderstoodSignal is gone (nil)'.
].
"/
"/ thats where we end up normally - raise a signal which (if unhandled) opens a debugger
"/
^ MessageNotUnderstoodSignal
raiseRequestWith:aMessage
errorString:errorString
in:sender
"Modified: 31.7.1997 / 17:04:49 / cg"
!
elementBoundsError
"{ Pragma: +optSpace }"
"report an error that badElement is out of bounds
(i.e. cannot be put into that collection).
The error is reported by raising the ElementOutOfBoundsSignal exception."
^ ElementOutOfBoundsSignal raiseIn:thisContext sender
"Modified: 8.5.1996 / 09:12:45 / cg"
!
elementNotCharacter
"{ Pragma: +optSpace }"
"report an error that object to be stored is no Character.
(usually when storing into Strings).
The error is reported by raising the ElementOutOfBoundsSignal exception."
^ ElementOutOfBoundsSignal raiseIn:thisContext sender
"Modified: 8.5.1996 / 09:12:49 / cg"
!
elementNotInteger
"{ Pragma: +optSpace }"
"report an error that object to be stored is not Integer.
(in collections that store integers only).
The error is reported by raising the ElementOutOfBoundsSignal exception."
^ ElementOutOfBoundsSignal raiseIn:thisContext sender
"Modified: 8.5.1996 / 09:12:51 / cg"
!
enterDebuggerWith:anException message:aString
"{ Pragma: +optSpace }"
"enter the debugger with error-message aString"
^ self
enterDebuggerWithMessage:aString
on:anException suspendedContext
!
enterDebuggerWithMessage:aString on:aContext
"{ Pragma: +optSpace }"
"enter the debugger with error-message aString.
The first visible context shown there is aContext
(this allows intermediate helpers to hide themselfes from what is
presented to the user)"
|debugger msg|
"
if there is no debugger, exit smalltalk
"
Debugger isNil ifTrue:[
msg := 'error: ' , aString.
Smalltalk isStandAloneApp ifTrue:[
Dialog notNil ifTrue:[
(Dialog
confirm:msg title:(Smalltalk commandName)
yesLabel:'ignore' noLabel:'exit'
) ifTrue:[
^ AbortSignal raise
]
].
msg errorPrintCR.
OperatingSystem exit:1
].
msg errorPrintCR.
Smalltalk fatalAbort:'no Debugger defined'
].
"
find an appropriate debugger to use
"
debugger := self appropriateDebugger:#'enter:withMessage:'.
debugger isNil ifTrue:[
^ AbortSignal raise
].
^ debugger enter:aContext withMessage:aString.
"Modified: 24.7.1997 / 10:09:20 / cg"
!
error
"{ Pragma: +optSpace }"
"report error that an error occured.
The error is reported by raising the ErrorSignal exception."
^ ErrorSignal raiseIn:thisContext sender
"Modified: 8.5.1996 / 09:13:01 / cg"
!
error:aString
"{ Pragma: +optSpace }"
"enter debugger with error-message aString.
The error is reported by raising the ErrorSignal exception."
^ ErrorSignal raiseRequestWith:#error:
errorString:aString
in:thisContext sender
"Modified: 8.5.1996 / 09:13:04 / cg"
!
error:aString in:aContext
"{ Pragma: +optSpace }"
"enter debugger with error-message aString.
The error is reported by raising the ErrorSignal exception."
^ ErrorSignal raiseRequestWith:#error:
errorString:aString
in:aContext
"Created: 8.5.1996 / 09:07:59 / cg"
"Modified: 8.5.1996 / 09:13:06 / cg"
!
errorKeyNotFound:aKey
"{ Pragma: +optSpace }"
"report an error that a key was not found in a collection.
The error is reported by raising the KeyNotFoundSignal exception."
^ KeyNotFoundSignal raiseRequestWith:aKey in:thisContext sender
"Modified: 8.5.1996 / 09:13:08 / cg"
!
errorNotFound
"{ Pragma: +optSpace }"
"report an error that no element was found in a collection.
The error is reported by raising the NotFoundSignal exception."
^ NotFoundSignal raiseIn:thisContext sender
"Modified: 8.5.1996 / 09:13:11 / cg"
!
errorSignal
^ self class errorSignal
"Created: / 19.6.1998 / 02:32:32 / cg"
!
halt
"{ Pragma: +optSpace }"
"enter debugger with halt-message.
The error is reported by raising the HaltSignal exception."
^ HaltSignal raiseIn:thisContext sender.
"Modified: 8.5.1996 / 09:12:38 / cg"
!
halt:aString
"{ Pragma: +optSpace }"
"enter debugger with halt-message.
The error is reported by raising the HaltSignal exception."
^ HaltSignal raiseRequestWith:#halt:
errorString:aString
in:thisContext sender
"Modified: 8.5.1996 / 09:13:23 / cg"
!
implementedBySubclass
"{ Pragma: +optSpace }"
"this is sent by ST/V code - its the same as #subclassResponsibility"
^ self subclassResponsibility
!
indexNotInteger
"{ Pragma: +optSpace }"
"report an error that index is not an Integer.
(when accessing collections indexed by an integer key).
The error is reported by raising the NonIntegerIndexSignal exception."
^ NonIntegerIndexSignal raiseIn:thisContext sender
"Modified: 8.5.1996 / 09:13:37 / cg"
!
indexNotInteger:anIndex
"{ Pragma: +optSpace }"
"report an error that index is not an Integer.
(when accessing collections indexed by an integer key).
The error is reported by raising the NonIntegerIndexSignal exception."
^ NonIntegerIndexSignal
raiseRequestWith:anIndex
in:thisContext sender
"Created: / 16.5.1998 / 19:39:41 / cg"
!
integerCheckError
"{ Pragma: +optSpace }"
"generated when a variable declared with an integer type gets a bad
value assigned"
^ self error:'bad assign of ' , self printString ,
' (' , self class name , ') to integer-typed variable'
!
invalidCodeObject
"{ Pragma: +optSpace }"
self error:'not an executable code object'
"Created: 1.8.1997 / 00:16:44 / cg"
!
invalidMessage
"{ Pragma: +optSpace }"
"this is sent by ST/V code - its the same as #shouldNotImplement"
^ self shouldNotImplement
!
mustBeRectangle
"{ Pragma: +optSpace }"
"report an argument-not-rectangle-error"
^ self error:'argument must be a Rectangle'
!
mustBeString
"{ Pragma: +optSpace }"
"report an argument-not-string-error"
^ self error:'argument must be a String'
!
notIndexed
"{ Pragma: +optSpace }"
"report an error that receiver has no indexed instance variables.
The error is reported by raising the SubscriptOutOfBoundsSignal exception."
^ SubscriptOutOfBoundsSignal
raiseErrorString:'receiver has no indexed variables'
in:thisContext sender
"Modified: 26.7.1996 / 16:43:13 / cg"
!
primitiveFailed
"{ Pragma: +optSpace }"
"report an error that some primitive code failed.
The error is reported by raising the PrimitiveFailureSignal exception."
^ PrimitiveFailureSignal raiseIn:(thisContext sender)
"Modified: 8.5.1996 / 09:14:07 / cg"
!
shouldNotImplement
"{ Pragma: +optSpace }"
"report an error that this message should not be implemented"
^ self error:'method not appropriate for this class'
"Modified: 8.5.1996 / 09:09:44 / cg"
!
subclassResponsibility
"{ Pragma: +optSpace }"
"report an error that this message should have been reimplemented in a
subclass"
^ self error:'method must be reimplemented in subclass' in:thisContext sender
"Modified: 8.5.1996 / 09:09:26 / cg"
!
subscriptBoundsError
"{ Pragma: +optSpace }"
"report an error that some index is out of bounds.
(when accessing indexable collections).
The error is reported by raising the SubscriptOutOfBoundsSignal exception."
^ SubscriptOutOfBoundsSignal
raiseIn:thisContext sender
"Modified: 26.7.1996 / 16:45:42 / cg"
!
subscriptBoundsError:anIndex
"{ Pragma: +optSpace }"
"report an error that anIndex is out of bounds.
(when accessing indexable collections).
The error is reported by raising the SubscriptOutOfBoundsSignal exception."
^ SubscriptOutOfBoundsSignal
raiseRequestWith:anIndex
errorString:('subscript (' , anIndex printString , ') out of bounds')
in:thisContext sender
"Modified: 8.5.1996 / 09:14:34 / cg"
!
typeCheckError
"{ Pragma: +optSpace }"
"generated when a variable declared with a type hint gets a bad
value assigned"
^ self error:'bad assign of ' , self printString ,
' (' , self class name , ') to typed variable'
! !
!Object methodsFor:'evaluation'!
value
"return the receiver itself.
This allows every object to be used where blocks or valueHolders
are typically used, and allows for valueHolders and blocks to be
used interchangably in some situations.
Time will show, if this is a good idea or leads to sloppy programming
style ... (the idea was borrowed from the Self language).
WARNING: dont 'optimize' away ifXXX: blocks
(i.e. do NOT replace
foo ifTrue:[var1] ifFalse:[var2]
by:
foo ifTrue:var1 ifFalse:var2
)
- the compilers will only generate inline code for the if,
iff the argument(s) are blocks - otherwise, a true send is
generated.
This 'oprimization' will work semantically correct,
but execute SLOWER instead."
^ self
"
#(1 2 3 4) indexOf:5 ifAbsent:0
#(1 2 3 4) indexOf:5 ifAbsent:[0]
1 > 2 ifTrue:['yes'] ifFalse:['no']
1 > 2 ifTrue:'yes' ifFalse:'no'
"
"DO NOT DO THIS (its slower)
(1 > 4) ifTrue:'oops' ifFalse:'ok'
USE (the compiler optimizes blocks in if/while):
(1 > 4) ifTrue:['oops'] ifFalse:['ok']
"
"Modified: 3.5.1996 / 11:57:08 / cg"
! !
!Object methodsFor:'finalization'!
finalize
"subclasses may redefine this method"
^ self
"Created: / 4.3.1998 / 10:40:30 / stefan"
! !
!Object methodsFor:'initialization'!
initialize
"just to ignore initialize to objects which do not need it"
^ self
! !
!Object methodsFor:'interest'!
addInterest:anInterest
"install an interest forwarder.
Here, we use the nonWeakDependencies."
self addNonWeakDependent:anInterest
"Created: 14.10.1996 / 22:27:34 / stefan"
!
expressInterestIn:aspect for:anObject sendBack:aSelector
"arrange for aSelector to be sent to anObject whenever the receiver
changes aspect."
"/ for now, use an interestConverter, which is somewhat less efficient.
"/ In the future, a more intelligent DependencyCollection class is planned for
self addInterest:(InterestConverter
destination:anObject
selector:aSelector
aspect:aspect)
"
|p b|
b := [Transcript showCR:' -> the point changed'].
p := Point new.
Transcript showCR:'interest in #foo:'.
p expressInterestIn:#foo for:b sendBack:#value.
p x:1.
Transcript showCR:'now changing #bar ... (expect no notification)'.
p changed:#bar.
Transcript cr.
Delay waitForSeconds:1.
Transcript showCR:'now changing #foo ... (expect notification)'.
p changed:#foo.
Transcript cr.
Delay waitForSeconds:1.
Transcript showCR:'no more interest in #foo:'.
p retractInterestIn:#foo for:b.
Transcript showCR:'now changing #foo ... (expect no notification)'.
p changed:#foo.
Transcript cr.
Delay waitForSeconds:1.
Transcript showCR:'interest in #bar now:'.
p expressInterestIn:#bar for:b sendBack:#value.
Transcript showCR:'now changing #foo ... (expect no notification)'.
p changed:#foo.
Transcript showCR:'now changing #bar ... (expect notification)'.
p changed:#bar.
Transcript cr.
Delay waitForSeconds:1.
Transcript showCR:'interest in #foo now:'.
p expressInterestIn:#foo for:b sendBack:#value.
Transcript showCR:'now changing #foo ... (expect notification)'.
p changed:#foo.
Transcript showCR:'now changing #bar ... (expect notification)'.
p changed:#bar.
Transcript cr.
Delay waitForSeconds:1.
Transcript showCR:'no more interests:'.
p retractInterestsFor:b.
Transcript showCR:'now changing #foo ... (expect no notification)'.
p changed:#foo.
Transcript showCR:'now changing #bar... (expect no notification)'.
p changed:#bar.
Transcript cr.
p release.
"
"Created: 19.4.1996 / 10:26:22 / cg"
"Modified: 19.4.1996 / 12:34:08 / cg"
"Modified: 14.10.1996 / 22:28:20 / stefan"
!
interests
"return a Collection of interests - empty if there is none.
Here, we use the nonWeakDependents for interests."
^ self nonWeakDependents
"Created: / 14.10.1996 / 22:20:51 / stefan"
"Modified: / 30.1.1998 / 14:07:35 / cg"
!
interestsFor:someOne
"return a collection of interests of someOne - empty if there is none."
|coll deps|
deps := self interests.
deps size == 0 ifTrue:[^ #()].
coll := IdentitySet new.
deps do:[:dep |
(dep isMemberOf:InterestConverter) ifTrue:[
dep destination == someOne ifTrue:[
coll add:dep.
]
]
].
^ coll
"Created: / 30.1.1998 / 14:02:26 / cg"
"Modified: / 30.1.1998 / 14:08:24 / cg"
!
onChangeSend:aSelector to:anObject
"arrange for aSelector to be sent to anObject whenever the receiver
changes."
"/ for now, use an interestConverter, which is somewhat less efficient.
"/ In the future, a more intelligent DependencyCollection class is planned for
self addInterest:(InterestConverter
destination:anObject
selector:aSelector)
"
|p b|
b := [Transcript showCR:'the point changed'].
p := Point new.
p onChangeSend:#value to:b.
p x:1.
Transcript showCR:'now changing'.
p changed.
Transcript cr.
Delay waitForSeconds:1.
Transcript showCR:'now changing'.
p changed.
Transcript cr.
Delay waitForSeconds:1.
Transcript showCR:'no more interest'.
p retractInterestsFor:b.
Transcript showCR:'now changing again'.
p changed.
Transcript cr.
Delay waitForSeconds:1.
Transcript showCR:'interest again'.
p onChangeSend:#value to:b.
Transcript showCR:'now changing again'.
p changed.
Transcript cr.
"
"Created: 19.4.1996 / 10:26:38 / cg"
"Modified: 19.4.1996 / 12:34:26 / cg"
"Modified: 14.10.1996 / 22:28:27 / stefan"
!
removeInterest:anInterest
"remove an interest forwarder.
Here, we use the nonWeakDependencies."
self removeNonWeakDependent:anInterest
"Created: 14.10.1996 / 22:21:59 / stefan"
!
retractInterestIn:aspect for:someOne
"remove the interest of someOne in the receiver changing aspect
(as installed with #expressInterestIn:for:sendBack:)."
"/ for now, remove the interestConverter.
"/ In the future, a more intelligent DependencyCollection class is planned for
"/ cannot removeDependent within the loop - the collection rehashes
|deps coll|
deps := self interests.
deps size ~~ 0 ifTrue:[
coll := IdentitySet new.
deps do:[:dep |
(dep isMemberOf:InterestConverter) ifTrue:[
dep destination == someOne ifTrue:[
dep aspect == aspect ifTrue:[
self removeInterest:dep.
^ self
]
]
]
].
coll do:[:dep |
self removeInterest:dep.
].
].
"
|p b|
b := [Transcript showCR:'the point changed'].
p := Point new.
Transcript showCR:'interest in #foo'.
p expressInterestIn:#foo for:b sendBack:#value.
p x:1.
Transcript showCR:'now changing #bar'.
p changed:#bar.
Transcript cr.
Delay waitForSeconds:1.
Transcript showCR:'now changing #foo'.
p changed:#foo.
Transcript cr.
Delay waitForSeconds:1.
Transcript showCR:'no more interest in #foo'.
p retractInterestIn:#foo for:b.
Transcript showCR:'now changing #foo'.
p changed:#foo.
Transcript cr.
Delay waitForSeconds:1.
Transcript showCR:'interest in #bar now'.
p expressInterestIn:#bar for:b sendBack:#value.
Transcript showCR:'now changing #foo'.
p changed:#foo.
Transcript showCR:'now changing #bar'.
p changed:#bar.
Transcript cr.
Delay waitForSeconds:1.
Transcript showCR:'interest in #foo now'.
p expressInterestIn:#foo for:b sendBack:#value.
Transcript showCR:'now changing #foo'.
p changed:#foo.
Transcript showCR:'now changing #bar'.
p changed:#bar.
Transcript cr.
Delay waitForSeconds:1.
Transcript showCR:'no more interests'.
p retractInterestsFor:b.
Transcript showCR:'now changing #foo'.
p changed:#foo.
Transcript showCR:'now changing #bar'.
p changed:#bar.
Transcript cr.
"
"Created: / 19.4.1996 / 10:27:11 / cg"
"Modified: / 14.10.1996 / 22:21:19 / stefan"
"Modified: / 30.1.1998 / 14:05:34 / cg"
!
retractInterestsFor:someOne
"remove the interest of someOne in the receiver
(as installed with #onChangeSend:to:)."
"/ for now, remove the interestConverter.
"/ In the future, a more intelligent DependencyCollection class is planned for
|coll deps|
"/ cannot removeDependent within the loop - the collection rehashes
deps := self interests.
deps size ~~ 0 ifTrue:[
coll := IdentitySet new.
deps do:[:dep |
(dep isMemberOf:InterestConverter) ifTrue:[
dep destination == someOne ifTrue:[
coll add:dep.
]
]
].
coll do:[:dep |
self removeInterest:dep.
].
].
"
|p b|
b := [Transcript showCR:'the point changed'].
p := Point new.
p onChangeSend:#value to:b.
p x:1.
Transcript showCR:'now changing'.
p changed.
Transcript cr.
Delay waitForSeconds:1.
Transcript showCR:'now changing'.
p changed.
Transcript cr.
Delay waitForSeconds:1.
Transcript showCR:'no more interest'.
p retractInterestsFor:b.
Transcript showCR:'now changing again'.
p changed.
Transcript cr.
Delay waitForSeconds:1.
Transcript showCR:'interest again'.
p onChangeSend:#value to:b.
Transcript showCR:'now changing again'.
p changed.
Transcript cr.
"
"Created: / 19.4.1996 / 10:23:46 / cg"
"Modified: / 14.10.1996 / 22:21:25 / stefan"
"Modified: / 30.1.1998 / 14:04:52 / cg"
! !
!Object methodsFor:'interrupt handling'!
childSignalInterrupt
"death of a child process (unix process) - do nothing"
^ self
!
customInterrupt
"{ Pragma: +optSpace }"
"a custom interrupt"
^ self error:'custom interrupt'
!
errorInterrupt:errorID with:aParameter
"subsystem error. The arguments errorID and aParameter are the values passed
to the 'errorInterruptWithIDAndParameter(id, param)' function,
which can be called from C subsystems to raise an (asynchronous)
error exception.
Currently, this is used to map XErrors to smalltalk errors, but can be
used from other C subsystems too, to upcast errors.
Especially, for subsystems which call errorHandler functions asynchronously.
IDs (currently) used:
#DisplayError ..... x-error interrupt
#XtError ..... xt-error interrupt (Xt interface is not yet published)
"
|handler|
handler := ObjectMemory registeredErrorInterruptHandlers at:errorID ifAbsent:nil.
handler notNil ifTrue:[
"/
"/ handler found; let it do whatever it wants ...
"/
handler errorInterrupt:errorID with:aParameter.
^ self
].
"/
"/ no handler - raise errorSignal passing the errorId as parameter
"/
^ ErrorSignal
raiseRequestWith:errorID
errorString:('Subsystem error. ErrorID = ' , errorID printString)
!
exceptionInterrupt
"{ Pragma: +optSpace }"
"exception interrupt - enter debugger"
self error:'exception Interrupt'
!
fpExceptionInterrupt
"{ Pragma: +optSpace }"
"a floating point exception occured - this one
has to be handled differently since it comes asynchronous
on some machines (for example, on machines with a separate FPU
or superscalar architectures. Also, errors from within primitive code
(or library functions such as GL) are sent via the Unix-signal
mechanism this way."
|where rec|
where := thisContext sender.
rec := where receiver.
rec isNumber ifTrue:[
^ rec class
raise:#domainErrorSignal
receiver:rec
selector:where selector
arguments:(where args asArray)
errorString:'floating point exception'
].
"/ could be in some C-library ...
^ Float domainErrorSignal raise
!
internalError:msg
"{ Pragma: +optSpace }"
"this is triggered, when VM hits some bad error,
such as corrupted class, corrupted method/selector array
etc. The argument string gives some more information on what happened.
(for example, if you set an objects class to a non-behavior, nil etc.).
Its not guaranteed, that the system is in a working condition once
this error occurred ...."
^ InternalErrorSignal
raiseRequestWith:self
errorString:msg
!
ioInterrupt
"{ Pragma: +optSpace }"
"I/O (SIGIO/SIGPOLL) interrupt (supposed to be sent to Processor).
If we arrive here, there is either no handler (ObjMem>>ioInterruptHandler)
or it does not understand the ioInterrupt message.
In any case, this is a sign of some big trouble. Enter debugger."
self error:'I/O Interrupt - but no handler'
!
memoryInterrupt
"{ Pragma: +optSpace }"
"out-of-memory interrupt and no handler - enter debugger"
^ self error:'almost out of memory'
!
recursionInterrupt
"{ Pragma: +optSpace }"
"recursion limit (actually: stack overflow) interrupt.
This interrupt is triggered, when a process stack grows above
its stackLimit - usually, this leads into the debugger, but
could be caught and the stackLimit increased in the handler.
At the time we arrive here, the system has still some stack
as a reserve so we can continue to do some useful work or cleanup or
debugging for a while.
If the signal is ignored, and the stack continues to grow, there
will be a few more chances (and more interrupts) before the VM
hard-terminates the process."
thisContext isRecursive ifFalse:[
^ RecursionInterruptSignal raise
]
!
schedulerInterrupt
"{ Pragma: +optSpace }"
"scheduler interrupt (supposed to be sent to Processor).
If we arrive here, either the Processor does not understand it,
or it has been set to nil. In any case, this is a sign of some
big trouble. Enter debugger."
self error:'schedulerInterrupt - but no Processor'
!
signalInterrupt:signalNumber
"{ Pragma: +optSpace }"
"unix signal occured - some signals are handled as Smalltalk Exceptions
(SIGPIPE), others (SIGBUS) are rather fatal ...
In any case, IF a smalltalk-signal has been connected to the OS signal,
that one is raised.
Otherwise, a dialog is shown, asking the user on how to handle the
signal.
TODO: add another argument, giving more detailed signal info (PC, VADDR,
exact cause etc.). This helps if segvs occur in primitive code.
Currently (temporary kludge), these are passed as global variables."
|box name here sig ignorable titles actions badContext msg pc addr
action title|
"
special case - since SIGPIPE has an ST-signal associated
"
(signalNumber == 13) ifTrue:[
"SIGPIPE - write on a pipe with no one to read"
^ PipeStream brokenPipeSignal raise.
].
"if there has been an ST-signal installed, use it ..."
sig := OperatingSystem operatingSystemSignal:signalNumber.
sig notNil ifTrue:[
^ sig raise
].
"/ if handled, raise OSSignalInterruptSignal
OSSignalInterruptSignal isHandled ifTrue:[
^ OSSignalInterruptSignal raiseWith:signalNumber
].
"
... otherwise , bring up a box asking for what to do ...
"
name := OperatingSystem nameForSignal:signalNumber.
here := thisContext.
"
the context, in which the signal occurred:
"
badContext := here sender.
"
ungrab - in case it happened in a box/popupview
otherwise display stays locked
"
"/ Display notNil ifTrue:[
"/ Display ungrabPointer.
"/ Display ungrabKeyboard.
"/ ].
Screen notNil ifTrue:[
Screen allScreens do:[:aScreen |
aScreen ungrabPointer.
aScreen ungrabKeyboard.
]
].
"
SIGBUS, SIGSEGV and SIGILL do not make sense to ignore (i.e. continue)
since the system will retry the faulty instruction, which leads to
another signal - to avoid frustration, better not offer this option.
"
ignorable := (signalNumber ~~ OperatingSystem sigBUS)
and:[signalNumber ~~ OperatingSystem sigILL
and:[signalNumber ~~ OperatingSystem sigSEGV]].
ignorable ifFalse:[
here isRecursive ifTrue:[
'Object [hard error]: signal ' errorPrint. signalNumber errorPrintCR.
MiniDebugger enterWithMessage:'recursive signal'.
^ self
].
"
a hard signal - go into debugger immediately
"
msg := 'OS-signal: ', name.
"/ the IRQ-PC is passed as low-hi, to avoid the need
"/ to allocate a LargeInteger in the VM during signal
"/ time. I know, this is ugly.
InterruptPcLow notNil ifTrue:[
pc := InterruptPcLow + (InterruptPcHi bitShift:(SmallInteger maxBits + 1 // 2)).
pc ~~ 0 ifTrue:[
msg := msg , ' PC=' , (pc printStringRadix:16)
].
].
InterruptAddrLow notNil ifTrue:[
addr := InterruptAddrLow + (InterruptAddrHi bitShift:(SmallInteger maxBits + 1 // 2)).
addr ~~ 0 ifTrue:[
msg := msg , ' ADDR=' , (addr printStringRadix:16)
].
].
Debugger enter:here withMessage:msg.
badContext return.
^ nil.
].
OptionBox isNil ifTrue:[
"
a system without GUI ...
go into minidebugger (if there is one)
"
MiniDebugger isNil ifTrue:[
"
a system without debugging facilities
(i.e. a standalone system)
output a message and exit.
"
('Object [error]: exit due to Signal ' , name , ' - and no debugger.') errorPrintCR.
Smalltalk exit.
].
MiniDebugger enterWithMessage:'Signal caught (' , name, ')'.
^ self
].
titles := #('dump core' 'exit ST/X').
actions := Array
with:[Smalltalk fatalAbort]
with:[Smalltalk exit].
action := nil.
title := 'OS Signal caught (' , name, ')'.
title := (title , '\[in ST-process: ' , Processor activeProcess nameOrId ,']') withCRs.
"/ if cought while in the scheduler or event dispatcher,
"/ a modal dialog is not possible ...
"/ (therefore, debug & return make no sense)
Processor activeProcess isSystemProcess ifFalse:[
titles := #('abort' 'debug') , titles.
actions := (Array
with:[action := #abort]
with:[action := #debug]) , actions.
badContext canReturn ifTrue:[
titles := #('return') , titles.
actions := (Array with:[action := #return]) , actions.
].
].
ignorable ifTrue:[
titles := titles, #('ignore').
actions := actions , (Array with:[action := #ignore]).
].
box := OptionBox
title:title
numberOfOptions:actions size.
ignorable ifTrue:[
box defaultButtonIndex:(actions size)
].
box buttonTitles:titles.
box actions:actions.
box showAtPointer.
action == #return ifTrue:[
badContext return
].
action == #abort ifTrue:[
AbortSignal raise.
].
action == #debug ifTrue:[
Debugger enter:here withMessage:('Signal ', name).
].
"Modified: / 4.5.1998 / 20:39:16 / cg"
!
spyInterrupt
"{ Pragma: +optSpace }"
"spy interrupt and no handler - enter debugger"
self error:'spy Interrupt - but no handler'
!
timerInterrupt
"{ Pragma: +optSpace }"
"timer interrupt and no handler - enter debugger"
self error:'timer Interrupt - but no handler'
!
userInterrupt
"{ Pragma: +optSpace }"
"user (^c) interrupt.
This is typically sent by the VM, when a ctrl-C is typed at the
controlling tty (i.e. in the xterm)."
UserInterruptSignal raise
!
userInterruptIn:aContext
"{ Pragma: +optSpace }"
"user (^c) interrupt - enter debugger, but show aContext
as top-context.
This is used to hide any intermediate scheduler contexts,
in case of an interrupted process. Typically, this is sent by
the WindowGroup, when a keyboardEvent for the ctrl-C key is
processed."
UserInterruptSignal raiseIn:aContext
"Created: 18.10.1996 / 20:46:04 / cg"
"Modified: 20.10.1996 / 13:06:38 / cg"
! !
!Object methodsFor:'message sending'!
perform:aSelector
"send the message aSelector to the receiver"
%{
REGISTER OBJ sel = aSelector;
struct inlineCache *pIlc;
static struct inlineCache ilc_0 = __ILCPERF0(@line);
static struct inlineCache ilc_1 = __ILCPERF0(@line);
static struct inlineCache ilc_2 = __ILCPERF0(@line);
static struct inlineCache ilc_3 = __ILCPERF0(@line);
static struct inlineCache ilc_4 = __ILCPERF0(@line);
static OBJ last_0 = nil;
static OBJ last_1 = nil;
static OBJ last_2 = nil;
static OBJ last_3 = nil;
static OBJ last_4 = nil;
static flip = 0;
if (InterruptPending == nil) {
if (sel == last_0) {
RETURN ( (*(ilc_0.ilc_func))(self, sel, nil, &ilc_0) );
}
if (sel == last_1) {
RETURN ( (*(ilc_1.ilc_func))(self, sel, nil, &ilc_1) );
}
if (sel == last_2) {
RETURN ( (*(ilc_2.ilc_func))(self, sel, nil, &ilc_2) );
}
if (sel == last_3) {
RETURN ( (*(ilc_3.ilc_func))(self, sel, nil, &ilc_3) );
}
if (sel == last_4) {
RETURN ( (*(ilc_4.ilc_func))(self, sel, nil, &ilc_4) );
}
if (flip == 0) {
pIlc = &ilc_0;
flip = 1;
last_0 = sel;
} else if (flip == 1) {
pIlc = &ilc_1;
flip = 2;
last_1 = sel;
} else if (flip == 2) {
pIlc = &ilc_2;
flip = 3;
last_2 = sel;
} else if (flip == 3) {
pIlc = &ilc_3;
flip = 4;
last_3 = sel;
} else {
pIlc = &ilc_4;
flip = 0;
last_4 = sel;
}
pIlc->ilc_func = __SEND0ADDR__;
if (pIlc->ilc_poly) {
__flushPolyCache(pIlc->ilc_poly);
pIlc->ilc_poly = 0;
}
RETURN ( (*(pIlc->ilc_func))(self, sel, nil, pIlc) );
} else {
static struct inlineCache ilc0 = __DUMMYILCSELF0(@line+1);
RETURN (_SEND0(self, aSelector, nil, &ilc0));
}
%}
!
perform:aSelector inClass:aClass withArguments:argArray
"send the message aSelector with all args taken from argArray
to the receiver as a super-send message.
This is actually more flexible than the normal super-send, since it allows
to execute a method in ANY superclass of the receiver (not just the
immediate superclass).
Thus, it is (theoretically) possible to do
'5 perform:#< inClass:Magnitude withArguments:#(6)'
and evaluate Magnitudes compare method even if there was one in Number.
This method is used by the interpreter to evaluate super sends
and could be used for very special behavior (language extension ?).
WARNING: this is an ST/X feature - probably not found in other smalltalks."
|numberOfArgs a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15|
"
check, if aClass is really a superclass of the receiver
"
(self class isSubclassOf:aClass) ifFalse:[
self error:'class argument is not a superclass of the receiver'.
^ nil
].
%{
REGISTER OBJ *argP;
int nargs, i;
if (__isArray(argArray)) {
nargs = __arraySize(argArray);
argP = __ArrayInstPtr(argArray)->a_element;
} else {
if (__isNonNilObject(argArray)) {
static struct inlineCache ilcSize = __ILC0(@line+1);
numberOfArgs = (*ilcSize.ilc_func)(argArray, @symbol(size), nil, &ilcSize);
if (!__isSmallInteger(numberOfArgs))
goto bad;
nargs = __intVal(numberOfArgs);
argP = (OBJ *)(&a1);
for (i=1; i <= nargs; i++) {
*argP++ = __AT_(argArray, __MKSMALLINT(i));
}
argP = (OBJ *)(&a1);
} else {
nargs = 0;
}
}
switch (nargs) {
case 0:
{
static struct inlineCache ilc0 = __DUMMYILCSELF0(@line+1);
RETURN ( _SEND0(self, aSelector, aClass, &ilc0));
}
case 1:
{
static struct inlineCache ilc1 = __DUMMYILCSELF1(@line+1);
RETURN ( _SEND1(self, aSelector, aClass, &ilc1, argP[0]));
}
case 2:
{
static struct inlineCache ilc2 = __DUMMYILCSELF2(@line+1);
RETURN ( _SEND2(self, aSelector, aClass, &ilc2, argP[0], argP[1]));
}
case 3:
{
static struct inlineCache ilc3 = __DUMMYILCSELF3(@line+1);
RETURN ( _SEND3(self, aSelector, aClass, &ilc3,
argP[0], argP[1], argP[2]));
}
case 4:
{
static struct inlineCache ilc4 = __DUMMYILCSELF4(@line+1);
RETURN ( _SEND4(self, aSelector, aClass, &ilc4,
argP[0], argP[1], argP[2], argP[3]));
}
case 5:
{
static struct inlineCache ilc5 = __DUMMYILCSELF5(@line+1);
RETURN ( _SEND5(self, aSelector, aClass, &ilc5,
argP[0], argP[1], argP[2], argP[3], argP[4]));
}
case 6:
{
static struct inlineCache ilc6 = __DUMMYILCSELF6(@line+1);
RETURN ( _SEND6(self, aSelector, aClass, &ilc6,
argP[0], argP[1], argP[2], argP[3], argP[4], argP[5]));
}
case 7:
{
static struct inlineCache ilc7 = __DUMMYILCSELF7(@line+1);
RETURN ( _SEND7(self, aSelector, aClass, &ilc7,
argP[0], argP[1], argP[2], argP[3], argP[4], argP[5],
argP[6]));
}
case 8:
{
static struct inlineCache ilc8 = __DUMMYILCSELF8(@line+1);
RETURN ( _SEND8(self, aSelector, aClass, &ilc8,
argP[0], argP[1], argP[2], argP[3], argP[4], argP[5],
argP[6], argP[7]));
}
case 9:
{
static struct inlineCache ilc9 = __DUMMYILCSELF9(@line+1);
RETURN ( _SEND9(self, aSelector, aClass, &ilc9,
argP[0], argP[1], argP[2], argP[3], argP[4], argP[5],
argP[6], argP[7], argP[8]));
}
case 10:
{
static struct inlineCache ilc10 = __DUMMYILCSELF10(@line+1);
RETURN ( _SEND10(self, aSelector, aClass, &ilc10,
argP[0], argP[1], argP[2], argP[3], argP[4], argP[5],
argP[6], argP[7], argP[8], argP[9]));
}
case 11:
{
static struct inlineCache ilc11 = __DUMMYILCSELF11(@line+1);
RETURN ( _SEND11(self, aSelector, aClass, &ilc11,
argP[0], argP[1], argP[2], argP[3], argP[4], argP[5],
argP[6], argP[7], argP[8], argP[9], argP[10]));
}
case 12:
{
static struct inlineCache ilc12 = __DUMMYILCSELF12(@line+1);
RETURN ( _SEND12(self, aSelector, aClass, &ilc12,
argP[0], argP[1], argP[2], argP[3], argP[4], argP[5],
argP[6], argP[7], argP[8], argP[9], argP[10],
argP[11]));
}
case 13:
{
static struct inlineCache ilc13 = __DUMMYILCSELF13(@line+1);
RETURN ( _SEND13(self, aSelector, aClass, &ilc13,
argP[0], argP[1], argP[2], argP[3], argP[4], argP[5],
argP[6], argP[7], argP[8], argP[9], argP[10],
argP[11], argP[12]));
}
case 14:
{
static struct inlineCache ilc14 = __DUMMYILCSELF14(@line+1);
RETURN ( _SEND14(self, aSelector, aClass, &ilc14,
argP[0], argP[1], argP[2], argP[3], argP[4], argP[5],
argP[6], argP[7], argP[8], argP[9], argP[10],
argP[11], argP[12], argP[13]));
}
case 15:
{
static struct inlineCache ilc15 = __DUMMYILCSELF15(@line+1);
RETURN ( _SEND15(self, aSelector, aClass, &ilc15,
argP[0], argP[1], argP[2], argP[3], argP[4], argP[5],
argP[6], argP[7], argP[8], argP[9], argP[10],
argP[11], argP[12], argP[13], argP[14]));
}
#ifdef _SEND16
case 16:
{
static struct inlineCache ilc16 = __DUMMYILCSELF16(@line+1);
RETURN ( _SEND15(self, aSelector, aClass, &ilc15,
argP[0], argP[1], argP[2], argP[3], argP[4], argP[5],
argP[6], argP[7], argP[8], argP[9], argP[10],
argP[11], argP[12], argP[13], argP[14], argP[15]));
}
#endif
}
bad:;
%}.
"/ arrive here, if bad number of arguments (too many)
"/ ST/X (currently) only allows up to 15 method arguments
^ self primitiveFailed
!
perform:aSelector with:arg
"send the one-arg-message aSelector to the receiver"
%{
REGISTER OBJ sel = aSelector;
struct inlineCache *pIlc;
static struct inlineCache ilc_0 = __ILCPERF1(@line);
static struct inlineCache ilc_1 = __ILCPERF1(@line);
static struct inlineCache ilc_2 = __ILCPERF1(@line);
static struct inlineCache ilc_3 = __ILCPERF1(@line);
static struct inlineCache ilc_4 = __ILCPERF1(@line);
static OBJ last_0 = nil;
static OBJ last_1 = nil;
static OBJ last_2 = nil;
static OBJ last_3 = nil;
static OBJ last_4 = nil;
static flip = 0;
if (InterruptPending == nil) {
if (sel == last_0) {
RETURN ( (*(ilc_0.ilc_func))(self, sel, nil, &ilc_0, arg) );
}
if (sel == last_1) {
RETURN ( (*(ilc_1.ilc_func))(self, sel, nil, &ilc_1, arg) );
}
if (sel == last_2) {
RETURN ( (*(ilc_2.ilc_func))(self, sel, nil, &ilc_2, arg) );
}
if (sel == last_3) {
RETURN ( (*(ilc_3.ilc_func))(self, sel, nil, &ilc_3, arg) );
}
if (sel == last_4) {
RETURN ( (*(ilc_4.ilc_func))(self, sel, nil, &ilc_4, arg) );
}
if (flip == 0) {
pIlc = &ilc_0;
flip = 1;
last_0 = sel;
} else if (flip == 1) {
pIlc = &ilc_1;
flip = 2;
last_1 = sel;
} else if (flip == 2) {
pIlc = &ilc_2;
flip = 3;
last_2 = sel;
} else if (flip == 3) {
pIlc = &ilc_3;
flip = 4;
last_3 = sel;
} else {
pIlc = &ilc_4;
flip = 0;
last_4 = sel;
}
pIlc->ilc_func = __SEND1ADDR__;
if (pIlc->ilc_poly) {
__flushPolyCache(pIlc->ilc_poly);
pIlc->ilc_poly = 0;
}
RETURN ( (*(pIlc->ilc_func))(self, sel, nil, pIlc, arg) );
} else {
static struct inlineCache ilc1 = __DUMMYILCSELF1(@line+1);
RETURN (_SEND1(self, aSelector, nil, &ilc1, arg));
}
%}
!
perform:aSelector with:arg1 with:arg2
"send the two-arg-message aSelector to the receiver"
%{
struct inlineCache *pIlc;
static struct inlineCache ilc_0 = __ILCPERF2(@line);
static struct inlineCache ilc_1 = __ILCPERF2(@line);
static OBJ last_0 = nil;
static OBJ last_1 = nil;
static flip = 0;
if (InterruptPending == nil) {
if (aSelector != last_0) {
if (aSelector != last_1) {
if (flip) {
pIlc = &ilc_0;
flip = 0;
last_0 = aSelector;
} else {
pIlc = &ilc_1;
flip = 1;
last_1 = aSelector;
}
pIlc->ilc_func = __SEND2ADDR__;
if (pIlc->ilc_poly) {
__flushPolyCache(pIlc->ilc_poly);
pIlc->ilc_poly = 0;
}
} else {
pIlc = &ilc_1;
}
} else {
pIlc = &ilc_0;
}
RETURN ( (*(pIlc->ilc_func))(self, aSelector, nil, pIlc, arg1, arg2) );
} else {
static struct inlineCache ilc2 = __DUMMYILCSELF2(@line+1);
RETURN (_SEND2(self, aSelector, nil, &ilc2, arg1, arg2));
}
%}
!
perform:aSelector with:arg1 with:arg2 with:arg3
"send the three-arg-message aSelector to the receiver"
%{
struct inlineCache *pIlc;
static struct inlineCache ilc_0 = __ILCPERF3(@line);
static struct inlineCache ilc_1 = __ILCPERF3(@line);
static OBJ last_0 = nil;
static OBJ last_1 = nil;
static flip = 0;
if (InterruptPending == nil) {
if (aSelector != last_0) {
if (aSelector != last_1) {
if (flip) {
pIlc = &ilc_0;
flip = 0;
last_0 = aSelector;
} else {
pIlc = &ilc_1;
flip = 1;
last_1 = aSelector;
}
pIlc->ilc_func = __SEND3ADDR__;
if (pIlc->ilc_poly) {
__flushPolyCache(pIlc->ilc_poly);
pIlc->ilc_poly = 0;
}
} else {
pIlc = &ilc_1;
}
} else {
pIlc = &ilc_0;
}
RETURN ( (*(pIlc->ilc_func))(self, aSelector, nil, pIlc,
arg1, arg2, arg3) );
} else {
static struct inlineCache ilc3 = __DUMMYILCSELF3(@line+1);
RETURN (_SEND3(self, aSelector, nil, &ilc3, arg1, arg2, arg3));
}
%}
!
perform:aSelector with:arg1 with:arg2 with:arg3 with:arg4
"send the four-arg-message aSelector to the receiver"
%{
struct inlineCache *pIlc;
static struct inlineCache ilc_0 = __ILCPERF4(@line);
static struct inlineCache ilc_1 = __ILCPERF4(@line);
static OBJ last_0 = nil;
static OBJ last_1 = nil;
static flip = 0;
if (InterruptPending == nil) {
if (aSelector != last_0) {
if (aSelector != last_1) {
if (flip) {
pIlc = &ilc_0;
flip = 0;
last_0 = aSelector;
} else {
pIlc = &ilc_1;
flip = 1;
last_1 = aSelector;
}
pIlc->ilc_func = __SEND4ADDR__;
if (pIlc->ilc_poly) {
__flushPolyCache(pIlc->ilc_poly);
pIlc->ilc_poly = 0;
}
} else {
pIlc = &ilc_1;
}
} else {
pIlc = &ilc_0;
}
RETURN ( (*(pIlc->ilc_func))(self, aSelector, nil, pIlc,
arg1, arg2, arg3, arg4) );
} else {
static struct inlineCache ilc4 = __DUMMYILCSELF4(@line+1);
RETURN (_SEND4(self, aSelector, nil, &ilc4,
arg1, arg2, arg3, arg4));
}
%}
!
perform:aSelector with:arg1 with:arg2 with:arg3 with:arg4 with:arg5
"send the five-arg-message aSelector to the receiver"
%{
struct inlineCache *pIlc;
static struct inlineCache ilc_0 = __ILCPERF5(@line);
static struct inlineCache ilc_1 = __ILCPERF5(@line);
static OBJ last_0 = nil;
static OBJ last_1 = nil;
static flip = 0;
if (InterruptPending == nil) {
if (aSelector != last_0) {
if (aSelector != last_1) {
if (flip) {
pIlc = &ilc_0;
flip = 0;
last_0 = aSelector;
} else {
pIlc = &ilc_1;
flip = 1;
last_1 = aSelector;
}
pIlc->ilc_func = __SEND5ADDR__;
if (pIlc->ilc_poly) {
__flushPolyCache(pIlc->ilc_poly);
pIlc->ilc_poly = 0;
}
} else {
pIlc = &ilc_1;
}
} else {
pIlc = &ilc_0;
}
RETURN ( (*(pIlc->ilc_func))(self, aSelector, nil, pIlc,
arg1, arg2, arg3, arg4, arg5) );
} else {
static struct inlineCache ilc5 = __DUMMYILCSELF5(@line+1);
RETURN (_SEND5(self, aSelector, nil, &ilc5,
arg1, arg2, arg3, arg4, arg5));
}
%}
!
perform:aSelector with:arg1 with:arg2 with:arg3 with:arg4 with:arg5 with:arg6
"send the six-arg-message aSelector to the receiver"
%{
struct inlineCache *pIlc;
static struct inlineCache ilc_0 = __ILCPERF6(@line);
static struct inlineCache ilc_1 = __ILCPERF6(@line);
static OBJ last_0 = nil;
static OBJ last_1 = nil;
static flip = 0;
if (InterruptPending == nil) {
if (aSelector != last_0) {
if (aSelector != last_1) {
if (flip) {
pIlc = &ilc_0;
flip = 0;
last_0 = aSelector;
} else {
pIlc = &ilc_1;
flip = 1;
last_1 = aSelector;
}
pIlc->ilc_func = __SEND6ADDR__;
if (pIlc->ilc_poly) {
__flushPolyCache(pIlc->ilc_poly);
pIlc->ilc_poly = 0;
}
} else {
pIlc = &ilc_1;
}
} else {
pIlc = &ilc_0;
}
RETURN ( (*(pIlc->ilc_func))(self, aSelector, nil, pIlc,
arg1, arg2, arg3, arg4, arg5, arg6) );
} else {
static struct inlineCache ilc6 = __DUMMYILCSELF6(@line+1);
RETURN (_SEND6(self, aSelector, nil, &ilc6,
arg1, arg2, arg3, arg4, arg5, arg6));
}
%}
!
perform:aSelector withArguments:argArray
"send the message aSelector with all args taken from argArray
to the receiver."
|numberOfArgs a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15|
%{
REGISTER OBJ *argP;
int nargs, i;
static struct inlineCache ilcSize = __ILC0(@line);
static OBJ last0 = nil; static struct inlineCache ilc0 = __ILCPERF0(@line);
static OBJ last1 = nil; static struct inlineCache ilc1 = __ILCPERF1(@line);
static OBJ last2 = nil; static struct inlineCache ilc2 = __ILCPERF2(@line);
static OBJ last3 = nil; static struct inlineCache ilc3 = __ILCPERF3(@line);
static OBJ last4 = nil; static struct inlineCache ilc4 = __ILCPERF4(@line);
static OBJ last5 = nil; static struct inlineCache ilc5 = __ILCPERF5(@line);
static OBJ last6 = nil; static struct inlineCache ilc6 = __ILCPERF6(@line);
static OBJ last7 = nil; static struct inlineCache ilc7 = __ILCPERF7(@line);
static OBJ last8 = nil; static struct inlineCache ilc8 = __ILCPERF8(@line);
static OBJ last9 = nil; static struct inlineCache ilc9 = __ILCPERF9(@line);
static OBJ last10 = nil; static struct inlineCache ilc10 = __ILCPERF10(@line);
static OBJ last11 = nil; static struct inlineCache ilc11 = __ILCPERF11(@line);
static OBJ last12 = nil; static struct inlineCache ilc12 = __ILCPERF12(@line);
static OBJ last13 = nil; static struct inlineCache ilc13 = __ILCPERF13(@line);
static OBJ last14 = nil; static struct inlineCache ilc14 = __ILCPERF14(@line);
static OBJ last15 = nil; static struct inlineCache ilc15 = __ILCPERF15(@line);
OBJ l;
#if defined(xxxTHIS_CONTEXT) /* not because this has a context */
/*
* must set lineno in sender by hand here ... (because of NOCONTEXT)
*/
if ((l = __ILC_LNO_AS_OBJ(__pilc)) != __MKSMALLINT(0)) {
_ContextInstPtr(__thisContext)->c_lineno = l;
}
#endif
if (__isArray(argArray)) {
nargs = __arraySize(argArray);
argP = __ArrayInstPtr(argArray)->a_element;
} else {
if (__isNonNilObject(argArray)) {
numberOfArgs = (*ilcSize.ilc_func)(argArray, @symbol(size), nil, &ilcSize);
if (!__isSmallInteger(numberOfArgs))
goto bad;
nargs = __intVal(numberOfArgs);
argP = (OBJ *)(&a1);
for (i=1; i <= nargs; i++) {
*argP++ = __AT_(argArray, __MKSMALLINT(i));
}
argP = (OBJ *)(&a1);
} else {
nargs = 0;
}
}
switch (nargs) {
case 0:
if ((InterruptPending != nil) || (aSelector != last0)) {
ilc0.ilc_func = __SEND0ADDR__;
if (ilc0.ilc_poly) {
__flushPolyCache(ilc0.ilc_poly);
ilc0.ilc_poly = 0;
}
last0 = aSelector;
}
#ifdef xxTHIS_CONTEXT /* not because this has a context */
ilc0.ilc_lineNo = __pilc->ilc_lineNo;
#endif
RETURN ((*ilc0.ilc_func)(self, aSelector, nil, &ilc0));
case 1:
if ((InterruptPending != nil) || (aSelector != last1)) {
ilc1.ilc_func = __SEND1ADDR__;
if (ilc1.ilc_poly) {
__flushPolyCache(ilc1.ilc_poly);
ilc1.ilc_poly = 0;
}
last1 = aSelector;
}
#ifdef xxTHIS_CONTEXT /* not because this has a context */
ilc1.ilc_lineNo = __pilc->ilc_lineNo;
#endif
RETURN ( (*ilc1.ilc_func)(self, aSelector, nil, &ilc1, argP[0]));
case 2:
if ((InterruptPending != nil) || (aSelector != last2)) {
ilc2.ilc_func = __SEND2ADDR__;
if (ilc2.ilc_poly) {
__flushPolyCache(ilc2.ilc_poly);
ilc2.ilc_poly = 0;
}
last2 = aSelector;
}
#ifdef xxTHIS_CONTEXT /* not because this has a context */
ilc2.ilc_lineNo = __pilc->ilc_lineNo;
#endif
RETURN ( (*ilc2.ilc_func)(self, aSelector, nil, &ilc2,
argP[0], argP[1]));
case 3:
if ((InterruptPending != nil) || (aSelector != last3)) {
ilc3.ilc_func = __SEND3ADDR__;
if (ilc3.ilc_poly) {
__flushPolyCache(ilc3.ilc_poly);
ilc3.ilc_poly = 0;
}
last3 = aSelector;
}
#ifdef xxTHIS_CONTEXT /* not because this has a context */
ilc3.ilc_lineNo = __pilc->ilc_lineNo;
#endif
RETURN ( (*ilc3.ilc_func)(self, aSelector, nil, &ilc3,
argP[0], argP[1], argP[2]));
case 4:
if ((InterruptPending != nil) || (aSelector != last4)) {
ilc4.ilc_func = __SEND4ADDR__;
if (ilc4.ilc_poly) {
__flushPolyCache(ilc4.ilc_poly);
ilc4.ilc_poly = 0;
}
last4 = aSelector;
}
#ifdef xxTHIS_CONTEXT /* not because this has a context */
ilc4.ilc_lineNo = __pilc->ilc_lineNo;
#endif
RETURN ( (*ilc4.ilc_func)(self, aSelector, nil, &ilc4,
argP[0], argP[1], argP[2], argP[3]));
case 5:
if ((InterruptPending != nil) || (aSelector != last5)) {
ilc5.ilc_func = __SEND5ADDR__;
if (ilc5.ilc_poly) {
__flushPolyCache(ilc5.ilc_poly);
ilc5.ilc_poly = 0;
}
last5 = aSelector;
}
#ifdef xxTHIS_CONTEXT /* not because this has a context */
ilc5.ilc_lineNo = __pilc->ilc_lineNo;
#endif
RETURN ( (*ilc5.ilc_func)(self, aSelector, nil, &ilc5,
argP[0], argP[1], argP[2], argP[3], argP[4]));
case 6:
if ((InterruptPending != nil) || (aSelector != last6)) {
ilc6.ilc_func = __SEND6ADDR__;
if (ilc6.ilc_poly) {
__flushPolyCache(ilc6.ilc_poly);
ilc6.ilc_poly = 0;
}
last6 = aSelector;
}
#ifdef xxTHIS_CONTEXT /* not because this has a context */
ilc6.ilc_lineNo = __pilc->ilc_lineNo;
#endif
RETURN ( (*ilc6.ilc_func)(self, aSelector, nil, &ilc6,
argP[0], argP[1], argP[2], argP[3], argP[4],
argP[5]));
case 7:
if ((InterruptPending != nil) || (aSelector != last7)) {
ilc7.ilc_func = __SEND7ADDR__;
if (ilc7.ilc_poly) {
__flushPolyCache(ilc7.ilc_poly);
ilc7.ilc_poly = 0;
}
last7 = aSelector;
}
#ifdef xxTHIS_CONTEXT /* not because this has a context */
ilc7.ilc_lineNo = __pilc->ilc_lineNo;
#endif
RETURN ( (*ilc7.ilc_func)(self, aSelector, nil, &ilc7,
argP[0], argP[1], argP[2], argP[3], argP[4],
argP[5], argP[6]));
case 8:
if ((InterruptPending != nil) || (aSelector != last8)) {
ilc8.ilc_func = __SEND8ADDR__;
last8 = aSelector;
}
#ifdef xxTHIS_CONTEXT /* not because this has a context */
ilc8.ilc_lineNo = __pilc->ilc_lineNo;
#endif
RETURN ( (*ilc8.ilc_func)(self, aSelector, nil, &ilc8,
argP[0], argP[1], argP[2], argP[3], argP[4],
argP[5], argP[6], argP[7]));
case 9:
if ((InterruptPending != nil) || (aSelector != last9)) {
ilc9.ilc_func = __SEND9ADDR__;
last9 = aSelector;
}
#ifdef xxTHIS_CONTEXT /* not because this has a context */
ilc9.ilc_lineNo = __pilc->ilc_lineNo;
#endif
RETURN ( (*ilc9.ilc_func)(self, aSelector, nil, &ilc9,
argP[0], argP[1], argP[2], argP[3], argP[4],
argP[5], argP[6], argP[7], argP[8]));
case 10:
if ((InterruptPending != nil) || (aSelector != last10)) {
ilc10.ilc_func = __SEND10ADDR__;
last10 = aSelector;
}
#ifdef xxTHIS_CONTEXT /* not because this has a context */
ilc10.ilc_lineNo = __pilc->ilc_lineNo;
#endif
RETURN ( (*ilc10.ilc_func)(self, aSelector, nil, &ilc10,
argP[0], argP[1], argP[2], argP[3], argP[4],
argP[5], argP[6], argP[7], argP[8], argP[9]));
case 11:
if ((InterruptPending != nil) || (aSelector != last11)) {
ilc11.ilc_func = __SEND11ADDR__;
last11 = aSelector;
}
#ifdef xxTHIS_CONTEXT /* not because this has a context */
ilc11.ilc_lineNo = __pilc->ilc_lineNo;
#endif
RETURN ( (*ilc11.ilc_func)(self, aSelector, nil, &ilc11,
argP[0], argP[1], argP[2], argP[3], argP[4],
argP[5], argP[6], argP[7], argP[8], argP[9],
argP[10]));
case 12:
if ((InterruptPending != nil) || (aSelector != last12)) {
ilc12.ilc_func = __SEND12ADDR__;
last12 = aSelector;
}
#ifdef xxTHIS_CONTEXT /* not because this has a context */
ilc12.ilc_lineNo = __pilc->ilc_lineNo;
#endif
RETURN ( (*ilc12.ilc_func)(self, aSelector, nil, &ilc12,
argP[0], argP[1], argP[2], argP[3], argP[4],
argP[5], argP[6], argP[7], argP[8], argP[9],
argP[10], argP[11]));
case 13:
if ((InterruptPending != nil) || (aSelector != last13)) {
ilc13.ilc_func = __SEND13ADDR__;
last13 = aSelector;
}
#ifdef xxTHIS_CONTEXT /* not because this has a context */
ilc13.ilc_lineNo = __pilc->ilc_lineNo;
#endif
RETURN ( (*ilc13.ilc_func)(self, aSelector, nil, &ilc13,
argP[0], argP[1], argP[2], argP[3], argP[4],
argP[5], argP[6], argP[7], argP[8], argP[9],
argP[10], argP[11], argP[12]));
case 14:
if ((InterruptPending != nil) || (aSelector != last14)) {
ilc14.ilc_func = __SEND14ADDR__;
last14 = aSelector;
}
#ifdef xxTHIS_CONTEXT /* not because this has a context */
ilc14.ilc_lineNo = __pilc->ilc_lineNo;
#endif
RETURN ( (*ilc14.ilc_func)(self, aSelector, nil, &ilc14,
argP[0], argP[1], argP[2], argP[3], argP[4],
argP[5], argP[6], argP[7], argP[8], argP[9],
argP[10], argP[11], argP[12], argP[13]));
case 15:
if ((InterruptPending != nil) || (aSelector != last15)) {
ilc15.ilc_func = __SEND15ADDR__;
last15 = aSelector;
}
#ifdef xxTHIS_CONTEXT /* not because this has a context */
ilc15.ilc_lineNo = __pilc->ilc_lineNo;
#endif
RETURN ( (*ilc15.ilc_func)(self, aSelector, nil, &ilc15,
argP[0], argP[1], argP[2], argP[3], argP[4],
argP[5], argP[6], argP[7], argP[8], argP[9],
argP[10], argP[11], argP[12], argP[13],
argP[14]));
}
bad:;
%}.
"/ arrive here, if bad number of arguments (too many)
"/ ST/X (currently) only allows up to 15 method arguments
^ self primitiveFailed
!
performMethod:aMethod
"invoke aMethod on the receiver.
The method should be a zero-argument method.
This is a non-object-oriented entry, applying a method
in a functional way on a receiver.
Warning:
Take care for the method to be appropriate for the
receiver - no checking is done by the VM."
^ aMethod valueWithReceiver:self arguments:#()
"
|mthd|
mthd := SmallInteger compiledMethodAt:#negated.
Transcript showCR:(1 performMethod:mthd)
"
"BAD USE example:
|mthd|
mthd := Point compiledMethodAt:#x.
Transcript showCR:((1->2) performMethod:mthd)
"
"Modified: 31.7.1997 / 17:41:50 / cg"
!
performMethod:aMethod arguments:argumentArray
"invoke aMethod on the receiver, passing an argumentArray.
The size of the argumentArray should match the number of args
expected by the method.
This is a non-object-oriented entry, applying a method
in a functional way on a receiver.
Warning:
Take care for the method to be appropriate for the
receiver - no checking is done by the VM."
^ aMethod valueWithReceiver:self arguments:argumentArray
"
|mthd|
mthd := SmallInteger compiledMethodAt:#+.
Transcript showCR:(1 performMethod:mthd arguments:#(2))
"
"Created: 31.7.1997 / 17:46:31 / cg"
!
performMethod:aMethod with:arg
"invoke aMethod on the receiver, passing an argument.
The method should be a one-argument method.
This is a non-object-oriented entry, applying a method
in a functional way on a receiver.
Warning:
Take care for the method to be appropriate for the
receiver - no checking is done by the VM."
^ aMethod valueWithReceiver:self arguments:(Array with:arg)
"
|mthd|
mthd := SmallInteger compiledMethodAt:#+.
Transcript showCR:(1 performMethod:mthd with:2)
"
"Modified: 31.7.1997 / 17:42:32 / cg"
!
performMethod:aMethod with:arg1 with:arg2
"invoke aMethod on the receiver, passing two arguments.
The method should be a two-argument method.
This is a non-object-oriented entry, applying a method
in a functional way on a receiver.
Warning:
Take care for the method to be appropriate for the
receiver - no checking is done by the VM."
^ aMethod valueWithReceiver:self arguments:(Array with:arg1 with:arg2)
"
|mthd arr|
arr := Array new:1.
mthd := Array compiledMethodAt:#basicAt:put:.
arr performMethod:mthd with:1 with:'foo'.
Transcript showCR:arr
"
"Modified: 31.7.1997 / 17:44:54 / cg"
!
performMethod:aMethod with:arg1 with:arg2 with:arg3
"invoke aMethod on the receiver, passing three arguments.
The method should be a three-argument method.
This is a non-object-oriented entry, applying a method
in a functional way on a receiver.
Warning:
Take care for the method to be appropriate for the
receiver - no checking is done by the VM."
^ aMethod valueWithReceiver:self arguments:(Array with:arg1 with:arg2 with:arg3)
"Created: 31.7.1997 / 17:45:20 / cg"
! !
!Object methodsFor:'printing & storing'!
className
"return the classname of the receivers class"
^ self class name
"
1 className
1 class className 'this may change ...'
$a className
$a class className 'this may change ...'
"
!
classNameWithArticle
"return a string consisting of classname preceeded by an article.
(dont expect me to write national variants for this ... :-)
If you have special preferences, redefine it ..."
|classname cls|
(cls := self class) == self ifTrue:[
^ 'a funny object'
].
classname := cls displayString.
^ classname article , ' ' , classname
"
1 classNameWithArticle
(1->2) classNameWithArticle
XWorkstation basicNew classNameWithArticle
"
"Modified: 13.5.1996 / 12:16:14 / cg"
!
errorPrint
"print the receiver on the standard error stream."
Stream streamErrorSignal catch:[
self printOn:Stderr
]
"Modified: 7.3.1996 / 19:11:29 / cg"
!
errorPrintCR
"{ Pragma: +optSpace }"
"print the receiver followed by a cr on the standard error stream."
Stream streamErrorSignal catch:[
self printOn:Stderr.
Stderr cr
]
"Modified: 7.3.1996 / 19:13:01 / cg"
"Created: 20.5.1996 / 10:20:41 / cg"
!
errorPrintNL
"{ Pragma: +optSpace }"
"print the receiver followed by a cr on the standard error stream.
Please use #errorPrintCR - this method exists for backward compatibility."
^ self errorPrintCR
"Modified: 20.5.1996 / 10:24:45 / cg"
!
errorPrintNewline
"{ Pragma: +optSpace }"
"print the receiver followed by a cr on the standard error stream.
Please use #errorPrintCR - this method exists for backward compatibility."
self errorPrintCR.
"Modified: 20.5.1996 / 10:24:38 / cg"
!
infoPrint
"{ Pragma: +optSpace }"
"print the receiver on the standard error stream.
This is meant for information messages which are not warnings
or fatal messages.
These messages can be turned on/off by 'Object infoPrinting:true/false'"
InfoPrinting == true ifTrue:[
self errorPrint
]
!
infoPrintCR
"{ Pragma: +optSpace }"
"print the receiver followed by a cr on the standard error stream.
This is meant for information messages which are not warnings
or fatal messages.
These messages can be turned on/off by 'Object infoPrinting:true/false'"
InfoPrinting == true ifTrue:[
self errorPrintCR
]
"Created: 20.5.1996 / 10:21:28 / cg"
!
infoPrintNL
"{ Pragma: +optSpace }"
"print the receiver followed by a cr on the standard error stream.
This is meant for information messages which are not warnings
or fatal messages.
These messages can be turned on/off by 'Object infoPrinting:true/false'.
Please use #infoPrintCR - this method exists for backward compatibility."
^ self infoPrintCR
"Modified: 20.5.1996 / 10:25:07 / cg"
!
print
"print the receiver on the standard output stream (which is not the Transcript)"
self printOn:Stdout
"Modified: 4.11.1996 / 23:36:58 / cg"
!
printCR
"print the receiver followed by a cr on the standard output stream (which is not the Transcript)"
self printOn:Stdout.
Stdout cr
"Created: 20.5.1996 / 10:21:37 / cg"
"Modified: 4.11.1996 / 23:37:06 / cg"
!
printNL
"print the receiver followed by a cr on the standard output stream
This exists for GNU Smalltalk compatibility - please use #printCR."
^ self printCR
"Modified: 20.5.1996 / 10:25:31 / cg"
!
printNewline
"print the receiver followed by a cr on the standard output stream.
This exists for backward compatibility - please use #printCR."
self printCR
"Modified: 20.5.1996 / 10:25:46 / cg"
!
printOn:aStream
"print the receiver on the argument-stream.
The default here is to output the receivers class name.
BUT: this method is heavily redefined for objects which
can print prettier."
aStream nextPutAll:self classNameWithArticle
!
printOn:aStream leftPaddedTo:size
"print the receiver on aStream, padding with spaces up to size.
padding is done on the left."
self printOn:aStream leftPaddedTo:size with:(Character space)
"
123 printOn:Transcript leftPaddedTo:10. Transcript cr
123 printOn:Transcript leftPaddedTo:2. Transcript cr
"
!
printOn:aStream leftPaddedTo:size with:padCharacter
"print the receiver on aStream, padding with padCharacters up to size.
padding is done on the left."
aStream nextPutAll:(self printStringLeftPaddedTo:size with:padCharacter)
"
123 printOn:Transcript leftPaddedTo:10 with:$_ . Transcript cr
123 printOn:Transcript leftPaddedTo:10 with:$. . Transcript cr
"
!
printOn:aStream paddedTo:size
"print the receiver on aStream, padding with spaces up to size."
self printOn:aStream paddedTo:size with:(Character space)
"
123.0 printOn:Transcript paddedTo:10. Transcript nextPut:$|. Transcript cr
"
!
printOn:aStream paddedTo:size with:padCharacter
"print the receiver on aStream, padding with padCharacter up to size"
aStream nextPutAll:(self printStringPaddedTo:size with:padCharacter).
"
123 printOn:Transcript paddedTo:10 with:$_ . Transcript cr
123 printOn:Transcript paddedTo:10 with:$. . Transcript cr
"
!
printOn:aStream zeroPaddedTo:size
"print the receiver on aStream, padding with zeros up to size.
Usually used with float numbers."
self printOn:aStream paddedTo:size with:$0.
"
123.0 printOn:Transcript zeroPaddedTo:10
"
!
printRightAdjustLen:size
"obsolete - just a name confusion.
This method will go away ..."
(self printStringLeftPaddedTo:size) printOn:Stdout
!
printString
"return a string for printing the receiver.
Since we now use printOn: as the basic print mechanism,
we have to create a stream and print into it."
|s|
s := WriteStream on:(String new:30).
self printOn:s.
^ s contents
!
printStringLeftPaddedTo:size
"return my printString as a right-adjusted string of length size;
characters on the left are filled with spaces.
If the printString is longer than size,
it is returned unchanged (i.e. not truncated)"
^ self printStringLeftPaddedTo:size with:(Character space)
"
10 printStringLeftPaddedTo:10
1 printStringLeftPaddedTo:10
"
!
printStringLeftPaddedTo:size ifLarger:alternative
"return my printString as a right-adjusted string of length size;
characters on the left are filled with spaces.
If the printString is larger than size,
return the result from evaluating alternative."
^ self printStringLeftPaddedTo:size with:(Character space) ifLarger:alternative
"
12 printStringLeftPaddedTo:3 ifLarger:['***']
123 printStringLeftPaddedTo:3 ifLarger:['***']
1234 printStringLeftPaddedTo:3 ifLarger:['***']
"
!
printStringLeftPaddedTo:size with:padCharacter
"return my printString as a right-adjusted string of length size;
characters on the left are filled with padCharacter.
If the printString is longer than size,
it is returned unchanged (i.e. not truncated)"
^ (self printString) leftPaddedTo:size with:padCharacter
"
123 printStringLeftPaddedTo:10 with:$.
1 printStringLeftPaddedTo:10 with:$.
(Float pi) printStringLeftPaddedTo:20 with:$*
"
!
printStringLeftPaddedTo:size with:padCharacter ifLarger:alternative
"return my printString as a right-adjusted string of length size;
characters on the left are filled with padCharacter.
If the printString is larger than size,
return the result from evaluating alternative."
|s|
s := self printString.
s size > size ifTrue:[^ alternative value].
^ s leftPaddedTo:size with:padCharacter
"
12 printStringLeftPaddedTo:3 with:$. ifLarger:['***']
123 printStringLeftPaddedTo:3 with:$. ifLarger:['***']
1234 printStringLeftPaddedTo:3 with:$. ifLarger:['***']
"
!
printStringPaddedTo:size
"return a printed representation of the receiver,
padded with spaces (at the right) up to size.
If the printString is longer than size,
it is returned unchanged (i.e. not truncated)"
^ self printStringPaddedTo:size with:(Character space)
"
123 printStringPaddedTo:10
1234567890123456 printStringPaddedTo:10
'hello' printStringPaddedTo:10
"
!
printStringPaddedTo:size ifLarger:alternative
"return a printed representation of the receiver,
padded with spaces (at the right) up to size.
If the resulting printString is too large,
return the result from evaluating alternative."
^ self printStringPaddedTo:size with:(Character space) ifLarger:alternative
"
12 printStringPaddedTo:3 ifLarger:['***']
123 printStringPaddedTo:3 ifLarger:['***']
1234 printStringPaddedTo:3 ifLarger:['***']
"
!
printStringPaddedTo:size with:padCharacter
"return a printed representation of the receiver,
padded with padCharacter (at the right) up to size.
If the printString is longer than size,
it is returned unchanged (i.e. not truncated)"
^ (self printString) paddedTo:size with:padCharacter
"
123 printStringPaddedTo:10 with:$.
123 printStringPaddedTo:10 with:$*
123 printStringPaddedTo:3 with:$*
1234 printStringPaddedTo:3 with:$*
"
!
printStringPaddedTo:size with:padCharacter ifLarger:alternative
"return a printed representation of the receiver,
padded with padCharacter (at the right) up to size.
If the resulting printString is too large,
return the result from evaluating alternative."
|s|
s := self printString.
s size > size ifTrue:[^ alternative value].
^ s paddedTo:size with:padCharacter
"
123 printStringPaddedTo:3 with:$. ifLarger:['***']
12345 printStringPaddedTo:3 with:$. ifLarger:['***']
"
!
printStringRightAdjustLen:size
"obsolete - just a name confusion.
This method will go away ..."
^ self printStringLeftPaddedTo:size
!
printStringZeroPaddedTo:size
"return a printed representation of the receiver,
padded with zero (at the right) characters up to size.
Usually used with float numbers."
^ self printStringPaddedTo:size with:$0
"
123.0 printStringZeroPaddedTo:10
"
!
store
"store the receiver on standard output.
this method is useless, but included for compatibility."
self storeOn:Stdout
!
storeCR
"store the receiver on standard output; append a carriage return."
self store.
Character cr print
"Created: 20.5.1996 / 10:26:01 / cg"
"Modified: 20.5.1996 / 10:26:57 / cg"
!
storeNl
"store the receiver on standard output; append a newline.
This method is included for backward compatibility- use #storeCR."
self storeCR.
"Modified: 20.5.1996 / 10:26:49 / cg"
!
storeOn:aStream
"store the receiver on aStream; i.e. print an expression which will
reconstruct the receiver.
Notice, that no self referencing or cyclic objects can be represented
in this format.
Use storeBinaryOn:, which handles these cases correctly."
|myClass hasSemi sz "{ Class: SmallInteger }" |
thisContext isRecursive ifTrue:[
('Object [error]: storeString of self referencing object.') errorPrintCR.
aStream nextPutAll:'#("recursive")'.
^ self
].
myClass := self class.
aStream nextPut:$(.
aStream nextPutAll:self class name.
hasSemi := false.
myClass isVariable ifTrue:[
aStream nextPutAll:' basicNew:'.
self basicSize printOn:aStream
] ifFalse:[
aStream nextPutAll:' basicNew'
].
sz := myClass instSize.
1 to:sz do:[:i |
aStream nextPutAll:' instVarAt:'.
i printOn:aStream.
aStream nextPutAll:' put:'.
(self instVarAt:i) storeOn:aStream.
aStream nextPut:$;.
hasSemi := true
].
myClass isVariable ifTrue:[
sz := self basicSize.
1 to:sz do:[:i |
aStream nextPutAll:' basicAt:'.
i printOn:aStream.
aStream nextPutAll:' put:'.
(self basicAt:i) storeOn:aStream.
aStream nextPut:$;.
hasSemi := true
]
].
hasSemi ifTrue:[
aStream nextPutAll:' yourself'
].
aStream nextPut:$).
"
|s|
s := WriteStream on:(String new).
('hello' -> 'world') storeOn:s.
s := ReadStream on:(s contents).
(Object readFrom:s) inspect
"
"
|s|
s := 'data' asFilename writeStream.
('hello' -> 'world') storeOn:s.
s close.
s := 'data' asFilename readStream.
(Object readFrom:s) inspect
"
"does not work example:"
"
|s a|
a := Array new:2.
a at:1 put:a.
s := 'data' asFilename writeStream.
a storeOn:s.
s close.
s := 'data' asFilename readStream.
(Object readFrom:s) inspect
"
"Modified: 28.1.1997 / 00:36:12 / cg"
!
storeString
"return a string representing an expression to reconstruct the receiver.
Notice, that no self referencing or cyclic objects can be represented
in this format.
Use storeBinaryOn:, which handles these cases correctly."
|s|
s := WriteStream on:(String new:50).
self storeOn:s.
^ s contents
! !
!Object methodsFor:'queries'!
basicSize
"return the number of the receivers indexed instance variables,
0 if it has none.
This method should NOT be redefined in any subclass (except with great care, for tuning)"
%{ /* NOCONTEXT */
REGISTER int nbytes;
REGISTER OBJ myClass;
#ifdef alpha64
# define int32 int
#else
# define int32 long
#endif
/*
* notice the missing test for self being a nonNilObject -
* this can be done since basicSize is defined both in UndefinedObject
* and SmallInteger
*/
myClass = __qClass(self);
nbytes = __qSize(self)
- OHDR_SIZE
- __OBJS2BYTES__(__intVal(__ClassInstPtr(myClass)->c_ninstvars));
switch ((INT)(__ClassInstPtr(myClass)->c_flags) & __MASKSMALLINT(ARRAYMASK)) {
case __MASKSMALLINT(POINTERARRAY):
RETURN ( __MKSMALLINT(__BYTES2OBJS__(nbytes)) );
case __MASKSMALLINT(BYTEARRAY):
RETURN ( __MKSMALLINT(nbytes / sizeof(char)) );
case __MASKSMALLINT(WKPOINTERARRAY):
RETURN ( __MKSMALLINT(__BYTES2OBJS__(nbytes)) );
case __MASKSMALLINT(FLOATARRAY):
RETURN ( __MKSMALLINT(nbytes / sizeof(float)) );
case __MASKSMALLINT(DOUBLEARRAY):
#ifdef NEED_DOUBLE_ALIGN
/*
* care for filler
*/
nbytes -= sizeof(FILLTYPE);
#endif
RETURN ( __MKSMALLINT(nbytes / sizeof(double)) );
case __MASKSMALLINT(WORDARRAY):
case __MASKSMALLINT(SWORDARRAY):
RETURN ( __MKSMALLINT(nbytes / sizeof(short)) );
case __MASKSMALLINT(LONGARRAY):
case __MASKSMALLINT(SLONGARRAY):
RETURN ( __MKSMALLINT(nbytes / sizeof(int32)) );
}
# undef int32
%}.
^ 0
!
byteSize
"return the number of bytes in the receivers indexed instance variables,
0 if it has none. This only returns non-zero for non-pointer indexed
instvars i.e. byteArrays, wordArrays etc.
Notice: for Strings the returned size may look strange.
Only useful with binary storage."
%{ /* NOCONTEXT */
REGISTER int indx;
int nIndex;
REGISTER OBJ slf;
REGISTER OBJ cls;
slf = self;
if (__isNonNilObject(slf)) {
cls = __qClass(slf);
switch ((INT)(__ClassInstPtr(cls)->c_flags) & __MASKSMALLINT(ARRAYMASK)) {
case __MASKSMALLINT(BYTEARRAY):
case __MASKSMALLINT(WORDARRAY):
case __MASKSMALLINT(LONGARRAY):
case __MASKSMALLINT(SWORDARRAY):
case __MASKSMALLINT(SLONGARRAY):
case __MASKSMALLINT(FLOATARRAY):
case __MASKSMALLINT(DOUBLEARRAY):
nIndex = __byteArraySize(slf);
nIndex -= __OBJS2BYTES__(__intVal(__ClassInstPtr(cls)->c_ninstvars));
RETURN ( __MKSMALLINT(nIndex) );
}
}
%}.
^ 0
"
Point new byteSize
'hello' byteSize
(ByteArray with:1 with:2) byteSize
(FloatArray with:1.5) byteSize
"
!
class
"return the receivers class"
%{ /* NOCONTEXT */
RETURN ( __Class(self) );
%}
!
respondsTo:aSelector
"return true, if the receiver implements a method with selector equal
to aSelector; i.e. if there is a method for aSelector in either the
receivers class or one of its superclasses.
Notice, that this does not imply, that such a message can be sent without
an error being raised. For example, an implementation could send
#shouldNotImplement or #subclassResponsibility."
"
should we go via the cache, or search (by class) ?
The first is faster, most of the time; while the 2nd fills
the cache with useless data if this is sent in a loop over all objects.
For now, use the cache ...
"
%{ /* NOCONTEXT */
if (__lookup(__Class(self), aSelector) == nil) {
RETURN ( false );
}
RETURN ( true );
%}
.
"
^ self class canUnderstand:aSelector
"
"'aString' respondsTo:#+"
"'aString' respondsTo:#,"
"'aString' respondsTo:#collect:"
!
respondsToArithmetic
"return true, if the receiver responds to arithmetic messages.
false is returned here - the method is redefined in ArithmeticValue."
^ false
!
size
"return the number of the receivers indexed instance variables;
this method may be redefined in subclasses"
^ self basicSize
!
species
"return a class which is similar to (or the same as) the receivers class.
This is used to create an appropriate object when creating derived
copies in the collection classes (sometimes redefined)."
^ self class
!
yourself
"return the receiver - used for cascades to return self at the end"
^ self
! !
!Object methodsFor:'secure message sending'!
askFor:aSelector
"try to send the receiver the message, aSelector.
If it does not understand it, return false. Otherwise
the real value returned.
Useful to send messages such as: 'isColor' to unknown
receivers."
^ self perform:aSelector ifNotUnderstood:[false]
"
1 askFor:#isColor
"
!
perform:aSelector ifNotUnderstood:exceptionBlock
"try to send message aSelector to the receiver.
If its understood, return the methods returned value,
otherwise return the value of the exceptionBlock"
|val|
MessageNotUnderstoodSignal handle:[:ex |
^ exceptionBlock value
] do:[
val := self perform:aSelector
].
^ val
"
1.2345 perform:#foo ifNotUnderstood:['sorry']
"
!
perform:aSelector with:argument ifNotUnderstood:exceptionBlock
"try to send message aSelector to the receiver.
If its understood, return the methods returned value,
otherwise return the value of the exceptionBlock"
|val|
MessageNotUnderstoodSignal handle:[:ex |
^ exceptionBlock value
] do:[
val := self perform:aSelector with:argument
].
^ val
"
|unknown|
unknown := 1.
(unknown perform:#+ with:2 ifNotUnderstood:['sorry']) printNewline.
unknown := 'high there'.
(unknown perform:#+ with:2 ifNotUnderstood:['sorry']) printNewline.
"
!
perform:aSelector withArguments:argumentArray ifNotUnderstood:exceptionBlock
"try to send message aSelector to the receiver.
If its understood, return the methods returned value,
otherwise return the value of the exceptionBlock"
|val|
MessageNotUnderstoodSignal handle:[:ex |
^ exceptionBlock value
] do:[
val := self perform:aSelector withArguments:argumentArray
].
^ val
"
|unknown|
unknown := 1.
(unknown perform:#+ withArguments:#(2) ifNotUnderstood:['sorry']) printNewline.
unknown := 'high there'.
(unknown perform:#+ withArguments:#(2) ifNotUnderstood:['sorry']) printNewline.
"
"Modified: 27.3.1997 / 14:13:16 / cg"
! !
!Object methodsFor:'signal constants'!
messageNotUnderstoodSignal
^ MessageNotUnderstoodSignal
"Created: 6.3.1997 / 15:46:52 / cg"
! !
!Object methodsFor:'special queries'!
allOwners
"return a collection of all objects referencing the receiver"
^ ObjectMemory whoReferences:self
!
references:anObject
"return true, if the receiver refers to the argument, anObject.
- for debugging only"
%{ /* NOCONTEXT */
OBJ cls, flags;
int nInsts, i;
if (! __isNonNilObject(self)) {
RETURN (false);
}
/*
* a little optimization: use the fact that all old objects
* refering to a new object are on the remSet; if I am not,
* a trivial reject is possible, if anObject is a newbee
*/
if (__isNonNilObject(anObject)) {
if ((__qSpace(self) <= OLDSPACE) && !__isRemembered(self)) {
int spc;
if (((spc = __qSpace(anObject)) == NEWSPACE) || (spc == SURVSPACE)) {
RETURN (false);
}
}
}
cls = __qClass(self);
if (cls == anObject) {
RETURN (true);
}
flags = __ClassInstPtr(cls)->c_flags;
if (((INT)flags & __MASKSMALLINT(ARRAYMASK)) == __MASKSMALLINT(POINTERARRAY)) {
nInsts = __BYTES2OBJS__(__qSize(self) - OHDR_SIZE);
} else {
nInsts = __intVal(__ClassInstPtr(cls)->c_ninstvars);
}
if (! nInsts) {
RETURN (false);
}
#if defined(memsrch4)
if (memsrch4(__InstPtr(self)->i_instvars, (INT)anObject, nInsts)) {
RETURN (true);
}
#else
for (i=0; i<nInsts; i++) {
if (__InstPtr(self)->i_instvars[i] == anObject) {
RETURN (true);
}
}
#endif /* memsrch4 */
%}.
"/ |myClass
"/ numInst "{ Class: SmallInteger }" |
"/
"/ myClass := self class.
"/
"/ "check the class"
"/ (myClass == anObject) ifTrue:[^ true].
"/
"/ "check the instance variables"
"/ numInst := myClass instSize.
"/ 1 to:numInst do:[:i |
"/ ((self instVarAt:i) == anObject) ifTrue:[^ true]
"/ ].
"/
"/ "check the indexed variables"
"/ myClass isVariable ifTrue:[
"/ myClass isPointers ifFalse:[
"/ "/
"/ "/ we could argue about the following unconditional return:
"/ "/ it says that a non pointer array never has a reference to the
"/ "/ corresponding object - not mimicing a reference to a copy of the
"/ "/ integer. However, it avoids useless searches in huge byteArray
"/ "/ like objects when searching for owners. If in doubt, remove it.
"/ "/ A consequence of the return below is that #[1 2 3] will say that it
"/ "/ does not refer to the number 2 (think of keeping a copy instead)
"/
"/ ^ false.
"/
"/ "/ alternative:
"/ "/ anObject isNumber ifFalse:[^ false].
"/ ].
"/
"/ "/
"/ "/ because arrays are so common, and those have a highly tuned
"/ "/ idenitytIndex method, use it
"/ "/
"/ myClass == Array ifTrue:[
"/ ^ (self identityIndexOf:anObject) ~~ 0
"/ ].
"/
"/ "/
"/ "/ otherwise, do it the slow way
"/ "/
"/ numInst := self basicSize.
"/ 1 to:numInst do:[:i |
"/ ((self basicAt:i) == anObject) ifTrue:[^ true]
"/ ]
"/ ].
^ false
"
|v|
v := View new initialize.
v references:Display.
"
!
referencesAny:aCollection
"return true, if the receiver refers to any object from
the argument, aCollection.
- for debugging only"
%{
OBJ cls, flags;
int nInsts, inst;
if (! __isNonNilObject(self)) {
RETURN (false);
}
if (__isArray(aCollection)) {
int nObjs = __arraySize(aCollection);
char *minAddr = 0, *maxAddr = 0;
if (nObjs == 0) {
RETURN (false);
}
/*
* a little optimization: use the fact that all old objects
* refering to a new object are on the remSet; if I am not,
* a trivial reject is possible, if all objects are newbees.
* as a side effect, gather min/max addresses
*/
if ((__qSpace(self) <= OLDSPACE) && !__isRemembered(self)) {
int allNewBees = 1;
int i;
minAddr = (char *)(__ArrayInstPtr(aCollection)->a_element[0]);
maxAddr = minAddr;
for (i=0; i<nObjs; i++) {
OBJ anObject;
anObject = __ArrayInstPtr(aCollection)->a_element[i];
if (__isNonNilObject(anObject)) {
int spc;
if (((spc = __qSpace(anObject)) != NEWSPACE) && (spc != SURVSPACE)) {
allNewBees = 0;
}
}
if ((char *)anObject < minAddr) {
minAddr = (char *)anObject;
} else if ((char *)anObject > maxAddr) {
maxAddr = (char *)anObject;
}
}
if (allNewBees) {
RETURN (false);
}
}
/*
* fetch min/max in searchList (if not already done)
*/
if (minAddr == 0) {
int i;
for (i=0; i<nObjs; i++) {
OBJ anObject;
anObject = __ArrayInstPtr(aCollection)->a_element[i];
if ((char *)anObject < minAddr) {
minAddr = (char *)anObject;
} else if ((char *)anObject > maxAddr) {
maxAddr = (char *)anObject;
}
}
}
cls = __qClass(self);
if (((char *)cls >= minAddr) && ((char *)cls <= maxAddr)) {
#if defined(memsrch4)
if (memsrch4(__ArrayInstPtr(aCollection)->a_element, (INT)cls, nObjs)) {
RETURN (true);
}
#else
int i;
for (i=0; i<nObjs; i++) {
OBJ anObject;
anObject = __ArrayInstPtr(aCollection)->a_element[i];
if (cls == anObject) {
RETURN (true);
}
}
#endif /* memsrch4 */
}
flags = __ClassInstPtr(cls)->c_flags;
if (((INT)flags & __MASKSMALLINT(ARRAYMASK)) == __MASKSMALLINT(POINTERARRAY)) {
nInsts = __BYTES2OBJS__(__qSize(self) - OHDR_SIZE);
} else {
nInsts = __intVal(__ClassInstPtr(cls)->c_ninstvars);
}
if (! nInsts) {
RETURN (false);
}
if (nObjs == 1) {
/* better reverse the loop */
OBJ anObject;
anObject = __ArrayInstPtr(aCollection)->a_element[0];
#if defined(memsrch4)
if (memsrch4(__InstPtr(self)->i_instvars, (INT)anObject, nInsts)) {
RETURN (true);
}
#else
for (inst=0; inst<nInsts; inst++) {
if ((__InstPtr(self)->i_instvars[inst]) == anObject) {
RETURN (true);
}
}
#endif
RETURN (false);
}
for (inst=0; inst<nInsts; inst++) {
OBJ instVar = __InstPtr(self)->i_instvars[inst];
int i;
if (((char *)instVar >= minAddr) && ((char *)instVar <= maxAddr)) {
#if defined(memsrch4)
if (memsrch4(__ArrayInstPtr(aCollection)->a_element, (INT)instVar, nObjs)) {
RETURN (true);
}
#else
for (i=0; i<nObjs; i++) {
OBJ anObject;
anObject = __ArrayInstPtr(aCollection)->a_element[i];
if (instVar == anObject) {
RETURN (true);
}
}
#endif /* memsrch4 */
}
}
RETURN (false);
}
%}.
aCollection do:[:el |
(self references:el) ifTrue:[^ true].
].
^ false
!
referencesDerivedInstanceOf:aClass
"return true, if the receiver refers to an instance of
the argument, aClass or its subclass. This method exists
to support searching for users of a class."
|myClass
numInst "{ Class: SmallInteger }" |
myClass := self class.
"check the class"
(myClass isKindOf:aClass) ifTrue:[^ true].
"check the instance variables"
numInst := myClass instSize.
1 to:numInst do:[:i |
((self instVarAt:i) isKindOf:aClass) ifTrue:[^ true]
].
"check the indexed variables"
myClass isVariable ifTrue:[
myClass isPointers ifFalse:[
"no need to search in non pointer fields"
((aClass == Number) or:[aClass isSubclassOf:Number]) ifFalse:[^ false].
].
numInst := self basicSize.
1 to:numInst do:[:i |
((self basicAt:i) isKindOf:aClass) ifTrue:[^ true]
]
].
^ false
"
(1 @ 3.4) referencesDerivedInstanceOf:Number
(1 @ 3.4) referencesDerivedInstanceOf:Array
View new initialize referencesDerivedInstanceOf:DeviceWorkstation
"
!
referencesInstanceOf:aClass
"return true, if the receiver refers to an instance of
the argument, aClass.This method exists
to support searching for users of a class."
|myClass
numInst "{ Class: SmallInteger }" |
myClass := self class.
"check the class"
(myClass isMemberOf:aClass) ifTrue:[^ true].
"check the instance variables"
numInst := myClass instSize.
1 to:numInst do:[:i |
((self instVarAt:i) isMemberOf:aClass) ifTrue:[^ true]
].
"check the indexed variables"
myClass isVariable ifTrue:[
myClass isPointers ifFalse:[
"no need to search in non-pointer indexed fields"
myClass isLongs ifTrue:[
(aClass == SmallInteger or:[aClass == LargeInteger]) ifFalse:[^ false].
] ifFalse:[
myClass isFloatsOrDoubles ifTrue:[^ aClass == Float].
^ aClass == SmallInteger
]
].
numInst := self basicSize.
1 to:numInst do:[:i |
((self basicAt:i) isMemberOf:aClass) ifTrue:[^ true]
]
].
^ false
"
(1 @ 3.4) referencesInstanceOf:Float
(1 @ 3.4) referencesInstanceOf:Fraction
View new initialize referencesInstanceOf:(Display class)
"
! !
!Object methodsFor:'synchronized evaluation'!
freeSynchronizationSemaphore
"free synchronizationSemaphore. May be used, to save memory when
an object is no longer used synchronized."
|sema|
sema := self synchronizationSemaphore.
sema notNil ifTrue:[
sema wait. "/ get lock
self synchronizationSemaphore:nil.
].
"
self synchronized:[].
self synchronizationSemaphore.
self freeSynchronizationSemaphore.
"
"Created: 28.1.1997 / 19:31:20 / stefan"
"Modified: 28.1.1997 / 19:47:55 / stefan"
!
synchronizationSemaphore
"return the synchronization semaphore for myself.
subclasses may redefine"
^ SynchronizationSemaphores at:self ifAbsent:[].
"
self synchronizationSemaphore
"
"Modified: 28.1.1997 / 19:47:09 / stefan"
!
synchronizationSemaphore:aSemaphore
"set the synchronisationSemaphore for myself.
subclasses may redefine this method"
aSemaphore isNil ifTrue:[
"/ remove Semaphore
SynchronizationSemaphores removeKey:self ifAbsent:[].
] ifFalse:[
SynchronizationSemaphores at:self put:aSemaphore.
].
"Modified: 28.1.1997 / 19:37:48 / stefan"
!
synchronized:aBlock
"evaluate aBlock synchronized, i.e. use a monitor for this object"
|sema blocked gotSema|
blocked := OperatingSystem blockInterrupts.
"/ the following avoids creation of an additional
"/ block in the common case
sema := self synchronizationSemaphore.
sema isNil ifTrue:[
"get a locked semaphore (with count = 0)"
sema := Semaphore new.
self synchronizationSemaphore:sema.
blocked ifFalse:[OperatingSystem unblockInterrupts].
^ aBlock valueNowOrOnUnwindDo:[sema signal].
].
"
Poll sema (never waits).
Assuming that this is the common operation, this saves the creation
of some blocks.
"
(sema waitWithTimeout:0) notNil ifTrue:[
blocked ifFalse:[OperatingSystem unblockInterrupts].
^ aBlock valueNowOrOnUnwindDo:[sema signal].
].
[
gotSema := sema wait.
blocked ifFalse:[OperatingSystem unblockInterrupts].
^ aBlock value.
] valueNowOrOnUnwindDo:[
gotSema notNil ifTrue:[gotSema signal]
].
"
[Object synchronized:[Delay waitForSeconds:2. Transcript showCR:'1']] fork.
[Object synchronized:[Delay waitForSeconds:2. Transcript showCR:'2']] fork.
"
"Created: 28.1.1997 / 17:52:56 / stefan"
"Modified: 30.1.1997 / 13:38:54 / cg"
"Modified: 20.2.1997 / 09:43:35 / stefan"
! !
!Object methodsFor:'system primitives'!
asOop
"ST-80 compatibility:
ST-80 returns an OOP-identity based number here (I guess: its address
or index); since ST/X has no such thing, and the objects address cannot
be used (since its changing over time), we return the objects identityHash
key, which provides (at least) some identity indication.
However, notice that (in contrast to ST-80's #asOop), the identityHash
key of two non-identical objects may be the same.
You'd better not use it - especially do not misuse it."
^ self identityHash
"Created: 9.11.1996 / 19:09:56 / cg"
"Modified: 9.11.1996 / 19:16:04 / cg"
!
become:anotherObject
"make all references to the receiver become references to anotherObject
and vice-versa. Notice the vice-versa; see #becomeSameAs: for a one-way become.
This can be a very dangerous operation - be warned.
In general, using #become: should be avoided if possible, since it may
produce many strange effects (think of hashing in Sets, Dictionaries etc.).
This may also be an expensive (i.e. slow) operation,
since in the worst case, the whole memory has to be searched for
references to the two objects (although the primitive tries hard to
limit the search, for acceptable performance in most cases).
This method fails, if the receiver or the argument is a SmallInteger
or nil, or is a context of a living method (i.e. one that has not already
returned).
(notice that #become: is not used heavily by the system
- the Collection-classes have been rewritten to not use it.)"
%{
if (__primBecome(self, anotherObject)) {
RETURN ( self );
}
%}.
self primitiveFailed
!
becomeNil
"make all references to the receiver become nil - effectively getting
rid of the receiver.
This can be a very dangerous operation - be warned.
This may be an expensive (i.e. slow) operation.
The receiver may not be a SmallInteger or a context of a living method."
%{
if (__primBecomeNil(self)) {
RETURN ( nil );
}
%}.
self primitiveFailed
!
becomeSameAs:anotherObject
"make all references to the receiver become references to anotherObject
but NOT vice versa (as done in #become:).
This can be a very dangerous operation - be warned.
In general, using #become: should be avoided if possible, since it may
produce many strange effects (think of hashing in Sets, Dictionaries etc.).
This may also be an expensive (i.e. slow) operation,
since in the worst case, the whole memory has to be searched for
references to the two objects (although the primitive tries hard to
limit the search, for acceptable performance in most cases).
This method fails, if the receiver or the argument is a SmallInteger
or nil, or is a context of a living method (i.e. one that has not already returned)."
%{
if (__primBecomeSameAs(self, anotherObject)) {
RETURN ( self );
}
%}.
self primitiveFailed
!
changeClassTo:otherClass
"changes the class of the receiver to the argument, otherClass.
This is only allowed (possible), if the receivers class and the argument
have the same structure (i.e. number of named instance variables and
type of indexed instance variables).
If the structures do not match, or any of the original class or new class
is UndefinedObject or a Smallinteger, a primitive error is triggered."
|myClass ok|
"check for UndefinedObject/SmallInteger receiver or newClass"
%{
{
OBJ other = otherClass;
if (__isNonNilObject(self)
&& __isNonNilObject(other)
&& (other != UndefinedObject)
&& (other != SmallInteger)) {
ok = true;
} else {
ok = false;
}
}
%}.
ok ifTrue:[
ok := false.
myClass := self class.
myClass flags == otherClass flags ifTrue:[
myClass instSize == otherClass instSize ifTrue:[
"same instance layout and types: its ok to do it"
ok := true.
] ifFalse:[
myClass isPointers ifTrue:[
myClass isVariable ifTrue:[
ok := true
]
]
]
] ifFalse:[
myClass isPointers ifTrue:[
"if newClass is a variable class, with instSize <= my instsize,
we can do it (effectively mapping additional instvars into the
variable part) - usefulness is questionable, though"
otherClass isPointers ifTrue:[
otherClass isVariable ifTrue:[
otherClass instSize <= (myClass instSize + self basicSize)
ifTrue:[
ok := true
]
] ifFalse:[
otherClass instSize == (myClass instSize + self basicSize)
ifTrue:[
ok := true
]
]
] ifFalse:[
"it does not make sense to convert pointers to bytes ..."
]
] ifFalse:[
"does it make sense, to convert bits ?"
"could allow byteArray->wordArray->longArray->floatArray->doubleArray here ..."
(myClass isBits and:[otherClass isBits]) ifTrue:[
ok := true
]
]
]
].
ok ifTrue:[
"now, change the receivers class ..."
%{
{
OBJ me = self;
__qClass(me) = otherClass;
__STORE(me, otherClass);
RETURN (me);
}
%}.
].
"
the receiver cannot be represented as a instance of
the desired class.
For example, you cannot change a bitInstance (byteArray etc.)
into a pointer object and vice versa.
"
self primitiveFailed
!
changeClassToThatOf:anObject
"changes the class of the receiver to that of the argument, anObject.
This is only allowed (possible), if the receivers class and the arguments
class have the same structure (i.e. number of named instance variables and
type of indexed instance variables). If the structures do not match, or any
of the objects is nil or a Smallinteger, a primitive error is triggered."
self changeClassTo:(anObject class)
! !
!Object methodsFor:'testing'!
? defaultValue
"a syntactic shugar-piece:
if the receiver is nil, return the defaultValue;
otherwise, return the receiver.
This method is only redefined in UndefinedObject - therefore,
the recevier is retuned here.
Thus, if foo and bar are simple variables or constants,
foo ? bar
is the same as:
(foo isNil ifTrue:[bar] ifFalse:[foo])
if they are message sends, the equivalent code is:
[
|t1 t2|
t1 := foo.
t2 := bar.
t1 isNil ifTrue:[t2] ifFalse:[t1]
] value
Can be used to provide defaultValues to variables,
as in:
foo := arg ? #defaultValue
Note: this method should never be redefined in classes other than UndefinedObject.
"
^ self
"
1 ? #default
nil ? #default
"
"Created: / 4.11.1996 / 20:36:19 / cg"
"Modified: / 19.5.1998 / 17:39:56 / cg"
!
?? defaultValue
"a syntactic shugar-piece:
much like ?, but sends value to the argument if required.
If the receiver is nil, return the defaultValues value;
otherwise, return the receiver.
This method is only redefined in UndefinedObject - therefore,
the recevier is retuned here.
Thus, if foo and bar are simple variables or constants,
foo ?? bar
is the same as:
(foo isNil ifTrue:[bar value] ifFalse:[foo])
if they are message sends, the equivalent code is:
[
|t t2|
t := foo.
t isNil ifTrue:[bar value] ifFalse:[t]
] value
Can be used to provide defaultValues to variables,
as in:
foo := arg ?? #defaultValue
Note: this method should never be redefined in classes other than UndefinedObject.
"
^ self
"
1 ?? #default
nil ?? #default
"
"Created: / 4.11.1996 / 20:36:19 / cg"
"Modified: / 19.5.1998 / 17:42:56 / cg"
!
isArray
"return true, if the receiver is some kind of array (or weakArray etc);
false is returned here - the method is only redefined in Array."
^ false
!
isAssociation
"return true, if the receiver is some kind of association;
false is returned here - the method is only redefined in Association."
^ false
"Created: 14.5.1996 / 17:03:45 / cg"
!
isBehavior
"return true, if the receiver is some kind of class (i.e. behavior);
false is returned here - the method is only redefined in Behavior."
^ false
!
isBlock
"return true, if the receiver is some kind of block;
false returned here - the method is only redefined in Block."
^ false
!
isCharacter
"return true, if the receiver is some kind of character;
false is returned here - the method is only redefined in Character."
^ false
!
isClass
"return true, if the receiver is some kind of class (real class,
not just behavior);
false is returned here - the method is only redefined in Class."
^ false
!
isCollection
"return true, if the receiver is some kind of collection;
false is returned here - the method is only redefined in Collection."
^ false
!
isColor
"return true, if the receiver is some kind of color;
false is returned here - the method is only redefined in Color."
^ false
!
isContext
"return true, if the receiver is some kind of context;
false returned here - the method is only redefined in Context."
^ false
!
isExternalStream
"return true, if the receiver is some kind of externalStream;
false is returned here - the method is only redefined in ExternalStream."
^false
!
isFileStream
"return true, if the receiver is some kind of fileStream;
false is returned here - the method is only redefined in FileStream."
^false
!
isFixedPoint
"return true, if the receiver is some kind of fixedPoint number;
false is returned here - the method is only redefined in FixedPoint."
^ false
"Created: 5.11.1996 / 19:23:04 / cg"
!
isFixedSize
"return true if the receiver cannot grow easily
(i.e. a grow may be expensive, since it involves a become:)"
^ true
!
isForm
"return true, if the receiver is some kind of form;
false is returned here - the method is only redefined in Form."
^ false
!
isFraction
"return true, if the receiver is some kind of fraction;
false is returned here - the method is only redefined in Fraction."
^ false
!
isImage
"return true, if the receiver is some kind of image;
false is returned here - the method is only redefined in Image."
^ false
!
isImageOrForm
"return true, if the receiver is some kind of image or form;
false is returned here - the method is only redefined in Image and Form."
^ false
!
isImmediate
"return true if this object has immediate representation"
^ self class hasImmediateInstances
"Created: 3.6.1997 / 12:00:18 / cg"
!
isInteger
"return true, if the receiver is some kind of integer number;
false is returned here - the method is only redefined in Integer."
^ false
!
isJavaClass
"return true, if this is a javaClass.
false is returned here - the method is only redefined in JavaClass."
^ false
"Created: / 26.3.1997 / 13:34:54 / cg"
"Modified: / 8.5.1998 / 21:25:21 / cg"
!
isJavaContext
"return true, if this is a javaContext.
false is returned here - the method is only redefined in JavaContext."
^ false
"Created: / 8.5.1998 / 21:24:27 / cg"
"Modified: / 8.5.1998 / 21:25:35 / cg"
!
isJavaObject
"return true, if this is a javaObject.
false is returned here - the method is only redefined in JavaObject."
^ false
"Created: / 26.3.1997 / 13:34:48 / cg"
"Modified: / 8.5.1998 / 21:25:46 / cg"
!
isKindOf:aClass
"return true, if the receiver is an instance of aClass or one of its
subclasses, false otherwise.
Advice:
use of this to check objects for certain attributes/protocoll should
be avoided; it limits the reusability of your classes by limiting use
to instances of certain classes and fences you into a specific inheritance
hierarchy.
Use check-methods to check an object for a certain attributes/protocol
(such as #isXXXX, #respondsTo: or #isNumber).
Using #isKindOf: is considered BAD STYLE.
Advice2:
Be aware, that using an #isXXX method is usually much faster than
using #isKindOf:; because isKindOf: has to walk up all the superclass
hierarchy, comparing every class on the way.
Due to caching in the VM, a call to #isXXX is normally reached via
a single function call.
"
%{ /* NOCONTEXT */
register OBJ thisClass;
thisClass = __Class(self);
while (thisClass != nil) {
if (thisClass == aClass) {
RETURN ( true );
}
thisClass = __ClassInstPtr(thisClass)->c_superclass;
}
%}
.
"/
"/ the above code is equivalent to:
"/
"/ thisClass := self class.
"/ [thisClass notNil] whileTrue:[
"/ thisClass == aClass ifTrue:[^ true].
"/ thisClass := thisClass superclass
"/ ]
"/
^ false
!
isLayout
"return true, if the receiver is some kind of layout;
false is returned here - the method is only redefined in Layout."
^ false
!
isLiteral
"return true, if the receiver can be represented as a constant in ST syntax;
false is returned here - the method is redefined in some classes."
^ false
!
isMemberOf:aClass
"return true, if the receiver is an instance of aClass, false otherwise.
Advice:
use of this to check objects for certain attributes/protocoll should
be avoided; it limits the reusability of your classes by limiting use
to instances of a certain class.
Use check-methods to check an object for a certain attributes/protocol
(such as #isXXX, #respondsTo: or #isNumber);
Using #isMemberOf: is considered BAD STYLE.
Notice:
This method is open coded (inlined) by the compiler(s)
- redefining it may not work as expected."
^ (self class) == aClass
!
isMeta
"return true, if the receiver is some kind of metaclass;
false is returned here - the method is only redefined in Metaclass."
^ false
!
isMethod
"return true, if the receiver is some kind of method;
false returned here - the method is only redefined in Method."
^ false
!
isNamespace
"return true, if this is a nameSpace.
false is returned here - the method is only redefined in Namespace."
^ false
"Created: / 11.10.1996 / 18:08:56 / cg"
"Modified: / 8.5.1998 / 21:26:05 / cg"
!
isNumber
"return true, if the receiver is some kind of number;
false is returned here - the method is only redefined in Number."
^ false
!
isPoint
"return true, if the receiver is some kind of point;
false is returned here - the method is only redefined in Point."
^ false
!
isReal
"return true, if the receiver is some kind of real number;
false is returned here - the method is only redefined in LimitedPrecisionReal."
^ false
!
isRectangle
"return true, if the receiver is some kind of rectangle;
false is returned here - the method is only redefined in Rectangle."
^ false
!
isRemoteObject
"return true, if the receiver is some kind of remoteObject,
false if its local - the method is only redefined in RemoteObject."
^ false
"Created: 28.10.1996 / 15:18:45 / cg"
"Modified: 28.10.1996 / 15:20:57 / cg"
!
isSequenceable
"return true, if the receiver is some kind of sequenceable collection;
false is returned here - the method is only redefined in SequenceableCollection."
^ false
!
isSequenceableCollection
"OBSOLETE: use isSequenceable for ST-80 compatibility.
This method is a historic leftover and will be removed soon ..."
self obsoleteMethodWarning:'use #isSequenceable'.
^ false
!
isSignal
"return true, if the receiver is some kind of signal;
false returned here - the method is only redefined in Signal."
^ false
!
isStream
"return true, if the receiver is some kind of stream;
false is returned here - the method is only redefined in Stream."
^ false
!
isString
"return true, if the receiver is some kind of string;
false is returned here - the method is only redefined in String."
^ false
!
isSymbol
"return true, if the receiver is some kind of symbol;
false is returned here - the method is only redefined in Symbol."
^ false
!
isText
"return true, if the receiver is some kind of text object;
false is returned here - the method is only redefined in Text."
^ false
"Created: 12.5.1996 / 10:56:50 / cg"
!
isVariable
"return true if the receiver has indexed instance variables,
false otherwise."
^ self class isVariable
!
isVariableBinding
"return true, if this is a binding for a variable.
false is returned here - the method is only redefined in Binding."
^ false
"Created: / 19.6.1997 / 17:38:44 / cg"
"Modified: / 8.5.1998 / 21:26:55 / cg"
!
isView
"return true, if the receiver is some kind of view;
false is returned here - the method is only redefined in View."
^ false
! !
!Object methodsFor:'user interaction & notifications'!
activityNotification:aString
"this can be sent from deeply nested methods, which are going to perform
some long-time activity.
If there is a handler for the ActivityNotificationSignal signal, that one is raised,
passing the argument. The handler should show this message whereever it likes,
and proceed. If there is no handler, this is simply ignored.
This is very useful to pass busy messages up to some higher level (typically a view)
which likes to display that message in its label or a busy-box.
It could also be put into some logfile or printed on the standard output/error."
ActivityNotificationSignal isHandled ifTrue:[
^ ActivityNotificationSignal raiseRequestWith:self errorString:aString
].
"
nil activityNotification:'hello there'
self activityNotification:'hello there'
"
"
ActivityNotificationSignal handle:[:ex |
ex errorString printNL.
ex proceed.
] do:[
'hello' printNL.
self activityNotification:'doing some long time computation'.
'world' printNL.
]
"
"Modified: 16.12.1995 / 18:23:42 / cg"
!
confirm:aString
"launch a confirmer, which allows user to enter yes or no.
return true for yes, false for no"
"
on systems without GUI, or during startup, output a message
and return true (as if yes was answered)
Q: should we ask user by reading Stdin ?
"
Smalltalk isInitialized ifFalse:[
'*** confirmation requested during initialization:' printCR.
aString printCR.
'*** I''ll continue, assuming <yes> ...' printCR.
^ true
].
Dialog isNil ifTrue:[
Transcript showCR:aString.
Transcript showCR:'continue, assuming <yes>'.
^ true
].
Dialog autoload. "in case its autoloaded"
^ Dialog confirm:aString
"
nil confirm:'hello'
self confirm:'hello'
"
"Modified: 20.5.1996 / 10:28:40 / cg"
!
errorNotify:aString
"launch a Notifier, showing top stack, telling user something
and give user a chance to enter debugger."
^ self
errorNotify:aString
from:thisContext sender
"
nil errorNotify:'hello there'
self errorNotify:'hello there'
"
"Modified: 11.1.1997 / 18:39:20 / cg"
!
errorNotify:aString from:aContext
"launch a Notifier, showing top stack (above aContext),
telling user something and give user a chance to enter debugger."
^ self errorNotify:aString from:aContext allowDebug:true
"Modified: / 17.8.1998 / 10:09:27 / cg"
!
errorNotify:aString from:aContext allowDebug:allowDebug
"launch a Notifier, showing top stack (above aContext),
telling user something and optionally give the user a chance to enter debugger."
|info con sender action|
Smalltalk isInitialized ifFalse:[
'errorNotification: ' print. aString printCR.
^ self
].
Dialog isNil ifTrue:[
"
on systems without GUI, simply show
the message on the Transcript and abort.
"
Transcript showCR:aString.
AbortSignal raise.
^ self
].
Processor activeProcessIsSystemProcess ifTrue:[
action := #debug.
sender := aContext.
] ifFalse:[
Dialog autoload. "in case its autoloaded"
ErrorSignal handle:[:ex |
"/ a recursive error - quickly enter debugger
"/ this happened, when I corrupted the Dialog class ...
('Object [error]: ' , ex errorString , ' caught in errorNotification') errorPrintCR.
action := #debug.
ex return.
] do:[
sender := aContext.
sender isNil ifTrue:[
sender := thisContext sender.
"/
"/ for your convenience: skip the emergencyHandler block
"/ sender isBlockContext ifTrue:[
"/ sender := sender sender
"/ ].
].
"/ skip intermediate (signal & exception) contexts
DebugView notNil ifTrue:[
sender := DebugView interestingContextFrom:sender
].
"/ show the first 5 contexts
con := sender.
info := aString , Character cr asString , Character cr asString.
1 to:5 do:[:n |
con notNil ifTrue:[
info := info , con printString , Character cr asString.
con := con sender
]
].
allowDebug ifTrue:[
action := Dialog
choose:info
label:('Exception [' , Processor activeProcess nameOrId , ']')
labels:#('proceed' 'abort' 'debug')
values:#(#proceed #abort #debug)
default:#debug.
] ifFalse:[
action := Dialog
choose:info
label:('Exception [' , Processor activeProcess nameOrId , ']')
labels:#('proceed' 'abort')
values:#(#proceed #abort)
default:#abort.
]
].
].
action == #debug ifTrue:[
Debugger enter:sender withMessage:aString
] ifFalse:[
action == #abort ifTrue:[
AbortSignal raise
]
]
"
nil errorNotify:'hello there'
self errorNotify:'hello there'
"
"Modified: / 8.2.1997 / 12:47:41 / cg"
"Created: / 17.8.1998 / 10:09:26 / cg"
!
information:aString
"launch an InfoBox, telling user something.
These info-boxes can be suppressed by handling the
UserNotification- or InformationSignal and proceeding in the handler."
InformationSignal isHandled ifTrue:[
^ InformationSignal raiseRequestWith:self errorString:aString
].
self notify:aString
"
nil information:'hello there'
self information:'hello there'
"
"
InformationSignal handle:[:ex |
'no box popped' printNL.
ex proceed.
] do:[
'hello' printNL.
self information:'some info'.
'world' printNL.
]
"
"Modified: 24.11.1995 / 22:29:49 / cg"
!
notify:aString
"launch a Notifier, telling user something.
Use #information: for ignorable messages."
Smalltalk isInitialized ifFalse:[
'information: ' print. aString printCR.
^ self
].
Dialog isNil ifTrue:[
"
on systems without GUI, simply show
the message on the Transcript.
"
Transcript showCR:aString.
^ self
].
Dialog autoload. "in case its autoloaded"
Dialog information:aString
"
nil notify:'hello there'
self notify:'hello there'
"
"Modified: 20.5.1996 / 10:28:48 / cg"
!
warn:aString
"launch a WarningBox, telling user something.
These warn-boxes can be suppressed by handling the
UserNotification- or WarningSignal and proceeding in the handler."
WarningSignal isHandled ifTrue:[
^ WarningSignal raiseRequestWith:self errorString:aString
].
Smalltalk isInitialized ifFalse:[
'warning: ' print. aString printCR.
^ self
].
Dialog isNil ifTrue:[
"
on systems without GUI, simply show
the message on the Transcript.
"
Transcript showCR:aString.
^ self
].
Dialog autoload. "in case its autoloaded"
Dialog warn:aString
"
nil warn:'hello there'
self warn:'hello there'
"
"
WarningSignal handle:[:ex |
ex proceed.
] do:[
'hello' printNL.
self warn:'some info'.
'world' printNL.
]
"
"Modified: 20.5.1996 / 10:28:53 / cg"
! !
!Object class methodsFor:'documentation'!
version
^ '$Header: /cvs/stx/stx/libbasic/Object.st,v 1.246 1998-08-17 08:10:24 cg Exp $'
! !
Object initialize!