"
 COPYRIGHT (c) 1988 by Claus Gittinger
	      All Rights Reserved

 This software is furnished under a license and may be used
 only in accordance with the terms of that license and with the
 inclusion of the above copyright notice.   This software may not
 be provided or otherwise made available to, or used by, any
 other person.  No title to or ownership of the software is
 hereby transferred.
"

Object subclass:#Behavior
       instanceVariableNames:'superclass otherSuperclasses
			      selectorArray methodArray
			      instSize flags'
       classVariableNames:''
       poolDictionaries:''
       category:'Kernel-Classes'
!

Behavior comment:'
COPYRIGHT (c) 1988 by Claus Gittinger
	      All Rights Reserved

$Header: /cvs/stx/stx/libbasic/Behavior.st,v 1.30 1995-03-06 20:58:51 claus Exp $
'!

!Behavior class methodsFor:'documentation'!

copyright
"
 COPYRIGHT (c) 1988 by Claus Gittinger
	      All Rights Reserved

 This software is furnished under a license and may be used
 only in accordance with the terms of that license and with the
 inclusion of the above copyright notice.   This software may not
 be provided or otherwise made available to, or used by, any
 other person.  No title to or ownership of the software is
 hereby transferred.
"
!

version
"
$Header: /cvs/stx/stx/libbasic/Behavior.st,v 1.30 1995-03-06 20:58:51 claus Exp $
"
!

documentation
"
    Every class in the system inherits from Behavior (via Class, ClassDescription);
    so here is where most of the class messages end up being implemented.
    (to answer a FAQ: 'Point basicNew' will be done here :-)

    Beginners should keep in mind, that all classes are instances of subclasses
    of Behavior, therefore you will find the above mentioned 'basicNew:' method 
    under the 'instance'-methods of Behavior - NOT under the class methods 
    ('Behavior new' will create and return a new class, while sending 'new' to 
    any instance of Behavior (i.e. any class) will return an instance of that class).

    Behavior provides minimum support for all classes - additional stuff is
    found in ClassDescription and Class. Behaviors provides all mechanisms needed
    to create instances, and send messages to those. However, Behavior does not provide 
    all the (symbolic) information needed to compile methods for a class or to get
    useful information in inspectors.

    In contrast to other ST implementations, the methods have been separated
    from the selectors (there is no Dictionary, but two separate Arrays)
    - this avoids the need for knowledge about Dictionaries in the runtime library (VM)
    (lookup and search in these is seldom anyway, so the added benefit from using a 
     hashed dictionary is almost void).

    Instance variables:

	superclass        <Class>           the receivers superclass
	otherSuperclasses <Array of Class>  experimental: other superclasses
	selectorArray     <Array of Symbol> the selectors for which inst-methods are defined here
	methodArray       <Array of Method> the inst-methods corresponding to the selectors
	instSize          <SmallInteger>    the number of instance variables
	flags             <SmallInteger>    special flag bits coded in a number

    flag bits (see stc.h):

    NOTICE: layout known by compiler and runtime system; be careful when changing
"
! !

!Behavior class methodsFor:'queries'!

isBuiltInClass
    "this class is known by the run-time-system"

    ^ true
! !

!Behavior class methodsFor:'creating new classes'!

new
    "creates and return a new class"

    |newClass|

    newClass := self basicNew.
    newClass setSuperclass:Object
		 selectors:(Array new:0)
		   methods:(Array new:0)
		  instSize:0
		     flags:0.
    ^ newClass
! !

!Behavior methodsFor:'initialization'!

initialize
    "to catch initialize for classes which do not"

    ^ self
!

reinitialize
    "to catch reinitialize for classes which do not"

    ^ self
! !

!Behavior methodsFor:'copying'!

deepCopy
    "return a deep copy of the receiver
     - return the receiver here - time will show if this is ok"

    ^ self
!

deepCopyUsing:aDictionary
    "return a deep copy of the receiver
     - return the receiver here - time will show if this is ok"

    ^ self
!

simpleDeepCopy
    "return a deep copy of the receiver
     - return the receiver here - time will show if this is ok"

    ^ self
! !

!Behavior methodsFor:'creating an instance of myself'!

uninitializedNew
    "same as new - only redefined in ByteArray"

    ^ self basicNew
!

uninitializedNew:anInteger
    "same as new:anInteger - only redefined in ByteArray"

    ^ self basicNew:anInteger
!

niceBasicNew:anInteger
    "same as basicNew:anInteger, but tries to avoid long pauses
     due to garbage collection. This method checks to see if
     allocation is possible without a pause, and does a background
     incremental garbage collect first if there is not enough memory
     available at the moment for fast allocation. 
     This is useful in low-priority background processes which like to 
     avoid disturbing any higher priority foreground process while allocating
     big amounts of memory. Of course, using this method only makes
     sense for big or huge objects (say > 200k).

     EXPERIMENTAL: this is a non-standard interface and should only 
     be used for special applications. There is no guarantee, that this
     method will be available in future ST/X releases."

    |size|

    size := self sizeOfInst:anInteger.
    (ObjectMemory checkForFastNew:size) ifFalse:[
	"
	 incrementally collect garbage
	"
	ObjectMemory incrementalGC.
    ].
    ^ self basicNew:anInteger
!

new
    "return an instance of myself without indexed variables"

    ^ self basicNew
!

new:anInteger
    "return an instance of myself with anInteger indexed variables"

    ^ self basicNew:anInteger
!

basicNew
    "return an instance of myself without indexed variables.
     If the receiver-class has indexed instvars, the new object will have
     a basicSize of zero - 
     i.e. 'aClass basicNew' is equivalent to 'aClass basicNew:0'.

     ** Do not redefine this method in any class **"

