'From Squeak3.5 of ''11 April 2003'' [latest update: #5180] on 22 June 2003 at 11:48:54 pm'! "Change Set: GeneralEnh-ajh Date: 22 June 2003 Author: Anthony Hannan Fixes: Enhances failure code for elementsExchangeIdentityWith:. Enhances Interval + and -. Enhances LinkedList species, at: and add:before:. Enhances LookupKey name. Enhances Message printOn:. Moves tryNamedPrimitive... from Object to ProtoObject so simulator will work correctly for all objects. Enhances Object copy by calling postCopy. Fixes Object newFrom: and copySameFrom: so as: will copy indexable fields as well. Fixes Object in: so it will work with BlockClosures as well as BlockContexts. Adds Object asStringOrText so all objects not just MethodReferences can exist in list morphs and print. Adds ReadStream readStream to return self, so readStream can be sent without worrying if the receiver is already a stream. Enhances Stream printOn: to show contents. Adds gray to TextColor constants. Fixes WriteStream setToEnd to update readLimit. New Protocol: Object postCopy. Object literalEqual:. Integer as31BitSmallInt. Message sendTo:, setSelector:, lookupClass:, lookupClass. OrderedCollection removeFirst:, removeLast:. PositionableStream back, backChunck, peekBack. SequenceableCollection allButFirstDo:, allButLastDo:, atLast:[ifAbsent:], atLast:put:, copyWithFirst:. MessageCatcher. "! ProtoObject subclass: #MessageCatcher instanceVariableNames: 'echoToTranscript ' classVariableNames: '' poolDictionaries: '' category: 'Kernel-Contexts'! !MessageCatcher commentStamp: '' prior: 0! Any message sent to me is returned as a Message object. "Message catcher" creates an instance of me. ! !Message class methodsFor: 'instance creation' stamp: 'ajh 7/11/2001 12:05'! catcher ^ MessageCatcher new! ! !MessageCatcher methodsFor: 'as yet unclassified' stamp: 'ajh 9/26/2002 12:24'! doesNotUnderstand: aMessage echoToTranscript == true ifTrue: [Transcript show: aMessage printString; cr]. ^ aMessage! ! !MessageCatcher methodsFor: 'as yet unclassified' stamp: 'ajh 9/26/2002 12:23'! privEchoToTranscript echoToTranscript _ true! ! !ProtoObject methodsFor: 'apply primitives' stamp: 'ajh 1/31/2003 22:20'! tryNamedPrimitive "This method is a template that the Smalltalk simulator uses to execute primitives. See Object documentation whatIsAPrimitive." ^ ContextPart primitiveFailToken! ! !ProtoObject methodsFor: 'apply primitives' stamp: 'ajh 1/31/2003 22:20'! tryNamedPrimitive: arg1 "This method is a template that the Smalltalk simulator uses to execute primitives. See Object documentation whatIsAPrimitive." ^ ContextPart primitiveFailToken! ! !ProtoObject methodsFor: 'apply primitives' stamp: 'ajh 1/31/2003 22:20'! tryNamedPrimitive: arg1 with: arg2 "This method is a template that the Smalltalk simulator uses to execute primitives. See Object documentation whatIsAPrimitive." ^ ContextPart primitiveFailToken! ! !ProtoObject methodsFor: 'apply primitives' stamp: 'ajh 1/31/2003 22:20'! tryNamedPrimitive: arg1 with: arg2 with: arg3 "This method is a template that the Smalltalk simulator uses to execute primitives. See Object documentation whatIsAPrimitive." ^ ContextPart primitiveFailToken! ! !ProtoObject methodsFor: 'apply primitives' stamp: 'ajh 1/31/2003 22:20'! tryNamedPrimitive: arg1 with: arg2 with: arg3 with: arg4 "This method is a template that the Smalltalk simulator uses to execute primitives. See Object documentation whatIsAPrimitive." ^ ContextPart primitiveFailToken! ! !ProtoObject methodsFor: 'apply primitives' stamp: 'ajh 1/31/2003 22:21'! tryNamedPrimitive: arg1 with: arg2 with: arg3 with: arg4 with: arg5 "This method is a template that the Smalltalk simulator uses to execute primitives. See Object documentation whatIsAPrimitive." ^ ContextPart primitiveFailToken! ! !ProtoObject methodsFor: 'apply primitives' stamp: 'ajh 1/31/2003 22:21'! tryNamedPrimitive: arg1 with: arg2 with: arg3 with: arg4 with: arg5 with: arg6 "This method is a template that the Smalltalk simulator uses to execute primitives. See Object documentation whatIsAPrimitive." ^ ContextPart primitiveFailToken! ! !ProtoObject methodsFor: 'apply primitives' stamp: 'ajh 1/31/2003 22:21'! tryNamedPrimitive: arg1 with: arg2 with: arg3 with: arg4 with: arg5 with: arg6 with: arg7 "This method is a template that the Smalltalk simulator uses to execute primitives. See Object documentation whatIsAPrimitive." ^ ContextPart primitiveFailToken! ! !ProtoObject methodsFor: 'apply primitives' stamp: 'ajh 1/31/2003 22:21'! tryNamedPrimitive: arg1 with: arg2 with: arg3 with: arg4 with: arg5 with: arg6 with: arg7 with: arg8 "This method is a template that the Smalltalk simulator uses to execute primitives. See Object documentation whatIsAPrimitive." ^ ContextPart primitiveFailToken! ! !ProtoObject methodsFor: 'apply primitives' stamp: 'ajh 1/31/2003 22:21'! tryPrimitive: primIndex withArgs: argumentArray "This method is a template that the Smalltalk simulator uses to execute primitives. See Object documentation whatIsAPrimitive." ^ ContextPart primitiveFailToken! ! !Object methodsFor: 'accessing' stamp: 'ajh 1/21/2003 12:59'! in: aBlock "Evaluate the given block with the receiver as its argument." ^ aBlock value: self ! ! !Object methodsFor: 'comparing' stamp: 'ajh 2/2/2002 15:02'! literalEqual: other ^ self class == other class and: [self = other]! ! !Object methodsFor: 'converting' stamp: 'ajh 3/11/2003 10:27'! asStringOrText "Answer a string that represents the receiver." ^ self printString ! ! !Object methodsFor: 'copying' stamp: 'ajh 1/27/2003 18:45'! postCopy "self is a shallow copy, subclasses should copy fields as necessary to complete the full copy" ^ self! ! !Object methodsFor: 'copying' stamp: 'ajh 8/18/2001 21:25'! copy "Answer another instance just like the receiver. Subclasses typically override postCopy; they typically do not override shallowCopy." ^self shallowCopy postCopy! ! !Object methodsFor: 'copying' stamp: 'ajh 5/23/2002 00:38'! copySameFrom: otherObject "Copy to myself all instance variables named the same in otherObject. This ignores otherObject's control over its own inst vars." | myInstVars otherInstVars match | myInstVars _ self class allInstVarNames. otherInstVars _ otherObject class allInstVarNames. myInstVars doWithIndex: [:each :index | (match _ otherInstVars indexOf: each) > 0 ifTrue: [self instVarAt: index put: (otherObject instVarAt: match)]]. 1 to: (self basicSize min: otherObject basicSize) do: [:i | self basicAt: i put: (otherObject basicAt: i)]. ! ! !LargePositiveInteger methodsFor: 'converting' stamp: 'ajh 7/25/2001 22:28'! as31BitSmallInt "This is only for 31 bit numbers. Keep my 31 bits the same, but put them in a small int. The small int will be negative since my 31st bit is 1. We know my 31st bit is 1 because otherwise I would already be a positive small int." self highBit = 31 ifFalse: [self error: 'more than 31 bits can not fit in a SmallInteger']. ^ self - 16r80000000! ! !LookupKey methodsFor: 'accessing' stamp: 'ajh 3/24/2003 21:14'! name ^ self key isString ifTrue: [self key] ifFalse: [self key printString]! ! !Message methodsFor: 'accessing' stamp: 'ajh 10/9/2001 16:32'! lookupClass ^ lookupClass! ! !Message methodsFor: 'printing' stamp: 'ajh 10/9/2001 15:31'! printOn: stream args isEmpty ifTrue: [^ stream nextPutAll: selector]. args with: selector keywords do: [:arg :word | stream nextPutAll: word. stream space. arg printOn: stream. stream space. ]. stream skip: -1. ! ! !Message methodsFor: 'private' stamp: 'ajh 9/23/2001 04:59'! lookupClass: aClass lookupClass _ aClass! ! !Message methodsFor: 'private' stamp: 'ajh 3/9/2003 19:25'! setSelector: aSymbol selector _ aSymbol. ! ! !Message methodsFor: 'sending' stamp: 'ajh 1/22/2003 11:51'! sendTo: receiver "answer the result of sending this message to receiver" ^ receiver perform: selector withArguments: args! ! !Object class methodsFor: 'instance creation' stamp: 'ajh 5/23/2002 00:35'! newFrom: aSimilarObject "Create an object that has similar contents to aSimilarObject. If the classes have any instance varaibles with the same names, copy them across. If this is bad for a class, override this method." ^ (self isVariable ifTrue: [self basicNew: aSimilarObject basicSize] ifFalse: [self basicNew] ) copySameFrom: aSimilarObject! ! !SequenceableCollection methodsFor: 'accessing' stamp: 'ajh 6/27/2002 17:53'! atLast: indexFromEnd "Return element at indexFromEnd from the last position. atLast: 1, returns the last element" ^ self atLast: indexFromEnd ifAbsent: [self errorIndexOutOfRange]! ! !SequenceableCollection methodsFor: 'accessing' stamp: 'ajh 6/27/2002 17:52'! atLast: indexFromEnd ifAbsent: block "Return element at indexFromEnd from the last position. atLast: 1 ifAbsent: [] returns the last element" ^ self at: self size + 1 - indexFromEnd ifAbsent: block! ! !SequenceableCollection methodsFor: 'accessing' stamp: 'ajh 6/27/2002 18:10'! atLast: indexFromEnd put: obj "Set the element at indexFromEnd from the last position. atLast: 1 put: obj, sets the last element" ^ self at: self size + 1 - indexFromEnd put: obj! ! !SequenceableCollection methodsFor: 'copying' stamp: 'ajh 9/27/2002 12:09'! copyWithFirst: newElement "Answer a copy of the receiver that is 1 bigger than the receiver with newElement as the first element." | newIC | newIC _ self species ofSize: self size + 1. newIC replaceFrom: 2 to: self size + 1 with: self startingAt: 1. newIC at: 1 put: newElement. ^ newIC! ! !SequenceableCollection methodsFor: 'enumerating' stamp: 'ajh 8/6/2002 15:03'! allButFirstDo: block 2 to: self size do: [:index | block value: (self at: index)]! ! !SequenceableCollection methodsFor: 'enumerating' stamp: 'ajh 8/6/2002 15:01'! allButLastDo: block 1 to: self size - 1 do: [:index | block value: (self at: index)]! ! !Array methodsFor: 'comparing' stamp: 'ajh 2/2/2002 15:03'! literalEqual: other self class == other class ifFalse: [^ false]. self size = other size ifFalse: [^ false]. self with: other do: [:e1 :e2 | (e1 literalEqual: e2) ifFalse: [^ false]]. ^ true! ! !Array methodsFor: 'converting' stamp: 'ajh 9/8/2002 17:45'! elementsExchangeIdentityWith: otherArray "This primitive performs a bulk mutation, causing all pointers to the elements of this array to be replaced by pointers to the corresponding elements of otherArray. At the same time, all pointers to the elements of otherArray are replaced by pointers to the corresponding elements of this array. The identityHashes remain with the pointers rather than with the objects so that objects in hashed structures should still be properly indexed after the mutation." otherArray class == Array ifFalse: [^ self error: 'arg must be array']. self size = otherArray size ifFalse: [^ self error: 'arrays must be same size']. (self anySatisfy: [:obj | obj class == SmallInteger]) ifTrue: [^ self error: 'can''t become SmallIntegers']. (otherArray anySatisfy: [:obj | obj class == SmallInteger]) ifTrue: [^ self error: 'can''t become SmallIntegers']. "Must have failed because not enough space in forwarding table (see ObjectMemory-prepareForwardingTableForBecoming:with:twoWay:). Do GC and try again only once" (Smalltalk bytesLeft: true) = Smalltalk primitiveGarbageCollect ifTrue: [^ self primitiveFailed]. ^ self elementsExchangeIdentityWith: otherArray! ! !Interval methodsFor: 'arithmetic' stamp: 'ajh 3/13/2003 15:45'! + number ^ start + number to: stop + number by: step! ! !Interval methodsFor: 'arithmetic' stamp: 'ajh 3/13/2003 15:46'! - number ^ start - number to: stop - number by: step! ! !LinkedList methodsFor: 'accessing' stamp: 'ajh 8/6/2002 15:46'! at: index | i | i _ 0. self do: [:link | (i _ i + 1) = index ifTrue: [^ link]]. ^ self errorSubscriptBounds: index! ! !LinkedList methodsFor: 'adding' stamp: 'ajh 8/22/2002 14:17'! add: link before: otherLink | aLink | firstLink == otherLink ifTrue: [^ self addFirst: link]. aLink _ firstLink. [aLink == nil] whileFalse: [ aLink nextLink == otherLink ifTrue: [ link nextLink: aLink nextLink. aLink nextLink: link. ^ link ]. aLink _ aLink nextLink. ]. ^ self errorNotFound: otherLink! ! !LinkedList methodsFor: 'enumerating' stamp: 'ajh 8/6/2002 16:39'! species ^ Array! ! !OrderedCollection methodsFor: 'removing' stamp: 'ajh 6/22/2003 14:37'! removeFirst: n "Remove first n object into an array" | list | list _ Array new: n. 1 to: n do: [:i | list at: i put: self removeFirst]. ^ list! ! !OrderedCollection methodsFor: 'removing' stamp: 'ajh 6/22/2003 14:36'! removeLast: n "Remove last n object into an array with last in last position" | list | list _ Array new: n. n to: 1 by: -1 do: [:i | list at: i put: self removeLast]. ^ list! ! !SmallInteger methodsFor: 'converting' stamp: 'ajh 7/25/2001 22:34'! as31BitSmallInt "Polymorphic with LargePositiveInteger (see comment there). Return self since all SmallIntegers are 31 bits" ^ self! ! !Stream methodsFor: 'accessing' stamp: 'ajh 7/31/2001 20:34'! printOn: stream super printOn: stream. stream space. self contents printOn: stream. ! ! !PositionableStream methodsFor: 'accessing' stamp: 'ajh 1/18/2002 01:03'! back "Go back one element and return it. Use indirect messages in case I am a StandardFileStream" self position = 0 ifTrue: [self errorCantGoBack]. self position = 1 ifTrue: [self position: 0. ^ nil]. self skip: -2. ^ self next ! ! !PositionableStream methodsFor: 'accessing' stamp: 'ajh 1/18/2002 01:02'! peekBack "Return the element at the previous position, without changing position. Use indirect messages in case self is a StandardFileStream." | element | element _ self back. self skip: 1. ^ element! ! !PositionableStream methodsFor: 'fileIn/Out' stamp: 'ajh 1/18/2002 01:02'! backChunk "Answer the contents of the receiver back to the previous terminator character. Doubled terminators indicate an embedded terminator character." | terminator out ch | terminator _ $!!. out _ WriteStream on: (String new: 1000). [(ch _ self back) == nil] whileFalse: [ (ch == terminator) ifTrue: [ self peekBack == terminator ifTrue: [ self back. "skip doubled terminator" ] ifFalse: [ ^ out contents reversed "we're done!!" ]. ]. out nextPut: ch. ]. ^ out contents reversed! ! !ReadStream methodsFor: 'accessing' stamp: 'ajh 9/5/2002 22:11'! readStream "polymorphic with SequenceableCollection. Return self" ^ self! ! !TextColor class methodsFor: 'constants' stamp: 'ajh 9/10/2002 02:26'! gray ^ self new color: Color gray! ! !WriteStream methodsFor: 'positioning' stamp: 'ajh 5/25/2001 20:19'! setToEnd "Refer to the comment in PositionableStream|setToEnd." readLimit _ readLimit max: position. super setToEnd.! ! !ReadWriteStream methodsFor: 'converting' stamp: 'ajh 9/14/2002 20:37'! readStream "polymorphic with SequenceableCollection. Return self" ^ self! ! Object removeSelector: #tryNamedPrimitive! Object removeSelector: #tryNamedPrimitive:! Object removeSelector: #tryNamedPrimitive:with:! Object removeSelector: #tryNamedPrimitive:with:with:! Object removeSelector: #tryNamedPrimitive:with:with:with:! Object removeSelector: #tryNamedPrimitive:with:with:with:with:! Object removeSelector: #tryNamedPrimitive:with:with:with:with:with:! Object removeSelector: #tryNamedPrimitive:with:with:with:with:with:with:! Object removeSelector: #tryNamedPrimitive:with:with:with:with:with:with:with:! Object removeSelector: #tryPrimitive:withArgs:!