--- a/Object.st Thu Nov 12 12:02:05 2020 +0000
+++ b/Object.st Mon Aug 31 12:15:59 2020 +0100
@@ -1,3 +1,5 @@
+"{ Encoding: utf8 }"
+
"
COPYRIGHT (c) 1988 by Claus Gittinger
COPYRIGHT (c) 2010 Jan Vrany
@@ -25,7 +27,7 @@
ErrorSignal FinalizationLobby HaltSignal IndexNotFoundSignal
InfoPrinting InformationSignal InternalErrorSignal
KeyNotFoundSignal MessageNotUnderstoodSignal
- NonIntegerIndexSignal NonWeakDependencies NotFoundSignal
+ NonIntegerIndexSignal NonWeakDependencies NotFoundSignal Nothing
OSSignalInterruptSignal ObjectAttributes
ObjectAttributesAccessLock PartialErrorPrintLine
PartialInfoPrintLine PrimitiveFailureSignal
@@ -232,40 +234,44 @@
initialize
"called only once - initialize signals"
- ErrorSignal isNil ifTrue:[
- self initSignals.
- ErrorRecursion := true.
- ].
-
- ObjectAttributes isNil ifTrue:[
- ObjectAttributes := WeakIdentityDictionary new.
- ObjectAttributesAccessLock := RecursionLock new.
- ].
- Dependencies isNil ifTrue:[
- Dependencies := WeakDependencyDictionary new.
- ].
- NonWeakDependencies isNil ifTrue:[
- NonWeakDependencies := IdentityDictionary new.
- ].
- SynchronizationSemaphores isNil ifTrue:[
- SynchronizationSemaphores := WeakIdentityDictionary new.
- ].
- FinalizationLobby isNil ifTrue:[
- FinalizationLobby := Registry new.
- ].
-
- "/ initialize InfoPrinting to the VM's infoPrint setting
- "/ (which can be turned off via a command line argument)
- InfoPrinting := ObjectMemory infoPrinting.
+ Nothing isNil ifTrue:[
+ Nothing := VoidObject new.
+
+ ErrorSignal isNil ifTrue:[
+ self initSignals.
+ ErrorRecursion := true.
+ ].
+
+ ObjectAttributes isNil ifTrue:[
+ ObjectAttributes := WeakIdentityDictionary new.
+ ObjectAttributesAccessLock := RecursionLock new.
+ ].
+ Dependencies isNil ifTrue:[
+ Dependencies := WeakDependencyDictionary new.
+ ].
+ NonWeakDependencies isNil ifTrue:[
+ NonWeakDependencies := IdentityDictionary new.
+ ].
+ SynchronizationSemaphores isNil ifTrue:[
+ SynchronizationSemaphores := WeakIdentityDictionary new.
+ ].
+ FinalizationLobby isNil ifTrue:[
+ FinalizationLobby := Registry 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: / 22.1.1998 / 21:23:40 / av"
- "Modified: / 3.2.1998 / 18:55:09 / cg"
- "Modified: / 4.8.1999 / 08:54:06 / stefan"
+ "Modified: / 22-01-1998 / 21:23:40 / av"
+ "Modified: / 03-02-1998 / 18:55:09 / cg"
+ "Modified: / 04-08-1999 / 08:54:06 / stefan"
+ "Modified: / 30-01-2019 / 16:26:31 / Claus Gittinger"
! !
-
!Object class methodsFor:'Compatibility-ST80'!
rootError
@@ -328,9 +334,15 @@
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)"
+ be put into a bytearray).
+ This now returns ElementBoundsError (class based exception)
+ and this method is only provided for portability
+ (old Smalltalk versions used a signal instance here).
+ You can savely use ElementBoundsError directly."
^ ElementBoundsError
+
+ "Modified (comment): / 17-05-2020 / 14:52:05 / cg"
!
errorSignal
@@ -348,11 +360,16 @@
indexNotFoundSignal
"return the signal used for bad index error reporting.
This is also the parentSignal of the nonIntegerIndex- and
- subscriptOutOfBoundsSignal"
+ subscriptOutOfBoundsSignal.
+ This now returns IndexNotFoundError (class based exception)
+ and this method is only provided for portability
+ (old Smalltalk versions used a signal instance here).
+ You can savely use IndexNotFoundError directly."
^ IndexNotFoundSignal
- "Created: / 8.11.1997 / 19:15:48 / cg"
+ "Created: / 08-11-1997 / 19:15:48 / cg"
+ "Modified (comment): / 17-05-2020 / 14:52:38 / cg"
!
informationSignal
@@ -369,27 +386,51 @@
!
keyNotFoundSignal
- "return the signal used for no such key error reporting"
+ "return the signal used for no such key error reporting.
+ This now returns KeyNotFoundError (class based exception)
+ and this method is only provided for portability
+ (old Smalltalk versions used a signal instance here).
+ You can savely use KeyNotFoundError directly."
^ KeyNotFoundError
+
+ "Modified (comment): / 17-05-2020 / 14:58:53 / cg"
!
messageNotUnderstoodSignal
- "return the signal used for doesNotUnderstand: - error handling"
+ "return the signal used for doesNotUnderstand: - error handling.
+ This now returns MessageNotUnderstood (class based exception)
+ and this method is only provided for portability
+ (old Smalltalk versions used a signal instance here).
+ You can savely use MessageNotUnderstood directly."
^ MessageNotUnderstood
+
+ "Modified (comment): / 17-05-2020 / 14:52:55 / cg"
!
nonIntegerIndexSignal
- "return the signal used for bad subscript error reporting"
+ "return the signal used for bad subscript error reporting.
+ This now returns NonIntegerIndexError (class based exception)
+ and this method is only provided for portability
+ (old Smalltalk versions used a signal instance here).
+ You can savely use NonIntegerIndexError directly."
^ NonIntegerIndexSignal
+
+ "Modified (comment): / 17-05-2020 / 14:54:39 / cg"
!
notFoundSignal
- "return the signal used for no element found error reporting"
+ "return the signal used for no element found error reporting.
+ This now returns NotFoundError (class based exception)
+ and this method is only provided for portability
+ (old Smalltalk versions used a signal instance here).
+ You can savely use NotFoundError directly."
^ NotFoundSignal
+
+ "Modified (comment): / 17-05-2020 / 14:34:46 / cg"
!
notifySignal
@@ -408,9 +449,15 @@
!
primitiveFailureSignal
- "return the signal used for primitiveFailed - error handling"
+ "return the signal used for primitiveFailed - error handling.
+ This now returns PrimitiveFailure (class based exception)
+ and this method is only provided for portability
+ (old Smalltalk versions used a signal instance here).
+ You can savely use PrimitiveFailure directly."
^ PrimitiveFailure
+
+ "Modified (comment): / 17-05-2020 / 14:55:25 / cg"
!
privateMethodSignal
@@ -452,10 +499,14 @@
!
subclassResponsibilitySignal
- "return the signal used for subclassResponsibility error reporting.
- (this signal is used to signal incomplete subclasses - i.e. a programmers error)"
+ "deprecated - use SubclassResponsibilityError.
+ obsolete to not show up in selector completion."
+
+ <resource: #obsolete>
^ SubclassResponsibilityError
+
+ "Modified (comment): / 29-01-2019 / 18:50:24 / Stefan Vogel"
!
subscriptOutOfBoundsSignal
@@ -504,7 +555,6 @@
InfoPrinting := aBoolean
! !
-
!Object class methodsFor:'queries'!
isAbstract
@@ -526,10 +576,6 @@
"Modified: 23.4.1996 / 16:00:07 / cg"
! !
-
-
-
-
!Object methodsFor:'Compatibility-GNU'!
display
@@ -557,62 +603,11 @@
!Object methodsFor:'Compatibility-Squeak'!
-clone
- ^ self shallowCopy
-!
-
-copyTwoLevel
- "one more level than a shallowCopy"
-
- ^ self copyToLevel:2
-
- "
- |original copy elL1 elL2 elL3 copyOfElL1|
-
- original := Array new:3.
- original at:1 put:1234.
- original at:2 put:'hello'.
- original at:3 put:(elL1 := Array new:3).
-
- elL1 at:1 put:1234.
- elL1 at:2 put:'hello'.
- elL1 at:3 put:(elL2 := Array new:3).
-
- elL2 at:1 put:1234.
- elL2 at:2 put:'hello'.
- elL2 at:3 put:(elL3 := Array new:3).
-
- elL3 at:1 put:1234.
- elL3 at:2 put:'hello'.
- elL3 at:3 put:(Array new:3).
-
- copy := original copyTwoLevel.
- self assert:((original at:2) ~~ (copy at:2)).
- self assert:((original at:3) ~~ (copy at:3)).
-
- copyOfElL1 := copy at:3.
- self assert:((elL1 at:2) == (copyOfElL1 at:2)).
- self assert:((elL1 at:3) == (copyOfElL1 at:3)).
- "
-!
-
-flag:aString
- "Send this message, with a relevant symbol as argument, to flag a message for subsequent retrieval. For example, you might put the following line in a number of messages:
- self flag: #returnHereUrgently
- Then, to retrieve all such messages, browse all senders of #returnHereUrgently."
-
- "Created: / 21-04-2015 / 15:50:20 / Jan Vrany <jan.vrany@fit.cvut.cz>"
-!
-
isCompiledMethod
"same as isMethod - for squeak compatibility"
"/ left in libbasic package, because it is used by refactory code
^ false
-!
-
-veryDeepCopy
- ^ self deepCopyUsing:(IdentityDictionary new)
! !
!Object methodsFor:'Compatibility-VW'!
@@ -638,37 +633,72 @@
self errorKeyNotFound:aKey.
! !
-
!Object methodsFor:'accessing'!
_at:index
- "experimental:
- this is a synthetic selector, generated by the compiler,
+ "this is a synthetic selector, generated by the compiler,
+ if a construct of the form expr[idx] is parsed.
+ I.e.
+ foo[n]
+ generates
+ foo _at: n
+ "
+ ^ self at:index
+!
+
+_at:index1 at:index2
+ "this is a synthetic selector, generated by the compiler,
+ if a construct of the form expr[idx] is parsed.
+ I.e.
+ foo[n][m]
+ generates
+ foo _at:n at:m
+ "
+ ^ (self at:index1) at:index2
+!
+
+_at:index1 at:index2 at:index3
+ "this is a synthetic selector, generated by the compiler,
if a construct of the form expr[idx...] is parsed.
I.e.
- v[n]
+ foo[n][m][o]
+ generates
+ foo _at:n at:m at:o
+ "
+ ^ ((self at:index1) at:index2) at:index3
+!
+
+_at:index1 at:index2 at:index3 put:val
+ "this is a synthetic selector, generated by the compiler,
+ if a construct of the form expr[idx...] := val is parsed.
+ I.e.
+ foo[n][m][o] := val
generates
- v _at: n
- "
-
- ^ self at:index
-
- "Created: / 21-03-2011 / 14:07:57 / cg"
-!
-
-_at:index put:value
- "experimental:
- this is a synthetic selector, generated by the compiler,
- if a construct of the form expr[idx...] is parsed.
+ foo _at:n at:m at:o put:val
+ "
+ ^ ((self at:index1) at:index2) at:index3 put:val
+!
+
+_at:index1 at:index2 put:val
+ "this is a synthetic selector, generated by the compiler,
+ if a construct of the form expr[idx...] := val is parsed.
I.e.
- v[n]
+ foo[n][m] := val
generates
- v _at: n
- "
-
- ^ self at:index put:value
-
- "Created: / 21-03-2011 / 14:10:12 / cg"
+ foo _at:n at:m put:val
+ "
+ ^ (self at:index1) at:index2 put:val
+!
+
+_at:index put:val
+ "this is a synthetic selector, generated by the compiler,
+ if a construct of the form expr[idx...] := val is parsed.
+ I.e.
+ foo[n] := val
+ generates
+ foo _at:n put:val
+ "
+ ^ self at:index put:val
!
addSlot: slotName
@@ -735,6 +765,19 @@
^ self basicAt:index
!
+at:index ifAbsent:exceptionalValue
+ "return the indexed instance variable with index, anInteger.
+ If there is no such key, return the value from exceptionalValue.
+ This method is usually be redefined in subclasses."
+
+ (index isInteger and:[index <= self size]) ifTrue:[
+ ^ self basicAt:index
+ ].
+ ^ exceptionalValue value.
+
+ "Modified: / 27-05-2020 / 12:37:33 / cg"
+!
+
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)"
@@ -757,8 +800,7 @@
}
/* NOTREACHED */
#else
- REGISTER INT indx;
- REGISTER INT nBytes;
+ REGISTER INT nbytes, indx;
OBJ myClass;
REGISTER char *pFirst;
REGISTER int n;
@@ -773,7 +815,7 @@
indx = __intVal(index) - 1;
n /* nInstVars */ = __intVal(__ClassInstPtr(myClass)->c_ninstvars);
n /* nInstBytes */ = OHDR_SIZE + __OBJS2BYTES__(n /* nInstVars */);
- nBytes = __qSize(self) - n /* nInstBytes */;
+ nbytes = __qSize(self) - n /* nInstBytes */;
pFirst = (char *)(__InstPtr(self)) + n /* nInstBytes */;
switch ((INT)(__ClassInstPtr(myClass)->c_flags) & __MASKSMALLINT(ARRAYMASK)) {
@@ -781,7 +823,7 @@
/*
* pointers
*/
- if ((unsigned INT)indx < (unsigned INT)(__BYTES2OBJS__(nBytes))) {
+ if ((unsigned INT)indx < (unsigned INT)(__BYTES2OBJS__(nbytes))) {
OBJ *op;
op = (OBJ *)pFirst + indx;
@@ -790,13 +832,15 @@
break;
case __MASKSMALLINT(WKPOINTERARRAY):
- if ((unsigned INT)indx < (unsigned INT)(__BYTES2OBJS__(nBytes))) {
- OBJ *op;
+ if ((unsigned INT)indx < (unsigned INT)(__BYTES2OBJS__(nbytes))) {
+ OBJ *optr;
OBJ el;
- op = (OBJ *)pFirst + indx;
- el = *op;
- el = __WEAK_READ__(self, el);
+ optr = (OBJ *)pFirst + indx;
+ el = *optr;
+ if (__isNonNilObject(el)) {
+ el = __WEAK_READ__(self, el);
+ }
RETURN ( el );
}
break;
@@ -805,7 +849,7 @@
/*
* (unsigned) bytes
*/
- if ((unsigned INT)indx < (unsigned INT)nBytes) {
+ if ((unsigned INT)indx < (unsigned INT)nbytes) {
unsigned char *cp;
cp = (unsigned char *)pFirst + indx;
@@ -822,10 +866,10 @@
int delta = __FLOATARRAY_ALIGN - ((INT)pFirst & (__FLOATARRAY_ALIGN-1));
pFirst += delta;
- nBytes -= delta;
+ nbytes -= delta;
}
# endif
- if ((unsigned INT)indx < (unsigned INT)(nBytes / sizeof(float))) {
+ if ((unsigned INT)indx < (unsigned INT)(nbytes / sizeof(float))) {
float *fp;
float f;
OBJ v;
@@ -850,10 +894,10 @@
int delta = __DOUBLE_ALIGN - ((INT)pFirst & (__DOUBLE_ALIGN-1));
pFirst += delta;
- nBytes -= delta;
+ nbytes -= delta;
}
# endif
- if ((unsigned INT)indx < (unsigned INT)(nBytes / sizeof(double))) {
+ if ((unsigned INT)indx < (unsigned INT)(nbytes / sizeof(double))) {
double *dp;
double d;
OBJ v;
@@ -876,7 +920,7 @@
/* Notice: the hard coded shifts are by purpose;
* it makes us independent of the short-size of the machine
*/
- if ((unsigned INT)indx < (unsigned INT)(nBytes>>1)) {
+ if ((unsigned INT)indx < (unsigned INT)(nbytes>>1)) {
unsigned short *sp;
sp = (unsigned short *)(pFirst + (indx<<1));
@@ -891,7 +935,7 @@
/* Notice: the hard coded shifts are by purpose;
* it makes us independent of the short-size of the machine
*/
- if ((unsigned INT)indx < (unsigned INT)(nBytes>>1)) {
+ if ((unsigned INT)indx < (unsigned INT)(nbytes>>1)) {
short *ssp;
ssp = (short *)(pFirst + (indx<<1));
@@ -906,7 +950,7 @@
/* Notice: the hard coded shifts are by purpose;
* it makes us independent of the int-size of the machine
*/
- if ((unsigned INT)indx < (unsigned INT)(nBytes>>2)) {
+ if ((unsigned INT)indx < (unsigned INT)(nbytes>>2)) {
unsigned int32 ul;
unsigned int32 *lp;
@@ -933,7 +977,7 @@
/* Notice: the hard coded shifts are by purpose;
* it makes us independent of the int-size of the machine
*/
- if ((unsigned INT)indx < (unsigned INT)(nBytes>>2)) {
+ if ((unsigned INT)indx < (unsigned INT)(nbytes>>2)) {
int32 *slp;
int32 l;
@@ -962,13 +1006,13 @@
int delta = __LONGLONG_ALIGN - ((INT)pFirst & (__LONGLONG_ALIGN-1));
pFirst += delta;
- nBytes -= delta;
+ nbytes -= delta;
}
# endif
/* Notice: the hard coded shifts are by purpose;
* it makes us independent of the long/longlong-size of the machine
*/
- if ((unsigned INT)indx < (unsigned INT)(nBytes>>3)) {
+ if ((unsigned INT)indx < (unsigned INT)(nbytes>>3)) {
# if __POINTER_SIZE__ == 8
INT *slp, ll;
@@ -996,13 +1040,13 @@
int delta = __LONGLONG_ALIGN - ((INT)pFirst & (__LONGLONG_ALIGN-1));
pFirst += delta;
- nBytes -= delta;
+ nbytes -= delta;
}
# endif
/* Notice: the hard coded shifts are by purpose;
* it makes us independent of the long/longlong-size of the machine
*/
- if ((unsigned INT)indx < (unsigned INT)(nBytes>>3)) {
+ if ((unsigned INT)indx < (unsigned INT)(nbytes>>3)) {
# if __POINTER_SIZE__ == 8
unsigned INT *ulp, ul;
@@ -1044,8 +1088,7 @@
}
/* NOTREACHED */
#else
- REGISTER INT indx;
- REGISTER INT nBytes;
+ REGISTER INT nbytes, indx;
OBJ myClass;
REGISTER char *pFirst;
/* int nInstBytes, ninstvars, flags; */
@@ -1057,17 +1100,18 @@
this can be done since basicAt: is defined both in UndefinedObject
and SmallInteger */
- if (__isSmallInteger(index)) {
+ if (__isSmallInteger(index)
+ && !__isImmutable(self)) {
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 */;
+ nbytes = __qSize(self) - n /* nInstBytes */;
pFirst = (char *)(__InstPtr(self)) + n /* nInstBytes */;
switch ((INT)(__ClassInstPtr(myClass)->c_flags) & __MASKSMALLINT(ARRAYMASK)) {
case __MASKSMALLINT(POINTERARRAY):
- if ((unsigned INT)indx < (unsigned INT)(__BYTES2OBJS__(nBytes))) {
+ if ((unsigned INT)indx < (unsigned INT)(__BYTES2OBJS__(nbytes))) {
OBJ *op;
op = (OBJ *)pFirst + indx;
@@ -1078,7 +1122,7 @@
break;
case __MASKSMALLINT(WKPOINTERARRAY):
- if ((unsigned INT)indx < (unsigned INT)(__BYTES2OBJS__(nBytes))) {
+ if ((unsigned INT)indx < (unsigned INT)(__BYTES2OBJS__(nbytes))) {
OBJ *op;
op = (OBJ *)pFirst + indx;
@@ -1093,7 +1137,7 @@
if (__isSmallInteger(anObject)) {
val = __intVal(anObject);
if ((val & ~0xFF) == 0 /* i.e. (val >= 0) && (val <= 255) */) {
- if ((unsigned INT)indx < (unsigned INT)nBytes) {
+ if ((unsigned INT)indx < (unsigned INT)nbytes) {
char *cp;
cp = pFirst + indx;
@@ -1110,10 +1154,10 @@
int delta = __FLOATARRAY_ALIGN - ((INT)pFirst & (__FLOATARRAY_ALIGN-1));
pFirst += delta;
- nBytes -= delta;
+ nbytes -= delta;
}
# endif
- if ((unsigned INT)indx < (unsigned INT)(nBytes / sizeof(float))) {
+ if ((unsigned INT)indx < (unsigned INT)(nbytes / sizeof(float))) {
float *fp;
fp = (float *)pFirst + indx;
@@ -1141,10 +1185,10 @@
int delta = __DOUBLE_ALIGN - ((INT)pFirst & (__DOUBLE_ALIGN-1));
pFirst += delta;
- nBytes -= delta;
+ nbytes -= delta;
}
# endif
- if ((unsigned INT)indx < (unsigned INT)(nBytes / sizeof(double))) {
+ if ((unsigned INT)indx < (unsigned INT)(nbytes / sizeof(double))) {
double *dp;
dp = (double *)pFirst + indx;
@@ -1170,7 +1214,7 @@
if (__isSmallInteger(anObject)) {
val = __intVal(anObject);
if ((unsigned)val <= 0xFFFF) {
- if ((unsigned INT)indx < (unsigned INT)(nBytes>>1)) {
+ if ((unsigned INT)indx < (unsigned INT)(nbytes>>1)) {
unsigned short *sp;
sp = (unsigned short *)(pFirst + (indx<<1));
@@ -1185,7 +1229,7 @@
if (__isSmallInteger(anObject)) {
val = __intVal(anObject);
if ((val >= -32768) && (val < 32768)) {
- if ((unsigned INT)indx < (unsigned INT)(nBytes>>1)) {
+ if ((unsigned INT)indx < (unsigned INT)(nbytes>>1)) {
short *ssp;
ssp = (short *)(pFirst + (indx<<1));
@@ -1197,7 +1241,7 @@
break;
case __MASKSMALLINT(SLONGARRAY):
- if ((unsigned INT)indx < (unsigned INT)(nBytes>>2)) {
+ if ((unsigned INT)indx < (unsigned INT)(nbytes>>2)) {
int32 *slp;
slp = (int32 *)(pFirst + (indx<<2));
@@ -1223,7 +1267,7 @@
break;
case __MASKSMALLINT(LONGARRAY):
- if ((unsigned INT)indx < (unsigned INT)(nBytes>>2)) {
+ if ((unsigned INT)indx < (unsigned INT)(nbytes>>2)) {
unsigned int32 *lp;
lp = (unsigned int32 *)(pFirst + (indx<<2));
@@ -1254,10 +1298,10 @@
int delta = __LONGLONG_ALIGN - ((INT)pFirst & (__LONGLONG_ALIGN-1));
pFirst += delta;
- nBytes -= delta;
+ nbytes -= delta;
}
# endif
- if ((unsigned INT)indx < (unsigned INT)(nBytes>>3)) {
+ if ((unsigned INT)indx < (unsigned INT)(nbytes>>3)) {
__int64__ ll;
__int64__ *sllp;
@@ -1293,10 +1337,10 @@
int delta = __LONGLONG_ALIGN - ((INT)pFirst & (__LONGLONG_ALIGN-1));
pFirst += delta;
- nBytes -= delta;
+ nbytes -= delta;
}
# endif
- if ((unsigned INT)indx < (unsigned INT)(nBytes>>3)) {
+ if ((unsigned INT)indx < (unsigned INT)(nbytes>>3)) {
__uint64__ ll;
__uint64__ *llp;
@@ -1328,17 +1372,17 @@
}
#endif /* ! __SCHTEAM__ */
%}.
+ "/ arrive here only in case of an error
+ self isImmutable ifTrue:[
+ self noModificationError
+ ].
index isInteger ifFalse:[
- "
- the index should be an integer number
- "
+ "/ the index should be an integer number
^ self indexNotInteger:index
].
(index between:1 and:self size) ifFalse:[
- "
- the index is less than 1 or greater than the size of the
- receiver collection
- "
+ "/ the index is less than 1 or greater than the size of the
+ "/ receiver collection
^ self subscriptBoundsError:index
].
(self class isFloatsOrDoubles) ifTrue:[
@@ -1347,16 +1391,14 @@
]
].
anObject isInteger ifFalse:[
- "
- the object to put into the receiver collection
- should be an integer number
- "
+ "/ 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.
+ or the value is not within the element's valid range.
"
^ self elementBoundsError:anObject
@@ -1737,55 +1779,67 @@
"
! !
-
-
!Object methodsFor:'attributes access'!
objectAttributeAt:attributeKey
- "return the attribute for a given key or nil if not found"
+ "return the attribute for a given key or nil if not found.
+ Such attributes behave like dynamically addable slots in languages like JavaScript.
+ They are much more expensive though, because they are not a ''natural'' mechanism in Smalltalk,
+ but instead simulated via an additional objectAttributes collection mechanism, which
+ defaults to using a dictionary holding per instance attributes.
+ So only use it for seldom needed/seldom assigned attributes,
+ and only if it is not easy to add an instance variable or class-private mechanism for that."
| attrs |
attrs := self objectAttributes.
attrs size ~~ 0 ifTrue:[
- ^ attrs at:attributeKey ifAbsent:[]
+ ^ attrs at:attributeKey ifAbsent:nil
].
^ nil
- "Created: / 22.1.1998 / 21:29:17 / av"
- "Modified: / 3.2.1998 / 18:55:55 / cg"
+ "Created: / 22-01-1998 / 21:29:17 / av"
+ "Modified: / 03-02-1998 / 18:55:55 / cg"
+ "Modified (comment): / 13-07-2017 / 14:26:38 / cg"
+ "Modified: / 28-05-2018 / 16:18:59 / Claus Gittinger"
!
objectAttributeAt:attributeKey put:anObject
- "store the attribute anObject referenced by key into the receiver"
+ "store the attribute anObject referenced by key into the receiver.
+ Such attributes behave like dynamically addable slots in languages like JavaScript.
+ They are much more expensive though, because they are not a ''natural'' mechanism in Smalltalk,
+ but instead simulated via an additional objectAttributes collection mechanism, which
+ defaults to using a dictionary holding per instance attributes.
+ So only use it for seldom needed/seldom assigned attributes,
+ and only if it is not easy to add an instance variable or class-private mechanism for that."
"/ must do this save from being reentered, since the attributes collection
"/ is possibly accessed from multiple threads...
ObjectAttributesAccessLock critical:[
- | attrs |
-
- attrs := self objectAttributes.
- "/ only need a WeakIdentityDictionary, if there are any non-symbol keys in
- "/ it. Start with a regular IDDict, and migrate to WeakIDDict if ever required.
- "/ Typically, this never happens (but does in the UIPainter!!)
- attrs isEmptyOrNil ifTrue:[
- attributeKey isSymbol ifTrue:[
- attrs := IdentityDictionary new.
- ] ifFalse:[
- attrs := WeakIdentityDictionary new.
- ].
- attrs at:attributeKey put:anObject.
- self objectAttributes:attrs.
- ] ifFalse:[
- attributeKey isSymbol ifFalse:[
- attrs isWeakCollection ifFalse:[
- "first non-symbol attributeKey - convert to WeakIdentityDictionary"
- attrs := WeakIdentityDictionary new declareAllFrom:attrs.
- self objectAttributes:attrs.
- ].
- ].
- attrs at:attributeKey put:anObject.
- ].
+ | attrs |
+
+ attrs := self objectAttributes.
+ "/ only need a WeakIdentityDictionary, if there are any non-symbol keys in
+ "/ it. Start with a regular IDDict, and migrate to WeakIDDict if ever required.
+ "/ Typically, this never happens (but does in the UIPainter!!)
+ attrs isEmptyOrNil ifTrue:[
+ attributeKey isSymbol ifTrue:[
+ attrs := IdentityDictionary new.
+ ] ifFalse:[
+ attrs := WeakIdentityDictionary new.
+ ].
+ attrs at:attributeKey put:anObject.
+ self objectAttributes:attrs.
+ ] ifFalse:[
+ attributeKey isSymbol ifFalse:[
+ attrs isWeakCollection ifFalse:[
+ "first non-symbol attributeKey - convert to WeakIdentityDictionary"
+ attrs := WeakIdentityDictionary new declareAllFrom:attrs.
+ self objectAttributes:attrs.
+ ].
+ ].
+ attrs at:attributeKey put:anObject.
+ ].
]
"Attaching additional attributes (slots) to an arbitrary object:
@@ -1798,26 +1852,29 @@
p objectAttributeAt:#color
"
- "Created: / 22.1.1998 / 21:29:25 / av"
- "Modified: / 3.2.1998 / 18:57:58 / cg"
+ "Created: / 22-01-1998 / 21:29:25 / av"
+ "Modified: / 03-02-1998 / 18:57:58 / cg"
+ "Modified (comment): / 13-07-2017 / 14:28:44 / cg"
!
objectAttributes
"return a Collection of attributes - nil if there is none.
- The default implementation here uses a global WeakDictionary to store
- attributes
+
+ 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 performnce.
+ therefore, some classes may redefine this for better performance.
Notice the mentioning of a WeakDictionary - read the classes documentation."
^ ObjectAttributes at:self ifAbsent:[nil]
- "Created: / 22.1.1998 / 21:29:30 / av"
- "Modified: / 18.2.2000 / 11:34:16 / cg"
+ "Created: / 22-01-1998 / 21:29:30 / av"
+ "Modified: / 18-02-2000 / 11:34:16 / cg"
+ "Modified (comment): / 13-07-2017 / 14:28:53 / 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."
@@ -1826,15 +1883,16 @@
"/ is possibly accessed from multiple threads.
ObjectAttributesAccessLock critical:[
- aCollection isEmptyOrNil ifTrue:[
- ObjectAttributes removeKey:self ifAbsent:nil
- ] ifFalse:[
- ObjectAttributes at:self put:aCollection
- ].
+ aCollection isEmptyOrNil ifTrue:[
+ ObjectAttributes removeKey:self ifAbsent:nil
+ ] ifFalse:[
+ ObjectAttributes at:self put:aCollection
+ ].
]
- "Created: / 22.1.1998 / 21:29:35 / av"
- "Modified: / 3.2.1998 / 18:58:10 / cg"
+ "Created: / 22-01-1998 / 21:29:35 / av"
+ "Modified: / 03-02-1998 / 18:58:10 / cg"
+ "Modified (comment): / 13-07-2017 / 14:28:58 / cg"
!
removeObjectAttribute:attributeKey
@@ -1842,32 +1900,28 @@
return the value previously stored there, or nil.
(make the argument, anObject be no longer an attribute of the receiver)"
- |oldVal|
-
"/ must do this save from being reentered, since the attributes collection
"/ is possibly accessed from multiple threads.
- ObjectAttributesAccessLock critical:[
- |attrs|
-
- attrs := self objectAttributes.
- attrs notNil ifTrue:[
- attrs size ~~ 0 ifTrue:[
- oldVal := attrs removeKey:attributeKey ifAbsent:nil.
- ].
- attrs size == 0 ifTrue:[
- self objectAttributes:nil
- ].
- ]
- ].
- ^ oldVal
-
- "Created: / 22.1.1998 / 21:29:39 / av"
- "Modified: / 18.2.2000 / 11:32:19 / cg"
+ ^ ObjectAttributesAccessLock critical:[
+ |attrs oldVal|
+
+ attrs := self objectAttributes.
+ attrs notNil ifTrue:[
+ attrs notEmpty ifTrue:[
+ oldVal := attrs removeKey:attributeKey ifAbsent:nil.
+ ].
+ attrs isEmpty ifTrue:[
+ self objectAttributes:nil
+ ].
+ ].
+ oldVal
+ ].
+
+ "Created: / 22-01-1998 / 21:29:39 / av"
+ "Modified: / 18-02-2000 / 11:32:19 / cg"
+ "Modified: / 15-03-2017 / 17:25:12 / stefan"
! !
-
-
-
!Object methodsFor:'change & update'!
broadcast:aSelectorSymbol
@@ -2010,10 +2064,12 @@
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
+ if it returns true. The dependents must decide in updateRequest and
return true if they think a change is ok."
^ true
+
+ "Modified (comment): / 12-03-2019 / 20:52:12 / Claus Gittinger"
!
updateRequest:aSymbol
@@ -2025,30 +2081,34 @@
updateRequest:aSymbol with:aParameter
"return true if an update request is granted.
- Default here a simple updateRequest"
+ Default here is a simple updateRequest"
^ self updateRequest:aSymbol
+
+ "Modified (comment): / 12-03-2019 / 20:52:32 / Claus Gittinger"
!
updateRequest:aSymbol with:aParameter from:sender
"return true if an update request is granted.
- Default here a simple updateRequest"
+ Default here is a simple updateRequest"
^ self updateRequest:aSymbol with:aParameter
+
+ "Modified (comment): / 12-03-2019 / 20:52:37 / Claus Gittinger"
!
withoutUpdating:someone do:aBlock
"evaluate a block but remove someone from my dependents temporarily"
- (self dependents includesIdentical:someone)
- ifFalse:[
- ^ aBlock value.
+ (self dependents includesIdentical:someone) ifFalse:[
+ ^ aBlock value.
].
self removeDependent:someone.
^ aBlock ensure:[ self addDependent:someone ]
+
+ "Modified (format): / 19-02-2019 / 23:43:59 / Claus Gittinger"
! !
-
!Object methodsFor:'comparing'!
= anObject
@@ -2340,9 +2400,11 @@
asCollectionDo:aBlock
"enumerate myself as a Collection.
- Redefined in collection."
+ Redefined in Collection."
^ aBlock value:self
+
+ "Modified (comment): / 26-04-2018 / 14:20:22 / stefan"
!
asLink
@@ -2371,6 +2433,10 @@
!Object methodsFor:'copying'!
+clone
+ ^ self shallowCopy
+!
+
cloneFrom:anObject
"Helper for copy:
copy all instance variables from anObject into the receiver,
@@ -2607,6 +2673,41 @@
"
!
+copyTwoLevel
+ "one more level than a shallowCopy"
+
+ ^ self copyToLevel:2
+
+ "
+ |original copy elL1 elL2 elL3 copyOfElL1|
+
+ original := Array new:3.
+ original at:1 put:1234.
+ original at:2 put:'hello'.
+ original at:3 put:(elL1 := Array new:3).
+
+ elL1 at:1 put:1234.
+ elL1 at:2 put:'hello'.
+ elL1 at:3 put:(elL2 := Array new:3).
+
+ elL2 at:1 put:1234.
+ elL2 at:2 put:'hello'.
+ elL2 at:3 put:(elL3 := Array new:3).
+
+ elL3 at:1 put:1234.
+ elL3 at:2 put:'hello'.
+ elL3 at:3 put:(Array new:3).
+
+ copy := original copyTwoLevel.
+ self assert:((original at:2) ~~ (copy at:2)).
+ self assert:((original at:3) ~~ (copy at:3)).
+
+ copyOfElL1 := copy at:3.
+ self assert:((elL1 at:2) == (copyOfElL1 at:2)).
+ self assert:((elL1 at:3) == (copyOfElL1 at:3)).
+ "
+!
+
deepCopy
"return a copy of the object with all subobjects also copied.
This method DOES handle cycles/self-refs and preserves object identity;
@@ -2682,11 +2783,11 @@
myClass := self class.
myClass isVariable ifTrue:[
- basicSize := self basicSize.
- aCopy := self speciesForCopy basicNew:basicSize.
+ basicSize := self basicSize.
+ aCopy := self speciesForCopy basicNew:basicSize.
] ifFalse:[
- basicSize := 0.
- aCopy := self speciesForCopy basicNew
+ basicSize := 0.
+ aCopy := self speciesForCopy basicNew
].
aCopy setHashFrom:self.
aDictionary at:self put:aCopy.
@@ -2696,65 +2797,47 @@
"
instSize := myClass instSize.
1 to:instSize do:[:i |
- (self skipInstvarIndexInDeepCopy:i) ifFalse:[
- iOrig := self instVarAt:i.
- iOrig notNil ifTrue:[
- iCopy := aDictionary at:iOrig ifAbsent:nil.
- iCopy isNil ifTrue:[
- iCopy := iOrig deepCopyUsing:aDictionary postCopySelector:postCopySelector
- ].
- aCopy instVarAt:i put:iCopy
- ]
- ]
+ (self skipInstvarIndexInDeepCopy:i) ifFalse:[
+ iOrig := self instVarAt:i.
+ iOrig notNil ifTrue:[
+ iCopy := aDictionary at:iOrig ifAbsent:Nothing.
+ iCopy == Nothing ifTrue:[
+ iCopy := iOrig deepCopyUsing:aDictionary postCopySelector:postCopySelector
+ ].
+ aCopy instVarAt:i put:iCopy
+ ]
+ ]
].
"
copy indexed instvars - if any
"
basicSize ~~ 0 ifTrue:[
- myClass isBits ifTrue:[
- "block-copy indexed instvars"
- aCopy replaceFrom:1 to:basicSize with:self startingAt:1
- ] ifFalse:[
- "individual deep copy the indexed variables"
- 1 to:basicSize do:[:i |
- iOrig := self basicAt:i.
- iOrig notNil ifTrue:[
- "/ used to be dict-includesKey-ifTrue[dict-at:],
- "/ changed to use dict-at:ifAbsent:, to avoid double lookup in dictionary
- iCopy := aDictionary at:iOrig ifAbsent:nil.
- iCopy isNil ifTrue:[
- iCopy := iOrig deepCopyUsing:aDictionary postCopySelector:postCopySelector
- ].
- aCopy basicAt:i put:iCopy
- ]
- ]
- ]
+ myClass isBits ifTrue:[
+ "block-copy indexed instvars"
+ aCopy replaceFrom:1 to:basicSize with:self startingAt:1
+ ] ifFalse:[
+ "individual deep copy the indexed variables"
+ 1 to:basicSize do:[:i |
+ iOrig := self basicAt:i.
+ iOrig notNil ifTrue:[
+ "/ used to be dict-includesKey-ifTrue[dict-at:],
+ "/ changed to use dict-at:ifAbsent:, to avoid double lookup in dictionary
+ iCopy := aDictionary at:iOrig ifAbsent:Nothing.
+ iCopy == Nothing ifTrue:[
+ iCopy := iOrig deepCopyUsing:aDictionary postCopySelector:postCopySelector
+ ].
+ aCopy basicAt:i put:iCopy
+ ]
+ ]
+ ]
].
aCopy perform:postCopySelector withOptionalArgument:self and:aDictionary.
^ aCopy
"Modified: / 21-07-2011 / 13:30:52 / cg"
-!
-
-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
-!
-
-postDeepCopy
- "allows for cleanup after deep copying.
- To be redefined in subclasses."
-!
-
-postDeepCopyFrom:aSource
- "allows for cleanup after deep copying"
-
- ^ self postDeepCopy
+ "Modified: / 30-01-2019 / 16:27:21 / Claus Gittinger"
!
setHashFrom:anObject
@@ -2907,6 +2990,27 @@
^ aCopy
! !
+!Object methodsFor:'copying-private'!
+
+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
+!
+
+postDeepCopy
+ "allows for cleanup after deep copying.
+ To be redefined in subclasses."
+!
+
+postDeepCopyFrom:aSource
+ "allows for cleanup after deep copying"
+
+ ^ self postDeepCopy
+! !
+
!Object methodsFor:'debugging'!
assert:aBooleanOrBlock
@@ -2916,23 +3020,21 @@
<resource: #skipInDebuggersWalkBack>
- aBooleanOrBlock == true ifTrue:[^ self].
+ "/ do not use assert:message: - otherwise the shown context (where the assert is) is wrong
+ aBooleanOrBlock value == true ifTrue:[^ self].
(Smalltalk ignoreAssertions) ifTrue:[^ self].
-
"/ could still be a block or false.
- (aBooleanOrBlock value) ifFalse:[
- AssertionFailedError
- raiseRequestWith:self
- errorString:('Assertion failed in ',
- thisContext methodHome sender printString,
- '[', thisContext methodHome sender lineNumber printString,']')
- ].
+ aBooleanOrBlock value == true ifTrue:[ ^ self].
+
+ AssertionFailedError raiseRequestWith:self errorString:'Assertion failed' in:(thisContext sender)
"
self assert:false
"
"Modified: / 20-08-2010 / 17:13:06 / cg"
+ "Modified: / 08-11-2018 / 11:36:40 / Claus Gittinger"
+ "Modified: / 12-12-2018 / 18:19:08 / Stefan Vogel"
!
assert:aBooleanOrBlock description:messageIfFailing
@@ -2942,21 +3044,21 @@
<resource: #skipInDebuggersWalkBack>
+ "/ sorry for the code duplication
+ "/ do not use assert:message: - otherwise the shown context (where the assert is) is wrong
aBooleanOrBlock == true ifTrue:[^ self].
(Smalltalk ignoreAssertions) ifTrue:[^ self].
-
"/ could still be a block or false.
- (aBooleanOrBlock value) ifFalse:[
- AssertionFailedError
- raiseRequestWith:self
- errorString:(messageIfFailing, ' {',thisContext methodHome sender "methodHome" printString,' }')
- ].
+ aBooleanOrBlock value == true ifTrue:[ ^ self].
+
+ AssertionFailedError raiseRequestWith:self errorString:messageIfFailing in:(thisContext sender)
"
self assert:false description:'xxx'
"
"Modified (comment): / 06-03-2012 / 11:26:48 / cg"
+ "Modified: / 08-11-2018 / 11:36:44 / Claus Gittinger"
!
assert:aBooleanOrBlock message:messageIfFailing
@@ -2966,13 +3068,34 @@
<resource: #skipInDebuggersWalkBack>
- ^ self assert: aBooleanOrBlock description: messageIfFailing
+ "/ sorry for the code duplication
+ "/ do not use assert:description: - otherwise the shown context (where the assert is) is wrong
+ aBooleanOrBlock == true ifTrue:[^ self].
+ (Smalltalk ignoreAssertions) ifTrue:[^ self].
+ "/ could still be a block or false.
+ aBooleanOrBlock value == true ifTrue:[ ^ self].
+
+ AssertionFailedError raiseRequestWith:self errorString:messageIfFailing in:(thisContext sender)
"
self assert:false message:'xxx'
"
"Modified (comment): / 06-03-2012 / 11:26:48 / cg"
+ "Modified: / 20-02-2019 / 14:17:28 / Stefan Vogel"
+!
+
+assertNotNil
+ "fail and report an error, if the receiver is nil"
+
+ "/ intentionally left empty
+ ^ self
+
+ "
+ self assertNotNil
+ "
+
+ "Created: / 18-12-2018 / 15:39:28 / Claus Gittinger"
!
basicInspect
@@ -3007,9 +3130,9 @@
"/ don't send #breakPoint:info: here - ask cg why.
(self isBreakPointEnabled:someKey) ifTrue:[
- ^ HaltSignal
- raiseRequestWith:someKey
- errorString:('Breakpoint encountered: %1' bindWith:someKey)
+ ^ HaltSignal
+ raiseRequestWith:someKey
+ errorString:('Breakpoint encountered: %1' bindWith:someKey)
].
"
@@ -3021,6 +3144,8 @@
EncounteredBreakPoints.
Smalltalk enableBreakPoint:#cg.
Smalltalk disableBreakPoint:#cg.
+ Smalltalk enableBreakPoint:#expecco.
+ Smalltalk disableBreakPoint:#cg.
"
!
@@ -3163,6 +3288,21 @@
"Modified: / 18-11-2010 / 11:22:16 / cg"
!
+haltIfNil
+ "halt if the receiver is nil"
+
+ <resource: #skipInDebuggersWalkBack>
+
+ ^ self
+
+ "
+ 3 haltIfNil
+ nil haltIfNil
+ "
+
+ "Created: / 17-07-2017 / 10:51:56 / cg"
+!
+
isBreakPointEnabled:someKey
"{ Pragma: +optSpace }"
@@ -3194,27 +3334,31 @@
<resource: #skipInDebuggersWalkBack>
- self error:'Non boolean receiver - proceed for truth' mayProceed:true.
+ self proceedableError:'Non boolean receiver - proceed for truth'.
^ true
+
+ "Modified: / 24-05-2018 / 21:03:06 / Claus Gittinger"
!
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.
+ 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 ..."
<resource: #skipInDebuggersWalkBack>
(self isKindOf:aClass) ifFalse:[
- self error:'argument is not of expected type'
+ ArgumentError raiseErrorString:'argument is not of expected type'
]
+
+ "Modified (format): / 06-06-2019 / 23:21:03 / Claus Gittinger"
!
obsoleteFeatureWarning
@@ -3306,8 +3450,8 @@
|spec sender message|
Smalltalk isSmalltalkDevelopmentSystem ifFalse:[
- "ignore in production systems"
- ^ self.
+ "ignore in production systems"
+ ^ self.
].
message := messageOrNil ? 'Obsolete method called'.
@@ -3318,28 +3462,29 @@
(' And may not be present in future ST/X versions.') infoPrintCR.
(' called from ' , sender printString) infoPrintCR.
(sender selector startsWith:'perform:') ifTrue:[
- sender := sender sender.
- (sender selector startsWith:'perform:') ifTrue:[
- sender := sender sender.
- ].
- (' called from ' , sender printString) infoPrintCR.
+ sender := sender sender.
+ (sender selector startsWith:'perform:') ifTrue:[
+ sender := sender sender.
+ ].
+ (' called from ' , sender printString) infoPrintCR.
].
message notNil ifTrue:[
- '------> ' infoPrint. message infoPrintCR
+ '------> ' infoPrint. message infoPrintCR
].
"CG: care for standalone non-GUI progs, which have no userPreferences class"
(Smalltalk isInitialized
and:[ UserPreferences notNil
and:[ UserPreferences current haltInObsoleteMethod]]) ifTrue:[
- "/ cg: nice try, stefan, but I don't want halts in system processes (fly by help and others)
- Processor activeProcess isSystemProcess ifTrue:[
- (message , ' - please fix this now (no halt in system process)') infoPrintCR
- ] ifFalse:[
- "/ please check for the sender of the obsoleteMethodWarning,
- "/ and fix the code there.
- ObsoleteMethodCallWarning raiseRequestErrorString:(message , ' - please fix this now!!')
- ].
+ "/ cg: nice try, stefan, but I don't want halts in system processes (fly by help and others)
+ Processor activeProcess isSystemProcess ifTrue:[
+ (message , ' - please fix this now (no halt in system process)') infoPrintCR
+ ] ifFalse:[
+ "/ please check for the sender of the obsoleteMethodWarning,
+ "/ and fix the code there.
+ "/ ObsoleteMethodCallWarning ignoreWarningFrom:thisContext
+ ObsoleteMethodCallWarning raiseRequestErrorString:(message , ' - please fix this now!!')
+ ].
].
"
@@ -3400,12 +3545,14 @@
"Example: nil tracePoint:#stefan"
- (self isBreakPointEnabled:someKey) ifTrue:[
- ^ Transcript showCR:('Tracepoint (at %1 for %3 from %2)'
- bindWith:(Timestamp now printString)
- with:(thisContext sender printString)
- with:someKey)
- ].
+ (self isBreakPointEnabled:someKey) ifFalse:[
+ ^ self.
+ ].
+
+ Transcript showCR:('Tracepoint (at %1 for %3 from %2)'
+ bindWith:(Timestamp now printString)
+ with:(thisContext sender printString)
+ with:someKey)
"
nil tracePoint:#stefan
@@ -3415,6 +3562,7 @@
"
"Modified: / 28-08-2013 / 21:41:54 / cg"
+ "Modified: / 20-02-2019 / 14:19:28 / Stefan Vogel"
!
tracePoint:someKey message:messageBlockOrString
@@ -3427,13 +3575,15 @@
"Example: nil tracePoint:#stefan"
- (self isBreakPointEnabled:someKey) ifTrue:[
- Transcript showCR:('Tracepoint: %4 (at %1 for %3 from %2)'
- bindWith:(Timestamp now printString)
- with:(thisContext sender printString)
- with:someKey
- with:messageBlockOrString value)
- ].
+ (self isBreakPointEnabled:someKey) ifFalse:[
+ ^ self.
+ ].
+
+ Transcript showCR:('Tracepoint: %4 (at %1 for %3 from %2)'
+ bindWith:(Timestamp now printString)
+ with:(thisContext sender printString)
+ with:someKey
+ with:messageBlockOrString value)
"
Smalltalk enableBreakPoint:#stefan.
@@ -3444,6 +3594,7 @@
"
"Modified: / 28-08-2013 / 21:41:47 / cg"
+ "Modified: / 20-02-2019 / 14:19:47 / Stefan Vogel"
! !
!Object methodsFor:'dependents access'!
@@ -3460,38 +3611,41 @@
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 class == SmallInteger]) ifTrue:[
- deps at:1 put:anObject
- ] ifFalse:[
- self dependents:(WeakIdentitySet with:dep with:anObject)
- ]
- ]
- ] ifFalse:[
- deps add:anObject
- ]
- ]
+ |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 isEmptyOrNil) ifTrue:[
+ self dependents:(WeakArray with:anObject)
+ ] ifFalse:[
+ deps class == WeakArray ifTrue:[
+ dep := deps at:1.
+ dep ~~ anObject ifTrue:[
+ (dep isNil or:[dep class == SmallInteger "old dependent already collected"]) ifTrue:[
+ deps at:1 put:anObject
+ ] ifFalse:[
+ self dependents:(WeakIdentitySet with:dep with:anObject)
+ ]
+ ]
+ ] ifFalse:[
+ deps add:anObject
+ ]
+ ]
] ensure:[
- wasBlocked ifFalse:[
- OperatingSystem unblockInterrupts
- ]
+ wasBlocked ifFalse:[
+ OperatingSystem unblockInterrupts
+ ]
]
- "Modified: / 27.10.1997 / 19:35:52 / cg"
+ "Modified: / 27-10-1997 / 19:35:52 / cg"
+ "Modified: / 15-03-2017 / 17:17:44 / stefan"
+ "Modified (comment): / 07-02-2018 / 11:45:32 / stefan"
+ "Modified: / 19-02-2019 / 23:45:03 / Claus Gittinger"
!
breakDependents
@@ -3525,14 +3679,14 @@
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"
+ ^ Dependencies at:self ifAbsent:#()
+
+ "
+ #(1 2 3) dependents
+ "
+
+ "Modified: / 26-01-1998 / 11:18:15 / cg"
+ "Modified (comment): / 03-12-2018 / 17:54:14 / Stefan Vogel"
!
dependents:aCollection
@@ -3576,19 +3730,21 @@
|deps nwDeps|
deps := self dependents.
- deps size ~~ 0 ifTrue:[
- deps do:[:d |
- (d notNil and:[d class ~~ SmallInteger]) ifTrue:[
- aBlock value:d
- ]
- ]
+ deps notEmptyOrNil ifTrue:[
+ deps do:[:d |
+ (d notNil and:[d class ~~ SmallInteger]) 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"
+ (nwDeps ~~ deps and:[nwDeps notNil]) ifTrue:[
+ nwDeps do:aBlock
+ ].
+
+ "Modified: / 30-01-1998 / 14:03:40 / cg"
+ "Modified: / 15-03-2017 / 17:15:09 / stefan"
+ "Modified: / 19-02-2019 / 23:44:42 / Claus Gittinger"
!
myDependents
@@ -3601,9 +3757,12 @@
"remove all references to objects that may refer to self.
Subclasses may redefine this method but should do a 'super release'."
+ <modifier: #super> "must be called if redefined"
+
self breakDependents
- "Modified: / 27.2.1998 / 11:29:35 / stefan"
+ "Modified: / 27-02-1998 / 11:29:35 / stefan"
+ "Modified: / 08-02-2017 / 00:23:42 / cg"
!
removeDependent:anObject
@@ -3618,48 +3777,49 @@
wasBlocked := OperatingSystem blockInterrupts.
[
- |deps n dep|
-
- 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) or:[deps class == Array]) ifTrue:[
- ((dep := deps at:1) == anObject
- or:[dep isNil
- or:[dep class == SmallInteger]]) ifTrue:[
- self dependents:nil
- ]
- ] ifFalse:[
- dep := deps remove:anObject ifAbsent:[].
- "if dep is nil, nothing has changed"
- dep notNil ifTrue:[
- (n := deps size) == 0 ifTrue:[
- self dependents:nil
- ] ifFalse:[
- n == 1 ifTrue:[
- dep := deps firstIfEmpty:nil.
- dep notNil ifTrue:[
- deps := (deps isWeakCollection ifTrue:[WeakArray] ifFalse:[Array]) with:dep
- ] ifFalse:[
- deps := nil
- ].
- self dependents:deps.
- ]
- ].
- ].
- ]
- ]
+ |deps n dep|
+
+ deps := self dependents.
+ deps notEmptyOrNil 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) or:[deps class == Array]) ifTrue:[
+ ((dep := deps at:1) == anObject
+ or:[dep isNil
+ or:[dep class == SmallInteger]]) ifTrue:[
+ self dependents:nil
+ ]
+ ] ifFalse:[
+ dep := deps remove:anObject ifAbsent:[].
+ "if dep is nil, nothing has changed"
+ dep notNil ifTrue:[
+ (n := deps size) == 0 ifTrue:[
+ self dependents:nil
+ ] ifFalse:[
+ n == 1 ifTrue:[
+ dep := deps firstIfEmpty:nil.
+ dep notNil ifTrue:[
+ deps := (deps isWeakCollection ifTrue:[WeakArray] ifFalse:[Array]) with:dep
+ ] ifFalse:[
+ deps := nil
+ ].
+ self dependents:deps.
+ ]
+ ].
+ ].
+ ]
+ ]
] ensure:[
- wasBlocked ifFalse:[
- OperatingSystem unblockInterrupts
- ]
+ wasBlocked ifFalse:[
+ OperatingSystem unblockInterrupts
+ ]
]
"Modified: / 05-07-2011 / 22:49:31 / cg"
+ "Modified (format): / 15-03-2017 / 17:20:23 / stefan"
! !
!Object methodsFor:'dependents access (non weak)'!
@@ -3679,41 +3839,42 @@
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:[
- anObject notNil ifTrue:[
- self nonWeakDependents:(Array with:anObject).
- ] ifFalse:[
- "adding nil causes problems when adding the next one
- (see below: trying to add nil to IdentitySet)"
+ |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 isEmptyOrNil ifTrue:[
+ anObject notNil ifTrue:[
+ self nonWeakDependents:(Array with:anObject).
+ ] ifFalse:[
+ "adding nil causes problems when adding the next one
+ (see below: trying to add nil to IdentitySet)"
"/ self halt:'try to add nil to list of dependents'.
- ].
- ] ifFalse:[
- deps class == Array ifTrue:[
- dep := deps at:1.
- dep ~~ anObject ifTrue:[
- self nonWeakDependents:(IdentitySet with:dep with:anObject)
- ]
- ] ifFalse:[
- deps add:anObject
- ]
- ]
+ ].
+ ] ifFalse:[
+ deps class == Array ifTrue:[
+ dep := deps at:1.
+ dep ~~ anObject ifTrue:[
+ self nonWeakDependents:(IdentitySet with:dep with:anObject)
+ ]
+ ] ifFalse:[
+ deps add:anObject
+ ]
+ ]
] ensure:[
- wasBlocked ifFalse:[
- OperatingSystem unblockInterrupts
- ]
+ wasBlocked ifFalse:[
+ OperatingSystem unblockInterrupts
+ ]
]
- "Created: / 19.4.1996 / 10:54:08 / cg"
- "Modified: / 30.1.1998 / 14:03:08 / cg"
+ "Created: / 19-04-1996 / 10:54:08 / cg"
+ "Modified: / 30-01-1998 / 14:03:08 / cg"
+ "Modified: / 15-03-2017 / 17:18:11 / stefan"
!
nonWeakDependents
@@ -3755,37 +3916,36 @@
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))
- ]
- ]
- ]
- ]
+ |deps n|
+
+ deps := self nonWeakDependents.
+ deps notEmptyOrNil 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))
+ ]
+ ]
+ ]
+ ]
] ensure:[
- wasBlocked ifFalse:[
- OperatingSystem unblockInterrupts
- ]
+ wasBlocked ifFalse:[
+ OperatingSystem unblockInterrupts
+ ]
]
- "Created: / 19.4.1996 / 11:44:44 / cg"
- "Modified: / 30.1.1998 / 14:04:01 / cg"
+ "Created: / 19-04-1996 / 11:44:44 / cg"
+ "Modified: / 30-01-1998 / 14:04:01 / cg"
+ "Modified: / 15-03-2017 / 17:19:38 / stefan"
! !
-
-
!Object methodsFor:'displaying'!
ascentOn:aGC
@@ -3799,23 +3959,39 @@
^ aGC fontAscent
!
+classDisplayString
+ "used by walkbacks and inspectors;
+ same as self class displayString for smalltalk objects;
+ redefinable for proxy objects to not display the className of the proxy,
+ but the classname of the remote object (-> JavaObject)"
+
+ ^ self class displayString.
+!
+
displayOn:aGCOrStream
"Compatibility
- append a printed desription on some stream (Dolphin, Squeak)
+ append a printed desription on some stream (Dolphin, Squeak)
OR:
- display the receiver in a graphicsContext at 0@0 (ST80).
+ display the receiver in a graphicsContext at 0@0 (ST80).
This method allows for any object to be displayed in some view
- (although the fallBack is to display its printString ...)"
-
- "/ what a kludge - Dolphin and Squeak mean: printOn: a stream;
- "/ ST/X (and some old ST80's) mean: draw-yourself on a GC.
- aGCOrStream isStream ifTrue:[
- self printOn:aGCOrStream.
- ^ self
- ].
- ^ self displayOn:aGCOrStream x:0 y:0.
-
- "Created: 29.5.1996 / 16:28:58 / cg"
+ (although the fallBack is to display its printString ...)
+
+ Notice: displayString and displayOn: are for developers, debugging and inspectors,
+ whereas printString and printOn: are for the program to print data."
+
+ aGCOrStream isStream ifFalse:[
+ "/ what a kludge - Dolphin and Squeak mean: printOn: a stream;
+ "/ old ST80 means: draw-yourself on a GC.
+ self obsoleteFeatureWarning:'displayOn: should not be used to display objects in a GC'.
+ self displayOn:aGCOrStream x:0 y:0.
+ ^ self.
+ ].
+ self printOn:aGCOrStream.
+
+ "Created: / 29-05-1996 / 16:28:58 / cg"
+ "Modified (format): / 22-02-2017 / 17:03:14 / cg"
+ "Modified: / 23-11-2018 / 14:54:12 / Stefan Vogel"
+ "Modified (comment): / 25-06-2019 / 10:47:18 / Claus Gittinger"
!
displayOn:aGC at:aPoint
@@ -3823,7 +3999,9 @@
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).
+ self displayOn:aGC x:(aPoint x) y:(aPoint y).
+
+ "Modified: / 23-11-2018 / 14:54:34 / Stefan Vogel"
!
displayOn:aGC x:x y:y
@@ -3870,15 +4048,16 @@
for example an Inspector. This is usually the same as printString,
but sometimes redefined for a better look.
+ Notice: displayString and displayOn: are for developers, debugging and inspectors,
+ whereas printString and printOn: are for the program to print data.
+
Note: the base method (used by the inspector) is #displayOn:.
- So you should implement #displayOn: instead of #displayString in subclasses."
+ So you should implement #displayOn: instead of #displayString in subclasses."
|s|
- "/ attention: TextStream is not present in ultra-mini standalone apps
- s := TextStream isNil
- ifTrue:['' writeStream]
- ifFalse:[TextStream on:(String new:32)].
+ "/ attention: TextStream is not present in ultra-mini standalone apps (WriteStream is in libbasic)
+ s := (TextStream ? CharacterWriteStream ? WriteStream) on:(String new:32).
self displayOn:s.
^ s contents
@@ -3886,7 +4065,12 @@
#(1 2 3) printString
#(1 2 3) displayString
#(1 2 3) storeString
- "
+ #hello printString
+ #hello displayString
+ #hello storeString
+ "
+
+ "Modified (comment): / 25-06-2019 / 10:47:29 / Claus Gittinger"
!
heightOn:aGC
@@ -3896,7 +4080,9 @@
!
printStringForPrintIt
- "for compatibility (used to be displayString), now the printIt menu function now sends this message"
+ "for compatibility (used to be displayString),
+ the printIt menu function now sends this message,
+ allowing for more fine-grain control over what is printed."
^ self displayString
@@ -3904,6 +4090,10 @@
#(1 2 3) printString
#(1 2 3) printStringForPrintIt
#(1 2 3) storeString
+
+ 'hello' printString
+ 'hello' printStringForPrintIt
+ 'hello' storeString
"
!
@@ -4040,79 +4230,103 @@
fromLiteralArrayEncoding:aSpecArray
"read my attributes from aSpecArray.
- Recursively decodes arguments."
-
- |sel litVal val msg ex
- stop "{ Class:SmallInteger }" |
+ Recursively decodes arguments and stores them using the setters
+ as coming from the literal array encoded specArray."
+
+ |sel litVal val msg
+ stop "{ Class:SmallInteger }" |
stop := aSpecArray size.
2 to:stop by:2 do:[:i|
- sel := aSpecArray at:i.
- litVal := aSpecArray at:i + 1.
-
- (self respondsTo:sel) ifTrue:[
- val := litVal decodeAsLiteralArray.
- self perform:sel with:val
- ] ifFalse:[
- "/ that's a debug halt,
- "/ it should probably be removed (to simply ignore unhandled attributes)...
- "/ for now, it is left in, in order to easily find incompatibilities between
- "/ VW and ST/X.
- self breakPoint:#cg.
-
- msg := '%1: unhandled literalArrayEncoding attribute:'
- bindWith:self class name
- with:sel.
- UnhandledAttributeInLiteralArrayErrorSignal isHandled ifTrue:[
- ex := UnhandledAttributeInLiteralArrayErrorSignal new.
- ex badLiteralArray:self.
- ex parameter:sel.
- ex notify:msg.
- ] ifFalse:[
- msg infoPrintCR.
- ].
- ]
+ sel := aSpecArray at:i.
+ litVal := aSpecArray at:i + 1.
+
+ (self respondsTo:sel) ifTrue:[
+ val := litVal decodeAsLiteralArray.
+ self perform:sel with:val
+ ] ifFalse:[
+ "/ that's a debug halt,
+ "/ it should probably be removed (to simply ignore unhandled attributes)...
+ "/ for now, it is left in, in order to easily find incompatibilities between
+ "/ VW and ST/X.
+ self breakPoint:#cg.
+
+ msg := '%1: unhandled literalArrayEncoding attribute: %2'
+ bindWith:self class name
+ with:sel.
+ UnhandledAttributeInLiteralArrayErrorSignal isHandled ifTrue:[
+ |ex|
+ ex := UnhandledAttributeInLiteralArrayErrorSignal new.
+ ex
+ badLiteralArray:self;
+ parameter:sel;
+ notify:msg.
+ ] ifFalse:[
+ msg infoPrintCR.
+ ].
+ ]
]
+
+ "Modified: / 19-07-2018 / 12:12:14 / Stefan Vogel"
+ "Modified (comment): / 09-08-2018 / 17:32:30 / Claus Gittinger"
!
literalArrayEncoding
"generate a literalArrayEncoding array for myself.
This uses #literalArrayEncodingSlotOrder which defines the slots and
order and #skippedInLiteralEncoding which defines slots to skip.
+ In addition, an object may define virtualSlotsInLiteralEncoding for slots
+ which are not really instvars, but should be fetched via getters.
For most subclasses, there is no need to redefine those."
- |names encoding cls skipped slots|
+ |names encoding cls skipped slots virtualSlots|
self isLiteral ifTrue:[
- ^ self
+ ^ self
].
slots := self literalArrayEncodingSlotOrder.
+ virtualSlots := self virtualSlotsInLiteralEncoding.
skipped := self skippedInLiteralEncoding.
cls := self class.
names := cls allInstVarNames.
- encoding := OrderedCollection new:(1 + (2 * (slots size - skipped size))).
+ encoding := OrderedCollection new:(1 + (2 * (slots size + virtualSlots size - skipped size))).
encoding add:cls name.
slots do:[:instSlot |
- |value nm|
-
- nm := names at:instSlot.
- (skipped includes:nm) ifFalse:[
- (value := self instVarAt:instSlot) notNil ifTrue:[
- encoding add:(nm asMutator).
- encoding add:value literalArrayEncoding
- ]
- ]
+ |value nm enc|
+
+ nm := names at:instSlot.
+ (skipped includes:nm) ifFalse:[
+ (value := self instVarAt:instSlot) notNil ifTrue:[
+ (enc := value literalArrayEncoding) notNil ifTrue:[
+ encoding add:(nm asMutator).
+ encoding add:enc
+ ]
+ ]
+ ]
+ ].
+ virtualSlots do:[:vSlotName |
+ |value|
+
+ (skipped includes:vSlotName) ifFalse:[
+ (value := self perform:vSlotName) notNil ifTrue:[
+ encoding add:(vSlotName asMutator).
+ encoding add:value literalArrayEncoding
+ ]
+ ]
].
^ encoding asArray
"
- (1 -> 2) literalArrayEncoding
- DebugView menuSpec decodeAsLiteralArray literalArrayEncoding =
- DebugView menuSpec
- "
+ (1 -> 2) literalArrayEncoding
+ DebugView menuSpec decodeAsLiteralArray literalArrayEncoding =
+ DebugView menuSpec
+ "
+
+ "Modified (comment): / 09-08-2018 / 17:31:51 / Claus Gittinger"
+ "Modified: / 11-02-2019 / 16:50:30 / sr"
!
literalArrayEncodingSlotOrder
@@ -4130,9 +4344,24 @@
!
skippedInLiteralEncoding
- "return a Collection with it's elements are slots for skipping"
+ "return the inst-slots which are skipped when generating a literalArrayEncoding;
+ (to skip the ones with default or irrelevant values.)"
^ #()
+
+ "Modified (comment): / 09-08-2018 / 17:16:44 / Claus Gittinger"
+!
+
+virtualSlotsInLiteralEncoding
+ "defines additional virtual slots in the literalEncoding.
+ These are not instvars, but accessed via getters and setters during
+ store and load.
+ Use this when flags encode values which were previously encoded as boolean instvars,
+ to remain backward compatible"
+
+ ^ #()
+
+ "Created: / 09-08-2018 / 17:22:04 / Claus Gittinger"
! !
!Object methodsFor:'error handling'!
@@ -4166,6 +4395,45 @@
"Modified (comment): / 02-11-2012 / 10:14:42 / cg"
!
+argumentError
+ "{ Pragma: +optSpace }"
+
+ "report an error that some bad argument was given to a methof.
+ The error is reported by raising the ArgumentError exception."
+
+ <resource: #skipInDebuggersWalkBack>
+
+ ^ ArgumentError raiseRequestWith:nil
+
+ "Created: / 14-08-2018 / 10:49:35 / Claus Gittinger"
+!
+
+argumentError:msg
+ "{ Pragma: +optSpace }"
+
+ "report an error that some bad argument was given to a methof.
+ The error is reported by raising the ArgumentError exception."
+
+ <resource: #skipInDebuggersWalkBack>
+
+ ^ ArgumentError raiseRequestErrorString:msg
+
+ "Created: / 14-08-2018 / 10:49:52 / Claus Gittinger"
+!
+
+argumentError:msg with:aValue
+ "{ Pragma: +optSpace }"
+
+ "report an error that some bad argument was given to a methof.
+ The error is reported by raising the ArgumentError exception."
+
+ <resource: #skipInDebuggersWalkBack>
+
+ ^ ArgumentError raiseRequestWith:aValue errorString:msg
+
+ "Created: / 14-08-2018 / 10:52:20 / Claus Gittinger"
+!
+
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
@@ -4241,9 +4509,10 @@
<resource: #skipInDebuggersWalkBack>
- ^ ElementBoundsError raise
-
- "Modified: 8.5.1996 / 09:12:49 / cg"
+ ^ ElementBoundsError raiseErrorString:' - element must be a character'
+
+ "Modified: / 08-05-1996 / 09:12:49 / cg"
+ "Modified: / 07-02-2017 / 20:09:42 / stefan"
!
elementNotInteger
@@ -4255,9 +4524,10 @@
<resource: #skipInDebuggersWalkBack>
- ^ ElementBoundsError raise
-
- "Modified: 8.5.1996 / 09:12:51 / cg"
+ ^ ElementBoundsError raiseErrorString:' - element must be an integer'
+
+ "Modified: / 08-05-1996 / 09:12:51 / cg"
+ "Modified: / 07-02-2017 / 20:09:58 / stefan"
!
error
@@ -4340,10 +4610,20 @@
<resource: #skipInDebuggersWalkBack>
- ^ KeyNotFoundError raiseRequestWith:aKey errorString:(' ', aKey printString)
+ |info|
+
+ aKey class == Character ifTrue:[
+ info := aKey storeString.
+ ] ifFalse:[
+ info := aKey printString.
+ ].
+ "/ KeyNotFoundError already presents the paramater in its errorString
+ ^ KeyNotFoundError raiseRequestWith:aKey "/ errorString:(' ', info)
"
Dictionary new at:#nonExistentElement
+ 'hello' at:8
+ 'hello' detect:#isDigit
"
!
@@ -4380,7 +4660,21 @@
"Created: / 19.6.1998 / 02:32:32 / cg"
!
-handlerForSignal:exceptionHandler context:theContext originator:originator
+errorUnsupported:what
+ "{ Pragma: +optSpace }"
+
+ "report an error that some functionality is not supported"
+
+ <resource: #skipInDebuggersWalkBack>
+
+ ^ UnimplementedFunctionalityError raiseRequestErrorString:what
+
+ "
+ self errorUnsupported:'foobar'
+ "
+!
+
+handlerForSignal:exceptionCreator context:theContext originator:originator
" should never be invoked for non-blocks/non-exceptions/non-signals"
thisContext isRecursive ifTrue:[^ nil].
@@ -4392,16 +4686,8 @@
"/ MiniDebugger enter:thisContext withMessage:'oops' mayProceed:true.
self error:'this method should only be invoked for blocks, exceptions and signals'.
-!
-
-implementedBySubclass
- "{ Pragma: +optSpace }"
-
- "this is sent by ST/V code - its the same as #subclassResponsibility"
-
- <resource: #skipInDebuggersWalkBack>
-
- ^ SubclassResponsibilityError raiseRequestErrorString:'method must be reimplemented in ST/V subclass'
+
+ "Modified (format): / 06-09-2019 / 15:47:38 / Stefan Reise"
!
indexNotInteger
@@ -4454,13 +4740,14 @@
<resource: #skipInDebuggersWalkBack>
"/ ^ self error:'bad assign of ' , self printString ,
-"/ ' (' , self class name , ') to integer-typed variable'
+"/ ' (' , self className , ') to integer-typed variable'
^ InvalidTypeError
- raiseRequestErrorString:(
- 'bad assign of ' , self printString ,
- ' (' , self class name , ') to integer-typed variable')
+ raiseRequestErrorString:(
+ 'bad assign of ' , self printString ,
+ ' (' , self className , ') to integer-typed variable')
"Modified: / 02-11-2012 / 10:25:36 / cg"
+ "Modified (comment): / 28-06-2019 / 09:04:45 / Claus Gittinger"
!
invalidCodeObject
@@ -4477,18 +4764,6 @@
"Created: / 01-08-1997 / 00:16:44 / cg"
!
-invalidMessage
- "{ Pragma: +optSpace }"
-
- "this is sent by ST/V code - it is the same as #shouldNotImplement"
-
- <resource: #skipInDebuggersWalkBack>
-
- ^ self shouldNotImplement
-
- "Modified (comment): / 02-11-2012 / 10:11:18 / cg"
-!
-
mustBeRectangle
"{ Pragma: +optSpace }"
@@ -4548,8 +4823,10 @@
sender := thisContext sender.
- ^ UnimplementedFunctionalityError
- raiseRequestWith:(Message selector:sender selector arguments:sender args)
+ ^ UnimplementedFunctionalityError new
+ parameter:(Message selector:sender selector arguments:sender args);
+ lineNumber:sender lineNumber;
+ raise.
"Modified: / 02-11-2012 / 10:24:12 / cg"
!
@@ -4558,32 +4835,29 @@
"{ Pragma: +optSpace }"
"report an error that some primitive code failed.
- The error is reported by raising the PrimitiveFailure exception.
- Sorry for the code duplication: it avoids the extra frame in the debugger."
+ The error is reported by raising the PrimitiveFailure exception."
<resource: #skipInDebuggersWalkBack>
- |sender selector|
-
- "do loop to take care of super sends"
- sender := thisContext sender.
- [
- selector := sender selector.
- selector == #primitiveFailed: or:[selector == #primitiveFailed]
- ] whileTrue:[sender := sender sender].
-
- ^ PrimitiveFailure raiseRequestWith:(Message selector:selector arguments:sender args)
- in:sender.
+ ^ self primitiveFailed:nil.
"
1234 primitiveFailed
-
+ "
+
+ "
+ ExternalBytes new basicAt:40
+ "
+
+ "
[
- ExternalBytes new basicAt:40
+ ExternalBytes new basicAt:40
] on:PrimitiveFailure do:[:ex|
- ex inspect
+ ex inspect
]
"
+
+ "Modified (comment): / 01-08-2017 / 13:50:18 / cg"
!
primitiveFailed:messageString
@@ -4596,20 +4870,46 @@
|sender selector|
- "do loop to take care of super sends"
+ "loop to take care of super sends"
sender := thisContext sender.
[
- selector := sender selector.
- selector == #primitiveFailed: or:[selector == #primitiveFailed]
+ selector := sender selector.
+ selector == #primitiveFailed: or:[selector == #primitiveFailed]
] whileTrue:[sender := sender sender].
- ^ PrimitiveFailure raiseRequestWith:(Message selector:selector arguments:sender args)
- errorString:messageString
- in:sender.
+ ^ PrimitiveFailure
+ raiseRequestWith:(Message selector:selector arguments:sender args)
+ errorString:messageString
+ in:sender.
"
1234 primitiveFailed:'this is a test'
"
+
+ "
+ ExternalBytes new basicAt:40
+ "
+
+ "
+ [
+ ExternalBytes new basicAt:40
+ ] on:PrimitiveFailure do:[:ex|
+ ex inspect
+ ]
+ "
+
+ "Modified (format): / 01-08-2017 / 13:51:21 / cg"
+!
+
+proceedableError:errorMessage
+ "Report a proceedable error.
+ A handler can provide a default value"
+
+ <resource: #skipInDebuggersWalkBack>
+
+ ^ self error:errorMessage mayProceed:true
+
+ "Created: / 24-05-2018 / 13:45:58 / Claus Gittinger"
!
shouldImplement
@@ -4647,12 +4947,14 @@
sender := thisContext sender.
^ UnimplementedFunctionalityError
- raiseRequestWith:(Message selector:sender selector arguments:sender args)
- errorString:what
+ raiseRequestWith:(Message selector:sender selector arguments:sender args)
+ errorString:what
"
self shouldImplement:'foobar'
"
+
+ "Modified (format): / 27-02-2018 / 11:12:19 / stefan"
!
shouldNeverBeReached
@@ -4671,11 +4973,18 @@
<resource: #skipInDebuggersWalkBack>
+ |sender|
+
+ sender := thisContext sender.
+
^ MethodNotAppropriateError
- raiseRequestErrorString:'This message never may be sent to me'.
+ raiseRequestWith:(Message selector:sender selector arguments:sender args)
+ errorString:'this message may never be sent to me'.
"Modified: / 20-04-2005 / 18:59:28 / janfrog"
"Modified: / 02-11-2012 / 10:10:42 / cg"
+ "Modified (format): / 27-02-2018 / 11:24:57 / stefan"
+ "Modified: / 25-09-2018 / 17:02:30 / Claus Gittinger"
!
shouldNotImplement
@@ -4684,12 +4993,18 @@
"report an error that this message should not be implemented -
i.e. that a method is invoked which is not appropriate for the receiver."
+ |sender|
+
<resource: #skipInDebuggersWalkBack>
+ sender := thisContext sender.
+
^ MethodNotAppropriateError
- raiseRequestErrorString:'method/functionality is not appropriate for class'.
+ raiseRequestWith:(Message selector:sender selector arguments:sender args)
+ errorString:'method/functionality is not appropriate for class'.
"Modified: / 02-11-2012 / 10:02:25 / cg"
+ "Modified (format): / 27-02-2018 / 11:25:13 / stefan"
!
subclassResponsibility
@@ -4709,7 +5024,9 @@
<resource: #skipInDebuggersWalkBack>
- ^ SubclassResponsibilityError raiseRequestErrorString:msg
+ ^ SubclassResponsibilityError raiseRequestWith:thisContext sender selector errorString:msg
+
+ "Modified: / 27-02-2018 / 11:09:32 / stefan"
!
subscriptBoundsError
@@ -4752,14 +5069,15 @@
<resource: #skipInDebuggersWalkBack>
"/ ^ self error:'bad assign of ' , self printString ,
-"/ ' (' , self class name , ') to typed variable'
+"/ ' (' , self className , ') to typed variable'
^ InvalidTypeError
- raiseRequestErrorString:
- ('bad assign of ' , self printString ,
- ' (' , self class name , ') to typed variable')
+ raiseRequestErrorString:
+ ('bad assign of ' , self printString ,
+ ' (' , self className , ') to typed variable')
"Modified: / 02-11-2012 / 10:19:15 / cg"
+ "Modified: / 28-06-2019 / 09:05:14 / Claus Gittinger"
! !
!Object methodsFor:'error handling - debugger'!
@@ -4805,53 +5123,50 @@
!
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."
+ "{ Pragma: +optSpace }"
+
|context|
- "DebugView cannot run without system processes"
-
(Processor isNil
- or:[Processor activeProcessIsSystemProcess
- or:[Smalltalk isInitialized not]]) ifTrue:[
- ^ MiniDebugger
+ or:[Processor activeProcessIsSystemProcess
+ or:[Smalltalk isInitialized not]]) ifTrue:[
+ "DebugView cannot run without system processes"
+ ^ MiniDebugger
].
(Screen isNil or:[Screen default isNil or:[Screen default isOpen not]]) ifTrue:[
- Debugger isNil ifTrue:[^ nil].
- ^ MiniDebugger
+ Debugger isNil ifTrue:[^ nil].
+ ^ 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 occurred while in the graphical debugger;
- lets try MiniDebugger"
- ^ MiniDebugger
- ].
- context := context findNextContextWithSelector:aSelector or:nil or:nil.
+ [(context := context findNextContextWithSelector:aSelector or:nil or:nil) 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 occurred while in the graphical debugger;
+ lets try MiniDebugger"
+ ^ MiniDebugger
+ ].
].
"not within Debugger - no problem"
^ Debugger
- "Modified: / 23.9.1996 / 12:14:52 / stefan"
- "Modified: / 19.5.1999 / 18:05:00 / cg"
+ "Modified: / 19-05-1999 / 18:05:00 / cg"
+ "Modified (format): / 15-03-2017 / 17:37:08 / stefan"
!
openDebuggerOnException:ex
@@ -4953,17 +5268,18 @@
^ self
!
-argumentCount
- "compatibility with Blocks and Messages.
- Answer 0, since we only understand #value.
-
- By implementing this, you can pass any object as an exception handler."
-
- ^ 0
-
- "
- [1 // 0] on:ArithmeticError do:9999
- "
+doIfNotNil:aBlock
+ "if I am a collection, then enumerate myself into aBlock.
+ if I am nil, then do nothing.
+ Otherwise, evaluate aBlock with myself as argument.
+ Return the receiver.
+ Redefined in Collection and UndefinedObject."
+
+ aBlock value:self
+
+ "Created: / 20-03-2018 / 15:39:37 / stefan"
+ "Modified (comment): / 26-04-2018 / 14:20:13 / stefan"
+ "Modified (comment): / 05-08-2018 / 11:26:13 / Claus Gittinger"
!
value
@@ -5008,23 +5324,43 @@
"Modified: 3.5.1996 / 11:57:08 / cg"
!
+valueWithOptionalArgument:arg
+ "see comment in #value.
+ The arg is ignored here
+ (equivalent to sending this message to a 0-arg Block)"
+
+ ^ self value
+
+ "
+ [ 'abc' ] valueWithOptionalArgument:1
+ 'abc' valueWithOptionalArgument:1
+ 'abc' asValue valueWithOptionalArgument:1
+ "
+
+ "Created: / 08-03-2018 / 11:34:51 / stefan"
+!
+
valueWithPossibleArguments:argArray
"see comment in #value.
The argArray is ignored here
(equivalent to sending this message to a 0-arg Block)"
- ^ self
-
- "
- [ 'abc' ] valueWithPossibleArguments:#(1 2 3)
- 'abc' valueWithPossibleArguments:#(1 2 3)
- "
+ ^ self value
+
+ "
+ [ 'abc' ] valueWithPossibleArguments:#(1 2 3)
+ 'abc' valueWithPossibleArguments:#(1 2 3)
+ 'abc' asValue valueWithPossibleArguments:#(1 2 3)
+ "
+
+ "Modified: / 08-03-2018 / 11:55:05 / stefan"
! !
!Object methodsFor:'finalization'!
disposed
- "OBSOLETE INTERFACE: use #finalize
+ "OBSOLETE INTERFACE: please redefine #finalize instead.
+
this is invoked for objects which have been registered
in a Registry, when the original object dies.
Subclasses may redefine this method"
@@ -5036,12 +5372,14 @@
executor
"Return the object which does the finalization for me.
- This interface is also VW & Sqeak compatible,"
+ This interface is also VW & Squeak compatible,"
"for now, send #shallowCopyForFinalization, to be compatible with
classes designed for old ST/X versions"
^ self shallowCopyForFinalization
+
+ "Modified (comment): / 15-06-2017 / 01:46:54 / mawalch"
!
finalizationLobby
@@ -5081,7 +5419,7 @@
!
shallowCopyForFinalization
- "OBSOLETE INTERFACE: use #executor.
+ "OBSOLETE INTERFACE: please redefine #executor instead.
This is used to acquire a copy to be used for finalization -
(the copy will be sent a #finalize message; see the documentation in the Registry class)
This method can be redefined for more efficient copying - especially for large objects."
@@ -5132,7 +5470,9 @@
"a custom interrupt - but no handler has defined"
- self error:'custom interrupt' mayProceed:true
+ self proceedableError:'custom interrupt'
+
+ "Modified: / 24-05-2018 / 21:02:28 / Claus Gittinger"
!
errorInterrupt:errorID with:aParameter
@@ -5145,30 +5485,32 @@
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)
+ #DisplayError ..... x-error interrupt
+ #XtError ..... xt-error interrupt (Xt interface is not yet published)
"
|handlers handler|
handlers := ObjectMemory registeredErrorInterruptHandlers.
handlers notNil ifTrue:[
- handler := handlers at:errorID ifAbsent:nil.
- handler notNil ifTrue:[
- "/
- "/ handler found; let it do whatever it wants ...
- "/
- handler errorInterrupt:errorID with:aParameter.
- ^ self
- ].
+ handler := handlers 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
"/
- ^ Error
- raiseRequestWith:errorID
- errorString:('Subsystem error. ErrorID = ' , errorID printString)
+ ^ ProceedableError
+ raiseRequestWith:errorID
+ errorString:('Subsystem error. ErrorID = ' , errorID printString)
+
+ "Modified: / 04-02-2019 / 15:23:19 / Stefan Vogel"
!
exceptionInterrupt
@@ -5176,7 +5518,9 @@
"exception interrupt - enter debugger"
- self error:'exception Interrupt' mayProceed:true
+ self proceedableError:'exception Interrupt'
+
+ "Modified: / 24-05-2018 / 21:02:43 / Claus Gittinger"
!
fpExceptionInterrupt
@@ -5227,7 +5571,9 @@
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' mayProceed:true
+ self proceedableError:'I/O Interrupt - but no handler'
+
+ "Modified: / 24-05-2018 / 21:02:52 / Claus Gittinger"
!
memoryInterrupt
@@ -5235,7 +5581,9 @@
"out-of-memory interrupt and no handler - enter debugger"
- self error:'almost out of memory' mayProceed:true
+ self proceedableError:'almost out of memory'
+
+ "Modified: / 24-05-2018 / 21:02:58 / Claus Gittinger"
!
recursionInterrupt
@@ -5256,7 +5604,7 @@
will be a few more chances (and more interrupts) before the VM
terminates the process."
- |con remaining sender nSkipped caller level n|
+ |con remaining sender nSkipped caller level|
(con := thisContext) isRecursive ifFalse:[
"/ Processor activeProcess usedStackSize < Processor activeProcess maximumStackSize ifTrue:[
@@ -5264,44 +5612,48 @@
"/ 'Stray recursionInterrupt ...' infoPrintCR.
"/ ^ self
"/ ].
- ObjectMemory infoPrinting ifTrue:[
- level := 0.
- caller := thisContext sender.
- [caller notNil] whileTrue:[
- level := level + 1.
- caller := caller sender.
- ].
-
- 'Object [info]: recursionInterrupt from:' errorPrintCR.
- con := con sender.
- remaining := 500.
- n := 0.
- [con notNil and:[remaining > 0]] whileTrue:[
- sender := con sender.
- RecursionInterruptSignal handle:[:ex |
- ] do:[
- '| ' _errorPrint. con fullPrint.
- ].
- nSkipped := 0.
- [sender notNil and:[sender sender notNil
- and:[sender selector == con selector
- and:[sender sender selector == con selector
- and:[sender method == con method]]]]] whileTrue:[
- nSkipped := nSkipped + 1.
- con := sender.
- sender := con sender.
- ].
- nSkipped > 0 ifTrue:[
- '| ... ***** ' _errorPrint. nSkipped _errorPrint. ' recursive contexts skipped *****' _errorPrintCR.
- ].
- con := sender.
- remaining := remaining - 1
- ].
- ].
- ^ RecursionInterruptSignal raiseSignal
+ ObjectMemory infoPrinting ifTrue:[
+ level := 0.
+ caller := con sender.
+ [caller notNil] whileTrue:[
+ level := level + 1.
+ caller := caller sender.
+ ].
+
+ 'Object [info]: recursionInterrupt ( from:' _errorPrint.
+ level _errorPrint. ') from:' _errorPrintCR.
+
+ con := con sender.
+ remaining := 500.
+ [con notNil and:[remaining > 0]] whileTrue:[
+ sender := con sender.
+ RecursionInterruptSignal handle:[:ex |
+ ] do:[
+ '| ' _errorPrint. con savePrint.
+ ].
+ nSkipped := 0.
+ [sender notNil and:[sender sender notNil
+ and:[sender selector == con selector
+ and:[sender sender selector == con selector
+ and:[sender method == con method]]]]] whileTrue:[
+ nSkipped := nSkipped + 1.
+ con := sender.
+ sender := con sender.
+ ].
+ nSkipped > 0 ifTrue:[
+ '| ... ***** ' _errorPrint. nSkipped _errorPrint. ' recursive contexts skipped *****' _errorPrintCR.
+ ].
+ con := sender.
+ remaining := remaining - 1
+ ].
+ ].
+ ^ RecursionInterruptSignal raiseSignal
]
- "Modified: / 10.11.2001 / 15:15:56 / cg"
+ "Modified: / 10-11-2001 / 15:15:56 / cg"
+ "Modified: / 15-03-2017 / 17:26:56 / stefan"
+ "Modified: / 20-02-2019 / 14:22:11 / Stefan Vogel"
+ "Modified: / 05-06-2019 / 20:27:31 / Claus Gittinger"
!
schedulerInterrupt
@@ -5312,7 +5664,9 @@
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' mayProceed:true
+ self proceedableError:'schedulerInterrupt - but no Processor'
+
+ "Modified: / 24-05-2018 / 21:03:28 / Claus Gittinger"
!
signalInterrupt:signalNumber
@@ -5329,44 +5683,35 @@
|name here sig fatal titles actions badContext msg pc addr
action title screen|
+ (signalNumber == OperatingSystem sigPWR
+ or:[signalNumber == OperatingSystem sigHUP]) ifTrue:[
+ self signalInterruptWithCrashImage:signalNumber.
+ ^ self.
+ ].
+
thisContext isRecursive ifTrue:[
- 'Severe error: signalInterrupt while processing a signalInterrupt.' _errorPrintCR.
- 'Terminating process ' _errorPrint. Processor activeProcess _errorPrintCR.
+ 'Severe error: signalInterrupt while processing a signalInterrupt.' _errorPrintCR.
+ 'Terminating process ' _errorPrint. Processor activeProcess _errorPrintCR.
"/ GenericException handle:[:ex |
"/ "/ ignore any error during termination
"/ ] do:[
"/ Processor activeProcess terminate.
"/ ].
- MiniDebugger enter.
- Processor activeProcess terminateNoSignal.
+ MiniDebugger enter.
+ Processor activeProcess terminateNoSignal.
].
"if there has been an ST-signal installed, use it ..."
sig := OperatingSystem operatingSystemSignal:signalNumber.
sig notNil ifTrue:[
- sig raiseSignalWith:signalNumber.
- ^ self.
+ sig raiseSignalWith:signalNumber.
+ ^ self.
].
"/ if handled, raise OSSignalInterruptSignal
OSSignalInterrupt isHandled ifTrue:[
- OSSignalInterrupt raiseRequestWith:signalNumber.
- ^ self.
- ].
-
- "
- special cases
- - SIGPWR: power failure - write a crash image and continue
- - SIGHUP: hang up - write a crash image and exit
- "
- (signalNumber == OperatingSystem sigPWR) ifTrue:[
- SnapshotError ignoreIn:[ObjectMemory writeCrashImage].
- ^ self.
- ].
- (signalNumber == OperatingSystem sigHUP) ifTrue:[
- SnapshotError ignoreIn:[ObjectMemory writeCrashImage].
- 'Object [info]: exit due to hangup signal.' errorPrintCR.
- Smalltalk exit:1.
+ OSSignalInterrupt raiseRequestWith:signalNumber.
+ ^ self.
].
name := OperatingSystem nameForSignal:signalNumber.
@@ -5376,7 +5721,7 @@
or:[(screen := Screen current) isNil
or:[(screen := Screen default) isNil
or:[screen isOpen not]]]) ifTrue:[
- ^ self startMiniDebuggerOrExit:'OS-Signal (' , name, ')'.
+ ^ self startMiniDebuggerOrExit:'OS-Signal (' , name, ')'.
].
"ungrab - in case it happened in a box/popupview
@@ -5388,117 +5733,144 @@
"there is a screen. use it to bring up a box asking for what to do ..."
Screen currentScreenQuerySignal answer:screen do:[
- "
- 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.
- "
- fatal := OperatingSystem isFatalSignal:signalNumber.
- fatal ifTrue:[
- (Debugger isNil or:[here isRecursive]) ifTrue:[
- 'Object [hard error]: signal ' errorPrint. signalNumber errorPrintCR.
- ^ self startMiniDebuggerOrExit:'OS-Signal (' , name, ')'.
- ].
- "
- 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 mayProceed:false.
- "unreachable"
- ^ nil.
- ].
-
- "if possible, open an option box asking the user what do.
- Otherwise, start a debugger"
- Dialog notNil ifTrue:[
- OperatingSystem isOSXlike ifTrue:[
- titles := #('Save crash image' 'Dump core' 'GDB' 'Exit ST/X' 'Debug').
- actions := #(save core gdb exit debug).
- ] ifFalse:[
- titles := #('Save crash image' 'Dump core' 'Exit ST/X' 'Debug').
- actions := #(save core exit debug).
- ].
- action := nil.
- title := 'OS Signal caught (' , name, ')'.
- title := (title , '\[in ST-process: ' , Processor activeProcess nameOrId ,']') withCRs.
-
- "/ if caught while in the scheduler or event dispatcher,
- "/ a modal dialog is not possible ...
- "/ (therefore, abort & return does not makes sense)
-
- Processor activeProcess isSystemProcess ifFalse:[
- titles := #('Abort') , titles.
- actions := #(abort), actions.
-
- badContext canReturn ifTrue:[
- titles := #('Return') , titles.
- actions := #(return), actions.
- ].
- ].
-
- fatal ifFalse:[
- titles := titles, #('Ignore').
- actions := actions , #(ignore).
- ].
- action := Dialog choose:title
- labels:titles
- values:actions
- default:(fatal ifTrue:[nil] ifFalse:[#ignore]).
-
- "Dialog may fail (if system process), default action is debug"
- action isEmptyOrNil ifTrue:[action := #debug].
- ] ifFalse:[
- action := #debug.
- ].
-
- action == #save ifTrue:[
- ObjectMemory writeCrashImage
- ].
- action == #gdb ifTrue:[
- OperatingSystem openTerminalWithCommand:('gdb -p %1' bindWith:OperatingSystem getProcessId) inBackground:true.
- MiniDebugger enter. "/ to stop, so gdb can show where we are
- AbortOperationRequest raise.
- ].
- action == #core ifTrue:[
- Smalltalk fatalAbort
- ].
- action == #exit ifTrue:[
- Smalltalk exit:10.
- ].
- action == #return ifTrue:[
- badContext return
- ].
- action == #abort ifTrue:[
- AbortOperationRequest raise.
- ].
-
- action == #debug ifTrue:[
- Debugger isNil ifTrue:[
- ^ self startMiniDebuggerOrExit:'OS-Signal (' , name, ')'.
- ].
- Debugger enter:here withMessage:('OS-Signal ', name) mayProceed:true.
- ].
- "action == #ignore"
+ "
+ 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.
+ "
+ fatal := OperatingSystem isFatalSignal:signalNumber.
+ fatal ifTrue:[
+ (Debugger isNil or:[here isRecursive]) ifTrue:[
+ 'Object [hard error]: signal ' errorPrint. signalNumber errorPrintCR.
+ ^ self startMiniDebuggerOrExit:'OS-Signal (' , name, ')'.
+ ].
+ "
+ 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 mayProceed:false.
+ "unreachable"
+ ^ nil.
+ ].
+
+ "if possible, open an option box asking the user what do.
+ Otherwise, start a debugger"
+ Dialog notNil ifTrue:[
+ OperatingSystem isOSXlike ifTrue:[
+ titles := #('Save crash image' 'Dump core' 'GDB' 'Exit ST/X' 'Debug').
+ actions := #(save core gdb exit debug).
+ ] ifFalse:[
+ titles := #('Save crash image' 'Dump core' 'Exit ST/X' 'Debug').
+ actions := #(save core exit debug).
+ ].
+ action := nil.
+ title := 'OS Signal caught (' , name, ')'.
+ title := (title , '\[in ST-process: ' , Processor activeProcess nameOrId ,']') withCRs.
+
+ "/ if caught while in the scheduler or event dispatcher,
+ "/ a modal dialog is not possible ...
+ "/ (therefore, abort & return does not makes sense)
+
+ Processor activeProcess isSystemProcess ifFalse:[
+ titles := #('Abort') , titles.
+ actions := #(abort), actions.
+
+ badContext canReturn ifTrue:[
+ titles := #('Return') , titles.
+ actions := #(return), actions.
+ ].
+ ].
+
+ fatal ifFalse:[
+ titles := titles, #('Ignore').
+ actions := actions , #(ignore).
+ ].
+ action := Dialog choose:title
+ labels:titles
+ values:actions
+ default:(fatal ifTrue:[nil] ifFalse:[#ignore]).
+
+ "Dialog may fail (if system process), default action is debug"
+ action isEmptyOrNil ifTrue:[action := #debug].
+ ] ifFalse:[
+ action := #debug.
+ ].
+
+ action == #save ifTrue:[
+ ObjectMemory writeCrashImage
+ ].
+ action == #gdb ifTrue:[
+ OperatingSystem openTerminalWithCommand:('gdb -p %1' bindWith:OperatingSystem getProcessId) inBackground:true.
+ MiniDebugger enter. "/ to stop, so gdb can show where we are
+ AbortOperationRequest raise.
+ ].
+ action == #core ifTrue:[
+ Smalltalk fatalAbort
+ ].
+ action == #exit ifTrue:[
+ Smalltalk exit:10.
+ ].
+ action == #return ifTrue:[
+ badContext return
+ ].
+ action == #abort ifTrue:[
+ AbortOperationRequest raise.
+ ].
+
+ action == #debug ifTrue:[
+ Debugger isNil ifTrue:[
+ ^ self startMiniDebuggerOrExit:'OS-Signal (' , name, ')'.
+ ].
+ Debugger enter:here withMessage:('OS-Signal ', name) mayProceed:true.
+ ].
+ "action == #ignore"
].
"Modified: / 15-09-2011 / 16:38:14 / cg"
+ "Modified: / 09-02-2018 / 18:06:16 / stefan"
+!
+
+signalInterruptWithCrashImage:signalNumber
+ "
+ special cases
+ - SIGPWR: power failure - write a crash image and continue
+ - SIGHUP: hang up - write a crash image and exit
+ "
+
+ thisContext isRecursive ifTrue:[
+ "got another signal while writing crash just continue"
+ ^ self.
+ ].
+
+ (signalNumber == OperatingSystem sigPWR) ifTrue:[
+ SnapshotError catch:[ObjectMemory writeCrashImage].
+ ^ self.
+ ].
+ (signalNumber == OperatingSystem sigHUP) ifTrue:[
+ 'Smalltalk [info]: got hangup signal from OS: writing crash.img.' _errorPrintCR.
+ SnapshotError catch:[ObjectMemory writeCrashImage].
+ 'Smalltalk [info]: exit due to hangup signal from OS.' _errorPrintCR.
+ Smalltalk exit:1.
+ ].
+
+ "Created: / 09-02-2018 / 18:05:46 / stefan"
!
spyInterrupt
@@ -5506,7 +5878,9 @@
"spy interrupt and no handler - enter debugger"
- self error:'spy Interrupt - but no handler' mayProceed:true
+ self proceedableError:'spy Interrupt - but no handler'
+
+ "Modified: / 24-05-2018 / 21:03:35 / Claus Gittinger"
!
startMiniDebuggerOrExit:text
@@ -5527,7 +5901,9 @@
"timer interrupt and no handler - enter debugger"
- self error:'timer Interrupt - but no handler' mayProceed:true
+ self proceedableError:'timer Interrupt - but no handler'
+
+ "Modified: / 24-05-2018 / 21:03:41 / Claus Gittinger"
!
userInterrupt
@@ -7051,15 +7427,17 @@
|cls|
+ "/ the new inspector2 will create multiple tabs containing basic,regular and type-specific inspectors
Inspector ~~ MiniInspector ifTrue:[
- cls := (Smalltalk classNamed: #'Tools::Inspector2').
+ cls := #'Tools::Inspector2' asClassIfAbsent:nil.
].
cls isNil ifTrue:[
- cls := self inspectorClass.
- cls isNil ifTrue:[
- ^ self basicInspect
- ].
- ].
+ cls := self inspectorClass.
+ cls isNil ifTrue:[
+ self basicInspect.
+ ^ self.
+ ].
+ ].
cls openOn:self
"
@@ -7068,8 +7446,12 @@
Smalltalk inspect
#(1 2 3) asOrderedCollection inspect
(Color red) inspect
- (Image fromFile:'bitmaps/garfield.gif') inspect
- "
+ (Image fromFile:'../../goodies/bitmaps/gifImages/garfield.gif') inspect
+ "
+
+ "Modified (format): / 29-11-2017 / 10:40:56 / stefan"
+ "Modified: / 10-10-2018 / 00:41:58 / Claus Gittinger"
+ "Modified (format): / 28-05-2019 / 19:45:07 / Claus Gittinger"
!
inspectorClass
@@ -7079,11 +7461,12 @@
Can (should) be redefined in classes for which a better inspector is available"
Inspector notNil ifTrue:[
- ^ Inspector.
- ].
- ^ (Smalltalk classNamed: #'InspectorView')
+ ^ Inspector.
+ ].
+ ^ #'InspectorView' asClassIfAbsent:nil
"Modified: / 08-03-2012 / 16:09:38 / cg"
+ "Modified: / 10-10-2018 / 00:42:11 / Claus Gittinger"
! !
!Object methodsFor:'object persistency'!
@@ -7175,35 +7558,54 @@
_errorPrint
"Do not use this in user code.
Prints on stderr, regardless of any redirection to a logger.
- Only to be used by the MiniDebugger, to ensure that its output is shown to a user"
-
- self asString _errorPrint.
+ Only to be used by the MiniDebugger or during early startup (before classes are initialized),
+ to ensure that its output is shown to a user"
+
+ "do not use #asString - error when executing: #('bla' 'fasel') asString"
+ (self printString asSingleByteStringReplaceInvalidWith:$?) _errorPrint.
+
+ "
+ #('bla' 'fasel') _errorPrint
+ 'hello' asUnicode16String _errorPrint
+ 'helloαβγ' asUnicode16String _errorPrint
+ 'helloαβγ' asUnicode16String _errorPrintCR
+ "
+
+ "Modified (comment): / 17-10-2017 / 13:31:09 / stefan"
!
_errorPrintCR
"Do not use this in user code.
Prints on stderr, regardless of any redirection to a logger.
- Only to be used by the MiniDebugger, to ensure that its output is shown to a user"
-
- self asString _errorPrintCR.
+ Only to be used by the MiniDebugger or during early startup (before classes are initialized),
+ to ensure that its output is shown to a user"
+
+ "do not use #asString - error when executing: #('bla' 'fasel') asString"
+ (self printString asSingleByteStringReplaceInvalidWith:$?) _errorPrintCR.
+
+ "Modified: / 17-10-2017 / 13:28:06 / stefan"
!
_print
"Do not use this in user code.
Prints on stdout, regardless of any redirection to a logger.
- Only to be used by low-level crash utilities (like MiniDebugger),
+ Only to be used by low-level crash utilities (like MiniDebugger),
to ensure that its output is shown to a user"
- self asString _print.
+ self printString _print.
+
+ "Modified: / 17-10-2017 / 13:28:11 / stefan"
!
_printCR
"Do not use this in user code.
Prints on stdout, regardless of any redirection to a logger.
- Only to be used by low-level crash utilities (like MiniDebugger),
+ Only to be used by low-level crash utilities (like MiniDebugger),
to ensure that its output is shown to a user"
- self asString _printCR.
+ self printString _printCR.
+
+ "Modified: / 17-10-2017 / 13:28:15 / stefan"
!
basicPrintOn:aStream
@@ -7263,15 +7665,15 @@
headless applications."
Logger notNil ifTrue:[
- PartialErrorPrintLine := (PartialErrorPrintLine ? ''), self printString string.
- ^ self.
+ PartialErrorPrintLine := (PartialErrorPrintLine ? ''), self printString string.
+ ^ self.
].
Stderr isNil ifTrue:[
- "/ the following allows errorPrint to be used during
- "/ the early init-phase, when no Stderr has been set up.
- "/ (depends on string to respond to #errorPrint)
- self printString utf8Encoded errorPrint.
- ^ self.
+ "/ the following allows errorPrint to be used during
+ "/ the early init-phase, when no Stderr has been set up.
+ "/ (depends on string to respond to #errorPrint)
+ self printString errorPrint.
+ ^ self.
].
self withErrorStreamDo:[:s | self printOn:s].
@@ -7288,24 +7690,25 @@
headless applications."
Logger notNil ifTrue:[
- |fullLine|
- fullLine := (PartialErrorPrintLine ? ''), self printString string.
- PartialErrorPrintLine := nil.
- Logger error:fullLine.
- ^ self.
+ |fullLine|
+ fullLine := (PartialErrorPrintLine ? ''), self printString string.
+ PartialErrorPrintLine := nil.
+ Logger error:fullLine.
+ ^ self.
].
Stderr isNil ifTrue:[
- "/ the following allows errorPrintCR to be used during
- "/ the early init-phase, when no Stderr has been set up.
- "/ (depends on string to respond to #errorPrintCR)
- self printString utf8Encoded errorPrintCR.
- ^ self.
+ "/ the following allows errorPrintCR to be used during
+ "/ the early init-phase, when no Stderr has been set up.
+ "/ (depends on string to respond to #errorPrintCR)
+ self printString errorPrintCR.
+ ^ self.
].
self withErrorStreamDo:[:s | self printOn:s. s cr].
"
'hello' errorPrintCR
+ 'aöäü' errorPrintCR
"
"Created: / 20-05-1996 / 10:20:41 / cg"
@@ -7450,6 +7853,17 @@
"Modified: 20.5.1996 / 10:25:46 / cg"
!
+printNl
+ "print the receiver followed by a cr on the standard output stream
+ This exists for GNU Smalltalk compatibility - please use #printCR."
+
+ <resource:#obsolete>
+
+ ^ self printCR
+
+ "Modified: 20.5.1996 / 10:25:31 / cg"
+!
+
printOn:aStream
"append a user printed representation of the receiver to aStream.
The format is suitable for a human - not meant to be read back.
@@ -7547,7 +7961,7 @@
"allocate at least 40 bytes for fast UUID conversion.
cg: who did that? If that's a bottleneck, it ought to be done in UUID, not here!!"
- s := CharacterWriteStream on:(String basicNew:40).
+ s := CharacterWriteStream new:40.
self printOn:s.
^ s contents.
@@ -7627,13 +8041,17 @@
!
printStringLimitedTo:sizeLimit
- "return a string for printing the receiver, but limit the result string in its size."
+ "return a string for printing the receiver, but limit the result string in its size.
+ (i.e. silently truncate the string)"
|s|
- s := CharacterWriteStream on:(String basicNew:30).
+ s := CharacterWriteStream new:30.
s writeLimit:sizeLimit.
- self printOn:s.
+ WriteError handle:[:ex |
+ ] do:[
+ self printOn:s.
+ ].
^ s contents.
"
@@ -7647,14 +8065,9 @@
evaluating exceptionBlock. Useful to print something in an exceptionHandler or other
cleanup code."
- |rslt|
-
- Error handle:[:ex |
- rslt := exceptionBlock value
- ] do:[
- rslt := self printString
- ].
- ^ rslt
+ ^ [self printString] on:Error do:exceptionBlock.
+
+ "Modified: / 09-02-2017 / 10:00:59 / stefan"
!
printStringPaddedTo:size
@@ -7741,10 +8154,13 @@
"
!
-printfPrintString:ignoredFormat
+printfPrintString:format
"fallback to default printString
(for compatibility with float and integer-printing)"
+ PrintfScanf notNil ifTrue:[
+ ^ PrintfScanf printf:format argument:self
+ ].
^ self printString
!
@@ -7755,13 +8171,6 @@
self storeOn:Processor activeProcess stdout
!
-storeArrayElementOn:aStream
- "store an object as an Array element.
- Subclasses may redefine this to omit a leading '#'"
-
- ^ self storeOn:aStream
-!
-
storeCR
"store the receiver on standard output; append a carriage return."
@@ -7796,62 +8205,62 @@
|myClass hasSemi sz "{ Class: SmallInteger }" |
thisContext isRecursive ifTrue:[
- RecursiveStoreError raiseRequestWith:self.
- 'Object [error]: storeString of self referencing object (' errorPrint.
- self class name errorPrint.
- ')' errorPrintCR.
- aStream nextPutAll:'#("recursive")'.
- ^ self
+ RecursiveStoreError raiseRequestWith:self.
+ 'Object [error]: storeString of self referencing object (' errorPrint.
+ self class name errorPrint.
+ ')' errorPrintCR.
+ aStream nextPutAll:'#("recursive")'.
+ ^ self
].
myClass := self class.
aStream nextPut:$(.
- aStream nextPutAll:self class name.
+ aStream nextPutAll:myClass name.
hasSemi := false.
myClass isVariable ifTrue:[
- aStream nextPutAll:' basicNew:'.
- self basicSize printOn:aStream
+ aStream nextPutAll:' basicNew:'.
+ self basicSize printOn:aStream
] ifFalse:[
- aStream nextPutAll:' basicNew'
+ aStream nextPutAll:' basicNew'
].
sz := myClass instSize.
1 to:sz do:[:i |
- |ref|
-
- ref := (self instVarAt:i).
- "/ no need to store nil entries, because the object has been instantiated
- "/ with basicNew just a moment ago (so the fields are already nil)
- ref notNil ifTrue:[
- aStream nextPutAll:' instVarAt:'.
- i printOn:aStream.
- aStream nextPutAll:' put:'.
- ref storeOn:aStream.
- aStream nextPut:$;.
- hasSemi := true
- ].
+ |ref|
+
+ ref := (self instVarAt:i).
+ "/ no need to store nil entries, because the object has been instantiated
+ "/ with basicNew just a moment ago (so the fields are already nil)
+ ref notNil ifTrue:[
+ aStream nextPutAll:' instVarAt:'.
+ i printOn:aStream.
+ aStream nextPutAll:' put:'.
+ ref storeOn:aStream.
+ aStream nextPut:$;.
+ hasSemi := true
+ ].
].
myClass isVariable ifTrue:[
- sz := self basicSize.
- 1 to:sz do:[:i |
- |ref|
-
- ref := (self basicAt:i).
- "/ no need to store nil entries, because the object has been instantiated
- "/ with basicNew just a moment ago (so the fields are already nil)
- ref notNil ifTrue:[
- aStream nextPutAll:' basicAt:'.
- i printOn:aStream.
- aStream nextPutAll:' put:'.
- ref storeOn:aStream.
- aStream nextPut:$;.
- hasSemi := true
- ]
- ]
+ sz := self basicSize.
+ 1 to:sz do:[:i |
+ |ref|
+
+ ref := (self basicAt:i).
+ "/ no need to store nil entries, because the object has been instantiated
+ "/ with basicNew just a moment ago (so the fields are already nil)
+ ref notNil ifTrue:[
+ aStream nextPutAll:' basicAt:'.
+ i printOn:aStream.
+ aStream nextPutAll:' put:'.
+ ref storeOn:aStream.
+ aStream nextPut:$;.
+ hasSemi := true
+ ]
+ ]
].
hasSemi ifTrue:[
- aStream nextPutAll:' yourself'
+ aStream nextPutAll:' yourself'
].
aStream nextPut:$).
@@ -7890,6 +8299,7 @@
"
"Modified: / 03-12-2010 / 13:27:51 / cg"
+ "Modified: / 30-09-2019 / 14:43:42 / Stefan Vogel"
!
storeString
@@ -7905,6 +8315,31 @@
^ s contents
!
+transcribe
+ "print the receiver on the Transcript (without CR)"
+
+ self printOn:(Processor activeProcess transcript)
+
+ "Created: / 03-02-2019 / 13:01:29 / Claus Gittinger"
+!
+
+transcribeCR
+ "print the receiver on the Transcript (with CR)"
+
+ |out|
+
+ out := Processor activeProcess transcript.
+ self printOn:out.
+ out cr.
+
+ "
+ 1234 transcribe
+ 1234 transcribeCR
+ "
+
+ "Created: / 03-02-2019 / 13:02:46 / Claus Gittinger"
+!
+
withErrorStreamDo:aBlock
"{ Pragma: +optSpace }"
@@ -7920,26 +8355,56 @@
"CG: care for standalone non-GUI progs, which have no userPreferences class"
(Smalltalk isInitialized
- and:[ UserPreferences notNil
- and:[ UserPreferences current sendMessagesAlsoToTranscript]]) ifTrue:[
- stream := activeProcess isSystemProcess
- ifTrue:[stderr]
- ifFalse:[activeProcess transcript].
+ and:[UserPreferences notNil
+ and:[UserPreferences current sendMessagesAlsoToTranscript]]) ifTrue:[
+ stream := activeProcess isSystemProcess
+ ifTrue:[stderr]
+ ifFalse:[activeProcess transcript].
].
stream notNil ifTrue:[
- StreamError catch:[
- aBlock value:stream.
- ].
- ].
- stream ~~ stderr ifTrue:[
- UserPreferences current sendMessagesOnlyToTranscript ifFalse:[
- aBlock value:stderr.
- ].
+ StreamError catch:[
+ aBlock value:stream.
+ ].
+ ].
+
+ (stream ~~ stderr
+ and:[stderr notNil
+ and:[UserPreferences current sendMessagesOnlyToTranscript not]]) ifTrue:[
+ StreamError catch:[
+ aBlock value:stderr.
+ ].
].
"Created: / 21-04-2011 / 12:46:21 / cg"
! !
+!Object methodsFor:'private array element printing'!
+
+displayArrayElementOn:aStream
+ "Display myself as an Array element on aStream.
+ Subclasses may redefine this to omit a leading '#'"
+
+ ^ self displayOn:aStream
+
+ "Created: / 29-03-2019 / 12:01:32 / stefan"
+!
+
+printArrayElementOn:aStream
+ "Print myself as an Array element.
+ Subclasses may redefine this to omit a leading '#'"
+
+ ^ self printOn:aStream
+
+ "Created: / 29-03-2019 / 11:55:06 / stefan"
+!
+
+storeArrayElementOn:aStream
+ "store an object as an Array element.
+ Subclasses may redefine this to omit a leading '#'"
+
+ ^ self storeOn:aStream
+! !
+
!Object methodsFor:'queries'!
basicSize
@@ -7952,7 +8417,7 @@
#ifdef __SCHTEAM__
return context._RETURN( STInteger._new( self.basicSize() ) );
#else
- REGISTER INT nBytes;
+ REGISTER INT nbytes;
REGISTER OBJ myClass;
int nInstBytes;
@@ -7962,50 +8427,50 @@
* and SmallInteger
*/
myClass = __qClass(self);
- nBytes = __qSize(self);
+ nbytes = __qSize(self);
nInstBytes = OHDR_SIZE + __OBJS2BYTES__( __intVal(__ClassInstPtr(myClass)->c_ninstvars) );
switch ((INT)(__ClassInstPtr(myClass)->c_flags) & __MASKSMALLINT(ARRAYMASK)) {
case __MASKSMALLINT(POINTERARRAY):
case __MASKSMALLINT(WKPOINTERARRAY):
- nBytes -= nInstBytes;
- RETURN ( __mkSmallInteger(__BYTES2OBJS__(nBytes)) );
+ nbytes -= nInstBytes;
+ RETURN ( __mkSmallInteger(__BYTES2OBJS__(nbytes)) );
case __MASKSMALLINT(BYTEARRAY):
- nBytes -= nInstBytes;
- RETURN ( __mkSmallInteger(nBytes / sizeof(char)) );
+ nbytes -= nInstBytes;
+ RETURN ( __mkSmallInteger(nbytes / sizeof(char)) );
case __MASKSMALLINT(FLOATARRAY):
# ifdef __NEED_FLOATARRAY_ALIGN
nInstBytes = (nInstBytes-1+__FLOATARRAY_ALIGN) &~ (__FLOATARRAY_ALIGN-1);
# endif
- nBytes -= nInstBytes;
- RETURN ( __mkSmallInteger(nBytes / sizeof(float)) );
+ nbytes -= nInstBytes;
+ RETURN ( __mkSmallInteger(nbytes / sizeof(float)) );
case __MASKSMALLINT(DOUBLEARRAY):
# ifdef __NEED_DOUBLE_ALIGN
nInstBytes = (nInstBytes-1+__DOUBLE_ALIGN) &~ (__DOUBLE_ALIGN-1);
# endif
- nBytes -= nInstBytes;
- RETURN ( __mkSmallInteger(nBytes / sizeof(double)) );
+ nbytes -= nInstBytes;
+ RETURN ( __mkSmallInteger(nbytes / sizeof(double)) );
case __MASKSMALLINT(WORDARRAY):
case __MASKSMALLINT(SWORDARRAY):
- nBytes -= nInstBytes;
- RETURN ( __mkSmallInteger(nBytes>>1) ); /* notice the hardcoded 2 here - not sizeof(short) */
+ nbytes -= nInstBytes;
+ RETURN ( __mkSmallInteger(nbytes>>1) ); /* notice the hardcoded 2 here - not sizeof(short) */
case __MASKSMALLINT(LONGARRAY):
case __MASKSMALLINT(SLONGARRAY):
- nBytes -= nInstBytes;
- RETURN ( __mkSmallInteger(nBytes>>2) ); /* notice the hardcoded 4 here - not sizeof(int) */
+ nbytes -= nInstBytes;
+ RETURN ( __mkSmallInteger(nbytes>>2) ); /* notice the hardcoded 4 here - not sizeof(int) */
case __MASKSMALLINT(LONGLONGARRAY):
case __MASKSMALLINT(SLONGLONGARRAY):
# ifdef __NEED_LONGLONG_ALIGN
nInstBytes = (nInstBytes-1+__LONGLONG_ALIGN) &~ (__LONGLONG_ALIGN-1);
# endif
- nBytes -= nInstBytes;
- RETURN ( __mkSmallInteger(nBytes>>3) ); /* notice the hardcoded 8 here - not sizeof(long long) */
+ nbytes -= nInstBytes;
+ RETURN ( __mkSmallInteger(nbytes>>3) ); /* notice the hardcoded 8 here - not sizeof(long long) */
}
#endif /* not __SCHTEAM__ */
%}.
@@ -8082,12 +8547,12 @@
!
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
+ "return true if the receiver responds to a message with aSelector;
+ i.e. if there is a method for aSelector in either the
receiver's 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
+ an error being raised; for example, an implementation could send
#shouldNotImplement or #subclassResponsibility."
"
@@ -8099,7 +8564,7 @@
%{ /* NOCONTEXT */
if (__lookup(__Class(self), aSelector) == nil) {
- RETURN ( false );
+ RETURN ( false );
}
RETURN ( true );
%}
@@ -8107,9 +8572,11 @@
^ self class canUnderstand:aSelector
- "'aString' respondsTo:#+"
- "'aString' respondsTo:#,"
- "'aString' respondsTo:#collect:"
+ "
+ 'aString' respondsTo:#+
+ 'aString' respondsTo:#,
+ 'aString' respondsTo:#collect:
+ "
!
respondsToArithmetic
@@ -8134,6 +8601,17 @@
^ self class
!
+speciesForCompare
+ "return a class to determine if two objects can be compared.
+ The fallback here is my species; only redefined by some timestamp classes.
+ FIXME: not all classes (actually currently only one) use this in their #= method
+ (i.e. it needs to be done eg in Dictionary as well)"
+
+ ^ self species
+
+ "Modified (comment): / 10-10-2018 / 18:22:05 / Claus Gittinger"
+!
+
speciesForCopy
"return a class which is the receiver's class, except for readonly objects,
such as immutable collections.
@@ -8148,7 +8626,6 @@
^ self
! !
-
!Object methodsFor:'secure message sending'!
?:selector
@@ -8195,48 +8672,47 @@
"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: #isXXX: to unknown receivers."
+ Useful to send messages such as: #handlesPointerLeave:inView: to unknown receivers."
^ self perform:aSelector with:arg1 with:arg2 ifNotUnderstood:[false]
+
+ "Modified (comment): / 15-10-2019 / 14:49:33 / Stefan Vogel"
!
perform:aSelector ifNotUnderstood:exceptionBlock
"try to send message aSelector to the receiver.
- If its understood, return the method's returned value,
+ If it's understood, return the method's returned value,
otherwise return the value of the exceptionBlock.
Read this:
Many programmers do an Error-handle to perform a similar
checked-message send. However, this method is more specific,
- in that only errors for the given selector are caught - not any other
+ in that only errors for the given selector and this receiver are caught - not any other
doesNotUnderstand, and especially not any other error."
- |val ok|
-
- MessageNotUnderstood handle:[:ex |
- "/ reject, if the bad message is not the one
- "/ we have sent originally
- (ex selector == aSelector and:[ex receiver == self]) ifFalse:[
- ex reject
- ].
- ] do:[
- val := self perform:aSelector.
- ok := true.
- ].
- ok isNil ifTrue:[
- ^ exceptionBlock value
- ].
- ^ val
+ ^ [
+ self perform:aSelector.
+ ] on:MessageNotUnderstood do:[:ex |
+ "/ reject, if the bad message is not the one
+ "/ we have sent originally
+ (ex selector == aSelector and:[ex receiver == self]) ifFalse:[
+ ex reject
+ ].
+ exceptionBlock value
+ ].
"
1.2345 perform:#foo ifNotUnderstood:['sorry']
1.2345 perform:#sqrt ifNotUnderstood:['sorry']
12345 perform:#sqrt ifNotUnderstood:['sorry']
"
+
+ "Modified: / 15-03-2017 / 17:05:58 / stefan"
+ "Modified (comment): / 03-05-2020 / 13:19:31 / cg"
!
perform:aSelector with:argument ifNotUnderstood:exceptionBlock
"try to send message aSelector to the receiver.
- If its understood, return the method's returned value,
+ If it's understood, return the method's returned value,
otherwise return the value of the exceptionBlock.
Read this:
Many programmers do an Error-handle to perform a similar
@@ -8244,36 +8720,33 @@
in that only errors for the given selector are caught - not any other
doesNotUnderstand, and especially not any other error."
- |val ok|
-
- MessageNotUnderstood handle:[:ex |
- "/ reject, if the bad message is not the one
- "/ we have sent originally
- (ex selector == aSelector and:[ex receiver == self]) ifFalse:[
- ex reject
- ]
- ] do:[
- val := self perform:aSelector with:argument.
- ok := true.
- ].
- ok isNil ifTrue:[
- ^ exceptionBlock value
- ].
- ^ val
+ ^ [
+ self perform:aSelector with:argument.
+ ] on:MessageNotUnderstood do:[:ex |
+ "/ reject, if the bad message is not the one
+ "/ we have sent originally
+ (ex selector == aSelector and:[ex receiver == self]) ifFalse:[
+ ex reject
+ ].
+ exceptionBlock value
+ ].
"
|unknown|
unknown := 4.
- (unknown perform:#- with:2 ifNotUnderstood:['sorry']) printNewline.
+ Transcript showCR:(unknown perform:#- with:2 ifNotUnderstood:['sorry']).
unknown := 'high there'.
- (unknown perform:#- with:2 ifNotUnderstood:['sorry']) printNewline.
- "
+ Transcript showCR:(unknown perform:#- with:2 ifNotUnderstood:['sorry']) printCR.
+ "
+
+ "Modified (comment): / 13-02-2017 / 20:27:41 / cg"
+ "Modified (comment): / 15-03-2017 / 17:08:01 / stefan"
!
perform:aSelector with:arg1 with:arg2 ifNotUnderstood:exceptionBlock
"try to send message aSelector to the receiver.
- If its understood, return the method's returned value,
+ If it's understood, return the method's returned value,
otherwise return the value of the exceptionBlock.
Read this:
Many programmers do an Error-handle to perform a similar
@@ -8281,27 +8754,24 @@
in that only errors for the given selector are caught - not any other
doesNotUnderstand, and especially not any other error."
- |val ok|
-
- MessageNotUnderstood handle:[:ex |
- "/ reject, if the bad message is not the one
- "/ we have sent originally
- (ex selector == aSelector and:[ex receiver == self]) ifFalse:[
- ex reject
- ]
- ] do:[
- val := self perform:aSelector with:arg1 with:arg2.
- ok := true.
- ].
- ok isNil ifTrue:[
- ^ exceptionBlock value
- ].
- ^ val
+ ^ [
+ self perform:aSelector with:arg1 with:arg2.
+ ] on:MessageNotUnderstood do:[:ex |
+ "/ reject, if the bad message is not the one
+ "/ we have sent originally
+ (ex selector == aSelector and:[ex receiver == self]) ifFalse:[
+ ex reject
+ ].
+ exceptionBlock value
+ ].
+
+ "Modified (comment): / 13-02-2017 / 20:27:44 / cg"
+ "Modified: / 15-03-2017 / 17:09:12 / stefan"
!
perform:aSelector withArguments:argumentArray ifNotUnderstood:exceptionBlock
"try to send message aSelector to the receiver.
- If its understood, return the method's returned value,
+ If it's understood, return the method's returned value,
otherwise return the value of the exceptionBlock.
Read this:
Many programmers do an Error-handle to perform a similar
@@ -8309,33 +8779,29 @@
in that only errors for the given selector are caught - not any other
doesNotUnderstand, and especially not any other error."
- |val ok|
-
- MessageNotUnderstood handle:[:ex |
- "/ reject, if the bad message is not the one
- "/ we have sent originally.
- (ex selector == aSelector and:[ex receiver == self]) ifFalse:[
- ex reject
- ]
- ] do:[
- val := self perform:aSelector withArguments:argumentArray.
- ok := true.
- ].
- ok isNil ifTrue:[
- ^ exceptionBlock value
- ].
- ^ val
+ ^ [
+ self perform:aSelector withArguments:argumentArray.
+ ] on:MessageNotUnderstood do:[:ex |
+ "/ reject, if the bad message is not the one
+ "/ we have sent originally
+ (ex selector == aSelector and:[ex receiver == self]) ifFalse:[
+ ex reject
+ ].
+ exceptionBlock value
+ ].
"
|unknown|
unknown := 4.
- (unknown perform:#- withArguments:#(2) ifNotUnderstood:['sorry']) printNewline.
+ Transcript showCR:(unknown perform:#- withArguments:#(2) ifNotUnderstood:['sorry']).
unknown := 'high there'.
- (unknown perform:#- withArguments:#(2) ifNotUnderstood:['sorry']) printNewline.
- "
-
- "Modified: 27.3.1997 / 14:13:16 / cg"
+ Transcript showCR:(unknown perform:#- withArguments:#(2) ifNotUnderstood:['sorry']).
+ "
+
+ "Modified: / 27-03-1997 / 14:13:16 / cg"
+ "Modified (comment): / 13-02-2017 / 20:27:46 / cg"
+ "Modified: / 15-03-2017 / 17:10:27 / stefan"
! !
!Object methodsFor:'signal constants'!
@@ -8754,9 +9220,153 @@
"
! !
+!Object methodsFor:'splitting & joining'!
+
+split:aSequenceableCollection
+ "treating the receiver as a splitter,
+ split aSequenceableCollection accordingly and return a collection of fragments."
+
+ | result |
+
+ result := OrderedCollection new:(aSequenceableCollection size // 2).
+ self split:aSequenceableCollection do:[:item |
+ result add:item
+ ].
+ ^ result
+
+ "
+ 0 split:#(1 2 3 0 4 5 6 0 7 8 9)
+ Character space split: 'hello world'
+ ' ' split: 'hello world'
+
+ $a split:'abacadae'
+ 'aa' split:'abaacaadaae'
+ [:ch | ch == $a] split:'abaacaadaae'
+ ('a+' asRegex) split:'abaacaadaae'
+ "
+
+ "Created: / 13-07-2017 / 17:23:55 / cg"
+ "Modified (comment): / 30-07-2018 / 08:59:28 / Stefan Vogel"
+!
+
+split:aCollection do:aBlock
+ "treating the receiver as a splitter,
+ split aSequenceableCollection accordingly and evaluate aBlock for each fragment."
+
+ self split:aCollection indicesDo:[:start :stop |
+ aBlock value:(aCollection copyFrom:start to:stop)
+ ].
+
+ "
+ ' ' split: 'hello world' do: [:frag | Transcript showCR:frag ]
+ "
+
+ "Created: / 13-07-2017 / 16:43:28 / cg"
+ "Modified (comment): / 13-07-2017 / 18:11:53 / cg"
+!
+
+split:aCollection indicesDo:aTwoArgBlock
+ "treating the receiver as a splitter,
+ split aSequenceableCollection accordingly and evaluate aBlock for each pair of start-
+ and stop index."
+
+ |position oldPosition|
+
+ position := 1.
+ oldPosition := position.
+ position := aCollection indexOf:self startingAt:position.
+ [position ~~ 0] whileTrue:[
+ aTwoArgBlock value:oldPosition value:position-1.
+ position := position + 1.
+ oldPosition := position.
+ position := aCollection indexOf:self startingAt:position.
+ ].
+ aTwoArgBlock value:oldPosition value:aCollection size
+
+ "
+ 1 split:#(10 1 20 30 40 1 50 60 1 70) do: [:frag | Transcript showCR:frag ]
+ 1 split:#(10 1 20 30 40 1 50 60 1 70) indicesDo: [:start :stop | Transcript show:start; show:' to '; showCR:stop ]
+
+ nil split:#(10 nil 20 30 40 nil 50 60 nil 70) do: [:frag | Transcript showCR:frag ]
+ nil split:#(10 nil 20 30 40 nil 50 60 nil 70) indicesDo: [:start :stop | Transcript show:start; show:' to '; showCR:stop ]
+ "
+
+ "Created: / 13-07-2017 / 18:12:34 / cg"
+ "Modified: / 30-07-2018 / 09:02:13 / Stefan Vogel"
+!
+
+splitFirstIn:aCollection do:aTwoArgBlock
+ "treating the receiver as a splitter,
+ split aSequenceableCollection accordingly at my first encounter
+ and evaluate aBlock for the two parts (left and right).
+ If the splitter is not encountered, the block is invoked with nil as right part
+ (notice, that if the splitter is encountered at the end, but there are not more
+ elements, then the right part will be an empty collection)"
+
+ |firstEncounter gotFirst|
+
+ firstEncounter := nil.
+ gotFirst := false.
+ self split:aCollection indicesDo:[:start :stop |
+ gotFirst ifTrue:[
+ aTwoArgBlock value:firstEncounter value:(aCollection copyFrom:start).
+ ^ self
+ ].
+ gotFirst := true.
+ firstEncounter := (aCollection copyFrom:start to:stop)
+ ].
+ aTwoArgBlock value:aCollection value:nil.
+
+ "
+ ' '
+ splitFirstIn: 'hello world and more to come'
+ do: [:left :right | Transcript showCR:left; showCR:right ]
+ "
+ "
+ 123
+ splitFirstIn: #(true false 123 1 2 3 4 123 4 5 6)
+ do: [:left :right | Transcript showCR:left; showCR:right ]
+ "
+ "
+ ' '
+ splitFirstIn: 'helloworld'
+ do: [:left :right | Transcript showCR:left; showCR:right ]
+ "
+ "
+ ' '
+ splitFirstIn: 'helloworld '
+ do: [:left :right | Transcript showCR:left; showCR:right ]
+ "
+! !
!Object methodsFor:'synchronized evaluation'!
+ensureSynchronizationSemaphore
+ "return the synchronizationSemaphore.
+ Create it save if no one exists yet"
+
+ |sema wasBlocked|
+
+ "/ instead of using another lock to assign the lock,
+ "/ we block interrupts for a short time period. This is faster.
+ wasBlocked := OperatingSystem blockInterrupts.
+
+ sema := self synchronizationSemaphore.
+ sema isNil ifTrue:[
+ sema := RecursionLock name:self className.
+ self synchronizationSemaphore:sema.
+ ].
+
+ wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
+ ^ sema
+
+ "
+ Object ensureSynchronizationSemaphore.
+ "
+
+ "Created: / 06-02-2020 / 18:36:56 / Stefan Vogel"
+!
+
freeSynchronizationSemaphore
"free synchronizationSemaphore. May be used, to save memory when
an object is no longer used synchronized."
@@ -8781,7 +9391,8 @@
synchronizationSemaphore
"return the synchronization semaphore for myself.
- subclasses may redefine"
+ subclasses may redefine.
+ Return nil, if none has been allocated yet."
^ SynchronizationSemaphores at:self ifAbsent:[].
@@ -8789,37 +9400,36 @@
self synchronizationSemaphore
"
- "Modified: 28.1.1997 / 19:47:09 / stefan"
-!
-
-synchronizationSemaphore:aSemaphore
+ "Modified: / 28-01-1997 / 19:47:09 / stefan"
+ "Modified (comment): / 06-02-2020 / 18:39:43 / Stefan Vogel"
+!
+
+synchronizationSemaphore:aSemaphoreOrBetterARecursionLock
"set the synchronisationSemaphore for myself.
subclasses may redefine this method"
- aSemaphore isNil ifTrue:[
- "/ remove Semaphore
- SynchronizationSemaphores removeKey:self ifAbsent:nil.
+ aSemaphoreOrBetterARecursionLock isNil ifTrue:[
+ "/ remove Semaphore
+ SynchronizationSemaphores removeKey:self ifAbsent:nil.
] ifFalse:[
- SynchronizationSemaphores at:self put:aSemaphore.
- ].
-
- "Modified: 28.1.1997 / 19:37:48 / stefan"
+ SynchronizationSemaphores at:self put:aSemaphoreOrBetterARecursionLock.
+ ].
+
+ "Modified: / 28-01-1997 / 19:37:48 / stefan"
+ "Modified (format): / 01-08-2018 / 13:23:47 / Claus Gittinger"
!
synchronized:aBlock
- "evaluate aBlock synchronized, i.e. use a monitor for this object"
-
- |sema wasBlocked|
-
- wasBlocked := OperatingSystem blockInterrupts.
+ "evaluate aBlock synchronized, i.e. use a monitor for this object;
+ return the value from aBlock"
+
+ |sema|
sema := self synchronizationSemaphore.
sema isNil ifTrue:[
- sema := RecursionLock new name:self className.
- self synchronizationSemaphore:sema.
- ].
-
- wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
+ sema := self ensureSynchronizationSemaphore.
+ ].
+
^ sema critical:aBlock.
"
@@ -8827,9 +9437,29 @@
[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"
+ "Created: / 28-01-1997 / 17:52:56 / stefan"
+ "Modified: / 20-02-1997 / 09:43:35 / stefan"
+ "Modified: / 09-08-2017 / 11:55:40 / cg"
+ "Modified: / 29-05-2018 / 20:06:40 / Claus Gittinger"
+ "Modified (comment): / 07-06-2019 / 13:50:38 / Claus Gittinger"
+ "Modified: / 06-02-2020 / 18:38:12 / Stefan Vogel"
+!
+
+synchronized:aBlock timeoutMs:timeoutMs ifBlocking:blockingBlock
+ "like synchronized:, but do not block if the lock cannot be acquired
+ within timeoutMs milliseconds.
+ Instead, return the value of blockingBlock."
+
+ |sema|
+
+ sema := self synchronizationSemaphore.
+ sema isNil ifTrue:[
+ sema := self ensureSynchronizationSemaphore.
+ ].
+
+ ^ sema critical:aBlock timeoutMs:timeoutMs ifBlocking:blockingBlock.
+
+ "Created: / 06-02-2020 / 18:43:00 / Stefan Vogel"
! !
!Object methodsFor:'system primitives'!
@@ -8951,88 +9581,89 @@
%{
#ifdef __SCHTEAM__
ok = (self.isSTInstance() && otherClass.isSTInstance())
- ? STObject.True : STObject.False;
+ ? STObject.True : STObject.False;
#else
{
- OBJ other = otherClass;
-
- if (__isNonNilObject(self)
- && __isNonNilObject(other)
- && (other != UndefinedObject)
- && (other != SmallInteger)) {
- ok = true;
- } else {
- ok = false;
- }
+ OBJ other = otherClass;
+
+ if (__isNonNilObject(self)
+ && __isNonNilObject(other)
+ && (other != UndefinedObject)
+ && (other != SmallInteger)) {
+ ok = true;
+ } else {
+ ok = false;
+ }
}
#endif /* not SCHTEAM */
%}.
ok == true ifTrue:[
- ok := false.
- myClass := self class.
- myClass == otherClass ifTrue:[
- "nothing to change"
- ^ self.
- ].
- 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 isBitsExtended and:[otherClass isBitsExtended]) ifTrue:[
- ok := true
- ]
- ]
- ]
+ ok := false.
+ myClass := self class.
+ myClass == otherClass ifTrue:[
+ "nothing to change"
+ ^ self.
+ ].
+ 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 isBitsExtended and:[otherClass isBitsExtended]) ifTrue:[
+ ok := true
+ ]
+ ]
+ ]
].
ok == true ifTrue:[
- "now, change the receiver's class ..."
+ "now, change the receiver's class ..."
%{
#ifdef __SCHTEAM__
- ((STInstance)self).clazz = (STClass)otherClass;
- return __c__._RETURN(self);
+ ((STInstance)self).clazz = (STClass)otherClass;
+ return __c__._RETURN(self);
#else
- {
- OBJ me = self;
-
- // gcc4.4 does not like this:
- // __qClass(me) = otherClass;
- __objPtr(me)->o_class = (CLASS_OBJ)otherClass;
- __STORE(me, otherClass);
- RETURN (me);
- }
+ {
+ OBJ me = self;
+
+ // gcc4.4 does not like this:
+ // __qClass(me) = otherClass;
+ __objPtr(me)->o_class = (CLASS_OBJ)otherClass;
+ __STORE(me, otherClass);
+ RETURN (me);
+ }
#endif /* not SCHTEAM */
%}.
+ 0.
].
"
@@ -9080,7 +9711,7 @@
int nInsts, i;
if (! __isNonNilObject(self)) {
- RETURN (false);
+ RETURN (false);
}
/*
@@ -9089,34 +9720,34 @@
* 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);
- }
- }
+ if ((__qSpace(self) <= OLDSPACE) && !__isRemembered(self)) {
+ int spc;
+
+ if (((spc = __qSpace(anObject)) == NEWSPACE) || (spc == SURVSPACE)) {
+ RETURN (false);
+ }
+ }
}
cls = __qClass(self);
flags = __ClassInstPtr(cls)->c_flags;
if (((INT)flags & __MASKSMALLINT(ARRAYMASK)) == __MASKSMALLINT(POINTERARRAY)) {
- nInsts = __BYTES2OBJS__(__qSize(self) - OHDR_SIZE);
+ nInsts = __BYTES2OBJS__(__qSize(self) - OHDR_SIZE);
} else {
- nInsts = __intVal(__ClassInstPtr(cls)->c_ninstvars);
+ nInsts = __intVal(__ClassInstPtr(cls)->c_ninstvars);
}
if (! nInsts) {
- RETURN (false);
+ RETURN (false);
}
anyChange = false;
for (i=0; i<nInsts; i++) {
- if (__InstPtr(self)->i_instvars[i] == anObject) {
- __InstPtr(self)->i_instvars[i] = newRef;
- __STORE(self, newRef);
- // __dumpObject__(self, __LINE__);
- anyChange = true;
- }
+ if (__InstPtr(self)->i_instvars[i] == anObject) {
+ __InstPtr(self)->i_instvars[i] = newRef;
+ __STORE(self, newRef);
+ // __dumpObject__(self, __LINE__,__FILE__);
+ anyChange = true;
+ }
}
RETURN (anyChange);
%}.
@@ -9251,39 +9882,42 @@
"return the value of the first arg, if I am nil,
the result from evaluating the 2nd argument, if I am not nil.
Notice:
- This method is open coded (inlined) by the compiler(s)
- - redefining it may not work as expected."
-
- (notNilBlockOrValue isBlock and:[notNilBlockOrValue argumentCount == 1]) ifTrue:[
- ^ notNilBlockOrValue value:self.
+ This method is open coded (inlined) by the compiler(s)
+ - redefining it may not work as expected."
+
+ (notNilBlockOrValue isBlockWithArgumentCount:1) ifTrue:[
+ ^ notNilBlockOrValue value:self.
].
^ notNilBlockOrValue value
+
+ "Modified: / 18-03-2017 / 19:07:10 / stefan"
!
ifNotNil:aBlockOrValue
"return myself if nil, or the result from evaluating the argument,
if I am not nil.
Notice:
- This method is open coded (inlined) by the compiler(s)
- - redefining it may not work as expected."
-
- (aBlockOrValue isBlock and:[aBlockOrValue argumentCount == 1]) ifTrue:[
- ^ aBlockOrValue value:self.
- ].
- ^ aBlockOrValue value
+ This method is open coded (inlined) by the compiler(s)
+ - redefining it may not work as expected."
+
+ ^ aBlockOrValue valueWithOptionalArgument:self
+
+ "Modified: / 22-03-2018 / 11:39:24 / stefan"
!
ifNotNil:notNilBlockOrValue ifNil:nilBlockOrValue
"return the value of the 2nd arg, if I am nil,
the result from evaluating the 1st argument, if I am not nil.
Notice:
- This method is open coded (inlined) by the compiler(s)
- - redefining it may not work as expected."
-
- (notNilBlockOrValue isBlock and:[notNilBlockOrValue argumentCount == 1]) ifTrue:[
- ^ notNilBlockOrValue value:self.
+ This method is open coded (inlined) by the compiler(s)
+ - redefining it may not work as expected."
+
+ (notNilBlockOrValue isBlockWithArgumentCount:1) ifTrue:[
+ ^ notNilBlockOrValue value:self.
].
^ notNilBlockOrValue value
+
+ "Modified: / 18-03-2017 / 18:26:29 / stefan"
!
ifNotNilDo:aBlock
@@ -9293,6 +9927,13 @@
^ aBlock value:self
!
+isApplicationModel
+ "return true if the receiver is some kind of applicationModel;
+ false is returned here - the method is only redefined in ApplicationModel."
+
+ ^ false
+!
+
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."
@@ -9323,6 +9964,22 @@
^ false
!
+isBlockOrMessageSend
+ "return true if the receiver is some kind of block;
+ false returned here - the method is only redefined in Block."
+
+ ^ self isBlock
+!
+
+isBlockWithArgumentCount:count
+ "return true if the receiver is some kind of block;
+ false returned here - the method is only redefined in Block."
+
+ ^ false
+
+ "Created: / 18-03-2017 / 18:07:26 / stefan"
+!
+
isBoolean
"return true if the receiver is a boolean;
false is returned here - the method is only redefined in Boolean."
@@ -9331,15 +9988,20 @@
!
isBridgeProxy
- "answer true, if I am a proxy object for a bridged remote object"
-
- "do not move this into the bridge-package;
- it is called by some others, to prevent remote messages from implements/respondsTo, etc.
- which are called from inspectors and debuggers"
-
- ^ false
-
- "Modified (comment): / 25-05-2018 / 12:45:42 / Claus Gittinger"
+ "answer true, if I am a proxy object for a bridged remote object.
+ Do NOT move this into the bridge package;
+ it is required to be understood even without a bridge being loaded
+ (debugger, inspectors, etc. may use it)"
+
+ ^ false
+
+ "Modified (comment): / 28-05-2018 / 16:20:10 / Claus Gittinger"
+!
+
+isBridgedPythonClass
+ "return true if this is a Python class"
+
+ ^ false
!
isByteArray
@@ -9351,10 +10013,8 @@
isByteCollection
"return true if the receiver is some kind of byte collection,
- i.e. #at: and #at:put: accesses a byte. This is different from 'self class isBytes',
- since e.g. in BitArray single bits are accessed, but it is implemented as variableBytes class.
-
- false is returned here - the method is only redefined in UninterpretedBytes."
+ This is different from 'self class isBytes',
+ since e.g. in BitArray single bits are accessed, but it is implemented as variableBytes class."
^ false
!
@@ -9409,6 +10069,22 @@
^ false
!
+isEOF
+ "Return true if the receiver is the EOF token.
+ This is (and should only be) redefined in EOFObject,
+ for the one and only instance of it, void"
+
+ ^ false
+
+ "
+ nil isEOF
+ void isEOF
+ EOF isEOF
+ "
+
+ "Created: / 20-12-2018 / 17:00:58 / Claus Gittinger"
+!
+
isEmptyOrNil
"return true if I am nil or an empty collection - return false here.
(from Squeak)"
@@ -9513,6 +10189,15 @@
"Modified: / 14.11.2001 / 14:57:46 / cg"
!
+isFloatArray
+ "return true if the receiver has float elements.
+ These are Float, Double- and HalfFloat arrays"
+
+ ^ false
+
+ "Created: / 02-03-2019 / 23:14:46 / Claus Gittinger"
+!
+
isForm
"return true if the receiver is some kind of form;
false is returned here - the method is only redefined in Form."
@@ -9550,12 +10235,20 @@
isImmediate
"return true if I am an immediate object
i.e. I am represented in the pointer itself and
- no real object header/storage is used me.
+ no real object header/storage is used by me.
(currently, only SmallIntegers, some characters and nil return true)"
^ self class hasImmediateInstances
- "Created: 3.6.1997 / 12:00:18 / cg"
+ "Created: / 03-06-1997 / 12:00:18 / cg"
+ "Modified (comment): / 27-05-2019 / 15:38:38 / Claus Gittinger"
+!
+
+isInlineObject
+ "return true if the receiver is some kind of inline object;
+ false is returned here - the method is only redefined in InlineObject."
+
+ ^ false
!
isInteger
@@ -9565,6 +10258,15 @@
^ false
!
+isIntegerArray
+ "return true if the receiver has integer elements.
+ These are Byte- and Integer arrays; both signed and unsigned"
+
+ ^ false
+
+ "Created: / 02-03-2019 / 23:09:54 / Claus Gittinger"
+!
+
isInterestConverter
"return true if I am a kind of interest forwarder"
@@ -9573,11 +10275,12 @@
isInternalByteStream
"return true, if the receiver is some kind of Stream for reading bytes;
- false is returned here - the method is only redefined in PeekableStream."
+ false is returned here - the method is only redefined in PositionableStream."
^false
"Created: / 30-05-2007 / 16:15:33 / cg"
+ "Modified (comment): / 22-10-2019 / 17:06:07 / Stefan Vogel"
!
isJavaClass
@@ -9658,21 +10361,33 @@
"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/protocol 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.
+ use of this to check objects for certain attributes/protocol 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.
+ 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.
+
+ Advice3:
+ It is usually better to ask for a feature being present,
+ or an operation to be supported, instead of asking for being something or someone.
+ For example, it is much better to ask for #respondsToArithmetic,
+ instead of asking for #isNumber,
+ Because other things (characters, matrices, physicak/mathematical objects
+ might also be able to do arithmetic, although not being numbers.
+ Thus you'd better implement such queries and use those to make your code
+ more flexble and easier to reuse in the future.
+
+ Having sayd all that, and being warned, here is the implementation:
"
%{ /* NOCONTEXT */
@@ -9680,10 +10395,10 @@
thisClass = __Class(self);
while (thisClass != nil) {
- if (thisClass == aClass) {
- RETURN ( true );
- }
- thisClass = __ClassInstPtr(thisClass)->c_superclass;
+ if (thisClass == aClass) {
+ RETURN ( true );
+ }
+ thisClass = __ClassInstPtr(thisClass)->c_superclass;
}
RETURN ( false );
%}
@@ -9698,6 +10413,68 @@
"/ ].
"/ ^ false
"/
+
+ "Modified: / 08-06-2019 / 16:47:00 / Claus Gittinger"
+!
+
+isKindOf:class1 orOf:class2
+ "return true if the receiver is an instance of class1 or of class2
+ or one of either subclasses, false otherwise.
+ Advice:
+ use of this to check objects for certain attributes/protocol 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.
+
+ Advice3:
+ It is usually better to ask for a feature being present,
+ or an operation to be supported, instead of asking for being something or someone.
+ For example, it is much better to ask for #respondsToArithmetic,
+ instead of asking for #isNumber,
+ Because other things (characters, matrices, physicak/mathematical objects
+ might also be able to do arithmetic, although not being numbers.
+ Thus you'd better implement such queries and use those to make your code
+ more flexble and easier to reuse in the future.
+
+ Having sayd all that, and being warned, here is the implementation:
+ "
+
+%{ /* NOCONTEXT */
+ register OBJ thisClass;
+
+ thisClass = __Class(self);
+ while (thisClass != nil) {
+ if ((thisClass == class1) || (thisClass == class2)) {
+ RETURN ( true );
+ }
+ thisClass = __ClassInstPtr(thisClass)->c_superclass;
+ }
+ RETURN ( false );
+%}
+
+"/
+"/ the above code is equivalent to:
+"/
+"/ thisClass := self class.
+"/ [thisClass notNil] whileTrue:[
+"/ ((thisClass == class1) or:[thisClass == class2]) ifTrue:[^ true].
+"/ thisClass := thisClass superclass
+"/ ].
+"/ ^ false
+"/
+
+ "Created: / 08-06-2019 / 16:46:36 / Claus Gittinger"
!
isLabelAndIcon
@@ -9741,21 +10518,32 @@
^ false
!
+isLongFloat
+ "return true if the receiver is a long floating point number (iee extended precision);
+ false is returned here."
+
+ ^ 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/protocol 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.
+ use of this to check objects for certain attributes/protocol 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).
+ Read more on this in #isKindOf:
+
+ Using #isMemberOf: is considered VERY BAD STYLE.
+
Notice:
- This method is open coded (inlined) by the compiler(s)
- - redefining it may not work as expected."
+ This method is open coded (inlined) by the compiler(s)
+ - redefining it may not work as expected."
^ (self class) == aClass
+
+ "Modified (comment): / 08-06-2019 / 16:50:42 / Claus Gittinger"
!
isMenuItem
@@ -9823,9 +10611,10 @@
<resource:#obsolete>
- ^ false
-
- "Modified: / 13.11.2001 / 13:28:06 / cg"
+ ^ self isEmptyOrNil
+
+ "Modified: / 13-11-2001 / 13:28:06 / cg"
+ "Modified: / 20-03-2018 / 15:27:42 / stefan"
!
isNonByteCollection
@@ -9851,9 +10640,10 @@
the receiver is definitely not nil here, so unconditionally return true."
self obsoleteMethodWarning:'use #notNil'.
- ^ true
+ ^ self notNil
"Created: / 26-10-2014 / 01:30:15 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+ "Modified: / 20-03-2018 / 15:26:52 / stefan"
!
isNumber
@@ -9867,6 +10657,16 @@
^ false
!
+isObjectiveCObject
+ "return true if the receiver is a proxy for an
+ objectiveC object.
+ False is returned here."
+
+ ^ false
+
+ "Created: / 04-03-2019 / 11:45:20 / Claus Gittinger"
+!
+
isOrderedCollection
"return true if the receiver is some kind of ordered collection (or list etc);
false is returned here - the method is only redefined in OrderedCollection."
@@ -9929,6 +10729,13 @@
"Created: / 21-11-2010 / 11:15:46 / cg"
!
+isQuadFloat
+ "return true if the receiver is a quad floating point number (iee quad precision);
+ false is returned here."
+
+ ^ false
+!
+
isRealNameSpace
"return true if the receiver is a NameSpace, but not Smalltalk (which is also a class).
False is returned here - the method is redefined in Namespace and Smalltalk."
@@ -9945,21 +10752,16 @@
^ 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;
+ "return true if the receiver is sequenceable;
+ i.e. if its elements are accessible by an integer index,
+ and support the do:-protocol.
false is returned here - the method is only redefined in SequenceableCollection."
^ false
+
+ "Modified (comment): / 03-03-2019 / 00:09:00 / Claus Gittinger"
+ "Modified (comment): / 26-05-2020 / 17:11:28 / cg"
!
isSequenceableCollection
@@ -9980,6 +10782,22 @@
^ false
!
+isShortFloat
+ "return true if the receiver is a short floating point number (iee single precision);
+ false is returned here."
+
+ ^ false
+!
+
+isSingleByteCollection
+ "return true, if the receiver has access methods for bytes;
+ i.e. #at: and #at:put: accesses a byte and are equivalent to #byteAt: and byteAt:put:
+ and #replaceFrom:to: is equivalent to #replaceBytesFrom:to:.
+ This is different from 'self class isBytes'."
+
+ ^ false
+!
+
isSingleByteString
"return true if the receiver is a string or immutableString.
false is returned here - the method is only redefined in String.
@@ -10190,9 +11008,7 @@
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."
- ActivityNotification isHandled ifTrue:[
- ^ ActivityNotification raiseRequestWith:self errorString:aString
- ].
+ ^ ActivityNotification raiseRequestWith:self errorString:aString
"
nil activityNotification:'hello there'
@@ -10201,16 +11017,17 @@
"
ActivityNotification handle:[:ex |
- ex errorString printCR.
- ex proceed.
+ ex errorString printCR.
+ ex proceed.
] do:[
- 'hello' printCR.
- self activityNotification:'doing some long time computation'.
- 'world' printCR.
+ 'hello' printCR.
+ self activityNotification:'doing some long time computation'.
+ 'world' printCR.
]
"
- "Modified: 16.12.1995 / 18:23:42 / cg"
+ "Modified: / 16-12-1995 / 18:23:42 / cg"
+ "Modified (comment): / 05-10-2018 / 17:42:02 / Claus Gittinger"
!
confirm:aString
@@ -10274,10 +11091,10 @@
by handling the UserConfirmation."
^ UserConfirmation new
- defaultAnswer:defaultAnswerOrNil;
- canCancel:true;
- errorString:aString;
- raiseRequest
+ defaultAnswer:defaultAnswerOrNil;
+ canCancel:true;
+ messageText:aString;
+ raiseRequest
"
nil confirmWithCancel:'hello' defaultAnswer:true
@@ -10326,141 +11143,141 @@
|currentScreen con sender action boxLabels boxValues default s|
Smalltalk isInitialized ifFalse:[
- 'errorNotification: ' print. aString printCR.
- con := aContext ? thisContext methodHome.
- con sender printAllLevels:10.
- ^ nil
+ 'errorNotification: ' print. aString printCR.
+ con := aContext ? thisContext methodHome.
+ con sender printAllLevels:10.
+ ^ nil
].
(Dialog isNil
or:[Screen isNil
or:[(currentScreen := Screen current) isNil
or:[currentScreen isOpen not]]]) ifTrue:[
- "
- on systems without GUI, simply show
- the message on the Transcript and abort.
- "
- Transcript showCR:aString.
- AbortOperationRequest raise.
- "not reached"
- ^ nil
+ "
+ on systems without GUI, simply show
+ the message on the Transcript and abort.
+ "
+ Transcript showCR:aString.
+ AbortOperationRequest raise.
+ "not reached"
+ ^ nil
].
Processor activeProcessIsSystemProcess ifTrue:[
- action := #debug.
- sender := aContext.
- Debugger isNil ifTrue:[
- '****************** Caught Error while in SystemProcess ****************' errorPrintCR.
- aString errorPrintCR.
- Exception handle:[:ex |
- 'Caught recursive error while printing backtrace:' errorPrintCR.
- ex description errorPrintCR.
- ] do:[
- thisContext fullPrintAll.
- ].
- action := #abort.
- ].
+ action := #debug.
+ sender := aContext.
+ Debugger isNil ifTrue:[
+ '****************** Caught Error while in SystemProcess ****************' errorPrintCR.
+ aString errorPrintCR.
+ Exception handle:[:ex |
+ 'Caught recursive error while printing backtrace:' errorPrintCR.
+ ex description errorPrintCR.
+ ] do:[
+ thisContext fullPrintAll.
+ ].
+ action := #abort.
+ ].
] ifFalse:[
- Dialog autoload. "in case it is autoloaded"
-
- Error handle:[:ex |
- "/ a recursive error - quickly enter debugger
- "/ this happened, when I corrupted the Dialog class ...
- ('Object [error]: ' , ex description , ' caught in errorNotification') errorPrintCR.
- action := #debug.
- ex return.
- ] do:[ |s|
- sender := aContext.
- sender isNil ifTrue:[
- sender := thisContext methodHome sender.
- ].
- con := sender.
-
- "/ skip intermediate (signal & exception) contexts
- DebugView notNil ifTrue:[
- con := DebugView interestingContextFrom:sender
- ].
-
- "/ show the first few contexts
-
- s := CharacterWriteStream with:aString.
- s cr; cr.
- s nextPutLine:'Calling Chain:'.
- s nextPutLine:'--------------------------------------------------------------'.
- 1 to:25 do:[:n |
- con notNil ifTrue:[
- con printOn:s.
- s cr.
- con := con sender
- ]
- ].
-
- mayProceed ifTrue:[
- boxLabels := #('Proceed').
- boxValues := #(#proceed).
- default := #proceed.
- ] ifFalse:[
- boxLabels := #().
- boxValues := #().
- ].
-
- AbortOperationRequest isHandled ifTrue:[
- default := #abort.
- boxLabels := boxLabels , #('Abort').
- boxValues := boxValues , #(#abort).
- AbortAllOperationRequest isHandled ifTrue:[
- boxLabels := boxLabels , #('Abort All').
- boxValues := boxValues , #(#abortAll).
- ].
- true "allowDebug" ifTrue:[
- boxLabels := boxLabels , #('Copy Trace and Abort').
- boxValues := boxValues , #(#copyAndAbort).
- ].
- ] ifFalse:[
- mayProceed "and:[allowDebug]" ifTrue:[
- boxLabels := boxLabels , #('Copy Trace and Proceed').
- boxValues := boxValues , #(#copyAndProceed).
- ].
- ].
-
- (allowDebug and:[Debugger notNil]) ifTrue:[
- boxLabels := boxLabels , #('Debug').
- boxValues := boxValues , #(#debug).
- default := #debug.
- ].
-
- action := Dialog
- choose:s contents
- label:('Exception [' , Processor activeProcess nameOrId , ']')
- image:WarningBox errorIconBitmap
- labels:boxLabels
- values:boxValues
- default:default
- onCancel:nil.
- ].
+ Dialog autoload. "in case it is autoloaded"
+
+ Error handle:[:ex |
+ "/ a recursive error - quickly enter debugger
+ "/ this happened, when I corrupted the Dialog class ...
+ ('Object [error]: ' , ex description , ' caught in errorNotification') errorPrintCR.
+ action := #debug.
+ ex return.
+ ] do:[ |s|
+ sender := aContext.
+ sender isNil ifTrue:[
+ sender := thisContext methodHome sender.
+ ].
+ con := sender.
+
+ "/ skip intermediate (signal & exception) contexts
+ DebugView notNil ifTrue:[
+ con := DebugView interestingContextFrom:sender
+ ].
+
+ "/ show the first few contexts
+
+ s := CharacterWriteStream with:aString.
+ s cr; cr.
+ s nextPutLine:'Calling Chain:'.
+ s nextPutLine:'--------------------------------------------------------------'.
+ 1 to:25 do:[:n |
+ con notNil ifTrue:[
+ con printOn:s.
+ s cr.
+ con := con sender
+ ]
+ ].
+
+ mayProceed ifTrue:[
+ boxLabels := #('Proceed').
+ boxValues := #(#proceed).
+ default := #proceed.
+ ] ifFalse:[
+ boxLabels := #().
+ boxValues := #().
+ ].
+
+ AbortOperationRequest isHandled ifTrue:[
+ default := #abort.
+ boxLabels := boxLabels , #('Abort').
+ boxValues := boxValues , #(#abort).
+ AbortAllOperationRequest isHandled ifTrue:[
+ boxLabels := boxLabels , #('Abort All').
+ boxValues := boxValues , #(#abortAll).
+ ].
+ true "allowDebug" ifTrue:[
+ boxLabels := boxLabels , #('Copy Error Details to Clipboard and Abort').
+ boxValues := boxValues , #(#copyAndAbort).
+ ].
+ ] ifFalse:[
+ mayProceed "and:[allowDebug]" ifTrue:[
+ boxLabels := boxLabels , #('Copy Error Details to Clipboard and Proceed').
+ boxValues := boxValues , #(#copyAndProceed).
+ ].
+ ].
+
+ (allowDebug and:[Debugger notNil]) ifTrue:[
+ boxLabels := boxLabels , #('Debug').
+ boxValues := boxValues , #(#debug).
+ default := #debug.
+ ].
+
+ action := Dialog
+ choose:s contents
+ label:('Exception [' , Processor activeProcess nameOrId , ']')
+ image:WarningBox errorIconBitmap
+ labels:boxLabels
+ values:boxValues
+ default:default
+ onCancel:nil.
+ ].
].
action == #debug ifTrue:[
- ^ Debugger enter:sender withMessage:aString mayProceed:mayProceed
+ ^ Debugger enter:sender withMessage:aString mayProceed:mayProceed
].
action == #proceed ifTrue:[
- ^ nil.
+ ^ nil.
].
(action == #copyAndProceed
- or:[action == #copyAndAbort]) ifTrue:[
- s := '' writeStream.
- Exception handle:[:ex |
- 'Caught recursive error while printing backtrace' errorPrintCR.
- ] do:[
- sender fullPrintAllOn:s.
- ].
- currentScreen rootView setClipboardText:s contents.
- action == #copyAndProceed ifTrue:[
- ^ nil
- ].
+ or:[action == #copyAndAbort]) ifTrue:[
+ s := '' writeStream.
+ Exception handle:[:ex |
+ 'Caught recursive error while printing backtrace' errorPrintCR.
+ ] do:[
+ sender fullPrintAllOn:s.
+ ].
+ currentScreen rootView setClipboardText:s contents.
+ action == #copyAndProceed ifTrue:[
+ ^ nil
+ ].
].
(action == #abortAll) ifTrue:[
- AbortAllOperationRequest raise
+ AbortAllOperationRequest raise
].
AbortOperationRequest raise.
@@ -10474,6 +11291,7 @@
"Created: / 17-08-1998 / 10:09:26 / cg"
"Modified: / 08-08-2011 / 11:26:17 / sr"
"Modified: / 05-12-2011 / 03:50:59 / cg"
+ "Modified: / 06-11-2018 / 18:05:17 / Stefan Vogel"
!
information:aString
@@ -10505,6 +11323,17 @@
"Modified: 24.11.1995 / 22:29:49 / cg"
!
+logFacility
+ "the 'log facility';
+ this is used by the Logger both as a prefix to the log message,
+ and maybe (later) used to filter and/or control per-facility log thresholds.
+ The default here is to base the facility on my class"
+
+ ^ self class logFacility
+
+ "Created: / 24-05-2019 / 01:03:49 / Claus Gittinger"
+!
+
notify:aString
"launch a Notifier, telling user something.
Use #information: for ignorable messages.
@@ -10571,9 +11400,6 @@
^ aVisitor visitObject:self with:aParameter
! !
-
-
-
!Object class methodsFor:'documentation'!
version
@@ -10582,11 +11408,6 @@
version_CVS
^ '$Header$'
-!
-
-version_HG
-
- ^ '$Changeset: <not expanded> $'
! !