%{  /* NOCONTEXT */
    OBJ new();
    REGISTER OBJ newobj;
    REGISTER char *nextPtr;
    unsigned int instsize;
    REGISTER unsigned int nInstVars;

    /*
     * the following ugly code is nothing more than a new() followed
     * by a nilling of the new instance.
     * Unrolled for a bit more speed since this is one of the central object 
     * allocation methods in the system
     */
    nInstVars = _intVal(_INST(instSize));
    instsize = OHDR_SIZE + __OBJS2BYTES__(nInstVars);

    newobj = (OBJ) newNextPtr;
    nextPtr = ((char *)newobj) + instsize;

    /*
     * dont argue about the goto and the arrangement below - it saves 
     * an extra nil-compare and branch in the common case ...
     * (i.e. if no GC is needed, we fall through without a branch)
     */
    if (nextPtr < newEndPtr) {
	_objPtr(newobj)->o_size = instsize;
	/* o_allFlags(newobj) = 0;              */
	/* _objPtr(newobj)->o_space = newSpace; */
	o_setAllFlags(newobj, newSpace);
#ifdef ALIGN4
	newNextPtr = nextPtr;
#else
	if (instsize & (ALIGN-1)) {
	    newNextPtr = (char *)newobj + (instsize & ~(ALIGN-1)) + ALIGN;
	} else {
	    newNextPtr = nextPtr;
	}
#endif

ok:
	_InstPtr(newobj)->o_class = self;

	if (nInstVars) {
#if defined(FAST_OBJECT_MEMSET4)
	    memset4(_InstPtr(newobj)->i_instvars, nil, nInstVars);
#else
	    REGISTER OBJ *op;

	    op = _InstPtr(newobj)->i_instvars;

# if !defined(NEGATIVE_ADDRESSES)
	    /*
	     * knowing that nil is 0
	     */
#  if defined(FAST_OBJECT_MEMSET_DOUBLES_UNROLLED)
	    if (nInstVars > 8) {
		*op++ = nil;    /* for alignment */
		nInstVars--;
		while (nInstVars >= 8) {
		    *(double *)op = 0.0;
		    ((double *)op)[1] = 0.0;
		    ((double *)op)[2] = 0.0;
		    ((double *)op)[3] = 0.0;
		    op += 8;
		    nInstVars -= 8;
		}
	    }
	    while (nInstVars != 0) {
		*op++ = 0;
		nInstVars--;
	    }
#  else
#   if defined(FAST_OBJECT_MEMSET_LONGLONG_UNROLLED)
	    if (nInstVars > 8) {
		*op++ = nil;    /* for alignment */
		nInstVars--;
		while (nInstVars >= 8) {
		    *(long long *)op = 0;
		    ((long long *)op)[1] = 0;
		    ((long long *)op)[2] = 0;
		    ((long long *)op)[3] = 0;
		    op += 8;
		    nInstVars -= 8;
		}
	    }
	    while (nInstVars != 0) {
		*op++ = 0;
		nInstVars--;
	    }

#   else
#    if defined(FAST_OBJECT_MEMSET_WORDS_UNROLLED)
	    while (nInstVars >= 8) {
		*op = nil;
		*(op+1) = nil;
		*(op+2) = nil;
		*(op+3) = nil;
		*(op+4) = nil;
		*(op+5) = nil;
		*(op+6) = nil;
		*(op+7) = nil;
		op += 8;
		nInstVars -= 8;
	    }
	    while (nInstVars != 0) {
		*op++ = nil;
		nInstVars--;
	    }
#    else
#     if defined(FAST_MEMSET)
	    memset(_InstPtr(newobj)->i_instvars, 0, instsize-OHDR_SIZE);
#     else
	    do {
		*op++ = nil;
		nInstVars--;
	    } while (nInstVars != 0);
#     endif
#    endif
#   endif
#  endif
# else /* nil could be ~~ 0 */
	    while (nInstVars >= 8) {
		*op = nil;
		*(op+1) = nil;
		*(op+2) = nil;
		*(op+3) = nil;
		*(op+4) = nil;
		*(op+5) = nil;
		*(op+6) = nil;
		*(op+7) = nil;
		op += 8;
		nInstVars -= 8;
	    }
	    while (nInstVars != 0) {
		*op++ = nil;
		nInstVars--;
	    }
# endif
#endif
	}
	RETURN ( newobj );
    }

    /*
     * the slow case - a GC will occur
     */
    PROTECT_CONTEXT
    newobj = new(instsize, SENDER);
    UNPROTECT_CONTEXT
    if (newobj != nil) goto ok;
%}
.
    "
     memory allocation failed.
     When we arrive here, there was no memory, even after
     a garbage collect. 
     This means, that the VM wanted to get some more memory from the 
     Operatingsystem, which was not kind enough to give it.
     Bad luck - you should increase the swap space on your machine.
    "
    ^ ObjectMemory allocationFailureSignal raise.
!

basicNew:anInteger
    "return an instance of myself with anInteger indexed variables.
     If the receiver-class has no indexed instvars, this is only allowed
     if the argument, anInteger is zero.
     ** Do not redefine this method in any class **"

