Packages December 2014

packages@lists.squeakfoundation.org

1 participants
153 discussions

The Trunk: Kernel.spur-nice.892.mcz
by commits＠source.squeak.org 27 Dec '14

27 Dec '14

Eliot Miranda uploaded a new version of Kernel to project The Trunk: http://source.squeak.org/trunk/Kernel.spur-nice.892.mcz ==================== Summary ==================== Name: Kernel.spur-nice.892 Author: eem Time: 26 December 2014, 5:06:08.521 pm UUID: a3b71873-6e18-4eb8-a1c0-075f558df60b Ancestors: Kernel-nice.892, Kernel.spur-eem.891 Kernel-nice.892 patched for Spur by SpurBootstrapMonticelloPackagePatcher Cog-eem.234 Fix Float class>>fromIEEE32Bit: in the case of gradual underflow again... Details: A single precision (32bits) float gradual underflow is of the form biased exponent = 0 (-127 unbiased, but true value to take into account is -126) significand of the form 0.bbb....b (23 bit after the floating point, no implied 1) Once converted to double precision, this will not underflow... So we must shift the significand left until the highest bit pass left of the floating point : for example 0.001b...b ==> 1.b...b000 adjust the exponent (which is -126) by same number of shift (-129 in this example since there are 3 shifts) then remove the leading bit left of floating point - it is already taken into account as the implied 1 now that we do not underflow. =============== Diff against Kernel-nice.892 =============== Item was changed: ----- Method: Behavior>>allInstances (in category 'accessing instances and variables') ----- + allInstances + "Answer all instances of the receiver." + <primitive: 177> + "The primitive can fail because memory is low. If so, fall back on the old + enumeration code, which gives the system a chance to GC and/or grow. + Because aBlock might change the class of inst (for example, using become:), + it is essential to compute next before aBlock value: inst." + | inst insts next | + insts := WriteStream on: (Array new: 64). + inst := self someInstance. + [inst == nil] whileFalse: + [next := inst nextInstance. + (inst == insts or: [inst == insts originalContents]) ifFalse: [insts nextPut: inst]. + inst := next]. + ^insts contents! - allInstances - "Answer a collection of all current instances of the receiver." - - | all | - all := OrderedCollection new. - self allInstancesDo: [:x | x == all ifFalse: [all add: x]]. - ^ all asArray - ! Item was changed: ----- Method: Behavior>>allInstancesDo: (in category 'enumerating') ----- + allInstancesDo: aBlock + "Evaluate aBlock with each of the current instances of the receiver." + | instances inst next | + instances := self allInstancesOrNil. + instances ifNotNil: + [instances do: aBlock. + ^self]. + "allInstancesOrNil can fail because memory is low. If so, fall back on the old + enumeration code. Because aBlock might change the class of inst (for example, + using become:), it is essential to compute next before aBlock value: inst." - allInstancesDo: aBlock - "Evaluate the argument, aBlock, for each of the current instances of the - receiver. - - Because aBlock might change the class of inst (for example, using become:), - it is essential to compute next before aBlock value: inst." - | inst next | inst := self someInstance. + [inst == nil] whileFalse: + [next := inst nextInstance. + aBlock value: inst. + inst := next]! - [inst == nil] - whileFalse: - [ - next := inst nextInstance. - aBlock value: inst. - inst := next]! Item was added: + ----- Method: Behavior>>allInstancesOrNil (in category 'enumerating') ----- + allInstancesOrNil + "Answer all instances of the receiver, or nil if the primitive + fails, which it may be due to being out of memory." + <primitive: 177> + ^nil! Item was changed: ----- Method: Behavior>>basicNew (in category 'instance creation') ----- basicNew "Primitive. Answer an instance of the receiver (which is a class) with no + indexable variables. Fail if the class is indexable. Essential. See Object + documentation whatIsAPrimitive. + + If the primitive fails because space is low then the scavenger will run + before the method is activated. Check that space was low and retry + via handleFailingBasicNew if so." - indexable variables. Fail if the class is indexable. Essential. See Object - documentation whatIsAPrimitive." + <primitive: 70 error: ec> + ec == #'insufficient object memory' ifTrue: + [^self handleFailingBasicNew]. + self isVariable ifTrue: [^self basicNew: 0]. + self primitiveFailed! - <primitive: 70> - self isVariable ifTrue: [ ^ self basicNew: 0 ]. - "space must be low" - OutOfMemory signal. - ^ self basicNew "retry if user proceeds" - ! Item was changed: ----- Method: Behavior>>basicNew: (in category 'instance creation') ----- + basicNew: sizeRequested + "Primitive. Answer an instance of this class with the number of indexable + variables specified by the argument, sizeRequested. Fail if this class is not + indexable or if the argument is not a positive Integer, or if there is not + enough memory available. Essential. See Object documentation whatIsAPrimitive. + + If the primitive fails because space is low then the scavenger will run before the + method is activated. Check args and retry via handleFailingBasicNew: if they're OK." - basicNew: sizeRequested - "Primitive. Answer an instance of this class with the number - of indexable variables specified by the argument, sizeRequested. - Fail if this class is not indexable or if the argument is not a - positive Integer, or if there is not enough memory available. - Essential. See Object documentation whatIsAPrimitive." + <primitive: 71 error: ec> + ec == #'insufficient object memory' ifTrue: + [^self handleFailingBasicNew: sizeRequested]. - <primitive: 71> self isVariable ifFalse: [self error: self printString, ' cannot have variable sized instances']. - (sizeRequested isInteger and: [sizeRequested >= 0]) ifTrue: - ["arg okay; space must be low." - OutOfMemory signal. - ^ self basicNew: sizeRequested "retry if user proceeds"]. self primitiveFailed! Item was added: + ----- Method: Behavior>>byteSizeOfInstance (in category 'accessing instances and variables') ----- + byteSizeOfInstance + "Answer the total memory size of an instance of the receiver." + + <primitive: 181 error: ec> + self isVariable ifTrue: + [^self byteSizeOfInstanceOfSize: 0]. + self primitiveFailed! Item was added: + ----- Method: Behavior>>byteSizeOfInstanceOfSize: (in category 'accessing instances and variables') ----- + byteSizeOfInstanceOfSize: basicSize + "Answer the total memory size of an instance of the receiver + with the given number of indexable instance variables." + + <primitive: 181 error: ec> + self isVariable + ifTrue: "If the primitive overflowed answer a close approximation" + [(basicSize isInteger + and: [basicSize >= 16r1000000]) ifTrue: + [^2 * (self byteSizeOfInstanceOfSize: basicSize + 1 // 2) + - (self byteSizeOfInstanceOfSize: 0)]] + ifFalse: + [basicSize = 0 ifTrue: + [^self byteSizeOfInstance]]. + self primitiveFailed! Item was added: + ----- Method: Behavior>>elementSize (in category 'accessing instances and variables') ----- + elementSize + "Answer the size in bytes of an element in the receiver. The formats are + 0 = 0 sized objects (UndefinedObject True False et al) + 1 = non-indexable objects with inst vars (Point et al) + 2 = indexable objects with no inst vars (Array et al) + 3 = indexable objects with inst vars (MethodContext AdditionalMethodState et al) + 4 = weak indexable objects with inst vars (WeakArray et al) + 5 = weak non-indexable objects with inst vars (ephemerons) (Ephemeron) + 6 = unused + 7 = immediates (SmallInteger, Character) + 8 = unused + 9 = 64-bit indexable + 10-11 = 32-bit indexable (Bitmap) + 12-15 = 16-bit indexable + 16-23 = 8-bit indexable + 24-31 = compiled methods (CompiledMethod)" + | instSpec | + instSpec := self instSpec. + instSpec < 9 ifTrue: [^Smalltalk wordSize]. + instSpec >= 16 ifTrue: [^1]. + instSpec >= 12 ifTrue: [^2]. + instSpec >= 10 ifTrue: [^4]. + ^8! Item was added: + ----- Method: Behavior>>handleFailingBasicNew (in category 'private') ----- + handleFailingBasicNew + "handleFailingBasicNew gets sent after basicNew has failed and allowed + a scavenging garbage collection to occur. The scavenging collection + will have happened as the VM is activating the (failing) basicNew. If + handleFailingBasicNew fails then the scavenge failed to reclaim sufficient + space and a global garbage collection is required. Retry after garbage + collecting and growing memory if necessary. + + Primitive. Answer an instance of this class with the number of indexable + variables specified by the argument, sizeRequested. Fail if this class is not + indexable or if the argument is not a positive Integer, or if there is not + enough memory available. Essential. See Object documentation whatIsAPrimitive." + + <primitive: 70> + Smalltalk garbageCollect < 1048576 ifTrue: + [Smalltalk growMemoryByAtLeast: 1048576]. + ^self handleFailingFailingBasicNew "retry after global garbage collect"! Item was added: + ----- Method: Behavior>>handleFailingBasicNew: (in category 'private') ----- + handleFailingBasicNew: sizeRequested + "handleFailingBasicNew: gets sent after basicNew: has failed and allowed + a scavenging garbage collection to occur. The scavenging collection + will have happened as the VM is activating the (failing) basicNew:. If + handleFailingBasicNew: fails then the scavenge failed to reclaim sufficient + space and a global garbage collection is required. Retry after garbage + collecting and growing memory if necessary. + + Primitive. Answer an instance of this class with the number of indexable + variables specified by the argument, sizeRequested. Fail if this class is not + indexable or if the argument is not a positive Integer, or if there is not + enough memory available. Essential. See Object documentation whatIsAPrimitive." + + <primitive: 71> + | bytesRequested | + bytesRequested := self byteSizeOfInstanceOfSize: sizeRequested. + Smalltalk garbageCollect < bytesRequested ifTrue: + [Smalltalk growMemoryByAtLeast: bytesRequested]. + "retry after global garbage collect and possible grow" + ^self handleFailingFailingBasicNew: sizeRequested! Item was added: + ----- Method: Behavior>>handleFailingFailingBasicNew (in category 'private') ----- + handleFailingFailingBasicNew + "This basicNew gets sent after handleFailingBasicNew: has done a full + garbage collection and possibly grown memory. If this basicNew fails + then the system really is low on space, so raise the OutOfMemory signal. + + Primitive. Answer an instance of this class with the number of indexable + variables specified by the argument, sizeRequested. Fail if this class is not + indexable or if the argument is not a positive Integer, or if there is not + enough memory available. Essential. See Object documentation whatIsAPrimitive." + + <primitive: 70> + "space must be low" + OutOfMemory signal. + ^self basicNew "retry if user proceeds"! Item was added: + ----- Method: Behavior>>handleFailingFailingBasicNew: (in category 'private') ----- + handleFailingFailingBasicNew: sizeRequested + "This basicNew: gets sent after handleFailingBasicNew: has done a full + garbage collection and possibly grown memory. If this basicNew: fails + then the system really is low on space, so raise the OutOfMemory signal. + + Primitive. Answer an instance of this class with the number of indexable + variables specified by the argument, sizeRequested. Fail if this class is not + indexable or if the argument is not a positive Integer, or if there is not + enough memory available. Essential. See Object documentation whatIsAPrimitive." + + <primitive: 71> + "space must be low." + OutOfMemory signal. + ^self basicNew: sizeRequested "retry if user proceeds"! Item was added: + ----- Method: Behavior>>identityHash (in category 'comparing') ----- + identityHash + "Answer a SmallInteger whose value is related to the receiver's identity. + Behavior implements identityHash to allow the VM to use an object representation which + does not include a direct reference to an object's class in an object. If the VM is using + this implementation then classes are held in a class table and instances contain the index + of their class in the table. A class's class table index is its identityHash so that an instance + can be created without searching the table for a class's index. The VM uses this primitive + to enter the class into the class table, assigning its identityHash with an as yet unused + class table index. If this primitive fails it means that the class table is full. In Spur as of + 2014 there are 22 bits of classTable index and 22 bits of identityHash per object. + + Primitive. Essential. Do not override. See Object documentation whatIsAPrimitive." + + <primitive: 175> + self primitiveFailed! Item was changed: ----- Method: Behavior>>indexIfCompact (in category 'private') ----- indexIfCompact + "Backward compatibility with the Squeak V3 object format. + Spur does not have a distinction between compact and non-compact classes." + ^0! - "If these 5 bits are non-zero, then instances of this class - will be compact. It is crucial that there be an entry in - Smalltalk compactClassesArray for any class so optimized. - See the msgs becomeCompact and becomeUncompact." - ^ (format bitShift: -11) bitAnd: 16r1F - " - Smalltalk compactClassesArray doWithIndex: - [:c :i | c == nil ifFalse: - [c indexIfCompact = i ifFalse: [self halt]]] - "! Item was changed: ----- Method: Behavior>>instSize (in category 'testing') ----- instSize "Answer the number of named instance variables + (as opposed to indexed variables) of the receiver. + Above Cog Spur the class format is + <5 bits inst spec><16 bits inst size>" + ^format bitAnd: 16rFFFF! - (as opposed to indexed variables) of the receiver." - - self flag: #instSizeChange. "Smalltalk browseAllCallsOn: #instSizeChange" - " - NOTE: This code supports the backward-compatible extension to 8 bits of instSize. - When we revise the image format, it should become... - ^ ((format bitShift: -1) bitAnd: 16rFF) - 1 - Note also that every other method in this category will require - 2 bits more of right shift after the change. - " - ^ ((format bitShift: -10) bitAnd: 16rC0) + ((format bitShift: -1) bitAnd: 16r3F) - 1! Item was changed: ----- Method: Behavior>>instSpec (in category 'testing') ----- instSpec + "Answer the instance specification part of the format that defines what kind of object + an instance of the receiver is. The formats are + 0 = 0 sized objects (UndefinedObject True False et al) + 1 = non-indexable objects with inst vars (Point et al) + 2 = indexable objects with no inst vars (Array et al) + 3 = indexable objects with inst vars (MethodContext AdditionalMethodState et al) + 4 = weak indexable objects with inst vars (WeakArray et al) + 5 = weak non-indexable objects with inst vars (ephemerons) (Ephemeron) + 6 = unused + 7 = immediates (SmallInteger, Character) + 8 = unused + 9 = 64-bit indexable + 10-11 = 32-bit indexable (Bitmap) + 12-15 = 16-bit indexable + 16-23 = 8-bit indexable + 24-31 = compiled methods (CompiledMethod)" + ^(format bitShift: -16) bitAnd: 16r1F! - ^ (format bitShift: -7) bitAnd: 16rF! Item was changed: ----- Method: Behavior>>isBits (in category 'testing') ----- isBits + "Answer whether the receiver contains just bits (not pointers). + Above Cog Spur the class format is + <5 bits inst spec><16 bits inst size> + where the 5-bit inst spec is + 0 = 0 sized objects (UndefinedObject True False et al) + 1 = non-indexable objects with inst vars (Point et al) + 2 = indexable objects with no inst vars (Array et al) + 3 = indexable objects with inst vars (MethodContext AdditionalMethodState et al) + 4 = weak indexable objects with inst vars (WeakArray et al) + 5 = weak non-indexable objects with inst vars (ephemerons) (Ephemeron) + 6 = unused + 7 = immediates (SmallInteger, Character) + 8 = unused + 9 = 64-bit indexable + 10-11 = 32-bit indexable (Bitmap) + 12-15 = 16-bit indexable + 16-23 = 8-bit indexable + 24-31 = compiled methods (CompiledMethod)" + ^self instSpec >= 7! - "Answer whether the receiver contains just bits (not pointers)." - - ^ self instSpec >= 6! Item was changed: ----- Method: Behavior>>isBytes (in category 'testing') ----- isBytes + "Answer whether the receiver has 8-bit instance variables. + Above Cog Spur the class format is + <5 bits inst spec><16 bits inst size> + where the 5-bit inst spec is + 0 = 0 sized objects (UndefinedObject True False et al) + 1 = non-indexable objects with inst vars (Point et al) + 2 = indexable objects with no inst vars (Array et al) + 3 = indexable objects with inst vars (MethodContext AdditionalMethodState et al) + 4 = weak indexable objects with inst vars (WeakArray et al) + 5 = weak non-indexable objects with inst vars (ephemerons) (Ephemeron) + 6 = unused + 7 = immediates (SmallInteger, Character) + 8 = unused + 9 = 64-bit indexable + 10-11 = 32-bit indexable (Bitmap) + 12-15 = 16-bit indexable + 16-23 = 8-bit indexable + 24-31 = compiled methods (CompiledMethod)" + ^self instSpec >= 16! - "Answer whether the receiver has 8-bit instance variables." - - ^ self instSpec >= 8! Item was added: + ----- Method: Behavior>>isCompiledMethodClass (in category 'as yet unclassified') ----- + isCompiledMethodClass + "Answer whether the receiver has compiled method instances that mix pointers and bytes." + ^self instSpec >= 24! Item was added: + ----- Method: Behavior>>isEphemeronClass (in category 'testing') ----- + isEphemeronClass + "Answer whether the receiver has ephemeral instance variables. The garbage collector will + fire (queue for finalization) any ephemeron whose first instance variable is not referenced + other than from the transitive closure of references from ephemerons. Hence referring to + an object from the first inst var of an ephemeron will cause the ephemeron to fire when + the rest of the system does not refer to the object and that object is ready to be collected. + Since references from the remaining inst vars of an ephemeron will not prevent the ephemeron + from firing, ephemerons may act as the associations in weak dictionaries such that the value + (e.g. properties attached to the key) will not prevent firing when the key is no longer referenced + other than from ephemerons. Ephemerons can therefore be used to implement instance-based + pre-mortem finalization." + ^self instSpec = 5! Item was added: + ----- Method: Behavior>>isImmediateClass (in category 'testing') ----- + isImmediateClass + "Answer whether the receiver has immediate instances. Immediate instances + store their value in their object pointer, not in an object body. Hence immediates + take no space and are immutable. The immediates are distinguished by tag bits + in the pointer. They include SmallIntegers and Characters. Hence in the 32-bit + system SmallIntegers are 31-bit signed integers and Characters are 30-bit + unsigned character codes." + ^self instSpec = 7! Item was changed: ----- Method: Behavior>>isVariable (in category 'testing') ----- isVariable + "Answer whether the receiver has indexable variables. + Above Cog Spur the class format is + <5 bits inst spec><16 bits inst size> + where the 5-bit inst spec is + 0 = 0 sized objects (UndefinedObject True False et al) + 1 = non-indexable objects with inst vars (Point et al) + 2 = indexable objects with no inst vars (Array et al) + 3 = indexable objects with inst vars (MethodContext AdditionalMethodState et al) + 4 = weak indexable objects with inst vars (WeakArray et al) + 5 = weak non-indexable objects with inst vars (ephemerons) (Ephemeron) + 6 = unused + 7 = immediates (SmallInteger, Character) + 8 = unused + 9 = 64-bit indexable + 10-11 = 32-bit indexable (Bitmap) + 12-15 = 16-bit indexable + 16-23 = 8-bit indexable + 24-31 = compiled methods (CompiledMethod)" + | instSpec | + instSpec := self instSpec. + ^instSpec >= 2 and: [instSpec <= 4 or: [instSpec >= 9]]! - "Answer whether the receiver has indexable variables." - - ^ self instSpec >= 2! Item was changed: ----- Method: Behavior>>kindOfSubclass (in category 'testing class hierarchy') ----- kindOfSubclass + "Answer a String that is the keyword that describes the receiver's kind of subclass, + either a regular subclass, a variableSubclass, a variableByteSubclass, + a variableWordSubclass, a weakSubclass, an ephemeronSubclass or an immediateSubclass. + c.f. typeOfClass" + ^self isVariable + ifTrue: + [self isBits + ifTrue: + [self isBytes + ifTrue: [' variableByteSubclass: '] + ifFalse: [' variableWordSubclass: ']] + ifFalse: + [self isWeak + ifTrue: [' weakSubclass: '] + ifFalse: [' variableSubclass: ']]] + ifFalse: + [self isImmediateClass + ifTrue: [' immediateSubclass: '] + ifFalse: + [self isEphemeronClass + ifTrue: [' ephemeronSubclass: '] + ifFalse: [' subclass: ']]]! - "Answer a String that is the keyword that describes the receiver's kind - of subclass, either a regular subclass, a variableSubclass, a - variableByteSubclass, a variableWordSubclass, or a weakSubclass." - self isWeak - ifTrue: [^ ' weakSubclass: ']. - ^ self isVariable - ifTrue: [self isBits - ifTrue: [self isBytes - ifTrue: [ ' variableByteSubclass: '] - ifFalse: [ ' variableWordSubclass: ']] - ifFalse: [ ' variableSubclass: ']] - ifFalse: [ ' subclass: ']! Item was changed: ----- Method: Behavior>>shouldNotBeRedefined (in category 'testing') ----- shouldNotBeRedefined + "Answer if the receiver should not be redefined. + The assumption is that classes in Smalltalk specialObjects and + instance-specific Behaviors should not be redefined" - "Return true if the receiver should not be redefined. - The assumption is that compact classes, - classes in Smalltalk specialObjects and - Behaviors should not be redefined" + ^(Smalltalk specialObjectsArray + identityIndexOf: self + ifAbsent: [(self isKindOf: self) ifTrue: [1] ifFalse: [0]]) ~= 0! - ^(Smalltalk compactClassesArray includes: self) - or:[(Smalltalk specialObjectsArray includes: self) - or:[self isKindOf: self]]! Item was changed: ----- Method: Behavior>>typeOfClass (in category 'accessing') ----- typeOfClass + "Answer a symbol uniquely describing the type of the receiver. c.f. kindOfSubclass" + self isBytes ifTrue: + [^self instSpec = CompiledMethod instSpec + ifTrue: [#compiledMethod] "Very special!!" + ifFalse: [#bytes]]. + (self isWords and: [self isPointers not]) ifTrue: + [^self instSpec = SmallInteger instSpec + ifTrue: [#immediate] "Very special!!" + ifFalse: [#words]]. + self isWeak ifTrue: [^#weak]. + self isVariable ifTrue: [^#variable]. + self isEphemeronClass ifTrue: [^#ephemeron]. + ^#normal! - "Answer a symbol uniquely describing the type of the receiver" - self instSpec = CompiledMethod instSpec ifTrue:[^#compiledMethod]. "Very special!!" - self isBytes ifTrue:[^#bytes]. - (self isWords and:[self isPointers not]) ifTrue:[^#words]. - self isWeak ifTrue:[^#weak]. - self isVariable ifTrue:[^#variable]. - ^#normal.! Item was changed: ----- Method: BlockClosure>>simulateValueWithArguments:caller: (in category 'system simulation') ----- simulateValueWithArguments: anArray caller: aContext + "Simulate the valueWithArguments: primitive. Fail if anArray is not an array of the right arity." | newContext sz | - (anArray class ~~ Array - or: [numArgs ~= anArray size]) ifTrue: - [^ContextPart primitiveFailTokenFor: nil]. newContext := (MethodContext newForMethod: outerContext method) setSender: aContext receiver: outerContext receiver method: outerContext method closure: self startpc: startpc. + ((newContext objectClass: anArray) ~~ Array + or: [numArgs ~= anArray size]) ifTrue: + [^ContextPart primitiveFailTokenFor: nil]. sz := self basicSize. newContext stackp: sz + numArgs. 1 to: numArgs do: [:i| newContext at: i put: (anArray at: i)]. 1 to: sz do: [:i| newContext at: i + numArgs put: (self at: i)]. ^newContext! Item was added: + Float variableWordSubclass: #BoxedFloat64 + instanceVariableNames: '' + classVariableNames: '' + poolDictionaries: '' + category: 'Kernel-Numbers'! + + !BoxedFloat64 commentStamp: 'eem 11/25/2014 07:54' prior: 0! + My instances hold 64-bit Floats in heap objects. This is the only representation on 32-bit systems. But on 64-bit systems SmallFloat64 holds a subset of the full 64-bit double-precision range in immediate objects.! Item was added: + ----- Method: BoxedFloat64 class>>basicNew (in category 'instance creation') ----- + basicNew + ^self basicNew: 2! Item was added: + ----- Method: BoxedFloat64 class>>basicNew: (in category 'instance creation') ----- + basicNew: sizeRequested + "Primitive. Answer an instance of this class with the number + of indexable variables specified by the argument, sizeRequested. + Fail if this class is not indexable or if the argument is not a + positive Integer, or if there is not enough memory available. + Essential. See Object documentation whatIsAPrimitive." + + <primitive: 71> + sizeRequested isInteger ifTrue: + [^sizeRequested = 2 + ifTrue: "arg okay; space must be low." + [OutOfMemory signal. + self basicNew: sizeRequested] "retry if user proceeds" + ifFalse: + [self error: 'a Float shall always have two slots']]. + self primitiveFailed! Item was added: + ----- Method: BoxedFloat64>>* (in category 'arithmetic') ----- + * aNumber + "Primitive. Answer the result of multiplying the receiver by aNumber. + Fail if the argument is not a Float. Essential. See Object documentation + whatIsAPrimitive." + + <primitive: 49> + ^ aNumber adaptToFloat: self andSend: #*! Item was added: + ----- Method: BoxedFloat64>>+ (in category 'arithmetic') ----- + + aNumber + "Primitive. Answer the sum of the receiver and aNumber. Essential. + Fail if the argument is not a Float. See Object documentation + whatIsAPrimitive." + + <primitive: 41> + ^ aNumber adaptToFloat: self andSend: #+! Item was added: + ----- Method: BoxedFloat64>>- (in category 'arithmetic') ----- + - aNumber + "Primitive. Answer the difference between the receiver and aNumber. + Fail if the argument is not a Float. Essential. See Object documentation + whatIsAPrimitive." + + <primitive: 42> + ^ aNumber adaptToFloat: self andSend: #-! Item was added: + ----- Method: BoxedFloat64>>/ (in category 'arithmetic') ----- + / aNumber + "Primitive. Answer the result of dividing receiver by aNumber. + Fail if the argument is not a Float. Essential. See Object documentation + whatIsAPrimitive." + + <primitive: 50> + aNumber isZero ifTrue: [^(ZeroDivide dividend: self) signal]. + ^ aNumber adaptToFloat: self andSend: #/! Item was added: + ----- Method: BoxedFloat64>>< (in category 'comparing') ----- + < aNumber + "Primitive. Compare the receiver with the argument and return true + if the receiver is less than the argument. Otherwise return false. + Fail if the argument is not a Float. Essential. See Object documentation + whatIsAPrimitive." + + <primitive: 43> + ^ aNumber adaptToFloat: self andCompare: #<! Item was added: + ----- Method: BoxedFloat64>><= (in category 'comparing') ----- + <= aNumber + "Primitive. Compare the receiver with the argument and return true + if the receiver is less than or equal to the argument. Otherwise return + false. Fail if the argument is not a Float. Optional. See Object + documentation whatIsAPrimitive." + + <primitive: 45> + ^ aNumber adaptToFloat: self andCompare: #<=! Item was added: + ----- Method: BoxedFloat64>>= (in category 'comparing') ----- + = aNumber + "Primitive. Compare the receiver with the argument and return true + if the receiver is equal to the argument. Otherwise return false. + Fail if the argument is not a Float. Essential. See Object documentation + whatIsAPrimitive." + + <primitive: 47> + aNumber isNumber ifFalse: [^ false]. + ^ aNumber adaptToFloat: self andCompare: #=! Item was added: + ----- Method: BoxedFloat64>>> (in category 'comparing') ----- + > aNumber + "Primitive. Compare the receiver with the argument and return true + if the receiver is greater than the argument. Otherwise return false. + Fail if the argument is not a Float. Essential. See Object documentation + whatIsAPrimitive." + + <primitive: 44> + ^ aNumber adaptToFloat: self andCompare: #>! Item was added: + ----- Method: BoxedFloat64>>>= (in category 'comparing') ----- + >= aNumber + "Primitive. Compare the receiver with the argument and return true + if the receiver is greater than or equal to the argument. Otherwise return + false. Fail if the argument is not a Float. Optional. See Object documentation + whatIsAPrimitive. " + + <primitive: 46> + ^ aNumber adaptToFloat: self andCompare: #>=! Item was added: + ----- Method: BoxedFloat64>>arcTan (in category 'mathematical functions') ----- + arcTan + "Answer the angle in radians. + Optional. See Object documentation whatIsAPrimitive." + + | theta eps step sinTheta cosTheta | + <primitive: 57> + + "Newton-Raphson" + self < 0.0 ifTrue: [ ^ 0.0 - (0.0 - self) arcTan ]. + + "first guess" + theta := (self * Halfpi) / (self + 1.0). + + "iterate" + eps := Halfpi * Epsilon. + step := theta. + [(step * step) > eps] whileTrue: [ + sinTheta := theta sin. + cosTheta := theta cos. + step := (sinTheta * cosTheta) - (self * cosTheta * cosTheta). + theta := theta - step]. + ^ theta! Item was added: + ----- Method: BoxedFloat64>>exp (in category 'mathematical functions') ----- + exp + "Answer E raised to the receiver power. + Optional. See Object documentation whatIsAPrimitive." + + | base fract correction delta div | + <primitive: 59> + + "Taylor series" + "check the special cases" + self < 0.0 ifTrue: [^ (self negated exp) reciprocal]. + self = 0.0 ifTrue: [^ 1]. + self abs > MaxValLn ifTrue: [self error: 'exp overflow']. + + "get first approximation by raising e to integer power" + base := E raisedToInteger: (self truncated). + + "now compute the correction with a short Taylor series" + "fract will be 0..1, so correction will be 1..E" + "in the worst case, convergance time is logarithmic with 1/Epsilon" + fract := self fractionPart. + fract = 0.0 ifTrue: [ ^ base ]. "no correction required" + + correction := 1.0 + fract. + delta := fract * fract / 2.0. + div := 2.0. + [delta > Epsilon] whileTrue: [ + correction := correction + delta. + div := div + 1.0. + delta := delta * fract / div]. + correction := correction + delta. + ^ base * correction! Item was added: + ----- Method: BoxedFloat64>>exponent (in category 'truncation and round off') ----- + exponent + "Primitive. Consider the receiver to be represented as a power of two + multiplied by a mantissa (between one and two). Answer with the + SmallInteger to whose power two is raised. Optional. See Object + documentation whatIsAPrimitive." + + <primitive: 53> + ^self exponentFromBitPattern! Item was added: + ----- Method: BoxedFloat64>>fractionPart (in category 'truncation and round off') ----- + fractionPart + "Primitive. Answer a Float whose value is the difference between the + receiver and the receiver's asInteger value. Optional. See Object + documentation whatIsAPrimitive." + + <primitive: 52> + ^self - self truncated asFloat! Item was added: + ----- Method: BoxedFloat64>>ln (in category 'mathematical functions') ----- + ln + "Answer the natural logarithm of the receiver. + Optional. See Object documentation whatIsAPrimitive." + + | expt n mant x div pow delta sum eps | + <primitive: 58> + + "Taylor series" + self <= 0.0 ifTrue: [DomainError signal: 'ln is only defined for x > 0.0']. + + "get a rough estimate from binary exponent" + expt := self exponent. + n := Ln2 * expt. + mant := self timesTwoPower: 0 - expt. + + "compute fine correction from mantinssa in Taylor series" + "mant is in the range [0..2]" + "we unroll the loop to avoid use of abs" + x := mant - 1.0. + div := 1.0. + pow := delta := sum := x. + x := x negated. "x <= 0" + eps := Epsilon * (n abs + 1.0). + [delta > eps] whileTrue: [ + "pass one: delta is positive" + div := div + 1.0. + pow := pow * x. + delta := pow / div. + sum := sum + delta. + "pass two: delta is negative" + div := div + 1.0. + pow := pow * x. + delta := pow / div. + sum := sum + delta]. + + ^ n + sum + + "2.718284 ln 1.0"! Item was added: + ----- Method: BoxedFloat64>>sin (in category 'mathematical functions') ----- + sin + "Answer the sine of the receiver taken as an angle in radians. + Optional. See Object documentation whatIsAPrimitive." + + | sum delta self2 i | + <primitive: 56> + + "Taylor series" + "normalize to the range [0..Pi/2]" + self < 0.0 ifTrue: [^ (0.0 - ((0.0 - self) sin))]. + self > Twopi ifTrue: [^ (self \\ Twopi) sin]. + self > Pi ifTrue: [^ (0.0 - (self - Pi) sin)]. + self > Halfpi ifTrue: [^ (Pi - self) sin]. + + "unroll loop to avoid use of abs" + sum := delta := self. + self2 := 0.0 - (self * self). + i := 2.0. + [delta > Epsilon] whileTrue: [ + "once" + delta := (delta * self2) / (i * (i + 1.0)). + i := i + 2.0. + sum := sum + delta. + "twice" + delta := (delta * self2) / (i * (i + 1.0)). + i := i + 2.0. + sum := sum + delta]. + ^ sum! Item was added: + ----- Method: BoxedFloat64>>sqrt (in category 'mathematical functions') ----- + sqrt + "Answer the square root of the receiver. + Optional. See Object documentation whatIsAPrimitive." + | exp guess eps delta | + <primitive: 55> + #Numeric. + "Changed 200/01/19 For ANSI <number> support." + "Newton-Raphson" + self <= 0.0 + ifTrue: [self = 0.0 + ifTrue: [^ 0.0] + ifFalse: ["v Chg" + ^ DomainError signal: 'sqrt undefined for number less than zero.']]. + "first guess is half the exponent" + exp := self exponent // 2. + guess := self timesTwoPower: 0 - exp. + "get eps value" + eps := guess * Epsilon. + eps := eps * eps. + delta := self - (guess * guess) / (guess * 2.0). + [delta * delta > eps] + whileTrue: + [guess := guess + delta. + delta := self - (guess * guess) / (guess * 2.0)]. + ^ guess! Item was added: + ----- Method: BoxedFloat64>>timesTwoPower: (in category 'mathematical functions') ----- + timesTwoPower: anInteger + "Primitive. Answer with the receiver multiplied by 2.0 raised + to the power of the argument. + Optional. See Object documentation whatIsAPrimitive." + + <primitive: 54> + + anInteger < -29 ifTrue: [^ self * (2.0 raisedToInteger: anInteger)]. + anInteger < 0 ifTrue: [^ self / (1 bitShift: (0 - anInteger)) asFloat]. + anInteger < 30 ifTrue: [^ self * (1 bitShift: anInteger) asFloat]. + ^ self * (2.0 raisedToInteger: anInteger)! Item was added: + ----- Method: BoxedFloat64>>truncated (in category 'truncation and round off') ----- + truncated + "Answer with a SmallInteger equal to the value of the receiver without + its fractional part. The primitive fails if the truncated value cannot be + represented as a SmallInteger. In that case, the code below will compute + a LargeInteger truncated value. + Essential. See Object documentation whatIsAPrimitive. " + + <primitive: 51> + self isFinite ifFalse: [self error: 'Cannot truncate this number']. + + self abs < 2.0e16 + ifTrue: ["Fastest way when it may not be an integer" + | di df q r | + di := 1 + (SmallInteger maxVal bitShift: -1). + df := di asFloat. + q := self quo: df. + r := self - (q asFloat * df). + ^q * di + r truncated] + ifFalse: [^ self asTrueFraction. "Extract all bits of the mantissa and shift if necess"] + + + + ! Item was added: + ----- Method: BoxedFloat64>>~= (in category 'comparing') ----- + ~= aNumber + "Primitive. Compare the receiver with the argument and return true + if the receiver is not equal to the argument. Otherwise return false. + Fail if the argument is not a Float. Optional. See Object documentation + whatIsAPrimitive." + + <primitive: 48> + ^super ~= aNumber! Item was added: + ----- Method: Class>>immediateSubclass:instanceVariableNames:classVariableNames:poolDictionaries:category: (in category 'subclass creation') ----- + immediateSubclass: t instanceVariableNames: f classVariableNames: d poolDictionaries: s category: cat + "This is the standard initialization message for creating a new + immediate class as a subclass of an existing class (the receiver)." + ^ClassBuilder new + superclass: self + immediateSubclass: t + instanceVariableNames: f + classVariableNames: d + poolDictionaries: s + category: cat! Item was changed: ----- Method: ClassBuilder>>computeFormat:instSize:forSuper:ccIndex: (in category 'class format') ----- computeFormat: type instSize: newInstSize forSuper: newSuper ccIndex: ccIndex "Compute the new format for making oldClass a subclass of newSuper. + Answer the format or nil if there is any problem." - Return the format or nil if there is any problem." | instSize isVar isWords isPointers isWeak | type == #compiledMethod ifTrue: + [newInstSize > 0 ifTrue: + [self error: 'A compiled method class cannot have named instance variables'. + ^nil]. + ^CompiledMethod format]. - [^(CompiledMethod format - bitClear: (16r1F bitShift: 11)) - bitOr: (ccIndex bitShift: 11)]. instSize := newInstSize + (newSuper ifNil:[0] ifNotNil:[newSuper instSize]). + instSize > 65535 ifTrue: - instSize > 254 ifTrue: [self error: 'Class has too many instance variables (', instSize printString,')'. ^nil]. type == #normal ifTrue:[isVar := isWeak := false. isWords := isPointers := true]. type == #bytes ifTrue:[isVar := true. isWords := isPointers := isWeak := false]. type == #words ifTrue:[isVar := isWords := true. isPointers := isWeak := false]. type == #variable ifTrue:[isVar := isPointers := isWords := true. isWeak := false]. type == #weak ifTrue:[isVar := isWeak := isWords := isPointers := true]. + type == #ephemeron ifTrue:[isVar := false. isWeak := isWords := isPointers := true]. + type == #immediate ifTrue:[isVar := isWeak := isPointers := false. isWords := true]. + (isPointers not and: [instSize > 0]) ifTrue: + [self error: 'A non-pointer class cannot have named instance variables'. - (isPointers not and:[instSize > 0]) ifTrue: - [self error:'A non-pointer class cannot have instance variables'. ^nil]. + ^self format: instSize variable: isVar words: isWords pointers: isPointers weak: isWeak! - ^(self format: instSize - variable: isVar - words: isWords - pointers: isPointers - weak: isWeak) + (ccIndex bitShift: 11).! Item was changed: ----- Method: ClassBuilder>>format:variable:words:pointers:weak: (in category 'class format') ----- + format: nInstVars variable: isVar words: is32BitWords pointers: isPointers weak: isWeak + "Compute the format for the given instance specfication. + Above Cog Spur the class format is + <5 bits inst spec><16 bits inst size> + where the 5-bit inst spec is + 0 = 0 sized objects (UndefinedObject True False et al) + 1 = non-indexable objects with inst vars (Point et al) + 2 = indexable objects with no inst vars (Array et al) + 3 = indexable objects with inst vars (MethodContext AdditionalMethodState et al) + 4 = weak indexable objects with inst vars (WeakArray et al) + 5 = weak non-indexable objects with inst vars (ephemerons) (Ephemeron) + 6 = unused + 7 = immediates (SmallInteger, Character) + 8 = unused + 9 = reserved for 64-bit indexable + 10-11 = 32-bit indexable (Bitmap) + 12-15 = 16-bit indexable + 16-23 = 8-bit indexable + 24-31 = compiled methods (CompiledMethod)" + | instSpec | - format: nInstVars variable: isVar words: isWords pointers: isPointers weak: isWeak - "Compute the format for the given instance specfication." - | cClass instSpec sizeHiBits fmt | - self flag: #instSizeChange. - " - Smalltalk browseAllCallsOn: #instSizeChange. - Smalltalk browseAllImplementorsOf: #fixedFieldsOf:. - Smalltalk browseAllImplementorsOf: #instantiateClass:indexableSize:. - " - " - NOTE: This code supports the backward-compatible extension to 8 bits of instSize. - For now the format word is... - <2 bits=instSize//64><5 bits=cClass><4 bits=instSpec><6 bits=instSize\\64><1 bit=0> - But when we revise the image format, it should become... - <5 bits=cClass><4 bits=instSpec><8 bits=instSize><1 bit=0> - " - sizeHiBits := (nInstVars+1) // 64. - cClass := 0. "for now" instSpec := isWeak + ifTrue: + [isVar + ifTrue: [4] + ifFalse: [5]] + ifFalse: + [isPointers + ifTrue: + [isVar + ifTrue: [nInstVars > 0 ifTrue: [3] ifFalse: [2]] + ifFalse: [nInstVars > 0 ifTrue: [1] ifFalse: [0]]] + ifFalse: + [isVar + ifTrue: [is32BitWords ifTrue: [10] ifFalse: [16]] + ifFalse: [7]]]. + ^(instSpec bitShift: 16) + nInstVars! - ifTrue:[4] - ifFalse:[isPointers - ifTrue: [isVar - ifTrue: [nInstVars>0 ifTrue: [3] ifFalse: [2]] - ifFalse: [nInstVars>0 ifTrue: [1] ifFalse: [0]]] - ifFalse: [isWords ifTrue: [6] ifFalse: [8]]]. - fmt := sizeHiBits. - fmt := (fmt bitShift: 5) + cClass. - fmt := (fmt bitShift: 4) + instSpec. - fmt := (fmt bitShift: 6) + ((nInstVars+1)\\64). "+1 since prim size field includes header" - fmt := (fmt bitShift: 1). "This shift plus integer bit lets wordSize work like byteSize" - ^fmt! Item was added: + ----- Method: ClassBuilder>>superclass:immediateSubclass:instanceVariableNames:classVariableNames:poolDictionaries:category: (in category 'public') ----- + superclass: aClass + immediateSubclass: t instanceVariableNames: f + classVariableNames: d poolDictionaries: s category: cat + "This is the standard initialization message for creating a + new immediate class as a subclass of an existing class." + | env | + aClass instSize > 0 + ifTrue: [^self error: 'cannot make an immediate subclass of a class with named fields']. + aClass isVariable + ifTrue: [^self error: 'cannot make an immediate subclass of a class with indexed instance variables']. + aClass isPointers + ifFalse: [^self error: 'cannot make an immediate subclass of a class without pointer fields']. + "Cope with pre-environment and environment versions. Simplify asap." + env := (Smalltalk classNamed: #EnvironmentRequest) + ifNil: [aClass environment] + ifNotNil: [:erc| erc signal ifNil: [aClass environment]]. + ^self + name: t + inEnvironment: env + subclassOf: aClass + type: #immediate + instanceVariableNames: f + classVariableNames: d + poolDictionaries: s + category: cat! Item was changed: ----- Method: ClassBuilder>>update:to: (in category 'class mutation') ----- update: oldClass to: newClass + "Convert oldClass, all its instances and possibly its meta class into newClass, + instances of newClass and possibly its meta class. The process is surprisingly + simple in its implementation and surprisingly complex in its nuances and potentially + bad side effects. + We can rely on two assumptions (which are critical): + #1: The method #updateInstancesFrom: will not create any lasting pointers to + 'old' instances ('old' is quote on quote since #updateInstancesFrom: will do + a become of the old vs. the new instances and therefore it will not create + pointers to *new* instances before the #become: which are *old* afterwards) + #2: The non-preemptive execution of the critical piece of code guarantees that + nobody can get a hold by 'other means' (such as process interruption and + reflection) on the old instances. + Given the above two, we know that after #updateInstancesFrom: there are no pointers + to any old instances. After the forwarding become there will be no pointers to the old + class or meta class either. + Andreas Raab, 2/27/2003 23:42" - "Convert oldClass, all its instances and possibly its meta class into newClass, instances of newClass and possibly its meta class. The process is surprisingly simple in its implementation and surprisingly complex in its nuances and potentially bad side effects. - We can rely on two assumptions (which are critical): - #1: The method #updateInstancesFrom: will not create any lasting pointers to 'old' instances ('old' is quote on quote since #updateInstancesFrom: will do a become of the old vs. the new instances and therefore it will not create pointers to *new* instances before the #become: which are *old* afterwards) - #2: The non-preemptive execution of the critical piece of code guarantees that nobody can get a hold by 'other means' (such as process interruption and reflection) on the old instances. - Given the above two, we know that after #updateInstancesFrom: there are no pointer to any old instances. After the forwarding become there will be no pointers to the old class or meta class either. Meaning that if we throw in a nice fat GC at the end of the critical block, everything will be gone (but see the comment right there). There's no need to worry. - " | meta | meta := oldClass isMeta. "Note: Everything from here on will run without the ability to get interrupted to prevent any other process to create new instances of the old class." + ["Note: The following removal may look somewhat obscure and needs an explanation. + When we mutate the class hierarchy we create new classes for any existing subclass. + So it may look as if we don't have to remove the old class from its superclass. However, + at the top of the hierarchy (the first class we reshape) that superclass itself is not newly + created so therefore it will hold both the oldClass and newClass in its (obsolete or not) + subclasses. Since the #become: below will transparently replace the pointers to oldClass + with newClass the superclass would have newClass in its subclasses TWICE. With rather + unclear effects if we consider that we may convert the meta-class hierarchy itself (which + is derived from the non-meta class hierarchy). + Due to this problem ALL classes are removed from their superclass just prior to converting + them. Here, breaking the superclass/subclass invariant really doesn't matter since we will + effectively remove the oldClass (becomeForward:) just a few lines below." - [ - "Note: The following removal may look somewhat obscure and needs an explanation. When we mutate the class hierarchy we create new classes for any existing subclass. So it may look as if we don't have to remove the old class from its superclass. However, at the top of the hierarchy (the first class we reshape) that superclass itself is not newly created so therefore it will hold both the oldClass and newClass in its (obsolete or not) subclasses. Since the #become: below will transparently replace the pointers to oldClass with newClass the superclass would have newClass in its subclasses TWICE. With rather unclear effects if we consider that we may convert the meta-class hierarchy itself (which is derived from the non-meta class hierarchy). - Due to this problem ALL classes are removed from their superclass just prior to converting them. Here, breaking the superclass/subclass invariant really doesn't matter since we will effectively remove the oldClass (become+GC) just a few lines below." oldClass superclass removeSubclass: oldClass. oldClass superclass removeObsoleteSubclass: oldClass. "make sure that the VM cache is clean" oldClass methodDict do: [:cm | cm flushCache]. "Convert the instances of oldClass into instances of newClass" newClass updateInstancesFrom: oldClass. meta ifTrue: [oldClass becomeForward: newClass. oldClass updateMethodBindingsTo: oldClass binding] ifFalse: [{oldClass. oldClass class} elementsForwardIdentityTo: {newClass. newClass class}. oldClass updateMethodBindingsTo: oldClass binding. oldClass class updateMethodBindingsTo: oldClass class binding]. + "eem 5/31/2014 07:22 At this point there used to be a garbage collect whose purpose was + to ensure no old instances existed after the becomeForward:. Without the GC it was possible + to resurrect old instances using e.g. allInstancesDo:. This was because the becomeForward: + updated references from the old objects to new objects but didn't destroy the old objects. + But as of late 2013/early 2014 becomeForward: has been modified to free all the old objects."] + valueUnpreemptively! - Smalltalk garbageCollect. - - "Warning: Read this before you even think about removing the GC. Yes, it slows us down. Quite heavily if you have a large image. However, there's no good and simple alternative here, since unfortunately, #become: does change class pointers. What happens is that after the above become all of the instances of the old class will have a class pointer identifying them as instances of newClass. If we get our hands on any of these instances we will break immediately since their expected instance layout (that of its class, e.g., newClass) will not match their actual instance layout (that of oldClass). And getting your hands on any of those instances is really simple - just reshaping one class two times in rapid succession will do it. Reflection techniques, interrupts, etc. will only add to this problem. In the case of Metaclass things get even worse since when we recompile the entire class hierarchy we will recompile both, Metaclass and its instances (and some of its instances will have the old and some the new layout). - - The only easy solution to this problem would be to 'fix up' the class pointers of the old instances to point to the old class (using primitiveChangeClassTo:). But this won't work either - as we do a one-way become we would have to search the entire object memory for the oldClass and couldn't even clearly identify it unless we give it some 'special token' which sounds quite error-prone. If you really need to get rid of the GC here are some alternatives: - - On the image level, one could create a copy of the oldClass before becoming it into the new class and, after becoming it, 'fix up' the old instances. That would certainly work but it sounds quite complex, as we need to make sure we're not breaking any of the superclass/subclass meta/non-meta class variants. - - Alternatively, fix up #becomeForward on the VM-level to 'dump the source objects' of #become. This would be quite doable (just 'convert' them into a well known special class such as bitmap) yet it has problems if (accidentally or not) one of the objects in #become: appears on 'both sides of the fence' (right now, this will work ... in a way ... even though the consequences are unclear). - - Another alternative is to provide a dedicated primitive for this (instead of using it implicitly in become) which would allow us to dump all the existing instances right here. This is equivalent to a more general primitiveChangeClassTo: and might be worthwhile but it would likely have to keep in mind the differences between bits and pointer thingies etc. - - Since all of the alternatives seem rather complex and magical compared to a straight-forward GC it seems best to stick with the GC solution for now. If someone has a real need to fix this problem, that person will likely be motivated enough to check out the alternatives. Personally I'd probably go for #1 (copy the old class and remap the instances to it) since it's a solution that could be easily reverted from within the image if there's any problem with it." - - ] valueUnpreemptively. - ! Item was changed: ----- Method: ClassDescription>>updateInstances:from:isMeta: (in category 'initialize-release') ----- updateInstances: oldInstances from: oldClass isMeta: isMeta + "Recreate any existing instances of the argument, oldClass, as instances of the receiver, + which is a newly changed class. Permute variables as necessary, and forward old instances + to new instances. Answer nil to defeat old clients that expect an array of old instances. + The old behaviour, which necessitated a global GC, exchanged identities and answered + the old instances. But no clients used the result. This way we avoid the unnecessary GC," - "Recreate any existing instances of the argument, oldClass, as instances of the receiver, which is a newly changed class. Permute variables as necessary. Return the array of old instances (none of which should be pointed to legally by anyone but the array)." - "If there are any contexts having an old instance as receiver it might crash the system because the layout has changed, and the method only knows about the old layout." | map variable instSize newInstances | + oldInstances isEmpty ifTrue: + [^nil]. "no instances to convert" + isMeta ifTrue: + [(oldInstances size = 1 + and: [self soleInstance class == self]) ifFalse: + [^self error:'Metaclasses can only have one instance']]. - oldInstances isEmpty ifTrue:[^#()]. "no instances to convert" - isMeta ifTrue: [ - oldInstances size = 1 ifFalse:[^self error:'Metaclasses can only have one instance']. - self soleInstance class == self ifTrue:[ - ^self error:'Metaclasses can only have one instance']]. map := self instVarMappingFrom: oldClass. variable := self isVariable. instSize := self instSize. newInstances := Array new: oldInstances size. + 1 to: oldInstances size do: + [:i| + newInstances + at: i + put: (self newInstanceFrom: (oldInstances at: i) variable: variable size: instSize map: map)]. - 1 to: oldInstances size do:[:i| - newInstances at: i put: ( - self newInstanceFrom: (oldInstances at: i) variable: variable size: instSize map: map)]. "Now perform a bulk mutation of old instances into new ones" + oldInstances elementsForwardIdentityTo: newInstances. + ^nil! - oldInstances elementsExchangeIdentityWith: newInstances. - ^newInstances "which are now old"! Item was changed: ----- Method: ClassDescription>>updateInstancesFrom: (in category 'initialize-release') ----- updateInstancesFrom: oldClass "Recreate any existing instances of the argument, oldClass, as instances of + the receiver, which is a newly changed class. Permute variables as necessary, + and forward old instances to new instances.. Answer nil to defeat any clients + that expected the old behaviour of answering the array of old instances." - the receiver, which is a newly changed class. Permute variables as - necessary. Return the array of old instances (none of which should be - pointed to legally by anyone but the array)." "ar 7/15/1999: The updating below is possibly dangerous. If there are any contexts having an old instance as receiver it might crash the system if the new receiver in which the context is executed has a different layout. See bottom below for a simple example:" + self updateInstances: oldClass allInstances asArray from: oldClass isMeta: self isMeta. - | oldInstances | - oldInstances := oldClass allInstances asArray. - oldInstances := self updateInstances: oldInstances from: oldClass isMeta: self isMeta. "Now fix up instances in segments that are out on the disk." + ImageSegment allSubInstancesDo: + [:seg | - ImageSegment allSubInstancesDo: [:seg | seg segUpdateInstancesOf: oldClass toBe: self isMeta: self isMeta]. + ^nil - ^oldInstances + "This attempts to crash the VM by stepping off the end of an instance. + As the doctor says, do not do this." " | crashingBlock class | class := Object subclass: #CrashTestDummy instanceVariableNames: 'instVar' classVariableNames: '' poolDictionaries: '' category: 'Crash-Test'. class compile:'instVar: value instVar := value'. class compile:'crashingBlock ^[instVar]'. crashingBlock := (class new) instVar: 42; crashingBlock. Object subclass: #CrashTestDummy instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Crash-Test'. + crashingBlock value"! - crashingBlock. - crashingBlock value. - " - ! Item was changed: ByteArray variableByteSubclass: #CompiledMethod instanceVariableNames: '' classVariableNames: 'LargeFrame PrimaryBytecodeSetEncoderClass SecondaryBytecodeSetEncoderClass SmallFrame' poolDictionaries: '' category: 'Kernel-Methods'! + !CompiledMethod commentStamp: 'eem 8/12/2014 14:45' prior: 0! + CompiledMethod instances are methods suitable for interpretation by the virtual machine. Instances of CompiledMethod and its subclasses are the only objects in the system that have both indexable pointer fields and indexable 8-bit integer fields. The first part of a CompiledMethod is pointers, the second part is bytes. CompiledMethod inherits from ByteArray to avoid duplicating some of ByteArray's methods, not because a CompiledMethod is-a ByteArray. - !CompiledMethod commentStamp: 'eem 5/12/2014 18:02' prior: 0! - My instances are methods suitable for interpretation by the virtual machine. This is the only class in the system whose instances have both indexable pointer fields and indexable 8-bit integer fields. The first part of a CompiledMethod is pointers, the second part is bytes. I'm a subclass of ByteArray to avoid duplicating some of ByteArray's methods, not because a CompiledMethod is-a ByteArray. Class variables: SmallFrame - the number of stack slots in a small frame Context LargeFrame - the number of stack slots in a large frame Context PrimaryBytecodeSetEncoderClass - the encoder class that defines the primary instruction set SecondaryBytecodeSetEncoderClass - the encoder class that defines the secondary instruction set The current format of a CompiledMethod is as follows: header (4 or 8 bytes, SmallInteger) + literals (4 or 8 bytes each, Object, see "The last literal..." below) - literals (4 or 8 bytes each, Object) bytecodes (variable, bytes) trailer (variable, bytes) + The header is a 31-bit signed integer (a SmallInteger) in the following format: - The header is a 31-bit signed integer (a SmallInteger) with one of the two following formats, selected by the sign bit: - sign bit 0, header >= 0: - (index 0) 9 bits: main part of primitive number (#primitive) - (index 9) 8 bits: number of literals (#numLiterals) - (index 17) 1 bit: whether a large frame size is needed (#frameSize) - (index 18) 6 bits: number of temporary variables (#numTemps) - (index 24) 4 bits: number of arguments to the method (#numArgs) - (index 28) 1 bit: high-bit of primitive number (#primitive) - (index 29) 1 bit: flag bit, ignored by the VM (#flag) - (index 30/63) sign bit: 0 selects the Primary instruction set (#signFlag) - sign bit 1, header < 0: (index 0) 16 bits: number of literals (#numLiterals) (index 16) 1 bit: has primitive + (index 17) 1 bit: whether a large frame size is needed (#frameSize => either SmallFrame or LargeFrame) - (index 17) 1 bit: whether a large frame size is needed (#frameSize) (index 18) 6 bits: number of temporary variables (#numTemps) (index 24) 4 bits: number of arguments to the method (#numArgs) + (index 28) 2 bits: reserved for an access modifier (00-unused, 01-private, 10-protected, 11-public), although accessors for bit 29 exist (see #flag). + (index 30/63) sign bit: 1 selects the Secondary instruction set (e.g. NewsqueakV4, 0 selects the primary instruction set, e.g. SqueakV3PlusClosures) (#signFlag) - (index 28) 2 bits: reserved for an access modifier (00-unused, 01-private, 10-protected, 11-public) - (index 30/63) sign bit: 1 selects the Secondary instruction set (e.g. NewsqueakV4) (#signFlag) - i.e. the Secondary Bytecode Set expands the number of literals to 65535 by assuming a CallPrimitive bytecode. + If the method has a primitive then the first bytecode of the method must be a callPrimitive: bytecode that encodes the primitive index. + + The trailer is an encoding of an instance of CompiledMethodTrailer. It is typically used to encode the index into the source files array of the method's source, but may be used to encode other values, e.g. tempNames, source as a string, etc. See the class CompiledMethodTrailer. + + The last literal in a CompiledMethod must be its methodClassAssociation, a binding whose value is the class the method is installed in. The methodClassAssociation is used to implement super sends. If a method contains no super send then its methodClassAssociation may be left nil (as would be the case for example of methods providing a pool of inst var accessors). By convention the penultimate literal of a method is either its selector or an instance of AdditionalMethodState. AdditionalMethodState holds any pragmas and properties of a method, but may also be used to add instance variables to a method, albeit ones held in the method's AdditionalMethodState. Subclasses of CompiledMethod that want to add state should subclass AdditionalMethodState to add the state they want, and implement methodPropertiesClass on the class side of the CompiledMethod subclass to answer the specialized subclass of AdditionalMethodState.! - The trailer is an encoding of an instance of CompiledMethodTrailer. It is typically used to encode the index into the source files array of the method's source, but may be used to encode other values, e.g. tempNames, source as a string, etc. See the class CompiledMethodTrailer.! Item was added: + ----- Method: CompiledMethod class>>handleFailingFailingNewMethod:header: (in category 'private') ----- + handleFailingFailingNewMethod: numberOfBytes header: headerWord + "This newMethod:header: gets sent after handleFailingBasicNew: has done a full + garbage collection and possibly grown memory. If this basicNew: fails then the + system really is low on space, so raise the OutOfMemory signal. + + Primitive. Answer an instance of this class with the number of indexable variables + specified by the argument, headerWord, and the number of bytecodes specified + by numberOfBytes. Fail if this if the arguments are not Integers, or if numberOfBytes + is negative, or if the receiver is not a CompiledMethod class, or if there is not enough + memory available. Essential. See Object documentation whatIsAPrimitive." + + <primitive: 79> + "space must be low." + OutOfMemory signal. + "retry if user proceeds" + ^self newMethod: numberOfBytes header: headerWord! Item was added: + ----- Method: CompiledMethod class>>handleFailingNewMethod:header: (in category 'private') ----- + handleFailingNewMethod: numberOfBytes header: headerWord + "This newMethod:header: gets sent after newMethod:header: has failed + and allowed a scavenging garbage collection to occur. The scavenging + collection will have happened as the VM is activating the (failing) basicNew:. + If handleFailingBasicNew: fails then the scavenge failed to reclaim sufficient + space and a global garbage collection is required. Retry after garbage + collecting and growing memory if necessary. + + Primitive. Answer an instance of this class with the number of indexable variables + specified by the argument, headerWord, and the number of bytecodes specified + by numberOfBytes. Fail if this if the arguments are not Integers, or if numberOfBytes + is negative, or if the receiver is not a CompiledMethod class, or if there is not enough + memory available. Essential. See Object documentation whatIsAPrimitive." + + <primitive: 79> + | bytesRequested | + bytesRequested := (headerWord bitAnd: 16rFFFF) + 1 * Smalltalk wordSize + numberOfBytes + 16. + Smalltalk garbageCollect < bytesRequested ifTrue: + [Smalltalk growMemoryByAtLeast: bytesRequested]. + "retry after global garbage collect and possible grow" + ^self handleFailingFailingNewMethod: numberOfBytes header: headerWord! Item was added: + ----- Method: CompiledMethod class>>installPrimaryBytecodeSet: (in category 'class initialization') ----- + installPrimaryBytecodeSet: aBytecodeEncoderSubclass + PrimaryBytecodeSetEncoderClass == aBytecodeEncoderSubclass ifTrue: + [^self]. + (aBytecodeEncoderSubclass inheritsFrom: BytecodeEncoder) ifFalse: + [self error: 'A bytecode set encoder is expected to be a subclass of BytecodeEncoder']. + (self allSubInstances + detect: [:m| m header >= 0 and: [m encoderClass ~~ aBytecodeEncoderSubclass]] + ifNone: []) ifNotNil: + [Warning signal: 'There are existing CompiledMethods with a different encoderClass.']. + PrimaryBytecodeSetEncoderClass := aBytecodeEncoderSubclass! Item was added: + ----- Method: CompiledMethod class>>installSecondaryBytecodeSet: (in category 'class initialization') ----- + installSecondaryBytecodeSet: aBytecodeEncoderSubclass + PrimaryBytecodeSetEncoderClass == aBytecodeEncoderSubclass ifTrue: + [^self]. + (aBytecodeEncoderSubclass inheritsFrom: BytecodeEncoder) ifFalse: + [self error: 'A bytecode set encoder is expected to be a subclass of BytecodeEncoder']. + (self allSubInstances + detect: [:m| m header < 0 and: [m encoderClass ~~ aBytecodeEncoderSubclass]] + ifNone: []) ifNotNil: + [Warning signal: 'There are existing CompiledMethods with a different encoderClass.']. + SecondaryBytecodeSetEncoderClass := aBytecodeEncoderSubclass! Item was changed: ----- Method: CompiledMethod class>>newBytes:trailerBytes:nArgs:nTemps:nStack:nLits:primitive: (in category 'instance creation') ----- newBytes: numberOfBytes trailerBytes: trailer nArgs: nArgs nTemps: nTemps nStack: stackSize nLits: nLits primitive: primitiveIndex "Answer an instance of me. The header is specified by the message arguments. The remaining parts are not as yet determined." + | method pc | + nArgs > 15 ifTrue: + [^self error: 'Cannot compile -- too many arguments']. - | largeBit primBits | nTemps > 63 ifTrue: + [^self error: 'Cannot compile -- too many temporary variables']. + nLits > 65535 ifTrue: + [^self error: 'Cannot compile -- too many literals']. - [^ self error: 'Cannot compile -- too many temporary variables']. - nLits > 255 ifTrue: - [^ self error: 'Cannot compile -- too many literals']. - largeBit := (nTemps + stackSize) > SmallFrame ifTrue: [1] ifFalse: [0]. - primBits := primitiveIndex <= 16r1FF - ifTrue: [primitiveIndex] - ifFalse: ["For now the high bit of primitive no. is in the 29th bit of header" - primitiveIndex > 16r3FF ifTrue: [self error: 'prim num too large']. - (primitiveIndex bitAnd: 16r1FF) + ((primitiveIndex bitAnd: 16r200) bitShift: 19)]. + method := trailer + createMethod: numberOfBytes + class: self + header: (nArgs bitShift: 24) + + (nTemps bitShift: 18) + + ((nTemps + stackSize) > SmallFrame ifTrue: [1 bitShift: 17] ifFalse: [0]) + + nLits + + (primitiveIndex > 0 ifTrue: [1 bitShift: 16] ifFalse: [0]). + primitiveIndex > 0 ifTrue: + [pc := method initialPC. + method + at: pc + 0 put: method encoderClass callPrimitiveCode; + at: pc + 1 put: (primitiveIndex bitAnd: 16rFF); + at: pc + 2 put: (primitiveIndex bitShift: -8)]. + ^method! - ^trailer - createMethod: numberOfBytes - class: self - header: (nArgs bitShift: 24) + - (nTemps bitShift: 18) + - (largeBit bitShift: 17) + - (nLits bitShift: 9) + - primBits! Item was changed: ----- Method: CompiledMethod class>>newBytes:trailerBytes:nArgs:nTemps:nStack:nLits:primitive:flag: (in category 'instance creation') ----- newBytes: numberOfBytes trailerBytes: trailer nArgs: nArgs nTemps: nTemps nStack: stackSize nLits: nLits primitive: primitiveIndex flag: flag "Answer an instance of me. The header is specified by the message arguments. The remaining parts are not as yet determined." + | method pc | + nArgs > 15 ifTrue: + [^self error: 'Cannot compile -- too many arguments']. - | largeBit primBits flagBit | nTemps > 63 ifTrue: + [^self error: 'Cannot compile -- too many temporary variables']. + nLits > 65535 ifTrue: + [^self error: 'Cannot compile -- too many literals']. - [^ self error: 'Cannot compile -- too many temporary variables']. - nLits > 255 ifTrue: - [^ self error: 'Cannot compile -- too many literals']. - largeBit := (nTemps + stackSize) > SmallFrame ifTrue: [1] ifFalse: [0]. + method := trailer + createMethod: numberOfBytes + class: self + header: (nArgs bitShift: 24) + + (nTemps bitShift: 18) + + ((nTemps + stackSize) > SmallFrame ifTrue: [1 bitShift: 17] ifFalse: [0]) + + nLits + + (primitiveIndex > 0 ifTrue: [1 bitShift: 16] ifFalse: [0]) + + (flag ifTrue: [1 bitShift: 29] ifFalse: [0]). + primitiveIndex > 0 ifTrue: + [pc := method initialPC. + method + at: pc + 0 put: method encoderClass callPrimitiveCode; + at: pc + 1 put: (primitiveIndex bitAnd: 16rFF); + at: pc + 2 put: (primitiveIndex bitShift: -8)]. + ^method! - "For now the high bit of the primitive no. is in a high bit of the header" - primBits := (primitiveIndex bitAnd: 16r1FF) + ((primitiveIndex bitAnd: 16r200) bitShift: 19). - - flagBit := flag ifTrue: [ 1 ] ifFalse: [ 0 ]. - - ^trailer - createMethod: numberOfBytes - class: self - header: (nArgs bitShift: 24) + - (nTemps bitShift: 18) + - (largeBit bitShift: 17) + - (nLits bitShift: 9) + - primBits + - (flagBit bitShift: 29)! Item was changed: ----- Method: CompiledMethod class>>newMethod:header: (in category 'instance creation') ----- + newMethod: numberOfBytes header: headerWord - newMethod: numberOfBytes header: headerWord "Primitive. Answer an instance of me. The number of literals (and other + information) is specified by the headerWord (see my class comment). + The first argument specifies the number of fields for bytecodes in the + method. Fail if either argument is not a SmallInteger, or if numberOfBytes + is negative, or if memory is low. Once the header of a method is set by + this primitive, it cannot be changed to change the number of literals. + Essential. See Object documentation whatIsAPrimitive." - information) is specified the headerWord. The first argument specifies - the number of fields for bytecodes in the method. Fail if either - argument is not a SmallInteger, or if numberOfBytes is negative. Once - the header of a method is set by this primitive, it cannot be changed in - any way. Essential. See Object documentation whatIsAPrimitive." + <primitive: 79 error: ec> + ec == #'insufficient object memory' ifTrue: + [^self handleFailingNewMethod: numberOfBytes header: headerWord]. - <primitive: 79> - (numberOfBytes isInteger and: - [headerWord isInteger and: - [numberOfBytes >= 0]]) ifTrue: [ - "args okay; space must be low" - OutOfMemory signal. - "retry if user proceeds" - ^ self newMethod: numberOfBytes header: headerWord - ]. ^self primitiveFailed! Item was changed: ----- Method: CompiledMethod class>>toReturnConstant:trailerBytes: (in category 'instance creation') ----- toReturnConstant: index trailerBytes: trailer "Answer an instance of me that is a quick return of the constant indexed in (true false nil -1 0 1 2)." + ^self newBytes: 3 trailerBytes: trailer nArgs: 0 nTemps: 0 nStack: 0 nLits: 2 primitive: 256 + index! - ^ self newBytes: 0 trailerBytes: trailer nArgs: 0 nTemps: 0 nStack: 0 nLits: 2 primitive: 256 + index - ! Item was changed: ----- Method: CompiledMethod class>>toReturnField:trailerBytes: (in category 'instance creation') ----- toReturnField: field trailerBytes: trailer "Answer an instance of me that is a quick return of the instance variable indexed by the argument, field." + ^self newBytes: 3 trailerBytes: trailer nArgs: 0 nTemps: 0 nStack: 0 nLits: 2 primitive: 264 + field! - ^ self newBytes: 0 trailerBytes: trailer nArgs: 0 nTemps: 0 nStack: 0 nLits: 2 primitive: 264 + field - ! Item was changed: ----- Method: CompiledMethod class>>toReturnSelfTrailerBytes: (in category 'instance creation') ----- toReturnSelfTrailerBytes: trailer "Answer an instance of me that is a quick return of the instance (^self)." + ^self newBytes: 3 trailerBytes: trailer nArgs: 0 nTemps: 0 nStack: 0 nLits: 2 primitive: 256! - ^ self newBytes: 0 trailerBytes: trailer nArgs: 0 nTemps: 0 nStack: 0 nLits: 2 primitive: 256 - ! Item was added: + ----- Method: CompiledMethod>>bytecodeSetName (in category 'accessing') ----- + bytecodeSetName + ^self encoderClass name copyReplaceAll: 'EncoderFor' with: ''! Item was changed: ----- Method: CompiledMethod>>headerDescription (in category 'literals') ----- headerDescription + "Answer a description containing the information about the form of the + receiver and the form of the context needed to run the receiver." - "Answer a description containing the information about the form of the - receiver and the form of the context needed to run the receiver." + ^(ByteString new: 128) writeStream + print: self header; cr; + nextPutAll: '"primitive: '; print: self primitive; cr; + nextPutAll: ' numArgs: '; print: self numArgs; cr; + nextPutAll: ' numTemps: '; print: self numTemps; cr; + nextPutAll: ' numLiterals: '; print: self numLiterals; cr; + nextPutAll: ' frameSize: '; print: self frameSize; cr; + nextPutAll: ' bytecodeSet: '; nextPutAll: self bytecodeSetName; + nextPut: $"; cr; + contents! - | s | - s := '' writeStream. - self header printOn: s. - s cr; nextPutAll: '"primitive: '. - self primitive printOn: s. - s cr; nextPutAll: ' numArgs: '. - self numArgs printOn: s. - s cr; nextPutAll: ' numTemps: '. - self numTemps printOn: s. - s cr; nextPutAll: ' numLiterals: '. - self numLiterals printOn: s. - s cr; nextPutAll: ' frameSize: '. - self frameSize printOn: s. - s cr; nextPutAll: ' isClosureCompiled: '. - self isBlueBookCompiled not printOn: s. - s nextPut: $"; cr. - ^ s contents! Item was changed: ----- Method: CompiledMethod>>numLiterals (in category 'accessing') ----- numLiterals "Answer the number of literals used by the receiver." + ^self header bitAnd: 65535! - | header | - ^(header := self header) < 0 - ifTrue: [header bitAnd: 65535] - ifFalse: [(header bitShift: -9) bitAnd: 16rFF]! Item was changed: ----- Method: CompiledMethod>>primitive (in category 'accessing') ----- primitive "Answer the primitive index associated with the receiver. + Zero indicates that this is not a primitive method." + | initialPC | + ^(self header anyMask: 65536) "Is the hasPrimitive? flag set?" + ifTrue: [(self at: (initialPC := self initialPC) + 1) + ((self at: initialPC + 2) bitShift: 8)] + ifFalse: [0]! - Zero indicates that this is not a primitive method. - In the original header format we currently allow 10 bits of primitive index, but they are - in two places for backward compatibility. In the new format the primitive index is in the - last two bytes of a three byte callPrimitive: bytecode. The time to unpack is negligible, - since the derived primitive function pointer full index is stored in the method cache." - | header initialPC | - ^(header := self header) < 0 - ifTrue: - [(header anyMask: 65536) "Is the hasPrimitive? flag set?" - ifTrue: [(self at: (initialPC := self initialPC) + 1) + ((self at: initialPC + 2) bitShift: 8)] - ifFalse: [0]] - ifFalse: - [(header bitAnd: 16r1FF) + ((header bitShift: -19) bitAnd: 16r200)]! Item was changed: ----- Method: ContextPart>>activateReturn:value: (in category 'private') ----- activateReturn: aContext value: value "Activate 'aContext return: value' in place of self, so execution will return to aContext's sender" + ^MethodContext + sender: self - ^ self - activateMethod: ContextPart theReturnMethod - withArgs: {value} receiver: aContext + method: MethodContext theReturnMethod + arguments: {value}! - class: aContext class! Item was changed: ----- Method: ContextPart>>doPrimitive:method:receiver:args: (in category 'private') ----- doPrimitive: primitiveIndex method: meth receiver: receiver args: arguments + "Simulate a primitive method whose index is primitiveIndex. The simulated receiver and + arguments are given as arguments to this message. If successful, push result and return + resuming context, else ^ {errCode, PrimitiveFailToken}. Any primitive which provokes + execution needs to be intercepted and simulated to avoid execution running away." - "Simulate a primitive method whose index is primitiveIndex. The - simulated receiver and arguments are given as arguments to this message. - If successful, push result and return resuming context, else ^ PrimitiveFailToken. - Any primitive which provokes execution needs to be intercepted and simulated - to avoid execution running away." | value | "Judicious use of primitive 19 (a null primitive that doesn't do anything) prevents the debugger from entering various run-away activities such as spawning a new process, etc. Injudicious use results in the debugger not being able to debug + interesting code, such as the debugger itself. hence use primitive 19 with care :-)" - interesting code, such as the debugger itself. hence use primtiive 19 with care :-)" "SystemNavigation new browseAllSelect: [:m| m primitive = 19]" primitiveIndex = 19 ifTrue: [ToolSet debugContext: self label:'Code simulation error' contents: nil]. + ((primitiveIndex between: 201 and: 222) + and: [(self objectClass: receiver) includesBehavior: BlockClosure]) ifTrue: + [((primitiveIndex between: 201 and: 205) "BlockClosure>>value[:value:...]" + or: [primitiveIndex between: 221 and: 222]) ifTrue: "BlockClosure>>valueNoContextSwitch[:]" + [^receiver simulateValueWithArguments: arguments caller: self]. + primitiveIndex = 206 ifTrue: "BlockClosure>>valueWithArguments:" + [^receiver simulateValueWithArguments: arguments first caller: self]]. - "ContextPart>>blockCopy:; simulated to get startpc right" - (primitiveIndex = 80 and: [(self objectClass: receiver) includesBehavior: ContextPart]) - ifTrue: [^self push: ((BlockContext newForMethod: receiver method) - home: receiver home - startpc: pc + 2 - nargs: (arguments at: 1))]. - (primitiveIndex = 81 and: [(self objectClass: receiver) == BlockContext]) "BlockContext>>value[:value:...]" - ifTrue: [^receiver pushArgs: arguments from: self]. - (primitiveIndex = 82 and: [(self objectClass: receiver) == BlockContext]) "BlockContext>>valueWithArguments:" - ifTrue: [^receiver pushArgs: arguments first from: self]. - primitiveIndex = 83 "afr 9/11/1998 19:50" "Object>>perform:[with:...]" - ifTrue: [^self send: arguments first - to: receiver - with: arguments allButFirst - super: false]. - primitiveIndex = 84 "afr 9/11/1998 19:50 & eem 8/18/2009 17:04" "Object>>perform:withArguments:" - ifTrue: [^self send: arguments first - to: receiver - with: (arguments at: 2) - startClass: nil]. - primitiveIndex = 100 "eem 8/18/2009 16:57" "Object>>perform:withArguments:inSuperclass:" - ifTrue: [^self send: arguments first - to: receiver - with: (arguments at: 2) - startClass: (arguments at: 3)]. + primitiveIndex = 83 ifTrue: "afr 9/11/1998 19:50" "Object>>perform:[with:...]" + [^self send: arguments first to: receiver with: arguments allButFirst super: false]. + primitiveIndex = 84 ifTrue: "afr 9/11/1998 19:50 & eem 8/18/2009 17:04" "Object>>perform:withArguments:" + [^self send: arguments first to: receiver with: (arguments at: 2) lookupIn: (self objectClass: receiver)]. + primitiveIndex = 100 ifTrue: "eem 8/18/2009 16:57" "Object>>perform:withArguments:inSuperclass:" + [^self send: arguments first to: receiver with: (arguments at: 2) lookupIn: (arguments at: 3)]. + "Mutex>>primitiveEnterCriticalSection Mutex>>primitiveTestAndSetOwnershipOfCriticalSection" (primitiveIndex = 186 or: [primitiveIndex = 187]) ifTrue: [| active effective | active := Processor activeProcess. effective := active effectiveProcess. "active == effective" value := primitiveIndex = 186 ifTrue: [receiver primitiveEnterCriticalSectionOnBehalfOf: effective] ifFalse: [receiver primitiveTestAndSetOwnershipOfCriticalSectionOnBehalfOf: effective]. + ^(self isPrimFailToken: value) - ^((self objectClass: value) == Array - and: [value size = 2 - and: [value first == PrimitiveFailToken]]) ifTrue: [value] ifFalse: [self push: value]]. + primitiveIndex = 188 ifTrue: "eem 5/27/2008 11:10 Object>>withArgs:executeMethod:" - ((primitiveIndex = 188 or: [primitiveIndex = 189]) "eem 10/6/2014 16:14 Object>>with:*executeMethod:" - and: [arguments last isQuick not]) ifTrue: "eem 5/27/2008 11:10 Object>>withArgs:executeMethod:" [^MethodContext sender: self receiver: receiver + method: (arguments at: 2) + arguments: (arguments at: 1)]. - method: arguments last - arguments: (primitiveIndex = 188 - ifTrue: [arguments at: 1] - ifFalse: [arguments allButLast])]. "Closure primitives" (primitiveIndex = 200 and: [self == receiver]) ifTrue: "ContextPart>>closureCopy:copiedValues:; simulated to get startpc right" [^self push: (BlockClosure outerContext: receiver startpc: pc + 2 numArgs: arguments first copiedValues: arguments last)]. - ((primitiveIndex between: 201 and: 205) "BlockClosure>>value[:value:...]" - or: [primitiveIndex between: 221 and: 222]) ifTrue: "BlockClosure>>valueNoContextSwitch[:]" - [^receiver simulateValueWithArguments: arguments caller: self]. - primitiveIndex = 206 ifTrue: "BlockClosure>>valueWithArguments:" - [^receiver simulateValueWithArguments: arguments first caller: self]. primitiveIndex = 118 ifTrue: "tryPrimitive:withArgs:; avoid recursing in the VM" [(arguments size = 2 and: [arguments first isInteger and: [(self objectClass: arguments last) == Array]]) ifFalse: [^ContextPart primitiveFailTokenFor: nil]. ^self doPrimitive: arguments first method: meth receiver: receiver args: arguments last]. value := primitiveIndex = 120 "FFI method" ifTrue: [(meth literalAt: 1) tryInvokeWithArguments: arguments] ifFalse: [primitiveIndex = 117 "named primitives" ifTrue: [self tryNamedPrimitiveIn: meth for: receiver withArgs: arguments] + ifFalse: [receiver tryPrimitive: primitiveIndex withArgs: arguments]]. + + ^(self isPrimFailToken: value) - ifFalse: - [receiver tryPrimitive: primitiveIndex withArgs: arguments]]. - ^((self objectClass: value) == Array - and: [value size = 2 - and: [value first == PrimitiveFailToken]]) ifTrue: [value] ifFalse: [self push: value]! Item was added: + ----- Method: ContextPart>>isPrimFailToken: (in category 'private') ----- + isPrimFailToken: anObject + ^(self objectClass: anObject) == Array + and: [anObject size = 2 + and: [anObject first == PrimitiveFailToken]]! Item was added: + ----- Method: ContextPart>>send:to:with:lookupIn: (in category 'controlling') ----- + send: selector to: rcvr with: arguments lookupIn: lookupClass + "Simulate the action of sending a message with selector and arguments + to rcvr. The argument, lookupClass, is the class in which to lookup the + message. This is the receiver's class for normal messages, but for super + messages it will be some specific class related to the source method." + + | meth primIndex val ctxt | + (meth := lookupClass lookupSelector: selector) ifNil: + [^self send: #doesNotUnderstand: + to: rcvr + with: {Message selector: selector arguments: arguments} + lookupIn: lookupClass]. + (primIndex := meth primitive) > 0 ifTrue: + [val := self doPrimitive: primIndex method: meth receiver: rcvr args: arguments. + (self isPrimFailToken: val) ifFalse: + [^val]]. + (selector == #doesNotUnderstand: and: [lookupClass == ProtoObject]) ifTrue: + [^self error: 'Simulated message ', arguments first selector, ' not understood']. + ctxt := MethodContext sender: self receiver: rcvr method: meth arguments: arguments. + primIndex > 0 ifTrue: + [ctxt failPrimitiveWith: val]. + ^ctxt! Item was changed: ----- Method: ContextPart>>send:to:with:super: (in category 'controlling') ----- + send: selector to: rcvr with: arguments super: superFlag + "Simulate the action of sending a message with selector arguments + to rcvr. The argument, superFlag, tells whether the receiver of the + message was specified with 'super' in the source method." - send: selector to: rcvr with: args super: superFlag - "Simulate the action of sending a message with selector, selector, and - arguments, args, to receiver. The argument, superFlag, tells whether the - receiver of the message was specified with 'super' in the source method." + ^self send: selector + to: rcvr + with: arguments + lookupIn: (superFlag + ifTrue: [self method methodClassAssociation value superclass] + ifFalse: [self objectClass: rcvr])! - | class meth val ctxt | - class := superFlag - ifTrue: [self method methodClassAssociation value superclass] - ifFalse: [self objectClass: rcvr]. - meth := class lookupSelector: selector. - meth == nil ifTrue: - [^self - send: #doesNotUnderstand: - to: rcvr - with: (Array with: (Message selector: selector arguments: args)) - super: superFlag]. - val := self tryPrimitiveFor: meth receiver: rcvr args: args. - ((self objectClass: val) == Array - and: [val size = 2 - and: [val first == PrimitiveFailToken]]) ifFalse: - [^val]. - (selector == #doesNotUnderstand: - and: [class == ProtoObject]) ifTrue: - [^self error: 'Simulated message ' , (args at: 1) selector, ' not understood']. - ctxt := self activateMethod: meth withArgs: args receiver: rcvr class: class. - ((self objectClass: val) == Array - and: [val size = 2 - and: [val first == PrimitiveFailToken - and: [val last notNil - and: [(ctxt method at: ctxt pc) = 129 "long store temp"]]]]) ifTrue: - [ctxt at: ctxt stackPtr put: val last]. - ^ctxt! Item was changed: ----- Method: ContextPart>>tryNamedPrimitiveIn:for:withArgs: (in category 'private') ----- tryNamedPrimitiveIn: aCompiledMethod for: aReceiver withArgs: arguments + "Invoke the named primitive for aCompiledMethod, answering its result, or, + if the primiitve fails, answering the error code." - | selector theMethod spec receiverClass | <primitive: 218 error: ec> ec ifNotNil: ["If ec is an integer other than -1 there was a problem with primitive 218, not with the external primitive itself. -1 indicates a generic failure (where ec should be nil) but ec = nil means primitive 218 is not implemented. So interpret -1 to mean the external primitive failed with a nil error code." ec isInteger ifTrue: [ec = -1 ifTrue: [ec := nil] + ifFalse: [self primitiveFailed]]]. + ^self class primitiveFailTokenFor: ec! - ifFalse: [self primitiveFailed]]. - ^{PrimitiveFailToken. ec}]. - "Assume a nil error code implies the primitive is not implemented and fall back on the old code." - "Hack. Attempt to execute the named primitive from the given compiled method" - arguments size > 8 ifTrue: - [^{PrimitiveFailToken. nil}]. - selector := #( - tryNamedPrimitive - tryNamedPrimitive: - tryNamedPrimitive:with: - tryNamedPrimitive:with:with: - tryNamedPrimitive:with:with:with: - tryNamedPrimitive:with:with:with:with: - tryNamedPrimitive:with:with:with:with:with: - tryNamedPrimitive:with:with:with:with:with:with: - tryNamedPrimitive:with:with:with:with:with:with:with:) at: arguments size+1. - receiverClass := self objectClass: aReceiver. - theMethod := receiverClass lookupSelector: selector. - theMethod == nil ifTrue: - [^{PrimitiveFailToken. nil}]. - spec := theMethod literalAt: 1. - spec replaceFrom: 1 to: spec size with: (aCompiledMethod literalAt: 1) startingAt: 1. - Smalltalk unbindExternalPrimitives. - ^self object: aReceiver perform: selector withArguments: arguments inClass: receiverClass! Item was changed: + Number subclass: #Float - Number variableWordSubclass: #Float instanceVariableNames: '' classVariableNames: 'E Epsilon Halfpi Infinity Ln10 Ln2 MaxVal MaxValLn MinValLogBase2 NaN NegativeInfinity NegativeZero Pi RadiansPerDegree Sqrt2 ThreePi Twopi' poolDictionaries: '' category: 'Kernel-Numbers'! !Float commentStamp: '<historical>' prior: 0! My instances represent IEEE-754 floating-point double-precision numbers. They have about 16 digits of accuracy and their range is between plus and minus 10^307. Some valid examples are: 8.0 13.3 0.3 2.5e6 1.27e-30 1.27e-31 -12.987654e12 Mainly: no embedded blanks, little e for tens power, and a digit on both sides of the decimal point. It is actually possible to specify a radix for Squeak Float constants. This is great for teaching about numbers, but may be confusing to the average reader: 3r20.2 --> 6.66666666666667 8r20.2 --> 16.25 If you don't have access to the definition of IEEE-754, you can figure out what is going on by printing various simple values in Float hex. It may help you to know that the basic format is... sign 1 bit exponent 11 bits with bias of 1023 (16r3FF) to produce an exponent in the range -1023 .. +1024 - 16r000: significand = 0: Float zero significand ~= 0: Denormalized number (exp = -1024, no hidden '1' bit) - 16r7FF: significand = 0: Infinity significand ~= 0: Not A Number (NaN) representation mantissa 53 bits, but only 52 are stored (20 in the first word, 32 in the second). This is because a normalized mantissa, by definition, has a 1 to the right of its floating point, and IEEE-754 omits this redundant bit to gain an extra bit of precision instead. People talk about the mantissa without its leading one as the FRACTION, and with its leading 1 as the SIGNFICAND. The single-precision format is... sign 1 bit exponent 8 bits, with bias of 127, to represent -126 to +127 - 0x0 and 0xFF reserved for Float zero (mantissa is ignored) - 16r7F reserved for Float underflow/overflow (mantissa is ignored) mantissa 24 bits, but only 23 are stored This format is used in FloatArray (qv), and much can be learned from the conversion routines, Float asIEEE32BitWord, and Float class fromIEEE32Bit:. Thanks to Rich Harmon for asking many questions and to Tim Olson, Bruce Cohen, Rick Zaccone and others for the answers that I have collected here.! Item was changed: ----- Method: Float class>>basicNew (in category 'instance creation') ----- basicNew + ^BoxedFloat64 basicNew: 2! - ^self basicNew: 2! Item was changed: ----- Method: Float class>>basicNew: (in category 'instance creation') ----- basicNew: anInteger + ^BoxedFloat64 basicNew: 2! - anInteger = 2 ifFalse: [^self error: 'a Float shall always have two slots']. - ^super basicNew: 2! Item was changed: ----- Method: Float class>>fromIEEE32Bit: (in category 'instance creation') ----- fromIEEE32Bit: word + "Convert the given 32 bit word (which is supposed to be a positive 32-bit value) from + a 32 bit IEEE floating point representation into an actual Squeak float object (being + 64 bits wide). Should only be used for conversion in FloatArrays or likewise objects." - "Convert the given 32 bit word (which is supposed to be a positive 32bit value) from a 32bit IEEE floating point representation into an actual Squeak float object (being 64bit wide). Should only be used for conversion in FloatArrays or likewise objects." + | sign mantissa exponent delta | + word <= 0 ifTrue: + [^word negative + ifTrue: [self error: 'Cannot deal with negative numbers'] + ifFalse: [self zero]]. - | sign mantissa exponent newFloat delta | - word negative ifTrue: [^ self error:'Cannot deal with negative numbers']. - word = 0 ifTrue: [^ Float zero]. sign := word bitAnd: 16r80000000. + word = sign ifTrue: + [^self negativeZero]. - word = sign ifTrue: [^self negativeZero]. exponent := ((word bitShift: -23) bitAnd: 16rFF) - 127. mantissa := word bitAnd: 16r7FFFFF. + exponent = 128 ifTrue: "Either NAN or INF" + [^mantissa = 0 + ifTrue: + [sign = 0 + ifTrue: [self infinity] + ifFalse: [self negativeInfinity]] + ifFalse: [self nan]]. - exponent = 128 ifTrue:["Either NAN or INF" - mantissa = 0 ifFalse:[^ Float nan]. - sign = 0 - ifTrue:[^ Float infinity] - ifFalse:[^ Float negativeInfinity]]. + exponent = -127 ifTrue: - exponent = -127 ifTrue: [ "gradual underflow (denormalized number) + Remove first bit of mantissa and adjust exponent" + [delta := mantissa highBit. + mantissa := (mantissa bitShift: 1) bitAnd: (1 bitShift: delta) - 1. + exponent := exponent + delta - 23]. - Remove first bit of mantissa and adjust exponent" - delta := mantissa highBit. - mantissa := (mantissa bitAnd: (1 bitShift: delta - 1) - 1) bitShift: 24 - delta. - exponent := exponent + delta - 23]. "Create new float" + ^(self basicNew: 2) + basicAt: 1 put: ((sign bitOr: (1023 + exponent bitShift: 20)) bitOr: (mantissa bitShift: -3)); + basicAt: 2 put: ((mantissa bitAnd: 7) bitShift: 29); + * 1.0 "reduce to SmallFloat64 if possible"! - newFloat := self new: 2. - newFloat basicAt: 1 put: ((sign bitOr: (1023 + exponent bitShift: 20)) bitOr: (mantissa bitShift: -3)). - newFloat basicAt: 2 put: ((mantissa bitAnd: 7) bitShift: 29). - ^newFloat! Item was removed: - ----- Method: Float>>* (in category 'arithmetic') ----- - * aNumber - "Primitive. Answer the result of multiplying the receiver by aNumber. - Fail if the argument is not a Float. Essential. See Object documentation - whatIsAPrimitive." - - <primitive: 49> - ^ aNumber adaptToFloat: self andSend: #*! Item was removed: - ----- Method: Float>>+ (in category 'arithmetic') ----- - + aNumber - "Primitive. Answer the sum of the receiver and aNumber. Essential. - Fail if the argument is not a Float. See Object documentation - whatIsAPrimitive." - - <primitive: 41> - ^ aNumber adaptToFloat: self andSend: #+! Item was removed: - ----- Method: Float>>- (in category 'arithmetic') ----- - - aNumber - "Primitive. Answer the difference between the receiver and aNumber. - Fail if the argument is not a Float. Essential. See Object documentation - whatIsAPrimitive." - - <primitive: 42> - ^ aNumber adaptToFloat: self andSend: #-! Item was removed: - ----- Method: Float>>/ (in category 'arithmetic') ----- - / aNumber - "Primitive. Answer the result of dividing receiver by aNumber. - Fail if the argument is not a Float. Essential. See Object documentation - whatIsAPrimitive." - - <primitive: 50> - aNumber isZero ifTrue: [^(ZeroDivide dividend: self) signal]. - ^ aNumber adaptToFloat: self andSend: #/! Item was removed: - ----- Method: Float>>< (in category 'comparing') ----- - < aNumber - "Primitive. Compare the receiver with the argument and return true - if the receiver is less than the argument. Otherwise return false. - Fail if the argument is not a Float. Essential. See Object documentation - whatIsAPrimitive." - - <primitive: 43> - ^ aNumber adaptToFloat: self andCompare: #<! Item was removed: - ----- Method: Float>><= (in category 'comparing') ----- - <= aNumber - "Primitive. Compare the receiver with the argument and return true - if the receiver is less than or equal to the argument. Otherwise return - false. Fail if the argument is not a Float. Optional. See Object - documentation whatIsAPrimitive." - - <primitive: 45> - ^ aNumber adaptToFloat: self andCompare: #<=! Item was removed: - ----- Method: Float>>= (in category 'comparing') ----- - = aNumber - "Primitive. Compare the receiver with the argument and return true - if the receiver is equal to the argument. Otherwise return false. - Fail if the argument is not a Float. Essential. See Object documentation - whatIsAPrimitive." - - <primitive: 47> - aNumber isNumber ifFalse: [^ false]. - ^ aNumber adaptToFloat: self andCompare: #=! Item was removed: - ----- Method: Float>>> (in category 'comparing') ----- - > aNumber - "Primitive. Compare the receiver with the argument and return true - if the receiver is greater than the argument. Otherwise return false. - Fail if the argument is not a Float. Essential. See Object documentation - whatIsAPrimitive." - - <primitive: 44> - ^ aNumber adaptToFloat: self andCompare: #>! Item was removed: - ----- Method: Float>>>= (in category 'comparing') ----- - >= aNumber - "Primitive. Compare the receiver with the argument and return true - if the receiver is greater than or equal to the argument. Otherwise return - false. Fail if the argument is not a Float. Optional. See Object documentation - whatIsAPrimitive. " - - <primitive: 46> - ^ aNumber adaptToFloat: self andCompare: #>=! Item was removed: - ----- Method: Float>>arcTan (in category 'mathematical functions') ----- - arcTan - "Answer the angle in radians. - Optional. See Object documentation whatIsAPrimitive." - - | theta eps step sinTheta cosTheta | - <primitive: 57> - - "Newton-Raphson" - self < 0.0 ifTrue: [ ^ 0.0 - (0.0 - self) arcTan ]. - - "first guess" - theta := (self * Halfpi) / (self + 1.0). - - "iterate" - eps := Halfpi * Epsilon. - step := theta. - [(step * step) > eps] whileTrue: [ - sinTheta := theta sin. - cosTheta := theta cos. - step := (sinTheta * cosTheta) - (self * cosTheta * cosTheta). - theta := theta - step]. - ^ theta! Item was removed: - ----- Method: Float>>exp (in category 'mathematical functions') ----- - exp - "Answer E raised to the receiver power. - Optional. See Object documentation whatIsAPrimitive." - - | base fract correction delta div | - <primitive: 59> - - "Taylor series" - "check the special cases" - self < 0.0 ifTrue: [^ (self negated exp) reciprocal]. - self = 0.0 ifTrue: [^ 1]. - self abs > MaxValLn ifTrue: [self error: 'exp overflow']. - - "get first approximation by raising e to integer power" - base := E raisedToInteger: (self truncated). - - "now compute the correction with a short Taylor series" - "fract will be 0..1, so correction will be 1..E" - "in the worst case, convergance time is logarithmic with 1/Epsilon" - fract := self fractionPart. - fract = 0.0 ifTrue: [ ^ base ]. "no correction required" - - correction := 1.0 + fract. - delta := fract * fract / 2.0. - div := 2.0. - [delta > Epsilon] whileTrue: [ - correction := correction + delta. - div := div + 1.0. - delta := delta * fract / div]. - correction := correction + delta. - ^ base * correction! Item was removed: - ----- Method: Float>>exponent (in category 'truncation and round off') ----- - exponent - "Primitive. Consider the receiver to be represented as a power of two - multiplied by a mantissa (between one and two). Answer with the - SmallInteger to whose power two is raised. Optional. See Object - documentation whatIsAPrimitive." - - <primitive: 53> - ^self exponentFromBitPattern! Item was removed: - ----- Method: Float>>fractionPart (in category 'truncation and round off') ----- - fractionPart - "Primitive. Answer a Float whose value is the difference between the - receiver and the receiver's asInteger value. Optional. See Object - documentation whatIsAPrimitive." - - <primitive: 52> - ^self - self truncated asFloat! Item was removed: - ----- Method: Float>>ln (in category 'mathematical functions') ----- - ln - "Answer the natural logarithm of the receiver. - Optional. See Object documentation whatIsAPrimitive." - - | expt n mant x div pow delta sum eps | - <primitive: 58> - - "Taylor series" - self <= 0.0 ifTrue: [DomainError signal: 'ln is only defined for x > 0.0']. - - "get a rough estimate from binary exponent" - expt := self exponent. - n := Ln2 * expt. - mant := self timesTwoPower: 0 - expt. - - "compute fine correction from mantinssa in Taylor series" - "mant is in the range [0..2]" - "we unroll the loop to avoid use of abs" - x := mant - 1.0. - div := 1.0. - pow := delta := sum := x. - x := x negated. "x <= 0" - eps := Epsilon * (n abs + 1.0). - [delta > eps] whileTrue: [ - "pass one: delta is positive" - div := div + 1.0. - pow := pow * x. - delta := pow / div. - sum := sum + delta. - "pass two: delta is negative" - div := div + 1.0. - pow := pow * x. - delta := pow / div. - sum := sum + delta]. - - ^ n + sum - - "2.718284 ln 1.0"! Item was removed: - ----- Method: Float>>sin (in category 'mathematical functions') ----- - sin - "Answer the sine of the receiver taken as an angle in radians. - Optional. See Object documentation whatIsAPrimitive." - - | sum delta self2 i | - <primitive: 56> - - "Taylor series" - "normalize to the range [0..Pi/2]" - self < 0.0 ifTrue: [^ (0.0 - ((0.0 - self) sin))]. - self > Twopi ifTrue: [^ (self \\ Twopi) sin]. - self > Pi ifTrue: [^ (0.0 - (self - Pi) sin)]. - self > Halfpi ifTrue: [^ (Pi - self) sin]. - - "unroll loop to avoid use of abs" - sum := delta := self. - self2 := 0.0 - (self * self). - i := 2.0. - [delta > Epsilon] whileTrue: [ - "once" - delta := (delta * self2) / (i * (i + 1.0)). - i := i + 2.0. - sum := sum + delta. - "twice" - delta := (delta * self2) / (i * (i + 1.0)). - i := i + 2.0. - sum := sum + delta]. - ^ sum! Item was removed: - ----- Method: Float>>sqrt (in category 'mathematical functions') ----- - sqrt - "Answer the square root of the receiver. - Optional. See Object documentation whatIsAPrimitive." - | exp guess eps delta | - <primitive: 55> - #Numeric. - "Changed 200/01/19 For ANSI <number> support." - "Newton-Raphson" - self <= 0.0 - ifTrue: [self = 0.0 - ifTrue: [^ 0.0] - ifFalse: ["v Chg" - ^ DomainError signal: 'sqrt undefined for number less than zero.']]. - "first guess is half the exponent" - exp := self exponent // 2. - guess := self timesTwoPower: 0 - exp. - "get eps value" - eps := guess * Epsilon. - eps := eps * eps. - delta := self - (guess * guess) / (guess * 2.0). - [delta * delta > eps] - whileTrue: - [guess := guess + delta. - delta := self - (guess * guess) / (guess * 2.0)]. - ^ guess! Item was removed: - ----- Method: Float>>timesTwoPower: (in category 'mathematical functions') ----- - timesTwoPower: anInteger - "Primitive. Answer with the receiver multiplied by 2.0 raised - to the power of the argument. - Optional. See Object documentation whatIsAPrimitive." - - <primitive: 54> - - anInteger < -29 ifTrue: [^ self * (2.0 raisedToInteger: anInteger)]. - anInteger < 0 ifTrue: [^ self / (1 bitShift: (0 - anInteger)) asFloat]. - anInteger < 30 ifTrue: [^ self * (1 bitShift: anInteger) asFloat]. - ^ self * (2.0 raisedToInteger: anInteger)! Item was removed: - ----- Method: Float>>truncated (in category 'truncation and round off') ----- - truncated - "Answer with a SmallInteger equal to the value of the receiver without - its fractional part. The primitive fails if the truncated value cannot be - represented as a SmallInteger. In that case, the code below will compute - a LargeInteger truncated value. - Essential. See Object documentation whatIsAPrimitive. " - - <primitive: 51> - self isFinite ifFalse: [self error: 'Cannot truncate this number']. - - self abs < 2.0e16 - ifTrue: ["Fastest way when it may not be an integer" - | di df q r | - di := 1 + (SmallInteger maxVal bitShift: -1). - df := di asFloat. - q := self quo: df. - r := self - (q asFloat * df). - ^q * di + r truncated] - ifFalse: [^ self asTrueFraction. "Extract all bits of the mantissa and shift if necess"] - - - - ! Item was removed: - ----- Method: Float>>~= (in category 'comparing') ----- - ~= aNumber - "Primitive. Compare the receiver with the argument and return true - if the receiver is not equal to the argument. Otherwise return false. - Fail if the argument is not a Float. Optional. See Object documentation - whatIsAPrimitive." - - <primitive: 48> - ^super ~= aNumber! Item was added: + ----- Method: InstructionClient>>callPrimitive: (in category 'instruction decoding') ----- + callPrimitive: pimIndex + "V3PlusClosures: 139 10001011 iiiiiiii jjjjjjjj Call Primitive #iiiiiiii + (jjjjjjjj * 256) + NewsqueakV4: 249 11111001 iiiiiiii jjjjjjjj Call Primitive #iiiiiiii + (jjjjjjjj * 256) + SistaV1: 248 11111000 iiiiiiii mjjjjjjj Call Primitive #iiiiiiii + ( jjjjjjj * 256) + m=1 means inlined primitive, no hard return after execution."! Item was added: + ----- Method: InstructionPrinter>>callPrimitive: (in category 'instruction decoding') ----- + callPrimitive: index + "Print the callPrimitive." + + self print: 'callPrimtive: ' , index printString! Item was changed: ----- Method: InstructionStream>>interpretV3ClosuresExtension:in:for: (in category 'decoding - private - v3 plus closures') ----- interpretV3ClosuresExtension: offset in: method for: client | type offset2 byte2 byte3 byte4 | offset <= 6 ifTrue: ["Extended op codes 128-134" byte2 := method at: pc. pc := pc + 1. offset <= 2 ifTrue: ["128-130: extended pushes and pops" type := byte2 // 64. offset2 := byte2 \\ 64. offset = 0 ifTrue: [type = 0 ifTrue: [^client pushReceiverVariable: offset2]. type = 1 ifTrue: [^client pushTemporaryVariable: offset2]. type = 2 ifTrue: [^client pushConstant: (method literalAt: offset2 + 1)]. type = 3 ifTrue: [^client pushLiteralVariable: (method literalAt: offset2 + 1)]]. offset = 1 ifTrue: [type = 0 ifTrue: [^client storeIntoReceiverVariable: offset2]. type = 1 ifTrue: [^client storeIntoTemporaryVariable: offset2]. type = 2 ifTrue: [self error: 'illegalStore']. type = 3 ifTrue: [^client storeIntoLiteralVariable: (method literalAt: offset2 + 1)]]. offset = 2 ifTrue: [type = 0 ifTrue: [^client popIntoReceiverVariable: offset2]. type = 1 ifTrue: [^client popIntoTemporaryVariable: offset2]. type = 2 ifTrue: [self error: 'illegalStore']. type = 3 ifTrue: [^client popIntoLiteralVariable: (method literalAt: offset2 + 1)]]]. "131-134: extended sends" offset = 3 ifTrue: "Single extended send" [^client send: (method literalAt: byte2 \\ 32 + 1) super: false numArgs: byte2 // 32]. offset = 4 ifTrue: "Double extended do-anything" [byte3 := method at: pc. pc := pc + 1. type := byte2 // 32. type = 0 ifTrue: [^client send: (method literalAt: byte3 + 1) super: false numArgs: byte2 \\ 32]. type = 1 ifTrue: [^client send: (method literalAt: byte3 + 1) super: true numArgs: byte2 \\ 32]. type = 2 ifTrue: [^client pushReceiverVariable: byte3]. type = 3 ifTrue: [^client pushConstant: (method literalAt: byte3 + 1)]. type = 4 ifTrue: [^client pushLiteralVariable: (method literalAt: byte3 + 1)]. type = 5 ifTrue: [^client storeIntoReceiverVariable: byte3]. type = 6 ifTrue: [^client popIntoReceiverVariable: byte3]. type = 7 ifTrue: [^client storeIntoLiteralVariable: (method literalAt: byte3 + 1)]]. offset = 5 ifTrue: "Single extended send to super" [^client send: (method literalAt: byte2 \\ 32 + 1) super: true numArgs: byte2 // 32]. offset = 6 ifTrue: "Second extended send" [^client send: (method literalAt: byte2 \\ 64 + 1) super: false numArgs: byte2 // 64]]. offset = 7 ifTrue: [^client doPop]. offset = 8 ifTrue: [^client doDup]. offset = 9 ifTrue: [^client pushActiveContext]. byte2 := method at: pc. pc := pc + 1. offset = 10 ifTrue: [^byte2 < 128 ifTrue: [client pushNewArrayOfSize: byte2] ifFalse: [client pushConsArrayWithElements: byte2 - 128]]. - offset = 11 ifTrue: [^self unusedBytecode: client at: pc - 1]. byte3 := method at: pc. pc := pc + 1. + offset = 11 ifTrue: [^client callPrimitive: byte2 + (byte3 bitShift: 8)]. offset = 12 ifTrue: [^client pushRemoteTemp: byte2 inVectorAt: byte3]. offset = 13 ifTrue: [^client storeIntoRemoteTemp: byte2 inVectorAt: byte3]. offset = 14 ifTrue: [^client popIntoRemoteTemp: byte2 inVectorAt: byte3]. "offset = 15" byte4 := method at: pc. pc := pc + 1. ^client pushClosureCopyNumCopiedValues: (byte2 bitShift: -4) numArgs: (byte2 bitAnd: 16rF) blockSize: (byte3 * 256) + byte4! Item was changed: ----- Method: Integer class>>initialize (in category 'class initialization') ----- + initialize + "Integer initialize" + self initializeLowBitPerByteTable! - initialize "Integer initialize" - "Ensure we have the right compact class index" - - "LPI has been a compact class forever - just ensure basic correctness" - (LargePositiveInteger indexIfCompact = 5) ifFalse:[ - (Smalltalk compactClassesArray at: 5) - ifNil:[LargePositiveInteger becomeCompactSimplyAt: 5] - ifNotNil:[self error: 'Unexpected compact class setup']]. - - "Cog requires LNI to be compact at 4 (replacing PseudoContext)" - (LargeNegativeInteger indexIfCompact = 4) ifFalse:[ - "PseudoContext will likely get removed at some point so write this test - without introducing a hard dependency" - (Smalltalk compactClassesArray at: 4) name == #PseudoContext - ifTrue:[Smalltalk compactClassesArray at: 4 put: nil]. - (Smalltalk compactClassesArray at: 4) - ifNil:[LargeNegativeInteger becomeCompactSimplyAt: 4] - ifNotNil:[self error: 'Unexpected compact class setup']]. - - self initializeLowBitPerByteTable - ! Item was added: + ----- Method: MethodContext class>>allInstances (in category 'enumerating') ----- + allInstances + "Answer all instances of the receiver." + <primitive: 177> + "The primitive can fail because memory is low. If so, fall back on the old + enumeration code, which gives the system a chance to GC and/or grow. + Because aBlock might change the class of inst (for example, using become:), + it is essential to compute next before aBlock value: inst. + Only count until thisContext since this context has been created only to + compute the existing instances." + | inst insts next | + insts := WriteStream on: (Array new: 64). + inst := self someInstance. + [inst == thisContext or: [inst == nil]] whileFalse: + [next := inst nextInstance. + insts nextPut: inst. + inst := next]. + ^insts contents! Item was changed: ----- Method: MethodContext class>>allInstancesDo: (in category 'private') ----- allInstancesDo: aBlock + "Evaluate aBlock with each of the current instances of the receiver." + | instances inst next | + instances := self allInstancesOrNil. + instances ifNotNil: + [instances do: aBlock. + ^self]. + "allInstancesOrNil can fail because memory is low. If so, fall back on the old + enumeration code. Because aBlock might change the class of inst (for example, + using become:), it is essential to compute next before aBlock value: inst. + Only count until thisContext since evaluation of aBlock will create new contexts." - "Only count until thisContext since evaluation of aBlock will create new contexts." - | inst next | inst := self someInstance. + [inst == thisContext or: [inst == nil]] whileFalse: + [next := inst nextInstance. + aBlock value: inst. + inst := next]! - [inst == thisContext] whileFalse:[ - next := inst nextInstance. - aBlock value: inst. - inst := next] - ! Item was added: + ----- Method: MethodContext>>failPrimitiveWith: (in category 'system simulation') ----- + failPrimitiveWith: maybePrimFailToken + "The receiver is a freshly-created context on a primitive method. Skip the callPrimitive: + bytecode and store the primitive fail code if there is one and the method consumes it." + self skipCallPrimitive. + ((self isPrimFailToken: maybePrimFailToken) + and: [method encoderClass isStoreAt: pc in: method]) ifTrue: + [self at: stackp put: maybePrimFailToken last]! Item was changed: ----- Method: Object>>clone (in category 'copying') ----- clone + "Answer a shallow copy of the receiver." + <primitive: 148 error: ec> + | class newObject | + ec == #'insufficient object memory' ifFalse: + [^self primitiveFailed]. + "If the primitive fails due to insufficient memory, instantiate via basicNew: to invoke + the garbage collector before retrying, and use copyFrom: to copy state." + newObject := (class := self class) isVariable + ifTrue: + [class isCompiledMethodClass + ifTrue: + [class newMethod: self basicSize - self initialPC + 1 header: self header] + ifFalse: + [class basicNew: self basicSize]] + ifFalse: + [class basicNew]. + ^newObject copyFrom: self! - - <primitive: 148> - self primitiveFailed! Item was changed: ----- Method: Object>>instVarAt: (in category 'system primitives') ----- + instVarAt: index + "Primitive. Answer a fixed variable in an object. The numbering of the variables + corresponds to the named instance variables, followed by the indexed instance + variables. Fail if the index is not an Integer or is not the index of a fixed variable. + Essential. See Object documentation whatIsAPrimitive." - instVarAt: index - "Primitive. Answer a fixed variable in an object. The numbering of the - variables corresponds to the named instance variables. Fail if the index - is not an Integer or is not the index of a fixed variable. Essential. See - Object documentation whatIsAPrimitive." + <primitive: 173 error: ec> + self primitiveFailed! - <primitive: 73> - "Access beyond fixed variables." - ^self basicAt: index - self class instSize ! Item was changed: ----- Method: Object>>instVarAt:put: (in category 'system primitives') ----- + instVarAt: index put: anObject + "Primitive. Store a value into a fixed variable in an object. The numbering of the + variables corresponds to the named instance variables, followed by the indexed + instance variables. Fail if the index is not an Integer or is not the index of a fixed + variable. Essential. See Object documentation whatIsAPrimitive." - instVarAt: anInteger put: anObject - "Primitive. Store a value into a fixed variable in the receiver. The - numbering of the variables corresponds to the named instance variables. - Fail if the index is not an Integer or is not the index of a fixed variable. - Answer the value stored as the result. Using this message violates the - principle that each object has sovereign control over the storing of - values into its instance variables. Essential. See Object documentation - whatIsAPrimitive." + <primitive: 174 error: ec> + self primitiveFailed! - <primitive: 74> - "Access beyond fixed fields" - ^self basicAt: anInteger - self class instSize put: anObject! Item was added: + ----- Method: Object>>isPinned (in category 'system primitives') ----- + isPinned + "Answer if the receiver is pinned. The VM's garbage collector routinely moves + objects as it reclaims and compacts memory. But it can also pin an object so + that it will not be moved, which can make it easier to pass objects out through + the FFI." + <primitive: 183 error: ec> + ^self primitiveFailed! Item was added: + ----- Method: Object>>pin (in category 'system primitives') ----- + pin + "The VM's garbage collector routinely moves objects as it reclaims and compacts + memory. But it can also pin an object so that it will not be moved, which can make + it easier to pass objects out through the FFI. Objects are unpinnned when created. + This method ensures an object is pinned, and answers whether it was already pinned." + ^self setPinned: true! Item was added: + ----- Method: Object>>setPinned: (in category 'system primitives') ----- + setPinned: aBoolean + "The VM's garbage collector routinely moves objects as it reclaims and compacts + memory. But it can also pin an object so that it will not be moved, which can make + it easier to pass objects out through the FFI. Objects are unpinnned when created. + This primitive either pins or unpins an object, and answers if it was already pinned." + <primitive: 184 error: ec> + ^self primitiveFailed! Item was added: + ----- Method: Object>>unpin (in category 'system primitives') ----- + unpin + "The VM's garbage collector routinely moves objects as it reclaims and compacts + memory. But it can also pin an object so that it will not be moved, which can make + it easier to pass objects out through the FFI. Objects are unpinnned when created. + This method ensures an object is unpinned, and answers whether it was pinned." + ^self setPinned: false! Item was changed: ----- Method: ProtoObject>>scaledIdentityHash (in category 'comparing') ----- scaledIdentityHash "For identityHash values returned by primitive 75, answer + such values times 2^8. Otherwise, match the existing + identityHash implementation" - such values times 2^18. Otherwise, match the existing - identityHash implementation" + ^self identityHash * 256 "bitShift: 8"! - ^self identityHash * 262144 "bitShift: 18"! Item was added: ==== ERROR === Error: Unrecognized class type 27 December 2014 1:07:07.439 am VM: unix - a SmalltalkImage Image: Squeak3.11alpha [latest update: #8824] SecurityManager state: Restricted: false FileAccess: true SocketAccess: true Working Dir /home/squeaksource Trusted Dir /home/squeaksource/secure Untrusted Dir /home/squeaksource/My Squeak MCClassDefinition(Object)>>error: Receiver: a MCClassDefinition(SmallFloat64) Arguments and temporary variables: aString: 'Unrecognized class type' Receiver's instance variables: name: #SmallFloat64 superclassName: #Float variables: an OrderedCollection() category: 'Kernel-Numbers' type: #immediate comment: 'My instances represent 64-bit Floats whose exponent fits in 8 bits as...etc... commentStamp: 'eem 11/25/2014 07:54' traitComposition: nil classTraitComposition: nil MCClassDefinition>>kindOfSubclass Receiver: a MCClassDefinition(SmallFloat64) Arguments and temporary variables: Receiver's instance variables: name: #SmallFloat64 superclassName: #Float variables: an OrderedCollection() category: 'Kernel-Numbers' type: #immediate comment: 'My instances represent 64-bit Floats whose exponent fits in 8 bits as...etc... commentStamp: 'eem 11/25/2014 07:54' traitComposition: nil classTraitComposition: nil MCClassDefinition>>printDefinitionOn: Receiver: a MCClassDefinition(SmallFloat64) Arguments and temporary variables: stream: a WriteStream Receiver's instance variables: name: #SmallFloat64 superclassName: #Float variables: an OrderedCollection() category: 'Kernel-Numbers' type: #immediate comment: 'My instances represent 64-bit Floats whose exponent fits in 8 bits as...etc... commentStamp: 'eem 11/25/2014 07:54' traitComposition: nil classTraitComposition: nil [] in MCDiffyTextWriter(MCStWriter)>>writeClassDefinition: Receiver: a MCDiffyTextWriter Arguments and temporary variables: definition: a WriteStream s: a MCClassDefinition(SmallFloat64) Receiver's instance variables: stream: a WriteStream initStream: nil --- The full stack --- MCClassDefinition(Object)>>error: MCClassDefinition>>kindOfSubclass MCClassDefinition>>printDefinitionOn: [] in MCDiffyTextWriter(MCStWriter)>>writeClassDefinition: - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - String class(SequenceableCollection class)>>new:streamContents: String class(SequenceableCollection class)>>streamContents: MCDiffyTextWriter(MCTextWriter)>>chunkContents: MCDiffyTextWriter(MCStWriter)>>writeClassDefinition: MCDiffyTextWriter(MCStWriter)>>visitClassDefinition: MCClassDefinition>>accept: [] in MCDiffyTextWriter(MCTextWriter)>>visitInFork: String class(SequenceableCollection class)>>new:streamContents: String class(SequenceableCollection class)>>streamContents: MCDiffyTextWriter(MCTextWriter)>>visitInFork: MCDiffyTextWriter>>writePatchFrom:to: MCDiffyTextWriter>>writeAddition: [] in MCDiffyTextWriter>>writePatch: SortedCollection(OrderedCollection)>>do: MCDiffyTextWriter>>writePatch: SSDiffyTextWriter>>writePatch: [] in SSDiffyTextWriter>>writeVersion:for: BlockClosure>>on:do: SSDiffyTextWriter>>writeVersion:for: [] in SSEMailSubscription>>versionAdded:to: BlockClosure>>on:do: SSEMailSubscription>>versionAdded:to: [] in [] in SSProject>>versionAdded: [] in BlockClosure>>newProcess

