'From Squeak3.6alpha of ''17 March 2003'' [latest update: #5294] on 6 July 2003 at 1:19:51 pm'! "Change Set: forgivingPrims Date: 3 July 2003 Author: Lex Spoon Modifies several primitives so that they may be executed in other places than in class Object. This is needed for Islands."! !Interpreter methodsFor: 'array and stream primitives' stamp: 'ls 8/17/2000 15:23'! commonAt: stringy "This code is called if the receiver responds primitively to at:. If this is so, it will be installed in the atCache so that subsequent calls of at: or next may be handled immediately in bytecode primitive routines." | index rcvr atIx result | index _ self positive32BitValueOf: (self stackValue: 0). "Sets successFlag" rcvr _ self stackValue: 1. successFlag & (self isIntegerObject: rcvr) not ifFalse: [^ self primitiveFail]. "NOTE: The at-cache, since it is specific to the non-super response to #at:. Therefore we must determine that the message is #at: (not, eg, #basicAt:), and that the send is not a super-send, before using the at-cache." (messageSelector = (self specialSelector: 16) and: [lkupClass = (self fetchClassOfNonInt: rcvr)]) ifTrue: ["OK -- look in the at-cache" atIx _ rcvr bitAnd: AtCacheMask. "Index into atCache = 4N, for N = 0 ... 7" (atCache at: atIx+AtCacheOop) = rcvr ifFalse: ["Rcvr not in cache. Install it..." self install: rcvr inAtCache: atCache at: atIx string: stringy]. successFlag ifTrue: [result _ self commonVariable: rcvr at: index cacheIndex: atIx]. successFlag ifTrue: [^ self pop: argumentCount+1 thenPush: result]]. "The slow but sure way..." successFlag _ true. result _ self stObject: rcvr at: index. successFlag ifTrue: [stringy ifTrue: [result _ self characterForAscii: (self integerValueOf: result)]. ^ self pop: argumentCount+1 thenPush: result]! ! !Interpreter methodsFor: 'array and stream primitives' stamp: 'ls 8/17/2000 14:31'! commonAtPut: stringy "This code is called if the receiver responds primitively to at:Put:. If this is so, it will be installed in the atPutCache so that subsequent calls of at: or next may be handled immediately in bytecode primitive routines." | value index rcvr atIx | value _ self stackValue: 0. index _ self positive32BitValueOf: (self stackValue: 1). "Sets successFlag" rcvr _ self stackValue: 2. successFlag & (self isIntegerObject: rcvr) not ifFalse: [^ self primitiveFail]. "NOTE: The atPut-cache, since it is specific to the non-super response to #at:Put:. Therefore we must determine that the message is #at:Put: (not, eg, #basicAt:Put:), and that the send is not a super-send, before using the at-cache." (messageSelector = (self specialSelector: 17) and: [lkupClass = (self fetchClassOfNonInt: rcvr)]) ifTrue: ["OK -- look in the at-cache" atIx _ (rcvr bitAnd: AtCacheMask) + AtPutBase. "Index into atPutCache" (atCache at: atIx+AtCacheOop) = rcvr ifFalse: ["Rcvr not in cache. Install it..." self install: rcvr inAtCache: atCache at: atIx string: stringy]. successFlag ifTrue: [self commonVariable: rcvr at: index put: value cacheIndex: atIx]. successFlag ifTrue: [^ self pop: argumentCount+1 thenPush: value]]. "The slow but sure way..." successFlag _ true. stringy ifTrue: [self stObject: rcvr at: index put: (self asciiOfCharacter: value)] ifFalse: [self stObject: rcvr at: index put: value]. successFlag ifTrue: [^ self pop: argumentCount+1 thenPush: value]. ! ! !Interpreter methodsFor: 'array and stream primitives' stamp: 'ls 8/17/2000 17:36'! primitiveStringReplace " primReplaceFrom: start to: stop with: replacement startingAt: repStart " | array start stop repl replStart hdr arrayFmt totalLength arrayInstSize replFmt replInstSize srcIndex | array _ self stackValue: 4. start _ self stackIntegerValue: 3. stop _ self stackIntegerValue: 2. repl _ self stackValue: 1. replStart _ self stackIntegerValue: 0. successFlag ifFalse: [^ self primitiveFail]. (self isIntegerObject: repl) "can happen in LgInt copy" ifTrue: [^ self primitiveFail]. hdr _ self baseHeader: array. arrayFmt _ (hdr >> 8) bitAnd: 16rF. totalLength _ self lengthOf: array baseHeader: hdr format: arrayFmt. arrayInstSize _ self fixedFieldsOf: array format: arrayFmt length: totalLength. ((start >= 1) and: [((start-1) <= stop) and: [stop + arrayInstSize <= totalLength]]) ifFalse: [^ self primitiveFail]. hdr _ self baseHeader: repl. replFmt _ (hdr >> 8) bitAnd: 16rF. totalLength _ self lengthOf: repl baseHeader: hdr format: replFmt. replInstSize _ self fixedFieldsOf: repl format: replFmt length: totalLength. ((replStart >= 1) and: [stop - start + replStart + replInstSize <= totalLength]) ifFalse: [^ self primitiveFail]. "Array formats (without byteSize bits, if bytes array) must be same" arrayFmt < 8 ifTrue: [arrayFmt = replFmt ifFalse: [^ self primitiveFail]] ifFalse: [(arrayFmt bitAnd: 16rC) = (replFmt bitAnd: 16rC) ifFalse: [^ self primitiveFail]]. srcIndex _ replStart + replInstSize - 1. " - 1 for 0-based access" arrayFmt < 4 ifTrue: [ "pointer type objects" start + arrayInstSize - 1 to: stop + arrayInstSize - 1 do: [:i | self storePointer: i ofObject: array withValue: (self fetchPointer: srcIndex ofObject: repl). srcIndex _ srcIndex + 1. ] ] ifFalse: [ arrayFmt < 8 ifTrue: [ "long-word type objects" start + arrayInstSize - 1 to: stop + arrayInstSize - 1 do: [:i | self storeWord: i ofObject: array withValue: (self fetchWord: srcIndex ofObject: repl). srcIndex _ srcIndex + 1 ] ] ifFalse: [ "byte-type objects" start + arrayInstSize - 1 to: stop + arrayInstSize - 1 do: [:i | self storeByte: i ofObject: array withValue: (self fetchByte: srcIndex ofObject: repl). srcIndex _ srcIndex + 1. ] ]. ]. self pop: argumentCount "leave rcvr on stack"! ! !Interpreter methodsFor: 'object access primitives' stamp: 'ls 8/17/2000 15:52'! primitiveClass | instance | instance _ self stackTop. self pop: argumentCount+1 thenPush: (self fetchClassOf: instance)! ! !Interpreter methodsFor: 'object access primitives' stamp: 'ls 8/17/2000 14:30'! primitiveInstVarAt | index rcvr hdr fmt totalLength fixedFields value | index _ self stackIntegerValue: 0. rcvr _ self stackValue: 1. successFlag ifTrue: [ hdr _ self baseHeader: rcvr. fmt _ (hdr >> 8) bitAnd: 16rF. totalLength _ self lengthOf: rcvr baseHeader: hdr format: fmt. fixedFields _ self fixedFieldsOf: rcvr format: fmt length: totalLength. ((index >= 1) and: [index <= fixedFields]) ifFalse: [successFlag _ false]]. successFlag ifTrue: [value _ self subscript: rcvr with: index format: fmt]. successFlag ifTrue: [self pop: argumentCount+1 thenPush: value] ifFalse: []! ! !Interpreter methodsFor: 'object access primitives' stamp: 'ls 8/17/2000 14:30'! primitiveInstVarAtPut | newValue index rcvr hdr fmt totalLength fixedFields | newValue _ self stackValue: 0. index _ self stackIntegerValue: 1. rcvr _ self stackValue: 2. successFlag ifTrue: [ hdr _ self baseHeader: rcvr. fmt _ (hdr >> 8) bitAnd: 16rF. totalLength _ self lengthOf: rcvr baseHeader: hdr format: fmt. fixedFields _ self fixedFieldsOf: rcvr format: fmt length: totalLength. ((index >= 1) and: [index <= fixedFields]) ifFalse: [successFlag _ false]]. successFlag ifTrue: [self subscript: rcvr with: index storing: newValue format: fmt]. successFlag ifTrue: [self pop: argumentCount+1 thenPush: newValue] ifFalse: []! ! !Interpreter methodsFor: 'object access primitives' stamp: 'ls 7/4/2003 15:36'! primitiveNextInstance | object instance | object _ self stackValue: 0. instance _ self instanceAfter: object. instance = nilObj ifTrue: [self primitiveFail] ifFalse: [self pop: argumentCount+1 thenPush: instance]! ! !Interpreter methodsFor: 'object access primitives' stamp: 'ls 7/4/2003 15:14'! primitiveNextObject "Return the object following the receiver in the heap. Return the SmallInteger zero when there are no more objects." | object instance | object _ self stackValue: 0. instance _ self accessibleObjectAfter: object. instance = nil ifTrue: [ self pop: argumentCount+1. self pushInteger: 0 ] ifFalse: [ self pop: argumentCount+1 thenPush: instance ].! ! !Interpreter methodsFor: 'object access primitives' stamp: 'ls 7/4/2003 15:36'! primitiveSomeInstance | class instance | class _ self stackValue: 0. instance _ self initialInstanceOf: class. instance = nilObj ifTrue: [self primitiveFail] ifFalse: [self pop: argumentCount+1 thenPush: instance]! ! !Interpreter methodsFor: 'object access primitives' stamp: 'ls 7/4/2003 15:14'! primitiveSomeObject "Return the first object in the heap." self pop: argumentCount+1. self push: self firstAccessibleObject.! !