%{  /* NOCONTEXT */

    OBJ newobj;
    unsigned INT instsize, nInstVars;
    INT nindexedinstvars;
    unsigned INT flags;
#if ! defined(FAST_ARRAY_MEMSET) || defined(NEGATIVE_ADDRESSES)
    REGISTER char *cp;
    short *sp;
    long *lp;
#endif
    REGISTER OBJ *op;
    float *fp;
    double *dp;
    extern OBJ new();

    if (__isSmallInteger(anInteger)) {
	nindexedinstvars = _intVal(anInteger);
	if (nindexedinstvars >= 0) {
	    nInstVars = _intVal(_INST(instSize));
	    flags = _intVal(_INST(flags)) & ARRAYMASK;
	    switch (flags) {
		case BYTEARRAY:
		    instsize = OHDR_SIZE + nindexedinstvars;
		    if (nInstVars == 0) {
			if (_CanDoQuickNew(instsize)) {
			    /*
			     * the most common case
			     */
			    _qCheckedNew(newobj, instsize);
			    _InstPtr(newobj)->o_class = self;
#if defined(FAST_ARRAY_MEMSET) && ! defined(NEGATIVE_ADDRESSES)
			    memset(_InstPtr(newobj)->i_instvars, 0, nindexedinstvars);
#else
			    cp = (char *)_InstPtr(newobj)->i_instvars;
			    while (nindexedinstvars >= sizeof(long)) {
				*(long *)cp = 0;
				cp += sizeof(long);
				nindexedinstvars -= sizeof(long);
			    }
			    while (nindexedinstvars--)
				*cp++ = '\0';
#endif
			    RETURN ( newobj );
			}
		    } else {
			instsize += __OBJS2BYTES__(nInstVars);
		    }
		    PROTECT_CONTEXT
		    _qNew(newobj, instsize, SENDER);
		    UNPROTECT_CONTEXT
		    if (newobj == nil) {
			break;
		    }
		    _InstPtr(newobj)->o_class = self;
#if defined(FAST_ARRAY_MEMSET) && ! defined(NEGATIVE_ADDRESSES)
		    /*
		     * knowing that nil is 0
		     */
		    memset(_InstPtr(newobj)->i_instvars, 0, instsize-OHDR_SIZE);
#else
		    op = _InstPtr(newobj)->i_instvars;
		    while (nInstVars--)
			*op++ = nil;
		    cp = (char *)op;
		    while (nindexedinstvars >= sizeof(long)) {
			*(long *)cp = 0;
			cp += sizeof(long);
			nindexedinstvars -= sizeof(long);
		    }
		    while (nindexedinstvars--)
			*cp++ = '\0';
#endif
		    RETURN ( newobj );
		    break;

		case WORDARRAY:
		    instsize = OHDR_SIZE + 
			       __OBJS2BYTES__(nInstVars) + 
			       nindexedinstvars * sizeof(short);
		    PROTECT_CONTEXT
		    _qNew(newobj, instsize, SENDER);
		    UNPROTECT_CONTEXT
		    if (newobj == nil) {
			break;
		    }
		    _InstPtr(newobj)->o_class = self;
#if defined(FAST_ARRAY_MEMSET) && ! defined(NEGATIVE_ADDRESSES)
		    /*
		     * knowing that nil is 0
		     */
		    memset(_InstPtr(newobj)->i_instvars, 0, instsize - OHDR_SIZE);
#else
		    op = _InstPtr(newobj)->i_instvars;
		    while (nInstVars--)
			*op++ = nil;
		    sp = (short *)op;
		    while (nindexedinstvars--)
			*sp++ = 0;
#endif
		    RETURN ( newobj );
		    break;

	       case LONGARRAY:
		    instsize = OHDR_SIZE + 
			       __OBJS2BYTES__(nInstVars) + 
			       nindexedinstvars * sizeof(long);
		    PROTECT_CONTEXT
		    _qAlignedNew(newobj, instsize, SENDER);
		    UNPROTECT_CONTEXT
		    if (newobj == nil) {
			break;
		    }
		    _InstPtr(newobj)->o_class = self;
#if defined(FAST_ARRAY_MEMSET4) && ! defined(NEGATIVE_ADDRESSES)
		    /*
		     * knowing that nil is 0
		     */
		    memset4(_InstPtr(newobj)->i_instvars, 0, nInstVars + nindexedinstvars);
#else
# if defined(FAST_ARRAY_MEMSET) && ! defined(NEGATIVE_ADDRESSES)
		    /*
		     * knowing that nil is 0
		     */
		    memset(_InstPtr(newobj)->i_instvars, 0, instsize - OHDR_SIZE);
# else
		    op = _InstPtr(newobj)->i_instvars;
		    while (nInstVars--)
			*op++ = nil;
		    lp = (long *)op;
		    while (nindexedinstvars--)
			*lp++ = 0;
# endif
#endif
		    RETURN ( newobj );
		    break;

	       case FLOATARRAY:
		    instsize = sizeof(struct floatArray) + 
			       __OBJS2BYTES__(nInstVars) + 
			       (nindexedinstvars - 1) * sizeof(float);

		    PROTECT_CONTEXT
		    _qNew(newobj, instsize, SENDER);
		    UNPROTECT_CONTEXT
		    if (newobj == nil) {
			break;
		    }
		    _InstPtr(newobj)->o_class = self;
		    op = _InstPtr(newobj)->i_instvars;
# if defined(mips) /* knowin that float 0.0 is all-zeros */
		    memset(_InstPtr(newobj)->i_instvars, 0, instsize - OHDR_SIZE);
# else
		    while (nInstVars--)
			*op++ = nil;
		    fp = (float *)op;
		    while (nindexedinstvars--)
			*fp++ = 0.0;
# endif
		    RETURN ( newobj );
		    break;

	       case DOUBLEARRAY:
		    instsize = sizeof(struct doubleArray) + 
			       __OBJS2BYTES__(nInstVars) + 
			       (nindexedinstvars - 1) * sizeof(double);

		    PROTECT_CONTEXT
		    _qAlignedNew(newobj, instsize, SENDER);
		    UNPROTECT_CONTEXT
		    if (newobj == nil) {
			break;
		    }
		    _InstPtr(newobj)->o_class = self;
		    op = _InstPtr(newobj)->i_instvars;
		    while (nInstVars--)
			*op++ = nil;
#ifdef NEED_DOUBLE_ALIGN
		    /*
		     * care for double alignment
		     */
		    if ((INT)op & (ALIGN-1)) {
			*op++ = nil;
		    }
#endif
		    dp = (double *)op;
		    while (nindexedinstvars--)
			*dp++ = 0.0;
		    RETURN ( newobj );
		    break;

		case WKPOINTERARRAY:
		case POINTERARRAY:
		    nInstVars += nindexedinstvars;
		    instsize = OHDR_SIZE + __OBJS2BYTES__(nInstVars);
		    PROTECT_CONTEXT
		    _qAlignedNew(newobj, instsize, SENDER);
		    UNPROTECT_CONTEXT
		    if (newobj == nil) {
			break;
		    }
		    _InstPtr(newobj)->o_class = self;
#if defined(FAST_ARRAY_MEMSET4)
		    memset4(_InstPtr(newobj)->i_instvars, nil, nInstVars);
#else
# if !defined(NEGATIVE_ADDRESSES)
		    /*
		     * knowing that nil is 0
		     */
#ifdef mips
# undef FAST_ARRAY_MEMSET_DOUBLES_UNROLLED
# undef FAST_ARRAY_MEMSET_LONGLONG_UNROLLED
/* seems to be slightly faster */
# define FAST_ARRAY_MEMSET
#endif
#ifdef sparc
# define FAST_ARRAY_MEMSET_DOUBLES_UNROLLED
#endif

#  if defined(FAST_ARRAY_MEMSET_DOUBLES_UNROLLED)
		    op = _InstPtr(newobj)->i_instvars;
		    if (nInstVars > 8) {
			*op++ = nil;    /* for alignment */
			nInstVars--;
			while (nInstVars >= 8) {
			    *(double *)op = 0.0;
			    ((double *)op)[1] = 0.0;
			    ((double *)op)[2] = 0.0;
			    ((double *)op)[3] = 0.0;
			    op += 8;
			    nInstVars -= 8;
			}
		    }
		    while (nInstVars) {
			*op++ = 0;
			nInstVars--;
		    }
#  else
#   if defined(FAST_ARRAY_MEMSET_LONGLONG_UNROLLED)
		    op = _InstPtr(newobj)->i_instvars;
		    if (nInstVars > 8) {
			*op++ = nil;    /* for alignment */
			nInstVars--;
			while (nInstVars >= 8) {
			    *(long long *)op = 0;
			    ((long long *)op)[1] = 0;
			    ((long long *)op)[2] = 0;
			    ((long long *)op)[3] = 0;
			    op += 8;
			    nInstVars -= 8;
			}
		    }
		    while (nInstVars) {
			*op++ = 0;
			nInstVars--;
		    }
#   else
#    if defined(FAST_ARRAY_MEMSET)
		    memset(_InstPtr(newobj)->i_instvars, 0, instsize - OHDR_SIZE);
#    else
		    op = _InstPtr(newobj)->i_instvars;
		    while (nInstVars--)
			*op++ = nil;
#    endif
#   endif
#  endif
# else
		    op = _InstPtr(newobj)->i_instvars;
		    while (nInstVars--)
			*op++ = nil;
# endif
#endif
		    RETURN ( newobj );
		    break;

		default:
		    /*
		     * new:n for non-variable classes only allowed if
		     * n == 0
		     */
		    if (nindexedinstvars == 0) {
			instsize = OHDR_SIZE + __OBJS2BYTES__(nInstVars);
			PROTECT_CONTEXT
			_qAlignedNew(newobj, instsize, SENDER);
			UNPROTECT_CONTEXT
			if (newobj == nil) {
			    break;
			}
			_InstPtr(newobj)->o_class = self;
			if (nInstVars) {
#if defined(FAST_OBJECT_MEMSET4)
			    memset4(_InstPtr(newobj)->i_instvars, nil, nInstVars);
#else
# if defined(FAST_MEMSET) && ! defined(NEGATIVE_ADDRESSES)
			    /*
			     * knowing that nil is 0
			     */
			    memset(_InstPtr(newobj)->i_instvars, 0, instsize - OHDR_SIZE);
# else
			    op = _InstPtr(newobj)->i_instvars;
			    do {
				*op++ = nil;
			    } while (--nInstVars);
# endif
#endif
			}
			RETURN ( newobj );
		    }
		    break;
	    }
	}
    }
%}.
    "
     arrive here if something went wrong ...
     figure out what it was
    "

    (anInteger isMemberOf:SmallInteger) ifFalse:[
	"
	 the argument is either not an integer,
	 or a LargeInteger (which means that its definitely too big)
	"
	self error:'argument to new: must be Integer'.
	^ nil
    ].
    (anInteger < 0) ifTrue:[
	"
	 the argument is negative,
	"
	self error:'bad (negative) argument to new:'.
	^ nil
    ].
    self isVariable ifFalse:[
	"
	 this class does not have any indexed instance variables
	"
	self error:'class has no indexed instvars - cannot create with new:'.
	^ nil
    ].
    "
     memory allocation failed.
     When we arrive here, there was no memory, even after
     a garbage collect. 
     This means, that the VM wanted to get some more memory from the 
     Operatingsystem, which was not kind enough to give it.
     Bad luck - you should increase the swap space on your machine.
    "
    ^ ObjectMemory allocationFailureSignal raise.
!

readFrom:aStream
    "read an objects printed representation from the argument, aStream 
     and return it. 
     The read object must be a kind of myself if its not, an error is raised.
     This is the reverse operation to 'storeOn:'.

     WARNING: storeOn: does not handle circular references and multiple 
	      references to the same object.
	      Use #storeBinary:/readBinaryFrom: for this."

    ^ self readFrom:aStream onError:[self error:'expected ' , self name]

    "
     |s|
     s := WriteStream on:String new.
     #(1 2 3 4) storeOn:s.
     Object readFrom:(ReadStream on:s contents)  
    "
!