1 0

The Trunk: Kernel.spur-nice.892.mcz
by commits＠source.squeak.org 27 Dec '14

27 Dec '14

1 0

The Trunk: Kernel.spur-nice.892.mcz
by commits＠source.squeak.org 27 Dec '14

27 Dec '14

1 0

The Trunk: KernelTests-nice.285.mcz
by commits＠source.squeak.org 26 Dec '14

26 Dec '14

Nicolas Cellier uploaded a new version of KernelTests to project The Trunk: http://source.squeak.org/trunk/KernelTests-nice.285.mcz ==================== Summary ==================== Name: KernelTests-nice.285 Author: nice Time: 26 December 2014, 3:27:41.92 pm UUID: 49e9fec1-53df-4f38-9b76-455d6196bd5f Ancestors: KernelTests-bf.284 Test that the conversion 32bits float -> 64 bits -> 32bits will preserve the original bit pattern for any single precision float but nan(s) =============== Diff against KernelTests-bf.284 =============== Item was added: + ----- Method: FloatTest>>test32bitConversion (in category 'tests - IEEE 754') ----- + test32bitConversion + "Except for NaN, we can convert a 32bits float to a 64bits float exactly. + Thus we can convert the 64bits float to the original 32bits float pattern." + + #(16r0 "zero" + 16r80000000 "negative zero" + 16r1 "min unormalized" + 16r12345 "a unnormalized" + 16r801FEDCB "a negative unnormalized" + 16r7FFFFF "largest unnormalized" + 16r800000 "smallest normalized" + 16r468ACDEF "a normalized float" + 16rCABD1234 "a negative normalized float" + 16r7F7FFFFF "largest finite float" + 16r7F800000 "positive infinity" + 16rFF800000 "negative infinity" + ) + do: [:originalWord | self assert: (Float fromIEEE32Bit: originalWord) asIEEE32BitWord = originalWord]!

