--- a/Object.st Sat Dec 16 18:17:20 1995 +0100
+++ b/Object.st Sat Dec 16 18:24:21 1995 +0100
@@ -10,20 +10,18 @@
hereby transferred.
"
-Object subclass:#Object
- instanceVariableNames:''
- classVariableNames:'ErrorSignal HaltSignal
- MessageNotUnderstoodSignal UserInterruptSignal
- RecursionInterruptSignal ExceptionInterruptSignal
- SubscriptOutOfBoundsSignal NonIntegerIndexSignal
- NotFoundSignal KeyNotFoundSignal ElementOutOfBoundsSignal
- UserNotificationSignal InformationSignal WarningSignal PrimitiveFailureSignal
- DeepCopyErrorSignal
- AbortSignal
- ErrorRecursion Dependencies
- InfoPrinting ActivityNotificationSignal'
- poolDictionaries:''
- category:'Kernel-Objects'
+nil subclass:#Object
+ instanceVariableNames:''
+ classVariableNames:'ErrorSignal HaltSignal MessageNotUnderstoodSignal
+ UserInterruptSignal RecursionInterruptSignal
+ ExceptionInterruptSignal SubscriptOutOfBoundsSignal
+ NonIntegerIndexSignal NotFoundSignal KeyNotFoundSignal
+ ElementOutOfBoundsSignal UserNotificationSignal InformationSignal
+ WarningSignal PrimitiveFailureSignal DeepCopyErrorSignal
+ AbortSignal ErrorRecursion Dependencies InfoPrinting
+ ActivityNotificationSignal'
+ poolDictionaries:''
+ category:'Kernel-Objects'
!
!Object class methodsFor:'documentation'!
@@ -42,10 +40,6 @@
"
!
-version
- ^ '$Header: /cvs/stx/stx/libbasic/Object.st,v 1.79 1995-12-16 17:17:20 cg Exp $'
-!
-
documentation
"
Object is the superclass of all other classes. Protocol common to
@@ -187,107 +181,13 @@
!Object class methodsFor:'Signal constants'!
-errorSignal
- "return the signal used for error/error: - handling"
-
- ^ ErrorSignal
-!
-
-haltSignal
- "return the signal used for halt/halt: - handling"
-
- ^ HaltSignal
-!
-
-messageNotUnderstoodSignal
- "return the signal used for doesNotUnderstand: - error handling"
-
- ^ MessageNotUnderstoodSignal
-!
-
-privateMethodSignal
- "return the signal used for privateMethod - error handling"
-
- ^ MessageNotUnderstoodSignal
-!
-
-primitiveFailureSignal
- "return the signal used for primitiveFailed - error handling"
-
- ^ PrimitiveFailureSignal
-!
-
-userInterruptSignal
- "return the signal used for ^C interrupts handling"
-
- ^ UserInterruptSignal
-!
-
-recursionInterruptSignal
- "return the signal used for recursion overflow error handling"
-
- ^ RecursionInterruptSignal
-!
-
-exceptionInterruptSignal
- "return the signal used for exception (display errors) error handling"
-
- ^ ExceptionInterruptSignal
-!
-
-subscriptOutOfBoundsSignal
- "return the signal used for subscript error reporting.
- (this signal is used for example when an array is accessed with an
- index less than 1 or greater than the array size)"
-
- ^ SubscriptOutOfBoundsSignal
-!
-
-elementOutOfBoundsSignal
- "return the signal used for element error reporting
- (this signal is used for example when a value not in 0..255 is to
- be put into a bytearray)"
-
- ^ ElementOutOfBoundsSignal
-!
-
-nonIntegerIndexSignal
- "return the signal used for bad subscript error reporting"
-
- ^ NonIntegerIndexSignal
-!
-
-notFoundSignal
- "return the signal used for no element found error reporting"
-
- ^ NotFoundSignal
-!
-
-keyNotFoundSignal
- "return the signal used for no such key error reporting"
-
- ^ KeyNotFoundSignal
-!
-
-userNotificationSignal
- "the parent signal used with information and warnings.
- Handling this allows handling of both information- and warning notifications."
-
- ^ UserNotificationSignal
-!
-
-informationSignal
- "return the signal used for informations.
- A handler for this signal gets all #information: sends"
-
- ^ InformationSignal
-!
-
-warningSignal
- "return the signal used for warnings.
- A handler for this signal gets all #warn: sends"
-
- ^ WarningSignal
+abortSignal
+ "return the signal used to abort user actions. This signal is only
+ raised if cought (by the debugger), and will lead way out of the
+ currently active doIt/printIt or inspectIt. (also some others use
+ this for a save abort)"
+
+ ^ AbortSignal
!
activityNotificationSignal
@@ -305,29 +205,123 @@
^ DeepCopyErrorSignal
!
-abortSignal
- "return the signal used to abort user actions. This signal is only
- raised if cought (by the debugger), and will lead way out of the
- currently active doIt/printIt or inspectIt. (also some others use
- this for a save abort)"
-
- ^ AbortSignal
+elementOutOfBoundsSignal
+ "return the signal used for element error reporting
+ (this signal is used for example when a value not in 0..255 is to
+ be put into a bytearray)"
+
+ ^ ElementOutOfBoundsSignal
+!
+
+errorSignal
+ "return the signal used for error/error: - handling"
+
+ ^ ErrorSignal
+!
+
+exceptionInterruptSignal
+ "return the signal used for exception (display errors) error handling"
+
+ ^ ExceptionInterruptSignal
+!
+
+haltSignal
+ "return the signal used for halt/halt: - handling"
+
+ ^ HaltSignal
+!
+
+informationSignal
+ "return the signal used for informations.
+ A handler for this signal gets all #information: sends"
+
+ ^ InformationSignal
+!
+
+keyNotFoundSignal
+ "return the signal used for no such key error reporting"
+
+ ^ KeyNotFoundSignal
+!
+
+messageNotUnderstoodSignal
+ "return the signal used for doesNotUnderstand: - error handling"
+
+ ^ MessageNotUnderstoodSignal
+!
+
+nonIntegerIndexSignal
+ "return the signal used for bad subscript error reporting"
+
+ ^ NonIntegerIndexSignal
+!
+
+notFoundSignal
+ "return the signal used for no element found error reporting"
+
+ ^ NotFoundSignal
+!
+
+primitiveFailureSignal
+ "return the signal used for primitiveFailed - error handling"
+
+ ^ PrimitiveFailureSignal
+!
+
+privateMethodSignal
+ "return the signal used for privateMethod - error handling"
+
+ ^ MessageNotUnderstoodSignal
+!
+
+recursionInterruptSignal
+ "return the signal used for recursion overflow error handling"
+
+ ^ RecursionInterruptSignal
+!
+
+subscriptOutOfBoundsSignal
+ "return the signal used for subscript error reporting.
+ (this signal is used for example when an array is accessed with an
+ index less than 1 or greater than the array size)"
+
+ ^ SubscriptOutOfBoundsSignal
+!
+
+userInterruptSignal
+ "return the signal used for ^C interrupts handling"
+
+ ^ UserInterruptSignal
+!
+
+userNotificationSignal
+ "the parent signal used with information and warnings.
+ Handling this allows handling of both information- and warning notifications."
+
+ ^ UserNotificationSignal
+!
+
+warningSignal
+ "return the signal used for warnings.
+ A handler for this signal gets all #warn: sends"
+
+ ^ WarningSignal
! !
!Object class methodsFor:'info messages'!
+infoPrinting
+ "return the flag which controls information messages."
+
+ ^ InfoPrinting
+!
+
infoPrinting:aBoolean
"turn on/off printing of information messages.
If the argument, aBoolean is false, infoPrint will not output
messages. The default is true."
InfoPrinting := aBoolean
-!
-
-infoPrinting
- "return the flag which controls information messages."
-
- ^ InfoPrinting
! !
!Object class methodsFor:'queries'!
@@ -340,1908 +334,6 @@
^ self == Object
! !
-!Object methodsFor:'initialization'!
-
-initialize
- "just to ignore initialize to objects which do not need it"
-
- ^ self
-! !
-
-!Object ignoredMethodsFor:'initialization'!
-
-fromLiteralArrayEncoding:aSpecArray
- "read my values from a specArray. The argument is supposed to
- consist of setSelector/value pairs, which are sent to the receiver.
- Some classes (Point, Rectangle) redefine this for a slightly more compact
- literal representation.
- This was added to allow for VW windowSpecs to be parsed in ST/X;
- do not use if for general object printing/restoring."
-
- |sz "{Class: SmallInteger }"|
-
- sz := aSpecArray size.
- 2 to:sz by:2 do:[:i |
- self perform:(aSpecArray at:i) with:(aSpecArray at:i+1)
- ]
-
- "
- (Association new) fromLiteralArrayEncoding:#(#dummy #key: 1 #value: 'one')
- "
-! !
-
-!Object methodsFor:'cleanup'!
-
-lowSpaceCleanup
- "ignored here - redefined in some classes to
- cleanup in low-memory situations"
-
- ^ self
-! !
-
-!Object methodsFor:'system primitives'!
-
-become:anotherObject
- "make all references to the receiver become references to anotherObject
- and vice-versa. This may be an expensive (i.e. slow) operation,
- since in the worst case, the whole memory has to be searched for
- references to the two objects (although the primitive tries hard to
- limit the search, for acceptable performance in most cases).
- In general, using become: should be avoided if possible, since it may
- produce many strange effects (think of hashing in Sets).
- This method fails, if the receiver or the argument is a SmallInteger
- or nil, or is a context of a living method (i.e. one that has not already
- returned).
- (notice that become: is not used heavily by the system
- - the Collection-classes have been rewritten to not use it.)"
-%{
- if (__primBecome(self, anotherObject COMMA_CON))
- RETURN ( self );
-%}
-.
- self primitiveFailed
-!
-
-becomeNil
- "make all references to the receiver become nil - effectively getting
- rid of the receiver. This can be a very dangerous operation - be warned.
- The receiver may not be a SmallInteger or a context of a living method."
-
-%{
- if (__primBecomeNil(self COMMA_CON ))
- RETURN ( nil );
-%}
-.
- self primitiveFailed
-!
-
-changeClassTo:otherClass
- "changes the class of the receiver to the argument, otherClass.
- This is only allowed (possible), if the receivers class and the argument
- have the same structure (i.e. number of named instance variables and
- type of indexed instance variables).
- If the structures do not match, or any of the original class or new class
- is UndefinedObject or a Smallinteger, a primitive error is triggered."
-
- |myClass ok|
-
- "check for UndefinedObject/SmallInteger receiver or newClass"
-%{
- if (__isNonNilObject(self)
- && __isNonNilObject(otherClass)
- && (otherClass != UndefinedObject)
- && (otherClass != SmallInteger)) {
- ok = true;
- } else {
- ok = false;
- }
-%}.
- ok ifTrue:[
- ok := false.
- myClass := self class.
- myClass flags == otherClass flags ifTrue:[
- myClass instSize == otherClass instSize ifTrue:[
- "same instance layout and types: its ok to do it"
- ok := true.
- ] ifFalse:[
- myClass isPointers ifTrue:[
- myClass isVariable ifTrue:[
- ok := true
- ]
- ]
- ]
- ] ifFalse:[
- myClass isPointers ifTrue:[
- "if newClass is a variable class, with instSize <= my instsize,
- we can do it (effectively mapping additional instvars into the
- variable part) - usefulness is questionable, though"
-
- otherClass isPointers ifTrue:[
- otherClass isVariable ifTrue:[
- otherClass instSize <= (myClass instSize + self basicSize)
- ifTrue:[
- ok := true
- ]
- ] ifFalse:[
- otherClass instSize == (myClass instSize + self basicSize)
- ifTrue:[
- ok := true
- ]
- ]
- ] ifFalse:[
- "it does not make sense to convert pointers to bytes ..."
- ]
- ] ifFalse:[
- "does it make sense, to convert bits ?"
- "could allow byteArray->wordArray->longArray->floatArray->doubleArray here ..."
- ]
- ]
- ].
- ok ifTrue:[
- "now, change the receivers class ..."
-%{
- __qClass(self) = otherClass;
- __STORE(self, otherClass);
- RETURN ( self );
-%}.
- ].
- self primitiveFailed
-!
-
-changeClassToThatOf:anObject
- "changes the class of the receiver to that of the argument, anObject.
- This is only allowed (possible), if the receivers class and the arguments
- class have the same structure (i.e. number of named instance variables and
- type of indexed instance variables). If the structures do not match, or any
- of the objects is nil or a Smallinteger, a primitive error is triggered."
-
- self changeClassTo:(anObject class)
-! !
-
-!Object methodsFor:'queries'!
-
-size
- "return the number of the receivers indexed instance variables;
- this method may be redefined in subclasses"
-
- ^ self basicSize
-!
-
-basicSize
- "return the number of the receivers indexed instance variables,
- 0 if it has none.
-
- This method should NOT be redefined in any subclass"
-
-%{ /* NOCONTEXT */
-
- REGISTER int nbytes;
- REGISTER OBJ myClass;
- REGISTER int flags;
-
- /*
- * notice the missing test for self being a nonNilObject -
- * this can be done since basicSize is defined both in UndefinedObject
- * and SmallInteger
- */
- myClass = __qClass(self);
- nbytes = __qSize(self)
- - OHDR_SIZE
- - __OBJS2BYTES__(__intVal(_ClassInstPtr(myClass)->c_ninstvars));
-
- flags = __intVal(_ClassInstPtr(myClass)->c_flags) & ARRAYMASK;
- /*
- * replaced switch by open-if; this is slightly faster since
- * it avoids the range check and also checks the most common case first
- */
- if ((flags == POINTERARRAY)
- || (flags == WKPOINTERARRAY)) {
- RETURN ( __MKSMALLINT(__BYTES2OBJS__(nbytes)) );
- }
- if (flags == BYTEARRAY) {
- RETURN ( __MKSMALLINT(nbytes / sizeof(char)) );
- }
- if (flags == FLOATARRAY) {
- RETURN ( __MKSMALLINT(nbytes / sizeof(float)) );
- }
- if (flags == DOUBLEARRAY) {
-#ifdef NEED_DOUBLE_ALIGN
- /*
- * care for filler
- */
- nbytes -= sizeof(FILLTYPE);
-#endif
- RETURN ( __MKSMALLINT(nbytes / sizeof(double)) );
- }
- if (flags == LONGARRAY) {
- RETURN ( __MKSMALLINT(nbytes / sizeof(long)) );
- }
- if (flags == WORDARRAY) {
- RETURN ( __MKSMALLINT(nbytes / sizeof(short)) );
- }
-%}.
- ^ 0
-!
-
-isVariable
- "return true if the receiver has indexed instance variables,
- false otherwise."
-
- ^ self class isVariable
-!
-
-isFixedSize
- "return true if the receiver cannot grow easily
- (i.e. a grow may be expensive, since it involves a become:)"
-
- ^ true
-!
-
-class
- "return the receivers class"
-
-%{ /* NOCONTEXT */
-
- RETURN ( __Class(self) );
-%}
-!
-
-species
- "return a class which is similar to (or the same as) the receivers class.
- This is used to create an appropriate object when creating derived
- copies in the collection classes (sometimes redefined)."
-
- ^ self class
-!
-
-yourself
- "return the receiver - used for cascades to return self at the end"
-
- ^ self
-!
-
-isBehavior
- "return true, if the receiver is some kind of class (i.e. behavior);
- false is returned here - the method is only redefined in Behavior."
-
- ^ false
-!
-
-isClass
- "return true, if the receiver is some kind of class (real class,
- not just behavior);
- false is returned here - the method is only redefined in Class."
-
- ^ false
-!
-
-isMeta
- "return true, if the receiver is some kind of metaclass;
- false is returned here - the method is only redefined in Metaclass."
-
- ^ false
-!
-
-isBlock
- "return true, if the receiver is some kind of block;
- false returned here - the method is only redefined in Block."
-
- ^ false
-!
-
-isMethod
- "return true, if the receiver is some kind of method;
- false returned here - the method is only redefined in Method."
-
- ^ false
-!
-
-isContext
- "return true, if the receiver is some kind of context;
- false returned here - the method is only redefined in Context."
-
- ^ false
-!
-
-isSignal
- "return true, if the receiver is some kind of signal;
- false returned here - the method is only redefined in Signal."
-
- ^ false
-!
-
-isStream
- "return true, if the receiver is some kind of stream;
- false is returned here - the method is only redefined in Stream."
-
- ^ false
-!
-
-isExternalStream
- "return true, if the receiver is some kind of externalStream;
- false is returned here - the method is only redefined in ExternalStream."
-
- ^false
-!
-
-isFileStream
- "return true, if the receiver is some kind of fileStream;
- false is returned here - the method is only redefined in FileStream."
-
- ^false
-!
-
-isCollection
- "return true, if the receiver is some kind of collection;
- false is returned here - the method is only redefined in Collection."
-
- ^ false
-!
-
-isSequenceable
- "return true, if the receiver is some kind of sequenceable collection;
- false is returned here - the method is only redefined in SequenceableCollection."
-
- ^ false
-!
-
-isSequenceableCollection
- "OBSOLETE: use isSequenceable for ST-80 compatibility.
- This method is a historic leftover and will be removed soon ..."
-
- self obsoleteMethodWarning:'use #isSequenceable'.
- ^ false
-!
-
-isColor
- "return true, if the receiver is some kind of color;
- false is returned here - the method is only redefined in Color."
-
- ^ 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."
-
- ^ false
-!
-
-isString
- "return true, if the receiver is some kind of string;
- false is returned here - the method is only redefined in String."
-
- ^ false
-!
-
-isSymbol
- "return true, if the receiver is some kind of symbol;
- false is returned here - the method is only redefined in Symbol."
-
- ^ false
-!
-
-isCharacter
- "return true, if the receiver is some kind of character;
- false is returned here - the method is only redefined in Character."
-
- ^ false
-!
-
-isNumber
- "return true, if the receiver is some kind of number;
- false is returned here - the method is only redefined in Number."
-
- ^ false
-!
-
-isFraction
- "return true, if the receiver is some kind of fraction;
- false is returned here - the method is only redefined in Fraction."
-
- ^ false
-!
-
-isReal
- "return true, if the receiver is some kind of real number;
- false is returned here - the method is only redefined in LimitedPrecisionReal."
-
- ^ false
-!
-
-isInteger
- "return true, if the receiver is some kind of integer number;
- false is returned here - the method is only redefined in Integer."
-
- ^ false
-!
-
-isPoint
- "return true, if the receiver is some kind of point;
- false is returned here - the method is only redefined in Point."
-
- ^ false
-!
-
-isRectangle
- "return true, if the receiver is some kind of rectangle;
- false is returned here - the method is only redefined in Rectangle."
-
- ^ false
-!
-
-isLayout
- "return true, if the receiver is some kind of layout;
- false is returned here - the method is only redefined in Layout."
-
- ^ false
-!
-
-isForm
- "return true, if the receiver is some kind of form;
- false is returned here - the method is only redefined in Form."
-
- ^ false
-!
-
-isImage
- "return true, if the receiver is some kind of image;
- false is returned here - the method is only redefined in Image."
-
- ^ false
-!
-
-isImageOrForm
- "return true, if the receiver is some kind of image or form;
- false is returned here - the method is only redefined in Image and Form."
-
- ^ false
-!
-
-isView
- "return true, if the receiver is some kind of view;
- false is returned here - the method is only redefined in View."
-
- ^ false
-!
-
-isLiteral
- "return true, if the receiver can be represented as a constant in ST syntax;
- false is returned here - the method is redefined in some classes."
-
- ^ false
-!
-
-isMemberOf:aClass
- "return true, if the receiver is an instance of aClass, false otherwise.
- Advice:
- use of this to check objects for certain attributes/protocoll should
- be avoided; it limits the reusability of your classes by limiting use
- to instances of a certain class.
- Use check-methods to check an object for a certain attributes/protocol
- (such as #isXXX, #respondsTo: or #isNumber);
-
- Using #isMemberOf: is considered BAD STYLE."
-
- ^ (self class) == aClass
-!
-
-isKindOf:aClass
- "return true, if the receiver is an instance of aClass or one of its
- subclasses, false otherwise.
- Advice:
- use of this to check objects for certain attributes/protocoll should
- be avoided; it limits the reusability of your classes by limiting use
- to instances of certain classes and fences you into a specific inheritance
- hierarchy.
- Use check-methods to check an object for a certain attributes/protocol
- (such as #isXXXX, #respondsTo: or #isNumber).
-
- Using #isKindOf: is considered BAD STYLE.
-
- Advice2:
- Be aware, that using an #isXXX method is usually much faster than
- using #isKindOf:; because isKindOf: has to walk up all the superclass
- hierarchy, comparing every class on the way.
- Due to caching in the VM, a call to #isXXX is normally reached via
- a single function call.
- "
-
-%{ /* NOCONTEXT */
- register OBJ thisClass;
-
- thisClass = __Class(self);
- while (thisClass != nil) {
- if (thisClass == aClass) {
- RETURN ( true );
- }
- thisClass = _ClassInstPtr(thisClass)->c_superclass;
- }
-%}
-.
-"/
-"/ the above code is equivalent to:
-"/
-"/ thisClass := self class.
-"/ [thisClass notNil] whileTrue:[
-"/ thisClass == aClass ifTrue:[^ true].
-"/ thisClass := thisClass superclass
-"/ ]
-"/
- ^ false
-!
-
-respondsTo:aSelector
- "return true, if the receiver implements a method with selector equal
- to aSelector; i.e. if there is a method for aSelector in either the
- receivers class or one of its superclasses.
-
- Notice, that this does not imply, that such a message can be sent without
- an error being raised. For example, an implementation could send
- #shouldNotImplement or #subclassResponsibility."
-
- "
- should we go via the cache, or search (by class) ?
- The first is faster, most of the time; while the 2nd fills
- the cache with useless data if this is sent in a loop over all objects.
- For now, use the cache ...
- "
-%{ /* NOCONTEXT */
-
- extern OBJ __lookup();
-
- if (__lookup(__Class(self), aSelector) == nil) {
- RETURN ( false );
- }
- RETURN ( true );
-%}
-.
-"
- ^ self class canUnderstand:aSelector
-"
-
- "'aString' respondsTo:#+"
- "'aString' respondsTo:#,"
- "'aString' respondsTo:#collect:"
-!
-
-respondsToArithmetic
- "return true, if the receiver responds to arithmetic messages.
- false is returned here - the method is redefined in ArithmeticValue."
-
- ^ false
-! !
-
-!Object methodsFor:'special queries'!
-
-references:anObject
- "return true, if the receiver refers to the argument, anObject.
- - for debugging only"
-
- |myClass
- numInst "{ Class: SmallInteger }" |
-
-%{
- /*
- * a little optimization: use the fact that all old objects
- * refering to a new object are on the remSet; if I am not,
- * a trivial reject is possible, if anObject is a newbee
- */
- if (__isNonNilObject(self) && __isNonNilObject(anObject)) {
- if ((__qSpace(self) <= OLDSPACE) && !__isRemembered(self)) {
- int spc;
-
- if (((spc = __qSpace(anObject)) == NEWSPACE) || (spc == SURVSPACE)) {
- RETURN (false);
- }
- }
- }
-%}.
-
- myClass := self class.
-
- "check the class"
- (myClass == anObject) ifTrue:[^ true].
-
- "check the instance variables"
- numInst := myClass instSize.
- 1 to:numInst do:[:i |
- ((self instVarAt:i) == anObject) ifTrue:[^ true]
- ].
-
- "check the indexed variables"
- myClass isVariable ifTrue:[
- myClass isPointers ifFalse:[
- "/
- "/ we could argue about the following unconditional return:
- "/ it says that a non pointer array never has a reference to the
- "/ corresponding object - not mimicing a reference to a copy of the
- "/ integer. However, it avoids useless searches in huge byteArray
- "/ like objects when searching for owners. If in doubt, remove it.
- "/ A consequence of the return below is that #[1 2 3] will say that it
- "/ does not refer to the number 2 (think of keeping a copy instead)
-
- ^ false.
-
- "/ alternative:
- "/ anObject isNumber ifFalse:[^ false].
- ].
-
- "/
- "/ because arrays are so common, and those have a highly tuned
- "/ idenitytIndex method, use it
- "/
- myClass == Array ifTrue:[
- ^ (self identityIndexOf:anObject) ~~ 0
- ].
-
- "/
- "/ otherwise, do it the slow way
- "/
- numInst := self basicSize.
- 1 to:numInst do:[:i |
- ((self basicAt:i) == anObject) ifTrue:[^ true]
- ]
- ].
- ^ false
-
- "
- |v|
-
- v := View new initialize.
- v references:Display.
- "
-!
-
-referencesInstanceOf:aClass
- "return true, if the receiver refers to an instance of
- the argument, aClass.This method exists
- to support searching for users of a class."
-
- |myClass
- numInst "{ Class: SmallInteger }" |
-
- myClass := self class.
-
- "check the class"
- (myClass isMemberOf:aClass) ifTrue:[^ true].
-
- "check the instance variables"
- numInst := myClass instSize.
- 1 to:numInst do:[:i |
- ((self instVarAt:i) isMemberOf:aClass) ifTrue:[^ true]
- ].
-
- "check the indexed variables"
- myClass isVariable ifTrue:[
- myClass isPointers ifFalse:[
- "no need to search in non-pointer indexed fields"
- myClass isLongs ifTrue:[
- (aClass == SmallInteger or:[aClass == LargeInteger]) ifFalse:[^ false].
- ] ifFalse:[
- myClass isFloatsOrDoubles ifTrue:[^ aClass == Float].
- ^ aClass == SmallInteger
- ]
- ].
- numInst := self basicSize.
- 1 to:numInst do:[:i |
- ((self basicAt:i) isMemberOf:aClass) ifTrue:[^ true]
- ]
- ].
- ^ false
-
- "
- (1 @ 3.4) referencesInstanceOf:Float
- (1 @ 3.4) referencesInstanceOf:Fraction
- View new initialize referencesInstanceOf:(Display class)
- "
-!
-
-referencesDerivedInstanceOf:aClass
- "return true, if the receiver refers to an instance of
- the argument, aClass or its subclass. This method exists
- to support searching for users of a class."
-
- |myClass
- numInst "{ Class: SmallInteger }" |
-
- myClass := self class.
-
- "check the class"
- (myClass isKindOf:aClass) ifTrue:[^ true].
-
- "check the instance variables"
- numInst := myClass instSize.
- 1 to:numInst do:[:i |
- ((self instVarAt:i) isKindOf:aClass) ifTrue:[^ true]
- ].
-
- "check the indexed variables"
- myClass isVariable ifTrue:[
- myClass isPointers ifFalse:[
- "no need to search in non pointer fields"
- ((aClass == Number) or:[aClass isSubclassOf:Number]) ifFalse:[^ false].
- ].
- numInst := self basicSize.
- 1 to:numInst do:[:i |
- ((self basicAt:i) isKindOf:aClass) ifTrue:[^ true]
- ]
- ].
- ^ false
-
- "
- (1 @ 3.4) referencesDerivedInstanceOf:Number
- (1 @ 3.4) referencesDerivedInstanceOf:Array
- View new initialize referencesDerivedInstanceOf:DeviceWorkstation
- "
-!
-
-allOwners
- "return a collection of all objects referencing the receiver"
-
- ^ ObjectMemory whoReferences:self
-! !
-
-!Object methodsFor:'misc'!
-
--> anObject
- "return an association with the receiver as key and
- the argument as value"
-
- ^ Association key:self value:anObject
-! !
-
-!Object methodsFor:'evaluation'!
-
-value
- "this allows every object to be used where blocks are typically used.
- Time will show, if this is a good idea or leads to sloppy programming
- style ... (the idea was borrowed from the Self language).
- WARNING: dont 'optimize' away ifXXX: blocks - the compilers will
- only generate inline code for the if, if the argument(s) are blocks.
- It will work, but run slower instead."
-
- ^ self
-
- "
- #(1 2 3 4) indexOf:5 ifAbsent:0
- "
-
- "DO NOT DO THIS (its slower)
- (1 > 4) ifTrue:'oops' ifFalse:'ok'
-
- USE (the compiler optimizes blocks in if/while):
- (1 > 4) ifTrue:['oops'] ifFalse:['ok']
- "
-! !
-
-!Object methodsFor:'copying'!
-
-copy
- "return a copy of the receiver - defaults to shallowcopy here.
- Notice, that copy does not copy dependents."
-
- ^ self shallowCopy postCopy
-!
-
-shallowCopyForFinalization
- "this is used to aquire a copy to be used for finalization -
- (the copy will get a dispose-notification; see the documentation in the Registry class)
- This method can be redefined for more efficient copying - especially for large objects."
-
- ^ self shallowCopy
-!
-
-shallowCopy
- "return a copy of the object with shared subobjects (a shallow copy)
- i.e. the copy shares referenced instvars with its original."
-
- |myClass aCopy
- sz "{ Class: SmallInteger }" |
-
- myClass := self class.
- myClass isVariable ifTrue:[
- sz := self basicSize.
- aCopy := myClass basicNew:sz.
-
- "copy the indexed variables"
- 1 to:sz do:[:i |
- aCopy basicAt:i put:(self basicAt:i)
- ]
- ] ifFalse:[
- aCopy := myClass basicNew
- ].
-
- "copy the instance variables"
- sz := myClass instSize.
- 1 to:sz do:[:i |
- aCopy instVarAt:i put:(self instVarAt:i)
- ].
-
- ^ aCopy
-!
-
-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
-!
-
-postCopyFrom:original
- "sent to a freshly deep-copied object to give it a chance to adjust things.
- (a font could flush its device-handle for example).
- Notice, that for Sets/Dicts etc. a rehash is not needed, since the deepCopy
- will have the same hash key as the receiver (as long as ST/X provides the
- setHash: functionality)."
-
- "for ST-80 compatibility, we try postCopy here ..."
- ^ self postCopy
-!
-
-deepCopy
- "return a copy of the object with all subobjects also copied.
- This method DOES handle cycles/self-refs; however the receivers
- class is not copied (to avoid the 'total' copy).
- This deepCopy is a bit slower than the old (unsecure) one, since it
- keeps track of already copied objects. If you are sure, that your
- copied object does not include dublicates (or you do not care) and
- no cycles, you can use the old simpleDeepCopy, which avoids this overhead,
- but may run into trouble.
- Notice, that copy does not copy dependents."
-
- ^ self deepCopyUsing:(IdentityDictionary new)
-
- "an example which is not handled by the old deepCopy:
-
- |a|
- a := Array new:3.
- a at:3 put:a.
- a deepCopy inspect
- "
-!
-
-deepCopyError
- "raise a signal, that deepCopy is not allowed for this object"
-
- ^ DeepCopyErrorSignal raise
-!
-
-deepCopyUsing:aDictionary
- "a helper for deepCopy; return a copy of the object with
- all subobjects also copied. If the to-be-copied object is in the dictionary,
- use the value found there. The class of the receiver is not copied.
- This method DOES handle cycles/self references."
-
- |myClass aCopy
- sz "{ Class: SmallInteger }"
- iOrig iCopy|
-
- myClass := self class.
- myClass isVariable ifTrue:[
- sz := self basicSize.
- aCopy := myClass basicNew:sz.
- ] ifFalse:[
- sz := 0.
- aCopy := myClass basicNew
- ].
- aCopy setHashFrom:self.
-
- aDictionary at:self put:aCopy.
-
- "
- copy indexed instvars - if any
- "
- sz ~~ 0 ifTrue:[
- myClass isBits ifTrue:[
- "block-copy indexed instvars"
- aCopy replaceFrom:1 to:sz with:self startingAt:1
- ] ifFalse:[
- "individual deep copy the indexed variables"
- 1 to:sz do:[:i |
- iOrig := self basicAt:i.
- iOrig notNil ifTrue:[
- (aDictionary includesKey:iOrig) ifTrue:[
- iCopy := aDictionary at:iOrig
- ] ifFalse:[
- iCopy := iOrig deepCopyUsing:aDictionary.
- ].
- aCopy basicAt:i put:iCopy
- ]
- ]
- ]
- ].
-
- "
- copy the instance variables
- "
- sz := myClass instSize.
- sz ~~ 0 ifTrue:[
- 1 to:sz do:[:i |
- iOrig := self instVarAt:i.
- iOrig notNil ifTrue:[
- (aDictionary includesKey:iOrig) ifTrue:[
- iCopy := aDictionary at:iOrig
- ] ifFalse:[
- iCopy := iOrig deepCopyUsing:aDictionary.
- ].
- aCopy instVarAt:i put:iCopy
- ]
- ].
- ].
-
- ^ aCopy
-!
-
-simpleDeepCopy
- "return a copy of the object with all subobjects also copied.
- This method does NOT handle cycles - but is included to allow this
- slightly faster copy in situations where it is known that
- no recursive references occur (LargeIntegers for example).
- NOTICE: you will run into trouble, when trying this with recursive
- objects (usually recursionInterrupt or memory-alert).
- This method corresponds to the 'traditional' deepCopy found in
- the Blue book."
-
- |myClass aCopy
- sz "{ Class: SmallInteger }" |
-
- myClass := self class.
- myClass isVariable ifTrue:[
- sz := self basicSize.
- aCopy := myClass basicNew:sz.
-
- "copy the indexed variables"
- 1 to:sz do:[:i |
- aCopy basicAt:i put:((self basicAt:i) simpleDeepCopy)
- ]
- ] ifFalse:[
- aCopy := myClass basicNew
- ].
-
- "copy the instance variables"
- sz := myClass instSize.
- 1 to:sz do:[:i |
- aCopy instVarAt:i put:((self instVarAt:i) simpleDeepCopy)
- ].
-
- ^ aCopy
-
- "a bad example (but ST/X should survive ...)"
- "
- |a|
- a := Array new:3.
- a at:3 put:a.
- a simpleDeepCopy
- "
-!
-
-setHashFrom:anObject
- "set my identity-hash key to be the same as anObjects hash key.
- This is an ST/X speciality, which is NOT available in other (especially OT based)
- Smalltalks, and may not be available in future ST/X versions.
- DO NEVER use this for normal application code."
-
-%{ /* NOCONTEXT */
-
- REGISTER unsigned h;
-
- if (__isNonNilObject(self) && __isNonNilObject(anObject)) {
- h = __GET_HASH(anObject);
- __SET_HASH(self, h);
- RETURN (self);
- }
-%}
-.
- self primitiveFailed "neither receiver not arg may be nil or SmallInteger"
-! !
-
-!Object methodsFor:'comparing'!
-
-== anObject
- "return true, if the receiver and the arg are the same object"
-
-%{ /* NOCONTEXT */
-
- RETURN ( (self == anObject) ? true : false );
-%}
-!
-
-~~ anObject
- "return true, if the receiver and the arg are not the same object"
-
-%{ /* NOCONTEXT */
-
- RETURN ( (self == anObject) ? false : true );
-%}
-!
-
-= anObject
- "return true, if the receiver and the arg have the same structure"
-
- ^ self == anObject
-!
-
-~= anObject
- "return true, if the receiver and the arg do not have the same structure"
-
- ^ (self = anObject) not
-!
-
-isNil
- "return true, if the receiver is nil"
-
- ^ false
-!
-
-notNil
- "return true, if the receiver is not nil"
-
- ^ true
-!
-
-hash
- "return an Integer useful as a hash key for the receiver.
- This hash should return same values for objects with same
- contents (i.e. use this to hash on structure)"
-
- ^ self identityHash
-!
-
-identityHash
- "return an Integer useful as a hash key for the receiver.
- This hash should return same values for the same object (i.e. use
- this to hash on identity of objects).
-
- We cannot use the Objects address (as other smalltalks do) since
- no object-table exists and the hashval must not change when objects
- are moved by the collector. Therefore we assign each object a unique
- Id in the object header itself as its hashed upon.
- (luckily we have 11 bits spare to do this - unluckily its only 11 bits).
- Time will show, if 11 bits are enough; if not, another entry in the
- object header will be needed, adding 4 bytes to every object. Alternatively,
- hashed-upon objects could add an instvar containing the hash value."
-
-%{ /* NOCONTEXT */
-
- REGISTER unsigned hash;
- static unsigned nextHash = 0;
- OBJ cls;
-
- if (__isNonNilObject(self)) {
- hash = __GET_HASH(self);
- if (hash == 0) {
- hash = nextHash++;
- __SET_HASH(self, hash);
- hash = __GET_HASH(self);
- if (hash == 0) {
- hash = nextHash++;
- __SET_HASH(self, hash);
- hash = __GET_HASH(self);
- }
- }
-
- /*
- * now, we got 11 bits for hashing;
- * make it as large as possible; since most hashers use the returned
- * key and take it modulu some prime number, this will allow for
- * better distribution (i.e. bigger empty spaces) in hashed collection.
- * we could shift it up to the 30 bit limit - not making it negative.
- */
- RETURN ( __MKSMALLINT(hash << __HASH_SHIFT__) );
- }
-%}.
- ^ 0 "never reached, since redefined in UndefinedObject and SmallInteger"
-! !
-
-!Object methodsFor:'interrupt handling'!
-
-internalError:msg
- "this is triggered, when system hits some bad error,
- such as corrupted class, corrupted method/selector array
- etc. The argument string gives some more information on what happened.
- (for example, if you set an objects class to a smallInteger, nil etc).
- Its not guaranteed, that the system is in a working condition once
- this error occurred ...."
-
- ^ self error:msg
-!
-
-userInterrupt
- "user (^c) interrupt - enter debugger"
-
- UserInterruptSignal raise
-!
-
-ioInterrupt
- "I/O (SIGIO/SIGPOLL) interrupt (supposed to be sent to Processor).
- If we arrive here, there is either no handler (ObjMem>>ioInterruptHandler)
- or it does not understand the ioInterrupt message.
- In any case, this is a sign of some big trouble. Enter debugger."
-
- self error:'I/O Interrupt - but no handler'
-!
-
-schedulerInterrupt
- "scheduler interrupt (supposed to be sent to Processor).
- If we arrive here, either the Processor does not understand it,
- or it has been set to nil. In any case, this is a sign of some
- big trouble. Enter debugger."
-
- self error:'schedulerInterrupt - but no Processor'
-!
-
-childSignalInterrupt
- "death of a child process (unix process) - do nothing"
-
- ^ self
-!
-
-spyInterrupt
- "spy interrupt and no handler - enter debugger"
-
- self error:'spy Interrupt - but no handler'
-!
-
-timerInterrupt
- "timer interrupt and no handler - enter debugger"
-
- self error:'timer Interrupt - but no handler'
-!
-
-errorInterrupt:errorID with:aParameter
- "subsystem error. The arguments errorID and aParameter are the values passed
- to the 'errorInterruptWithIDAndParameter(id, param)' function,
- which can be called from C subsystems to raise an (asynchronous)
- error exception.
-
- Currently, this is used to map XErrors to smalltalk errors, but can be
- used from other C subsystems too, to upcast errors.
- Especially, for subsystems which call errorHandler functions asynchronously.
- IDs (currently) used:
- #DisplayError ..... x-error interrupt
- #XtError ..... xt-error interrupt (Xt interface is not yet published)
- "
-
- |handler|
-
- handler := ObjectMemory registeredErrorInterruptHandlers at:errorID ifAbsent:nil.
- handler notNil ifTrue:[
- "/
- "/ handler found; let it do whatever it wants ...
- "/
- handler errorInterrupt:errorID with:aParameter.
- ^ self
- ].
-
- "/
- "/ no handler - raise errorSignal passing the errorId as parameter
- "/
- ^ ErrorSignal
- raiseRequestWith:errorID
- errorString:('Subsystem error. ErrorID = ' , errorID printString)
-!
-
-memoryInterrupt
- "out-of-memory interrupt and no handler - enter debugger"
-
- ^ self error:'almost out of memory'
-!
-
-customInterrupt
- "a custom interrupt"
-
- ^ self error:'custom interrupt'
-!
-
-fpExceptionInterrupt
- "a floating point exception occured - this one
- has to be handled differently since it comes asynchronous
- on some machines (for example, on machines with a separate FPU
- or superscalar architectures. Also, errors from within primitive code
- (or library functions such as GL) are sent via the Unix-signal
- mechanism this way."
-
- ^ Float domainErrorSignal raise
-!
-
-signalInterrupt:signalNumber
- "unix signal occured - some signals are handled as Smalltalk Exceptions
- (SIGPIPE), others (SIGBUS) are rather fatal ...
- In any case, if a smalltalk-signal has been connected to the OS signal,
- that one is raised.
- TODO: add another argument, giving more detailed signal info (PC, VADDR,
- exact cause etc.). This helps if segvs occur in primitive code.
- Currently (temporary kludge), these are passed as global variables."
-
- |box name here sig ignorable titles actions badContext msg pc addr|
-
- "
- special case - since SIGPIPE has an ST-signal associated
- "
- (signalNumber == 13) ifTrue:[
- "SIGPIPE - write on a pipe with no one to read"
-
- ^ PipeStream brokenPipeSignal raise.
- ].
-
- "if there has been an ST-signal installed, use it ..."
-
- sig := OperatingSystem operatingSystemSignal:signalNumber.
- sig notNil ifTrue:[
- ^ sig raise
- ].
-
- "
- ... otherwise , bring up a box asking for what to do ...
- "
- name := OperatingSystem nameForSignal:signalNumber.
- here := thisContext.
-
- "
- the context, in which the signal occurred:
- "
- badContext := here sender.
-
- "
- ungrab - in case it happened in a box/popupview
- otherwise display stays locked
- "
- Display notNil ifTrue:[
- Display ungrabPointer.
- ].
-
- "
- SIGBUS, SIGSEGV and SIGILL do not make sense to ignore (i.e. continue)
- since the system will retry the faulty instruction, which leads to
- another signal - to avoid frustration, better not offer this option.
- "
- ignorable := (signalNumber ~~ OperatingSystem sigBUS)
- and:[signalNumber ~~ OperatingSystem sigILL
- and:[signalNumber ~~ OperatingSystem sigSEGV]].
-
- ignorable ifFalse:[
- here isRecursive ifTrue:[
- 'fatal: signal ' errorPrint. signalNumber errorPrintNL.
- MiniDebugger enterWithMessage:'recursive signal'.
- ^ self
- ].
- "
- a hard signal - go into debugger immediately
- "
- msg := 'Signal ', name.
- InterruptPcLow notNil ifTrue:[
- pc := InterruptPcLow + (InterruptPcHi bitShift:16).
- pc ~~ 0 ifTrue:[
- msg := msg , ' PC=' , (pc printStringRadix:16)
- ].
- ].
- InterruptAddrLow notNil ifTrue:[
- addr := InterruptAddrLow + (InterruptAddrHi bitShift:16).
- addr ~~ 0 ifTrue:[
- msg := msg , ' ADDR=' , (addr printStringRadix:16)
- ].
- ].
- Debugger enter:here withMessage:msg.
- badContext return.
- ^ nil.
- ].
-
- OptionBox isNil ifTrue:[
- "
- a system without GUI ...
- go into minidebugger (if there is one)
- "
- MiniDebugger isNil ifTrue:[
- "
- a system without debugging facilities
- (i.e. a standalone system)
- output a message and exit.
- "
- ('exit due to Signal ' , name) errorPrintNL.
- Smalltalk exit.
- ].
- MiniDebugger enterWithMessage:'Signal cought (' , name, ')'.
- ^ self
- ].
-
- box := OptionBox
- title:'Signal cought (' , name, ')'
- numberOfOptions:(ignorable ifTrue:[5] ifFalse:[4]).
-
- titles := #('return' 'debug' 'dump' 'exit').
- actions := Array
- with:[badContext return]
- with:[Debugger enter:here withMessage:('Signal ', name). ^nil]
- with:[Smalltalk fatalAbort]
- with:[Smalltalk exit].
-
- ignorable ifTrue:[
- titles := #('ignore') , titles.
- actions := (Array with:[^ nil]) , actions.
- ].
- box buttonTitles:titles.
- box actions:actions.
- box showAtPointer
-!
-
-recursionInterrupt
- "recursion limit (actually: stack overflow) interrupt.
- This interrupt is triggered, when a process stack grows above
- its stackLimit - usually, this leads into the debugger, but
- could be cought and the stackLimit increased in the handler.
- At the time we arrive here, the system has still some stack
- as a reserve so we can continue to do some useful work or cleanup or
- debugging for a while.
- If the signal is ignored, and the stack continues to grow, there
- will be a few more chances (and more interrupts) before the VM
- hard-terminates the process."
-
- thisContext isRecursive ifFalse:[
- ^ RecursionInterruptSignal raise
- ]
-!
-
-exceptionInterrupt
- "exception interrupt - enter debugger"
-
- self error:'exception Interrupt'
-! !
-
-!Object methodsFor:'error handling'!
-
-subscriptBoundsError
- "report error that some index is out of bounds.
- (when accessing indexable collections)"
-
- ^ SubscriptOutOfBoundsSignal raiseIn:thisContext sender
-!
-
-subscriptBoundsError:anIndex
- "report error that anIndex is out of bounds.
- (when accessing indexable collections)"
-
- ^ SubscriptOutOfBoundsSignal raiseRequestWith:anIndex in:thisContext sender
-!
-
-indexNotInteger
- "report error that index is not an Integer.
- (when accessing collections indexed by an integer key)"
-
- ^ NonIntegerIndexSignal raiseIn:thisContext sender
-!
-
-errorNotFound
- "report error that no element was found in a collection"
-
- ^ NotFoundSignal raiseIn:thisContext sender
-!
-
-errorKeyNotFound:aKey
- "report error that a key was not found in a collection"
-
- ^ KeyNotFoundSignal raiseRequestWith:aKey in:thisContext sender
-!
-
-elementBoundsError
- "report error that badElement is out of bounds
- (i.e. cannot be put into that collection)"
-
- ^ ElementOutOfBoundsSignal raiseIn:thisContext sender
-!
-
-elementNotInteger
- "report error that object to be stored is not Integer.
- (in collections that store integers only)"
-
- ^ ElementOutOfBoundsSignal raiseIn:thisContext sender
-!
-
-elementNotCharacter
- "report error that object to be stored is no Character.
- (usually when storing into Strings)"
-
- ^ ElementOutOfBoundsSignal raiseIn:thisContext sender
-!
-
-mustBeRectangle
- "report an argument-not-rectangle-error"
-
- ^ self error:'argument must be a Rectangle'
-!
-
-mustBeString
- "report an argument-not-string-error"
-
- ^ self error:'argument must be a String'
-!
-
-notIndexed
- "report error that receiver has no indexed instance variables"
-
- ^ self error:'receiver has no indexed variables'
-!
-
-integerCheckError
- "generated when a variable declared with an integer type gets a bad
- value assigned"
-
- ^ self error:'bad assign of ' , self printString ,
- ' (' , self class name , ') to integer-typed variable'
-!
-
-typeCheckError
- "generated when a variable declared with a type hint gets a bad
- value assigned"
-
- ^ self error:'bad assign of ' , self printString ,
- ' (' , self class name , ') to typed variable'
-!
-
-primitiveFailed
- "report error that primitive code failed"
-
- ^ PrimitiveFailureSignal raiseIn:(thisContext sender)
-!
-
-implementedBySubclass
- "this is sent by ST/V code - its the same as #subclassResponsibility"
-
- ^ self subclassResponsibility
-!
-
-invalidMessage
- "this is sent by ST/V code - its the same as #shouldNotImplement"
-
- ^ self shouldNotImplement
-!
-
-subclassResponsibility
- "report error that this message should have been reimplemented in a
- subclass"
-
- ^ self error:'method must be reimplemented in subclass'
-!
-
-shouldNotImplement
- "report error that this message should not be implemented"
-
- ^ self error:'method not appropriate for this class'
-!
-
-halt
- "enter debugger with halt-message"
-
- ^ HaltSignal raiseIn:thisContext sender.
-!
-
-halt:aString
- "enter debugger with halt-message"
-
- ^ HaltSignal raiseRequestWith:#halt:
- errorString:aString
- in:thisContext sender
-!
-
-error
- "report error that an error occured"
-
- ^ ErrorSignal raiseIn:thisContext sender
-!
-
-error:aString
- "enter debugger with error-message aString"
-
- ^ ErrorSignal raiseRequestWith:#error:
- errorString:aString
- in:thisContext sender
-!
-
-doesNotUnderstand:aMessage
- "this message is sent by the runtime system (VM) when
- a message is not understood by some object (i.e. there
- is no method for that selector). The original message has
- been packed into aMessage (i.e. the receiver, selector and
- any arguments) and the original receiver is then sent the
- #doesNotUnderstand: message.
- Here, we raise another signal which usually enters the debugger.
- You can of course redefine #doesNotUnderstand: in your classes
- to implement message delegation."
-
- |sel errorString cls sender|
-
- "/ handle the case of an error during early startup
- "/ (output streams not yet initialized)
- "/
- Stdout isNil ifTrue:[
- Smalltalk fatalAbort:'error during init phase'.
- ].
-
- (sel := aMessage selector) isNil ifTrue:[
- "/
- "/ happens when things go mad, or a method has been
- "/ called by valueWithReceiver: with a wrong receiver
- "/ to avoud later trouble (when concatenating strings),
- "/ replace the selector by some (nonNil) string
- "/
- sel := '(nil)'
- ].
-
- "/
- "/ extract the class that should have implemented the message.
- "/ (in case of a super-send, this is not the receivers class)
- "/
- sender := thisContext sender.
- cls := sender searchClass.
- cls isNil ifTrue:[
- "it was NOT a super or directed send ..."
- cls := self class
- ].
-
- cls notNil ifTrue:[
- "/
- "/ displayString is better than 'cls name',
- "/ since it appends (obsolete) for outdated classes.
- "/ (this happens if you send messages to old instances
- "/ after changing a classes definition)
- "/
- errorString := cls displayString.
- ] ifFalse:[
- errorString := '(** nil-class **)'
- ].
- errorString := errorString , ' does not understand: ' , sel.
-
- "/
- "/ this only happens, when YOU play around with my classvars ...
- "/ (or an error occurs during early startup, when signals are not yet set)
- "/
- MessageNotUnderstoodSignal isNil ifTrue:[
- ^ self enterDebuggerWith:nil
- message:'oops - MessageNotUnderstoodSignal is gone'.
- ].
-
- "/
- "/ thats where we end up normally - raise a signal which (if unhandled) opens a debugger
- "/
- ^ MessageNotUnderstoodSignal
- raiseRequestWith:aMessage
- errorString:errorString
- in:sender
-
- "Modified: 9.12.1995 / 17:25:37 / cg"
-!
-
-appropriateDebugger:aSelector
- "return an appropriate debugger to use.
- If there is already a debugger active on the stack, and it is
- the DebugView, return MiniDebugger (as a last chance) otherwise abort."
-
- |context|
-
- context := thisContext.
- context := context sender.
- [context notNil] whileTrue:[
- ((context receiver class == Debugger)
- and:[context selector == aSelector]) ifTrue:[
- "we are already in some Debugger"
- (Debugger == MiniDebugger) ifTrue:[
- "we are already in the MiniDebugger"
- ErrorRecursion ifFalse:[
- Smalltalk fatalAbort:'recursive error ...'
- ]
- ].
- MiniDebugger isNil ifTrue:[
- Smalltalk fatalAbort:'no debugger'
- ].
-
- "ok, an error occured while in the graphical debugger;
- lets try MiniDebugger"
- ^ MiniDebugger
- ].
- context := context sender
- ].
- "not within Debugger - no problem"
- ^ Debugger
-!
-
-enterDebuggerWith:anException message:aString
- "enter the debugger with error-message aString"
-
- ^ self enterDebuggerWith:anException
- message:aString
- on:anException suspendedContext
-!
-
-enterDebuggerWith:anException message:aString on:aContext
- "enter the debugger with error-message aString.
- The first visible context shown there is aContext
- (this allows intermediate helpers to hide themselfes from what is
- presented to the user)"
-
- |debugger|
-
- "
- if there is no debugger, exit smalltalk
- "
- Debugger isNil ifTrue:[
- 'error: ' errorPrint. aString errorPrintNL.
- Smalltalk fatalAbort:'no Debugger defined'
- ].
- "
- find an appropriate debugger to use
- "
- debugger := self appropriateDebugger:#'enter:withMessage:'.
- ^ debugger enter:aContext withMessage:aString.
-! !
-
-!Object methodsFor:'debugging'!
-
-obsoleteMethodWarning:message from:aContext
- "in methods which are going to be obsoleted, a self-send to
- this method is used to tell programmers that a method is
- used which is going to be removed in later ST/X versions.
- Find all methods which will be obsolete soon by looking at senders
- of this message.
- Hopefully, this warning message is annoying enough for you to
- change the code ... ;-)"
-
- |spec|
-
- spec := aContext methodPrintString.
- ('WARNING: the ''' , spec , ''' method is obsolete.') errorPrintNL.
- (' And may not be present in future ST/X versions.') errorPrintNL.
- (' called from ' , aContext sender printString) errorPrintNL.
- message notNil ifTrue:[
- '------> ' errorPrint. message errorPrintNL
- ]
-
- "
- Object obsoleteMethodWarning:'foo' from:thisContext sender sender
- "
-!
-
-obsoleteMethodWarning:message
- "in methods which are going to be obsoleted, a self send to
- this method is used to tell programmers that a method is
- used which is going to be removed in later ST/X versions.
- Find all methods which will be obsolete soon by looking at senders
- of this message.
- Hopefully, this warning message is annoying enough for you to
- change the code ... ;-)"
-
- self obsoleteMethodWarning:message from:thisContext sender
-!
-
-obsoleteMethodWarning
- "in methods which are going to be obsoleted, a self send to
- this method is used to tell programmers that a method is
- used which is going to be removed in later ST/X versions.
- Find all methods which will be obsolete soon by looking at senders
- of this message.
- Hopefully, this warning message is annoying enough for you to
- change the code ... ;-)"
-
- self obsoleteMethodWarning:nil from:thisContext sender
-!
-
-mustBeKindOf:aClass
- "for compatibility & debugging support:
- check if the receiver isKindOf:aClass and raise an error if not.
- Notice:
- it is VERY questionable, if it makes sense to add manual
- type checks to a dynamically typed language like smalltalk.
- It will, at least, slow down performance,
- make your code less reusable and clutter your code with stupid sends
- of this selector. Also, read the comment in isKindOf:, regarding the
- use of isXXX check methods.
- You see: The author does not like this at all ..."
-
- (self isKindOf:aClass) ifFalse:[
- self error:'argument is not of expected type'
- ]
-!
-
-errorNotify:aString
- "launch a Notifier, showing top stack, telling user something
- and give a chance to enter debugger."
-
- |info con sender|
-
- Dialog isNil ifTrue:[
- "
- on systems without GUI, simply show
- the message on the Transcript.
- "
- Transcript showCr:aString.
- ^ self
- ].
- Dialog autoload. "in case its autoloaded"
-
- con := sender := thisContext sender.
- info := aString , Character cr asString , Character cr asString.
- 1 to:5 do:[:n |
- con notNil ifTrue:[
- info := info , con printString , Character cr asString.
- con := con sender
- ]
- ].
-
- (Dialog choose:info
- labels:#('proceed' 'debug')
- values:#(#proceed #debug)
- default:#debug) == #debug
- ifTrue:[
- Debugger enter:sender withMessage:aString
- ]
-
- "
- nil errorNotify:'hello there'
- self errorNotify:'hello there'
- "
-!
-
-notify:aString
- "launch a Notifier, telling user something.
- Use #information: for ignorable messages."
-
- Dialog isNil ifTrue:[
- "
- on systems without GUI, simply show
- the message on the Transcript.
- "
- Transcript showCr:aString.
- ^ self
- ].
- Dialog autoload. "in case its autoloaded"
- Dialog information:aString
-
- "
- nil notify:'hello there'
- self notify:'hello there'
- "
-!
-
-information:aString
- "launch an InfoBox, telling user something.
- These info-boxes can be suppressed by handling the
- UserNotification- or InformationSignal and proceeding in the handler."
-
- InformationSignal isHandled ifTrue:[
- ^ InformationSignal raiseRequestWith:self errorString:aString
- ].
- self notify:aString
-
- "
- nil information:'hello there'
- self information:'hello there'
- "
-
- "
- InformationSignal handle:[:ex |
- 'no box popped' printNL.
- ex proceed.
- ] do:[
- 'hello' printNL.
- self information:'some info'.
- 'world' printNL.
- ]
- "
-
- "Modified: 24.11.1995 / 22:29:49 / cg"
-!
-
-warn:aString
- "launch a WarningBox, telling user something.
- These warn-boxes can be suppressed by handling the
- UserNotification- or WarningSignal and proceeding in the handler."
-
- WarningSignal isHandled ifTrue:[
- ^ WarningSignal raiseRequestWith:self errorString:aString
- ].
-
- Dialog isNil ifTrue:[
- "
- on systems without GUI, simply show
- the message on the Transcript.
- "
- Transcript showCr:aString.
- ^ self
- ].
- Dialog autoload. "in case its autoloaded"
- Dialog warn:aString
-
- "
- nil warn:'hello there'
- self warn:'hello there'
- "
-
- "
- WarningSignal handle:[:ex |
- ex proceed.
- ] do:[
- 'hello' printNL.
- self warn:'some info'.
- 'world' printNL.
- ]
- "
-!
-
-confirm:aString
- "launch a confirmer, which allows user to enter yes or no.
- return true for yes, false for no"
-
- Dialog isNil ifTrue:[
- "
- on systems without GUI, output a message
- and return true (as if yes was answered)
- Q: should we ask user by reading Stdin ?
- "
- Transcript showCr:aString.
- Transcript showCr:'continue, assuming <yes>'.
- ^ true
- ].
- Dialog autoload. "in case its autoloaded"
- ^ Dialog confirm:aString
-
- "
- nil confirm:'hello'
- self confirm:'hello'
- "
-!
-
-basicInspect
- "launch an inspector on the receiver.
- this method should NOT be redefined in subclasses."
-
- Inspector isNil ifTrue:[
- "
- for systems without GUI
- "
- Transcript showCr:'no Inspector'
- ] ifFalse:[
- Inspector openOn:self
- ]
-!
-
-inspect
- "launch an inspector on the receiver.
- this method (or better: inspectorClass) can be redefined in subclasses
- to start special inspectors."
-
- |cls|
-
- cls := self inspectorClass.
- cls isNil ifTrue:[
- ^ self basicInspect
- ].
- cls openOn:self
-
- "
- Object new inspect
- (1 @ 2) inspect
- Smalltalk inspect
- #(1 2 3) asOrderedCollection inspect
- (Color red) inspect
- (Image fromFile:'bitmaps/garfield.gif') inspect
- "
-!
-
-inspectorClass
- "return the class to use for inspect.
- Can (should) be redefined in classes for which a better inspector is available"
-
- ^ Inspector
-! !
-
-!Object methodsFor:'converting'!
-
-asValue
- "return a valueHolder for for the receiver"
-
- ^ ValueHolder with:self
-! !
-
!Object methodsFor:'accessing'!
at:index
@@ -2251,6 +343,13 @@
^ self basicAt:index
!
+at:index put:anObject
+ "store the 2nd arg, anObject as indexed instvar with index, anInteger.
+ this method can be redefined in subclasses."
+
+ ^ self basicAt:index put:anObject
+!
+
basicAt:index
"return the indexed instance variable with index, anInteger.
Trigger an error if the receiver has no indexed instance variables.
@@ -2339,13 +438,6 @@
^ self subscriptBoundsError:index
!
-at:index put:anObject
- "store the 2nd arg, anObject as indexed instvar with index, anInteger.
- this method can be redefined in subclasses."
-
- ^ self basicAt:index put:anObject
-!
-
basicAt:index put:anObject
"store the 2nd arg, anObject as indexed instvar with index, anInteger.
Trigger an error if the receiver has no indexed instance variables.
@@ -2579,76 +671,291 @@
^ self instVarAt:(self class instVarOffsetOf:name) put:value
! !
-!Object methodsFor:'dependents access'!
-
-dependents
- "return a Collection of dependents - nil if there is none.
- The default implementation here uses a global Dictionary to store
- dependents which may be too slow for high frequency change&update.
- Therefore, some classes (Model) redefine this for better performance."
-
- ^ Dependencies at:self ifAbsent:[nil]
+!Object methodsFor:'binary storage'!
+
+hasSpecialBinaryRepresentation
+ "return true, if the receiver has a special binary representation;
+ default here is false, but can be redefined in class which provide
+ their own storeBinary/readBinary methods.
+
+ Normal user classes should not use this, it is meant as a hook for
+ special classes such as True, False, UndefinedObject or SmallInteger.
+
+ If your instances should be stored in a special way, see
+ #representBinaryOn: and #readBinaryContentsFromdata:manager:."
+
+ ^ false
!
-dependents:aCollection
- "set the collection of dependents.
- The default implementation here uses a global Dictionary to store
- dependents which may be too slow for high frequency change&update.
- Therefore, some classes (Model) redefine this for better performance."
-
- (aCollection isNil or:[aCollection isEmpty]) ifTrue:[
- Dependencies removeKey:self ifAbsent:[]
- ] ifFalse:[
- Dependencies at:self put:aCollection
- ]
+readBinaryContentsFrom:stream manager:manager
+ "reconstruct the receivers instance variables by reading a binary
+ binary representation from stream.
+ This is a general implementation, walking over instances
+ and loading each recursively using manager.
+ Redefined by some classes to read a more compact representations
+ (see String, SmallInteger etc).
+
+ Notice, that the object is already recreated as an empty corps
+ with instance variables all nil and bit-instances (bytes, words etc.)
+ already read and restored.
+
+ Also notice: this method is not called for if a private representation
+ has been stored (see representBinaryOn:).
+ In that case, #readBinaryContentsFromData:manager: is called, which
+ has to be reimplemented in the objects class."
+
+ |size "{ Class: SmallInteger }"
+ instvarArray|
+
+ stream next == 1 ifTrue:[
+ "/
+ "/ special representation ...
+ "/
+ instvarArray := Array new:(size := stream nextNumber:3).
+ 1 to:size do:[:i |
+ instvarArray basicAt:i put:(manager nextObject)
+ ].
+ self readBinaryContentsFromData:instvarArray manager:manager.
+ ^ self
+ ].
+
+ "/
+ "/ standard representation
+ "/
+ size := self basicSize.
+ size ~~ 0 ifTrue:[
+ self class isPointers ifTrue:[
+ 1 to:size do:[:i |
+ self basicAt:i put:(manager nextObject)
+ ]
+ ]
+ ].
+ size := self class instSize.
+ 1 to:size do:[:i |
+ self instVarAt:i put:(manager nextObject)
+ ].
+!
+
+readBinaryContentsFromData:instvarArray manager:manager
+ "reconstruct the receivers instance variables by filling instance
+ variables with values from instvarArray. This array contains the instvars
+ as specified in #representBinaryOn: when the object was stored.
+ It is the receivers responsibility to set its instance variables in the
+ same order from that array."
+
+ ^ self subclassResponsibility
+
+ "typical implementation (see also comment in #representBinaryOn:)
+ (for an object with foo, bar and baz as instance variables,
+ which did not store baz and wants baz to be reinitialized to
+ some constant string)
+
+ foo := instvarArray at:1.
+ bar := instvarArray at:2.
+ baz := 'aConstant'.
+ "
+!
+
+representBinaryOn:manager
+ "this method is called by the storage manager to ask objects
+ if they wish to provide their own binary representation.
+
+ If they want to do so, they should return an array containing all
+ instance variables (named & indexed pointer) to be stored.
+ If not redefined, this method returns nil which means that all
+ instance variables are to be stored.
+
+ It should be redefined in objects which do not want all instance variables
+ to be stored (for example: objects which keep references to a view etc.).
+
+ If this is redefined returning non-nil, the corresponding class needs
+ a redefined instance method named #readBinaryContentsFromData:manager:
+ which has to fill the receivers named (and optionally indexed pointer)
+ instance variables with corresponding values from a data array."
+
+ ^ nil
+
+ "typical implementation:
+ (see also comment in #readBinaryContentsFromData:manager:)
+ for an object with foo, bar and baz as instance variables,
+ which does not want to store baz:
+
+ representBinaryOn:manager
+ |data|
+
+ data := Array new:2.
+ data at:1 put:foo.
+ data at:2 put:bar.
+ ^ data
+ "
!
-dependentsDo:aBlock
- "evaluate aBlock for all of my dependents"
-
- |deps|
-
- deps := self dependents.
- deps notNil ifTrue:[
- deps do:aBlock
- ]
+storeBinaryContentsFromData:instvarArray on:stream manager:manager
+ "store the instvars (both named & indexed pointer)
+ as returned by #representBinaryOn:."
+
+ |size "{ Class: SmallInteger }"|
+
+ size := instvarArray size.
+ 1 to:size do:[:i |
+ manager putIdOf:(instvarArray at:i) on:stream
+ ].
+!
+
+storeBinaryContentsOn:stream manager:manager
+ "store the receivers instance variables in a binary representation
+ on a stream using manager.
+ This is a general implementation, walking over instances
+ and storing each recursively using manager.
+
+ Notice, that the objects definition and bit-instances (bytes, words etc.)
+ are already stored.
+ Here, we only have to deal with indexed-pointer and named instance variables.
+
+ Also notice: this method is not called for if a private representation
+ has been stored (see representBinaryOn:).
+ In that case, #storeBinaryContentsFromData:manager: is called."
+
+ |size "{ Class: SmallInteger }"|
+
+ size := self basicSize.
+ size ~~ 0 ifTrue:[
+ self class isPointers ifTrue:[
+ 1 to:size do:[:i |
+ manager putIdOf:(self basicAt:i) on:stream
+ ].
+ ].
+ ].
+ size := self class instSize.
+ 1 to:size do:[:i |
+ manager putIdOf:(self instVarAt:i) on:stream
+ ].
!
-addDependent:anObject
- "make the argument, anObject be a dependent of the receiver"
-
- |deps|
-
- deps := self dependents.
- deps isNil ifTrue:[
- self dependents:(WeakIdentitySet with:anObject)
- ] ifFalse:[
- deps add:anObject
- ]
-!
-
-removeDependent:anObject
- "make the argument, anObject be independent of the receiver"
-
- |deps|
-
- deps := self dependents.
- deps notNil ifTrue:[
- deps remove:anObject ifAbsent:[].
- deps isEmpty ifTrue:[
- self dependents:nil
+storeBinaryDefinitionBodyOn:stream manager:manager
+ "append a binary representation of the receivers body onto stream.
+ This is a general implementation walking over instances storing
+ each recursively as an ID using manager.
+ Can be redefined in subclasses."
+
+ |basicSize "{ Class: SmallInteger }"
+ instSize "{ Class: SmallInteger }"
+ myClass specialRep pointers|
+
+ myClass := self class.
+ instSize := myClass instSize.
+
+ (pointers := myClass isPointers) ifTrue:[
+ "/
+ "/ inst size not needed - if you uncomment the line below,
+ "/ also uncomment the corresponding line in
+ "/ Object>>binaryDefinitionFrom:manager:
+ "/
+ "/ stream nextPut:instSize. "mhmh this limits us to 255 named instvars"
+
+ myClass isVariable ifTrue:[
+ stream nextNumber:3 put:(basicSize := self basicSize)
+ ] ifFalse:[
+ basicSize := 0
+ ].
+ ] ifFalse: [
+ stream nextNumber:4 put:(basicSize := self basicSize).
+ myClass isBytes ifTrue:[
+ 1 to:basicSize do:[:i |
+ stream nextPut:(self basicAt:i)
+ ]
+ ] ifFalse:[
+ myClass isWords ifTrue:[
+ 1 to:basicSize do:[:i |
+ stream nextNumber:2 put:(self basicAt: i)
+ ]
+ ] ifFalse:[
+ myClass isLongs ifTrue:[
+ 1 to:basicSize do:[:i |
+ stream nextNumber:4 put:(self basicAt: i)
+ ]
+ ] ifFalse:[
+ myClass isFloats ifTrue:[
+ "could do it in one big write on machines which use IEEE floats ..."
+ 1 to:basicSize do:[:i |
+ Float storeBinaryIEEESingle:(self basicAt:i) on:stream
+ ]
+ ] ifFalse:[
+ myClass isDoubles ifTrue:[
+ "could do it in one big write on machines which use IEEE doubles ..."
+ 1 to:basicSize do:[:i |
+ Float storeBinaryIEEEDouble:(self basicAt:i) on:stream
+ ]
+ ] ifFalse:[
+ "/ should never be reached ...
+ 1 to:basicSize do:[:i |
+ manager putIdOf:(self basicAt:i) on:stream
+ ]
+ ]
+ ]
+ ]
+ ]
+ ].
+ ].
+
+ (pointers or:[instSize ~~ 0]) ifTrue:[
+ specialRep := self representBinaryOn:manager.
+ specialRep notNil ifTrue:[
+ stream nextPut:1. "/ means: private representation follows
+ stream nextNumber:3 put:(specialRep basicSize).
+ self storeBinaryContentsFromData:specialRep on:stream manager:manager
+ ] ifFalse:[
+ stream nextPut:0. "/ means: full representation follows
+ self storeBinaryContentsOn:stream manager:manager
]
]
+
+ "Modified: 25.10.1995 / 14:00:51 / cg"
!
-release
- "remove all dependencies from the receiver"
-
- self dependents:nil
+storeBinaryDefinitionOn:stream manager:manager
+ "append a binary representation of the receiver onto stream.
+ This method first stores the class, then the body, which is done
+ in a separate method to allow redefinition of the bodies format.
+ Can be redefined in subclasses to write more compact representations
+ (see String, SmallInteger etc)."
+
+ manager putIdOfClass:(self class) on:stream.
+ self storeBinaryDefinitionBodyOn:stream manager:manager
+!
+
+storeBinaryOn:aStream
+ "Writes a description of the receiver onto aStream, in a way that allows
+ the object's structure to be reconstructed from the stream's contents"
+
+ BinaryOutputManager store:self on:aStream
+!
+
+storeBinaryOn:stream manager:manager
+ "append a binary representation of the receiver onto stream."
+
+ manager putIdOf:self on:stream
! !
!Object methodsFor:'change and update'!
+broadcast:aSelectorSymbol
+ "send a message with selector aSelectorSymbol to all my dependents"
+
+ self dependentsDo:[:dependent |
+ dependent perform:aSelectorSymbol
+ ]
+!
+
+broadcast:aSelectorSymbol with:anArgument
+ "send a message with selector aSelectorSymbol with an additional
+ argument anArgument to all my dependents."
+
+ self dependentsDo:[:dependent |
+ dependent perform:aSelectorSymbol with:anArgument
+ ]
+!
+
changeRequest
"the receiver wants to change - check if all dependents
grant the request, and return true if so"
@@ -2669,6 +976,20 @@
^ true
!
+changeRequest:aParameter from:anObject
+ "the receiver wants to change - check if all dependents
+ except anObject grant the request, and return true if so.
+ The argument anObject is typically going to be the one who is
+ about to send the change request."
+
+ self dependentsDo:[:dependent |
+ dependent == anObject ifFalse:[
+ (dependent updateRequest:aParameter) ifFalse:[^ false].
+ ]
+ ].
+ ^ true
+!
+
changeRequestFrom:anObject
"the receiver wants to change - check if all dependents
except anObject grant the request, and return true if so.
@@ -2683,20 +1004,6 @@
^ true
!
-changeRequest:aParameter from:anObject
- "the receiver wants to change - check if all dependents
- except anObject grant the request, and return true if so.
- The argument anObject is typically going to be the one who is
- about to send the change request."
-
- self dependentsDo:[:dependent |
- dependent == anObject ifFalse:[
- (dependent updateRequest:aParameter) ifFalse:[^ false].
- ]
- ].
- ^ true
-!
-
changed
"notify all dependents that the receiver has changed.
Each dependent gets a '#update:'-message with the original
@@ -2723,23 +1030,6 @@
]
!
-broadcast:aSelectorSymbol
- "send a message with selector aSelectorSymbol to all my dependents"
-
- self dependentsDo:[:dependent |
- dependent perform:aSelectorSymbol
- ]
-!
-
-broadcast:aSelectorSymbol with:anArgument
- "send a message with selector aSelectorSymbol with an additional
- argument anArgument to all my dependents."
-
- self dependentsDo:[:dependent |
- dependent perform:aSelectorSymbol with:anArgument
- ]
-!
-
update:aParameter
"the message is sent to a dependent, when one of the objects
on whom the receiver depends, has changed. The argument aParameter
@@ -2786,63 +1076,1092 @@
^ self updateRequest
! !
-!Object methodsFor:'secure message sending'!
-
-askFor:aSelector
- "try to send the receiver the message, aSelector.
- If it does not understand it, return false. Otherwise
- the real value returned.
- Useful to send messages such as: 'isColor' to unknown
- receivers."
-
- ^ self perform:aSelector ifNotUnderstood:[false]
+!Object methodsFor:'cleanup'!
+
+lowSpaceCleanup
+ "ignored here - redefined in some classes to
+ cleanup in low-memory situations"
+
+ ^ self
+! !
+
+!Object methodsFor:'comparing'!
+
+= anObject
+ "return true, if the receiver and the arg have the same structure"
+
+ ^ self == anObject
+!
+
+== anObject
+ "return true, if the receiver and the arg are the same object"
+
+%{ /* NOCONTEXT */
+
+ RETURN ( (self == anObject) ? true : false );
+%}
+!
+
+hash
+ "return an Integer useful as a hash key for the receiver.
+ This hash should return same values for objects with same
+ contents (i.e. use this to hash on structure)"
+
+ ^ self identityHash
+!
+
+identityHash
+ "return an Integer useful as a hash key for the receiver.
+ This hash should return same values for the same object (i.e. use
+ this to hash on identity of objects).
+
+ We cannot use the Objects address (as other smalltalks do) since
+ no object-table exists and the hashval must not change when objects
+ are moved by the collector. Therefore we assign each object a unique
+ Id in the object header itself as its hashed upon.
+ (luckily we have 11 bits spare to do this - unluckily its only 11 bits).
+ Time will show, if 11 bits are enough; if not, another entry in the
+ object header will be needed, adding 4 bytes to every object. Alternatively,
+ hashed-upon objects could add an instvar containing the hash value."
+
+%{ /* NOCONTEXT */
+
+ REGISTER unsigned hash;
+ static unsigned nextHash = 0;
+ OBJ cls;
+
+ if (__isNonNilObject(self)) {
+ hash = __GET_HASH(self);
+ if (hash == 0) {
+ hash = nextHash++;
+ __SET_HASH(self, hash);
+ hash = __GET_HASH(self);
+ if (hash == 0) {
+ hash = nextHash++;
+ __SET_HASH(self, hash);
+ hash = __GET_HASH(self);
+ }
+ }
+
+ /*
+ * now, we got 11 bits for hashing;
+ * make it as large as possible; since most hashers use the returned
+ * key and take it modulu some prime number, this will allow for
+ * better distribution (i.e. bigger empty spaces) in hashed collection.
+ * we could shift it up to the 30 bit limit - not making it negative.
+ */
+ RETURN ( __MKSMALLINT(hash << __HASH_SHIFT__) );
+ }
+%}.
+ ^ 0 "never reached, since redefined in UndefinedObject and SmallInteger"
+!
+
+isNil
+ "return true, if the receiver is nil"
+
+ ^ false
+!
+
+notNil
+ "return true, if the receiver is not nil"
+
+ ^ true
+!
+
+~= anObject
+ "return true, if the receiver and the arg do not have the same structure"
+
+ ^ (self = anObject) not
+!
+
+~~ anObject
+ "return true, if the receiver and the arg are not the same object"
+
+%{ /* NOCONTEXT */
+
+ RETURN ( (self == anObject) ? false : true );
+%}
+! !
+
+!Object methodsFor:'converting'!
+
+asValue
+ "return a valueHolder for for the receiver"
+
+ ^ ValueHolder with:self
+! !
+
+!Object methodsFor:'copying'!
+
+copy
+ "return a copy of the receiver - defaults to shallowcopy here.
+ Notice, that copy does not copy dependents."
+
+ ^ self shallowCopy postCopy
+!
+
+deepCopy
+ "return a copy of the object with all subobjects also copied.
+ This method DOES handle cycles/self-refs; however the receivers
+ class is not copied (to avoid the 'total' copy).
+ This deepCopy is a bit slower than the old (unsecure) one, since it
+ keeps track of already copied objects. If you are sure, that your
+ copied object does not include dublicates (or you do not care) and
+ no cycles, you can use the old simpleDeepCopy, which avoids this overhead,
+ but may run into trouble.
+ Notice, that copy does not copy dependents."
+
+ ^ self deepCopyUsing:(IdentityDictionary new)
+
+ "an example which is not handled by the old deepCopy:
+
+ |a|
+ a := Array new:3.
+ a at:3 put:a.
+ a deepCopy inspect
+ "
+!
+
+deepCopyError
+ "raise a signal, that deepCopy is not allowed for this object"
+
+ ^ DeepCopyErrorSignal raise
+!
+
+deepCopyUsing:aDictionary
+ "a helper for deepCopy; return a copy of the object with
+ all subobjects also copied. If the to-be-copied object is in the dictionary,
+ use the value found there. The class of the receiver is not copied.
+ This method DOES handle cycles/self references."
+
+ |myClass aCopy
+ sz "{ Class: SmallInteger }"
+ iOrig iCopy|
+
+ myClass := self class.
+ myClass isVariable ifTrue:[
+ sz := self basicSize.
+ aCopy := myClass basicNew:sz.
+ ] ifFalse:[
+ sz := 0.
+ aCopy := myClass basicNew
+ ].
+ aCopy setHashFrom:self.
+
+ aDictionary at:self put:aCopy.
"
- 1 askFor:#isColor
+ copy indexed instvars - if any
+ "
+ sz ~~ 0 ifTrue:[
+ myClass isBits ifTrue:[
+ "block-copy indexed instvars"
+ aCopy replaceFrom:1 to:sz with:self startingAt:1
+ ] ifFalse:[
+ "individual deep copy the indexed variables"
+ 1 to:sz do:[:i |
+ iOrig := self basicAt:i.
+ iOrig notNil ifTrue:[
+ (aDictionary includesKey:iOrig) ifTrue:[
+ iCopy := aDictionary at:iOrig
+ ] ifFalse:[
+ iCopy := iOrig deepCopyUsing:aDictionary.
+ ].
+ aCopy basicAt:i put:iCopy
+ ]
+ ]
+ ]
+ ].
+
+ "
+ copy the instance variables
+ "
+ sz := myClass instSize.
+ sz ~~ 0 ifTrue:[
+ 1 to:sz do:[:i |
+ iOrig := self instVarAt:i.
+ iOrig notNil ifTrue:[
+ (aDictionary includesKey:iOrig) ifTrue:[
+ iCopy := aDictionary at:iOrig
+ ] ifFalse:[
+ iCopy := iOrig deepCopyUsing:aDictionary.
+ ].
+ aCopy instVarAt:i put:iCopy
+ ]
+ ].
+ ].
+
+ ^ aCopy
+!
+
+postCopy
+ "this is for compatibility with ST-80 code, which uses postCopy for
+ cleanup after copying, while ST/X passes the original in postCopyFrom:
+ (see there)"
+
+ ^ self
+!
+
+postCopyFrom:original
+ "sent to a freshly deep-copied object to give it a chance to adjust things.
+ (a font could flush its device-handle for example).
+ Notice, that for Sets/Dicts etc. a rehash is not needed, since the deepCopy
+ will have the same hash key as the receiver (as long as ST/X provides the
+ setHash: functionality)."
+
+ "for ST-80 compatibility, we try postCopy here ..."
+ ^ self postCopy
+!
+
+setHashFrom:anObject
+ "set my identity-hash key to be the same as anObjects hash key.
+ This is an ST/X speciality, which is NOT available in other (especially OT based)
+ Smalltalks, and may not be available in future ST/X versions.
+ DO NEVER use this for normal application code."
+
+%{ /* NOCONTEXT */
+
+ REGISTER unsigned h;
+
+ if (__isNonNilObject(self) && __isNonNilObject(anObject)) {
+ h = __GET_HASH(anObject);
+ __SET_HASH(self, h);
+ RETURN (self);
+ }
+%}
+.
+ self primitiveFailed "neither receiver not arg may be nil or SmallInteger"
+!
+
+shallowCopy
+ "return a copy of the object with shared subobjects (a shallow copy)
+ i.e. the copy shares referenced instvars with its original."
+
+ |myClass aCopy
+ sz "{ Class: SmallInteger }" |
+
+ myClass := self class.
+ myClass isVariable ifTrue:[
+ sz := self basicSize.
+ aCopy := myClass basicNew:sz.
+
+ "copy the indexed variables"
+ 1 to:sz do:[:i |
+ aCopy basicAt:i put:(self basicAt:i)
+ ]
+ ] ifFalse:[
+ aCopy := myClass basicNew
+ ].
+
+ "copy the instance variables"
+ sz := myClass instSize.
+ 1 to:sz do:[:i |
+ aCopy instVarAt:i put:(self instVarAt:i)
+ ].
+
+ ^ aCopy
+!
+
+shallowCopyForFinalization
+ "this is used to aquire a copy to be used for finalization -
+ (the copy will get a dispose-notification; see the documentation in the Registry class)
+ This method can be redefined for more efficient copying - especially for large objects."
+
+ ^ self shallowCopy
+!
+
+simpleDeepCopy
+ "return a copy of the object with all subobjects also copied.
+ This method does NOT handle cycles - but is included to allow this
+ slightly faster copy in situations where it is known that
+ no recursive references occur (LargeIntegers for example).
+ NOTICE: you will run into trouble, when trying this with recursive
+ objects (usually recursionInterrupt or memory-alert).
+ This method corresponds to the 'traditional' deepCopy found in
+ the Blue book."
+
+ |myClass aCopy
+ sz "{ Class: SmallInteger }" |
+
+ myClass := self class.
+ myClass isVariable ifTrue:[
+ sz := self basicSize.
+ aCopy := myClass basicNew:sz.
+
+ "copy the indexed variables"
+ 1 to:sz do:[:i |
+ aCopy basicAt:i put:((self basicAt:i) simpleDeepCopy)
+ ]
+ ] ifFalse:[
+ aCopy := myClass basicNew
+ ].
+
+ "copy the instance variables"
+ sz := myClass instSize.
+ 1 to:sz do:[:i |
+ aCopy instVarAt:i put:((self instVarAt:i) simpleDeepCopy)
+ ].
+
+ ^ aCopy
+
+ "a bad example (but ST/X should survive ...)"
+ "
+ |a|
+ a := Array new:3.
+ a at:3 put:a.
+ a simpleDeepCopy
+ "
+! !
+
+!Object methodsFor:'debugging'!
+
+basicInspect
+ "launch an inspector on the receiver.
+ this method should NOT be redefined in subclasses."
+
+ Inspector isNil ifTrue:[
+ "
+ for systems without GUI
+ "
+ Transcript showCr:'no Inspector'
+ ] ifFalse:[
+ Inspector openOn:self
+ ]
+!
+
+inspect
+ "launch an inspector on the receiver.
+ this method (or better: inspectorClass) can be redefined in subclasses
+ to start special inspectors."
+
+ |cls|
+
+ cls := self inspectorClass.
+ cls isNil ifTrue:[
+ ^ self basicInspect
+ ].
+ cls openOn:self
+
+ "
+ Object new inspect
+ (1 @ 2) inspect
+ Smalltalk inspect
+ #(1 2 3) asOrderedCollection inspect
+ (Color red) inspect
+ (Image fromFile:'bitmaps/garfield.gif') inspect
"
!
-perform:aSelector ifNotUnderstood:exceptionBlock
- "try to send message aSelector to the receiver.
- If its understood, return the methods returned value,
- otherwise return the value of the exceptionBlock"
-
- |val|
-
- MessageNotUnderstoodSignal handle:[:ex |
- ^ exceptionBlock value
- ] do:[
- val := self perform:aSelector
+inspectorClass
+ "return the class to use for inspect.
+ Can (should) be redefined in classes for which a better inspector is available"
+
+ ^ Inspector
+!
+
+mustBeKindOf:aClass
+ "for compatibility & debugging support:
+ check if the receiver isKindOf:aClass and raise an error if not.
+ Notice:
+ it is VERY questionable, if it makes sense to add manual
+ type checks to a dynamically typed language like smalltalk.
+ It will, at least, slow down performance,
+ make your code less reusable and clutter your code with stupid sends
+ of this selector. Also, read the comment in isKindOf:, regarding the
+ use of isXXX check methods.
+ You see: The author does not like this at all ..."
+
+ (self isKindOf:aClass) ifFalse:[
+ self error:'argument is not of expected type'
+ ]
+!
+
+obsoleteMethodWarning
+ "in methods which are going to be obsoleted, a self send to
+ this method is used to tell programmers that a method is
+ used which is going to be removed in later ST/X versions.
+ Find all methods which will be obsolete soon by looking at senders
+ of this message.
+ Hopefully, this warning message is annoying enough for you to
+ change the code ... ;-)"
+
+ self obsoleteMethodWarning:nil from:thisContext sender
+!
+
+obsoleteMethodWarning:message
+ "in methods which are going to be obsoleted, a self send to
+ this method is used to tell programmers that a method is
+ used which is going to be removed in later ST/X versions.
+ Find all methods which will be obsolete soon by looking at senders
+ of this message.
+ Hopefully, this warning message is annoying enough for you to
+ change the code ... ;-)"
+
+ self obsoleteMethodWarning:message from:thisContext sender
+!
+
+obsoleteMethodWarning:message from:aContext
+ "in methods which are going to be obsoleted, a self-send to
+ this method is used to tell programmers that a method is
+ used which is going to be removed in later ST/X versions.
+ Find all methods which will be obsolete soon by looking at senders
+ of this message.
+ Hopefully, this warning message is annoying enough for you to
+ change the code ... ;-)"
+
+ |spec|
+
+ spec := aContext methodPrintString.
+ ('WARNING: the ''' , spec , ''' method is obsolete.') errorPrintNL.
+ (' And may not be present in future ST/X versions.') errorPrintNL.
+ (' called from ' , aContext sender printString) errorPrintNL.
+ message notNil ifTrue:[
+ '------> ' errorPrint. message errorPrintNL
+ ]
+
+ "
+ Object obsoleteMethodWarning:'foo' from:thisContext sender sender
+ "
+! !
+
+!Object methodsFor:'dependents access'!
+
+addDependent:anObject
+ "make the argument, anObject be a dependent of the receiver"
+
+ |deps|
+
+ deps := self dependents.
+ deps isNil ifTrue:[
+ self dependents:(WeakIdentitySet with:anObject)
+ ] ifFalse:[
+ deps add:anObject
+ ]
+!
+
+dependents
+ "return a Collection of dependents - nil if there is none.
+ The default implementation here uses a global Dictionary to store
+ dependents which may be too slow for high frequency change&update.
+ Therefore, some classes (Model) redefine this for better performance."
+
+ ^ Dependencies at:self ifAbsent:[nil]
+!
+
+dependents:aCollection
+ "set the collection of dependents.
+ The default implementation here uses a global Dictionary to store
+ dependents which may be too slow for high frequency change&update.
+ Therefore, some classes (Model) redefine this for better performance."
+
+ (aCollection isNil or:[aCollection isEmpty]) ifTrue:[
+ Dependencies removeKey:self ifAbsent:[]
+ ] ifFalse:[
+ Dependencies at:self put:aCollection
+ ]
+!
+
+dependentsDo:aBlock
+ "evaluate aBlock for all of my dependents"
+
+ |deps|
+
+ deps := self dependents.
+ deps notNil ifTrue:[
+ deps do:aBlock
+ ]
+!
+
+release
+ "remove all dependencies from the receiver"
+
+ self dependents:nil
+!
+
+removeDependent:anObject
+ "make the argument, anObject be independent of the receiver"
+
+ |deps|
+
+ deps := self dependents.
+ deps notNil ifTrue:[
+ deps remove:anObject ifAbsent:[].
+ deps isEmpty ifTrue:[
+ self dependents:nil
+ ]
+ ]
+! !
+
+!Object methodsFor:'error handling'!
+
+appropriateDebugger:aSelector
+ "return an appropriate debugger to use.
+ If there is already a debugger active on the stack, and it is
+ the DebugView, return MiniDebugger (as a last chance) otherwise abort."
+
+ |context|
+
+ context := thisContext.
+ context := context sender.
+ [context notNil] whileTrue:[
+ ((context receiver class == Debugger)
+ and:[context selector == aSelector]) ifTrue:[
+ "we are already in some Debugger"
+ (Debugger == MiniDebugger) ifTrue:[
+ "we are already in the MiniDebugger"
+ ErrorRecursion ifFalse:[
+ Smalltalk fatalAbort:'recursive error ...'
+ ]
+ ].
+ MiniDebugger isNil ifTrue:[
+ Smalltalk fatalAbort:'no debugger'
+ ].
+
+ "ok, an error occured while in the graphical debugger;
+ lets try MiniDebugger"
+ ^ MiniDebugger
+ ].
+ context := context sender
].
- ^ val
+ "not within Debugger - no problem"
+ ^ Debugger
+!
+
+doesNotUnderstand:aMessage
+ "this message is sent by the runtime system (VM) when
+ a message is not understood by some object (i.e. there
+ is no method for that selector). The original message has
+ been packed into aMessage (i.e. the receiver, selector and
+ any arguments) and the original receiver is then sent the
+ #doesNotUnderstand: message.
+ Here, we raise another signal which usually enters the debugger.
+ You can of course redefine #doesNotUnderstand: in your classes
+ to implement message delegation."
+
+ |sel errorString cls sender|
+
+ "/ handle the case of an error during early startup
+ "/ (output streams not yet initialized)
+ "/
+ Stdout isNil ifTrue:[
+ Smalltalk fatalAbort:'error during init phase'.
+ ].
+
+ (sel := aMessage selector) isNil ifTrue:[
+ "/
+ "/ happens when things go mad, or a method has been
+ "/ called by valueWithReceiver: with a wrong receiver
+ "/ to avoud later trouble (when concatenating strings),
+ "/ replace the selector by some (nonNil) string
+ "/
+ sel := '(nil)'
+ ].
+
+ "/
+ "/ extract the class that should have implemented the message.
+ "/ (in case of a super-send, this is not the receivers class)
+ "/
+ sender := thisContext sender.
+ cls := sender searchClass.
+ cls isNil ifTrue:[
+ "it was NOT a super or directed send ..."
+ cls := self class
+ ].
+
+ cls notNil ifTrue:[
+ "/
+ "/ displayString is better than 'cls name',
+ "/ since it appends (obsolete) for outdated classes.
+ "/ (this happens if you send messages to old instances
+ "/ after changing a classes definition)
+ "/
+ errorString := cls displayString.
+ ] ifFalse:[
+ errorString := '(** nil-class **)'
+ ].
+ errorString := errorString , ' does not understand: ' , sel.
+
+ "/
+ "/ this only happens, when YOU play around with my classvars ...
+ "/ (or an error occurs during early startup, when signals are not yet set)
+ "/
+ MessageNotUnderstoodSignal isNil ifTrue:[
+ ^ self enterDebuggerWith:nil
+ message:'oops - MessageNotUnderstoodSignal is gone'.
+ ].
+
+ "/
+ "/ thats where we end up normally - raise a signal which (if unhandled) opens a debugger
+ "/
+ ^ MessageNotUnderstoodSignal
+ raiseRequestWith:aMessage
+ errorString:errorString
+ in:sender
+
+ "Modified: 9.12.1995 / 17:25:37 / cg"
+!
+
+elementBoundsError
+ "report error that badElement is out of bounds
+ (i.e. cannot be put into that collection)"
+
+ ^ ElementOutOfBoundsSignal raiseIn:thisContext sender
+!
+
+elementNotCharacter
+ "report error that object to be stored is no Character.
+ (usually when storing into Strings)"
+
+ ^ ElementOutOfBoundsSignal raiseIn:thisContext sender
+!
+
+elementNotInteger
+ "report error that object to be stored is not Integer.
+ (in collections that store integers only)"
+
+ ^ ElementOutOfBoundsSignal raiseIn:thisContext sender
+!
+
+enterDebuggerWith:anException message:aString
+ "enter the debugger with error-message aString"
+
+ ^ self enterDebuggerWith:anException
+ message:aString
+ on:anException suspendedContext
+!
+
+enterDebuggerWith:anException message:aString on:aContext
+ "enter the debugger with error-message aString.
+ The first visible context shown there is aContext
+ (this allows intermediate helpers to hide themselfes from what is
+ presented to the user)"
+
+ |debugger|
"
- 1.2345 perform:#foo ifNotUnderstood:['sorry']
+ if there is no debugger, exit smalltalk
+ "
+ Debugger isNil ifTrue:[
+ 'error: ' errorPrint. aString errorPrintNL.
+ Smalltalk fatalAbort:'no Debugger defined'
+ ].
+ "
+ find an appropriate debugger to use
"
+ debugger := self appropriateDebugger:#'enter:withMessage:'.
+ ^ debugger enter:aContext withMessage:aString.
+!
+
+error
+ "report error that an error occured"
+
+ ^ ErrorSignal raiseIn:thisContext sender
+!
+
+error:aString
+ "enter debugger with error-message aString"
+
+ ^ ErrorSignal raiseRequestWith:#error:
+ errorString:aString
+ in:thisContext sender
+!
+
+errorKeyNotFound:aKey
+ "report error that a key was not found in a collection"
+
+ ^ KeyNotFoundSignal raiseRequestWith:aKey in:thisContext sender
+!
+
+errorNotFound
+ "report error that no element was found in a collection"
+
+ ^ NotFoundSignal raiseIn:thisContext sender
+!
+
+halt
+ "enter debugger with halt-message"
+
+ ^ HaltSignal raiseIn:thisContext sender.
+!
+
+halt:aString
+ "enter debugger with halt-message"
+
+ ^ HaltSignal raiseRequestWith:#halt:
+ errorString:aString
+ in:thisContext sender
+!
+
+implementedBySubclass
+ "this is sent by ST/V code - its the same as #subclassResponsibility"
+
+ ^ self subclassResponsibility
+!
+
+indexNotInteger
+ "report error that index is not an Integer.
+ (when accessing collections indexed by an integer key)"
+
+ ^ NonIntegerIndexSignal raiseIn:thisContext sender
+!
+
+integerCheckError
+ "generated when a variable declared with an integer type gets a bad
+ value assigned"
+
+ ^ self error:'bad assign of ' , self printString ,
+ ' (' , self class name , ') to integer-typed variable'
!
-perform:aSelector with:argument ifNotUnderstood:exceptionBlock
- "try to send message aSelector to the receiver.
- If its understood, return the methods returned value,
- otherwise return the value of the exceptionBlock"
-
- |val|
-
- MessageNotUnderstoodSignal handle:[:ex |
- ^ exceptionBlock value
- ] do:[
- val := self perform:aSelector with:argument
- ].
- ^ val
+invalidMessage
+ "this is sent by ST/V code - its the same as #shouldNotImplement"
+
+ ^ self shouldNotImplement
+!
+
+mustBeRectangle
+ "report an argument-not-rectangle-error"
+
+ ^ self error:'argument must be a Rectangle'
+!
+
+mustBeString
+ "report an argument-not-string-error"
+
+ ^ self error:'argument must be a String'
+!
+
+notIndexed
+ "report error that receiver has no indexed instance variables"
+
+ ^ self error:'receiver has no indexed variables'
+!
+
+primitiveFailed
+ "report error that primitive code failed"
+
+ ^ PrimitiveFailureSignal raiseIn:(thisContext sender)
+!
+
+shouldNotImplement
+ "report error that this message should not be implemented"
+
+ ^ self error:'method not appropriate for this class'
+!
+
+subclassResponsibility
+ "report error that this message should have been reimplemented in a
+ subclass"
+
+ ^ self error:'method must be reimplemented in subclass'
+!
+
+subscriptBoundsError
+ "report error that some index is out of bounds.
+ (when accessing indexable collections)"
+
+ ^ SubscriptOutOfBoundsSignal raiseIn:thisContext sender
+!
+
+subscriptBoundsError:anIndex
+ "report error that anIndex is out of bounds.
+ (when accessing indexable collections)"
+
+ ^ SubscriptOutOfBoundsSignal raiseRequestWith:anIndex in:thisContext sender
+!
+
+typeCheckError
+ "generated when a variable declared with a type hint gets a bad
+ value assigned"
+
+ ^ self error:'bad assign of ' , self printString ,
+ ' (' , self class name , ') to typed variable'
+! !
+
+!Object methodsFor:'evaluation'!
+
+value
+ "this allows every object to be used where blocks are typically used.
+ Time will show, if this is a good idea or leads to sloppy programming
+ style ... (the idea was borrowed from the Self language).
+ WARNING: dont 'optimize' away ifXXX: blocks - the compilers will
+ only generate inline code for the if, if the argument(s) are blocks.
+ It will work, but run slower instead."
+
+ ^ self
"
- |unknown|
-
- unknown := 1.
- (unknown perform:#+ with:2 ifNotUnderstood:['sorry']) printNewline.
- unknown := 'high there'.
- (unknown perform:#+ with:2 ifNotUnderstood:['sorry']) printNewline.
+ #(1 2 3 4) indexOf:5 ifAbsent:0
+ "
+
+ "DO NOT DO THIS (its slower)
+ (1 > 4) ifTrue:'oops' ifFalse:'ok'
+
+ USE (the compiler optimizes blocks in if/while):
+ (1 > 4) ifTrue:['oops'] ifFalse:['ok']
+ "
+! !
+
+!Object methodsFor:'initialization'!
+
+initialize
+ "just to ignore initialize to objects which do not need it"
+
+ ^ self
+! !
+
+!Object methodsFor:'interrupt handling'!
+
+childSignalInterrupt
+ "death of a child process (unix process) - do nothing"
+
+ ^ self
+!
+
+customInterrupt
+ "a custom interrupt"
+
+ ^ self error:'custom interrupt'
+!
+
+errorInterrupt:errorID with:aParameter
+ "subsystem error. The arguments errorID and aParameter are the values passed
+ to the 'errorInterruptWithIDAndParameter(id, param)' function,
+ which can be called from C subsystems to raise an (asynchronous)
+ error exception.
+
+ Currently, this is used to map XErrors to smalltalk errors, but can be
+ used from other C subsystems too, to upcast errors.
+ Especially, for subsystems which call errorHandler functions asynchronously.
+ IDs (currently) used:
+ #DisplayError ..... x-error interrupt
+ #XtError ..... xt-error interrupt (Xt interface is not yet published)
"
+
+ |handler|
+
+ handler := ObjectMemory registeredErrorInterruptHandlers at:errorID ifAbsent:nil.
+ handler notNil ifTrue:[
+ "/
+ "/ handler found; let it do whatever it wants ...
+ "/
+ handler errorInterrupt:errorID with:aParameter.
+ ^ self
+ ].
+
+ "/
+ "/ no handler - raise errorSignal passing the errorId as parameter
+ "/
+ ^ ErrorSignal
+ raiseRequestWith:errorID
+ errorString:('Subsystem error. ErrorID = ' , errorID printString)
+!
+
+exceptionInterrupt
+ "exception interrupt - enter debugger"
+
+ self error:'exception Interrupt'
+!
+
+fpExceptionInterrupt
+ "a floating point exception occured - this one
+ has to be handled differently since it comes asynchronous
+ on some machines (for example, on machines with a separate FPU
+ or superscalar architectures. Also, errors from within primitive code
+ (or library functions such as GL) are sent via the Unix-signal
+ mechanism this way."
+
+ ^ Float domainErrorSignal raise
+!
+
+internalError:msg
+ "this is triggered, when system hits some bad error,
+ such as corrupted class, corrupted method/selector array
+ etc. The argument string gives some more information on what happened.
+ (for example, if you set an objects class to a smallInteger, nil etc).
+ Its not guaranteed, that the system is in a working condition once
+ this error occurred ...."
+
+ ^ self error:msg
+!
+
+ioInterrupt
+ "I/O (SIGIO/SIGPOLL) interrupt (supposed to be sent to Processor).
+ If we arrive here, there is either no handler (ObjMem>>ioInterruptHandler)
+ or it does not understand the ioInterrupt message.
+ In any case, this is a sign of some big trouble. Enter debugger."
+
+ self error:'I/O Interrupt - but no handler'
+!
+
+memoryInterrupt
+ "out-of-memory interrupt and no handler - enter debugger"
+
+ ^ self error:'almost out of memory'
+!
+
+recursionInterrupt
+ "recursion limit (actually: stack overflow) interrupt.
+ This interrupt is triggered, when a process stack grows above
+ its stackLimit - usually, this leads into the debugger, but
+ could be cought and the stackLimit increased in the handler.
+ At the time we arrive here, the system has still some stack
+ as a reserve so we can continue to do some useful work or cleanup or
+ debugging for a while.
+ If the signal is ignored, and the stack continues to grow, there
+ will be a few more chances (and more interrupts) before the VM
+ hard-terminates the process."
+
+ thisContext isRecursive ifFalse:[
+ ^ RecursionInterruptSignal raise
+ ]
+!
+
+schedulerInterrupt
+ "scheduler interrupt (supposed to be sent to Processor).
+ If we arrive here, either the Processor does not understand it,
+ or it has been set to nil. In any case, this is a sign of some
+ big trouble. Enter debugger."
+
+ self error:'schedulerInterrupt - but no Processor'
+!
+
+signalInterrupt:signalNumber
+ "unix signal occured - some signals are handled as Smalltalk Exceptions
+ (SIGPIPE), others (SIGBUS) are rather fatal ...
+ In any case, if a smalltalk-signal has been connected to the OS signal,
+ that one is raised.
+ TODO: add another argument, giving more detailed signal info (PC, VADDR,
+ exact cause etc.). This helps if segvs occur in primitive code.
+ Currently (temporary kludge), these are passed as global variables."
+
+ |box name here sig ignorable titles actions badContext msg pc addr|
+
+ "
+ special case - since SIGPIPE has an ST-signal associated
+ "
+ (signalNumber == 13) ifTrue:[
+ "SIGPIPE - write on a pipe with no one to read"
+
+ ^ PipeStream brokenPipeSignal raise.
+ ].
+
+ "if there has been an ST-signal installed, use it ..."
+
+ sig := OperatingSystem operatingSystemSignal:signalNumber.
+ sig notNil ifTrue:[
+ ^ sig raise
+ ].
+
+ "
+ ... otherwise , bring up a box asking for what to do ...
+ "
+ name := OperatingSystem nameForSignal:signalNumber.
+ here := thisContext.
+
+ "
+ the context, in which the signal occurred:
+ "
+ badContext := here sender.
+
+ "
+ ungrab - in case it happened in a box/popupview
+ otherwise display stays locked
+ "
+ Display notNil ifTrue:[
+ Display ungrabPointer.
+ ].
+
+ "
+ SIGBUS, SIGSEGV and SIGILL do not make sense to ignore (i.e. continue)
+ since the system will retry the faulty instruction, which leads to
+ another signal - to avoid frustration, better not offer this option.
+ "
+ ignorable := (signalNumber ~~ OperatingSystem sigBUS)
+ and:[signalNumber ~~ OperatingSystem sigILL
+ and:[signalNumber ~~ OperatingSystem sigSEGV]].
+
+ ignorable ifFalse:[
+ here isRecursive ifTrue:[
+ 'fatal: signal ' errorPrint. signalNumber errorPrintNL.
+ MiniDebugger enterWithMessage:'recursive signal'.
+ ^ self
+ ].
+ "
+ a hard signal - go into debugger immediately
+ "
+ msg := 'Signal ', name.
+ InterruptPcLow notNil ifTrue:[
+ pc := InterruptPcLow + (InterruptPcHi bitShift:16).
+ pc ~~ 0 ifTrue:[
+ msg := msg , ' PC=' , (pc printStringRadix:16)
+ ].
+ ].
+ InterruptAddrLow notNil ifTrue:[
+ addr := InterruptAddrLow + (InterruptAddrHi bitShift:16).
+ addr ~~ 0 ifTrue:[
+ msg := msg , ' ADDR=' , (addr printStringRadix:16)
+ ].
+ ].
+ Debugger enter:here withMessage:msg.
+ badContext return.
+ ^ nil.
+ ].
+
+ OptionBox isNil ifTrue:[
+ "
+ a system without GUI ...
+ go into minidebugger (if there is one)
+ "
+ MiniDebugger isNil ifTrue:[
+ "
+ a system without debugging facilities
+ (i.e. a standalone system)
+ output a message and exit.
+ "
+ ('exit due to Signal ' , name) errorPrintNL.
+ Smalltalk exit.
+ ].
+ MiniDebugger enterWithMessage:'Signal cought (' , name, ')'.
+ ^ self
+ ].
+
+ box := OptionBox
+ title:'Signal cought (' , name, ')'
+ numberOfOptions:(ignorable ifTrue:[5] ifFalse:[4]).
+
+ titles := #('return' 'debug' 'dump' 'exit').
+ actions := Array
+ with:[badContext return]
+ with:[Debugger enter:here withMessage:('Signal ', name). ^nil]
+ with:[Smalltalk fatalAbort]
+ with:[Smalltalk exit].
+
+ ignorable ifTrue:[
+ titles := #('ignore') , titles.
+ actions := (Array with:[^ nil]) , actions.
+ ].
+ box buttonTitles:titles.
+ box actions:actions.
+ box showAtPointer
+!
+
+spyInterrupt
+ "spy interrupt and no handler - enter debugger"
+
+ self error:'spy Interrupt - but no handler'
+!
+
+timerInterrupt
+ "timer interrupt and no handler - enter debugger"
+
+ self error:'timer Interrupt - but no handler'
+!
+
+userInterrupt
+ "user (^c) interrupt - enter debugger"
+
+ UserInterruptSignal raise
! !
!Object methodsFor:'message sending'!
@@ -2901,6 +2220,133 @@
%}
!
+perform:aSelector inClass:aClass withArguments:argArray
+ "send the message aSelector with all args taken from argArray
+ to the receiver as a super-send message.
+ This is actually more flexible than the normal super-send, since it allows
+ to execute a method in ANY superclass of the receiver (not just the
+ immediate superclass).
+ Thus, it is (theoretically) possible to do
+ '5 perform:#< inClass:Magnitude withArguments:#(6)'
+ and evaluate Magnitudes compare method even if there was one in Number.
+ This method is used by the interpreter to evaluate super sends
+ and could be used for very special behavior (language extension ?).
+
+ WARNING: this is an ST/X feature - probably not found in other smalltalks."
+
+ |numberOfArgs a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15|
+
+ "
+ check, if aClass is really a superclass of the receiver
+ "
+ (self class isSubclassOf:aClass) ifFalse:[
+ self error:'class argument is not a superclass of the receiver'.
+ ^ nil
+ ].
+ numberOfArgs := argArray size.
+%{
+ extern OBJ Array, __AT_();
+ REGISTER OBJ *argP;
+ int nargs, i;
+ static struct inlineCache ilc0 = _DUMMYILC0;
+ static struct inlineCache ilc1 = _DUMMYILC1;
+ static struct inlineCache ilc2 = _DUMMYILC2;
+ static struct inlineCache ilc3 = _DUMMYILC3;
+ static struct inlineCache ilc4 = _DUMMYILC4;
+ static struct inlineCache ilc5 = _DUMMYILC5;
+ static struct inlineCache ilc6 = _DUMMYILC6;
+ static struct inlineCache ilc7 = _DUMMYILC7;
+ static struct inlineCache ilc8 = _DUMMYILC8;
+ static struct inlineCache ilc9 = _DUMMYILC9;
+ static struct inlineCache ilc10 = _DUMMYILC10;
+ static struct inlineCache ilc11 = _DUMMYILC11;
+ static struct inlineCache ilc12 = _DUMMYILC12;
+ static struct inlineCache ilc13 = _DUMMYILC13;
+ static struct inlineCache ilc14 = _DUMMYILC14;
+ static struct inlineCache ilc15 = _DUMMYILC15;
+
+ if (__isSmallInteger(numberOfArgs)) {
+ nargs = __intVal(numberOfArgs);
+ if (nargs == 0) {
+ RETURN (_SEND0(self, aSelector, CON_COMMA aClass, &ilc0));
+ }
+
+ argP = (OBJ *)(&a1);
+ if (__Class(argArray) == Array) {
+ for (i=0; i < nargs; i++) {
+ *argP++ = _ArrayInstPtr(argArray)->a_element[i];
+ }
+ } else {
+ for (i=1; i <= nargs; i++) {
+ *argP++ = __AT_(argArray, CON_COMMA __MKSMALLINT(i));
+ }
+ }
+ switch (nargs) {
+ case 1:
+ RETURN ( _SEND1(self, aSelector, CON_COMMA aClass, &ilc1, a1));
+
+ case 2:
+ RETURN ( _SEND2(self, aSelector, CON_COMMA aClass, &ilc2, a1, a2));
+
+ case 3:
+ RETURN ( _SEND3(self, aSelector, CON_COMMA aClass, &ilc3, a1, a2, a3));
+
+ case 4:
+ RETURN ( _SEND4(self, aSelector, CON_COMMA aClass, &ilc4, a1, a2, a3, a4));
+
+ case 5:
+ RETURN ( _SEND5(self, aSelector, CON_COMMA aClass, &ilc5,
+ a1, a2, a3, a4, a5));
+
+ case 6:
+ RETURN ( _SEND6(self, aSelector, CON_COMMA aClass, &ilc6,
+ a1, a2, a3, a4, a5, a6));
+
+ case 7:
+ RETURN ( _SEND7(self, aSelector, CON_COMMA aClass, &ilc7,
+ a1, a2, a3, a4, a5, a6, a7));
+
+ case 8:
+ RETURN ( _SEND8(self, aSelector, CON_COMMA aClass, &ilc8,
+ a1, a2, a3, a4, a5, a6, a7, a8));
+
+ case 9:
+ RETURN ( _SEND9(self, aSelector, CON_COMMA aClass, &ilc9,
+ a1, a2, a3, a4, a5, a6, a7, a8, a9));
+
+ case 10:
+ RETURN ( _SEND10(self, aSelector, CON_COMMA aClass, &ilc10,
+ a1, a2, a3, a4, a5, a6, a7, a8, a9, a10));
+
+ case 11:
+ RETURN ( _SEND11(self, aSelector, CON_COMMA aClass, &ilc11,
+ a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11));
+
+ case 12:
+ RETURN ( _SEND12(self, aSelector, CON_COMMA aClass, &ilc12,
+ a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12));
+
+ case 13:
+ RETURN ( _SEND13(self, aSelector, CON_COMMA aClass, &ilc13,
+ a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12,
+ a13));
+
+ case 14:
+ RETURN ( _SEND14(self, aSelector, CON_COMMA aClass, &ilc14,
+ a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12,
+ a13, a14));
+
+ case 15:
+ RETURN ( _SEND15(self, aSelector, CON_COMMA aClass, &ilc15,
+ a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12,
+ a13, a14, a15));
+ }
+ }
+%}
+.
+ ^ self primitiveFailed
+!
+
perform:aSelector with:anObject
"send the one-arg-message aSelector to the receiver"
@@ -3315,399 +2761,15 @@
%}
.
^ self primitiveFailed
-!
-
-perform:aSelector inClass:aClass withArguments:argArray
- "send the message aSelector with all args taken from argArray
- to the receiver as a super-send message.
- This is actually more flexible than the normal super-send, since it allows
- to execute a method in ANY superclass of the receiver (not just the
- immediate superclass).
- Thus, it is (theoretically) possible to do
- '5 perform:#< inClass:Magnitude withArguments:#(6)'
- and evaluate Magnitudes compare method even if there was one in Number.
- This method is used by the interpreter to evaluate super sends
- and could be used for very special behavior (language extension ?).
-
- WARNING: this is an ST/X feature - probably not found in other smalltalks."
-
- |numberOfArgs a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15|
-
- "
- check, if aClass is really a superclass of the receiver
- "
- (self class isSubclassOf:aClass) ifFalse:[
- self error:'class argument is not a superclass of the receiver'.
- ^ nil
- ].
- numberOfArgs := argArray size.
-%{
- extern OBJ Array, __AT_();
- REGISTER OBJ *argP;
- int nargs, i;
- static struct inlineCache ilc0 = _DUMMYILC0;
- static struct inlineCache ilc1 = _DUMMYILC1;
- static struct inlineCache ilc2 = _DUMMYILC2;
- static struct inlineCache ilc3 = _DUMMYILC3;
- static struct inlineCache ilc4 = _DUMMYILC4;
- static struct inlineCache ilc5 = _DUMMYILC5;
- static struct inlineCache ilc6 = _DUMMYILC6;
- static struct inlineCache ilc7 = _DUMMYILC7;
- static struct inlineCache ilc8 = _DUMMYILC8;
- static struct inlineCache ilc9 = _DUMMYILC9;
- static struct inlineCache ilc10 = _DUMMYILC10;
- static struct inlineCache ilc11 = _DUMMYILC11;
- static struct inlineCache ilc12 = _DUMMYILC12;
- static struct inlineCache ilc13 = _DUMMYILC13;
- static struct inlineCache ilc14 = _DUMMYILC14;
- static struct inlineCache ilc15 = _DUMMYILC15;
-
- if (__isSmallInteger(numberOfArgs)) {
- nargs = __intVal(numberOfArgs);
- if (nargs == 0) {
- RETURN (_SEND0(self, aSelector, CON_COMMA aClass, &ilc0));
- }
-
- argP = (OBJ *)(&a1);
- if (__Class(argArray) == Array) {
- for (i=0; i < nargs; i++) {
- *argP++ = _ArrayInstPtr(argArray)->a_element[i];
- }
- } else {
- for (i=1; i <= nargs; i++) {
- *argP++ = __AT_(argArray, CON_COMMA __MKSMALLINT(i));
- }
- }
- switch (nargs) {
- case 1:
- RETURN ( _SEND1(self, aSelector, CON_COMMA aClass, &ilc1, a1));
-
- case 2:
- RETURN ( _SEND2(self, aSelector, CON_COMMA aClass, &ilc2, a1, a2));
-
- case 3:
- RETURN ( _SEND3(self, aSelector, CON_COMMA aClass, &ilc3, a1, a2, a3));
-
- case 4:
- RETURN ( _SEND4(self, aSelector, CON_COMMA aClass, &ilc4, a1, a2, a3, a4));
-
- case 5:
- RETURN ( _SEND5(self, aSelector, CON_COMMA aClass, &ilc5,
- a1, a2, a3, a4, a5));
-
- case 6:
- RETURN ( _SEND6(self, aSelector, CON_COMMA aClass, &ilc6,
- a1, a2, a3, a4, a5, a6));
-
- case 7:
- RETURN ( _SEND7(self, aSelector, CON_COMMA aClass, &ilc7,
- a1, a2, a3, a4, a5, a6, a7));
-
- case 8:
- RETURN ( _SEND8(self, aSelector, CON_COMMA aClass, &ilc8,
- a1, a2, a3, a4, a5, a6, a7, a8));
-
- case 9:
- RETURN ( _SEND9(self, aSelector, CON_COMMA aClass, &ilc9,
- a1, a2, a3, a4, a5, a6, a7, a8, a9));
-
- case 10:
- RETURN ( _SEND10(self, aSelector, CON_COMMA aClass, &ilc10,
- a1, a2, a3, a4, a5, a6, a7, a8, a9, a10));
-
- case 11:
- RETURN ( _SEND11(self, aSelector, CON_COMMA aClass, &ilc11,
- a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11));
-
- case 12:
- RETURN ( _SEND12(self, aSelector, CON_COMMA aClass, &ilc12,
- a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12));
-
- case 13:
- RETURN ( _SEND13(self, aSelector, CON_COMMA aClass, &ilc13,
- a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12,
- a13));
-
- case 14:
- RETURN ( _SEND14(self, aSelector, CON_COMMA aClass, &ilc14,
- a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12,
- a13, a14));
-
- case 15:
- RETURN ( _SEND15(self, aSelector, CON_COMMA aClass, &ilc15,
- a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12,
- a13, a14, a15));
- }
- }
-%}
-.
- ^ self primitiveFailed
! !
-!Object methodsFor:'binary storage'!
-
-storeBinaryOn:aStream
- "Writes a description of the receiver onto aStream, in a way that allows
- the object's structure to be reconstructed from the stream's contents"
-
- BinaryOutputManager store:self on:aStream
-!
-
-hasSpecialBinaryRepresentation
- "return true, if the receiver has a special binary representation;
- default here is false, but can be redefined in class which provide
- their own storeBinary/readBinary methods.
-
- Normal user classes should not use this, it is meant as a hook for
- special classes such as True, False, UndefinedObject or SmallInteger.
-
- If your instances should be stored in a special way, see
- #representBinaryOn: and #readBinaryContentsFromdata:manager:."
-
- ^ false
-!
-
-representBinaryOn:manager
- "this method is called by the storage manager to ask objects
- if they wish to provide their own binary representation.
-
- If they want to do so, they should return an array containing all
- instance variables (named & indexed pointer) to be stored.
- If not redefined, this method returns nil which means that all
- instance variables are to be stored.
-
- It should be redefined in objects which do not want all instance variables
- to be stored (for example: objects which keep references to a view etc.).
-
- If this is redefined returning non-nil, the corresponding class needs
- a redefined instance method named #readBinaryContentsFromData:manager:
- which has to fill the receivers named (and optionally indexed pointer)
- instance variables with corresponding values from a data array."
-
- ^ nil
-
- "typical implementation:
- (see also comment in #readBinaryContentsFromData:manager:)
- for an object with foo, bar and baz as instance variables,
- which does not want to store baz:
-
- representBinaryOn:manager
- |data|
-
- data := Array new:2.
- data at:1 put:foo.
- data at:2 put:bar.
- ^ data
- "
-!
-
-readBinaryContentsFromData:instvarArray manager:manager
- "reconstruct the receivers instance variables by filling instance
- variables with values from instvarArray. This array contains the instvars
- as specified in #representBinaryOn: when the object was stored.
- It is the receivers responsibility to set its instance variables in the
- same order from that array."
-
- ^ self subclassResponsibility
-
- "typical implementation (see also comment in #representBinaryOn:)
- (for an object with foo, bar and baz as instance variables,
- which did not store baz and wants baz to be reinitialized to
- some constant string)
-
- foo := instvarArray at:1.
- bar := instvarArray at:2.
- baz := 'aConstant'.
- "
-!
-
-storeBinaryContentsFromData:instvarArray on:stream manager:manager
- "store the instvars (both named & indexed pointer)
- as returned by #representBinaryOn:."
-
- |size "{ Class: SmallInteger }"|
-
- size := instvarArray size.
- 1 to:size do:[:i |
- manager putIdOf:(instvarArray at:i) on:stream
- ].
-!
-
-readBinaryContentsFrom:stream manager:manager
- "reconstruct the receivers instance variables by reading a binary
- binary representation from stream.
- This is a general implementation, walking over instances
- and loading each recursively using manager.
- Redefined by some classes to read a more compact representations
- (see String, SmallInteger etc).
-
- Notice, that the object is already recreated as an empty corps
- with instance variables all nil and bit-instances (bytes, words etc.)
- already read and restored.
-
- Also notice: this method is not called for if a private representation
- has been stored (see representBinaryOn:).
- In that case, #readBinaryContentsFromData:manager: is called, which
- has to be reimplemented in the objects class."
-
- |size "{ Class: SmallInteger }"
- instvarArray|
-
- stream next == 1 ifTrue:[
- "/
- "/ special representation ...
- "/
- instvarArray := Array new:(size := stream nextNumber:3).
- 1 to:size do:[:i |
- instvarArray basicAt:i put:(manager nextObject)
- ].
- self readBinaryContentsFromData:instvarArray manager:manager.
- ^ self
- ].
-
- "/
- "/ standard representation
- "/
- size := self basicSize.
- size ~~ 0 ifTrue:[
- self class isPointers ifTrue:[
- 1 to:size do:[:i |
- self basicAt:i put:(manager nextObject)
- ]
- ]
- ].
- size := self class instSize.
- 1 to:size do:[:i |
- self instVarAt:i put:(manager nextObject)
- ].
-!
-
-storeBinaryContentsOn:stream manager:manager
- "store the receivers instance variables in a binary representation
- on a stream using manager.
- This is a general implementation, walking over instances
- and storing each recursively using manager.
-
- Notice, that the objects definition and bit-instances (bytes, words etc.)
- are already stored.
- Here, we only have to deal with indexed-pointer and named instance variables.
-
- Also notice: this method is not called for if a private representation
- has been stored (see representBinaryOn:).
- In that case, #storeBinaryContentsFromData:manager: is called."
-
- |size "{ Class: SmallInteger }"|
-
- size := self basicSize.
- size ~~ 0 ifTrue:[
- self class isPointers ifTrue:[
- 1 to:size do:[:i |
- manager putIdOf:(self basicAt:i) on:stream
- ].
- ].
- ].
- size := self class instSize.
- 1 to:size do:[:i |
- manager putIdOf:(self instVarAt:i) on:stream
- ].
-!
-
-storeBinaryDefinitionOn:stream manager:manager
- "append a binary representation of the receiver onto stream.
- This method first stores the class, then the body, which is done
- in a separate method to allow redefinition of the bodies format.
- Can be redefined in subclasses to write more compact representations
- (see String, SmallInteger etc)."
-
- manager putIdOfClass:(self class) on:stream.
- self storeBinaryDefinitionBodyOn:stream manager:manager
-!
-
-storeBinaryDefinitionBodyOn:stream manager:manager
- "append a binary representation of the receivers body onto stream.
- This is a general implementation walking over instances storing
- each recursively as an ID using manager.
- Can be redefined in subclasses."
-
- |basicSize "{ Class: SmallInteger }"
- instSize "{ Class: SmallInteger }"
- myClass specialRep pointers|
-
- myClass := self class.
- instSize := myClass instSize.
-
- (pointers := myClass isPointers) ifTrue:[
- "/
- "/ inst size not needed - if you uncomment the line below,
- "/ also uncomment the corresponding line in
- "/ Object>>binaryDefinitionFrom:manager:
- "/
- "/ stream nextPut:instSize. "mhmh this limits us to 255 named instvars"
-
- myClass isVariable ifTrue:[
- stream nextNumber:3 put:(basicSize := self basicSize)
- ] ifFalse:[
- basicSize := 0
- ].
- ] ifFalse: [
- stream nextNumber:4 put:(basicSize := self basicSize).
- myClass isBytes ifTrue:[
- 1 to:basicSize do:[:i |
- stream nextPut:(self basicAt:i)
- ]
- ] ifFalse:[
- myClass isWords ifTrue:[
- 1 to:basicSize do:[:i |
- stream nextNumber:2 put:(self basicAt: i)
- ]
- ] ifFalse:[
- myClass isLongs ifTrue:[
- 1 to:basicSize do:[:i |
- stream nextNumber:4 put:(self basicAt: i)
- ]
- ] ifFalse:[
- myClass isFloats ifTrue:[
- "could do it in one big write on machines which use IEEE floats ..."
- 1 to:basicSize do:[:i |
- Float storeBinaryIEEESingle:(self basicAt:i) on:stream
- ]
- ] ifFalse:[
- myClass isDoubles ifTrue:[
- "could do it in one big write on machines which use IEEE doubles ..."
- 1 to:basicSize do:[:i |
- Float storeBinaryIEEEDouble:(self basicAt:i) on:stream
- ]
- ] ifFalse:[
- "/ should never be reached ...
- 1 to:basicSize do:[:i |
- manager putIdOf:(self basicAt:i) on:stream
- ]
- ]
- ]
- ]
- ]
- ].
- ].
-
- (pointers or:[instSize ~~ 0]) ifTrue:[
- specialRep := self representBinaryOn:manager.
- specialRep notNil ifTrue:[
- stream nextPut:1. "/ means: private representation follows
- stream nextNumber:3 put:(specialRep basicSize).
- self storeBinaryContentsFromData:specialRep on:stream manager:manager
- ] ifFalse:[
- stream nextPut:0. "/ means: full representation follows
- self storeBinaryContentsOn:stream manager:manager
- ]
- ]
-
- "Modified: 25.10.1995 / 14:00:51 / cg"
-!
-
-storeBinaryOn:stream manager:manager
- "append a binary representation of the receiver onto stream."
-
- manager putIdOf:self on:stream
+!Object methodsFor:'misc'!
+
+-> anObject
+ "return an association with the receiver as key and
+ the argument as value"
+
+ ^ Association key:self value:anObject
! !
!Object methodsFor:'printing & storing'!
@@ -3742,33 +2804,52 @@
"
!
-printOn:aStream
- "print the receiver on the argument-stream.
- The default here is to output the receivers class name.
- BUT: this method is heavily redefined for objects which
- can print prettier."
-
- aStream nextPutAll:self classNameWithArticle
+displayOn:aGc at:aPoint
+ "ST-80 Compatibility
+ display the receiver in a graphicsContext - this method allows
+ for any object to be displayed in a ListView - for example."
+
+ ^ self displayOn:aGc x:(aPoint x) y:(aPoint y).
!
-print
- "print the receiver on the standard output stream"
-
- self printOn:Stdout
+displayOn:aGc x:x y:y
+ "display the receiver in a graphicsContext - this method allows
+ for any object to be displayed in a ListView - for example."
+
+ ^ aGc displayString:(self displayString) x:x y:y.
!
-printNewline
- "print the receiver followed by a cr on the standard output stream"
-
- self printOn:Stdout.
- Stdout cr
+displayString
+ "return a string used when displaying the receiver in a view;
+ for example an Inspector. This is usually the same as printString,
+ but sometimes redefined for a better look."
+
+ ^ self printString
+
+ "
+ #(1 2 3) printString
+ #(1 2 3) displayString
+ #(1 2 3) storeString
+ "
!
-printNL
- "print the receiver followed by a cr on the standard output stream
- - for GNU Smalltalk compatibility"
-
- ^ self printNewline
+errorPrint
+ "print the receiver on the standard error stream."
+
+ self printOn:Stderr
+!
+
+errorPrintNL
+ "print the receiver followed by a cr on the standard error stream"
+
+ ^ self errorPrintNewline
+!
+
+errorPrintNewline
+ "print the receiver followed by a cr on the standard error stream"
+
+ self printOn:Stderr.
+ Stderr cr
!
infoPrint
@@ -3793,23 +2874,96 @@
]
!
-errorPrint
- "print the receiver on the standard error stream."
-
- self printOn:Stderr
+print
+ "print the receiver on the standard output stream"
+
+ self printOn:Stdout
+!
+
+printNL
+ "print the receiver followed by a cr on the standard output stream
+ - for GNU Smalltalk compatibility"
+
+ ^ self printNewline
+!
+
+printNewline
+ "print the receiver followed by a cr on the standard output stream"
+
+ self printOn:Stdout.
+ Stdout cr
+!
+
+printOn:aStream
+ "print the receiver on the argument-stream.
+ The default here is to output the receivers class name.
+ BUT: this method is heavily redefined for objects which
+ can print prettier."
+
+ aStream nextPutAll:self classNameWithArticle
+!
+
+printOn:aStream leftPaddedTo:size
+ "print the receiver on aStream, padding with spaces up to size.
+ padding is done on the left."
+
+ self printOn:aStream leftPaddedTo:size with:(Character space)
+
+ "
+ 123 printOn:Transcript leftPaddedTo:10. Transcript cr
+ 123 printOn:Transcript leftPaddedTo:2. Transcript cr
+ "
!
-errorPrintNewline
- "print the receiver followed by a cr on the standard error stream"
-
- self printOn:Stderr.
- Stderr cr
+printOn:aStream leftPaddedTo:size with:padCharacter
+ "print the receiver on aStream, padding with padCharacters up to size.
+ padding is done on the left."
+
+ aStream nextPutAll:(self printStringLeftPaddedTo:size with:padCharacter)
+
+ "
+ 123 printOn:Transcript leftPaddedTo:10 with:$_ . Transcript cr
+ 123 printOn:Transcript leftPaddedTo:10 with:$. . Transcript cr
+ "
+!
+
+printOn:aStream paddedTo:size
+ "print the receiver on aStream, padding with spaces up to size."
+
+ self printOn:aStream paddedTo:size with:(Character space)
+
+ "
+ 123.0 printOn:Transcript paddedTo:10. Transcript nextPut:$|. Transcript cr
+ "
!
-errorPrintNL
- "print the receiver followed by a cr on the standard error stream"
-
- ^ self errorPrintNewline
+printOn:aStream paddedTo:size with:padCharacter
+ "print the receiver on aStream, padding with padCharacter up to size"
+
+ aStream nextPutAll:(self printStringPaddedTo:size with:padCharacter).
+
+ "
+ 123 printOn:Transcript paddedTo:10 with:$_ . Transcript cr
+ 123 printOn:Transcript paddedTo:10 with:$. . Transcript cr
+ "
+!
+
+printOn:aStream zeroPaddedTo:size
+ "print the receiver on aStream, padding with zeros up to size.
+ Usually used with float numbers."
+
+ self printOn:aStream paddedTo:size with:$0.
+
+ "
+ 123.0 printOn:Transcript zeroPaddedTo:10
+ "
+!
+
+printRightAdjustLen:size
+ "obsolete - just a name confusion.
+ This method will go away ..."
+
+ (self printStringLeftPaddedTo:size) printOn:Stdout
!
printString
@@ -3824,37 +2978,66 @@
^ s contents
!
-printStringPaddedTo:size with:padCharacter ifLarger:alternative
- "return a printed representation of the receiver,
- padded with padCharacter (at the right) up to size.
- If the resulting printString is too large,
+printStringLeftPaddedTo:size
+ "return my printString as a right-adjusted string of length size;
+ characters on the left are filled with spaces.
+ If the printString is longer than size,
+ it is returned unchanged (i.e. not truncated)"
+
+ ^ self printStringLeftPaddedTo:size with:(Character space)
+
+ "
+ 10 printStringLeftPaddedTo:10
+ 1 printStringLeftPaddedTo:10
+ "
+!
+
+printStringLeftPaddedTo:size ifLarger:alternative
+ "return my printString as a right-adjusted string of length size;
+ characters on the left are filled with spaces.
+ If the printString is larger than size,
+ return the result from evaluating alternative."
+
+ ^ self printStringLeftPaddedTo:size with:(Character space) ifLarger:alternative
+
+ "
+ 12 printStringLeftPaddedTo:3 ifLarger:['***']
+ 123 printStringLeftPaddedTo:3 ifLarger:['***']
+ 1234 printStringLeftPaddedTo:3 ifLarger:['***']
+ "
+!
+
+printStringLeftPaddedTo:size with:padCharacter
+ "return my printString as a right-adjusted string of length size;
+ characters on the left are filled with padCharacter.
+ If the printString is longer than size,
+ it is returned unchanged (i.e. not truncated)"
+
+ ^ (self printString) leftPaddedTo:size with:padCharacter
+
+ "
+ 123 printStringLeftPaddedTo:10 with:$.
+ 1 printStringLeftPaddedTo:10 with:$.
+ (Float pi) printStringLeftPaddedTo:20 with:$*
+ "
+!
+
+printStringLeftPaddedTo:size with:padCharacter ifLarger:alternative
+ "return my printString as a right-adjusted string of length size;
+ characters on the left are filled with padCharacter.
+ If the printString is larger than size,
return the result from evaluating alternative."
|s|
s := self printString.
s size > size ifTrue:[^ alternative value].
- ^ s paddedTo:size with:padCharacter
+ ^ s leftPaddedTo:size with:padCharacter
"
- 123 printStringPaddedTo:3 with:$. ifLarger:['***']
- 12345 printStringPaddedTo:3 with:$. ifLarger:['***']
- "
-!
-
-printStringPaddedTo:size with:padCharacter
- "return a printed representation of the receiver,
- padded with padCharacter (at the right) up to size.
- If the printString is longer than size,
- it is returned unchanged (i.e. not truncated)"
-
- ^ (self printString) paddedTo:size with:padCharacter
-
- "
- 123 printStringPaddedTo:10 with:$.
- 123 printStringPaddedTo:10 with:$*
- 123 printStringPaddedTo:3 with:$*
- 1234 printStringPaddedTo:3 with:$*
+ 12 printStringLeftPaddedTo:3 with:$. ifLarger:['***']
+ 123 printStringLeftPaddedTo:3 with:$. ifLarger:['***']
+ 1234 printStringLeftPaddedTo:3 with:$. ifLarger:['***']
"
!
@@ -3888,6 +3071,47 @@
"
!
+printStringPaddedTo:size with:padCharacter
+ "return a printed representation of the receiver,
+ padded with padCharacter (at the right) up to size.
+ If the printString is longer than size,
+ it is returned unchanged (i.e. not truncated)"
+
+ ^ (self printString) paddedTo:size with:padCharacter
+
+ "
+ 123 printStringPaddedTo:10 with:$.
+ 123 printStringPaddedTo:10 with:$*
+ 123 printStringPaddedTo:3 with:$*
+ 1234 printStringPaddedTo:3 with:$*
+ "
+!
+
+printStringPaddedTo:size with:padCharacter ifLarger:alternative
+ "return a printed representation of the receiver,
+ padded with padCharacter (at the right) up to size.
+ If the resulting printString is too large,
+ return the result from evaluating alternative."
+
+ |s|
+
+ s := self printString.
+ s size > size ifTrue:[^ alternative value].
+ ^ s paddedTo:size with:padCharacter
+
+ "
+ 123 printStringPaddedTo:3 with:$. ifLarger:['***']
+ 12345 printStringPaddedTo:3 with:$. ifLarger:['***']
+ "
+!
+
+printStringRightAdjustLen:size
+ "obsolete - just a name confusion.
+ This method will go away ..."
+
+ ^ self printStringLeftPaddedTo:size
+!
+
printStringZeroPaddedTo:size
"return a printed representation of the receiver,
padded with zero (at the right) characters up to size.
@@ -3900,166 +3124,19 @@
"
!
-printStringLeftPaddedTo:size with:padCharacter ifLarger:alternative
- "return my printString as a right-adjusted string of length size;
- characters on the left are filled with padCharacter.
- If the printString is larger than size,
- return the result from evaluating alternative."
-
- |s|
-
- s := self printString.
- s size > size ifTrue:[^ alternative value].
- ^ s leftPaddedTo:size with:padCharacter
-
- "
- 12 printStringLeftPaddedTo:3 with:$. ifLarger:['***']
- 123 printStringLeftPaddedTo:3 with:$. ifLarger:['***']
- 1234 printStringLeftPaddedTo:3 with:$. ifLarger:['***']
- "
-!
-
-printStringLeftPaddedTo:size with:padCharacter
- "return my printString as a right-adjusted string of length size;
- characters on the left are filled with padCharacter.
- If the printString is longer than size,
- it is returned unchanged (i.e. not truncated)"
-
- ^ (self printString) leftPaddedTo:size with:padCharacter
-
- "
- 123 printStringLeftPaddedTo:10 with:$.
- 1 printStringLeftPaddedTo:10 with:$.
- (Float pi) printStringLeftPaddedTo:20 with:$*
- "
-!
-
-printStringLeftPaddedTo:size ifLarger:alternative
- "return my printString as a right-adjusted string of length size;
- characters on the left are filled with spaces.
- If the printString is larger than size,
- return the result from evaluating alternative."
-
- ^ self printStringLeftPaddedTo:size with:(Character space) ifLarger:alternative
-
- "
- 12 printStringLeftPaddedTo:3 ifLarger:['***']
- 123 printStringLeftPaddedTo:3 ifLarger:['***']
- 1234 printStringLeftPaddedTo:3 ifLarger:['***']
- "
-!
-
-printStringLeftPaddedTo:size
- "return my printString as a right-adjusted string of length size;
- characters on the left are filled with spaces.
- If the printString is longer than size,
- it is returned unchanged (i.e. not truncated)"
-
- ^ self printStringLeftPaddedTo:size with:(Character space)
-
- "
- 10 printStringLeftPaddedTo:10
- 1 printStringLeftPaddedTo:10
- "
-!
-
-printOn:aStream paddedTo:size with:padCharacter
- "print the receiver on aStream, padding with padCharacter up to size"
-
- aStream nextPutAll:(self printStringPaddedTo:size with:padCharacter).
-
- "
- 123 printOn:Transcript paddedTo:10 with:$_ . Transcript cr
- 123 printOn:Transcript paddedTo:10 with:$. . Transcript cr
- "
+store
+ "store the receiver on standard output.
+ this method is useless, but included for compatibility."
+
+ self storeOn:Stdout
!
-printOn:aStream zeroPaddedTo:size
- "print the receiver on aStream, padding with zeros up to size.
- Usually used with float numbers."
-
- self printOn:aStream paddedTo:size with:$0.
-
- "
- 123.0 printOn:Transcript zeroPaddedTo:10
- "
-!
-
-printOn:aStream paddedTo:size
- "print the receiver on aStream, padding with spaces up to size."
-
- self printOn:aStream paddedTo:size with:(Character space)
-
- "
- 123.0 printOn:Transcript paddedTo:10. Transcript nextPut:$|. Transcript cr
- "
-!
-
-printOn:aStream leftPaddedTo:size with:padCharacter
- "print the receiver on aStream, padding with padCharacters up to size.
- padding is done on the left."
-
- aStream nextPutAll:(self printStringLeftPaddedTo:size with:padCharacter)
-
- "
- 123 printOn:Transcript leftPaddedTo:10 with:$_ . Transcript cr
- 123 printOn:Transcript leftPaddedTo:10 with:$. . Transcript cr
- "
-!
-
-printOn:aStream leftPaddedTo:size
- "print the receiver on aStream, padding with spaces up to size.
- padding is done on the left."
-
- self printOn:aStream leftPaddedTo:size with:(Character space)
-
- "
- 123 printOn:Transcript leftPaddedTo:10. Transcript cr
- 123 printOn:Transcript leftPaddedTo:2. Transcript cr
- "
-!
-
-printStringRightAdjustLen:size
- "obsolete - just a name confusion.
- This method will go away ..."
-
- ^ self printStringLeftPaddedTo:size
-!
-
-printRightAdjustLen:size
- "obsolete - just a name confusion.
- This method will go away ..."
-
- (self printStringLeftPaddedTo:size) printOn:Stdout
-!
-
-displayString
- "return a string used when displaying the receiver in a view;
- for example an Inspector. This is usually the same as printString,
- but sometimes redefined for a better look."
-
- ^ self printString
-
- "
- #(1 2 3) printString
- #(1 2 3) displayString
- #(1 2 3) storeString
- "
-!
-
-displayOn:aGc x:x y:y
- "display the receiver in a graphicsContext - this method allows
- for any object to be displayed in a ListView - for example."
-
- ^ aGc displayString:(self displayString) x:x y:y.
-!
-
-displayOn:aGc at:aPoint
- "ST-80 Compatibility
- display the receiver in a graphicsContext - this method allows
- for any object to be displayed in a ListView - for example."
-
- ^ self displayOn:aGc x:(aPoint x) y:(aPoint y).
+storeNl
+ "store the receiver on standard output; append a newline.
+ this method is useless, but included for compatibility."
+
+ self store.
+ Character nl print
!
storeOn:aStream
@@ -4160,19 +3237,957 @@
s := WriteStream on:(String new:50).
self storeOn:s.
^ s contents
+! !
+
+!Object methodsFor:'queries'!
+
+basicSize
+ "return the number of the receivers indexed instance variables,
+ 0 if it has none.
+
+ This method should NOT be redefined in any subclass"
+
+%{ /* NOCONTEXT */
+
+ REGISTER int nbytes;
+ REGISTER OBJ myClass;
+ REGISTER int flags;
+
+ /*
+ * notice the missing test for self being a nonNilObject -
+ * this can be done since basicSize is defined both in UndefinedObject
+ * and SmallInteger
+ */
+ myClass = __qClass(self);
+ nbytes = __qSize(self)
+ - OHDR_SIZE
+ - __OBJS2BYTES__(__intVal(_ClassInstPtr(myClass)->c_ninstvars));
+
+ flags = __intVal(_ClassInstPtr(myClass)->c_flags) & ARRAYMASK;
+ /*
+ * replaced switch by open-if; this is slightly faster since
+ * it avoids the range check and also checks the most common case first
+ */
+ if ((flags == POINTERARRAY)
+ || (flags == WKPOINTERARRAY)) {
+ RETURN ( __MKSMALLINT(__BYTES2OBJS__(nbytes)) );
+ }
+ if (flags == BYTEARRAY) {
+ RETURN ( __MKSMALLINT(nbytes / sizeof(char)) );
+ }
+ if (flags == FLOATARRAY) {
+ RETURN ( __MKSMALLINT(nbytes / sizeof(float)) );
+ }
+ if (flags == DOUBLEARRAY) {
+#ifdef NEED_DOUBLE_ALIGN
+ /*
+ * care for filler
+ */
+ nbytes -= sizeof(FILLTYPE);
+#endif
+ RETURN ( __MKSMALLINT(nbytes / sizeof(double)) );
+ }
+ if (flags == LONGARRAY) {
+ RETURN ( __MKSMALLINT(nbytes / sizeof(long)) );
+ }
+ if (flags == WORDARRAY) {
+ RETURN ( __MKSMALLINT(nbytes / sizeof(short)) );
+ }
+%}.
+ ^ 0
!
-store
- "store the receiver on standard output.
- this method is useless, but included for compatibility."
-
- self storeOn:Stdout
+class
+ "return the receivers class"
+
+%{ /* NOCONTEXT */
+
+ RETURN ( __Class(self) );
+%}
+!
+
+isArray
+ "return true, if the receiver is some kind of array (or weakArray etc);
+ false is returned here - the method is only redefined in Array."
+
+ ^ false
+!
+
+isBehavior
+ "return true, if the receiver is some kind of class (i.e. behavior);
+ false is returned here - the method is only redefined in Behavior."
+
+ ^ false
+!
+
+isBlock
+ "return true, if the receiver is some kind of block;
+ false returned here - the method is only redefined in Block."
+
+ ^ false
+!
+
+isCharacter
+ "return true, if the receiver is some kind of character;
+ false is returned here - the method is only redefined in Character."
+
+ ^ false
+!
+
+isClass
+ "return true, if the receiver is some kind of class (real class,
+ not just behavior);
+ false is returned here - the method is only redefined in Class."
+
+ ^ false
+!
+
+isCollection
+ "return true, if the receiver is some kind of collection;
+ false is returned here - the method is only redefined in Collection."
+
+ ^ false
+!
+
+isColor
+ "return true, if the receiver is some kind of color;
+ false is returned here - the method is only redefined in Color."
+
+ ^ false
+!
+
+isContext
+ "return true, if the receiver is some kind of context;
+ false returned here - the method is only redefined in Context."
+
+ ^ false
+!
+
+isExternalStream
+ "return true, if the receiver is some kind of externalStream;
+ false is returned here - the method is only redefined in ExternalStream."
+
+ ^false
+!
+
+isFileStream
+ "return true, if the receiver is some kind of fileStream;
+ false is returned here - the method is only redefined in FileStream."
+
+ ^false
+!
+
+isFixedSize
+ "return true if the receiver cannot grow easily
+ (i.e. a grow may be expensive, since it involves a become:)"
+
+ ^ true
+!
+
+isForm
+ "return true, if the receiver is some kind of form;
+ false is returned here - the method is only redefined in Form."
+
+ ^ false
+!
+
+isFraction
+ "return true, if the receiver is some kind of fraction;
+ false is returned here - the method is only redefined in Fraction."
+
+ ^ false
+!
+
+isImage
+ "return true, if the receiver is some kind of image;
+ false is returned here - the method is only redefined in Image."
+
+ ^ false
+!
+
+isImageOrForm
+ "return true, if the receiver is some kind of image or form;
+ false is returned here - the method is only redefined in Image and Form."
+
+ ^ false
+!
+
+isInteger
+ "return true, if the receiver is some kind of integer number;
+ false is returned here - the method is only redefined in Integer."
+
+ ^ false
+!
+
+isKindOf:aClass
+ "return true, if the receiver is an instance of aClass or one of its
+ subclasses, false otherwise.
+ Advice:
+ use of this to check objects for certain attributes/protocoll should
+ be avoided; it limits the reusability of your classes by limiting use
+ to instances of certain classes and fences you into a specific inheritance
+ hierarchy.
+ Use check-methods to check an object for a certain attributes/protocol
+ (such as #isXXXX, #respondsTo: or #isNumber).
+
+ Using #isKindOf: is considered BAD STYLE.
+
+ Advice2:
+ Be aware, that using an #isXXX method is usually much faster than
+ using #isKindOf:; because isKindOf: has to walk up all the superclass
+ hierarchy, comparing every class on the way.
+ Due to caching in the VM, a call to #isXXX is normally reached via
+ a single function call.
+ "
+
+%{ /* NOCONTEXT */
+ register OBJ thisClass;
+
+ thisClass = __Class(self);
+ while (thisClass != nil) {
+ if (thisClass == aClass) {
+ RETURN ( true );
+ }
+ thisClass = _ClassInstPtr(thisClass)->c_superclass;
+ }
+%}
+.
+"/
+"/ the above code is equivalent to:
+"/
+"/ thisClass := self class.
+"/ [thisClass notNil] whileTrue:[
+"/ thisClass == aClass ifTrue:[^ true].
+"/ thisClass := thisClass superclass
+"/ ]
+"/
+ ^ false
+!
+
+isLayout
+ "return true, if the receiver is some kind of layout;
+ false is returned here - the method is only redefined in Layout."
+
+ ^ false
+!
+
+isLiteral
+ "return true, if the receiver can be represented as a constant in ST syntax;
+ false is returned here - the method is redefined in some classes."
+
+ ^ false
+!
+
+isMemberOf:aClass
+ "return true, if the receiver is an instance of aClass, false otherwise.
+ Advice:
+ use of this to check objects for certain attributes/protocoll should
+ be avoided; it limits the reusability of your classes by limiting use
+ to instances of a certain class.
+ Use check-methods to check an object for a certain attributes/protocol
+ (such as #isXXX, #respondsTo: or #isNumber);
+
+ Using #isMemberOf: is considered BAD STYLE."
+
+ ^ (self class) == aClass
+!
+
+isMeta
+ "return true, if the receiver is some kind of metaclass;
+ false is returned here - the method is only redefined in Metaclass."
+
+ ^ false
+!
+
+isMethod
+ "return true, if the receiver is some kind of method;
+ false returned here - the method is only redefined in Method."
+
+ ^ false
+!
+
+isNumber
+ "return true, if the receiver is some kind of number;
+ false is returned here - the method is only redefined in Number."
+
+ ^ false
+!
+
+isPoint
+ "return true, if the receiver is some kind of point;
+ false is returned here - the method is only redefined in Point."
+
+ ^ false
+!
+
+isReal
+ "return true, if the receiver is some kind of real number;
+ false is returned here - the method is only redefined in LimitedPrecisionReal."
+
+ ^ false
+!
+
+isRectangle
+ "return true, if the receiver is some kind of rectangle;
+ false is returned here - the method is only redefined in Rectangle."
+
+ ^ false
+!
+
+isSequenceable
+ "return true, if the receiver is some kind of sequenceable collection;
+ false is returned here - the method is only redefined in SequenceableCollection."
+
+ ^ false
+!
+
+isSequenceableCollection
+ "OBSOLETE: use isSequenceable for ST-80 compatibility.
+ This method is a historic leftover and will be removed soon ..."
+
+ self obsoleteMethodWarning:'use #isSequenceable'.
+ ^ false
+!
+
+isSignal
+ "return true, if the receiver is some kind of signal;
+ false returned here - the method is only redefined in Signal."
+
+ ^ false
+!
+
+isStream
+ "return true, if the receiver is some kind of stream;
+ false is returned here - the method is only redefined in Stream."
+
+ ^ false
+!
+
+isString
+ "return true, if the receiver is some kind of string;
+ false is returned here - the method is only redefined in String."
+
+ ^ false
+!
+
+isSymbol
+ "return true, if the receiver is some kind of symbol;
+ false is returned here - the method is only redefined in Symbol."
+
+ ^ false
+!
+
+isVariable
+ "return true if the receiver has indexed instance variables,
+ false otherwise."
+
+ ^ self class isVariable
+!
+
+isView
+ "return true, if the receiver is some kind of view;
+ false is returned here - the method is only redefined in View."
+
+ ^ false
+!
+
+respondsTo:aSelector
+ "return true, if the receiver implements a method with selector equal
+ to aSelector; i.e. if there is a method for aSelector in either the
+ receivers class or one of its superclasses.
+
+ Notice, that this does not imply, that such a message can be sent without
+ an error being raised. For example, an implementation could send
+ #shouldNotImplement or #subclassResponsibility."
+
+ "
+ should we go via the cache, or search (by class) ?
+ The first is faster, most of the time; while the 2nd fills
+ the cache with useless data if this is sent in a loop over all objects.
+ For now, use the cache ...
+ "
+%{ /* NOCONTEXT */
+
+ extern OBJ __lookup();
+
+ if (__lookup(__Class(self), aSelector) == nil) {
+ RETURN ( false );
+ }
+ RETURN ( true );
+%}
+.
+"
+ ^ self class canUnderstand:aSelector
+"
+
+ "'aString' respondsTo:#+"
+ "'aString' respondsTo:#,"
+ "'aString' respondsTo:#collect:"
+!
+
+respondsToArithmetic
+ "return true, if the receiver responds to arithmetic messages.
+ false is returned here - the method is redefined in ArithmeticValue."
+
+ ^ false
+!
+
+size
+ "return the number of the receivers indexed instance variables;
+ this method may be redefined in subclasses"
+
+ ^ self basicSize
+!
+
+species
+ "return a class which is similar to (or the same as) the receivers class.
+ This is used to create an appropriate object when creating derived
+ copies in the collection classes (sometimes redefined)."
+
+ ^ self class
+!
+
+yourself
+ "return the receiver - used for cascades to return self at the end"
+
+ ^ self
+! !
+
+!Object methodsFor:'secure message sending'!
+
+askFor:aSelector
+ "try to send the receiver the message, aSelector.
+ If it does not understand it, return false. Otherwise
+ the real value returned.
+ Useful to send messages such as: 'isColor' to unknown
+ receivers."
+
+ ^ self perform:aSelector ifNotUnderstood:[false]
+
+ "
+ 1 askFor:#isColor
+ "
+!
+
+perform:aSelector ifNotUnderstood:exceptionBlock
+ "try to send message aSelector to the receiver.
+ If its understood, return the methods returned value,
+ otherwise return the value of the exceptionBlock"
+
+ |val|
+
+ MessageNotUnderstoodSignal handle:[:ex |
+ ^ exceptionBlock value
+ ] do:[
+ val := self perform:aSelector
+ ].
+ ^ val
+
+ "
+ 1.2345 perform:#foo ifNotUnderstood:['sorry']
+ "
!
-storeNl
- "store the receiver on standard output; append a newline.
- this method is useless, but included for compatibility."
-
- self store.
- Character nl print
+perform:aSelector with:argument ifNotUnderstood:exceptionBlock
+ "try to send message aSelector to the receiver.
+ If its understood, return the methods returned value,
+ otherwise return the value of the exceptionBlock"
+
+ |val|
+
+ MessageNotUnderstoodSignal handle:[:ex |
+ ^ exceptionBlock value
+ ] do:[
+ val := self perform:aSelector with:argument
+ ].
+ ^ val
+
+ "
+ |unknown|
+
+ unknown := 1.
+ (unknown perform:#+ with:2 ifNotUnderstood:['sorry']) printNewline.
+ unknown := 'high there'.
+ (unknown perform:#+ with:2 ifNotUnderstood:['sorry']) printNewline.
+ "
+! !
+
+!Object methodsFor:'special queries'!
+
+allOwners
+ "return a collection of all objects referencing the receiver"
+
+ ^ ObjectMemory whoReferences:self
+!
+
+references:anObject
+ "return true, if the receiver refers to the argument, anObject.
+ - for debugging only"
+
+ |myClass
+ numInst "{ Class: SmallInteger }" |
+
+%{
+ /*
+ * a little optimization: use the fact that all old objects
+ * refering to a new object are on the remSet; if I am not,
+ * a trivial reject is possible, if anObject is a newbee
+ */
+ if (__isNonNilObject(self) && __isNonNilObject(anObject)) {
+ if ((__qSpace(self) <= OLDSPACE) && !__isRemembered(self)) {
+ int spc;
+
+ if (((spc = __qSpace(anObject)) == NEWSPACE) || (spc == SURVSPACE)) {
+ RETURN (false);
+ }
+ }
+ }
+%}.
+
+ myClass := self class.
+
+ "check the class"
+ (myClass == anObject) ifTrue:[^ true].
+
+ "check the instance variables"
+ numInst := myClass instSize.
+ 1 to:numInst do:[:i |
+ ((self instVarAt:i) == anObject) ifTrue:[^ true]
+ ].
+
+ "check the indexed variables"
+ myClass isVariable ifTrue:[
+ myClass isPointers ifFalse:[
+ "/
+ "/ we could argue about the following unconditional return:
+ "/ it says that a non pointer array never has a reference to the
+ "/ corresponding object - not mimicing a reference to a copy of the
+ "/ integer. However, it avoids useless searches in huge byteArray
+ "/ like objects when searching for owners. If in doubt, remove it.
+ "/ A consequence of the return below is that #[1 2 3] will say that it
+ "/ does not refer to the number 2 (think of keeping a copy instead)
+
+ ^ false.
+
+ "/ alternative:
+ "/ anObject isNumber ifFalse:[^ false].
+ ].
+
+ "/
+ "/ because arrays are so common, and those have a highly tuned
+ "/ idenitytIndex method, use it
+ "/
+ myClass == Array ifTrue:[
+ ^ (self identityIndexOf:anObject) ~~ 0
+ ].
+
+ "/
+ "/ otherwise, do it the slow way
+ "/
+ numInst := self basicSize.
+ 1 to:numInst do:[:i |
+ ((self basicAt:i) == anObject) ifTrue:[^ true]
+ ]
+ ].
+ ^ false
+
+ "
+ |v|
+
+ v := View new initialize.
+ v references:Display.
+ "
+!
+
+referencesDerivedInstanceOf:aClass
+ "return true, if the receiver refers to an instance of
+ the argument, aClass or its subclass. This method exists
+ to support searching for users of a class."
+
+ |myClass
+ numInst "{ Class: SmallInteger }" |
+
+ myClass := self class.
+
+ "check the class"
+ (myClass isKindOf:aClass) ifTrue:[^ true].
+
+ "check the instance variables"
+ numInst := myClass instSize.
+ 1 to:numInst do:[:i |
+ ((self instVarAt:i) isKindOf:aClass) ifTrue:[^ true]
+ ].
+
+ "check the indexed variables"
+ myClass isVariable ifTrue:[
+ myClass isPointers ifFalse:[
+ "no need to search in non pointer fields"
+ ((aClass == Number) or:[aClass isSubclassOf:Number]) ifFalse:[^ false].
+ ].
+ numInst := self basicSize.
+ 1 to:numInst do:[:i |
+ ((self basicAt:i) isKindOf:aClass) ifTrue:[^ true]
+ ]
+ ].
+ ^ false
+
+ "
+ (1 @ 3.4) referencesDerivedInstanceOf:Number
+ (1 @ 3.4) referencesDerivedInstanceOf:Array
+ View new initialize referencesDerivedInstanceOf:DeviceWorkstation
+ "
+!
+
+referencesInstanceOf:aClass
+ "return true, if the receiver refers to an instance of
+ the argument, aClass.This method exists
+ to support searching for users of a class."
+
+ |myClass
+ numInst "{ Class: SmallInteger }" |
+
+ myClass := self class.
+
+ "check the class"
+ (myClass isMemberOf:aClass) ifTrue:[^ true].
+
+ "check the instance variables"
+ numInst := myClass instSize.
+ 1 to:numInst do:[:i |
+ ((self instVarAt:i) isMemberOf:aClass) ifTrue:[^ true]
+ ].
+
+ "check the indexed variables"
+ myClass isVariable ifTrue:[
+ myClass isPointers ifFalse:[
+ "no need to search in non-pointer indexed fields"
+ myClass isLongs ifTrue:[
+ (aClass == SmallInteger or:[aClass == LargeInteger]) ifFalse:[^ false].
+ ] ifFalse:[
+ myClass isFloatsOrDoubles ifTrue:[^ aClass == Float].
+ ^ aClass == SmallInteger
+ ]
+ ].
+ numInst := self basicSize.
+ 1 to:numInst do:[:i |
+ ((self basicAt:i) isMemberOf:aClass) ifTrue:[^ true]
+ ]
+ ].
+ ^ false
+
+ "
+ (1 @ 3.4) referencesInstanceOf:Float
+ (1 @ 3.4) referencesInstanceOf:Fraction
+ View new initialize referencesInstanceOf:(Display class)
+ "
! !
+
+!Object methodsFor:'system primitives'!
+
+become:anotherObject
+ "make all references to the receiver become references to anotherObject
+ and vice-versa. This may be an expensive (i.e. slow) operation,
+ since in the worst case, the whole memory has to be searched for
+ references to the two objects (although the primitive tries hard to
+ limit the search, for acceptable performance in most cases).
+ In general, using become: should be avoided if possible, since it may
+ produce many strange effects (think of hashing in Sets).
+ This method fails, if the receiver or the argument is a SmallInteger
+ or nil, or is a context of a living method (i.e. one that has not already
+ returned).
+ (notice that become: is not used heavily by the system
+ - the Collection-classes have been rewritten to not use it.)"
+%{
+ if (__primBecome(self, anotherObject COMMA_CON))
+ RETURN ( self );
+%}
+.
+ self primitiveFailed
+!
+
+becomeNil
+ "make all references to the receiver become nil - effectively getting
+ rid of the receiver. This can be a very dangerous operation - be warned.
+ The receiver may not be a SmallInteger or a context of a living method."
+
+%{
+ if (__primBecomeNil(self COMMA_CON ))
+ RETURN ( nil );
+%}
+.
+ self primitiveFailed
+!
+
+changeClassTo:otherClass
+ "changes the class of the receiver to the argument, otherClass.
+ This is only allowed (possible), if the receivers class and the argument
+ have the same structure (i.e. number of named instance variables and
+ type of indexed instance variables).
+ If the structures do not match, or any of the original class or new class
+ is UndefinedObject or a Smallinteger, a primitive error is triggered."
+
+ |myClass ok|
+
+ "check for UndefinedObject/SmallInteger receiver or newClass"
+%{
+ if (__isNonNilObject(self)
+ && __isNonNilObject(otherClass)
+ && (otherClass != UndefinedObject)
+ && (otherClass != SmallInteger)) {
+ ok = true;
+ } else {
+ ok = false;
+ }
+%}.
+ ok ifTrue:[
+ ok := false.
+ myClass := self class.
+ myClass flags == otherClass flags ifTrue:[
+ myClass instSize == otherClass instSize ifTrue:[
+ "same instance layout and types: its ok to do it"
+ ok := true.
+ ] ifFalse:[
+ myClass isPointers ifTrue:[
+ myClass isVariable ifTrue:[
+ ok := true
+ ]
+ ]
+ ]
+ ] ifFalse:[
+ myClass isPointers ifTrue:[
+ "if newClass is a variable class, with instSize <= my instsize,
+ we can do it (effectively mapping additional instvars into the
+ variable part) - usefulness is questionable, though"
+
+ otherClass isPointers ifTrue:[
+ otherClass isVariable ifTrue:[
+ otherClass instSize <= (myClass instSize + self basicSize)
+ ifTrue:[
+ ok := true
+ ]
+ ] ifFalse:[
+ otherClass instSize == (myClass instSize + self basicSize)
+ ifTrue:[
+ ok := true
+ ]
+ ]
+ ] ifFalse:[
+ "it does not make sense to convert pointers to bytes ..."
+ ]
+ ] ifFalse:[
+ "does it make sense, to convert bits ?"
+ "could allow byteArray->wordArray->longArray->floatArray->doubleArray here ..."
+ ]
+ ]
+ ].
+ ok ifTrue:[
+ "now, change the receivers class ..."
+%{
+ __qClass(self) = otherClass;
+ __STORE(self, otherClass);
+ RETURN ( self );
+%}.
+ ].
+ self primitiveFailed
+!
+
+changeClassToThatOf:anObject
+ "changes the class of the receiver to that of the argument, anObject.
+ This is only allowed (possible), if the receivers class and the arguments
+ class have the same structure (i.e. number of named instance variables and
+ type of indexed instance variables). If the structures do not match, or any
+ of the objects is nil or a Smallinteger, a primitive error is triggered."
+
+ self changeClassTo:(anObject class)
+! !
+
+!Object methodsFor:'user interaction & notifications'!
+
+activityNotification:aString
+ "this can be sent from deeply nested methods, which are going to perform
+ some long-time activity.
+ If there is a handler for the ActivityNotificationSignal signal, that one is raised,
+ passing the argument. The handler should show this message whereever it likes,
+ and proceed. If there is no handler, this is simply ignored.
+
+ This is very useful to pass busy messages up to some higher level (typically a view)
+ which likes to display that message in its label or a busy-box.
+ It could also be put into some logfile or printed on the standard output/error."
+
+ ActivityNotificationSignal isHandled ifTrue:[
+ ^ ActivityNotificationSignal raiseRequestWith:self errorString:aString
+ ].
+
+ "
+ nil activityNotification:'hello there'
+ self activityNotification:'hello there'
+ "
+
+ "
+ ActivityNotificationSignal handle:[:ex |
+ ex errorString printNL.
+ ex proceed.
+ ] do:[
+ 'hello' printNL.
+ self activityNotification:'doing some long time computation'.
+ 'world' printNL.
+ ]
+ "
+
+ "Modified: 16.12.1995 / 18:23:42 / cg"
+!
+
+confirm:aString
+ "launch a confirmer, which allows user to enter yes or no.
+ return true for yes, false for no"
+
+ Dialog isNil ifTrue:[
+ "
+ on systems without GUI, output a message
+ and return true (as if yes was answered)
+ Q: should we ask user by reading Stdin ?
+ "
+ Transcript showCr:aString.
+ Transcript showCr:'continue, assuming <yes>'.
+ ^ true
+ ].
+ Dialog autoload. "in case its autoloaded"
+ ^ Dialog confirm:aString
+
+ "
+ nil confirm:'hello'
+ self confirm:'hello'
+ "
+!
+
+errorNotify:aString
+ "launch a Notifier, showing top stack, telling user something
+ and give a chance to enter debugger."
+
+ |info con sender|
+
+ Dialog isNil ifTrue:[
+ "
+ on systems without GUI, simply show
+ the message on the Transcript.
+ "
+ Transcript showCr:aString.
+ ^ self
+ ].
+ Dialog autoload. "in case its autoloaded"
+
+ con := sender := thisContext sender.
+ info := aString , Character cr asString , Character cr asString.
+ 1 to:5 do:[:n |
+ con notNil ifTrue:[
+ info := info , con printString , Character cr asString.
+ con := con sender
+ ]
+ ].
+
+ (Dialog choose:info
+ labels:#('proceed' 'debug')
+ values:#(#proceed #debug)
+ default:#debug) == #debug
+ ifTrue:[
+ Debugger enter:sender withMessage:aString
+ ]
+
+ "
+ nil errorNotify:'hello there'
+ self errorNotify:'hello there'
+ "
+!
+
+information:aString
+ "launch an InfoBox, telling user something.
+ These info-boxes can be suppressed by handling the
+ UserNotification- or InformationSignal and proceeding in the handler."
+
+ InformationSignal isHandled ifTrue:[
+ ^ InformationSignal raiseRequestWith:self errorString:aString
+ ].
+ self notify:aString
+
+ "
+ nil information:'hello there'
+ self information:'hello there'
+ "
+
+ "
+ InformationSignal handle:[:ex |
+ 'no box popped' printNL.
+ ex proceed.
+ ] do:[
+ 'hello' printNL.
+ self information:'some info'.
+ 'world' printNL.
+ ]
+ "
+
+ "Modified: 24.11.1995 / 22:29:49 / cg"
+!
+
+notify:aString
+ "launch a Notifier, telling user something.
+ Use #information: for ignorable messages."
+
+ Dialog isNil ifTrue:[
+ "
+ on systems without GUI, simply show
+ the message on the Transcript.
+ "
+ Transcript showCr:aString.
+ ^ self
+ ].
+ Dialog autoload. "in case its autoloaded"
+ Dialog information:aString
+
+ "
+ nil notify:'hello there'
+ self notify:'hello there'
+ "
+!
+
+warn:aString
+ "launch a WarningBox, telling user something.
+ These warn-boxes can be suppressed by handling the
+ UserNotification- or WarningSignal and proceeding in the handler."
+
+ WarningSignal isHandled ifTrue:[
+ ^ WarningSignal raiseRequestWith:self errorString:aString
+ ].
+
+ Dialog isNil ifTrue:[
+ "
+ on systems without GUI, simply show
+ the message on the Transcript.
+ "
+ Transcript showCr:aString.
+ ^ self
+ ].
+ Dialog autoload. "in case its autoloaded"
+ Dialog warn:aString
+
+ "
+ nil warn:'hello there'
+ self warn:'hello there'
+ "
+
+ "
+ WarningSignal handle:[:ex |
+ ex proceed.
+ ] do:[
+ 'hello' printNL.
+ self warn:'some info'.
+ 'world' printNL.
+ ]
+ "
+! !
+
+!Object class methodsFor:'documentation'!
+
+version
+ ^ '$Header: /cvs/stx/stx/libbasic/Object.st,v 1.80 1995-12-16 17:24:21 cg Exp $'
+! !
+Object initialize!