readFrom:aStream onError:exceptionBlock
    "read an objects printed representation from the argument, aStream 
     and return it (i.e. the stream should contain some representation of
     the object which was created using #storeOn:). 
     The read object must be a kind of myself if its not, the value of
     exceptionBlock is returned.
     To get any object, use 'Object readFrom:...',
     To get any number, use 'Number readFrom:...' and so on.
     This is the reverse operation to 'storeOn:'.

     WARNING: storeOn: does not handle circular references and multiple 
	      references to the same object.
	      Use #storeBinary:/readBinaryFrom: for this."

    |newObject|

    newObject := self compilerClass evaluate:aStream.
    (newObject isKindOf:self) ifFalse:[^ exceptionBlock value].
    ^ newObject

    "
     |s|
     s := WriteStream on:String new.
     #(1 2 3 4) storeOn:s.
     Transcript showCr:(
	Array readFrom:(ReadStream on:s contents) onError:'not an Array'
     )
    "
    "
     |s|
     s := WriteStream on:String new.
     #[1 2 3 4] storeOn:s.
     Transcript showCr:(
	 Array readFrom:(ReadStream on:s contents) onError:'not an Array'
     ]
    "
!

readFromString:aString
    "create an object from its printed representation.
     For most classes, the string is expected to be in a format created by
     storeOn: or storeString; however, some (Time, Date) expect a user
     readable string here.
     See comments in Behavior>>readFromString:onError:,
     Behavior>>readFrom: and Behavior>>readFrom:onError:"

    ^ self readFromString:aString onError:[self error:'expected ' , self name]

    "
     Integer readFromString:'12345678901234567890' 
     Point readFromString:'1@2'  
    "
!

readFromString:aString onError:exceptionBlock
    "create an object from its printed representation.
     Here, the string is expected to be in a format created by
     storeOn: or storeString; however, some classes (Time, Date) may redefine
     it to expect a user readable string here.
     See comments in Behavior>>readFrom: and Behavior>>readFrom:onError:"

    ^ self readFrom:(ReadStream on:aString) onError:exceptionBlock

    "
     Integer readFromString:'12345678901234567890' 
     Integer readFromString:'abc' 
     Integer readFromString:'abc' onError:0
     Point readFromString:'1@2'  
     Point readFromString:'0'  
     Point readFromString:'0' onError:[0@0]  
    "
! !

!Behavior methodsFor:'autoload check'!

isLoaded
    "return true, if the class has been loaded; 
     redefined in Autoload; see comment there"

    ^ true
!

autoload
    "force autoloading - do nothing here; 
     redefined in Autoload; see comment there"

    ^ self
! !

!Behavior methodsFor:'snapshots'!

preSnapshot
    "sent by ObjectMemory, before a snapshot is written.
     Nothing done here."
!

postSnapshot
    "sent by ObjectMemory, after a snapshot has been written.
     Nothing done here."
! !

!Behavior class methodsFor:'flag bit constants'!

flagNotIndexed
    "return the flag code for non-indexed instances"

    ^ 0
! 

flagBytes
    "return the flag code for byte-valued indexed instances"

%{  /* NOCONTEXT */
    /* this is defined as a primitive to get defines from stc.h */

    RETURN ( _MKSMALLINT(BYTEARRAY) );
%}
    "
     Behavior flagBytes    
    "
! 

flagWords
    "return the flag code for word-valued indexed instances (i.e. 2-byte)"

%{  /* NOCONTEXT */
    /* this is defined as a primitive to get defines from stc.h */

    RETURN ( _MKSMALLINT(WORDARRAY) );
%}
    "
     Behavior flagWords    
    "
! 

flagLongs
    "return the flag code for long-valued indexed instances (i.e. 4-byte)"

%{  /* NOCONTEXT */
    /* this is defined as a primitive to get defines from stc.h */

    RETURN ( _MKSMALLINT(LONGARRAY) );
%}
    "
     Behavior flagLongs    
    "
! 

flagFloats
    "return the flag code for float-valued indexed instances (i.e. 4-byte reals)"

%{  /* NOCONTEXT */
    /* this is defined as a primitive to get defines from stc.h */

    RETURN ( _MKSMALLINT(FLOATARRAY) );
%}
    "
     Behavior flagFloats    
    "
! 

flagDoubles
    "return the flag code for double-valued indexed instances (i.e. 8-byte reals)"

%{  /* NOCONTEXT */
    /* this is defined as a primitive to get defines from stc.h */

    RETURN ( _MKSMALLINT(DOUBLEARRAY) );
%}
    "
     Behavior flagDoubles    
    "
! 

flagPointers
    "return the flag code for pointer indexed instances (i.e. Array of object)"

%{  /* NOCONTEXT */
    /* this is defined as a primitive to get defines from stc.h */

    RETURN ( _MKSMALLINT(POINTERARRAY) );
%}
    "
     Behavior flagPointers    
    "
! 

flagWeakPointers
    "return the flag code for weak pointer indexed instances (i.e. WeakArray)"

%{  /* NOCONTEXT */
    /* this is defined as a primitive to get defines from stc.h */

    RETURN ( _MKSMALLINT(WKPOINTERARRAY) );
%}
! 

maskIndexType
    "return a mask to extract all index-type bits"

%{  /* NOCONTEXT */
    /* this is defined as a primitive to get defines from stc.h */

    RETURN ( _MKSMALLINT(ARRAYMASK) );
%}
! 

flagBlock
    "return the flag code which marks Block-type instances"

%{  /* NOCONTEXT */
    /* this is defined as a primitive to get defines from stc.h */

    RETURN ( _MKSMALLINT(BLOCK_INSTS) );
%}
! 

flagMethod
    "return the flag code which marks Method-type instances"

%{  /* NOCONTEXT */
    /* this is defined as a primitive to get defines from stc.h */

    RETURN ( _MKSMALLINT(METHOD_INSTS) );
%}
! 

flagContext
    "return the flag code which marks Context-type instances"

%{  /* NOCONTEXT */
    /* this is defined as a primitive to get defines from stc.h */

    RETURN ( _MKSMALLINT(CONTEXT_INSTS) );
%}
! 

flagBlockContext
    "return the flag code which marks BlockContext-type instances"

%{  /* NOCONTEXT */
    /* this is defined as a primitive to get defines from stc.h */

    RETURN ( _MKSMALLINT(BCONTEXT_INSTS) );
%}
! 

flagFloat
    "return the flag code which marks Float-type instances"

%{  /* NOCONTEXT */
    /* this is defined as a primitive to get defines from stc.h */

    RETURN ( _MKSMALLINT(FLOAT_INSTS) );
%}
! 

flagSymbol
    "return the flag code which marks Symbol-type instances"

%{  /* NOCONTEXT */
    /* this is defined as a primitive to get defines from stc.h */

    RETURN ( _MKSMALLINT(SYMBOL_INSTS) );
%}
! !

!Behavior methodsFor:'accessing'!

name
    "although behaviors have no name, we return something
     useful here - there are many places (inspectors) where
     a classes name is asked for.
     Implementing this message here allows anonymous classes
     and instances of them to be inspected."

    ^ 'someBehavior'
!

superclass
    "return the receivers superclass"

    ^ superclass
!

selectorArray 
    "return the receivers selector array.
     Notice: this is not compatible with ST-80."

    ^ selectorArray
!

methodArray
    "return the receivers method array.
     Notice: this is not compatible with ST-80."

    ^ methodArray
!

methodDictionary
    "return the receivers method dictionary. 
     Since no dictionary is actually present, create one for ST-80 compatibility."

    |dict|

    dict := IdentityDictionary new.
    1 to:selectorArray size do:[:index |
	dict at:(selectorArray at:index) put:(methodArray at:index)
    ].
    ^ dict
!

instSize
    "return the number of instance variables of the receiver.
     This includes all superclass instance variables."

    ^ instSize
!

flags
    "return the receivers flag bits"

    ^ flags
!

superclass:aClass
    "set the superclass - this actually creates a new class,
     recompiling all methods for the new one. The receiving class stays
     around anonymous to allow existing instances some life.
     This may change in the future (adjusting existing instances)"

    "must flush caches since lookup chain changes"
    ObjectMemory flushCaches.

"
    superclass := aClass
"
    "for correct recompilation, just create a new class ..."

    aClass subclass:(self name)
	   instanceVariableNames:(self instanceVariableString)
	   classVariableNames:(self classVariableString)
	   poolDictionaries:''
	   category:self category
!

addSuperclass:aClass
    "EXPERIMENTAL MI support: add aClass to the set of classes, from which instances
     inherit protocol."

    "first, check if the class is abstract - 
     allows abstract mixins are allowed in the current implementation"

    aClass instSize == 0 ifFalse:[
	self error:'only abstract mixins allowed'.
	^ self
    ].
    otherSuperclasses isNil ifTrue:[
	otherSuperclasses := Array with:aClass
    ] ifFalse:[
	otherSuperclasses := otherSuperclasses copyWith:aClass
    ].
    ObjectMemory flushCaches
!

removeSuperclass:aClass
    "EXPERIMENTAL MI support: remove aClass from the set of classes, from which instances
     inherit protocol."

    otherSuperclasses notNil ifTrue:[
	otherSuperclasses := otherSuperclasses copyWithout:aClass.
	otherSuperclasses isEmpty ifTrue:[
	    otherSuperclasses := nil
	].
	ObjectMemory flushCaches
    ].
!

selectors:newSelectors methods:newMethods
    "set both selector array and method array of the receiver,
     and flush caches"

    ObjectMemory flushCaches.
    selectorArray := newSelectors.
    methodArray := newMethods
!

addSelector:newSelector withMethod:newMethod
    "add the method given by 2nd argument under the selector given by
     1st argument to the methodDictionary. Flush all caches."

    |nargs|

    (self primAddSelector:newSelector withMethod:newMethod) ifFalse:[^ false].
    self changed:#methodDictionary with:newSelector.

    "
     if I have no subclasses, all we have to flush is cached
     data for myself ... (actually, in any case all that needs
     to be flushed is info for myself and all of my subclasses)
    "
"
    problem: this is slower; since looking for all subclasses is (currently)
	     a bit slow :-(
	     We need the hasSubclasses-info bit in Behavior; now

    self withAllSubclassesDo:[:aClass |
	ObjectMemory flushInlineCachesFor:aClass withArgs:nargs.
	ObjectMemory flushMethodCacheFor:aClass
    ].
"

    "
     actually, we would do better with less flushing ...
    "
    nargs := newSelector numArgs.

    ObjectMemory flushMethodCache.
    ObjectMemory flushInlineCachesWithArgs:nargs.

    ^ true
!

addSelector:newSelector withLazyMethod:newMethod
    "add the method given by 2nd argument under the selector given by
     1st argument to the methodDictionary. Since it does not flush
     any caches, this is only allowed for lazy methods."

    newMethod isLazyMethod ifFalse:[
	self error:'operation only allowed for lazy methods'.
	^ false
    ].
    (self primAddSelector:newSelector withMethod:newMethod) ifTrue:[
	self changed:#methodDictionary with:newSelector.
	^ true
    ].
    ^ false
!

removeSelector:aSelector
    "remove the selector, aSelector and its associated method 
     from the methodDictionary"

    |index oldSelectorArray oldMethodArray newSelectorArray newMethodArray|

    index := selectorArray identityIndexOf:aSelector startingAt:1.
    (index == 0) ifTrue:[^ false].

    newSelectorArray := selectorArray copyWithoutIndex:index.
    newMethodArray := methodArray copyWithoutIndex:index.
    oldSelectorArray := selectorArray.
    oldMethodArray := methodArray.
    selectorArray := newSelectorArray.
    methodArray := newMethodArray.
"
    [
	|nargs|
	nargs := aSelector numArgs.
	ObjectMemory flushMethodCache.
	ObjectMemory flushInlineCachesWithArgs:nargs.
    ] value
"
    "
     actually, we would do better with less flushing ...
    "
    ObjectMemory flushCaches.
    ^ true
! !

!Behavior methodsFor:'queries'!

sizeOfInst:n
    "return the number of bytes required for an instance of
     myself with n indexed instance variables. The argument n 
     should be zero for classes without indexed instance variables.
     See Behavior>>niceNew: for an application of this."

    |nInstvars|

    nInstvars := self instSize.
%{
    int nBytes;

    nBytes = _intVal(nInstvars) * sizeof(OBJ) + OHDR_SIZE; 
    if (__isSmallInteger(n)) {
	int nIndex;

	nIndex = _intVal(n);
	switch (_intVal(_INST(flags)) & ARRAYMASK) {
	    case BYTEARRAY:
		nBytes += nIndex;
		if (nBytes & (ALIGN - 1)) {
		    nBytes = (nBytes & ~(ALIGN - 1)) + ALIGN;
		}
		break;

	    case WORDARRAY:
		nBytes += nIndex * sizeof(short);
		if (nBytes & (ALIGN - 1)) {
		    nBytes = (nBytes & ~(ALIGN - 1)) + ALIGN;
		}
		break;

	    case LONGARRAY:
		nBytes += nIndex * sizeof(long);
		break;

	    case FLOATARRAY:
		nBytes += nIndex * sizeof(float);
		break;

	    case DOUBLEARRAY:
		nBytes += nIndex * sizeof(double);
		break;

	    default:
		nBytes += nIndex * sizeof(OBJ);
		break;
	}
    }
    RETURN (_MKSMALLINT(nBytes));
%}
!

isVariable
    "return true, if instances have indexed instance variables"

    "this could be defined as:
	^ (flags bitAnd:(Behavior maskIndexType)) ~~ 0
     "

%{  /* NOCONTEXT */

    RETURN ( (_intVal(_INST(flags)) & ARRAYMASK) ? true : false ); 
%}
!

isFixed
    "return true, if instances do not have indexed instance variables"

    "this could be defined as:
	^ self isVariable not
    "

%{  /* NOCONTEXT */

    RETURN ( (_intVal(_INST(flags)) & ARRAYMASK) ? false : true ); 
%}
!

isBits
    "return true, if instances have indexed byte or short instance variables.
     Ignore long, float and double arrays, since ST-80 code using isBits are probably
     not prepared to handle them correctly."

%{  /* NOCONTEXT */

    REGISTER int flags;

    RETURN ( (((flags = (_intVal(_INST(flags)) & ARRAYMASK)) == BYTEARRAY)
	     || (flags == WORDARRAY)) ? true : false ); 
%}
!

isBytes
    "return true, if instances have indexed byte instance variables"

    "this could be defined as:
	^ (flags bitAnd:(Behavior maskIndexType)) == Behavior flagBytes
    "
%{  /* NOCONTEXT */

    RETURN ( ((_intVal(_INST(flags)) & ARRAYMASK) == BYTEARRAY) ? true : false ); 
%}
!

isWords
    "return true, if instances have indexed short instance variables"

    "this could be defined as:
	^ (flags bitAnd:(Behavior maskIndexType)) == Behavior flagWords
    "
%{  /* NOCONTEXT */

    RETURN ( ((_intVal(_INST(flags)) & ARRAYMASK) == WORDARRAY) ? true : false ); 
%}
!

isLongs
    "return true, if instances have indexed long instance variables"

    "this could be defined as:
	^ (flags bitAnd:(Behavior maskIndexType)) == Behavior flagLongs
    "
%{  /* NOCONTEXT */

    RETURN ( ((_intVal(_INST(flags)) & ARRAYMASK) == LONGARRAY) ? true : false ); 
%}
!

isFloats
    "return true, if instances have indexed float instance variables"

    "this could be defined as:
	^ (flags bitAnd:(Behavior maskIndexType)) == Behavior flagFloats
    "
%{  /* NOCONTEXT */

    RETURN ( ((_intVal(_INST(flags)) & ARRAYMASK) == FLOATARRAY) ? true : false ); 
%}
!

isDoubles
    "return true, if instances have indexed double instance variables"

    "this could be defined as:
	^ (flags bitAnd:(Behavior maskIndexType)) == Behavior flagDoubles
    "
%{  /* NOCONTEXT */

    RETURN ( ((_intVal(_INST(flags)) & ARRAYMASK) == DOUBLEARRAY) ? true : false ); 
%}
!

isPointers
    "return true, if instances have pointer instance variables 
     i.e. are either non-indexed or have indexed pointer variables"

    "QUESTION: should we ignore WeakPointers ?"

%{  /* NOCONTEXT */

    REGISTER int flags;

    flags = _intVal(_INST(flags)) & ARRAYMASK;
    switch (flags) {
	default:
	    /* normal objects */
	    RETURN ( true );

	case BYTEARRAY:
	case WORDARRAY:
	case LONGARRAY:
	case FLOATARRAY:
	case DOUBLEARRAY:
	    RETURN (false );

	case WKPOINTERARRAY:
	    /* what about those ? */
	    RETURN (true );
    }
%}
!

isBehavior
    "return true, if the receiver is describing another objects behavior,
     i.e. is a class. Defined to avoid the need to use isKindOf:"

    ^ true

    "
     True isBehavior   
     true isBehavior
    "
!

canBeSubclassed
    "return true, if its allowed to create subclasses of the receiver.
     This method is redefined in SmallInteger and UndefinedObject, since
     instances are detected by their pointer-fields, i.e. they do not have
     a class entry (you dont have to understand this :-)"

    ^ true
!

hasMultipleSuperclasses
    "Return true, if this class inherits from other classes 
     (beside its primary superclass). 
     This method is a preparation for a future multiple inheritance extension 
     - currently it is not supported by the VM"

    ^ otherSuperclasses notNil
!

superclasses
    "return a collection of the receivers immediate superclasses.
     This method is a preparation for a future multiple inheritance extension 
     - currently it is not supported by the VM"

    otherSuperclasses notNil ifTrue:[
	^ (Array with:superclass) , otherSuperclasses
    ].
    ^ Array with:superclass

    "
     String superclasses  
    "
!

allSuperclasses
    "return a collection of the receivers accumulated superclasses"

    |aCollection theSuperClass|

    theSuperClass := superclass.
    theSuperClass notNil ifTrue:[
	aCollection := OrderedCollection new.
	[theSuperClass notNil] whileTrue:[
	    aCollection add:theSuperClass.
	    theSuperClass := theSuperClass superclass
	]
    ].
    ^ aCollection

    "
     String allSuperclasses 
    "
!

withAllSuperclasses
    "return a collection containing the receiver and all
     of the receivers accumulated superclasses"

    |aCollection theSuperClass|

    aCollection := OrderedCollection with:self.
    theSuperClass := superclass.
    [theSuperClass notNil] whileTrue:[
	aCollection add:theSuperClass.
	theSuperClass := theSuperClass superclass
    ].
    ^ aCollection

    "
     String withAllSuperclasses 
    "
!

subclasses
    "return a collection of the direct subclasses of the receiver"

    |newColl|

    newColl := OrderedCollection new.
    self subclassesDo:[:aClass |
	newColl add:aClass
    ].
    ^ newColl

    "
     Collection subclasses
    "
!

allSubclasses
    "return a collection of all subclasses (direct AND indirect) of
     the receiver. There will be no specific order, in which entries
     are returned."

    |newColl|

    newColl := OrderedCollection new.
    self allSubclassesDo:[:aClass |
	newColl add:aClass
    ].
    ^ newColl

    "
     Collection allSubclasses
    "
!

allSubclassesInOrder
    "return a collection of all subclasses (direct AND indirect) of
     the receiver. Higher level subclasses will come before lower ones."

    |newColl|

    newColl := OrderedCollection new.
    self allSubclassesInOrderDo:[:aClass |
	newColl add:aClass
    ].
    ^ newColl

    "
     Collection allSubclassesInOrder
    "
!

withAllSubclasses
    "return a collection containing the receiver and 
     all subclasses (direct AND indirect) of the receiver"

    |newColl|

    newColl := OrderedCollection with:self.
    self allSubclassesDo:[:aClass |
	newColl add:aClass
    ].
    ^ newColl

    "
     Collection withAllSubclasses
    "
!

isSubclassOf:aClass
    "return true, if I am a subclass of the argument, aClass"

    |theClass|

    theClass := superclass.
    [theClass notNil] whileTrue:[
	(theClass == aClass) ifTrue:[^ true].
	theClass := theClass superclass
    ].
    ^ false

    "
     String isSubclassOf:Collection  
     LinkedList isSubclassOf:Array   
     1 isSubclassOf:Number              <- will fail since 1 is no class
    "     
!

allInstVarNames
    "return a collection of all the instance variable name-strings
     this includes all superclass-instance variables.
     Since Behavior has no idea of instvar-names, return an empty collection
     here. Redefined in ClassDescription."

    ^ #()
!

allClassVarNames
    "return a collection of all the class variable name-strings
     this includes all superclass-class variables.
     Since Behavior has no idea of classvar-names, return an empty collection
     here. Redefined in ClassDescription."

    ^ #()
!

allInstances
    "return a collection of all my instances"

    |coll|

    coll := OrderedCollection new:100.
    self allInstancesDo:[:anObject |
	coll add:anObject
    ].
    ^ coll 

    "
     ScrollBar allInstances
    "
!

allDerivedInstances
    "return a collection of all instances of myself and 
     instances of all subclasses of myself"

    |coll|

    coll := OrderedCollection new:100.
    self allDerivedInstancesDo:[:anObject |
	(anObject isKindOf:self) ifTrue:[
	    coll add:anObject
	]
    ].
    ^ coll 

    "
     View allDerivedInstances
    "
!

hasInstances
    "return true, if there are any instances of myself"

    ObjectMemory allObjectsDo:[:anObject |
	(anObject class == self) ifTrue:[
	    ^ true
	]
    ].
    ^ false

    "
     Object hasInstances
     SequenceableCollection hasInstances
     Float hasInstances
    "
!

instanceCount
    "return the number of instances of myself"

    |count|

    count := 0.
    ObjectMemory allObjectsDo:[:anObject |
	(anObject class == self) ifTrue:[
	    count := count + 1
	]
    ].
    ^ count

    "
     View instanceCount
     Object instanceCount
     Float instanceCount
     SequenceableCollection instanceCount
    "
!

derivedInstanceCount
    "return the number of instances of myself and of subclasses"

    |count|

    count := 0.
    ObjectMemory allObjectsDo:[:anObject |
	(anObject isKindOf:self) ifTrue:[
	    count := count + 1
	]
    ].
    ^ count

    "
     View derivedInstanceCount
     SequenceableCollection derivedInstanceCount
    "
!

selectorIndex:aSelector
    "return the index in the arrays for given selector aSelector"

    ^ selectorArray identityIndexOf:aSelector startingAt:1
!

includesSelector:aSelector
    "for ST-80 compatibility"

    ^ self implements:aSelector
!

compiledMethodAt:aSelector
    "return the method for given selector aSelector or nil.
     Only methods in the receiver - not in the superclass chain are tested."

    |index|

    index := selectorArray identityIndexOf:aSelector startingAt:1.
    (index == 0) ifTrue:[^ nil].
    ^ methodArray at:index

    "
     Object compiledMethodAt:#==
     (Object compiledMethodAt:#==) category
    "
!

sourceCodeAt:aSelector
    "return the methods source for given selector aSelector or nil.
     Only methods in the receiver - not in the superclass chain are tested."

    |method|

    method := self compiledMethodAt:aSelector.
    method isNil ifTrue:[^ nil].
    ^ method source

    "
     True sourceCodeAt:#ifTrue:
     Object sourceCodeAt:#==
     Behavior sourceCodeAt:#sourceCodeAt:
    "
!

lookupMethodFor:aSelector
    "return the method, which would be executed if aSelector was sent to
     an instance of the receiver. I.e. the selector arrays of the receiver
     and all of its superclasses are searched for aSelector.
     Return the method, or nil if instances do not understand aSelector.
     EXPERIMENTAL: take care of multiple superclasses."

    |m cls|

    cls := self.
    [cls notNil] whileTrue:[
	m := cls compiledMethodAt:aSelector.
	m notNil ifTrue:[^ m].
	cls hasMultipleSuperclasses ifTrue:[
	    cls superclasses do:[:aSuperClass |
		m := aSuperClass lookupMethodFor:aSelector.
		m notNil ifTrue:[^ m].
	    ].
	    ^ nil
	] ifFalse:[
	    cls := cls superclass
	]
    ].
    ^ nil
!

cachedLookupMethodFor:aSelector
    "return the method, which would be executed if aSelector was sent to
     an instance of the receiver. I.e. the selector arrays of the receiver
     and all of its superclasses are searched for aSelector.
     Return the method, or nil if instances do not understand aSelector.
     This interface provides exactly the same information as #lookupMethodFor:,
     but uses the lookup-cache in the VM for faster search. 
     However, keep in mind, that doing a lookup through the cache also adds new
     entries and can thus slow down the system by polluting the cache with 
     irrelevant entries. (do NOT loop over all objects calling this method).
     Does NOT (currently) handle MI"

%{  /* NOCONTEXT */
    extern OBJ lookup();

    RETURN ( lookup(self, aSelector, SENDER) );
%}

    "
     String cachedLookupMethodFor:#=
     String cachedLookupMethodFor:#asOrderedCollection
    "
!

hasMethods
    "return true, if there are any (local) methods in this class"

    ^ (methodArray size ~~ 0)

    "
     True hasMethods
     True class hasMethods
    "
!

implements:aSelector
    "return true, if the receiver implements aSelector.
     (i.e. implemented in THIS class - NOT in a superclass).
     Dont use this method to check if someone responds to a message -
     use #canUnderstand: on the class or #respondsTo: on the instance
     to do this."

    ^ (selectorArray identityIndexOf:aSelector startingAt:1) ~~ 0

    "
     True implements:#ifTrue:
     True implements:#==
    "
!

canUnderstand:aSelector
    "return true, if the receiver or one of its superclasses implements aSelector.
     (i.e. true if my instances understand aSelector)"

    ^ (self lookupMethodFor:aSelector) notNil

    "
     True canUnderstand:#ifTrue:
     True canUnderstand:#==
     True canUnderstand:#do:
    "
!

whichClassImplements:aSelector
    "return the class in the inheritance chain, which implements the method
     for aSelector; return nil if none.
     EXPERIMENTAL: handle multiple superclasses"

    |cls|

    cls := self.
    [cls notNil] whileTrue:[
	(cls implements:aSelector) ifTrue:[^ cls].
	cls hasMultipleSuperclasses ifTrue:[
	    cls superclasses do:[:aSuperClass |
		|implementingClass|

		implementingClass := aSuperClass whichClassImplements:aSelector.
		implementingClass notNil ifTrue:[^ implementingClass].
	    ].
	    ^ nil
	] ifFalse:[
	    cls := cls superclass
	]
    ].
    ^ nil

    "
     String whichClassImplements:#==
     String whichClassImplements:#collect:
    "
!

inheritsFrom:aClass
    "return true, if the receiver inherits methods from aClass"

    ^ self isSubclassOf:aClass

    "
     True inheritsFrom:Object
     LinkedList inheritsFrom:Array
    "
!

selectorAtMethod:aMethod ifAbsent:failBlock
    "return the selector for given method aMethod
     or the value of failBlock, if not found."

    |index|

    index := methodArray identityIndexOf:aMethod startingAt:1.
    (index == 0) ifTrue:[^ failBlock value].
    ^ selectorArray at:index

    "
     |m|

     m := Object compiledMethodAt:#copy.
     Object selectorAtMethod:m ifAbsent:'oops'].
    "
    "
     |m|

     m := Object compiledMethodAt:#copy.
     Fraction selectorAtMethod:m ifAbsent:'oops'].
    "
!

selectorForMethod:aMethod
    "Return the selector for given method aMethod."

    ^ self selectorAtMethod:aMethod ifAbsent:[nil]
!

containsMethod:aMethod
    "Return true, if the argument, aMethod is a method of myself"

    methodArray isNil ifTrue:[^ false].  "degenerated class"
    ^ (methodArray identityIndexOf:aMethod startingAt:1) ~~ 0
! !

!Behavior methodsFor:'private accessing'!

setSuperclass:sup selectors:sels methods:m instSize:i flags:f
    "set some inst vars. 
     this method is for special uses only - there will be no recompilation
     and no change record is written here. Also, if the receiver class has 
     already been in use, future operation of the system is not guaranteed to
     be correct, since no caches are flushed.
     Therefore: do NOT use it; use Behavior>>superclass: (or flush the caches, at least)"

    superclass := sup.
    selectorArray := sels.
    methodArray := m.
    instSize := i.
    flags := f
!

setSuperclass:aClass
    "set the superclass of the receiver.
     this method is for special uses only - there will be no recompilation
     and no change record written here. Also, if the receiver class has
     already been in use, future operation of the system is not guaranteed to
     be correct, since no caches are flushed.
     Therefore: do NOT use it; use Behavior>>superclass: (or flush the caches, at least)"

    superclass := aClass
!

setOtherSuperclasses:anArrayOfClasses
    "EXPERIMENTAL: set the other superclasses of the receiver.
     this method is for special uses only - there will be no recompilation
     and no change record written here; 
     Do NOT use it."

    otherSuperclasses := anArrayOfClasses
!

instSize:aNumber
    "set the instance size.
     this method is for special uses only - there will be no recompilation
     and no change record written here; 
     Do NOT use it."

    instSize := aNumber
!

flags:aNumber
    "set the flags.
     this method is for special uses only - there will be no recompilation
     and no change record written here; 
     Do NOT use it."

    flags := aNumber
!

setSelectors:sels methods:m
    "set some inst vars. 
     this method is for special uses only - there will be no recompilation
     and no change record written here; 
     Do NOT use it."

    selectorArray := sels.
    methodArray := m.
!

setSelectorArray:anArray
    "set the selector array of the receiver.
     this method is for special uses only - there will be no recompilation
     and no change record written here.
     NOT for general use."

    selectorArray := anArray
!

setMethodArray:anArray
    "set the method array of the receiver.
     this method is for special uses only - there will be no recompilation
     and no change record written here.
     NOT for general use."

    methodArray := anArray
!

setMethodDictionary:aDictionary
    "set the receivers method dictionary. 
     Since no dictionary is actually used, decompose into selector- and
     method arrays and set those. For ST-80 compatibility.
     NOT for general use."

    |n newSelectorArray newMethodArray idx|

    n := aDictionary size.
    newSelectorArray := Array new:n.
    newMethodArray := Array new:n.
    idx := 1.
    aDictionary keysAndValuesDo:[:sel :method |
	newSelectorArray at:idx put:sel.
	newMethodArray at:idx put:method.
	idx := idx + 1
    ].
    selectorArray := newSelectorArray.
    methodArray := newMethodArray
!

primAddSelector:newSelector withMethod:newMethod
    "add the method given by 2nd argument under the selector given by
     the 1st argument to the methodDictionary. 
     Does NOT flush any caches, does NOT write a change record.

     Do not use this in normal situations, strange behavior will be
     the consequence.
     I.e. executing obsolete methods, since the old method will still 
     be executed out of the caches."

    |index oldSelectorArray oldMethodArray newSelectorArray newMethodArray|

    (newSelector isMemberOf:Symbol) ifFalse:[
	self error:'invalid selector'. 
	^ false
    ].
    newMethod isNil ifTrue:[
	self error:'invalid method'. 
	^ false
    ].

    index := selectorArray identityIndexOf:newSelector startingAt:1.
    (index == 0) ifTrue:[
	"
	 a new selector
	"
	newSelectorArray := selectorArray copyWith:newSelector.
	newMethodArray := methodArray copyWith:newMethod.
	"
	 keep a reference so they wont go away ...
	 mhmh: this is no longer needed - try without
	"
	oldSelectorArray := selectorArray.
	oldMethodArray := methodArray.
	selectorArray := newSelectorArray.
	methodArray := newMethodArray
    ] ifFalse:[
	methodArray at:index put:newMethod
    ].
    ^ true
! !

!Behavior methodsFor:'compiler interface'!

compiler
    "return the compiler to use for this class.
     This is the old interface, kept for migration. Dont use it."

    ^ self CompilerClass
!

compilerClass
    "return the compiler to use for this class - 
     this can be redefined in special classes, to get classes with
     Lisp, Prolog, ASN1, Basic :-) or whatever syntax."

    ^ Compiler