1 0

The Trunk: KernelTests-nice.285.mcz
by commits＠source.squeak.org 26 Dec '14

26 Dec '14

1 0

The Trunk: KernelTests-nice.285.mcz
by commits＠source.squeak.org 26 Dec '14

26 Dec '14

1 0

The Trunk: Kernel-nice.892.mcz
by commits＠source.squeak.org 23 Dec '14

23 Dec '14

Nicolas Cellier uploaded a new version of Kernel to project The Trunk: http://source.squeak.org/trunk/Kernel-nice.892.mcz ==================== Summary ==================== Name: Kernel-nice.892 Author: nice Time: 23 December 2014, 11:50:48.613 pm UUID: 85017561-ba41-4e1f-9c6b-37f97730b5ea Ancestors: Kernel-eem.891 Fix Float class>>fromIEEE32Bit: in the case of gradual underflow again... Details: A single precision (32bits) float gradual underflow is of the form biased exponent = 0 (-127 unbiased, but true value to take into account is -126) significand of the form 0.bbb....b (23 bit after the floating point, no implied 1) Once converted to double precision, this will not underflow... So we must shift the significand left until the highest bit pass left of the floating point : for example 0.001b...b ==> 1.b...b000 adjust the exponent (which is -126) by same number of shift (-129 in this example since there are 3 shifts) then remove the leading bit left of floating point - it is already taken into account as the implied 1 now that we do not underflow. =============== Diff against Kernel-eem.891 =============== Item was changed: ----- Method: Float class>>fromIEEE32Bit: (in category 'instance creation') ----- fromIEEE32Bit: word "Convert the given 32 bit word (which is supposed to be a positive 32bit value) from a 32bit IEEE floating point representation into an actual Squeak float object (being 64bit wide). Should only be used for conversion in FloatArrays or likewise objects." | sign mantissa exponent newFloat delta | word negative ifTrue: [^ self error:'Cannot deal with negative numbers']. word = 0 ifTrue: [^ Float zero]. sign := word bitAnd: 16r80000000. word = sign ifTrue: [^self negativeZero]. exponent := ((word bitShift: -23) bitAnd: 16rFF) - 127. mantissa := word bitAnd: 16r7FFFFF. exponent = 128 ifTrue:["Either NAN or INF" mantissa = 0 ifFalse:[^ Float nan]. sign = 0 ifTrue:[^ Float infinity] ifFalse:[^ Float negativeInfinity]]. exponent = -127 ifTrue: [ "gradual underflow (denormalized number) Remove first bit of mantissa and adjust exponent" delta := mantissa highBit. + mantissa := (mantissa bitAnd: (1 bitShift: delta - 1) - 1) bitShift: 24 - delta. - mantissa := (mantissa bitShift: 1) bitAnd: (1 bitShift: delta) - 1. exponent := exponent + delta - 23]. "Create new float" newFloat := self new: 2. newFloat basicAt: 1 put: ((sign bitOr: (1023 + exponent bitShift: 20)) bitOr: (mantissa bitShift: -3)). newFloat basicAt: 2 put: ((mantissa bitAnd: 7) bitShift: 29). ^newFloat!