! !

!Behavior methodsFor:'enumerating'!

allInstancesDo:aBlock
    "evaluate aBlock for all of my instances"

    ObjectMemory allObjectsDo:[:anObject |
	(anObject class == self) ifTrue:[
	    aBlock value:anObject
	]
    ]

    "
     StandardSystemView allInstancesDo:[:v | Transcript showCr:(v name)]
    "
!

allDerivedInstancesDo:aBlock
    "evaluate aBlock for all of my instances and all instances of subclasses"

    ObjectMemory allObjectsDo:[:anObject |
	(anObject isKindOf:self) ifTrue:[
	    aBlock value:anObject
	]
    ]

    "
     StandardSystemView allDerivedInstancesDo:[:v | Transcript showCr:(v name)]
    "
!

subclassesDo:aBlock
    "evaluate the argument, aBlock for all immediate subclasses.
     This will only enumerate globally known classes - for anonymous
     behaviors, you have to walk over all instances of Behavior."

    Smalltalk allBehaviorsDo:[:aClass |
	(aClass superclass == self) ifTrue:[
	    aBlock value:aClass
	]
    ]

    "
     Collection subclassesDo:[:c | Transcript showCr:(c name)]
    "
!

allSubclassesDo:aBlock
    "evaluate aBlock for all of my subclasses.
     There is no specific order, in which the entries are enumerated.
     This will only enumerate globally known classes - for anonymous
     behaviors, you have to walk over all instances of Behavior."

    Smalltalk allBehaviorsDo:[:aClass |
	(aClass isSubclassOf:self) ifTrue:[
	    aBlock value:aClass
	]
    ]

    "
     Collection allSubclassesDo:[:c | Transcript showCr:(c name)]
    "
!

allSubclassesInOrderDo:aBlock
    "evaluate aBlock for all of my subclasses.
     Higher level subclasses will be enumerated before the deeper ones,
     so the order in which aBlock gets called is ok to fileOut classes in
     correct order for later fileIn.
     This will only enumerate globally known classes - for anonymous
     behaviors, you have to walk over all instances of Behavior"

    self subclassesDo:[:aClass |
	aBlock value:aClass.
	aClass allSubclassesInOrderDo:aBlock
    ]

    "
     Collection allSubclassesInOrderDo:[:c | Transcript showCr:(c name)]
    "
!

allSuperclassesDo:aBlock
    "evaluate aBlock for all of my superclasses"

    |theClass|

    theClass := superclass.
    [theClass notNil] whileTrue:[
	aBlock value:theClass.
	theClass := theClass superclass
    ]

    "
     String allSuperclassesDo:[:c | Transcript showCr:(c name)]
    "
! !

!Behavior methodsFor:'binary storage'!

readBinaryFrom:aStream
    "read an objects binary representation from the argument,
     aStream and return it. 
     The read object must be a kind of myself, otherwise an error is raised. 
     To get any object, use 'Object readBinaryFrom:...',
     To get any number, use 'Number readBinaryFrom:...' and so on.
     This is the reverse operation to 'storeBinaryOn:'. "

    ^ self readBinaryFrom:aStream onError:[self error:('expected ' , self name)]

    "
     |s|
     s := WriteStream on:(ByteArray new).
     #(1 2 3 4) storeBinaryOn:s.
     Object readBinaryFrom:(ReadStream on:s contents)  
    "
    "
     |s|
     s := 'testFile' asFilename writeStream binary.
     #(1 2 3 4) storeBinaryOn:s.
     'hello world' storeBinaryOn:s.
     s close.

     s := 'testFile' asFilename readStream binary.
     Transcript showCr:(Object readBinaryFrom:s).
     Transcript showCr:(Object readBinaryFrom:s).
     s close.
    "