1 0

The Trunk: Kernel-nice.892.mcz
by commits＠source.squeak.org 23 Dec '14

23 Dec '14

1 0

The Trunk: Kernel-nice.892.mcz
by commits＠source.squeak.org 23 Dec '14

23 Dec '14

1 0

The Trunk: Tools-ul.532.mcz
by commits＠source.squeak.org 19 Dec '14

19 Dec '14

Levente Uzonyi uploaded a new version of Tools to project The Trunk: http://source.squeak.org/trunk/Tools-ul.532.mcz ==================== Summary ==================== Name: Tools-ul.532 Author: ul Time: 19 December 2014, 7:39:38.064 pm UUID: dc84de0d-f5b1-4c59-a777-c6c723b6146c Ancestors: Tools-bf.531 Use a separate Random instance instead of RandomForPicking in MethodFinder>>testRandom. The method seems to have other issues too. =============== Diff against Tools-bf.531 =============== Item was changed: ----- Method: MethodFinder>>testRandom (in category 'initialize') ----- testRandom "verify that the methods allowed don't crash the system. Pick 3 or 4 from a mixed list of the fundamental types." + | objects other aa cnt take tuple fName sss random | - | objects other aa cnt take tuple fName sss | objects := #( (1 4 17 42) ($a $b $c $d) ('one' 'two' 'three' 'four') (x + rect: new) ((a b 1 4) (c 1 5) ($a 3 d) ()) (4.5 0.0 3.2 100.3) ). objects := objects, {{true. false. true. false}. {Point. SmallInteger. Association. Array}. {Point class. SmallInteger class. Association class. Array class}. "{ 4 blocks }." {Date today. '1 Jan 1950' asDate. '25 Aug 1987' asDate. '1 Jan 2000' asDate}. {'15:16' asTime. '1:56' asTime. '4:01' asTime. '6:23' asTime}. {Dictionary new. Dictionary new. Dictionary new. Dictionary new}. {#(a b 1 4) asOrderedCollection. #(c 1 5) asOrderedCollection. #($a 3 d) asOrderedCollection. #() asOrderedCollection}. {3 -> true. 5.6 -> $a. #x -> 2. 'abcd' -> false}. {9 @ 3 extent: 5 @ 4. 0 @ 0 extent: 45 @ 9. -3 @ -7 extent: 2 @ 2. 4 @ 4 extent: 16 @ 16}. {Color red. Color blue. Color black. Color gray}}. self test2: objects. "rec+0, rec+1, rec+2, rec+3 need to be tested. " fName := (FileDirectory default fileNamesMatching: '*.ran') first. sss := fName splitInteger first. + random := Random seed: sss. - (Collection classPool at: #RandomForPicking) seed: sss. cnt := 0. + [take := #(3 4) atRandom: random. + tuple := (1 to: take) collect: [:ind | (objects atRandom: random) atRandom: random]. + other := (1 to: take) collect: [:ind | (objects atRandom: random) atRandom: random]. - [take := #(3 4) atRandom. - tuple := (1 to: take) collect: [:ind | (objects atRandom) atRandom]. - other := (1 to: take) collect: [:ind | (objects atRandom) atRandom]. self load: (aa := Array with: tuple with: 1 with: other with: 7). ((cnt := cnt + 1) \\ 10 = 0) " | (cnt > Skip)" ifTrue: [Transcript cr; show: cnt printString; tab; tab; show: aa first printString]. cnt > (Smalltalk at: #StopHere) ifTrue: [self halt]. "stop just before crash" cnt > (Smalltalk at: #Skip) ifTrue: ["skip this many at start" self search: true. self test2: aa first. self test2: (aa at: 3). "self test2: objects"]] repeat. !

1 0

Jump to page:

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

Packages December 2014