!

readBinaryFrom:aStream onError:exceptionBlock
    "read an objects binary representation from the argument,
     aStream and return it. 
     The read object must be a kind of myself, otherwise the value of
     the exceptionBlock is returned.
     To get any object, use 'Object readBinaryFrom:...',
     To get any number, use 'Number readBinaryFrom:...' and so on.
     This is the reverse operation to 'storeBinaryOn:'. "

    |newObject|

    newObject := (BinaryInputManager new:1024) readFrom:aStream.
    (newObject isKindOf:self) ifFalse:[^ exceptionBlock value].
    ^ newObject

    "
     |s|
     s := WriteStream on:(ByteArray new).
     #(1 2 3 4) storeBinaryOn:s.
     Object readBinaryFrom:(ReadStream on:s contents) onError:['oops'] 
    "
    "
     |s|
     s := WriteStream on:(ByteArray new).
     #[1 2 3 4] storeBinaryOn:s.
     Array readBinaryFrom:(ReadStream on:s contents)  onError:['oops']  
    "
!

storeBinaryDefinitionOn: stream manager: manager
    "classes will store the name only and restore by looking for
     that name in the Smalltalk dictionary."

    | myName |

    myName := self name.
    stream nextNumber:4 put:self signature.
    stream nextNumber:2 put:0.
    stream nextNumber:2 put:myName size.
    myName do:[:c| 
	stream nextPut:c asciiValue
    ]

    "
     |s|
     s := WriteStream on:ByteArray new.
     #(1 2 3 4) storeBinaryOn:s.
     Object readBinaryFrom:(ReadStream on:s contents)  

     |s|
     s := WriteStream on:ByteArray new.
     Rectangle storeBinaryOn:s.
     Object readBinaryFrom:(ReadStream on:s contents)  
    "
!

binaryDefinitionFrom:stream manager:manager
    "read the definition on an empty instance (of my class) from stream.
     All pointer instances are left nil, while all bits are read in here.
     return the new object."

    |obj t
     basicSize "{ Class: SmallInteger }" |

    self isPointers ifTrue: [
	stream next. "skip instSize"
	self isVariable ifTrue: [
	    ^ self basicNew:(stream nextNumber:3)
	].
	^ self basicNew
    ].

    basicSize := stream nextNumber:4.
    obj := self basicNew:basicSize.

    self isBytes ifTrue: [
	stream nextBytes:basicSize into:obj
"
	1 to:basicSize do:[:i |
	    obj basicAt:i put:stream next
	]
"
    ] ifFalse: [
	self isWords ifTrue: [
	    1 to:basicSize do:[:i |
		obj basicAt:i put:(stream nextNumber:2)
	    ]
	] ifFalse:[
	    self isLongs ifTrue: [
		1 to:basicSize do:[:i |
		    obj basicAt:i put:(stream nextNumber:4)
		]
	    ] ifFalse:[
		self isFloats ifTrue: [
		    "could do it in one big read on machines which use IEEE floats ..."
		    1 to:basicSize do:[:i |
			t := Float basicNew.
			Float readBinaryIEEESingleFrom:stream into:t.
			obj basicAt:i put: t
		    ]
		] ifFalse:[
		    self isDoubles ifTrue: [
			"could do it in one big read on machines which use IEEE doubles ..."
			1 to:basicSize do:[:i |
			    t := Float basicNew.
			    Float readBinaryIEEEDoubleFrom:stream into:t.
			    obj basicAt:i put: t
			]
		    ]
		]
	    ]
	]
    ].
    ^obj
! !