[squeak-dev] The Inbox: Kernel-eem.1486.mczcommits at source.squeak.org commits at source.squeak.orgThu Jul 14 14:15:01 UTC 2022
A new version of Kernel was added to project The Inbox: http://source.squeak.org/inbox/Kernel-eem.1486.mcz ==================== Summary ==================== Name: Kernel-eem.1486 Author: eem Time: 5 July 2022, 4:08:05.255241 pm UUID: a9406e26-5f92-40fe-a876-a151252043e1 Ancestors: Kernel-eem.1485 Slightly faster implementations of CompiledMethod>>reads/writesField:. SImilarly neater CompiledCode>>sendsToSuper. Corrected CompiledCode>>hasMethodReturn; needs Compiler-eem.479 =============== Diff against Kernel-eem.1485 =============== Item was removed: - (PackageInfo named: 'Kernel') preamble: '"below, add code to be run before the loading of this package" - ProcessorScheduler instVarNames at: 2 put: ''genuineProcess''.'! Item was removed: - SystemOrganization addCategory: #'Kernel-Classes'! - SystemOrganization addCategory: #'Kernel-Exceptions'! - SystemOrganization addCategory: #'Kernel-Exceptions-Kernel'! - SystemOrganization addCategory: #'Kernel-Methods'! - SystemOrganization addCategory: #'Kernel-Models'! - SystemOrganization addCategory: #'Kernel-Numbers'! - SystemOrganization addCategory: #'Kernel-Numbers-Exceptions'! - SystemOrganization addCategory: #'Kernel-Objects'! - SystemOrganization addCategory: #'Kernel-Pools'! - SystemOrganization addCategory: #'Kernel-Processes'! - SystemOrganization addCategory: #'Kernel-Processes-Variables'! Item was removed: - Object variableSubclass: #AdditionalMethodState - instanceVariableNames: 'method selector' - classVariableNames: '' - poolDictionaries: '' - category: 'Kernel-Methods'! - - !AdditionalMethodState commentStamp: '<historical>' prior: 0! - I am class holding state for compiled methods. All my instance variables should be actually part of the CompiledMethod itself, but the current implementation of the VM doesn't allow this. Currently I hold the selector and any pragmas or properties the compiled method has. Pragmas and properties are stored in indexable fields; pragmas as instances of Pragma, properties as instances of Association. - - I am a reimplementation of much of MethodProperties, but eliminating the explicit properties and pragmas dictionaries. Hence I answer true to isMethodProperties.! Item was removed: - ----- Method: AdditionalMethodState class>>forMethod:selector: (in category 'instance creation') ----- - forMethod: aMethod selector: aSelector - ^(self new: 0) - selector: aSelector; - setMethod: aMethod; - yourself! Item was removed: - ----- Method: AdditionalMethodState class>>new (in category 'instance creation') ----- - new - ^self new: 0! Item was removed: - ----- Method: AdditionalMethodState class>>selector:with: (in category 'instance creation') ----- - selector: aSelector with: aPropertyOrPragma - ^(self new: 1) - selector: aSelector; - basicAt: 1 put: aPropertyOrPragma; - yourself! Item was removed: - ----- Method: AdditionalMethodState>>allLiteralsDo: (in category 'literals') ----- - allLiteralsDo: aBlock - - 1 to: self basicSize do: [:index | - (self basicAt: index) allLiteralsDo: aBlock].! Item was removed: - ----- Method: AdditionalMethodState>>analogousCodeTo: (in category 'testing') ----- - analogousCodeTo: aMethodProperties - | bs | - self class == aMethodProperties class ifFalse: - [^false]. - (bs := self basicSize) = aMethodProperties basicSize ifFalse: - [^false]. - 1 to: bs do: - [:i| - ((self basicAt: i) analogousCodeTo: (aMethodProperties basicAt: i)) ifFalse: - [^false]]. - ^true! Item was removed: - ----- Method: AdditionalMethodState>>at: (in category 'accessing') ----- - at: aKey - "Answer the property value or pragma associated with aKey." - - ^self at: aKey ifAbsent: [self error: 'not found']! Item was removed: - ----- Method: AdditionalMethodState>>at:ifAbsent: (in category 'accessing') ----- - at: aKey ifAbsent: aBlock - "Answer the property value or pragma associated with aKey or, - if aKey isn't found, answer the result of evaluating aBlock." - - 1 to: self basicSize do: - [:i | - | propertyOrPragma "<Association|Pragma>" | - (propertyOrPragma := self basicAt: i) key == aKey ifTrue: - [^propertyOrPragma isVariableBinding - ifTrue: [propertyOrPragma value] - ifFalse: [propertyOrPragma]]]. - ^aBlock value! Item was removed: - ----- Method: AdditionalMethodState>>at:ifAbsentPut: (in category 'accessing') ----- - at: aKey ifAbsentPut: aBlock - "Answer the property value or pragma associated with aKey or, - if aKey isn't found, answer the result of evaluating aBlock." - - 1 to: self basicSize do: - [:i | - | propertyOrPragma "<Association|Pragma>" | - (propertyOrPragma := self basicAt: i) key == aKey ifTrue: - [^propertyOrPragma isVariableBinding - ifTrue: [propertyOrPragma value] - ifFalse: [propertyOrPragma]]]. - ^method propertyValueAt: aKey put: aBlock value! Item was removed: - ----- Method: AdditionalMethodState>>at:put: (in category 'accessing') ----- - at: aKey put: aValue - "Replace the property value or pragma associated with aKey." - | keyAlreadyExists | - keyAlreadyExists := false. - - 1 to: self basicSize do: - [:i | - | propertyOrPragma "<Association|Pragma>" | - (propertyOrPragma := self basicAt: i) key == aKey ifTrue: [ - keyAlreadyExists := true. - propertyOrPragma isVariableBinding - ifTrue: [propertyOrPragma value: aValue] - ifFalse: [self basicAt: i put: aValue]]]. - - keyAlreadyExists ifFalse: [ - method propertyValueAt: aKey put: aValue ]. - - ^ aValue! Item was removed: - ----- Method: AdditionalMethodState>>copyWith: (in category 'copying') ----- - copyWith: aPropertyOrPragma "<Association|Pragma>" - "Answer a copy of the receiver which includes aPropertyOrPragma" - | bs copy | - (Association == aPropertyOrPragma class - or: [Pragma == aPropertyOrPragma class]) ifFalse: - [self error: self class name, ' instances should hold only Associations or Pragmas.']. - "no need to initialize here; we're copying all inst vars" - copy := self class basicNew: (bs := self basicSize) + 1. - 1 to: bs do: - [:i| - copy basicAt: i put: (self basicAt: i) shallowCopy]. - copy basicAt: bs + 1 put: aPropertyOrPragma. - 1 to: self class instSize do: - [:i| copy instVarAt: i put: (self instVarAt: i)]. - ^copy! Item was removed: - ----- Method: AdditionalMethodState>>copyWithout: (in category 'copying') ----- - copyWithout: aPropertyOrPragma "<Association|Pragma>" - "Answer a copy of the receiver which no longer includes aPropertyOrPragma" - | bs copy offset | - "no need to initialize here; we're copying all inst vars" - copy := self class basicNew: (bs := self basicSize) - ((self includes: aPropertyOrPragma) - ifTrue: [1] - ifFalse: [0]). - offset := 0. - 1 to: bs do: - [:i| - (self basicAt: i) = aPropertyOrPragma - ifTrue: [offset := 1] - ifFalse: [copy basicAt: i - offset put: (self basicAt: i) shallowCopy]]. - 1 to: self class instSize do: - [:i| copy instVarAt: i put: (self instVarAt: i)]. - ^copy! Item was removed: - ----- Method: AdditionalMethodState>>hasAtLeastTheSamePropertiesAs: (in category 'testing') ----- - hasAtLeastTheSamePropertiesAs: aMethodProperties - "Answer if the recever has at least the same properties as the argument. - N.B. The receiver may have additional properties and still answer true." - aMethodProperties keysAndValuesDo: - [:k :v| - (v isKindOf: Pragma) - "ifTrue: [Pragmas have already been checked]" - ifFalse: [ - (self includes: k->v) ifFalse: [^false]]]. - ^true! Item was removed: - ----- Method: AdditionalMethodState>>includes: (in category 'testing') ----- - includes: aPropertyOrPragma "<Association|Pragma>" - "Test if the property or pragma is present." - - 1 to: self basicSize do: - [:i | - (self basicAt: i) = aPropertyOrPragma ifTrue: - [^true]]. - ^false! Item was removed: - ----- Method: AdditionalMethodState>>includesKey: (in category 'testing') ----- - includesKey: aKey - "Test if the property aKey or pragma with selector aKey is present." - - 1 to: self basicSize do: - [:i | - (self basicAt: i) key == aKey ifTrue: - [^true]]. - ^false! Item was removed: - ----- Method: AdditionalMethodState>>includesProperty: (in category 'properties') ----- - includesProperty: aKey - "Test if the property aKey is present." - - 1 to: self basicSize do: [:i | - | propertyOrPragma "<Association|Pragma>" | - propertyOrPragma := self basicAt: i. - (propertyOrPragma isVariableBinding - and: [propertyOrPragma key == aKey]) ifTrue: - [^true]]. - ^false! Item was removed: - ----- Method: AdditionalMethodState>>isEmpty (in category 'testing') ----- - isEmpty - ^self basicSize = 0! Item was removed: - ----- Method: AdditionalMethodState>>isMethodProperties (in category 'testing') ----- - isMethodProperties - ^true! Item was removed: - ----- Method: AdditionalMethodState>>keysAndValuesDo: (in category 'accessing') ----- - keysAndValuesDo: aBlock - "Enumerate the receiver with all the keys and values." - - 1 to: self basicSize do: [:i | - | propertyOrPragma "<Association|Pragma>" | - (propertyOrPragma := self basicAt: i) isVariableBinding - ifTrue: [aBlock value: propertyOrPragma key value: propertyOrPragma value] - ifFalse: [aBlock value: propertyOrPragma keyword value: propertyOrPragma]]! Item was removed: - ----- Method: AdditionalMethodState>>method (in category 'accessing') ----- - method - ^method! Item was removed: - ----- Method: AdditionalMethodState>>method: (in category 'decompiling') ----- - method: aMethodNodeOrNil - "For decompilation" - method := aMethodNodeOrNil! Item was removed: - ----- Method: AdditionalMethodState>>methodHome (in category 'accessing') ----- - methodHome - "The behavior (trait/class) this method was originally defined in. - The methodClass in AdditionalMethodState but subclasses - (TraitMethodState) may know differently" - ^method methodClass! Item was removed: - ----- Method: AdditionalMethodState>>notEmpty (in category 'testing') ----- - notEmpty - ^self basicSize > 0! Item was removed: - ----- Method: AdditionalMethodState>>postCopy (in category 'copying') ----- - postCopy - "After copying we must duplicate any associations and pragmas so they don't end up being shared." - 1 to: self basicSize do: - [:i| self basicAt: i put: (self basicAt: i) shallowCopy]! Item was removed: - ----- Method: AdditionalMethodState>>pragmas (in category 'accessing') ----- - pragmas - "Answer the raw messages comprising my pragmas." - | pragmaStream | - pragmaStream := WriteStream on: (Array new: self basicSize). - 1 to: self basicSize do: [:i | - | propertyOrPragma "<Association|Message>" | - (propertyOrPragma := self basicAt: i) isVariableBinding ifFalse: - [pragmaStream nextPut: propertyOrPragma]]. - ^pragmaStream contents! Item was removed: - ----- Method: AdditionalMethodState>>printOn: (in category 'printing') ----- - printOn: aStream - super printOn: aStream. - aStream space; nextPut: $(; print: self identityHash; nextPut: $)! Item was removed: - ----- Method: AdditionalMethodState>>properties (in category 'accessing') ----- - properties - - | propertyStream | - propertyStream := WriteStream on: (Array new: self basicSize * 2). - 1 to: self basicSize do: [:i | - | propertyOrPragma "<Association|Pragma>" | - (propertyOrPragma := self basicAt: i) isVariableBinding ifTrue: - [propertyStream nextPut: propertyOrPragma key; nextPut: propertyOrPragma value]]. - ^IdentityDictionary newFromPairs: propertyStream contents! Item was removed: - ----- Method: AdditionalMethodState>>propertyKeysAndValuesDo: (in category 'properties') ----- - propertyKeysAndValuesDo: aBlock - "Enumerate the receiver with all the keys and values." - - 1 to: self basicSize do: [:i | - | propertyOrPragma "<Association|Pragma>" | - (propertyOrPragma := self basicAt: i) isVariableBinding ifTrue: - [aBlock value: propertyOrPragma key value: propertyOrPragma value]]! Item was removed: - ----- Method: AdditionalMethodState>>propertyValueAt: (in category 'properties') ----- - propertyValueAt: aKey - "Answer the property value associated with aKey." - - ^ self propertyValueAt: aKey ifAbsent: [ self error: 'Property not found' ].! Item was removed: - ----- Method: AdditionalMethodState>>propertyValueAt:ifAbsent: (in category 'properties') ----- - propertyValueAt: aKey ifAbsent: aBlock - "Answer the property value associated with aKey or, if aKey isn't found, answer the result of evaluating aBlock." - - 1 to: self basicSize do: [:i | - | propertyOrPragma "<Association|Pragma>" | - propertyOrPragma := self basicAt: i. - (propertyOrPragma isVariableBinding - and: [propertyOrPragma key == aKey]) ifTrue: - [^propertyOrPragma value]]. - ^aBlock value! Item was removed: - ----- Method: AdditionalMethodState>>removeKey: (in category 'properties') ----- - removeKey: aKey - "Remove the property with aKey. Answer the property or raise an error if aKey isn't found." - - ^ self removeKey: aKey ifAbsent: [ self error: 'Property not found' ].! Item was removed: - ----- Method: AdditionalMethodState>>removeKey:ifAbsent: (in category 'accessing') ----- - removeKey: aKey ifAbsent: aBlock - "Remove the property with aKey. Answer the value or, if aKey isn't found, answer the result of evaluating aBlock." - - 1 to: self basicSize do: [:i | - | propertyOrPragma "<Association|Pragma>" | - propertyOrPragma := self basicAt: i. - (propertyOrPragma isVariableBinding - ifTrue: [propertyOrPragma key] - ifFalse: [propertyOrPragma keyword]) - == aKey ifTrue: - [^method removeProperty: aKey]]. - ^aBlock value! Item was removed: - ----- Method: AdditionalMethodState>>selector (in category 'accessing') ----- - selector - ^selector! Item was removed: - ----- Method: AdditionalMethodState>>selector: (in category 'accessing') ----- - selector: aSymbol - selector := aSymbol! Item was removed: - ----- Method: AdditionalMethodState>>setMethod: (in category 'accessing') ----- - setMethod: aMethod - method := aMethod. - 1 to: self basicSize do: - [:i| | propertyOrPragma "<Association|Pragma>" | - (propertyOrPragma := self basicAt: i) isVariableBinding ifFalse: - [propertyOrPragma setMethod: aMethod]]! Item was removed: - Error subclass: #ArithmeticError - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Kernel-Numbers-Exceptions'! Item was removed: - Error subclass: #AssertionFailure - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Kernel-Exceptions'! - - !AssertionFailure commentStamp: 'gh 5/2/2002 20:29' prior: 0! - AsssertionFailure is the exception signaled from Object>>assert: when the assertion block evaluates to false.! Item was removed: - ----- Method: AssertionFailure>>isResumable (in category 'priv handling') ----- - isResumable - ^ true! Item was removed: - Error subclass: #AttemptToWriteReadOnlyGlobal - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Kernel-Exceptions'! - - !AttemptToWriteReadOnlyGlobal commentStamp: 'gh 5/2/2002 20:26' prior: 0! - This is a resumable error you get if you try to assign a readonly variable a value. - Name definitions in the module system can be read only and are then created using instances of ReadOnlyVariableBinding instead of Association. - See also LookupKey>>beReadWriteBinding and LookupKey>>beReadOnlyBinding. - - ! Item was removed: - ----- Method: AttemptToWriteReadOnlyGlobal>>description (in category 'as yet unclassified') ----- - description - "Return a textual description of the exception." - - | desc mt | - desc := 'Error'. - ^(mt := self messageText) == nil - ifTrue: [desc] - ifFalse: [desc, ': ', mt]! Item was removed: - ----- Method: AttemptToWriteReadOnlyGlobal>>isResumable (in category 'as yet unclassified') ----- - isResumable - ^true! Item was removed: - Categorizer subclass: #BasicClassOrganizer - instanceVariableNames: 'subject classComment commentStamp' - classVariableNames: '' - poolDictionaries: '' - category: 'Kernel-Classes'! Item was removed: - ----- Method: BasicClassOrganizer class>>ambiguous (in category 'constants') ----- - ambiguous - ^ #ambiguous! Item was removed: - ----- Method: BasicClassOrganizer class>>class: (in category 'instance creation') ----- - class: aClassDescription - ^ self new setSubject: aClassDescription! Item was removed: - ----- Method: BasicClassOrganizer class>>class:defaultList: (in category 'instance creation') ----- - class: aClassDescription defaultList: aSortedCollection - | inst | - inst := self defaultList: aSortedCollection. - inst setSubject: aClassDescription. - ^ inst! Item was removed: - ----- Method: BasicClassOrganizer>>classComment (in category 'accessing') ----- - classComment - classComment - ifNil: [^ '']. - ^ classComment text ifNil: ['']! Item was removed: - ----- Method: BasicClassOrganizer>>classComment: (in category 'accessing') ----- - classComment: aString - "Store the comment, aString, associated with the object that refers to the - receiver." - - (aString isKindOf: RemoteString) - ifTrue: [classComment := aString] - ifFalse: [(aString == nil or: [aString size = 0]) - ifTrue: [classComment := nil] - ifFalse: [ - self error: 'use aClass classComment:'. - classComment := RemoteString newString: aString onFileNumber: 2]] - "Later add priorSource and date and initials?"! Item was removed: - ----- Method: BasicClassOrganizer>>classComment:stamp: (in category 'accessing') ----- - classComment: aString stamp: aStamp - "Store the comment, aString, associated with the object that refers to the receiver." - - self commentStamp: aStamp. - (aString isKindOf: RemoteString) - ifTrue: [classComment := aString] - ifFalse: [(aString == nil or: [aString size = 0]) - ifTrue: [classComment := nil] - ifFalse: - [self error: 'use aClass classComment:'. - classComment := RemoteString newString: aString onFileNumber: 2]] - "Later add priorSource and date and initials?"! Item was removed: - ----- Method: BasicClassOrganizer>>commentRemoteStr (in category 'accessing') ----- - commentRemoteStr - ^ classComment! Item was removed: - ----- Method: BasicClassOrganizer>>commentStamp (in category 'accessing') ----- - commentStamp - "Answer the comment stamp for the class" - - ^ commentStamp! Item was removed: - ----- Method: BasicClassOrganizer>>commentStamp: (in category 'accessing') ----- - commentStamp: aStamp - commentStamp := aStamp! Item was removed: - ----- Method: BasicClassOrganizer>>dateCommentLastSubmitted (in category 'accessing') ----- - dateCommentLastSubmitted - "Answer a Date object indicating when my class comment was last submitted. If there is no date stamp, or one of the old-time <historical> guys, return nil" - "RecentMessageSet organization dateCommentLastSubmitted" - - | aStamp tokens | - (aStamp := self commentStamp) isEmptyOrNil ifTrue: [^ nil]. - tokens := aStamp findBetweenSubStrs: ' - '. "space is expected delimiter, but cr is sometimes seen, though of mysterious provenance" - ^ tokens size > 1 - ifTrue: - [[tokens second asDate] ifError: [nil]] - ifFalse: - [nil]! Item was removed: - ----- Method: BasicClassOrganizer>>fileOutCommentOn:moveSource:toFile: (in category 'fileIn/Out') ----- - fileOutCommentOn: aFileStream moveSource: moveSource toFile: fileIndex - "Copy the class comment to aFileStream. If moveSource is true (as in compressChanges or compressSources, then update classComment to point to the new file." - | fileComment | - classComment ifNotNil: - [aFileStream cr. - fileComment := RemoteString newString: classComment text - onFileNumber: fileIndex toFile: aFileStream. - moveSource ifTrue: [classComment := fileComment]]! Item was removed: - ----- Method: BasicClassOrganizer>>hasNoComment (in category 'testing') ----- - hasNoComment - "Answer whether the class classified by the receiver has a comment." - - ^classComment == nil! Item was removed: - ----- Method: BasicClassOrganizer>>hasSubject (in category 'testing') ----- - hasSubject - ^ self subject notNil! Item was removed: - ----- Method: BasicClassOrganizer>>moveChangedCommentToFile:numbered: (in category 'fileIn/Out') ----- - moveChangedCommentToFile: aFileStream numbered: fileIndex - "If the comment is in the changes file, then move it to a new file." - - (classComment ~~ nil and: [classComment sourceFileNumber > 1]) ifTrue: - [self fileOutCommentOn: aFileStream moveSource: true toFile: fileIndex]! Item was removed: - ----- Method: BasicClassOrganizer>>objectForDataStream: (in category 'fileIn/Out') ----- - objectForDataStream: refStrm - | dp | - "I am about to be written on an object file. Write a path to me in the other system instead." - - self hasSubject ifTrue: [ - (refStrm insideASegment and: [self subject isSystemDefined not]) ifTrue: [ - ^ self]. "do trace me" - (self subject isKindOf: Class) ifTrue: [ - dp := DiskProxy global: self subject name selector: #organization args: #(). - refStrm replace: self with: dp. - ^ dp]]. - ^ self "in desparation" - ! Item was removed: - ----- Method: BasicClassOrganizer>>putCommentOnFile:numbered:moveSource:forClass: (in category 'fileIn/Out') ----- - putCommentOnFile: aFileStream numbered: sourceIndex moveSource: moveSource forClass: aClass - "Store the comment about the class onto file, aFileStream." - | header | - classComment ifNotNil: - [aFileStream cr; nextPut: $!!. - header := String streamContents: [:strm | - strm nextPutAll: aClass name; - nextPutAll: ' commentStamp: '. - commentStamp ifNil: [commentStamp := '<historical>']. - commentStamp storeOn: strm. - strm nextPutAll: ' prior: '; nextPutAll: '0']. - aFileStream nextChunkPut: header. - aClass organization fileOutCommentOn: aFileStream - moveSource: moveSource toFile: sourceIndex. - aFileStream cr]! Item was removed: - ----- Method: BasicClassOrganizer>>setSubject: (in category 'private') ----- - setSubject: aClassDescription - subject := aClassDescription! Item was removed: - ----- Method: BasicClassOrganizer>>subject (in category 'accessing') ----- - subject - ^ subject.! Item was removed: - Object subclass: #Behavior - instanceVariableNames: 'superclass methodDict format' - classVariableNames: 'ObsoleteSubclasses' - poolDictionaries: '' - category: 'Kernel-Classes'! - - !Behavior commentStamp: 'al 12/8/2005 20:44' prior: 0! - My instances describe the behavior of other objects. I provide the minimum state necessary for compiling methods, and creating and running instances. Most objects are created as instances of the more fully supported subclass, Class, but I am a good starting point for providing instance-specific behavior (as in Metaclass).! Item was removed: - ----- Method: Behavior class>>canZapMethodDictionary (in category 'testing') ----- - canZapMethodDictionary - "Return false since zapping the method dictionary of Behavior class or its subclasses will cause the system to fail." - ^false! Item was removed: - ----- Method: Behavior class>>cleanUp (in category 'class initialization') ----- - cleanUp - "Flush the obsolete subclasses." - - self flushObsoleteSubclasses! Item was removed: - ----- Method: Behavior class>>flushObsoleteSubclasses (in category 'class initialization') ----- - flushObsoleteSubclasses - "Behavior flushObsoleteSubclasses" - ObsoleteSubclasses finalizeValues.! Item was removed: - ----- Method: Behavior class>>initialize (in category 'class initialization') ----- - initialize - "Behavior initialize" - "Never called for real" - ObsoleteSubclasses - ifNil: [self initializeObsoleteSubclasses] - ifNotNil: [| newDict | - newDict := WeakKeyToCollectionDictionary newFrom: ObsoleteSubclasses. - newDict rehash. - ObsoleteSubclasses := newDict]! Item was removed: - ----- Method: Behavior class>>initializeObsoleteSubclasses (in category 'class initialization') ----- - initializeObsoleteSubclasses - ObsoleteSubclasses := WeakKeyToCollectionDictionary new.! Item was removed: - ----- Method: Behavior>>>> (in category 'accessing method dictionary') ----- - >> selector - "Answer the compiled method associated with the argument, selector (a - Symbol), a message selector in the receiver's method dictionary. If the - selector is not in the dictionary, create an error notification." - - ^self compiledMethodAt: selector - ! Item was removed: - ----- Method: Behavior>>addObsoleteSubclass: (in category 'obsolete subclasses') ----- - addObsoleteSubclass: aClass - "Weakly remember that aClass was a subclass of the receiver and is now obsolete" - | obs | - - obs := ObsoleteSubclasses at: self ifAbsent:[WeakArray new]. - (obs includes: aClass) ifTrue:[^self]. - obs := obs copyWithout: nil. - obs := obs copyWith: aClass. - ObsoleteSubclasses at: self put: obs. - ! Item was removed: - ----- Method: Behavior>>addSelector:withMethod: (in category 'adding/removing methods') ----- - addSelector: selector withMethod: compiledMethod - ^ self addSelector: selector withMethod: compiledMethod notifying: nil! Item was removed: - ----- Method: Behavior>>addSelector:withMethod:notifying: (in category 'adding/removing methods') ----- - addSelector: selector withMethod: compiledMethod notifying: requestor - ^ self basicAddSelector: selector withMethod: compiledMethod! Item was removed: - ----- Method: Behavior>>addSelectorSilently:withMethod: (in category 'adding/removing methods') ----- - addSelectorSilently: selector withMethod: compiledMethod - self basicAddSelector: selector withMethod: compiledMethod.! Item was removed: - ----- Method: Behavior>>adoptInstance: (in category 'instance creation') ----- - adoptInstance: anObject - "Change the class of anObject to me. - Primitive (found in Cog and new VMs) follows the same rules as primitiveChangeClassTo:, but returns the class rather than the modified instance" - - <primitive: 160 error: ec> - ec == #'no modification' ifTrue: - [^self modificationForbiddenAdopting: anObject]. - self primitiveFailed! Item was removed: - ----- Method: Behavior>>allClassVarNames (in category 'accessing instances and variables') ----- - allClassVarNames - "Answer a Set of the names of the receiver's and the receiver's ancestor's - class variables." - - ^superclass allClassVarNames! Item was removed: - ----- Method: Behavior>>allInstVarNames (in category 'accessing instances and variables') ----- - allInstVarNames - "Answer an Array of the names of the receiver's instance variables. The - Array ordering is the order in which the variables are stored and - accessed by the interpreter." - - | vars | - superclass == nil - ifTrue: [vars := self instVarNames copy] "Guarantee a copy is answered." - ifFalse: [vars := superclass allInstVarNames , self instVarNames]. - ^vars! Item was removed: - ----- 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! Item was removed: - ----- 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." - inst := self someInstance. - [inst == nil] whileFalse: - [next := inst nextInstance. - aBlock value: inst. - inst := next]! Item was removed: - ----- 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 removed: - ----- Method: Behavior>>allSelectors (in category 'accessing method dictionary') ----- - allSelectors - "Answer all selectors understood by instances of the receiver" - - ^(Array streamContents: [ :stream | - self withAllSuperclassesDo: [ :aClass | - aClass selectorsDo: [ :each | - stream nextPut: each ] ] ]) asIdentitySet! Item was removed: - ----- Method: Behavior>>allSelectorsBelow: (in category 'accessing method dictionary') ----- - allSelectorsBelow: topClass - | coll | - coll := IdentitySet new. - self withAllSuperclassesDo: - [:aClass | - aClass = topClass - ifTrue: [^ coll ] - ifFalse: [aClass selectorsDo: [ :sel | coll add: sel ]]]. - ^ coll - - - ! Item was removed: - ----- Method: Behavior>>allSharedPools (in category 'accessing instances and variables') ----- - allSharedPools - "Answer a Set of the names of the pools (Dictionaries or SharedPool subclasses) that the receiver and the receiver's ancestors share." - - ^superclass allSharedPools! Item was removed: - ----- Method: Behavior>>allSubInstances (in category 'accessing instances and variables') ----- - allSubInstances - "Answer a list of all current instances of the receiver and all of its subclasses." - | aCollection | - aCollection := OrderedCollection new. - self allSubInstancesDo: - [:x | x == aCollection ifFalse: [aCollection add: x]]. - ^ aCollection! Item was removed: - ----- Method: Behavior>>allSubInstancesDo: (in category 'enumerating') ----- - allSubInstancesDo: aBlock - "Evaluate the argument, aBlock, for each of the current instances of the - receiver and all its subclasses." - - self allInstancesDo: aBlock. - self allSubclassesDo: [:sub | sub allInstancesDo: aBlock]! Item was removed: - ----- Method: Behavior>>allSubclasses (in category 'accessing class hierarchy') ----- - allSubclasses - "Answer a Collection of the receiver's and the receiver's descendent's subclasses. " - - | scan scanTop | - scan := OrderedCollection withAll: self subclasses. - scanTop := 1. - [scanTop > scan size] - whileFalse: [scan addAll: (scan at: scanTop) subclasses. - scanTop := scanTop + 1]. - ^ scan! Item was removed: - ----- Method: Behavior>>allSubclassesDo: (in category 'enumerating') ----- - allSubclassesDo: aBlock - "Evaluate the argument, aBlock, for each of the receiver's subclasses." - - self subclassesDo: - [:cl | - aBlock value: cl. - cl allSubclassesDo: aBlock]! Item was removed: - ----- Method: Behavior>>allSubclassesDoGently: (in category 'enumerating') ----- - allSubclassesDoGently: aBlock - "Evaluate the argument, aBlock, for each of the receiver's subclasses." - - self subclassesDoGently: - [:cl | - cl isInMemory ifTrue: [ - aBlock value: cl. - cl allSubclassesDoGently: aBlock]]! Item was removed: - ----- Method: Behavior>>allSubclassesWithLevelDo:startingLevel: (in category 'accessing class hierarchy') ----- - allSubclassesWithLevelDo: classAndLevelBlock startingLevel: level - "Walk the tree of subclasses, giving the class and its level" - - classAndLevelBlock value: self value: level. - self == Class ifTrue: [^ self]. "Don't visit all the metaclasses" - "Visit subclasses in alphabetical order" - self subclasses - sort: [ :a :b | a name <= b name ]; - do: [ :subclass | - subclass - allSubclassesWithLevelDo: classAndLevelBlock - startingLevel: level + 1 ]! Item was removed: - ----- Method: Behavior>>allSuperclasses (in category 'accessing class hierarchy') ----- - allSuperclasses - "Answer an OrderedCollection of the receiver's and the receiver's - ancestor's superclasses. The first element is the receiver's immediate - superclass, followed by its superclass; the last element is Object." - | temp | - ^ superclass == nil - ifTrue: [ OrderedCollection new] - ifFalse: [temp := superclass allSuperclasses. - temp addFirst: superclass. - temp]! Item was removed: - ----- Method: Behavior>>allSuperclassesDo: (in category 'enumerating') ----- - allSuperclassesDo: aBlock - "Evaluate the argument, aBlock, for each of the receiver's superclasses." - - superclass == nil - ifFalse: [aBlock value: superclass. - superclass allSuperclassesDo: aBlock]! Item was removed: - ----- Method: Behavior>>allTraits (in category 'Backstop-Traits') ----- - allTraits - "Backstop. When traits are unloaded there are no traits hiding here." - ^#()! Item was removed: - ----- Method: Behavior>>allUnreferencedInstanceVariables (in category 'user interface') ----- - allUnreferencedInstanceVariables - "Return a list of the instance variables known to the receiver which are not referenced in the receiver or any of its subclasses OR superclasses" - - ^ self allInstVarNames reject: [:ivn | - | definingClass | - definingClass := self classThatDefinesInstanceVariable: ivn. - definingClass withAllSubclasses anySatisfy: [:class | - (class whichSelectorsAccess: ivn asSymbol) notEmpty]]! Item was removed: - ----- Method: Behavior>>allowUnderscoreAssignments (in category 'compiling') ----- - allowUnderscoreAssignments - "Return true if the receiver and its subclasses should be allowed to use underscore as assignment operator. Returning nil here means that the compiler should use the system-wide default preference. Also see #allowUnderscoreSelectors. - - Combinations: If both preferences are false, underscore is illegal. If both preferences are true, underscore assignment needs the be surrounded by spaces and a single underscore cannot be used as selector." - ^nil! Item was removed: - ----- Method: Behavior>>allowsSubInstVars (in category 'accessing instances and variables') ----- - allowsSubInstVars - "Classes that allow instances to change classes among its subclasses will want to override this and return false, so inst vars are not accidentally added to its subclasses." - - ^ true! Item was removed: - ----- Method: Behavior>>basicAddSelector:withMethod: (in category 'adding/removing methods') ----- - basicAddSelector: selector withMethod: compiledMethod - "Add the message selector with the corresponding compiled method to the - receiver's method dictionary. - Do this without sending system change notifications" - - self methodDict at: selector put: compiledMethod. - compiledMethod - methodClass: self; - selector: selector. - - "Now flush Squeak's method cache for this selector" - selector flushCache! Item was removed: - ----- 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." - - <primitive: 70 error: ec> - ec == #'insufficient object memory' ifTrue: - [^self handleFailingBasicNew]. - self isVariable ifTrue: [^self basicNew: 0]. - self primitiveFailed! Item was removed: - ----- 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." - - <primitive: 71 error: ec> - (ec == #'insufficient object memory') ifTrue: - [^self handleFailingBasicNew: sizeRequested]. - (ec == #'bad argument') ifTrue: - [self error: self printString, ' called #basicNew: with invalid argument ', sizeRequested]. - self isVariable ifFalse: - [self error: self printString, ' cannot have variable sized instances']. - self primitiveFailed! Item was removed: - ----- Method: Behavior>>basicRemoveSelector: (in category 'adding/removing methods') ----- - basicRemoveSelector: selector - "Assuming that the argument, selector (a Symbol), is a message selector - in my method dictionary, remove it and its method. Returns the old method - if found, nil otherwise." - - | oldMethod | - oldMethod := self methodDict at: selector ifAbsent: [^ nil]. - self methodDict removeKey: selector. - - "Now flush Squeak's method cache for this selector" - selector flushCache. - ^oldMethod! Item was removed: - ----- Method: Behavior>>binding (in category 'compiling') ----- - binding - ^ nil -> self! Item was removed: - ----- Method: Behavior>>bindingOf: (in category 'testing method dictionary') ----- - bindingOf: varName - "Answer the binding of some variable resolved in the scope of the receiver" - ^superclass bindingOf: varName! Item was removed: - ----- Method: Behavior>>bindingOf:environment: (in category 'testing method dictionary') ----- - bindingOf: varName environment: anEnvironment - ^superclass bindingOf: varName environment: anEnvironment! Item was removed: - ----- 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 removed: - ----- 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 removed: - ----- Method: Behavior>>canUnderstand: (in category 'testing method dictionary') ----- - canUnderstand: selector - "Answer whether the receiver can respond to the message whose selector - is the argument. The selector can be in the method dictionary of the - receiver's class or any of its superclasses." - - (self includesSelector: selector) ifTrue: [^true]. - superclass == nil ifTrue: [^false]. - ^superclass canUnderstand: selector! Item was removed: - ----- Method: Behavior>>canZapMethodDictionary (in category 'testing') ----- - canZapMethodDictionary - "Return true if it is safe to zap the method dictionary on #obsolete" - ^true! Item was removed: - ----- Method: Behavior>>classBindingOf: (in category 'testing method dictionary') ----- - classBindingOf: varName - "Answer the binding of some variable resolved in the scope of the receiver's class" - ^self bindingOf: varName! Item was removed: - ----- Method: Behavior>>classBindingOf:environment: (in category 'testing method dictionary') ----- - classBindingOf: varName environment: anEnvironment - ^self bindingOf: varName environment: anEnvironment! Item was removed: - ----- Method: Behavior>>classDepth (in category 'accessing') ----- - classDepth - - superclass ifNil: [^ 1]. - ^ superclass classDepth + 1! Item was removed: - ----- Method: Behavior>>classVarNames (in category 'accessing instances and variables') ----- - classVarNames - "Answer a collection of the receiver's class variable names." - - ^#()! Item was removed: - ----- Method: Behavior>>cleanUp (in category 'initialize-release') ----- - cleanUp - "Clean out any caches and other state that should be flushed when trying to get an image into a pristine state. Subclasses may override #cleanUp: to provide different levels of cleanliness" - ! Item was removed: - ----- Method: Behavior>>cleanUp: (in category 'initialize-release') ----- - cleanUp: aggressive - "Clean out any caches and other state that should be flushed when trying to get an image into a pristine state. The argument should be used to indicate how aggressive the cleanup should be. Some subclasses may act differently depending on its value - for example, ChangeSet will only delete all unused and reinitialize the current change set if we're asking it to be aggressive." - - ^self cleanUp! Item was removed: - ----- Method: Behavior>>commentsAt: (in category 'accessing method dictionary') ----- - commentsAt: selector - "Answer a string representing the first comment in the method associated with selector. Return an empty string if the relevant source file is not available, or if the method's source code does not contain a comment. Not smart enough to bypass quotes in string constants, but does map doubled quote into a single quote." - - - ^self commentsIn: (self sourceCodeAt: selector) asString. - - "Behavior commentsAt: #commentsAt:"! Item was removed: - ----- Method: Behavior>>commentsIn: (in category 'accessing method dictionary') ----- - commentsIn: sourceString - "Return the comments as a collection of strings in sourceString. This method along with #nextQuotePosIn:startingFrom: is wrong, because it assumes that all double quote characters are comment delimiters, but even this method has a double quote which is not part of any method comment. Also this method has nothing to do with the Behavior itself. Probably CompiledMethod is the best place for this." - - | commentStart nextQuotePos someComments aPos | - (sourceString includes: $") ifFalse: [^#()]. - someComments:= OrderedCollection new. - aPos:=1. - nextQuotePos:= 0. - [commentStart := sourceString findString: '"' startingAt: aPos. - nextQuotePos:= self nextQuotePosIn: sourceString startingFrom: commentStart. - (commentStart ~= 0 and: [nextQuotePos >commentStart])] whileTrue: [ - commentStart ~= nextQuotePos ifTrue: [ - someComments add: ((sourceString copyFrom: commentStart + 1 to: nextQuotePos - 1) copyReplaceAll: '""' with: '"').]. - aPos := nextQuotePos+1]. - ^someComments! Item was removed: - ----- Method: Behavior>>compile: (in category 'compiling') ----- - compile: code - "Compile the argument, code, as source code in the context of the - receiver. Create an error notification if the code can not be compiled. - The argument is either a string or an object that converts to a string or a - PositionableStream on an object that converts to a string." - - ^self compile: code notifying: nil! Item was removed: - ----- Method: Behavior>>compile:environment:notifying:trailer:ifFail: (in category 'compiling') ----- - compile: code environment: anEnvironment notifying: requestor trailer: bytes ifFail: failBlock - "Compile code in another Environment without logging the source in the changes file" - - | methodNode | - methodNode := self newCompiler - compile: code - in: self - environment: anEnvironment - notifying: requestor - ifFail: failBlock. - ^ CompiledMethodWithNode generateMethodFromNode: methodNode trailer: bytes.! Item was removed: - ----- Method: Behavior>>compile:notifying: (in category 'compiling') ----- - compile: code notifying: requestor - "Compile the argument, code, as source code in the context of the - receiver and insEtall the result in the receiver's method dictionary. The - second argument, requestor, is to be notified if an error occurs. The - argument code is either a string or an object that converts to a string or - a PositionableStream. This method also saves the source code." - - | methodAndNode | - methodAndNode := self - compile: code "a Text" - notifying: requestor - trailer: (self defaultMethodTrailerIfLogSource: true) - ifFail: [^nil]. - methodAndNode method putSource: code fromParseNode: methodAndNode node inFile: 2 - withPreamble: [:f | f cr; nextPut: $!!; nextChunkPut: 'Behavior method'; cr]. - self addSelector: methodAndNode selector withMethod: methodAndNode method notifying: requestor. - ^ methodAndNode selector! Item was removed: - ----- Method: Behavior>>compile:notifying:trailer:ifFail: (in category 'compiling') ----- - compile: code notifying: requestor trailer: bytes ifFail: failBlock - "Compile code without logging the source in the changes file" - - | methodNode | - methodNode := self newCompiler - compile: code - in: self - notifying: requestor - ifFail: failBlock. - ^ CompiledMethodWithNode generateMethodFromNode: methodNode trailer: bytes.! Item was removed: - ----- Method: Behavior>>compileAll (in category 'compiling') ----- - compileAll - ^ self compileAllFrom: self! Item was removed: - ----- Method: Behavior>>compileAllFrom: (in category 'compiling') ----- - compileAllFrom: oldClass - "Compile all the methods in the receiver's method dictionary. - This validates sourceCode and variable references and forces - all methods to use the current bytecode set" - - "ar 7/10/1999: Use oldClass selectors not self selectors" - oldClass selectorsDo: [:sel | self recompile: sel from: oldClass]! Item was removed: - ----- Method: Behavior>>compiledMethodAt: (in category 'accessing method dictionary') ----- - compiledMethodAt: selector - "Answer the compiled method associated with the argument, selector (a - Symbol), a message selector in the receiver's method dictionary. If the - selector is not in the dictionary, create an error notification." - - ^ self methodDict at: selector! Item was removed: - ----- Method: Behavior>>compiledMethodAt:ifAbsent: (in category 'accessing method dictionary') ----- - compiledMethodAt: selector ifAbsent: aBlock - "Answer the compiled method associated with the argument, selector (a Symbol), a message selector in the receiver's method dictionary. If the selector is not in the dictionary, return the value of aBlock" - - ^ self methodDict at: selector ifAbsent: aBlock! Item was removed: - ----- Method: Behavior>>compilerClass (in category 'compiling') ----- - compilerClass - "Answer a compiler class appropriate for source methods of this class." - - ^Compiler! Item was removed: - ----- Method: Behavior>>compress (in category 'accessing method dictionary') ----- - compress - "Compact the method dictionary of the receiver." - - self methodDict compact! Item was removed: - ----- Method: Behavior>>compressedSourceCodeAt: (in category 'accessing method dictionary') ----- - compressedSourceCodeAt: selector - "(Paragraph compressedSourceCodeAt: #displayLines:affectedRectangle:) size 721 1921 - Paragraph selectors inject: 0 into: [:tot :sel | tot + (Paragraph compressedSourceCodeAt: sel) size] 13606 31450" - | rawText parse | - rawText := (self sourceCodeAt: selector) asString. - parse := self newCompiler parse: rawText in: self notifying: nil. - ^ rawText compressWithTable: - ((selector keywords , - parse tempNames , - self instVarNames , - #(self super ifTrue: ifFalse:) , - ((0 to: 7) collect: - [:i | String streamContents: - [:s | s cr. i timesRepeat: [s tab]]]) , - (self compiledMethodAt: selector) literalStrings) - sorted: [:a :b | a size > b size])! Item was removed: - ----- Method: Behavior>>copyOfMethodDictionary (in category 'copying') ----- - copyOfMethodDictionary - "Return a copy of the receiver's method dictionary" - - ^ self methodDict copy! Item was removed: - ----- Method: Behavior>>crossReference (in category 'user interface') ----- - crossReference - "Answer an Array of arrays of size 2 whose first element is a message selector in the receiver's method dictionary and whose second element is a set of all message selectors in the method dictionary whose methods send a message with that selector. Subclasses are not included." - - ^self selectors asArray sort collect: [:x | Array - with: (String with: Character cr), x - with: (self whichSelectorsReferTo: x)] - - "Point crossReference."! Item was removed: - ----- Method: Behavior>>decompile: (in category 'compiling') ----- - decompile: selector - "Find the compiled code associated with the argument, selector, as a - message selector in the receiver's method dictionary and decompile it. - Answer the resulting source code as a string. Create an error notification - if the selector is not in the receiver's method dictionary." - - ^self decompilerClass new decompile: selector in: self! Item was removed: - ----- Method: Behavior>>decompilerClass (in category 'compiling') ----- - decompilerClass - "Answer a decompiler class appropriate for compiled methods of this class." - - ^ self compilerClass decompilerClass! Item was removed: - ----- Method: Behavior>>deepCopy (in category 'copying') ----- - deepCopy - "Behavior are shared rather than copied." - - ^ self! Item was removed: - ----- Method: Behavior>>defaultMethodTrailer (in category 'compiling') ----- - defaultMethodTrailer - ^ CompiledMethodTrailer empty! Item was removed: - ----- Method: Behavior>>defaultMethodTrailerIfLogSource: (in category 'compiling') ----- - defaultMethodTrailerIfLogSource: logSource - - logSource ifFalse: [ ^self defaultMethodTrailer ]. - ^CompiledMethodTrailer sourcePointerInFile: 2! Item was removed: - ----- Method: Behavior>>defaultNameStemForInstances (in category 'printing') ----- - defaultNameStemForInstances - "Answer a basis for external names for default instances of the receiver. - For classees, the class-name itself is a good one." - - ^ self name! Item was removed: - ----- 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 (Context BlockClosure 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 removed: - ----- Method: Behavior>>emptyMethodDictionary (in category 'initialize-release') ----- - emptyMethodDictionary - - ^ MethodDictionary new! Item was removed: - ----- Method: Behavior>>environment (in category 'accessing') ----- - environment - "Return the environment in which the receiver is declared" - ^Smalltalk globals! Item was removed: - ----- Method: Behavior>>evaluatorClass (in category 'compiling') ----- - evaluatorClass - "Answer an evaluator class appropriate for evaluating expressions in the - context of this class." - - ^Compiler! Item was removed: - ----- Method: Behavior>>firstCommentAt: (in category 'accessing method dictionary') ----- - firstCommentAt: selector - "Answer a string representing the first comment in the method associated with selector. Return an empty string if the relevant source file is not available, or if the method's source code does not contain a comment. Not smart enough to bypass quotes in string constants, but does map doubled quote into a single quote." - - |someComments| - someComments := self commentsAt: selector. - ^someComments isEmpty ifTrue: [''] ifFalse: [someComments first] - - - "Behavior firstCommentAt: #firstCommentAt:"! Item was removed: - ----- Method: Behavior>>firstPrecodeCommentFor: (in category 'accessing method dictionary') ----- - firstPrecodeCommentFor: selector - "If there is a comment in the source code at the given selector that preceeds the body of the method, return it here, else return nil" - - | parser source tree | - "Behavior firstPrecodeCommentFor: #firstPrecodeCommentFor:" - (#(Comment Definition Hierarchy) includes: selector) - ifTrue: - ["Not really a selector" - ^ nil]. - source := self sourceCodeAt: selector asSymbol ifAbsent: [^ nil]. - parser := self newParser. - tree := - parser - parse: (ReadStream on: source) - class: self - noPattern: false - notifying: nil - ifFail: [^ nil]. - ^ (tree comment ifNil: [^ nil]) first! Item was removed: - ----- Method: Behavior>>flushCache (in category 'private') ----- - flushCache - "Tell the interpreter to remove the contents of its method lookup cache, if it has - one. Essential. See Object documentation whatIsAPrimitive." - - <primitive: 89> - self primitiveFailed! Item was removed: - ----- Method: Behavior>>formalHeaderPartsFor: (in category 'accessing method dictionary') ----- - "popeye" formalHeaderPartsFor: "olive oil" aSelector - "RELAX!! The warning you may have just seen about possibly having a bad source file does not apply here, because this method *intends* to have its source code start with a comment. - This method returns a collection giving the parts in the formal declaration for aSelector. This parse is in support of schemes in which adjutant properties of a method can be declared via special comments secreted in the formal header - The result will have - 3 elements for a simple, argumentless selector. - 5 elements for a single-argument selector - 9 elements for a two-argument selector - 13 elements for a three-argument, selector - etc... - - The syntactic elements are: - - 1 comment preceding initial selector fragment - - 2 first selector fragment - 3 comment following first selector fragment (nil if selector has no arguments) - - ---------------------- (ends here for, e.g., #copy) - - 4 first formal argument - 5 comment following first formal argument (nil if selector has only one argument) - - ---------------------- (ends here for, e.g., #copyFrom:) - - 6 second keyword - 7 comment following second keyword - 8 second formal argument - 9 comment following second formal argument (nil if selector has only two arguments) - - ---------------------- (ends here for, e.g., #copyFrom:to:) - - Any nil element signifies an absent comment. - NOTE: The comment following the final formal argument is *not* successfully retrieved by this method in its current form, though it can be obtained, if needed, by other means (e.g. calling #firstPrecodeCommentFor:). Thus, the *final* element in the structure returned by this method is always going to be nil." - - ^ Scanner new scanMessageParts: (self methodHeaderFor: aSelector) - - " - Behavior class formalHeaderPartsFor: #formalHeaderPartsFor: - " - - - ! Item was removed: - ----- Method: Behavior>>formalParametersAt: (in category 'accessing method dictionary') ----- - formalParametersAt: aSelector - "Return the names of the arguments used in this method." - - | source | - source := self sourceCodeAt: aSelector ifAbsent: [^ #()]. "for now" - ^self newParser parseParameterNames: source! Item was removed: - ----- Method: Behavior>>format (in category 'accessing') ----- - format - "Answer an Integer that encodes the kinds and numbers of variables of - instances of the receiver. The format is (currently) composed of two fields, - a 16-bit instSize, in the least significant bits, specifying the number of named - inst vars, if any, and a 5-bit format field, describing the kind of class. c.f. instSpec. - (msb)<5 bit format><16 bit #fixed fields>(lsb)" - - ^format! Item was removed: - ----- Method: Behavior>>formatterClass (in category 'printing') ----- - formatterClass - ^self compilerClass! Item was removed: - ----- Method: Behavior>>fullyImplementsVocabulary: (in category 'testing method dictionary') ----- - fullyImplementsVocabulary: aVocabulary - "Answer whether instances of the receiver respond to all the messages in aVocabulary" - - (aVocabulary encompassesAPriori: self) ifTrue: [^ true]. - aVocabulary allSelectorsInVocabulary do: - [:aSelector | (self canUnderstand: aSelector) ifFalse: [^ false]]. - ^ true! Item was removed: - ----- 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 removed: - ----- 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 removed: - ----- 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 removed: - ----- 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 removed: - ----- Method: Behavior>>hasMethods (in category 'testing method dictionary') ----- - hasMethods - "Answer whether the receiver has any methods in its method dictionary." - - ^ self methodDict size > 0! Item was removed: - ----- Method: Behavior>>hasTraitComposition (in category 'Backstop-Traits') ----- - hasTraitComposition - "Backstop. When traits are unloaded we never have a trait composition" - ^false! Item was removed: - ----- Method: Behavior>>hash (in category 'comparing') ----- - hash - ^ self name hash! Item was removed: - ----- 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 removed: - ----- Method: Behavior>>includesBehavior: (in category 'testing class hierarchy') ----- - includesBehavior: aClass - ^self == aClass or:[self inheritsFrom: aClass]! Item was removed: - ----- Method: Behavior>>includesLocalSelector: (in category 'testing method dictionary') ----- - includesLocalSelector: aSymbol - ^self includesSelector: aSymbol! Item was removed: - ----- Method: Behavior>>includesSelector: (in category 'testing method dictionary') ----- - includesSelector: aSymbol - "Answer whether the message whose selector is the argument is in the - method dictionary of the receiver's class." - - ^ self methodDict includesKey: aSymbol! Item was removed: - ----- Method: Behavior>>inheritsFrom: (in category 'testing class hierarchy') ----- - inheritsFrom: aClass - "Answer whether the argument, aClass, is on the receiver's superclass - chain." - - | aSuperclass | - aSuperclass := superclass. - [aSuperclass == nil] - whileFalse: - [aSuperclass == aClass ifTrue: [^true]. - aSuperclass := aSuperclass superclass]. - ^false! Item was removed: - ----- Method: Behavior>>initialize (in category 'initialize-release') ----- - initialize - "moved here from the class side's #new" - self methodDictionary: self emptyMethodDictionary. - self superclass: Object. - self setFormat: Object format! Item was removed: - ----- Method: Behavior>>initializedInstance (in category 'instance creation') ----- - initializedInstance - "Answer an instance of the receiver which in some sense is initialized. In the case of Morphs, this will yield an instance that can be attached to the Hand after having received the same kind of basic initialization that would be obtained from an instance chosen from the 'new morph' menu. Return nil if the receiver is reluctant for some reason to return such a thing" - - ^ self new! Item was removed: - ----- 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! Item was removed: - ----- 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 (Context BlockClosure 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 (DoubleWordArray et al) - 10-11 = 32-bit indexable (WordArray et al) (includes one odd bit, unused in 32-bit instances) - 12-15 = 16-bit indexable (DoubleByteArray et al) (includes two odd bits, one unused in 32-bit instances) - 16-23 = 8-bit indexable (ByteArray et al) (includes three odd bits, one unused in 32-bit instances) - 24-31 = compiled code (CompiledCode et al) (includes three odd bits, one unused in 32-bit instances) - - Note that in the VM instances also have a 5 bit format field that relates to their class's format. - Formats 11, 13-15, 17-23 & 25-31 are unused in classes but used in instances to define the - number of elements missing up to the slot size. For example, a 2-byte ByteString instance - has format 18 in 32 bits, since its size is one 32-bit slot - 2 bytes ((18 bitAnd: 3) = 2), and - 22 in 64 bits, since its size is one 64-bit slot - 6 bytes ((22 bitAnd: 7) = 6). - Formats 24-31 are for compiled code which is a combination of pointers and bytes. The number of pointers is - determined by literal count field of the method header, which is the first field of the object and must be a SmallInteger. - The literal count field occupies the least significant 15 bits of the method header, allowing up to 32,767 pointer fields, - not including the header." - ^(format bitShift: -16) bitAnd: 16r1F! Item was removed: - ----- Method: Behavior>>instVarIndexFor:ifAbsent: (in category 'accessing instances and variables') ----- - instVarIndexFor: instVarName ifAbsent: aBlock - "Answer the index of the named instance variable." - - ^self allInstVarNames indexOf: instVarName ifAbsent: aBlock! Item was removed: - ----- Method: Behavior>>instVarNames (in category 'accessing instances and variables') ----- - instVarNames - "Answer an Array of the instance variable names. Behaviors must make - up fake local instance variable names because Behaviors have instance - variables for the purpose of compiling methods, but these are not named - instance variables." - - | mySize superSize | - mySize := self instSize. - superSize := - superclass == nil - ifTrue: [0] - ifFalse: [superclass instSize]. - mySize = superSize ifTrue: [^#()]. - ^(superSize + 1 to: mySize) collect: [:i | 'inst' , i printString]! Item was removed: - ----- Method: Behavior>>instVarNamesAndOffsetsDo: (in category 'compiling') ----- - instVarNamesAndOffsetsDo: aBinaryBlock - "This is part of the interface between the compiler and a class's instance or field names. - The class should enumerate aBinaryBlock with the instance variable name strings and - their integer offsets. The order is important. Names evaluated later will override the - same names occurring earlier." - - "Nothing to do here; ClassDescription introduces named instance variables" - ^self! Item was removed: - ----- Method: Behavior>>instanceCount (in category 'accessing instances and variables') ----- - instanceCount - "Answer the number of instances of the receiver that are currently in - use." - - | count | - count := 0. - self allInstancesDo: [:x | count := count + 1]. - ^count! Item was removed: - ----- Method: Behavior>>isBehavior (in category 'testing') ----- - isBehavior - "Return true if the receiver is a behavior" - ^true! Item was removed: - ----- 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 (Context BlockClosure 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! Item was removed: - ----- Method: Behavior>>isBytes (in category 'testing') ----- - isBytes - "Answer whether the receiver's instances have indexed 8-bit integer 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 (Context BlockClosure 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! Item was removed: - ----- Method: Behavior>>isCompiledMethodClass (in category 'testing') ----- - isCompiledMethodClass - "Answer whether the receiver has compiled method instances that mix pointers and bytes." - ^self instSpec >= 24! Item was removed: - ----- 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 removed: - ----- Method: Behavior>>isFixed (in category 'testing') ----- - isFixed - "Answer whether the receiver does not have a variable (indexable) part." - - ^self isVariable not! Item was removed: - ----- 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 removed: - ----- Method: Behavior>>isLongs (in category 'testing') ----- - isLongs - "Answer whether the receiver's instances have indexed 64-bit integer 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 (Context BlockClosure 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 = 9! Item was removed: - ----- Method: Behavior>>isMeta (in category 'testing') ----- - isMeta - ^ false! Item was removed: - ----- Method: Behavior>>isObsolete (in category 'testing') ----- - isObsolete - "Return true if the receiver is obsolete." - ^self instanceCount = 0! Item was removed: - ----- Method: Behavior>>isPointers (in category 'testing') ----- - isPointers - "Answer whether the receiver contains just pointers (not bits)." - - ^self isBits not! Item was removed: - ----- Method: Behavior>>isShorts (in category 'testing') ----- - isShorts - "Answer whether the receiver's instances have indexed 16-bit integer 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 (Context BlockClosure 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 = 12! Item was removed: - ----- 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 (Context BlockClosure 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]]! Item was removed: - ----- Method: Behavior>>isWeak (in category 'testing') ----- - isWeak - "Answer whether the receiver has contains weak references." - ^ self instSpec = 4! Item was removed: - ----- Method: Behavior>>isWords (in category 'testing') ----- - isWords - "Answer whether the receiver's instances have indexed 32-bit integer 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 (Context BlockClosure 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 = 10! Item was removed: - ----- 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 & instSpec" - ^(#(' subclass: ' - ' subclass: ' - ' variableSubclass: ' - ' variableSubclass: ' - ' weakSubclass: ' - ' ephemeronSubclass: ' - nil - ' immediateSubclass: ' - nil - ' variableDoubleWordSubclass: ' - ' variableWordSubclass: ' nil - ' variableDoubleByteSubclass: ' nil nil nil - ' variableByteSubclass: ' nil nil nil nil nil nil nil - ' variableByteSubclass: ' nil nil nil nil nil nil nil ) - at: self instSpec + 1) ifNil: - [self error: 'invalid class type']! Item was removed: - ----- Method: Behavior>>literalScannedAs:environment:notifying: (in category 'printing') ----- - literalScannedAs: scannedLiteral environment: anEnvironment notifying: requestor - "Postprocesses a literal scanned by Scanner scanToken (esp. xLitQuote). - If scannedLiteral is not an association, answer it. - Else, if it is of the form: - nil->#NameOfMetaclass - answer nil->theMetaclass, if any has that name, else report an error. - Else, if it is of the form: - #NameOfGlobalVariable->anythiEng - answer the global, class, or pool association with that nameE, if any, else - add it to Undeclared a answer the new Association." - - | key value | - (scannedLiteral isVariableBinding) - ifFalse: [^ scannedLiteral]. - key := scannedLiteral key. - value := scannedLiteral value. - key ifNil: "###<metaclass soleInstance name>" - [(self bindingOf: value environment: anEnvironment) ifNotNil: - [:assoc| - (assoc value isKindOf: Behavior) ifTrue: - [^ nil->assoc value class]]. - requestor notify: 'No such metaclass'. - ^false]. - (key isSymbol) ifTrue: "##<global var name>" - [(self bindingOf: key environment: anEnvironment) ifNotNil: - [:assoc | ^assoc]. - ^ anEnvironment undeclared: key]. - requestor notify: '## must be followed by a non-local variable name'. - ^false - - " Form literalScannedAs: 14 notifying: nil 14 - Form literalScannedAs: #OneBitForm notiEfying: nil OneBitForm - Form literalScannedAs: ##OneBitForm notifying: nil OneBitForm->a Form - Form literalScannedAs: ##Form notifying: nil Form->Form - Form literalScannedAs: ###Form notifying: nil nilE->Form class - "! Item was removed: - ----- Method: Behavior>>localSelectors (in category 'adding/removing methods') ----- - localSelectors - "Return a set of selectors defined locally." - ^ self selectors - ! Item was removed: - ----- Method: Behavior>>longPrintOn: (in category 'printing') ----- - longPrintOn: aStream - "Append to the argument, aStream, the names and values of all of the receiver's instance variables. But, not useful for a class with a method dictionary." - - aStream nextPutAll: '<<too complex to show>>'; cr.! Item was removed: - ----- Method: Behavior>>lookupSelector: (in category 'accessing method dictionary') ----- - lookupSelector: selector - "Look up the given selector in my methodDictionary. - Return the corresponding method if found. - Otherwise chase the superclass chain and try again. - Return nil if no method is found." - | lookupClass | - lookupClass := self. - [lookupClass == nil] - whileFalse: - [(lookupClass includesSelector: selector) - ifTrue: [^ lookupClass compiledMethodAt: selector]. - lookupClass := lookupClass superclass]. - ^ nil! Item was removed: - ----- Method: Behavior>>methodDict (in category 'accessing') ----- - methodDict - methodDict == nil ifTrue: [self recoverFromMDFaultWithTrace]. - ^ methodDict! Item was removed: - ----- Method: Behavior>>methodDict: (in category 'accessing method dictionary') ----- - methodDict: aDictionary - methodDict := aDictionary! Item was removed: - ----- Method: Behavior>>methodDictionary (in category 'accessing method dictionary') ----- - methodDictionary - "Convenience" - ^self methodDict! Item was removed: - ----- Method: Behavior>>methodDictionary: (in category 'accessing method dictionary') ----- - methodDictionary: aDictionary - self methodDict: aDictionary! Item was removed: - ----- Method: Behavior>>methodHeaderFor: (in category 'accessing method dictionary') ----- - methodHeaderFor: selector - "Answer the string corresponding to the method header for the given selector" - - | sourceString parser | - sourceString := self ultimateSourceCodeAt: selector ifAbsent: [self standardMethodHeaderFor: selector]. - (parser := self newParser) parseSelector: sourceString. - ^ sourceString asString copyFrom: 1 to: (parser endOfLastToken min: sourceString size) - - "Behavior methodHeaderFor: #methodHeaderFor: " - ! Item was removed: - ----- Method: Behavior>>methodsDo: (in category 'accessing method dictionary') ----- - methodsDo: aBlock - "Evaluate aBlock for all the compiled methods in my method dictionary." - - ^ self methodDict valuesDo: aBlock! Item was removed: - ----- Method: Behavior>>modificationForbiddenAdopting: (in category 'read-only objects') ----- - modificationForbiddenAdopting: anObject - ^(BinaryModificationForbidden new - mirror: self - object: anObject - index: nil - newValue: nil - retrySelector: #adoptInstance:) signal! Item was removed: - ----- Method: Behavior>>name (in category 'accessing') ----- - name - "Answer a String that is the name of the receiver." - ^'a subclass of ', superclass name! Item was removed: - ----- Method: Behavior>>new (in category 'instance creation') ----- - new - "Answer a new initialized instance of the receiver (which is a class) with no indexable variables. Fail if the class is indexable." - - ^ self basicNew initialize - ! Item was removed: - ----- Method: Behavior>>new: (in category 'instance creation') ----- - new: sizeRequested - "Answer an initialized instance of this class with the number of indexable - variables specified by the argument, sizeRequested." - - ^ (self basicNew: sizeRequested) initialize ! Item was removed: - ----- Method: Behavior>>newCompiler (in category 'compiling') ----- - newCompiler - "Answer a Compiler suitable for compiling this Behavior" - ^self compilerClass new parser: self newParser! Item was removed: - ----- Method: Behavior>>newParser (in category 'compiling') ----- - newParser - "Answer a Parser suitable for parsing source code in this Behavior" - ^self parserClass new! Item was removed: - ----- Method: Behavior>>nextQuotePosIn:startingFrom: (in category 'accessing method dictionary') ----- - nextQuotePosIn: sourceString startingFrom: commentStart - | pos nextQuotePos | - pos := commentStart + 1. - [((nextQuotePos := sourceString findString: '"' startingAt: pos) == (sourceString findString: '""' startingAt: pos)) and: [nextQuotePos ~= 0]] - whileTrue: - [pos := nextQuotePos + 2]. - ^nextQuotePos! Item was removed: - ----- Method: Behavior>>nonObsoleteClass (in category 'initialize-release') ----- - nonObsoleteClass - "Attempt to find and return the current version of this obsolete class" - - | obsName | - obsName := self name. - [obsName beginsWith: 'AnObsolete'] - whileTrue: [obsName := obsName copyFrom: 'AnObsolete' size + 1 to: obsName size]. - ^ self environment at: obsName asSymbol! Item was removed: - ----- Method: Behavior>>obsolete (in category 'initialize-release') ----- - obsolete - "Invalidate and recycle local methods, - e.g., zap the method dictionary if can be done safely." - self canZapMethodDictionary - ifTrue: [self methodDict: self emptyMethodDictionary].! Item was removed: - ----- Method: Behavior>>obsoleteSubclasses (in category 'obsolete subclasses') ----- - obsoleteSubclasses - "Return all the weakly remembered obsolete subclasses of the receiver" - | obs | - obs := ObsoleteSubclasses at: self ifAbsent: [^ #()]. - ^ obs copyWithout: nil! Item was removed: - ----- Method: Behavior>>parserClass (in category 'compiling') ----- - parserClass - "Answer a parser class to use for parsing method headers." - - ^self compilerClass parserClass! Item was removed: - ----- Method: Behavior>>postCopy (in category 'copying') ----- - postCopy - super postCopy. - self methodDict: self methodDict copy! Item was removed: - ----- Method: Behavior>>precodeCommentOrInheritedCommentFor: (in category 'accessing method dictionary') ----- - precodeCommentOrInheritedCommentFor: selector - "Answer a string representing the first comment in the method associated - with selector, considering however only comments that occur before the - beginning of the actual code. If the version recorded in the receiver is - uncommented, look up the inheritance chain. Return nil if none found." - | aSuper aComment | - ^ (aComment := self firstPrecodeCommentFor: selector) isEmptyOrNil - ifTrue: [(self == Behavior - or: [superclass == nil - or: [(aSuper := superclass whichClassIncludesSelector: selector) == nil]]) - ifFalse: [aSuper precodeCommentOrInheritedCommentFor: selector] - "ActorState precodeCommentOrInheritedCommentFor: #printOn:"] - ifFalse: [aComment]! Item was removed: - ----- Method: Behavior>>prettyPrinterClass (in category 'printing') ----- - prettyPrinterClass - ^self compilerClass! Item was removed: - ----- Method: Behavior>>printHierarchy (in category 'printing') ----- - printHierarchy - "Answer a description containing the names and instance variable names - of all of the subclasses and superclasses of the receiver." - - | aStream index | - index := 0. - aStream := WriteStream on: (String new: 16). - self allSuperclasses reverseDo: - [:aClass | - aStream crtab: index. - index := index + 1. - aStream nextPutAll: aClass name. - aStream space. - aStream print: aClass instVarNames]. - aStream cr. - self printSubclassesOn: aStream level: index. - ^aStream contents! Item was removed: - ----- Method: Behavior>>printOn: (in category 'printing') ----- - printOn: aStream - "Refer to the comment in Object|printOn:." - - aStream nextPutAll: 'a descendent of '. - superclass printOn: aStream! Item was removed: - ----- Method: Behavior>>printWithClosureAnalysisOn: (in category 'printing') ----- - printWithClosureAnalysisOn: aStream - "Refer to the comment in Object|printOn:." - - aStream nextPutAll: 'a descendent of '. - superclass printWithClosureAnalysisOn: aStream! Item was removed: - ----- Method: Behavior>>recompile: (in category 'compiling') ----- - recompile: selector - "Compile the method associated with selector in the receiver's method dictionary." - ^self recompile: selector from: self! Item was removed: - ----- Method: Behavior>>recompile:from: (in category 'compiling') ----- - recompile: selector from: oldClass - "Compile the method associated with selector in the receiver's method dictionary." - "ar 7/10/1999: Use oldClass compiledMethodAt: not self compiledMethodAt:" - | method trailer methodNode | - method := oldClass compiledMethodAt: selector. - trailer := method trailer. - methodNode := self newCompiler - compile: (oldClass sourceCodeAt: selector) - in: self - notifying: nil - ifFail: [^ self]. "Assume OK after proceed from SyntaxError" - selector == methodNode selector ifFalse: [self error: 'selector changed!!']. - self basicAddSelector: selector withMethod: (methodNode generate: trailer). - ! Item was removed: - ----- Method: Behavior>>recompileChanges (in category 'compiling') ----- - recompileChanges - "Compile all the methods that are in the changes file. - This validates sourceCode and variable references and forces - methods to use the current bytecode set" - - self selectorsAndMethodsDo: - [:sel :m | m fileIndex > 1 ifTrue: - [self recompile: sel from: self]]! Item was removed: - ----- Method: Behavior>>recompileNonResidentMethod:atSelector:from: (in category 'compiling') ----- - recompileNonResidentMethod: method atSelector: selector from: oldClass - "Recompile the method supplied in the context of this class." - - | trailer methodNode | - trailer := method trailer. - methodNode := self newCompiler - compile: (method getSourceFor: selector in: oldClass) - in: self - notifying: nil - ifFail: ["We're in deep doo-doo if this fails (syntax error). - Presumably the user will correct something and proceed, - thus installing the result in this methodDict. We must - retrieve that new method, and restore the original (or remove) - and then return the method we retrieved." - ^ self error: 'see comment']. - selector == methodNode selector ifFalse: [self error: 'selector changed!!']. - ^ methodNode generate: trailer - ! Item was removed: - ----- Method: Behavior>>removeAllObsoleteSubclasses (in category 'obsolete subclasses') ----- - removeAllObsoleteSubclasses - "Remove all the obsolete subclasses of the receiver" - ObsoleteSubclasses removeKey: self ifAbsent: []. - ! Item was removed: - ----- Method: Behavior>>removeObsoleteSubclass: (in category 'obsolete subclasses') ----- - removeObsoleteSubclass: aClass - "Remove aClass from the weakly remembered obsolete subclasses" - | obs | - obs := ObsoleteSubclasses at: self ifAbsent:[^ self]. - (obs includes: aClass) ifFalse:[^self]. - obs := obs copyWithout: aClass. - obs := obs copyWithout: nil. - ObsoleteSubclasses at: self put: obs! Item was removed: - ----- Method: Behavior>>removeSelector: (in category 'adding/removing methods') ----- - removeSelector: aSelector - "Assuming that the argument, selector (a Symbol), is a message selector - in my method dictionary, remove it and its method." - ^self basicRemoveSelector: aSelector - ! Item was removed: - ----- Method: Behavior>>removeSelectorSilently: (in category 'adding/removing methods') ----- - removeSelectorSilently: selector - "Remove selector without sending system change notifications" - - ^ SystemChangeNotifier uniqueInstance doSilently: [self removeSelector: selector].! Item was removed: - ----- Method: Behavior>>rootStubInImageSegment: (in category 'accessing method dictionary') ----- - rootStubInImageSegment: imageSegment - - ^ ImageSegmentRootStub new - xxSuperclass: superclass - format: format - segment: imageSegment! Item was removed: - ----- Method: Behavior>>selectSubclasses: (in category 'enumerating') ----- - selectSubclasses: aBlock - "Evaluate the argument, aBlock, with each of the receiver's (next level) - subclasses as its argument. Collect into a Set only those subclasses for - which aBlock evaluates to true. In addition, evaluate aBlock for the - subclasses of each of these successful subclasses and collect into the set - those for which aBlock evaluates true. Answer the resulting set." - - | aSet | - aSet := Set new. - self allSubclasses do: - [:aSubclass | - (aBlock value: aSubclass) ifTrue: [aSet add: aSubclass]]. - ^aSet! Item was removed: - ----- Method: Behavior>>selectSuperclasses: (in category 'enumerating') ----- - selectSuperclasses: aBlock - "Evaluate the argument, aBlock, with the receiver's superclasses as the - argument. Collect into an OrderedCollection only those superclasses for - which aBlock evaluates to true. In addition, evaluate aBlock for the - superclasses of each of these successful superclasses and collect into the - OrderedCollection ones for which aBlock evaluates to true. Answer the - resulting OrderedCollection." - - | aSet | - aSet := Set new. - self allSuperclasses do: - [:aSuperclass | - (aBlock value: aSuperclass) ifTrue: [aSet add: aSuperclass]]. - ^aSet! Item was removed: - ----- Method: Behavior>>selectors (in category 'accessing method dictionary') ----- - selectors - "Answer a collection of all the message selectors specified in the receiver's - method dictionary." - - ^ self methodDict keys! Item was removed: - ----- Method: Behavior>>selectorsAndMethodsDo: (in category 'accessing method dictionary') ----- - selectorsAndMethodsDo: selectorAndMethodBlock - "Evaluate the two argument selectorAndMethodBlock for all the selector/method pairs in my method dictionary." - - ^ self methodDict keysAndValuesDo: selectorAndMethodBlock! Item was removed: - ----- Method: Behavior>>selectorsDo: (in category 'accessing method dictionary') ----- - selectorsDo: selectorBlock - "Evaluate selectorBlock for all the message selectors in my method dictionary." - - ^ self methodDict keysDo: selectorBlock! Item was removed: - ----- Method: Behavior>>selectorsWithArgs: (in category 'accessing method dictionary') ----- - selectorsWithArgs: numberOfArgs - "Return all selectors defined in this class that take this number of arguments" - - ^ self selectors select: [:selector | selector numArgs = numberOfArgs]! Item was removed: - ----- Method: Behavior>>setFormat: (in category 'private') ----- - setFormat: aFormatInstanceDescription - "only use this method with extreme care since it modifies the format of the class - ie a description of the number of instance variables and whether the class is - compact, variable sized" - - format := aFormatInstanceDescription - - ! Item was removed: - ----- Method: Behavior>>sharedPools (in category 'accessing instances and variables') ----- - sharedPools - "Answer a Set of the names of the pools (Dictionaries) that the receiver - shares. - 9/12/96 tk sharedPools have an order now" - - ^ OrderedCollection new! Item was removed: - ----- 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" - - ^(Smalltalk specialObjectsArray - identityIndexOf: self - ifAbsent: [(self isKindOf: self) ifTrue: [1] ifFalse: [0]]) ~= 0! Item was removed: - ----- Method: Behavior>>shutDown (in category 'system startup') ----- - shutDown - "This message is sent on system shutdown to registered classes" - ! Item was removed: - ----- Method: Behavior>>shutDown: (in category 'system startup') ----- - shutDown: quitting - "This message is sent on system shutdown to registered classes" - ^self shutDown.! Item was removed: - ----- Method: Behavior>>someInstance (in category 'accessing instances and variables') ----- - someInstance - "Primitive. Answer the first instance in the enumeration of all instances - of the receiver. Fails if there are none. Essential. See Object - documentation whatIsAPrimitive." - - <primitive: 77> - ^nil! Item was removed: - ----- Method: Behavior>>sourceCodeAt: (in category 'accessing method dictionary') ----- - sourceCodeAt: selector - - ^ (self methodDict at: selector) getSourceFor: selector in: self! Item was removed: - ----- Method: Behavior>>sourceCodeAt:ifAbsent: (in category 'accessing method dictionary') ----- - sourceCodeAt: selector ifAbsent: aBlock - - ^ (self methodDict at: selector ifAbsent: [^ aBlock value]) getSourceFor: selector in: self! Item was removed: - ----- Method: Behavior>>sourceCodeTemplate (in category 'compiling') ----- - sourceCodeTemplate - "Answer an expression to be edited and evaluated in order to define - methods in this class or trait." - - ^'message selector and argument names - "comment stating purpose of message" - - | temporary variable names | - statements'! Item was removed: - ----- Method: Behavior>>sourceMatchesBytecodeAt: (in category 'testing') ----- - sourceMatchesBytecodeAt: selector - "Answers true if the source code at the selector compiles to the bytecode at the selector, and false otherwise. Implemented to detect an error where Monticello did not recompile sources when the class shape changed" - "This code was copied from #recompile:from:, with few changes. Several methods would benefit from a method which turned a selector and class into a CompiledMethod, without installing it into the methodDictionary" - - | method trailer methodNode | - method := self compiledMethodAt: selector. - trailer := method trailer. - methodNode := self newCompiler - compile: (self sourceCodeAt: selector) - in: self - notifying: nil - ifFail: [^ false]. "Assume OK after proceed from SyntaxError" - selector == methodNode selector ifFalse: [self error: 'selector changed!!']. - ^ (methodNode generate: trailer) = method! Item was removed: - ----- Method: Behavior>>sourceMethodAt: (in category 'accessing method dictionary') ----- - sourceMethodAt: selector - "Answer the paragraph corresponding to the source code for the - argument." - - ^(self sourceCodeAt: selector) asText makeSelectorBoldIn: self! Item was removed: - ----- Method: Behavior>>sourceMethodAt:ifAbsent: (in category 'accessing method dictionary') ----- - sourceMethodAt: selector ifAbsent: aBlock - "Answer the paragraph corresponding to the source code for the - argument." - - ^ (self sourceCodeAt: selector ifAbsent: [^ aBlock value]) asText makeSelectorBoldIn: self! Item was removed: - ----- Method: Behavior>>spaceUsed (in category 'private') ----- - spaceUsed - "Answer a rough estimate of number of bytes used by this class and its metaclass. Does not include space used by class variables." - - | space | - space := 0. - self methodsDo: [:method | - space := space + 16. "dict and org'n space" - space := space + (method size + 6 "hdr + avg pad"). - method literalsDo: [:lit | - (lit isMemberOf: Array) ifTrue: [space := space + ((lit size + 1) * 4)]. - (lit isMemberOf: Float) ifTrue: [space := space + 12]. - (lit isMemberOf: ByteString) ifTrue: [space := space + (lit size + 6)]. - (lit isMemberOf: LargeNegativeInteger) ifTrue: [space := space + ((lit size + 1) * 4)]. - (lit isMemberOf: LargePositiveInteger) ifTrue: [space := space + ((lit size + 1) * 4)]]]. - ^ space! Item was removed: - ----- Method: Behavior>>standardMethodHeaderFor: (in category 'accessing method dictionary') ----- - standardMethodHeaderFor: aSelector - | args | - args := (1 to: aSelector numArgs) collect:[:i| 'arg', i printString]. - args size = 0 ifTrue:[^aSelector asString]. - args size = 1 ifTrue:[^aSelector,' arg1']. - ^String streamContents:[:s| - (aSelector findTokens:':') with: args do:[:tok :arg| - s nextPutAll: tok; nextPutAll:': '; nextPutAll: arg; nextPutAll:' '. - ]. - ]. - ! Item was removed: - ----- Method: Behavior>>startUp (in category 'system startup') ----- - startUp - "This message is sent to registered classes when the system is coming up." - ! Item was removed: - ----- Method: Behavior>>startUp: (in category 'system startup') ----- - startUp: resuming - "This message is sent to registered classes when the system is coming up. - resuming will be true if a snapshot is being resumed. resuming will be false - if the system is merely reinitializing after writing a snapshot." - ^self startUp! Item was removed: - ----- Method: Behavior>>startUpFrom: (in category 'system startup') ----- - startUpFrom: endiannessHasToBeFixed - "Override this when a per-instance startUp message needs to be sent. For example, to correct the order of 16-bit non-pointer data when it came from a different endian machine." - - ^ nil! Item was removed: - ----- Method: Behavior>>storeLiteral:on: (in category 'printing') ----- - storeLiteral: aCodeLiteral on: aStream - "Store aCodeLiteral on aStream, changing an Association to ##GlobalName - or ###MetaclassSoleInstanceName format if appropriate" - | key value | - (aCodeLiteral isVariableBinding) - ifFalse: - [aCodeLiteral storeOn: aStream. - ^self]. - key := aCodeLiteral key. - (key isNil and: [(value := aCodeLiteral value) isMemberOf: Metaclass]) - ifTrue: - [aStream nextPutAll: '###'; nextPutAll: value soleInstance name. - ^self]. - (key isSymbol and: [(self bindingOf: key) notNil]) - ifTrue: - [aStream nextPutAll: '##'; nextPutAll: key. - ^self]. - aCodeLiteral storeOn: aStream! Item was removed: - ----- Method: Behavior>>subclassDefinerClass (in category 'accessing') ----- - subclassDefinerClass - "Answer an evaluator class appropriate for evaluating definitions of new - subclasses of this class." - - ^Compiler! Item was removed: - ----- Method: Behavior>>subclassInstVarNames (in category 'accessing instances and variables') ----- - subclassInstVarNames - "Answer a Set of the names of the receiver's subclasses' instance - variables." - | vars | - vars := Set new. - self allSubclasses do: [:aSubclass | vars addAll: aSubclass instVarNames]. - ^vars! Item was removed: - ----- Method: Behavior>>subclasses (in category 'accessing class hierarchy') ----- - subclasses - "slow implementation since Behavior does not keep trace of subclasses" - - ^ self class allInstances select: [:each | each superclass = self ]! Item was removed: - ----- Method: Behavior>>superclass (in category 'accessing class hierarchy') ----- - superclass - "Answer the receiver's superclass, a Class." - - ^superclass! Item was removed: - ----- Method: Behavior>>superclass: (in category 'accessing class hierarchy') ----- - superclass: aClass - "Change the receiver's superclass to be aClass." - "Note: Do not use 'aClass isKindOf: Behavior' here - in case we recompile from Behavior itself." - (aClass == nil or: [aClass isBehavior]) - ifTrue: [superclass := aClass. - Object flushCache] - ifFalse: [self error: 'superclass must be a class-describing object']! Item was removed: - ----- Method: Behavior>>superclass:methodDictionary:format: (in category 'initialize-release') ----- - superclass: aClass methodDictionary: mDict format: fmt - "Basic initialization of the receiver. - Must only be sent to a new instance; else we would need Object flushCache." - superclass := aClass. - format := fmt. - methodDict := mDict.! Item was removed: - ----- Method: Behavior>>supermostPrecodeCommentFor: (in category 'accessing method dictionary') ----- - supermostPrecodeCommentFor: selector - "Answer a string representing the precode comment in the most distant - superclass's implementation of the selector. Return nil if none found." - | aSuper superComment | - (self == Behavior - or: [superclass == nil - or: [(aSuper := superclass whichClassIncludesSelector: selector) == nil]]) - ifFalse: ["There is a super implementor" - superComment := aSuper supermostPrecodeCommentFor: selector]. - ^ superComment - ifNil: [self firstPrecodeCommentFor: selector - "ActorState supermostPrecodeCommentFor: #printOn:"]! Item was removed: - ----- Method: Behavior>>traitComposition (in category 'Backstop-Traits') ----- - traitComposition - "Backstop. When traits are unloaded we never have a trait composition" - ^#()! Item was removed: - ----- Method: Behavior>>traitCompositionString (in category 'Backstop-Traits') ----- - traitCompositionString - "Backstop. Monticello needs a traitCompositionString even with traits unloaded" - ^'{}'! Item was removed: - ----- Method: Behavior>>typeOfClass (in category 'accessing') ----- - typeOfClass - "Answer a symbol uniquely describing the type of the receiver. c.f. kindOfSubclass, instSpec" - ^(#(normal - normal - variable - variable - weak - ephemeron - nil - immediate - nil - longs - words nil - shorts nil nil nil - bytes nil nil nil nil nil nil nil - compiledMethod nil nil nil nil nil nil nil) - at: self instSpec + 1) ifNil: - [self error: 'invalid class type']! Item was removed: - ----- Method: Behavior>>ultimateSourceCodeAt:ifAbsent: (in category 'accessing method dictionary') ----- - ultimateSourceCodeAt: selector ifAbsent: aBlock - "Return the source code at selector, deferring to superclass if necessary" - ^ self sourceCodeAt: selector ifAbsent: - [superclass - ifNil: - [aBlock value] - ifNotNil: - [superclass ultimateSourceCodeAt: selector ifAbsent: aBlock]]! Item was removed: - ----- Method: Behavior>>unreferencedInstanceVariables (in category 'user interface') ----- - unreferencedInstanceVariables - "Return a list of the instance variables defined in the receiver which are not referenced in the receiver or any of its subclasses." - - ^ self instVarNames select: - [:ivn | - self withAllSubclasses allSatisfy: - [:class | (class whichSelectorsAccess: ivn) isEmpty]]! Item was removed: - ----- Method: Behavior>>variablesAndOffsetsDo: (in category 'compiling') ----- - variablesAndOffsetsDo: aBinaryBlock - "This is the interface between the compiler and a class's instance or field names. The - class should enumerate aBinaryBlock with the field definitions (with nil offsets) followed - by the instance variable name strings and their integer offsets (1-relative). The order is - important; names evaluated later will override the same names occurring earlier." - - "Only need to do instance variables here. CProtoObject introduces field definitions." - self instVarNamesAndOffsetsDo: aBinaryBlock! Item was removed: - ----- Method: Behavior>>veryDeepCopyWith: (in category 'copying') ----- - veryDeepCopyWith: deepCopier - "Return self. Must be created, not copied. Do not record me."! Item was removed: - ----- Method: Behavior>>whichClassDefinesClassVar: (in category 'queries') ----- - whichClassDefinesClassVar: aString - - ^(Symbol lookup: aString) ifNotNil: [ :aSymbol | - ^self whichSuperclassSatisfies: - [:aClass | - aClass classVarNames anySatisfy: [:each | each = aSymbol]]]! Item was removed: - ----- Method: Behavior>>whichClassDefinesInstVar: (in category 'queries') ----- - whichClassDefinesInstVar: aString - ^self - whichSuperclassSatisfies: [:aClass | aClass instVarNames includes: aString]! Item was removed: - ----- Method: Behavior>>whichClassIncludesSelector: (in category 'testing method dictionary') ----- - whichClassIncludesSelector: aSymbol - "Answer the class on the receiver's superclass chain where the - argument, aSymbol (a message selector), will be found. Answer nil if none found." - "Rectangle whichClassIncludesSelector: #inspect." - (self includesSelector: aSymbol) - ifTrue: [^ self]. - superclass == nil - ifTrue: [^ nil]. - ^ superclass whichClassIncludesSelector: aSymbol! Item was removed: - ----- Method: Behavior>>whichMethodsStoreInto: (in category 'testing method dictionary') ----- - whichMethodsStoreInto: instVarName - "Answer a collection of CompiledMethod whose methods access the argument, instVarName, as a named instance variable." - - | instVarIndex | - instVarIndex := self instVarIndexFor: instVarName ifAbsent: [ ^Array new ]. - ^self methodDict values select: [:eachMethod | eachMethod writesField: instVarIndex ] - - "Point whichMethodsStoreInto: 'x'."! Item was removed: - ----- Method: Behavior>>whichSelectorsAccess: (in category 'testing method dictionary') ----- - whichSelectorsAccess: instVarName - "Answer a collection of selectors whose methods access the argument, instVarName, as a named instance variable." - "Point whichSelectorsAccess: 'x'." - - | instVarIndex | - instVarIndex := self instVarIndexFor: instVarName ifAbsent: [ ^Array new ]. - ^Array streamContents: [ :stream | - self selectorsAndMethodsDo: [ :selector :method | - ((method readsField: instVarIndex) or: [ - method writesField: instVarIndex ]) ifTrue: [ - stream nextPut: selector ] ] ] - ! Item was removed: - ----- Method: Behavior>>whichSelectorsRead: (in category 'queries') ----- - whichSelectorsRead: instVarName - "Answer a Set of selectors whose methods access the argument, - instVarName, as a named instance variable." - ^self whichSelectorsAccess: instVarName! Item was removed: - ----- Method: Behavior>>whichSelectorsReferTo: (in category 'testing method dictionary') ----- - whichSelectorsReferTo: literal - "Answer a Set of selectors whose methods access the argument as a literal. Note that we cannot use #systemNavigation because this method should not depend on the 'System' package." - - | who canBeSpecial | - canBeSpecial := BytecodeEncoder canBeSpecialLiteral: literal. - who := IdentitySet new. - self selectorsAndMethodsDo: [:selector :method | - (method hasLiteral: literal scanForSpecial: canBeSpecial) - ifTrue: [who add: selector]]. - ^ who - - "Rectangle whichSelectorsReferTo: #+."! Item was removed: - ----- Method: Behavior>>whichSelectorsStoreInto: (in category 'testing method dictionary') ----- - whichSelectorsStoreInto: instVarName - "Answer a collection of selectors whose methods access the argument, instVarName, as a named instance variable." - - | instVarIndex | - instVarIndex := self instVarIndexFor: instVarName ifAbsent: [ ^Array new ]. - ^ self methodDict keys select: - [:sel | (self methodDict at: sel) writesField: instVarIndex] - - "Point whichSelectorsStoreInto: 'x'."! Item was removed: - ----- Method: Behavior>>whichSuperclassSatisfies: (in category 'queries') ----- - whichSuperclassSatisfies: aBlock - (aBlock value: self) ifTrue: [^self]. - ^superclass isNil - ifTrue: [nil] - ifFalse: [superclass whichSuperclassSatisfies: aBlock]! Item was removed: - ----- Method: Behavior>>withAllSubAndSuperclassesDo: (in category 'user interface') ----- - withAllSubAndSuperclassesDo: aBlock - - self withAllSubclassesDo: aBlock. - self allSuperclassesDo: aBlock. - ! Item was removed: - ----- Method: Behavior>>withAllSubclasses (in category 'accessing class hierarchy') ----- - withAllSubclasses - "Answer a Collection of the receiver, the receiver's descendent's, and the - receiver's descendent's subclasses." - - ^ self allSubclasses addFirst: self; - yourself! Item was removed: - ----- Method: Behavior>>withAllSubclassesDo: (in category 'enumerating') ----- - withAllSubclassesDo: aBlock - "Evaluate the argument, aBlock, for the receiver and each of its - subclasses." - - aBlock value: self. - self allSubclassesDo: aBlock! Item was removed: - ----- Method: Behavior>>withAllSuperAndSubclassesDo: (in category 'enumerating') ----- - withAllSuperAndSubclassesDo: aBlock - self allSuperclassesDo: aBlock. - aBlock value: self. - self allSubclassesDo: aBlock! Item was removed: - ----- Method: Behavior>>withAllSuperAndSubclassesDoGently: (in category 'enumerating') ----- - withAllSuperAndSubclassesDoGently: aBlock - self allSuperclassesDo: aBlock. - aBlock value: self. - self allSubclassesDoGently: aBlock! Item was removed: - ----- Method: Behavior>>withAllSuperclasses (in category 'accessing class hierarchy') ----- - withAllSuperclasses - "Answer an OrderedCollection of the receiver and the receiver's - superclasses. The first element is the receiver, - followed by its superclass; the last element is Object." - - | temp | - temp := self allSuperclasses. - temp addFirst: self. - ^ temp! Item was removed: - ----- Method: Behavior>>withAllSuperclassesDo: (in category 'enumerating') ----- - withAllSuperclassesDo: aBlock - "Evaluate the argument, aBlock, for each of the receiver's superclasses." - aBlock value: self. - superclass == nil - ifFalse: [superclass withAllSuperclassesDo: aBlock]! Item was removed: - ----- Method: Behavior>>zapAllMethods (in category 'accessing method dictionary') ----- - zapAllMethods - "Remove all methods in this class which is assumed to be obsolete" - - methodDict := self emptyMethodDictionary. - self class isMeta ifTrue: [self class zapAllMethods]! Item was removed: - ModificationForbidden subclass: #BinaryModificationForbidden - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Kernel-Exceptions'! - - !BinaryModificationForbidden commentStamp: 'eem 3/11/2020 15:56' prior: 0! - A BinaryModificationForbidden is a variation of ModificationForbidden for messages that need neither fieldIndex nor newObject, such as elementsExchangeIdentityWith: and adoptInstance:. It overrides the retryModification method. - - Instance Variables - ! Item was removed: - ----- Method: BinaryModificationForbidden>>retryModification (in category 'retrying') ----- - retryModification - mirror perform: retrySelector with: object. - self resume: resumptionValue! Item was removed: - ----- Method: BinaryModificationForbidden>>retryModificationNoResume (in category 'retrying') ----- - retryModificationNoResume - mirror perform: retrySelector with: object! Item was removed: - Error subclass: #BlockCannotReturn - instanceVariableNames: 'result deadHome' - classVariableNames: '' - poolDictionaries: '' - category: 'Kernel-Exceptions'! - - !BlockCannotReturn commentStamp: '<historical>' prior: 0! - This class is private to the EHS implementation. Its use allows for ensured execution to survive code such as: - - [self doThis. - ^nil] - ensure: [self doThat] - - Signaling or handling this exception is not recommended.! Item was removed: - ----- Method: BlockCannotReturn>>deadHome (in category 'accessing') ----- - deadHome - - ^ deadHome! Item was removed: - ----- Method: BlockCannotReturn>>deadHome: (in category 'accessing') ----- - deadHome: context - - deadHome := context! Item was removed: - ----- Method: BlockCannotReturn>>defaultAction (in category 'exceptionDescription') ----- - defaultAction - - self messageText: 'Block cannot return'. - ^super defaultAction! Item was removed: - ----- Method: BlockCannotReturn>>isResumable (in category 'exceptionDescription') ----- - isResumable - - ^true! Item was removed: - ----- Method: BlockCannotReturn>>result (in category 'accessing') ----- - result - - ^result! Item was removed: - ----- Method: BlockCannotReturn>>result: (in category 'accessing') ----- - result: r - - result := r! Item was removed: - Object variableSubclass: #BlockClosure - instanceVariableNames: 'outerContext startpcOrMethod numArgs' - classVariableNames: '' - poolDictionaries: '' - category: 'Kernel-Methods'! - - !BlockClosure commentStamp: 'eem 5/1/2020 10:04' prior: 0! - Instances of BlockClosure represent blocks, a sequence of statements inside square brackets that can be evaluated at any time via one of the value messages (value, value:, value:value:, ... valueWithArguments:), which answer their last statement. Blocks therefore allow deferred evaluation and so are used to build control structures where a sequence of statements are evaluated or not depending on other values in the program. - - Blocks can close over variables in their enclosing method or block. The method in which a block is nested is called its home method. Blocks can return from their home method via an up-arrow return, and return to the sender of the message that created the home method, just like a return from the method itself. BlockClosures are fully first-class objects; they can outlive their enclosing method activation and be answered as results and/or assigned to variables. - - BlockClosures are central to the implementation of control structures in Smalltalk. The arguments to the conditional message ifTrue:ifFalse: are zero-argument blocks; the receiver of ifTrue:ifFalse: is a boolean which responds by evaluating ether the first argument or the second. The bytecode compiler inlines blocks for certain selectors, compiling to conditional branch and branch bytecodes. This is done for efficiency. The full list of inlined messages can be found in MessageNode's MacroSelectors class variable (at time of writing ther=se are ifTrue:, ifFalse:, ifTrue:ifFalse:, ifFalse:ifTrue:, and:, or:, whileFalse:, whileTrue:, whileFalse, whileTrue, to:do:, to:by:do:, caseOf:, caseOf:otherwise:, ifNil:, ifNotNil:, ifNil:ifNotNil:, ifNotNil:ifNil: and repeat. - - Examples (more can be found in BlockClosureTest's class comment): - [1 at 2] value - - | counter | - counter := 0. - { counter. (1 to: 10) collect: [:n| counter := counter + 1. n + counter]. counter } - - | fibonacciBlock | - fibonacciBlock := [:n| - n > 1 ifTrue: [(fibonacciBlock value: n - 1) + (fibonacciBlock value: n - 2)] ifFalse: [1]]. - (1 to: 10) collect: fibonacciBlock - - | randomNumbers | - randomNumbers := Random new next: 20. - { randomNumbers. randomNumbers sorted: [:a :b| a > b] } - - Implementation: - BlockClosure implements blocks that are nested within an enclosing method or block context. Further, the bytecodes for the block are embedded within the home method. BlockClosure's subclass FullBlockClosure has an independent CompiledBlock as its method, and may or may not have an outerContext. - - Instance Variables - numArgs: <Integer> - outerContext: <Context> - startpcOrMethod: <Integer|CompiledBlock> - - numArgs - - the number of arguments the block expects - - outerContext - - the Context of the method or block activation in which the receiver is created - - startpcOrMethod - - in BlockClosure this is the pc of the first bytecode of the block. Its bytecodes are embedded in the bytecodes of the home method. In FullBlockClosure this is the block's method.! Item was removed: - ----- Method: BlockClosure class>>outerContext:startpc:numArgs:copiedValues: (in category 'instance creation') ----- - outerContext: aContext startpc: aStartpc numArgs: argCount copiedValues: anArrayOrNil - ^(self new: anArrayOrNil basicSize) - outerContext: aContext - startpc: aStartpc - numArgs: argCount - copiedValues: anArrayOrNil! Item was removed: - ----- Method: BlockClosure>>= (in category 'comparing') ----- - = aClosure - self == aClosure ifTrue: [^true]. - aClosure class = self class ifFalse: [^false]. - (self method == aClosure method and: [self startpc = aClosure startpc and: [self isClean]]) - ifTrue: [^true]. - ^outerContext = aClosure outerContext and: [self startpc = aClosure startpc]! Item was removed: - ----- Method: BlockClosure>>abstractBytecodeMessagesDo: (in category 'scanning') ----- - abstractBytecodeMessagesDo: aBlock - "Evaluate aBlock with the sequence of abstract bytecodes in the receiver." - self method - abstractBytecodeMessagesFrom: startpcOrMethod - to: self endPC - do: aBlock - - "| msgs | - msgs := OrderedCollection new. - (SortedCollection sortBlock: [:a :b| a compare: b caseSensitive: false]) sortBlock - abstractBytecodeMessagesDo: [:msg| msgs add: msg selector]. - msgs"! Item was removed: - ----- Method: BlockClosure>>argumentCount (in category 'accessing') ----- - argumentCount - "Answers the number of arguments needed to evaluate the receiver. - For ansi compatibility." - ^ self numArgs! Item was removed: - ----- Method: BlockClosure>>asContext (in category 'scheduling') ----- - asContext - "Create a Context that is ready to execute self. Assumes self takes no args (if it does the args will be nil)" - - ^self asContextWithSender: nil! Item was removed: - ----- Method: BlockClosure>>asContextWithSender: (in category 'private') ----- - asContextWithSender: aContext - "Inner private support method for evaluation. Do not use unless you know what you're doing." - - ^(Context newForMethod: outerContext method) - setSender: aContext - receiver: outerContext receiver - method: outerContext method - closure: self - startpc: startpcOrMethod; - privRefresh! Item was removed: - ----- Method: BlockClosure>>asMinimalRepresentation (in category 'events-support') ----- - asMinimalRepresentation - "For use in the when:evaluate: protocol, i.e., - foo when: #bar evaluate:[self handleBar]. - Return the receiver." - ^self! Item was removed: - ----- Method: BlockClosure>>assert (in category 'exceptions') ----- - assert - self assert: self! Item was removed: - ----- Method: BlockClosure>>blockCreationBytecodeMessage (in category 'scanning') ----- - blockCreationBytecodeMessage - "Answer the abstract bytecode message that created the receiver." - ^self method abstractBytecodeMessageAt: self blockCreationPC - - "(SortedCollection sortBlock: [:a :b| a compare: b caseSensitive: false]) sortBlock blockCreationBytecodeMessage"! Item was removed: - ----- Method: BlockClosure>>blockCreationPC (in category 'scanning') ----- - blockCreationPC - "Answer the pc for the bytecode that created the receiver." - | method | - method := self method. - ^method encoderClass - pcOfBlockCreationBytecodeForBlockStartingAt: startpcOrMethod - in: method! Item was removed: - ----- Method: BlockClosure>>copiedValueAt: (in category 'accessing') ----- - copiedValueAt: i - <primitive: 60> - ^self basicAt: i! Item was removed: - ----- Method: BlockClosure>>copyForSaving (in category 'private') ----- - copyForSaving - "Answer a copy of the receiver suitable for serialization. - Notionally, if the receiver's outerContext has been returned from then nothing - needs to be done and we can use the receiver. But there's a race condition - determining if the receiver has been returned from (it could be executing in a - different process). So answer a copy anyway." - ^self shallowCopy postCopy! Item was removed: - ----- Method: BlockClosure>>cull: (in category 'evaluating') ----- - cull: firstArg - "Activate the receiver, with one or zero arguments." - <primitive: 202> "Handle the one argument case primitively" - numArgs >= 1 ifTrue: [ ^self value: firstArg ]. - ^self value! Item was removed: - ----- Method: BlockClosure>>cull:cull: (in category 'evaluating') ----- - cull: firstArg cull: secondArg - "Activate the receiver, with two or less arguments." - <primitive: 203> "Handle the two argument case primitively" - numArgs >= 2 ifTrue: [ ^self value: firstArg value: secondArg ]. - numArgs = 1 ifTrue: [ ^self value: firstArg ]. - ^self value! Item was removed: - ----- Method: BlockClosure>>cull:cull:cull: (in category 'evaluating') ----- - cull: firstArg cull: secondArg cull: thirdArg - "Activate the receiver, with three or less arguments." - <primitive: 204> "Handle the three argument case primitively" - numArgs >= 2 ifTrue: [ - numArgs >= 3 ifTrue: [ ^self value: firstArg value: secondArg value: thirdArg ]. - ^self value: firstArg value: secondArg ]. - numArgs = 1 ifTrue: [ ^self value: firstArg ]. - ^self value! Item was removed: - ----- Method: BlockClosure>>cull:cull:cull:cull: (in category 'evaluating') ----- - cull: firstArg cull: secondArg cull: thirdArg cull: fourthArg - "Activate the receiver, with four or less arguments." - <primitive: 205> "Handle the four argument case primitively" - numArgs >= 3 ifTrue: [ - numArgs >= 4 ifTrue: [ - ^self value: firstArg value: secondArg value: thirdArg value: fourthArg ]. - ^self value: firstArg value: secondArg value: thirdArg ]. - numArgs = 2 ifTrue: [ ^self value: firstArg value: secondArg ]. - numArgs = 1 ifTrue: [ ^self value: firstArg ]. - ^self value! Item was removed: - ----- Method: BlockClosure>>cull:cull:cull:cull:cull: (in category 'evaluating') ----- - cull: firstArg cull: secondArg cull: thirdArg cull: fourthArg cull: fifthArg - "Activate the receiver, with five or less arguments." - <primitive: 206> "Handle the five argument case primitively" - - ^ numArgs - caseOf: { - [5] -> [self value: firstArg value: secondArg value: thirdArg value: fourthArg value: fifthArg]. - [4] -> [self value: firstArg value: secondArg value: thirdArg value: fourthArg]. - [3] -> [self value: firstArg value: secondArg value: thirdArg]. - [2] -> [self value: firstArg value: secondArg]. - [1] -> [self value: firstArg]. - [0] -> [self value] } - otherwise: [self numArgsError: numArgs]! Item was removed: - ----- Method: BlockClosure>>decompile (in category 'printing') ----- - decompile - ^Decompiler new decompileBlock: self! Item was removed: - ----- Method: BlockClosure>>doWhileFalse: (in category 'controlling') ----- - doWhileFalse: conditionBlock - "Evaluate the receiver once, then again as long the value of conditionBlock is false." - - | result | - [result := self value. - conditionBlock value] whileFalse. - - ^ result! Item was removed: - ----- Method: BlockClosure>>doWhileTrue: (in category 'controlling') ----- - doWhileTrue: conditionBlock - "Evaluate the receiver once, then again as long the value of conditionBlock is true." - - | result | - [result := self value. - conditionBlock value] whileTrue. - - ^ result! Item was removed: - ----- Method: BlockClosure>>endPC (in category 'accessing') ----- - endPC - ^self blockCreationBytecodeMessage arguments last + startpcOrMethod - 1! Item was removed: - ----- Method: BlockClosure>>ensure: (in category 'exceptions') ----- - ensure: aBlock - "Evaluate a termination block after evaluating the receiver, regardless of - whether the receiver's evaluation completes. N.B. This method is *not* - implemented as a primitive. Primitive 198 always fails. The VM uses prim - 198 in a context's method as the mark for an ensure:/ifCurtailed: activation." - - | complete returnValue | - <primitive: 198> - returnValue := self valueNoContextSwitch. - complete ifNil:[ - complete := true. - aBlock value. - ]. - ^ returnValue! Item was removed: - ----- Method: BlockClosure>>fixTemps (in category 'private') ----- - fixTemps - "Fix the values of the temporary variables used in the block that - are ordinarily shared with the method in which the block is defined. - This is a no-op for closures, provided for backward-compatibility with - old BlockContexts that needed the fixTemps hack to persist."! Item was removed: - ----- Method: BlockClosure>>fork (in category 'scheduling') ----- - fork - "Create and schedule a Process running the code in the receiver." - - ^ self newProcess resume! Item was removed: - ----- Method: BlockClosure>>forkAndWait (in category 'scheduling') ----- - forkAndWait - "Suspend current process and execute self in new process, when it completes resume current process" - - | semaphore | - semaphore := Semaphore new. - [self ensure: [semaphore signal]] fork. - semaphore wait. - ! Item was removed: - ----- Method: BlockClosure>>forkAt: (in category 'scheduling') ----- - forkAt: priority - "Create and schedule a Process running the code in the receiver at the given priority. Answer the newly created process." - - ^ self newProcess - priority: priority; - resume! Item was removed: - ----- Method: BlockClosure>>forkAt:named: (in category 'scheduling') ----- - forkAt: priority named: name - - "Create and schedule a Process running the code in the receiver at the - - given priority and having the given name. Answer the newly created - - process." - - - - | forkedProcess | - - forkedProcess := self newProcess. - - forkedProcess priority: priority. - - forkedProcess name: name. - - ^ forkedProcess resume! Item was removed: - ----- Method: BlockClosure>>forkNamed: (in category 'scheduling') ----- - forkNamed: aString - - "Create and schedule a Process running the code in the receiver and - - having the given name." - - - - ^ self newProcess name: aString; resume! Item was removed: - ----- Method: BlockClosure>>fullPrintOn: (in category 'printing') ----- - fullPrintOn: aStream - aStream - print: self ; - cr. - self printSourceOn: aStream! Item was removed: - ----- Method: BlockClosure>>hasMethodReturn (in category 'testing') ----- - hasMethodReturn - "Answer whether the receiver has a method-return ('^') in its code." - | scanner endpc | - scanner := InstructionStream new method: outerContext method pc: startpcOrMethod. - endpc := self endPC. - scanner scanFor: [:byte | (byte between: 120 and: 124) or: [scanner pc > endpc]]. - ^scanner pc <= endpc! Item was removed: - ----- Method: BlockClosure>>hash (in category 'comparing') ----- - hash - ^(self method hash + startpcOrMethod hash) hashMultiply! Item was removed: - ----- Method: BlockClosure>>home (in category 'accessing') ----- - home - ^outerContext home! Item was removed: - ----- Method: BlockClosure>>homeMethod (in category 'accessing') ----- - homeMethod - ^outerContext method! Item was removed: - ----- Method: BlockClosure>>ifCurtailed: (in category 'exceptions') ----- - ifCurtailed: aBlock - "Evaluate the receiver with an abnormal termination action. - Evaluate aBlock only if execution is unwound during execution - of the receiver. If execution of the receiver finishes normally do - not evaluate aBlock. N.B. This method is *not* implemented as a - primitive. Primitive 198 always fails. The VM uses prim 198 in a - context's method as the mark for an ensure:/ifCurtailed: activation." - | complete result | - <primitive: 198> - result := self valueNoContextSwitch. - complete := true. - ^result! Item was removed: - ----- Method: BlockClosure>>ifError: (in category 'evaluating') ----- - ifError: errorHandlerBlock - "Evaluate the block represented by the receiver, and normally return it's value. If an error occurs, the errorHandlerBlock is evaluated, and it's value is instead returned. The errorHandlerBlock must accept zero, one, or two parameters (the error message and the receiver)." - "Examples: - [1 whatsUpDoc] ifError: [:err :rcvr | 'huh?']. - [1 / 0] ifError: [:err :rcvr | - 'ZeroDivide' = err - ifTrue: [Float infinity] - ifFalse: [self error: err]] - " - - ^ self on: Error do: [:ex | - errorHandlerBlock cull: ex description cull: ex receiver ]! Item was removed: - ----- Method: BlockClosure>>isBlock (in category 'accessing') ----- - isBlock - - ^ true! Item was removed: - ----- Method: BlockClosure>>isClean (in category 'testing') ----- - isClean - "Answer if the receiver does not close-over any variables other than globals, and does - not ^-return (does not close over the home context). Clean blocks are amenable to - being created at compile-time." - self numCopiedValues > 0 ifTrue: - [^false]. - self abstractBytecodeMessagesDo: - [:msg| - (#( pushReceiver - pushReceiverVariable: popIntoReceiverVariable: storeIntoReceiverVariable: - methodReturnConstant: methodReturnReceiver methodReturnTop) - includes: msg selector) ifTrue: - [^false]]. - ^true - - "clean:" - "[] isClean" - "[:a :b| a < b] isClean" - "unclean" - "[^nil] isClean" - "[self class] isClean" - "| v | v := 0. - [v class] isClean"! Item was removed: - ----- Method: BlockClosure>>isClosure (in category 'testing') ----- - isClosure - ^true! Item was removed: - ----- Method: BlockClosure>>isDead (in category 'testing') ----- - isDead - "Has self finished" - ^false! Item was removed: - ----- Method: BlockClosure>>isFullBlock (in category 'testing') ----- - isFullBlock - ^false! Item was removed: - ----- Method: BlockClosure>>isNestedWithin: (in category 'testing') ----- - isNestedWithin: aContextOrBlock - "Answer if the receiver is nested within aContextOrBlock, which may be ither a Context, or a BlockClosure." - aContextOrBlock ifNotNil: - [self outerContextsDo: - [:ctxt| - (ctxt == aContextOrBlock - or: [ctxt closure = aContextOrBlock]) ifTrue: [^true]]]. - ^false! Item was removed: - ----- Method: BlockClosure>>isReceiverOrAnyArgumentGarbage (in category 'events-support') ----- - isReceiverOrAnyArgumentGarbage - "For use in the when:evaluate: protocol, i.e., - foo when: #bar evaluate:[self handleBar].." - ^false! Item was removed: - ----- Method: BlockClosure>>method (in category 'accessing') ----- - method - ^outerContext method! Item was removed: - ----- Method: BlockClosure>>newProcess (in category 'scheduling') ----- - newProcess - "Answer a Process running the code in the receiver. The process is not scheduled." - ^Process - forContext: - [self value. - "Since control is now at the bottom, there is no need to terminate (which runs unwinds) since all unwinds have been run. Simply suspend. - Note that we must use this form rather than e.g. Processor suspendActive so that isTerminated answers true. isTerminated requires that if there is a suspended context it is the bottom-most, but using a send would result in the process's suspendedContext /not/ being the bottom-most." - Processor activeProcess suspend] asContext - priority: Processor activePriority! Item was removed: - ----- Method: BlockClosure>>newProcessWith: (in category 'scheduling') ----- - newProcessWith: anArray - "Answer a Process running the code in the receiver. The receiver's block arguments are bound to the contents of the argument, anArray. The process is not scheduled." - ^Process - forContext: - [self valueWithArguments: anArray. - "Since control is now at the bottom, there is no need to terminate (which runs unwinds) since all unwinds have been run. Simply suspend. - Note that we must use this form rather than e.g. Processor suspendActive so that isTerminated answers true. isTerminated requires that if there is a suspended context it is the bottom-most, but using a send would result in the process's suspendedContext /not/ being the bottom-most." - Processor activeProcess suspend] asContext - priority: Processor activePriority! Item was removed: - ----- Method: BlockClosure>>numArgs (in category 'accessing') ----- - numArgs - "Answer the number of arguments that must be used to evaluate this block" - - ^numArgs! Item was removed: - ----- Method: BlockClosure>>numArgsError: (in category 'error handing') ----- - numArgsError: numArgsForInvocation - - | printNArgs | - printNArgs := [:n| n printString, ' argument', (n = 1 ifTrue: [''] ifFalse:['s'])]. - self error: - 'This block accepts ', (printNArgs value: numArgs), - ', but was called with ', (printNArgs value: numArgsForInvocation), '.'! Item was removed: - ----- Method: BlockClosure>>numCopiedValues (in category 'accessing') ----- - numCopiedValues - "Answer the number of copied values of the receiver. Since these are - stored in the receiver's indexable fields this is the receiver's basic size. - Primitive. Answer the number of indexable variables in the receiver. - This value is the same as the largest legal subscript." - - <primitive: 62> - ^self basicSize! Item was removed: - ----- Method: BlockClosure>>numTemps (in category 'accessing') ----- - numTemps - "Answer the number of temporaries for the receiver; this includes - the number of arguments and the number of copied values." - ^self numCopiedValues - + self numArgs - + (BlockLocalTempCounter - tempCountForBlockStartingAt: startpcOrMethod - in: self method)! Item was removed: - ----- Method: BlockClosure>>on:do: (in category 'exceptions') ----- - on: exceptionOrExceptionSet do: handlerAction - "Evaluate the receiver in the scope of an exception handler." - - | handlerActive handlerRearmed | - <primitive: 199> "just a marker, fail and execute the following" - handlerActive := true. - handlerRearmed := false. - ^ self value! Item was removed: - ----- Method: BlockClosure>>on:do:on:do: (in category 'exceptions') ----- - on: exception1 do: block1 on: exception2 do: block2 - - ^[ - self - on: exception1 - do: block1 ] - on: exception2 - do: block2! Item was removed: - ----- Method: BlockClosure>>on:do:on:do:on:do: (in category 'exceptions') ----- - on: exception1 do: block1 on: exception2 do: block2 on: exception3 do: block3 - - ^[ - self - on: exception1 - do: block1 ] - on: exception2 - do: block2 - on: exception3 - do: block3! Item was removed: - ----- Method: BlockClosure>>on:ensure: (in category 'exceptions') ----- - on: exceptionOrExceptionSet ensure: aBlock - - ^ self - on: exceptionOrExceptionSet - do: [:exception | - aBlock value. - exception pass]! Item was removed: - ----- Method: BlockClosure>>on:ensure:on:ensure: (in category 'exceptions') ----- - on: anException1 ensure: aBlock1 on: anException2 ensure: aBlock2 - - ^ [self on: anException1 ensure: aBlock1] - on: anException2 - ensure: aBlock2! Item was removed: - ----- Method: BlockClosure>>on:ensure:on:ensure:on:ensure: (in category 'exceptions') ----- - on: anException1 ensure: aBlock1 on: anException2 ensure: aBlock2 on: anException3 ensure: aBlock3 - - ^ [self on: anException1 ensure: aBlock1] - on: anException2 - ensure: aBlock2 - on: anException3 - ensure: aBlock3! Item was removed: - ----- Method: BlockClosure>>onDNU:do: (in category 'exceptions') ----- - onDNU: selector do: handleBlock - "Catch MessageNotUnderstood exceptions but only those of the given selector (DNU stands for doesNotUnderstand:)" - - ^ self on: MessageNotUnderstood do: [:exception | - exception message selector = selector - ifTrue: [handleBlock cull: exception] - ifFalse: [exception pass] - ]! Item was removed: - ----- Method: BlockClosure>>once (in category 'evaluating') ----- - once - "Evaluate the receiver exactly once, so that repeated evaluations - answer exactly the same object as the first evaluation. This - allows one to intern values with the idiom - myResourceMethod - ^[expression] once" - - | cache | - cache := self method - propertyValueAt: #onceCache - ifAbsent: [self method propertyValueAt: #onceCache put: IdentityDictionary new]. - ^cache at: startpcOrMethod ifAbsentPut: [self value]! Item was removed: - ----- Method: BlockClosure>>outerContext (in category 'accessing') ----- - outerContext - ^outerContext! Item was removed: - ----- Method: BlockClosure>>outerContext:startpc:numArgs:copiedValues: (in category 'initialize-release') ----- - outerContext: aContext startpc: aStartpc numArgs: argCount copiedValues: anArrayOrNil - outerContext := aContext. - startpcOrMethod := aStartpc. - numArgs := argCount. - 1 to: self numCopiedValues do: - [:i| - self at: i put: (anArrayOrNil at: i)]! Item was removed: - ----- Method: BlockClosure>>outerContextsDo: (in category 'private') ----- - outerContextsDo: aBlock - "Evaluate aBlock with all the outer contexts along the receiver's static chain." - | outer | - outer := outerContext. - [outer notNil] whileTrue: - [aBlock value: outer. - outer := outer closure ifNotNil: [:outerClosure| outerClosure outerContext]]! Item was removed: - ----- Method: BlockClosure>>printOn: (in category 'printing') ----- - printOn: aStream - aStream nextPutAll: '[closure] in '. - outerContext printOn: aStream! Item was removed: - ----- Method: BlockClosure>>printSourceOn: (in category 'printing') ----- - printSourceOn: aStream - self decompile - ifNil: [ aStream nextPutAll: '--source missing--' ] - ifNotNil: [ : blockNode | blockNode printOn: aStream indent: 0 ]! Item was removed: - ----- Method: BlockClosure>>receiver (in category 'accessing') ----- - receiver - ^outerContext receiver! Item was removed: - ----- Method: BlockClosure>>reentrant (in category 'private') ----- - reentrant - "Answer a version of the recever that can be reentered. - Closures are reentrant (unlike BlockContext), so simply answer self." - ^self! Item was removed: - ----- Method: BlockClosure>>repeat (in category 'controlling') ----- - repeat - "Evaluate the receiver repeatedly, ending only if the block explicitly returns." - - [self value. true] whileTrue! Item was removed: - ----- Method: BlockClosure>>repeatWithGCIf: (in category 'controlling') ----- - repeatWithGCIf: testBlock - | ans | - "run the receiver, and if testBlock returns true, garbage collect and run the receiver again" - ans := self value. - (testBlock value: ans) ifTrue: [ Smalltalk garbageCollect. ans := self value ]. - ^ans! Item was removed: - ----- Method: BlockClosure>>sender (in category 'debugger access') ----- - sender - "Answer the context that sent the message that created the receiver." - - ^outerContext sender! Item was removed: - ----- 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 | - newContext := (Context newForMethod: outerContext method) - setSender: aContext - receiver: outerContext receiver - method: outerContext method - closure: self - startpc: startpcOrMethod. - ((newContext objectClass: anArray) ~~ Array - or: [numArgs ~= anArray size]) ifTrue: - [^Context 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 removed: - ----- Method: BlockClosure>>size (in category 'accessing') ----- - size - "Extract this closure's bytecode size (number of bytes) by accessing - the closure creation bytecode in the enclosing method." - - ^self blockCreationBytecodeMessage arguments last! Item was removed: - ----- Method: BlockClosure>>sourceString (in category 'printing') ----- - sourceString - ^ String streamContents: [ : stream | self printSourceOn: stream ]! Item was removed: - ----- Method: BlockClosure>>startpc (in category 'accessing') ----- - startpc - ^startpcOrMethod! Item was removed: - ----- Method: BlockClosure>>storeDataOn: (in category 'objects from disk') ----- - storeDataOn: aDataStream - "Blocks are allowed go to out in DataStreams, but only without home senders." - - | contexts | - contexts := IdentitySet new. - aDataStream insideASegment ifFalse: - [self outerContextsDo: - [:ctxt| - contexts add: ctxt. - aDataStream replace: ctxt sender with: nil]]. - ^[super storeDataOn: aDataStream] - on: Notification - do: [:ex| - (contexts includes: ex tag) - ifTrue: [ex resume: ex tag] - ifFalse: [ex pass]]! Item was removed: - ----- Method: BlockClosure>>value (in category 'evaluating') ----- - value - "Activate the receiver, creating a closure activation (Context) - whose closure is the receiver and whose caller is the sender of this - message. Supply the copied values to the activation as its copied - temps. Primitive. Essential." - <primitive: 201> - numArgs ~= 0 ifTrue: - [self numArgsError: 0]. - ^self primitiveFailed! Item was removed: - ----- Method: BlockClosure>>value: (in category 'evaluating') ----- - value: firstArg - "Activate the receiver, creating a closure activation (Context) - whose closure is the receiver and whose caller is the sender of this - message. Supply the argument and copied values to the activation - as its argument and copied temps. Primitive. Essential." - <primitive: 202> - numArgs ~= 1 ifTrue: - [self numArgsError: 1]. - ^self primitiveFailed! Item was removed: - ----- Method: BlockClosure>>value:value: (in category 'evaluating') ----- - value: firstArg value: secondArg - "Activate the receiver, creating a closure activation (Context) - whose closure is the receiver and whose caller is the sender of this - message. Supply the arguments and copied values to the activation - as its arguments and copied temps. Primitive. Essential." - <primitive: 203> - numArgs ~= 2 ifTrue: - [self numArgsError: 2]. - ^self primitiveFailed! Item was removed: - ----- Method: BlockClosure>>value:value:value: (in category 'evaluating') ----- - value: firstArg value: secondArg value: thirdArg - "Activate the receiver, creating a closure activation (Context) - whose closure is the receiver and whose caller is the sender of this - message. Supply the arguments and copied values to the activation - as its arguments and copied temps. Primitive. Essential." - <primitive: 204> - numArgs ~= 3 ifTrue: - [self numArgsError: 3]. - ^self primitiveFailed! Item was removed: - ----- Method: BlockClosure>>value:value:value:value: (in category 'evaluating') ----- - value: firstArg value: secondArg value: thirdArg value: fourthArg - "Activate the receiver, creating a closure activation (Context) - whose closure is the receiver and whose caller is the sender of this - message. Supply the arguments and copied values to the activation - as its arguments and copied temps. Primitive. Essential." - <primitive: 205> - numArgs ~= 4 ifTrue: - [self numArgsError: 4]. - ^self primitiveFailed! Item was removed: - ----- Method: BlockClosure>>value:value:value:value:value: (in category 'evaluating') ----- - value: firstArg value: secondArg value: thirdArg value: fourthArg value: fifthArg - "Activate the receiver, creating a closure activation (Context) - whose closure is the receiver and whose caller is the sender of this - message. Supply the arguments and copied values to the activation - as its arguments and copied temps. Primitive. Essential." - <primitive: 205> - numArgs ~= 5 ifTrue: - [self numArgsError: 5]. - ^self primitiveFailed! Item was removed: - ----- Method: BlockClosure>>valueAt: (in category 'evaluating') ----- - valueAt: blockPriority - "Evaluate the receiver (block), with another priority as the actual one - and restore it afterwards. The caller should be careful with using - higher priorities." - | activeProcess result outsidePriority | - activeProcess := Processor activeProcess. - outsidePriority := activeProcess priority. - activeProcess priority: blockPriority. - result := self ensure: [activeProcess priority: outsidePriority]. - "Yield after restoring lower priority to give the preempted processes a - chance to run." - blockPriority > outsidePriority - ifTrue: [Processor yield]. - ^ result! Item was removed: - ----- Method: BlockClosure>>valueNoContextSwitch (in category 'evaluating') ----- - valueNoContextSwitch - "An exact copy of BlockClosure>>value except that this version will not preempt - the current process on block activation if a higher-priority process is runnable. - Primitive. Essential." - <primitive: 221> - numArgs ~= 0 ifTrue: - [self numArgsError: 0]. - self primitiveFailed! Item was removed: - ----- Method: BlockClosure>>valueNoContextSwitch: (in category 'evaluating') ----- - valueNoContextSwitch: anArg - "An exact copy of BlockClosure>>value: except that this version will not preempt - the current process on block activation if a higher-priority process is runnable. - Primitive. Essential." - <primitive: 222> - numArgs ~= 1 ifTrue: - [self numArgsError: 1]. - self primitiveFailed! Item was removed: - ----- Method: BlockClosure>>valueOtherwise: (in category 'evaluating') ----- - valueOtherwise: aBlock - "Send the message and answer the return value" - - ^self value! Item was removed: - ----- Method: BlockClosure>>valueSupplyingAnswer: (in category 'evaluating') ----- - valueSupplyingAnswer: anObject - - ^ (anObject isCollection and: [anObject isString not]) - ifTrue: [self valueSupplyingAnswers: {anObject}] - ifFalse: [self valueSupplyingAnswers: {{'*'. anObject}}]! Item was removed: - ----- Method: BlockClosure>>valueSupplyingAnswers: (in category 'evaluating') ----- - valueSupplyingAnswers: aListOfPairs - "Evaluate the receiver using a list of questions / answers that might be called upon to automatically respond to Object>>confirm: or FillInTheBlank requests" - - ^ self on: ProvideAnswerNotification do: [ :notification | - | caption | - caption := notification messageText withSeparatorsCompacted. "to remove new lines" - aListOfPairs - detect: [ :each | - caption = each first - or: [ (caption includesSubstring: each first caseSensitive: false) - or: [ (each first match: caption) - or: [ (caption respondsTo: #matchesRegex:) - and: [ [caption matchesRegex: each first] ifError: [false] ] ] ] ] ] - ifFound: [ :answer | notification resume: answer second ] - ifNone: [ notification pass ] ]! Item was removed: - ----- Method: BlockClosure>>valueSuppressingAllMessages (in category 'evaluating') ----- - valueSuppressingAllMessages - - ^ self valueSuppressingMessages: #('*')! Item was removed: - ----- Method: BlockClosure>>valueSuppressingMessages: (in category 'evaluating') ----- - valueSuppressingMessages: aListOfStrings - - ^ self - valueSuppressingMessages: aListOfStrings - supplyingAnswers: #()! Item was removed: - ----- Method: BlockClosure>>valueSuppressingMessages:supplyingAnswers: (in category 'evaluating') ----- - valueSuppressingMessages: aListOfStrings supplyingAnswers: aListOfPairs - - ^ self valueSupplyingAnswers: aListOfPairs, (aListOfStrings collect: [:each | {each. true}])! Item was removed: - ----- Method: BlockClosure>>valueUninterruptably (in category 'exceptions') ----- - valueUninterruptably - "Prevent remote returns from escaping the sender. Even attempts to terminate (unwind) this process will be halted and the process will resume here. A terminate message is needed for every one of these in the sender chain to get the entire process unwound." - - ^ self ifCurtailed: [^ self]! Item was removed: - ----- Method: BlockClosure>>valueUnpreemptively (in category 'private') ----- - valueUnpreemptively - "Evaluate the receiver (block), without the possibility of preemption by higher priority processes. Use this facility VERY sparingly!!" - "Think about using Block>>valueUninterruptably first, and think about using Semaphore>>critical: before that, and think about redesigning your application even before that!! - After you've done all that thinking, go right ahead and use it..." - | activeProcess oldPriority result | - activeProcess := Processor activeProcess. - oldPriority := activeProcess priority. - activeProcess priority: Processor highestPriority. - result := self ensure: [activeProcess priority: oldPriority]. - "Yield after restoring priority to give the preempted processes a chance to run" - Processor yield. - ^result! Item was removed: - ----- Method: BlockClosure>>valueWithArguments: (in category 'evaluating') ----- - valueWithArguments: anArray - "Activate the receiver, creating a closure activation (Context) - whose closure is the receiver and whose caller is the sender of this - message. Supply the arguments in an anArray and copied values to - the activation as its arguments and copied temps. Primitive. Essential." - <primitive: 206> - numArgs ~= anArray size ifTrue: - [self numArgsError: anArray size]. - ^self primitiveFailed! Item was removed: - ----- Method: BlockClosure>>valueWithArguments:otherwise: (in category 'evaluating') ----- - valueWithArguments: anArray otherwise: aBlock - - ^ self valueWithArguments: anArray! Item was removed: - ----- Method: BlockClosure>>valueWithEnoughArguments: (in category 'evaluating') ----- - valueWithEnoughArguments: anArray - "call me with enough arguments from anArray" - | args | - (anArray size == self numArgs) - ifTrue: [ ^self valueWithArguments: anArray ]. - - args := Array new: self numArgs. - args replaceFrom: 1 - to: (anArray size min: args size) - with: anArray - startingAt: 1. - - ^ self valueWithArguments: args! Item was removed: - ----- Method: BlockClosure>>valueWithExit (in category 'evaluating') ----- - valueWithExit - "Provides an exit block to the receiver. Use it to break out of the control flow with an early return. Examples below. - [:break | 1 to: 10 do: [:each | each > 5 ifTrue: [break value]]] valueWithExit. - 1 to: 10 do: [:each | [:continue | each > 5 ifTrue: [continue value]] valueWithExit]." - ^self value: [ ^nil ]! Item was removed: - ----- Method: BlockClosure>>valueWithPossibleArgs: (in category 'evaluating') ----- - valueWithPossibleArgs: anArray - - ^numArgs = 0 - ifTrue: [self value] - ifFalse: - [self valueWithArguments: - (numArgs = anArray size - ifTrue: [anArray] - ifFalse: - [numArgs > anArray size - ifTrue: [anArray, (Array new: numArgs - anArray size)] - ifFalse: [anArray copyFrom: 1 to: numArgs]])]! Item was removed: - ----- Method: BlockClosure>>valueWithPossibleArgument: (in category 'evaluating') ----- - valueWithPossibleArgument: anArg - "Evaluate the block represented by the receiver. If the block requires one argument, use anArg, if it requires more than one, fill up the rest with nils. See also #cull: if you want to raise an exception for incompatible blocks instead." - - | a | - numArgs = 0 ifTrue: [^self value]. - numArgs = 1 ifTrue: [^self value: anArg]. - a := Array new: numArgs. - a at: 1 put: anArg. - ^self valueWithArguments: a! Item was removed: - ----- Method: BlockClosure>>whileFalse (in category 'controlling') ----- - whileFalse - "Ordinarily compiled in-line, and therefore not overridable. - This is in case the message is sent to other than a literal block. - Evaluate the receiver, as long as its value is false." - - ^ [self value] whileFalse: []! Item was removed: - ----- Method: BlockClosure>>whileFalse: (in category 'controlling') ----- - whileFalse: aBlock - "Ordinarily compiled in-line, and therefore not overridable. - This is in case the message is sent to other than a literal block. - Evaluate the argument, aBlock, as long as the value of the receiver is false." - - ^ [self value] whileFalse: [aBlock value]! Item was removed: - ----- Method: BlockClosure>>whileNil (in category 'controlling') ----- - whileNil - "Unlike #whileTrue/False this is not compiled inline." - | result | - [(result := self value) isNil] whileTrue. - ^ result - ! Item was removed: - ----- Method: BlockClosure>>whileNil: (in category 'controlling') ----- - whileNil: aBlock - "Unlike #whileTrue/False: this is not compiled inline." - | result | - [(result := self value) isNil] whileTrue: [aBlock value]. - ^ result - ! Item was removed: - ----- Method: BlockClosure>>whileNotNil: (in category 'controlling') ----- - whileNotNil: aBlock - "Unlike #whileTrue/False: this is not compiled inline." - ^ [self value notNil] whileTrue: [aBlock value] - ! Item was removed: - ----- Method: BlockClosure>>whileTrue (in category 'controlling') ----- - whileTrue - "Ordinarily compiled in-line, and therefore not overridable. - This is in case the message is sent to other than a literal block. - Evaluate the receiver, as long as its value is true." - - ^ [self value] whileTrue: []! Item was removed: - ----- Method: BlockClosure>>whileTrue: (in category 'controlling') ----- - whileTrue: aBlock - "Ordinarily compiled in-line, and therefore not overridable. - This is in case the message is sent to other than a literal block. - Evaluate the argument, aBlock, as long as the value of the receiver is true." - - ^ [self value] whileTrue: [aBlock value]! Item was removed: - InstructionClient subclass: #BlockLocalTempCounter - instanceVariableNames: 'stackPointer scanner blockEnd joinOffsets' - classVariableNames: '' - poolDictionaries: '' - category: 'Kernel-Methods'! - - !BlockLocalTempCounter commentStamp: 'eem 1/11/2018 08:30' prior: 0! - I am a support class for the decompiler that is used to find the number of local temps in a block by finding out what the stack offset is at the end of a block. I am necessary because in the EncoderForV3PlusClosures bytecode set the only way to initialize block-local temporaries is with pushConstant: nil bytecodes, but such bytecodes are ambiguous with a pushConstant: nil used to pass nil as a parameter or answer it as a result. By scanning through to the end of the block these can be disambiguated by tracking the stack depth.! Item was removed: - ----- Method: BlockLocalTempCounter class>>tempCountForBlockAt:in: (in category 'instance creation') ----- - tempCountForBlockAt: pc in: method - ^self new tempCountForBlockAt: pc in: method! Item was removed: - ----- Method: BlockLocalTempCounter class>>tempCountForBlockStartingAt:in: (in category 'instance creation') ----- - tempCountForBlockStartingAt: startpc in: method - ^self new - tempCountForBlockAt: (method encoderClass pcOfBlockCreationBytecodeForBlockStartingAt: startpc in: method) - in: method! Item was removed: - ----- Method: BlockLocalTempCounter>>blockReturnConstant: (in category 'instruction decoding') ----- - blockReturnConstant: value - "Return Constant From Block bytecode." - scanner pc < blockEnd ifTrue: - [self doJoin]! Item was removed: - ----- Method: BlockLocalTempCounter>>blockReturnTop (in category 'instruction decoding') ----- - blockReturnTop - "Return Top Of Stack bytecode." - stackPointer := stackPointer - 1. - scanner pc < blockEnd ifTrue: - [self doJoin]! Item was removed: - ----- Method: BlockLocalTempCounter>>directedSuperSend:numArgs: (in category 'instruction decoding') ----- - directedSuperSend: selector numArgs: numArgs - "Send Message Above Specific Class With Selector, selector, bytecode. - Start the lookup above the class that is the value of the association on - top of stack. The arguments of the message are found in the top numArgs - stack locations beneath the association, and the receiver just below them." - - stackPointer := stackPointer - (numArgs + 1)! Item was removed: - ----- Method: BlockLocalTempCounter>>doDup (in category 'instruction decoding') ----- - doDup - "Duplicate Top Of Stack bytecode." - stackPointer := stackPointer + 1! Item was removed: - ----- Method: BlockLocalTempCounter>>doJoin (in category 'private') ----- - doJoin - scanner pc < blockEnd ifTrue: - [stackPointer := joinOffsets at: scanner pc ifAbsent: [scanner followingPc]] - - "the ifAbsent: handles a caseOf:otherwise: where all cases return, which results - in the branch around the otherwise being unreached. e.g. in the following - jumpTo: L2 - is unreached. - - | t | - t caseOf: { [nil] -> [^thisContext method abstractSymbolic] } - otherwise: ['Oh no Mr Bill!!'] - - pushTemp: 0 - pushConstant: nil - send: #= (1 arg) - jumpFalseTo: L1 - pushThisContext: - send: #method (0 args) - send: #abstractSymbolic (0 args) - returnTop - jumpTo: L2 - L1: - pushConstant: 'Oh no Mr Bill!!' - L2: - returnTop"! Item was removed: - ----- Method: BlockLocalTempCounter>>doPop (in category 'instruction decoding') ----- - doPop - "Remove Top Of Stack bytecode." - stackPointer := stackPointer - 1! Item was removed: - ----- Method: BlockLocalTempCounter>>jump: (in category 'instruction decoding') ----- - jump: offset - "Unconditional Jump bytecode." - offset > 0 ifTrue: - [joinOffsets at: scanner pc + offset put: stackPointer. - self doJoin]! Item was removed: - ----- Method: BlockLocalTempCounter>>jump:if: (in category 'instruction decoding') ----- - jump: offset if: condition - "Conditional Jump bytecode." - stackPointer := stackPointer - 1. - offset > 0 ifTrue: - [joinOffsets at: scanner pc + offset put: stackPointer]! Item was removed: - ----- Method: BlockLocalTempCounter>>methodReturnConstant: (in category 'instruction decoding') ----- - methodReturnConstant: value - "Return Constant bytecode." - self doJoin! Item was removed: - ----- Method: BlockLocalTempCounter>>methodReturnReceiver (in category 'instruction decoding') ----- - methodReturnReceiver - "Return Self bytecode." - self doJoin! Item was removed: - ----- Method: BlockLocalTempCounter>>methodReturnTop (in category 'instruction decoding') ----- - methodReturnTop - "Return Top Of Stack bytecode." - stackPointer := stackPointer - 1. - self doJoin! Item was removed: - ----- Method: BlockLocalTempCounter>>popIntoLiteralVariable: (in category 'instruction decoding') ----- - popIntoLiteralVariable: anAssociation - "Remove Top Of Stack And Store Into Literal Variable bytecode." - stackPointer := stackPointer - 1! Item was removed: - ----- Method: BlockLocalTempCounter>>popIntoReceiverVariable: (in category 'instruction decoding') ----- - popIntoReceiverVariable: offset - "Remove Top Of Stack And Store Into Instance Variable bytecode." - stackPointer := stackPointer - 1! Item was removed: - ----- Method: BlockLocalTempCounter>>popIntoRemoteTemp:inVectorAt: (in category 'instruction decoding') ----- - popIntoRemoteTemp: remoteTempIndex inVectorAt: tempVectorIndex - "Remove Top Of Stack And Store Into Offset of Temp Vector bytecode." - stackPointer := stackPointer - 1! Item was removed: - ----- Method: BlockLocalTempCounter>>popIntoTemporaryVariable: (in category 'instruction decoding') ----- - popIntoTemporaryVariable: offset - "Remove Top Of Stack And Store Into Temporary Variable bytecode." - stackPointer := stackPointer - 1! Item was removed: - ----- Method: BlockLocalTempCounter>>pushActiveContext (in category 'instruction decoding') ----- - pushActiveContext - "Push Active Context On Top Of Its Own Stack bytecode." - stackPointer := stackPointer + 1! Item was removed: - ----- Method: BlockLocalTempCounter>>pushClosureCopyNumCopiedValues:numArgs:blockSize: (in category 'instruction decoding') ----- - pushClosureCopyNumCopiedValues: numCopied numArgs: numArgs blockSize: blockSize - "Push Closure bytecode. Either compute the end of the block if this is - the block we're analysing, or skip it, adjusting the stack as appropriate." - blockEnd - ifNil: [blockEnd := scanner pc + blockSize] - ifNotNil: - [stackPointer := stackPointer - numCopied + 1. - scanner pc: scanner pc + blockSize]! Item was removed: - ----- Method: BlockLocalTempCounter>>pushConsArrayWithElements: (in category 'instruction decoding') ----- - pushConsArrayWithElements: numElements - "Push Cons Array of size numElements popping numElements items from the stack into the array bytecode." - stackPointer := stackPointer - numElements + 1! Item was removed: - ----- Method: BlockLocalTempCounter>>pushConstant: (in category 'instruction decoding') ----- - pushConstant: value - "Push Constant, value, on Top Of Stack bytecode." - stackPointer := stackPointer + 1! Item was removed: - ----- Method: BlockLocalTempCounter>>pushFullClosure:numCopied: (in category 'instruction decoding') ----- - pushFullClosure: aCompiledBlock numCopied: numCopied - "Push Full Closure bytecode." - self error: 'BlockLocalTempCounter should not be used with full block compiled methods. A full block''s numTemps is accessible directly from its method.'! Item was removed: - ----- Method: BlockLocalTempCounter>>pushLiteralVariable: (in category 'instruction decoding') ----- - pushLiteralVariable: anAssociation - "Push Contents Of anAssociation On Top Of Stack bytecode." - stackPointer := stackPointer + 1! Item was removed: - ----- Method: BlockLocalTempCounter>>pushNewArrayOfSize: (in category 'instruction decoding') ----- - pushNewArrayOfSize: numElements - "Push New Array of size numElements bytecode." - stackPointer := stackPointer + 1! Item was removed: - ----- Method: BlockLocalTempCounter>>pushReceiver (in category 'instruction decoding') ----- - pushReceiver - "Push Active Context's Receiver on Top Of Stack bytecode." - stackPointer := stackPointer + 1! Item was removed: - ----- Method: BlockLocalTempCounter>>pushReceiverVariable: (in category 'instruction decoding') ----- - pushReceiverVariable: offset - "Push Contents Of the Receiver's Instance Variable Whose Index - is the argument, offset, On Top Of Stack bytecode." - stackPointer := stackPointer + 1! Item was removed: - ----- Method: BlockLocalTempCounter>>pushRemoteTemp:inVectorAt: (in category 'instruction decoding') ----- - pushRemoteTemp: remoteTempIndex inVectorAt: tempVectorIndex - "Push Contents at Offset in Temp Vector bytecode." - stackPointer := stackPointer + 1! Item was removed: - ----- Method: BlockLocalTempCounter>>pushTemporaryVariable: (in category 'instruction decoding') ----- - pushTemporaryVariable: offset - "Push Contents Of Temporary Variable Whose Index Is the - argument, offset, On Top Of Stack bytecode." - stackPointer := stackPointer + 1! Item was removed: - ----- Method: BlockLocalTempCounter>>send:super:numArgs: (in category 'instruction decoding') ----- - send: selector super: supered numArgs: numberArguments - "Send Message With Selector, selector, bytecode. The argument, - supered, indicates whether the receiver of the message is specified with - 'super' in the source method. The arguments of the message are found in - the top numArguments locations on the stack and the receiver just - below them." - - stackPointer := stackPointer - numberArguments! Item was removed: - ----- Method: BlockLocalTempCounter>>tempCountForBlockAt:in: (in category 'initialize-release') ----- - tempCountForBlockAt: pc in: method - "Compute the number of local temporaries in a block. - If the block begins with a sequence of push: nil bytecodes then some of - These could be initializing local temps. We can only reliably disambuguate - them from other uses of nil by parsing the stack and seeing what the offset - of the stack pointer is at the end of the block. - - There are short-cuts. The ones we take here are - - if there is no sequence of push nils there can be no local temps - - we follow forward jumps to shorten the amount of scanning" - stackPointer := 0. - scanner := InstructionStream new method: method pc: pc. - scanner interpretNextInstructionFor: self. - blockEnd ifNil: - [self error: 'pc is not that of a block']. - scanner nextByte = method encoderClass pushNilCode ifTrue: - [joinOffsets := Dictionary new. - [scanner pc < blockEnd] whileTrue: - [scanner interpretNextInstructionFor: self]]. - ^stackPointer! Item was removed: - ----- Method: BlockLocalTempCounter>>testTempCountForBlockAt:in: (in category 'initialize-release') ----- - testTempCountForBlockAt: startPc in: method - "Compute the number of local temporaries in a block. - If the block begins with a sequence of push: nil bytecodes then some of - These could be initializing local temps. We can only reliably disambuguate - them from other uses of nil by parsing the stack and seeing what the offset - of the stack pointer is at the end of the block.There are short-cuts. The only - one we take here is - - if there is no sequence of push nils there can be no local temps" - - | symbolicLines line prior thePc | - symbolicLines := Dictionary new. - method symbolicLinesDo: - [:pc :lineForPC| symbolicLines at: pc put: lineForPC]. - stackPointer := 0. - scanner := InstructionStream new method: method pc: startPc. - scanner interpretNextInstructionFor: self. - blockEnd ifNil: - [self error: 'pc is not that of a block']. - scanner nextByte = method encoderClass pushNilCode ifTrue: - [joinOffsets := Dictionary new. - [scanner pc < blockEnd] whileTrue: - [line := symbolicLines at: scanner pc. - prior := stackPointer. - thePc := scanner pc. - scanner interpretNextInstructionFor: self. - Transcript cr; print: prior; nextPutAll: '->'; print: stackPointer; tab; print: thePc; tab; nextPutAll: line; flush]]. - ^stackPointer! Item was removed: - Object subclass: #Boolean - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Kernel-Objects'! - - !Boolean commentStamp: '<historical>' prior: 0! - Boolean is an abstract class defining the protocol for logic testing operations and conditional control structures for the logical values represented by the instances of its subclasses True and False. - - Boolean redefines #new so no instances of Boolean can be created. It also redefines several messages in the 'copying' protocol to ensure that only one instance of each of its subclasses True (the global true, logical assertion) and False (the global false, logical negation) ever exist in the system.! Item was removed: - ----- Method: Boolean class>>initializedInstance (in category 'instance creation') ----- - initializedInstance - ^ nil! Item was removed: - ----- Method: Boolean class>>isAbstract (in category 'testing') ----- - isAbstract - ^self = Boolean! Item was removed: - ----- Method: Boolean class>>new (in category 'instance creation') ----- - new - self error: 'You may not create any more Booleans - this is two-valued logic'! Item was removed: - ----- Method: Boolean>>& (in category 'logical operations') ----- - & aBoolean - "Evaluating conjunction. Evaluate the argument. Then answer true if - both the receiver and the argument are true." - - self subclassResponsibility! Item was removed: - ----- Method: Boolean>>==> (in category 'logical operations') ----- - ==> aBlock - "this is material implication, a ==> b, also known as: - b if a - a implies b - if a then b - b is a consequence of a - a therefore b (but note: 'it is raining therefore it is cloudy' is implication; 'it is autumn therefore the leaves are falling' is equivalence). - - Here is the truth table for material implication (view in a monospaced font): - - p | q | p ==> q - -------|-------|------------- - T | T | T - T | F | F - F | T | T - F | F | T - " - - self subclassResponsibility! Item was removed: - ----- Method: Boolean>>and: (in category 'controlling') ----- - and: alternativeBlock - "Nonevaluating conjunction. If the receiver is true, answer the value of - the argument, alternativeBlock; otherwise answer false without - evaluating the argument." - - self subclassResponsibility! Item was removed: - ----- Method: Boolean>>and:and: (in category 'controlling') ----- - and: block1 and: block2 - "Nonevaluating conjunction without deep nesting. - The receiver is evaluated, followed by the blocks in order. - If any of these evaluates as false, then return false immediately, - without evaluating any further blocks. - If all return true, then return true." - - self ifFalse: [^ false]. - block1 value ifFalse: [^ false]. - block2 value ifFalse: [^ false]. - ^ true! Item was removed: - ----- Method: Boolean>>and:and:and: (in category 'controlling') ----- - and: block1 and: block2 and: block3 - "Nonevaluating conjunction without deep nesting. - The receiver is evaluated, followed by the blocks in order. - If any of these evaluates as false, then return false immediately, - without evaluating any further blocks. - If all return true, then return true." - - self ifFalse: [^ false]. - block1 value ifFalse: [^ false]. - block2 value ifFalse: [^ false]. - block3 value ifFalse: [^ false]. - ^ true! Item was removed: - ----- Method: Boolean>>and:and:and:and: (in category 'controlling') ----- - and: block1 and: block2 and: block3 and: block4 - "Nonevaluating conjunction without deep nesting. - The receiver is evaluated, followed by the blocks in order. - If any of these evaluates as false, then return false immediately, - without evaluating any further blocks. - If all return true, then return true." - - self ifFalse: [^ false]. - block1 value ifFalse: [^ false]. - block2 value ifFalse: [^ false]. - block3 value ifFalse: [^ false]. - block4 value ifFalse: [^ false]. - ^ true! Item was removed: - ----- Method: Boolean>>asBit (in category 'printing') ----- - asBit - "My numerical interpretation, as one-bit number. This extends nicely to n-bit numbers, - as long as they treat 0 as false, and anything else as true" - ^ self subclassResponsibility! Item was removed: - ----- Method: Boolean>>asInteger (in category 'converting') ----- - asInteger - "It is sufficient to treat this boolean as bit so as to interpret it as a number" - ^ self asBit! Item was removed: - ----- Method: Boolean>>asNumber (in category 'converting') ----- - asNumber - "It is sufficient to treat this boolean as bit so as to interpret it as a number" - ^ self asBit! Item was removed: - ----- Method: Boolean>>deepCopy (in category 'copying') ----- - deepCopy - "Receiver has two concrete subclasses, True and False. - Only one instance of each should be made, so return self."! Item was removed: - ----- Method: Boolean>>eqv: (in category 'logical operations') ----- - eqv: aBoolean - "Answer true if the receiver is equivalent to aBoolean." - - ^self == aBoolean! Item was removed: - ----- Method: Boolean>>ifFalse: (in category 'controlling') ----- - ifFalse: alternativeBlock - "If the receiver is true (i.e., the condition is true), then the value is the - true alternative, which is nil. Otherwise answer the result of evaluating - the argument, alternativeBlock. Create an error notification if the - receiver is nonBoolean. Execution does not actually reach here because - the expression is compiled in-line." - - self subclassResponsibility! Item was removed: - ----- Method: Boolean>>ifFalse:ifTrue: (in category 'controlling') ----- - ifFalse: falseAlternativeBlock ifTrue: trueAlternativeBlock - "Same as ifTrue:ifFalse:." - - self subclassResponsibility! Item was removed: - ----- Method: Boolean>>ifTrue: (in category 'controlling') ----- - ifTrue: alternativeBlock - "If the receiver is false (i.e., the condition is false), then the value is the - false alternative, which is nil. Otherwise answer the result of evaluating - the argument, alternativeBlock. Create an error notification if the - receiver is nonBoolean. Execution does not actually reach here because - the expression is compiled in-line." - - self subclassResponsibility! Item was removed: - ----- Method: Boolean>>ifTrue:ifFalse: (in category 'controlling') ----- - ifTrue: trueAlternativeBlock ifFalse: falseAlternativeBlock - "If the receiver is true (i.e., the condition is true), then answer the value - of the argument trueAlternativeBlock. If the receiver is false, answer the - result of evaluating the argument falseAlternativeBlock. If the receiver - is a nonBoolean then create an error notification. Execution does not - actually reach here because the expression is compiled in-line." - - self subclassResponsibility! Item was removed: - ----- Method: Boolean>>isBoolean (in category 'testing') ----- - isBoolean - ^ true! Item was removed: - ----- Method: Boolean>>isLiteral (in category 'printing') ----- - isLiteral - ^ true! Item was removed: - ----- Method: Boolean>>not (in category 'logical operations') ----- - not - "Negation. Answer true if the receiver is false, answer false if the - receiver is true." - - self subclassResponsibility! Item was removed: - ----- Method: Boolean>>or: (in category 'controlling') ----- - or: alternativeBlock - "Nonevaluating disjunction. If the receiver is false, answer the value of - the argument, alternativeBlock; otherwise answer true without - evaluating the argument." - - self subclassResponsibility! Item was removed: - ----- Method: Boolean>>or:or: (in category 'controlling') ----- - or: block1 or: block2 - "Nonevaluating alternation without deep nesting. - The receiver is evaluated, followed by the blocks in order. - If any of these evaluates as true, then return true immediately, - without evaluating any further blocks. - If all return false, then return false." - - self ifTrue: [^ true]. - block1 value ifTrue: [^ true]. - block2 value ifTrue: [^ true]. - ^ false! Item was removed: - ----- Method: Boolean>>or:or:or: (in category 'controlling') ----- - or: block1 or: block2 or: block3 - "Nonevaluating alternation without deep nesting. - The receiver is evaluated, followed by the blocks in order. - If any of these evaluates as true, then return true immediately, - without evaluating any further blocks. - If all return false, then return false." - - self ifTrue: [^ true]. - block1 value ifTrue: [^ true]. - block2 value ifTrue: [^ true]. - block3 value ifTrue: [^ true]. - ^ false! Item was removed: - ----- Method: Boolean>>or:or:or:or: (in category 'controlling') ----- - or: block1 or: block2 or: block3 or: block4 - "Nonevaluating alternation without deep nesting. - The receiver is evaluated, followed by the blocks in order. - If any of these evaluates as true, then return true immediately, - without evaluating any further blocks. - If all return false, then return false." - - self ifTrue: [^ true]. - block1 value ifTrue: [^ true]. - block2 value ifTrue: [^ true]. - block3 value ifTrue: [^ true]. - block4 value ifTrue: [^ true]. - ^ false! Item was removed: - ----- Method: Boolean>>or:or:or:or:or: (in category 'controlling') ----- - or: block1 or: block2 or: block3 or: block4 or: block5 - "Nonevaluating alternation without deep nesting. - The receiver is evaluated, followed by the blocks in order. - If any of these evaluates as true, then return true immediately, - without evaluating any further blocks. - If all return false, then return false." - - self ifTrue: [^ true]. - block1 value ifTrue: [^ true]. - block2 value ifTrue: [^ true]. - block3 value ifTrue: [^ true]. - block4 value ifTrue: [^ true]. - block5 value ifTrue: [^ true]. - ^ false! Item was removed: - ----- Method: Boolean>>printAsLiteralOn: (in category 'printing') ----- - printAsLiteralOn: aStream - ^self printOn: aStream! Item was removed: - ----- Method: Boolean>>shallowCopy (in category 'copying') ----- - shallowCopy - "Receiver has two concrete subclasses, True and False. - Only one instance of each should be made, so return self."! Item was removed: - ----- Method: Boolean>>storeOn: (in category 'printing') ----- - storeOn: aStream - "Refer to the comment in Object|storeOn:." - - self printOn: aStream! Item was removed: - ----- Method: Boolean>>veryDeepCopy (in category 'copying') ----- - veryDeepCopy - "Overridden for performance to avoid #fixDependents." - ^ self! Item was removed: - ----- Method: Boolean>>veryDeepCopyWith: (in category 'copying') ----- - veryDeepCopyWith: deepCopier - "Return self. I can't be copied. Do not record me."! Item was removed: - ----- Method: Boolean>>xor: (in category 'logical operations') ----- - xor: aBoolean - "Exclusive OR. Answer true if the receiver is not equivalent to aBoolean." - - ^(self == aBoolean) not! Item was removed: - ----- Method: Boolean>>| (in category 'logical operations') ----- - | aBoolean - "Evaluating disjunction (OR). Evaluate the argument. Then answer true - if either the receiver or the argument is true." - - self subclassResponsibility! Item was removed: - 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 removed: - ----- Method: BoxedFloat64 class>>basicNew (in category 'instance creation') ----- - basicNew - ^self basicNew: 2! Item was removed: - ----- 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 removed: - ----- 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 removed: - ----- 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 removed: - ----- 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 removed: - ----- 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 removed: - ----- 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 removed: - ----- 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 removed: - ----- 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 removed: - ----- 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 removed: - ----- 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 removed: - ----- 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 removed: - ----- 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 removed: - ----- 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 removed: - ----- 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 removed: - ----- 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 removed: - ----- 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 removed: - ----- Method: BoxedFloat64>>sqrt (in category 'mathematical functions') ----- - sqrt - "Answer the square root of the receiver. - Optional. See Object documentation whatIsAPrimitive." - <primitive: 55> - ^super sqrt! Item was removed: - ----- 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> - ^super timesTwoPower: anInteger! Item was removed: - ----- 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 < 4.503599627370496e15 - "Float maxExactInteger/2 = (1.0 timesTwoPower: Float precision - 1)" - "Every Float bigger than or equal to that has ulp >= 1, thus no fractionPart" - ifTrue: ["Fastest way when it may not be an integer" - "This branch is unreachable in 64 bits image" - | 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 significand and shift if necessary"] - - - - ! Item was removed: - ----- 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 removed: - Error subclass: #BrokenPromise - instanceVariableNames: 'promise' - classVariableNames: '' - poolDictionaries: '' - category: 'Kernel-Exceptions'! - - !BrokenPromise commentStamp: 'tonyg 2/17/2017 13:53' prior: 0! - I am signalled when, during a Promise>>wait, the promise is rejected. - promise: the promise itself. - ! Item was removed: - ----- Method: BrokenPromise>>defaultAction (in category 'as yet unclassified') ----- - defaultAction - self messageText: 'Promise was rejected'. - ^super defaultAction! Item was removed: - ----- Method: BrokenPromise>>isResumable (in category 'as yet unclassified') ----- - isResumable - ^ true! Item was removed: - ----- Method: BrokenPromise>>promise (in category 'as yet unclassified') ----- - promise - ^ promise! Item was removed: - ----- Method: BrokenPromise>>promise: (in category 'as yet unclassified') ----- - promise: aPromise - promise := aPromise! Item was removed: - Object subclass: #Categorizer - instanceVariableNames: 'categoryArray categoryStops elementArray' - classVariableNames: 'Default NullCategory' - poolDictionaries: '' - category: 'Kernel-Classes'! - - !Categorizer commentStamp: 'nice 5/6/2010 21:10' prior: 0! - A Categorizer goal is to classify the elements of a collection into categories. - It is typically used to classify methods of class into categories (also named protocols in this case). - - Instance Variables - categoryArray: <SequenceableCollection of: Object> - categoryStops: <SequenceableCollection of: Integer> - elementArray: <SequenceableCollection of: Object> - - categoryArray - - holds the list of categories. - A category could be any Object but is generally a String or Symbol. - Categories should be unique (categoryArray asSet size = categoryArray size) - - categoryStops - - holds the index of last element belonging to each category. - There should be a category stop for each category (categoryStops size = categoryArray size). - The categoryStops should be sorted (categoryStops sorted = categoryStops). - A category stop equal to its predecessor (= 0 for the first category stop) denotes an empty category. - - elementArray - - holds the elements to be classified. The elements are sorted by category. - - Class variables - Default is the default category used to classify yet unclassified methods of a class - NullCategory is the category to be displayed in a Browser for a class having no method. - ! Item was removed: - ----- Method: Categorizer class>>allCategory (in category 'class initialization') ----- - allCategory - "Return a symbol that represents the virtual all methods category." - - ^#'-- all --'! Item was removed: - ----- Method: Categorizer class>>default (in category 'class initialization') ----- - default - ^ Default! Item was removed: - ----- Method: Categorizer class>>defaultList: (in category 'instance creation') ----- - defaultList: aSortedCollection - "Answer an instance of me with initial elements from the argument, - aSortedCollection." - - ^self new setDefaultList: aSortedCollection! Item was removed: - ----- Method: Categorizer class>>documentation (in category 'documentation') ----- - documentation - "Instances consist of an Array of category names (categoryArray), each of - which refers to an Array of elements (elementArray). This association is - made through an Array of stop indices (categoryStops), each of which is - the index in elementArray of the last element (if any) of the - corresponding category. For example: categories := Array with: 'firstCat' - with: 'secondCat' with: 'thirdCat'. stops := Array with: 1 with: 4 with: 4. - elements := Array with: #a with: #b with: #c with: #d. This means that - category firstCat has only #a, secondCat has #b, #c, and #d, and - thirdCat has no elements. This means that stops at: stops size must be the - same as elements size." ! Item was removed: - ----- Method: Categorizer class>>initialize (in category 'class initialization') ----- - initialize - " self initialize " - - Default := 'as yet unclassified' asSymbol. - NullCategory := 'no messages' asSymbol.! Item was removed: - ----- Method: Categorizer class>>nullCategory (in category 'class initialization') ----- - nullCategory - ^ NullCategory! Item was removed: - ----- Method: Categorizer class>>sortAllCategories (in category 'housekeeping') ----- - sortAllCategories - - self allSubInstances - do: [:x | x sortCategories]! Item was removed: - ----- Method: Categorizer>>addCategory: (in category 'accessing') ----- - addCategory: newCategory - ^ self addCategory: newCategory before: nil ! Item was removed: - ----- Method: Categorizer>>addCategory:before: (in category 'accessing') ----- - addCategory: catString before: nextCategory - "Add a new category named heading. - If default category exists and is empty, remove it. - If nextCategory is nil, then add the new one at the end, - otherwise, insert it before nextCategory." - | index newCategory | - newCategory := catString asSymbol. - (categoryArray indexOf: newCategory) > 0 - ifTrue: [^self]. "heading already exists, so done" - (self isSpecialCategoryName: newCategory) - ifTrue: [^self inform: 'This category name is system reserved' translated]. - index := categoryArray indexOf: nextCategory - ifAbsent: [categoryArray size + 1]. - categoryArray := categoryArray - copyReplaceFrom: index - to: index-1 - with: (Array with: newCategory). - categoryStops := categoryStops - copyReplaceFrom: index - to: index-1 - with: (Array with: (index = 1 - ifTrue: [0] - ifFalse: [categoryStops at: index-1])). - "remove empty default category" - (newCategory ~= Default - and: [(self listAtCategoryNamed: Default) isEmpty]) - ifTrue: [self removeCategory: Default]! Item was removed: - ----- Method: Categorizer>>allElements (in category 'accessing') ----- - allElements - - ^ elementArray copy! Item was removed: - ----- Method: Categorizer>>allMethodSelectors (in category 'accessing') ----- - allMethodSelectors - "give a list of all method selectors." - - ^ self allElements sort! Item was removed: - ----- Method: Categorizer>>assertInvariant (in category 'private') ----- - assertInvariant - self assert: (elementArray size = categoryStops last)! Item was removed: - ----- Method: Categorizer>>basicRemoveElement: (in category 'private') ----- - basicRemoveElement: element - "Remove the selector, element, from all categories." - | categoryIndex elementIndex nextStop newElements | - categoryIndex := 1. - elementIndex := 0. - nextStop := 0. - "nextStop keeps track of the stops in the new element array" - newElements := WriteStream on: (Array new: elementArray size). - [(elementIndex := elementIndex + 1) <= elementArray size] - whileTrue: - [[elementIndex > (categoryStops at: categoryIndex)] - whileTrue: - [categoryStops at: categoryIndex put: nextStop. - categoryIndex := categoryIndex + 1]. - (elementArray at: elementIndex) = element - ifFalse: - [nextStop := nextStop + 1. - newElements nextPut: (elementArray at: elementIndex)]]. - [categoryIndex <= categoryStops size] - whileTrue: - [categoryStops at: categoryIndex put: nextStop. - categoryIndex := categoryIndex + 1]. - elementArray := newElements contents. - self assertInvariant.! Item was removed: - ----- Method: Categorizer>>categories (in category 'accessing') ----- - categories - "Answer an Array of categories (names)." - categoryArray isNil ifTrue: [^ nil]. - self isEmpty ifTrue: [^Array with: NullCategory]. - ^categoryArray! Item was removed: - ----- Method: Categorizer>>categories: (in category 'accessing') ----- - categories: anArray - "Reorder my categories to be in order of the argument, anArray. If the - resulting organization does not include all elements, then give an error." - - | newCategories newStops newElements catName list runningTotal | - - anArray size < 2 ifTrue: [ ^ self ]. - - newCategories := Array new: anArray size. - newStops := Array new: anArray size. - newElements := Array new: 0. - runningTotal := 0. - 1 to: anArray size do: - [:i | - catName := (anArray at: i) asSymbol. - list := self listAtCategoryNamed: catName. - newElements := newElements, list. - newCategories at: i put: catName. - newStops at: i put: (runningTotal := runningTotal + list size)]. - elementArray do: - [:element | "check to be sure all elements are included" - (newElements includes: element) - ifFalse: [^self error: 'New categories must match old ones']]. - "Everything is good, now update my three arrays." - categoryArray := newCategories. - categoryStops := newStops. - elementArray := newElements! Item was removed: - ----- Method: Categorizer>>categoryOfElement: (in category 'accessing') ----- - categoryOfElement: element - "Answer the category associated with the argument, element." - - | index | - index := self numberOfCategoryOfElement: element. - index = 0 - ifTrue: [^nil] - ifFalse: [^categoryArray at: index]! Item was removed: - ----- Method: Categorizer>>changeFromCategorySpecs: (in category 'accessing') ----- - changeFromCategorySpecs: categorySpecs - "Tokens is an array of categorySpecs as scanned from a browser 'reorganize' pane, or built up by some other process, such as a scan of an environment." - - | newCategories newStops cc currentStop oldElements newElements | - oldElements := elementArray asSet. - newCategories := Array new: categorySpecs size. - newStops := Array new: categorySpecs size. - currentStop := 0. - newElements := WriteStream on: (Array new: 16). - 1 to: categorySpecs size do: - [:i | | catSpec | - catSpec := categorySpecs at: i. - newCategories at: i put: catSpec first asSymbol. - catSpec allButFirst - replace: [ :each | - each isSymbol - ifTrue: [each] - ifFalse: [each printString asSymbol ] ]; - sort; - do: [ :elem | - (oldElements remove: elem ifAbsent: nil) ifNotNil: [ - newElements nextPut: elem. - currentStop := currentStop+1]]. - newStops at: i put: currentStop]. - - "Ignore extra elements but don't lose any existing elements!!" - oldElements := oldElements collect: - [:elem | Array with: (self categoryOfElement: elem) with: elem]. - newElements := newElements contents. - categoryArray := newCategories. - (cc := categoryArray asSet) size = categoryArray size ifFalse: ["has duplicate element" - | uniqueElements | - uniqueElements := cc copy. - categoryArray withIndexDo: [ :dup :ii | - uniqueElements remove: dup ifAbsent: [ "real duplicate" - | dup2 num | - num := 2. - [dup2 := (dup,' #', num printString) asSymbol. cc includes: dup2] whileTrue: [num := num + 1]. - cc add: dup2. - categoryArray at: ii put: dup2 ] ] ]. - categoryStops := newStops. - elementArray := newElements. - oldElements do: [:pair | self classify: pair last under: pair first].! Item was removed: - ----- Method: Categorizer>>changeFromString: (in category 'accessing') ----- - changeFromString: aString - "Parse the argument, aString, and make this be the receiver's structure." - - | categorySpecs | - categorySpecs := Scanner new scanTokens: aString. - "If nothing was scanned and I had no elements before, then default me" - (categorySpecs isEmpty and: [elementArray isEmpty]) - ifTrue: [^ self setDefaultList: Array new]. - - ^ self changeFromCategorySpecs: categorySpecs! Item was removed: - ----- Method: Categorizer>>classify:under: (in category 'classifying') ----- - classify: element under: heading - self classify: element under: heading suppressIfDefault: true! Item was removed: - ----- Method: Categorizer>>classify:under:suppressIfDefault: (in category 'classifying') ----- - classify: element under: heading suppressIfDefault: aBoolean - "Store the argument, element, in the category named heading. If aBoolean is true, then invoke special logic such that the classification is NOT done if the new heading is the Default and the element already had a non-Default classification -- useful for filein" - - | catName catIndex elemIndex realHeading | - realHeading := (heading isNil or: [self isSpecialCategoryName: heading]) - ifTrue: [Default] - ifFalse: [heading asSymbol]. - (catName := self categoryOfElement: element) = realHeading - ifTrue: [^ self]. "done if already under that category" - - catName ifNotNil: [ - (aBoolean and: [realHeading = Default]) - ifTrue: [^ self]. "return if non-Default category already assigned in memory" - self basicRemoveElement: element]. "remove if in another category" - - (categoryArray indexOf: realHeading) = 0 ifTrue: [self addCategory: realHeading]. - - catIndex := categoryArray indexOf: realHeading. - elemIndex := - catIndex > 1 - ifTrue: [categoryStops at: catIndex - 1] - ifFalse: [0]. - [(elemIndex := elemIndex + 1) <= (categoryStops at: catIndex) - and: [element >= (elementArray at: elemIndex)]] whileTrue. - - "elemIndex is now the index for inserting the element. Do the insertion before it." - elementArray := elementArray copyReplaceFrom: elemIndex to: elemIndex-1 - with: (Array with: element). - - "add one to stops for this and later categories" - catIndex to: categoryArray size do: - [:i | categoryStops at: i put: (categoryStops at: i) + 1]. - - ((categoryArray includes: Default) - and: [(self listAtCategoryNamed: Default) size = 0]) ifTrue: [self removeCategory: Default]. - - self assertInvariant.! Item was removed: - ----- Method: Categorizer>>classifyAll:under: (in category 'classifying') ----- - classifyAll: aCollection under: heading - - aCollection do: - [:element | self classify: element under: heading]! Item was removed: - ----- Method: Categorizer>>elementArray (in category 'private') ----- - elementArray - - ^ elementArray! Item was removed: - ----- Method: Categorizer>>elementCategoryDict (in category 'accessing') ----- - elementCategoryDict - | dict firstIndex lastIndex | - elementArray isNil ifTrue: [^ nil]. - dict := Dictionary new: elementArray size. - 1to: categoryStops size do: [:cat | - firstIndex := self firstIndexOfCategoryNumber: cat. - lastIndex := self lastIndexOfCategoryNumber: cat. - firstIndex to: lastIndex do: [:el | - dict at: (elementArray at: el) put: (categoryArray at: cat)]. - ]. - ^ dict.! Item was removed: - ----- Method: Categorizer>>firstIndexOfCategoryNumber: (in category 'private') ----- - firstIndexOfCategoryNumber: anInteger - anInteger < 1 ifTrue: [^ nil]. - ^ (anInteger > 1 - ifTrue: [(categoryStops at: anInteger - 1) + 1] - ifFalse: [1]).! Item was removed: - ----- Method: Categorizer>>isEmpty (in category 'testing') ----- - isEmpty - - ^ (categoryArray size = 1 - and: [categoryArray first = Default & (elementArray size = 0)])! Item was removed: - ----- Method: Categorizer>>isEmptyCategoryNamed: (in category 'accessing') ----- - isEmptyCategoryNamed: categoryName - | i | - i := categoryArray indexOf: categoryName ifAbsent: [^false]. - ^self isEmptyCategoryNumber: i! Item was removed: - ----- Method: Categorizer>>isEmptyCategoryNumber: (in category 'accessing') ----- - isEmptyCategoryNumber: anInteger - - | firstIndex lastIndex | - (anInteger < 1 or: [anInteger > categoryStops size]) - ifTrue: [^ true]. - firstIndex := self firstIndexOfCategoryNumber: anInteger. - lastIndex := self lastIndexOfCategoryNumber: anInteger. - ^ firstIndex > lastIndex! Item was removed: - ----- Method: Categorizer>>isSpecialCategoryName: (in category 'testing') ----- - isSpecialCategoryName: aName - - ^ aName = self class nullCategory - or: [aName = self class allCategory]! Item was removed: - ----- Method: Categorizer>>lastIndexOfCategoryNumber: (in category 'private') ----- - lastIndexOfCategoryNumber: anInteger - anInteger > categoryStops size ifTrue: [^ nil]. - ^ categoryStops at: anInteger! Item was removed: - ----- Method: Categorizer>>listAtCategoryNamed: (in category 'accessing') ----- - listAtCategoryNamed: categoryName - "Answer the array of elements associated with the name, categoryName." - - | i | - i := categoryArray indexOf: categoryName ifAbsent: [^Array new]. - ^self listAtCategoryNumber: i! Item was removed: - ----- Method: Categorizer>>listAtCategoryNumber: (in category 'accessing') ----- - listAtCategoryNumber: anInteger - "Answer the array of elements stored at the position indexed by anInteger. Answer nil if anInteger is larger than the number of categories." - - | firstIndex lastIndex | - (anInteger < 1 or: [anInteger > categoryStops size]) - ifTrue: [^ nil]. - firstIndex := self firstIndexOfCategoryNumber: anInteger. - lastIndex := self lastIndexOfCategoryNumber: anInteger. - ^elementArray copyFrom: firstIndex to: lastIndex! Item was removed: - ----- Method: Categorizer>>numberOfCategoryOfElement: (in category 'accessing') ----- - numberOfCategoryOfElement: element - "Answer the index of the category with which the argument, element, is - associated." - - | categoryIndex elementIndex elementArraySize | - categoryIndex := 1. - elementIndex := 0. - elementArraySize := elementArray size. - [(elementIndex := elementIndex + 1) <= elementArraySize] - whileTrue: - ["point to correct category" - [elementIndex > (categoryStops at: categoryIndex)] - whileTrue: [categoryIndex := categoryIndex + 1]. - "see if this is element" - element = (elementArray at: elementIndex) ifTrue: [^categoryIndex]]. - ^0! Item was removed: - ----- Method: Categorizer>>printOn: (in category 'printing') ----- - printOn: aStream - "Refer to the comment in Object|printOn:." - - | elementIndex | - elementIndex := 1. - 1 to: categoryArray size do: - [:i | - aStream nextPut: $(. - (categoryArray at: i) asString printOn: aStream. - [elementIndex <= (categoryStops at: i)] - whileTrue: - [aStream space; nextPutAll: (elementArray at: elementIndex). - elementIndex := elementIndex + 1]. - aStream nextPut: $); cr]! Item was removed: - ----- Method: Categorizer>>printString (in category 'printing') ----- - printString - ^self fullPrintString! Item was removed: - ----- Method: Categorizer>>removeCategory: (in category 'accessing') ----- - removeCategory: cat - "Remove the category named, cat. Create an error notificiation if the - category has any elements in it." - - | index lastStop | - index := categoryArray indexOf: cat ifAbsent: [^self]. - lastStop := - index = 1 - ifTrue: [0] - ifFalse: [categoryStops at: index - 1]. - (categoryStops at: index) - lastStop > 0 - ifTrue: [^self error: 'cannot remove non-empty category']. - categoryArray := categoryArray copyReplaceFrom: index to: index with: Array new. - categoryStops := categoryStops copyReplaceFrom: index to: index with: Array new. - categoryArray size = 0 - ifTrue: - [categoryArray := Array with: Default. - categoryStops := Array with: 0] - ! Item was removed: - ----- Method: Categorizer>>removeElement: (in category 'accessing') ----- - removeElement: element - ^ self basicRemoveElement: element! Item was removed: - ----- Method: Categorizer>>removeEmptyCategories (in category 'accessing') ----- - removeEmptyCategories - "Remove empty categories." - - | categoryIndex currentStop keptCategories keptStops | - keptCategories := WriteStream on: (Array new: 16). - keptStops := WriteStream on: (Array new: 16). - currentStop := categoryIndex := 0. - [(categoryIndex := categoryIndex + 1) <= categoryArray size] - whileTrue: - [(categoryStops at: categoryIndex) > currentStop - ifTrue: - [keptCategories nextPut: (categoryArray at: categoryIndex). - keptStops nextPut: (currentStop := categoryStops at: categoryIndex)]]. - categoryArray := keptCategories contents. - categoryStops := keptStops contents. - categoryArray size = 0 - ifTrue: - [categoryArray := Array with: Default. - categoryStops := Array with: 0] - - "ClassOrganizer allInstancesDo: [:co | co removeEmptyCategories]."! Item was removed: - ----- Method: Categorizer>>renameCategory:toBe: (in category 'accessing') ----- - renameCategory: oldCatString toBe: newCatString - "Rename a category. No action if new name already exists, or if old name does not exist." - | index oldCategory newCategory | - oldCategory := oldCatString asSymbol. - newCategory := newCatString asSymbol. - (categoryArray indexOf: newCategory) > 0 - ifTrue: [^ self]. "new name exists, so no action" - (index := categoryArray indexOf: oldCategory) = 0 - ifTrue: [^ self]. "old name not found, so no action" - categoryArray := categoryArray copy. "need to change identity so smart list update will notice the change" - categoryArray at: index put: newCategory! Item was removed: - ----- Method: Categorizer>>scanFrom: (in category 'fileIn/Out') ----- - scanFrom: aStream - "Reads in the organization from the next chunk on aStream. - Categories or elements not found in the definition are not affected. - New elements are ignored." - - self changeFromString: aStream nextChunk. - aStream skipStyleChunk.! Item was removed: - ----- Method: Categorizer>>scanFrom:environment: (in category 'fileIn/Out') ----- - scanFrom: aStream environment: anEnvironment - ^ self scanFrom: aStream! Item was removed: - ----- Method: Categorizer>>setDefaultList: (in category 'private') ----- - setDefaultList: aSortedCollection - - categoryArray := Array with: Default. - categoryStops := Array with: aSortedCollection size. - elementArray := aSortedCollection asArray! Item was removed: - ----- Method: Categorizer>>sortCategories (in category 'accessing') ----- - sortCategories - | privateCategories publicCategories newCategories | - - privateCategories := self categories select: - [:one | (one findString: 'private' startingAt: 1 caseSensitive: false) = 1]. - publicCategories := self categories copyWithoutAll: privateCategories. - newCategories := publicCategories asArray sort , privateCategories asArray sort. - self categories: newCategories! Item was removed: - ClassDescription subclass: #Class - instanceVariableNames: 'subclasses name classPool sharedPools environment category' - classVariableNames: '' - poolDictionaries: '' - category: 'Kernel-Classes'! - - !Class commentStamp: '<historical>' prior: 0! - I add a number of facilities to those in ClassDescription: - A set of all my subclasses (defined in ClassDescription, but only used here and below) - A name by which I can be found in a SystemDictionary - A classPool for class variables shared between this class and its metaclass - A list of sharedPools which probably should be supplanted by some better mechanism. - - My instances describe the representation and behavior of objects. I add more comprehensive programming support facilities to the basic attributes of Behavior and the descriptive facilities of ClassDescription. - - The slot 'subclasses' is a redundant structure. It is never used during execution, but is used by the development system to simplify or speed certain operations. ! Item was removed: - ----- Method: Class class>>fileOutPool: (in category 'fileIn/Out') ----- - fileOutPool: aString - "file out the global pool named aString" - - | internalStream | - internalStream := WriteStream on: (String new: 1000). - self new fileOutPool: (self environment at: aString asSymbol) onFileStream: internalStream. - - FileStream writeSourceCodeFrom: internalStream baseName: aString isSt: true useHtml: false.! Item was removed: - ----- Method: Class class>>rootsOfTheWorld (in category 'inquiries') ----- - rootsOfTheWorld - "return a collection of classes which have a nil superclass" - ^Smalltalk globals rootClasses! Item was removed: - ----- Method: Class class>>template: (in category 'instance creation') ----- - template: aSystemCategoryName - "Answer an expression that can be edited and evaluated in order to define a new class." - - ^ self templateForSubclassOf: Object name category: aSystemCategoryName ! Item was removed: - ----- Method: Class class>>templateForSubclassOf:category: (in category 'instance creation') ----- - templateForSubclassOf: priorClassName category: systemCategoryName - "Answer an expression that can be edited and evaluated in order to define a new class, given that the class previously looked at was as given" - - ^priorClassName asString, ' subclass: #NameOfSubclass - instanceVariableNames: '''' - classVariableNames: '''' - poolDictionaries: '''' - category: ''' , systemCategoryName asString , ''''! Item was removed: - ----- Method: Class>>addClassVarName: (in category 'class variables') ----- - addClassVarName: aString - "Add the argument, aString, as a class variable of the receiver. - Signal an error if the first character of aString is not capitalized, - or if it is already a variable named in the class." - | symbol oldState | - oldState := self copy. - aString first canBeGlobalVarInitial - ifFalse: [^self error: aString, ' class variable name should be capitalized; proceed to include anyway.']. - symbol := aString asSymbol. - self withAllSubclasses do: - [:subclass | - (self canFindWithoutEnvironment: symbol) ifTrue: [ - (DuplicateVariableError new) - superclass: superclass; "fake!!!!!!" - variable: aString; - signal: aString, ' is already defined']]. - classPool == nil ifTrue: [classPool := Dictionary new]. - (classPool includesKey: symbol) ifFalse: - ["Pick up any refs in Undeclared" - classPool declare: symbol from: self environment undeclared. - SystemChangeNotifier uniqueInstance classDefinitionChangedFrom: oldState to: self]! Item was removed: - ----- Method: Class>>addInstVarName: (in category 'instance variables') ----- - addInstVarName: aString - "Add the argument, aString, as one of the receiver's instance variables." - ^(ClassBuilder new) - name: self name - inEnvironment: self environment - subclassOf: self superclass - type: self typeOfClass - instanceVariableNames: self instanceVariablesString, ' ', aString - classVariableNames: self classVariablesString - poolDictionaries: self sharedPoolsString - category: self category - ! Item was removed: - ----- Method: Class>>addSharedPool: (in category 'pool variables') ----- - addSharedPool: aSharedPool - "Add the argument, aSharedPool, as one of the receiver's shared pools. - Create an error if the shared pool is already one of the pools. - This method will work with shared pools that are plain Dictionaries or thenewer SharedPool subclasses" - - (self sharedPools includes: aSharedPool) - ifTrue: [^self error: 'This is already in my shared pool list']. - sharedPools == nil - ifTrue: [sharedPools := OrderedCollection with: aSharedPool] - ifFalse: [sharedPools add: aSharedPool]! Item was removed: - ----- Method: Class>>addSubclass: (in category 'accessing class hierarchy') ----- - addSubclass: aSubclass - "Make the argument, aSubclass, be one of the subclasses of the receiver. - Create an error notification if the argument's superclass is not the receiver." - - aSubclass superclass ~~ self - ifTrue: [^self error: aSubclass name , ' is not my subclass']. - subclasses == nil - ifTrue: [subclasses := Array with: aSubclass. - ^self]. - subclasses do:[:cl| cl == aSubclass ifTrue:[^self]]. "Already my subclass" - subclasses := subclasses copyWith: aSubclass.! Item was removed: - ----- Method: Class>>allClassVarNames (in category 'class variables') ----- - allClassVarNames - "Answer a Set of the names of the receiver's class variables, including those defined in the superclasses of the receiver." - | aSet | - ^ self superclass == nil - ifTrue: - [self classVarNames asSet] "This is the keys so it is a new Set." - ifFalse: - [aSet := self superclass allClassVarNames. - aSet addAll: self classVarNames. - aSet]! Item was removed: - ----- Method: Class>>allSharedPools (in category 'pool variables') ----- - allSharedPools - "Answer a Set of the pools the receiver shares, including those defined - in the superclasses of the receiver." - | aSet | - ^self superclass == nil - ifTrue: [self sharedPools copy] - ifFalse: [aSet := self superclass allSharedPools. - aSet addAll: self sharedPools. - aSet]! Item was removed: - ----- Method: Class>>binding (in category 'compiling') ----- - binding - "Answer a binding for the receiver, sharing if possible" - (self environment bindingOf: name ifAbsent: nil) ifNotNil: - [:bindingOrNil| - bindingOrNil value == self ifTrue: - [^bindingOrNil]]. - ^ClassBinding key: nil value: self! Item was removed: - ----- Method: Class>>bindingOf: (in category 'compiling') ----- - bindingOf: varName - ^ self bindingOf: varName environment: self environment! Item was removed: - ----- Method: Class>>bindingOf:environment: (in category 'compiling') ----- - bindingOf: varName environment: anEnvironment - "Answer the binding of some variable resolved in the scope of the receiver" - | aSymbol binding | - aSymbol := varName asSymbol. - - "First look in local classVar dictionary." - binding := self classPool bindingOf: aSymbol. - binding ifNotNil:[^binding]. - - "Next look in local shared pools." - self sharedPools do:[:pool | - binding := pool bindingOf: aSymbol. - binding ifNotNil:[^binding]. - ]. - - "Next look into superclass pools" - superclass ifNotNil: [^ superclass bindingOf: aSymbol environment: anEnvironment]. - - "No more superclass... Last look in declared environment." - ^anEnvironment bindingOf: aSymbol - - ! Item was removed: - ----- Method: Class>>canFindWithoutEnvironment: (in category 'compiling') ----- - canFindWithoutEnvironment: varName - "This method is used for analysis of system structure -- see senders." - "Look up varName, in the context of the receiver. Return true if it can be found without using the declared environment." - - "First look in classVar dictionary." - (self classPool bindingOf: varName) ifNotNil:[^true]. - - "Next look in shared pools." - self sharedPools do:[:pool | - (pool bindingOf: varName) ifNotNil:[^true]. - ]. - - "Finally look higher up the superclass chain and fail at the end." - superclass == nil - ifTrue: [^ false] - ifFalse: [^ superclass canFindWithoutEnvironment: varName]. - - ! Item was removed: - ----- Method: Class>>category (in category 'organization') ----- - category - "Answer the system organization category for the receiver. First check whether the - category name stored in the ivar is still correct and only if this fails look it up - (latter is much more expensive)" - - category ifNotNil: [ :symbol | - ((self environment organization listAtCategoryNamed: symbol) includes: self name) - ifTrue: [ ^symbol ] ]. - category := self environment organization categoryOfElement: self name. - ^category! Item was removed: - ----- Method: Class>>category: (in category 'organization') ----- - category: aString - "Categorize the receiver under the system category, aString, removing it from - any previous categorization." - - | oldCategory | - oldCategory := category. - aString isString - ifTrue: [ - category := aString asSymbol. - self environment organization classify: self name under: category ] - ifFalse: [self errorCategoryName]! Item was removed: - ----- Method: Class>>classPool (in category 'accessing') ----- - classPool - "Answer the dictionary of class variables." - - classPool == nil - ifTrue: [^Dictionary new] - ifFalse: [^classPool]! Item was removed: - ----- Method: Class>>classPool: (in category 'accessing') ----- - classPool: aDictionary - classPool := aDictionary! Item was removed: - ----- Method: Class>>classPoolFrom: (in category 'accessing') ----- - classPoolFrom: aClass - "share the classPool with aClass." - - classPool := aClass classPool! Item was removed: - ----- Method: Class>>classVarNames (in category 'class variables') ----- - classVarNames - "Answer a collection of the names of the class variables defined in the receiver." - - ^self classPool keys asArray sort! Item was removed: - ----- Method: Class>>compileAllFrom: (in category 'compiling') ----- - compileAllFrom: oldClass - "Recompile all the methods in the receiver's method dictionary (not the - subclasses). Also recompile the methods in the metaclass." - - super compileAllFrom: oldClass. - self class compileAllFrom: oldClass class! Item was removed: - ----- Method: Class>>copy (in category 'copying') ----- - copy - "Answer a copy of the receiver without a list of subclasses. - This copy is used by the ClassBuilder when mutating classes on redefinition. - (SystemNavigation new browseAllCallsOn: #copy localTo: ClassBuilder)" - | newClass | - newClass := self class copy new - superclass: superclass - methodDict: self methodDict copy - format: format - name: name - organization: self organization copy - instVarNames: instanceVariables copy - classPool: classPool copy - sharedPools: sharedPools copy. - Class instSize+1 to: self class instSize do: - [:offset | newClass instVarAt: offset put: (self instVarAt: offset)]. - ^ newClass! Item was removed: - ----- Method: Class>>deactivate (in category 'initialize-release') ----- - deactivate - "A remnant from the 3.3a modules work, retained . Does nothing, but may be overridden in Metaclasses."! Item was removed: - ----- Method: Class>>declare: (in category 'initialize-release') ----- - declare: varString - "Declare class variables common to all instances. Answer whether - recompilation is advisable." - - | newVars conflicts | - - newVars := - (Scanner new scanFieldNames: varString) - collect: [:x | x asSymbol]. - newVars do: - [:var | var first canBeGlobalVarInitial - ifFalse: [self error: var, ' class variable name should be capitalized; proceed to include anyway.']]. - conflicts := false. - classPool == nil - ifFalse: [(classPool keys reject: [:x | newVars includes: x]) do: - [:var | self removeClassVarName: var]]. - (newVars reject: [:var | self classPool includesKey: var]) - do: [:var | "adding" - "check if new vars defined elsewhere" - (self canFindWithoutEnvironment: var) ifTrue: [ - (DuplicateVariableError new) - superclass: superclass; "fake!!!!!!" - variable: var; - signal: var, ' is already defined'. - conflicts := true]]. - newVars size > 0 - ifTrue: - [classPool := self classPool. - "in case it was nil" - newVars do: [:var | classPool declare: var from: self environment undeclared]]. - ^conflicts! Item was removed: - ----- Method: Class>>ensureClassPool (in category 'class variables') ----- - ensureClassPool - - ^classPool ifNil: [classPool := Dictionary new].! Item was removed: - ----- Method: Class>>environment (in category 'organization') ----- - environment - - environment == nil ifTrue: [^ super environment]. - ^ environment! Item was removed: - ----- Method: Class>>environment: (in category 'organization') ----- - environment: anEnvironment - - environment := anEnvironment! Item was removed: - ----- Method: Class>>ephemeronSubclass:instanceVariableNames:classVariableNames:poolDictionaries:category: (in category 'subclass creation') ----- - ephemeronSubclass: t instanceVariableNames: f classVariableNames: d poolDictionaries: s category: cat - "This is the standard initialization message for creating a new class as a - subclass of an existing class (the receiver) in which the subclass is to - have ephemeron semantics, i.e. where the object will be queued for - finalization when the key (first) inst var is not reachable other than through - the other fields of ephemerons with unreachable keys." - ^ClassBuilder new - superclass: self - ephemeronSubclass: t - instanceVariableNames: f - classVariableNames: d - poolDictionaries: s - category: cat! Item was removed: - ----- Method: Class>>externalName (in category 'class name') ----- - externalName - "Answer a name by which the receiver can be known." - - ^ name! Item was removed: - ----- Method: Class>>fileOut (in category 'fileIn/Out') ----- - fileOut - "Create a file whose name is the name of the receiver with '.st' as the - extension, and file a description of the receiver onto it." - ^ self fileOutAsHtml: false! Item was removed: - ----- Method: Class>>fileOutAsHtml: (in category 'fileIn/Out') ----- - fileOutAsHtml: useHtml - "File a description of the receiver onto a new file whose base name is the name of the receiver." - - | internalStream | - internalStream := WriteStream on: (String new: 100). - internalStream header; timeStamp. - - self sharedPools size > 0 ifTrue: [ - self shouldFileOutPools - ifTrue: [self fileOutSharedPoolsOn: internalStream]]. - self fileOutOn: internalStream moveSource: false toFile: 0. - internalStream trailer. - - FileStream writeSourceCodeFrom: internalStream baseName: self name isSt: true useHtml: useHtml. - ! Item was removed: - ----- Method: Class>>fileOutInitializerOn: (in category 'fileIn/Out') ----- - fileOutInitializerOn: aStream - ^self class fileOutInitializerOn: aStream! Item was removed: - ----- Method: Class>>fileOutOn:moveSource:toFile: (in category 'fileIn/Out') ----- - fileOutOn: aFileStream moveSource: moveSource toFile: fileIndex - "File a description of the receiver on aFileStream. If the boolean argument, - moveSource, is true, then set the trailing bytes to the position of aFileStream and - to fileIndex in order to indicate where to find the source code." - ^self fileOutOn: aFileStream moveSource: moveSource toFile: fileIndex initializing: true! Item was removed: - ----- Method: Class>>fileOutOn:moveSource:toFile:initializing: (in category 'fileIn/Out') ----- - fileOutOn: aFileStream moveSource: moveSource toFile: fileIndex initializing: aBool - "File a description of the receiver on aFileStream. If the boolean argument, - moveSource, is true, then set the trailing bytes to the position of aFileStream and - to fileIndex in order to indicate where to find the source code." - - Transcript cr; show: self name. - super - fileOutOn: aFileStream - moveSource: moveSource - toFile: fileIndex. - self class nonTrivial - ifTrue: - [aFileStream cr; nextPutAll: '"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!!'; cr; cr. - self class - fileOutOn: aFileStream - moveSource: moveSource - toFile: fileIndex - initializing: aBool]! Item was removed: - ----- Method: Class>>fileOutPool:onFileStream: (in category 'fileIn/Out') ----- - fileOutPool: aPool onFileStream: aFileStream - | aPoolName | - (aPool isKindOf: SharedPool class) ifTrue:[^self notify: 'we do not fileout SharedPool type shared pools for now']. - aPoolName := self environment keyAtIdentityValue: aPool. - Transcript cr; show: aPoolName. - aFileStream nextPutAll: 'Transcript show: ''' , aPoolName , '''; cr!!'; cr. - aFileStream nextPutAll: 'Smalltalk at: #' , aPoolName , ' put: Dictionary new!!'; cr. - aPool keys asArray sort do: [ :aKey | - | aValue | - aValue := aPool at: aKey. - aFileStream nextPutAll: aPoolName , ' at: #''' , aKey asString , '''', ' put: '. - (aValue isKindOf: Number) - ifTrue: [aValue printOn: aFileStream] - ifFalse: [aFileStream nextPutAll: '('. - aValue printOn: aFileStream. - aFileStream nextPutAll: ')']. - aFileStream nextPutAll: '!!'; cr]. - aFileStream cr! Item was removed: - ----- Method: Class>>fileOutSharedPoolsOn: (in category 'fileIn/Out') ----- - fileOutSharedPoolsOn: aFileStream - "file out the shared pools of this class after prompting the user about each pool" - | poolsToFileOut | - poolsToFileOut := self sharedPools select: - [:aPool | (self shouldFileOutPool: (self environment keyAtIdentityValue: aPool))]. - poolsToFileOut do: [:aPool | self fileOutPool: aPool onFileStream: aFileStream]. - ! Item was removed: - ----- Method: Class>>hasMethods (in category 'testing') ----- - hasMethods - "Answer a Boolean according to whether any methods are defined for the - receiver (includes whether there are methods defined in the receiver's - metaclass)." - - ^super hasMethods or: [self class hasMethods]! Item was removed: - ----- 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 removed: - ----- Method: Class>>isAbstract (in category 'testing') ----- - isAbstract - "Answer true if I am to be considered an abstract class. - An abstract class shall better not be instantiated. - Or its instances may miss some important behavior. - Typically, a class with methods sending #subclassResponsibility might be considered abstract. - But we can't erect this as a general rule, it might be that the message is never sent. - By default, all classes are concrete, up to each one to declare itself abstract." - - ^false! Item was removed: - ----- Method: Class>>isDeprecated (in category 'testing') ----- - isDeprecated - "Check for \d\d(Deprecated).* name. Optimized for speed. Accept false-positives if category cache is not valid anymore. See #category." - - ^ ((category ifNil: [self category]) findString: 'Deprecated' startingAt: 3 caseSensitive: true) > 0! Item was removed: - ----- Method: Class>>isObsolete (in category 'testing') ----- - isObsolete - "Return true if the receiver is obsolete." - ^(self environment at: name ifAbsent: [nil]) ~~ self! Item was removed: - ----- Method: Class>>isSystemDefined (in category 'testing') ----- - isSystemDefined - "Answer true if the receiver is a system-defined class, and not a UniClass (an instance-specific lightweight class)" - - ^ self == self officialClass! Item was removed: - ----- Method: Class>>metaCompilerClass (in category 'compiling') ----- - metaCompilerClass - "BE CAREFUL!! If you provide your own class to treat class-side (resp. meta) methods, you MUST account for the #meta*Class selector to use the default implementation in that case. That is, the methods behind #meta*Class MUST always get the default Smalltalk treatment." - - ^ super compilerClass! Item was removed: - ----- Method: Class>>metaDecompilerClass (in category 'compiling') ----- - metaDecompilerClass - "BE CAREFUL!! If you provide your own class to treat class-side (resp. meta) methods, you MUST account for the #meta*Class selector to use the default implementation in that case. That is, the methods behind #meta*Class MUST always get the default Smalltalk treatment." - - ^ super decompilerClass! Item was removed: - ----- Method: Class>>metaEvaluatorClass (in category 'compiling') ----- - metaEvaluatorClass - "BE CAREFUL!! If you provide your own class to treat class-side (resp. meta) methods, you MUST account for the #meta*Class selector to use the default implementation in that case. That is, the methods behind #meta*Class MUST always get the default Smalltalk treatment." - - ^ super evaluatorClass! Item was removed: - ----- Method: Class>>metaFormatterClass (in category 'printing') ----- - metaFormatterClass - "BE CAREFUL!! If you provide your own class to treat class-side (resp. meta) methods, you MUST account for the #meta*Class selector to use the default implementation in that case. That is, the methods behind #meta*Class MUST always get the default Smalltalk treatment." - - ^ super formatterClass! Item was removed: - ----- Method: Class>>metaParserClass (in category 'compiling') ----- - metaParserClass - "BE CAREFUL!! If you provide your own class to treat class-side (resp. meta) methods, you MUST account for the #meta*Class selector to use the default implementation in that case. That is, the methods behind #meta*Class MUST always get the default Smalltalk treatment." - - ^ super parserClass! Item was removed: - ----- Method: Class>>metaPrettyPrinterClass (in category 'printing') ----- - metaPrettyPrinterClass - "BE CAREFUL!! If you provide your own class to treat class-side (resp. meta) methods, you MUST account for the #meta*Class selector to use the default implementation in that case. That is, the methods behind #meta*Class MUST always get the default Smalltalk treatment." - - ^ super prettyPrinterClass! Item was removed: - ----- Method: Class>>name (in category 'accessing') ----- - name - "Answer the name of the receiver." - - name == nil - ifTrue: [^super name] - ifFalse: [^name]! Item was removed: - ----- Method: Class>>nameForViewer (in category 'class name') ----- - nameForViewer - "Answer the name to be shown in the header of a viewer looking at the receiver" - - ^ self name ifNil: ['Unnamed class']! Item was removed: - ----- Method: Class>>newEnvironment (in category 'subclass creation') ----- - newEnvironment - - self flag: #uniclasses. - ^ (Environment withName: 'EnvironmentForUniClass') - at: self name asSymbol put: self; - importSelf; - yourself! Item was removed: - ----- Method: Class>>newSubclass (in category 'subclass creation') ----- - newSubclass - - self flag: #uniclasses. - ^ self newUniqueClassInstVars: '' classInstVars: '' - - "Point newSubclass new"! Item was removed: - ----- Method: Class>>objectForDataStream: (in category 'fileIn/Out') ----- - objectForDataStream: refStrm - "I am about to be written on an object file. Write a reference to a class in Smalltalk instead." - - refStrm insideASegment - ifFalse: ["Normal use" - ^ DiskProxy global: self theNonMetaClass name selector: #withClassVersion: - args: {self classVersion}] - ifTrue: ["recording objects to go into an ImageSegment" - self isSystemDefined ifFalse: [^ self]. "do trace Player classes" - (refStrm rootObject includes: self) ifTrue: [^ self]. - "is in roots, intensionally write out, ^ self" - - "A normal class. remove it from references. Do not trace." - refStrm references removeKey: self ifAbsent: []. "already there" - ^ nil] - ! Item was removed: - ----- Method: Class>>obsolete (in category 'initialize-release') ----- - obsolete - "Change the receiver and all of its subclasses to an obsolete class." - self == Object - ifTrue: [^self error: 'Object is NOT obsolete']. - self setName: 'AnObsolete' , self name. - Object class instSize + 1 to: self class instSize do: - [:i | self instVarAt: i put: nil]. "Store nil over class instVars." - self classPool: nil. - self sharedPools: nil. - self class obsolete. - super obsolete.! Item was removed: - ----- Method: Class>>officialClass (in category 'testing') ----- - officialClass - "I am not a UniClass. (See Player officialClass). Return the class you use to make new subclasses." - - ^ self! Item was removed: - ----- Method: Class>>possibleVariablesFor:continuedFrom: (in category 'compiling') ----- - possibleVariablesFor: misspelled continuedFrom: oldResults - - | results | - results := misspelled correctAgainstDictionary: self classPool continuedFrom: oldResults. - self sharedPools do: [:pool | - results := misspelled correctAgainstDictionary: pool continuedFrom: results ]. - superclass == nil - ifTrue: - [ ^ misspelled correctAgainstDictionary: self environment continuedFrom: results ] - ifFalse: - [ ^ superclass possibleVariablesFor: misspelled continuedFrom: results ]! Item was removed: - ----- Method: Class>>reformatAll (in category 'fileIn/Out') ----- - reformatAll - "Reformat all methods in this class. - Leaves old code accessible to version browsing" - super reformatAll. "me..." - self class reformatAll "...and my metaclass"! Item was removed: - ----- Method: Class>>removeClassVarName: (in category 'class variables') ----- - removeClassVarName: aString - "Remove the class variable whose name is the argument, aString, from - the names defined in the receiver, a class. Create an error notification if - aString is not a class variable or if it is still being used in the code of - the class." - - | aSymbol | - aSymbol := aString asSymbol. - (classPool includesKey: aSymbol) - ifFalse: [^self error: aString, ' is not a class variable']. - self withAllSubclasses do:[:subclass | - (Array with: subclass with: subclass class) do:[:classOrMeta | - (classOrMeta whichSelectorsReferTo: (classPool associationAt: aSymbol)) - isEmpty ifFalse: [ - InMidstOfFileinNotification signal ifTrue: [ - Transcript cr; show: self name, ' (' , aString , ' is Undeclared) '. - ^self environment undeclare: aSymbol from: classPool]. - (self confirm: (aString,' is still used in code of class ', classOrMeta name, - '.\Is it okay to move it to Undeclared?') withCRs) - ifTrue:[^ self environment undeclare: aSymbol from: classPool] - ifFalse:[^self]]]]. - classPool removeKey: aSymbol. - classPool isEmpty ifTrue: [classPool := nil]. - ! Item was removed: - ----- Method: Class>>removeFromChanges (in category 'fileIn/Out') ----- - removeFromChanges - "References to the receiver, a class, and its metaclass should no longer be included in the system ChangeSet. - 7/18/96 sw: call removeClassAndMetaClassChanges:" - - ChangeSet current removeClassAndMetaClassChanges: self! Item was removed: - ----- Method: Class>>removeFromSystem (in category 'initialize-release') ----- - removeFromSystem - "Forget the receiver from the Smalltalk global dictionary. Any existing - instances will refer to an obsolete version of the receiver." - self removeFromSystem: true.! Item was removed: - ----- Method: Class>>removeFromSystem: (in category 'initialize-release') ----- - removeFromSystem: logged - "Forget the receiver from the Smalltalk global dictionary. Any existing - instances will refer to an obsolete version of the receiver." - - "keep the class name and category for triggering the system change message. If we wait to long, then we get obsolete information which is not what we want." - - "tell class to deactivate and unload itself-- two separate events in the module system" - self deactivate; unload. - self superclass ifNotNil: - ["If we have no superclass there's nothing to be remembered" - self superclass addObsoleteSubclass: self]. - self environment forgetClass: self logged: logged. - self obsolete.! Item was removed: - ----- Method: Class>>removeFromSystemUnlogged (in category 'initialize-release') ----- - removeFromSystemUnlogged - "Forget the receiver from the Smalltalk global dictionary. Any existing instances will refer to an obsolete version of the receiver. Do not log the removal either to the current change set nor to the system changes log" - ^self removeFromSystem: false! Item was removed: - ----- Method: Class>>removeInstVarName: (in category 'instance variables') ----- - removeInstVarName: aString - "Remove the argument, aString, as one of the receiver's instance variables." - - | newInstVarString | - (self instVarNames includes: aString) - ifFalse: [self error: aString , ' is not one of my instance variables']. - newInstVarString := ''. - (self instVarNames copyWithout: aString) do: - [:varName | newInstVarString := newInstVarString , ' ' , varName]. - ^(ClassBuilder new) - name: self name - inEnvironment: self environment - subclassOf: self superclass - type: self typeOfClass - instanceVariableNames: newInstVarString - classVariableNames: self classVariablesString - poolDictionaries: self sharedPoolsString - category: self category! Item was removed: - ----- Method: Class>>removeSharedPool: (in category 'pool variables') ----- - removeSharedPool: aDictionary - "Remove the pool dictionary, aDictionary, as one of the receiver's pool - dictionaries. Create an error notification if the dictionary is not one of - the pools. - : Note that it removes the wrong one if there are two empty Dictionaries in the list." - - | satisfiedSet workingSet aSubclass | - (self sharedPools includes: aDictionary) - ifFalse: [^self error: 'the dictionary is not in my pool']. - - "first see if it is declared in a superclass in which case we can remove it." - (self selectSuperclasses: [:class | class sharedPools includes: aDictionary]) isEmpty - ifFalse: [sharedPools remove: aDictionary. - sharedPools isEmpty ifTrue: [sharedPools := nil]. - ^self]. - - "second get all the subclasses that reference aDictionary through me rather than a - superclass that is one of my subclasses." - - workingSet := self subclasses asOrderedCollection. - satisfiedSet := Set new. - [workingSet isEmpty] whileFalse: - [aSubclass := workingSet removeFirst. - (aSubclass sharedPools includes: aDictionary) - ifFalse: - [satisfiedSet add: aSubclass. - workingSet addAll: aSubclass subclasses]]. - - "for each of these, see if they refer to any of the variables in aDictionary because - if they do, we can not remove the dictionary." - satisfiedSet add: self. - satisfiedSet do: - [:sub | - aDictionary associationsDo: - [:aGlobal | - (sub whichSelectorsReferTo: aGlobal) isEmpty - ifFalse: [^self error: aGlobal key - , ' is still used in code of class ' - , sub name]]]. - sharedPools remove: aDictionary. - sharedPools isEmpty ifTrue: [sharedPools := nil]! Item was removed: - ----- Method: Class>>removeSubclass: (in category 'accessing class hierarchy') ----- - removeSubclass: aSubclass - "If the argument, aSubclass, is one of the receiver's subclasses, remove it." - - subclasses == nil ifFalse: - [subclasses := subclasses copyWithout: aSubclass. - subclasses isEmpty ifTrue: [subclasses := nil]]. - ! Item was removed: - ----- Method: Class>>rename: (in category 'class name') ----- - rename: aString - "The new name of the receiver is the argument, aString." - - | oldName newName | - (newName := aString asSymbol) = (oldName := self name) - ifTrue: [^ self]. - (self environment includesKey: newName) - ifTrue: [^ self error: newName , ' already exists']. - ((self environment undeclared includesKey: newName) - and: [(self environment undeclared unreferencedKeys includes: newName) not]) - ifTrue: [RemarkNotification signal: 'There are references to ' , aString printString , ' - from Undeclared. Check them after this change.']. - name := newName. - self environment renameClass: self from: oldName! Item was removed: - ----- Method: Class>>setName: (in category 'private') ----- - setName: aSymbol - "Private - set the name of the class" - name := aSymbol.! Item was removed: - ----- Method: Class>>sharedPools (in category 'pool variables') ----- - sharedPools - "Answer a Set of the pool dictionaries declared in the receiver." - - sharedPools == nil - ifTrue: [^OrderedCollection new] - ifFalse: [^sharedPools]! Item was removed: - ----- Method: Class>>sharedPools: (in category 'pool variables') ----- - sharedPools: aCollection - sharedPools := aCollection! Item was removed: - ----- Method: Class>>sharing: (in category 'initialize-release') ----- - sharing: poolString - "Set up sharedPools. Answer whether recompilation is advisable." - | oldPools | - oldPools := self sharedPools. - sharedPools := OrderedCollection new. - (Scanner new scanFieldNames: poolString) do: - [:poolName | - sharedPools add: (self environment at: poolName asSymbol ifAbsent:[ - (self confirm: 'The pool dictionary ', poolName,' does not exist.', - '\Do you want it automatically created?' withCRs) - ifTrue:[self environment at: poolName asSymbol put: Dictionary new] - ifFalse:[^self error: poolName,' does not exist']])]. - sharedPools isEmpty ifTrue: [sharedPools := nil]. - oldPools do: [:pool | - | found | - found := self sharedPools anySatisfy: [:p | p == pool]. - found ifFalse: [^ true "A pool got deleted"]]. - ^ false! Item was removed: - ----- Method: Class>>shouldFileOutPool: (in category 'fileIn/Out') ----- - shouldFileOutPool: aPoolName - "respond with true if the user wants to file out aPoolName" - ^self confirm: ('FileOut the sharedPool ', aPoolName, '?')! Item was removed: - ----- Method: Class>>shouldFileOutPools (in category 'fileIn/Out') ----- - shouldFileOutPools - "respond with true if the user wants to file out the shared pools" - ^self confirm: 'FileOut selected sharedPools?'! Item was removed: - ----- Method: Class>>spaceUsed (in category 'private') ----- - spaceUsed - - "Object spaceUsed" - ^ super spaceUsed + self class spaceUsed! Item was removed: - ----- Method: Class>>storeDataOn: (in category 'fileIn/Out') ----- - storeDataOn: aDataStream - "I don't get stored. Use a DiskProxy" - - (aDataStream insideASegment and: [self isSystemDefined not]) ifTrue: [ - ^ super storeDataOn: aDataStream]. "do trace me" - self error: 'use a DiskProxy to store a Class'! Item was removed: - ----- Method: Class>>subclass:instanceVariableNames:classVariableNames:poolDictionaries:category: (in category 'subclass creation') ----- - subclass: t instanceVariableNames: f classVariableNames: d poolDictionaries: s category: cat - "This is the standard initialization message for creating a new class as a - subclass of an existing class (the receiver)." - ^(ClassBuilder new) - superclass: self - subclass: t - instanceVariableNames: f - classVariableNames: d - poolDictionaries: s - category: cat - ! Item was removed: - ----- Method: Class>>subclass:uses:instanceVariableNames:classVariableNames:poolDictionaries:category: (in category 'subclass creation') ----- - subclass: t uses: aTraitCompositionOrArray instanceVariableNames: f classVariableNames: d poolDictionaries: s category: cat - | newClass copyOfOldClass | - copyOfOldClass := self copy. - newClass := self - subclass: t - instanceVariableNames: f - classVariableNames: d - poolDictionaries: s - category: cat. - - - newClass setTraitComposition: aTraitCompositionOrArray asTraitComposition. - SystemChangeNotifier uniqueInstance - classDefinitionChangedFrom: copyOfOldClass to: newClass. - ^newClass! Item was removed: - ----- Method: Class>>subclasses (in category 'accessing class hierarchy') ----- - subclasses - "Answer a Set containing the receiver's subclasses." - - ^subclasses == nil - ifTrue: [#()] - ifFalse: [subclasses copy]! Item was removed: - ----- Method: Class>>subclassesDo: (in category 'accessing class hierarchy') ----- - subclassesDo: aBlock - "Evaluate the argument, aBlock, for each of the receiver's immediate subclasses." - subclasses == nil - ifFalse:[subclasses do: aBlock]! Item was removed: - ----- Method: Class>>subclassesDoGently: (in category 'accessing class hierarchy') ----- - subclassesDoGently: aBlock - "Evaluate the argument, aBlock, for each of the receiver's immediate subclasses." - subclasses == nil - ifFalse: [subclasses do: aBlock]! Item was removed: - ----- Method: Class>>superclass:methodDict:format:name:organization:instVarNames:classPool:sharedPools: (in category 'initialize-release') ----- - superclass: sup methodDict: md format: ft name: nm organization: org instVarNames: nilOrArray classPool: pool sharedPools: poolSet - "Answer an instance of me, a new class, using the arguments of the - message as the needed information. - Must only be sent to a new instance; else we would need Object flushCache." - - superclass := sup. - methodDict := md. - format := ft. - name := nm. - instanceVariables := nilOrArray. - classPool := pool. - sharedPools := poolSet. - self organization: org.! Item was removed: - ----- Method: Class>>superclass:methodDictionary:format: (in category 'initialize-release') ----- - superclass: aClass methodDictionary: mDict format: fmt - "Basic initialization of the receiver" - super superclass: aClass methodDictionary: mDict format: fmt. - subclasses := nil. "Important for moving down the subclasses field into Class" - ! Item was removed: - ----- Method: Class>>unload (in category 'initialize-release') ----- - unload - "Sent when a the class is removed. Does nothing, but may be overridden by (class-side) subclasses." - ! Item was removed: - ----- Method: Class>>variableByteSubclass:instanceVariableNames:classVariableNames:poolDictionaries:category: (in category 'subclass creation') ----- - variableByteSubclass: t instanceVariableNames: f - classVariableNames: d poolDictionaries: s category: cat - "This is the standard initialization message for creating a new class as a - subclass of an existing class (the receiver) in which the subclass is to - have indexable 8-bit byte-sized nonpointer variables." - ^ClassBuilder new - superclass: self - variableByteSubclass: t - instanceVariableNames: f - classVariableNames: d - poolDictionaries: s - category: cat! Item was removed: - ----- Method: Class>>variableByteSubclass:uses:instanceVariableNames:classVariableNames:poolDictionaries:category: (in category 'subclass creation') ----- - variableByteSubclass: t uses: aTraitCompositionOrArray instanceVariableNames: f - classVariableNames: d poolDictionaries: s category: cat - "This is the standard initialization message for creating a new class as a - subclass of an existing class (the receiver) in which the subclass is to - have indexable 8-bit byte-sized nonpointer variables." - - | newClass copyOfOldClass | - copyOfOldClass := self copy. - newClass := self - variableByteSubclass: t - instanceVariableNames: f - classVariableNames: d - poolDictionaries: s - category: cat. - - newClass setTraitComposition: aTraitCompositionOrArray asTraitComposition. - SystemChangeNotifier uniqueInstance - classDefinitionChangedFrom: copyOfOldClass to: newClass. - ^newClass! Item was removed: - ----- Method: Class>>variableDoubleByteSubclass:instanceVariableNames:classVariableNames:poolDictionaries:category: (in category 'subclass creation') ----- - variableDoubleByteSubclass: t instanceVariableNames: f - classVariableNames: d poolDictionaries: s category: cat - "This is the standard initialization message for creating a new class as a - subclass of an existing class (the receiver) in which the subclass is to - have indexable 16-bit double byte-sized nonpointer variables." - ^ClassBuilder new - superclass: self - variableDoubleByteSubclass: t - instanceVariableNames: f - classVariableNames: d - poolDictionaries: s - category: cat! Item was removed: - ----- Method: Class>>variableDoubleByteSubclass:uses:instanceVariableNames:classVariableNames:poolDictionaries:category: (in category 'subclass creation') ----- - variableDoubleByteSubclass: t uses: aTraitCompositionOrArray instanceVariableNames: f - classVariableNames: d poolDictionaries: s category: cat - "This is the standard initialization message for creating a new class as a - subclass of an existing class (the receiver) in which the subclass is to - have indexable 16-bit double byte-sized nonpointer variables." - - | newClass copyOfOldClass | - copyOfOldClass := self copy. - newClass := self - variableDoubleByteSubclass: t - instanceVariableNames: f - classVariableNames: d - poolDictionaries: s - category: cat. - - newClass setTraitComposition: aTraitCompositionOrArray asTraitComposition. - SystemChangeNotifier uniqueInstance - classDefinitionChangedFrom: copyOfOldClass to: newClass. - ^newClass! Item was removed: - ----- Method: Class>>variableDoubleWordSubclass:instanceVariableNames:classVariableNames:poolDictionaries:category: (in category 'subclass creation') ----- - variableDoubleWordSubclass: t instanceVariableNames: f - classVariableNames: d poolDictionaries: s category: cat - "This is the standard initialization message for creating a new class as a - subclass of an existing class (the receiver) in which the subclass is to - have indexable 64-bit word-sized nonpointer variables." - ^ClassBuilder new - superclass: self - variableDoubleWordSubclass: t - instanceVariableNames: f - classVariableNames: d - poolDictionaries: s - category: cat! Item was removed: - ----- Method: Class>>variableDoubleWordSubclass:uses:instanceVariableNames:classVariableNames:poolDictionaries:category: (in category 'subclass creation') ----- - variableDoubleWordSubclass: t uses: aTraitCompositionOrArray instanceVariableNames: f - classVariableNames: d poolDictionaries: s category: cat - "This is the standard initialization message for creating a new class as a - subclass of an existing class (the receiver) in which the subclass is to - have indexable 64-bit word-sized nonpointer variables." - - | newClass copyOfOldClass | - copyOfOldClass := self copy. - newClass := self - variableDoubleWordSubclass: t - instanceVariableNames: f - classVariableNames: d - poolDictionaries: s - category: cat. - - newClass setTraitComposition: aTraitCompositionOrArray asTraitComposition. - SystemChangeNotifier uniqueInstance - classDefinitionChangedFrom: copyOfOldClass to: newClass. - ^newClass! Item was removed: - ----- Method: Class>>variableSubclass:instanceVariableNames:classVariableNames:poolDictionaries:category: (in category 'subclass creation') ----- - variableSubclass: t instanceVariableNames: f - classVariableNames: d poolDictionaries: s category: cat - "This is the standard initialization message for creating a new class as a - subclass of an existing class (the receiver) in which the subclass is to - have indexable pointer variables." - ^(ClassBuilder new) - superclass: self - variableSubclass: t - instanceVariableNames: f - classVariableNames: d - poolDictionaries: s - category: cat - ! Item was removed: - ----- Method: Class>>variableSubclass:uses:instanceVariableNames:classVariableNames:poolDictionaries:category: (in category 'subclass creation') ----- - variableSubclass: t uses: aTraitCompositionOrArray instanceVariableNames: f - classVariableNames: d poolDictionaries: s category: cat - "This is the standard initialization message for creating a new class as a - subclass of an existing class (the receiver) in which the subclass is to - have indexable pointer variables." - - | newClass copyOfOldClass | - copyOfOldClass := self copy. - newClass := self - variableSubclass: t - instanceVariableNames: f - classVariableNames: d - poolDictionaries: s - category: cat. - - newClass setTraitComposition: aTraitCompositionOrArray asTraitComposition. - SystemChangeNotifier uniqueInstance - classDefinitionChangedFrom: copyOfOldClass to: newClass. - ^newClass ! Item was removed: - ----- Method: Class>>variableWordSubclass:instanceVariableNames:classVariableNames:poolDictionaries:category: (in category 'subclass creation') ----- - variableWordSubclass: t instanceVariableNames: f - classVariableNames: d poolDictionaries: s category: cat - "This is the standard initialization message for creating a new class as a - subclass of an existing class (the receiver) in which the subclass is to - have indexable 32-bit word-sized nonpointer variables." - ^ClassBuilder new - superclass: self - variableWordSubclass: t - instanceVariableNames: f - classVariableNames: d - poolDictionaries: s - category: cat! Item was removed: - ----- Method: Class>>variableWordSubclass:uses:instanceVariableNames:classVariableNames:poolDictionaries:category: (in category 'subclass creation') ----- - variableWordSubclass: t uses: aTraitCompositionOrArray instanceVariableNames: f - classVariableNames: d poolDictionaries: s category: cat - "This is the standard initialization message for creating a new class as a - subclass of an existing class (the receiver) in which the subclass is to - have indexable 32-bit word-sized nonpointer variables." - - | newClass copyOfOldClass | - copyOfOldClass := self copy. - newClass := self - variableWordSubclass: t - instanceVariableNames: f - classVariableNames: d - poolDictionaries: s - category: cat. - - newClass setTraitComposition: aTraitCompositionOrArray asTraitComposition. - SystemChangeNotifier uniqueInstance - classDefinitionChangedFrom: copyOfOldClass to: newClass. - ^newClass ! Item was removed: - ----- Method: Class>>weakSubclass:instanceVariableNames:classVariableNames:poolDictionaries:category: (in category 'subclass creation') ----- - weakSubclass: t instanceVariableNames: f - classVariableNames: d poolDictionaries: s category: cat - "This is the standard initialization message for creating a new class as a - subclass of an existing class (the receiver) in which the subclass is to - have weak indexable pointer variables." - ^(ClassBuilder new) - superclass: self - weakSubclass: t - instanceVariableNames: f - classVariableNames: d - poolDictionaries: s - category: cat! Item was removed: - ----- Method: Class>>weakSubclass:uses:instanceVariableNames:classVariableNames:poolDictionaries:category: (in category 'subclass creation') ----- - weakSubclass: t uses: aTraitCompositionOrArray instanceVariableNames: f - classVariableNames: d poolDictionaries: s category: cat - "This is the standard initialization message for creating a new class as a - subclass of an existing class (the receiver) in which the subclass is to - have weak indexable pointer variables." - - | newClass copyOfOldClass | - copyOfOldClass := self copy. - newClass := self - weakSubclass: t - instanceVariableNames: f - classVariableNames: d - poolDictionaries: s - category: cat. - - newClass setTraitComposition: aTraitCompositionOrArray asTraitComposition. - SystemChangeNotifier uniqueInstance - classDefinitionChangedFrom: copyOfOldClass to: newClass. - ^newClass - ! Item was removed: - ----- Method: Class>>whichSelectorsStoreInto: (in category 'testing') ----- - whichSelectorsStoreInto: varName - "Answer a collection of selectors whose methods access the argument, varName, as a named class variable. Or let super try with a named instance variable." - | ref | - ref := self classPool - associationAt: varName - ifAbsent: [ ^ super whichSelectorsStoreInto: varName ]. - ^self methodDict keys select: [:aSelector | (self methodDict at: aSelector) writesRef: ref ]! Item was removed: - ----- Method: Class>>withClassVersion: (in category 'fileIn/Out') ----- - withClassVersion: aVersion - aVersion = self classVersion ifTrue:[^self]. - ^self error: 'Invalid class version'! Item was removed: - Object subclass: #ClassBuilder - instanceVariableNames: 'environ classMap instVarMap progress maxClassIndex currentClassIndex' - classVariableNames: 'QuietMode' - poolDictionaries: '' - category: 'Kernel-Classes'! - - !ClassBuilder commentStamp: 'ar 2/27/2003 22:55' prior: 0! - Responsible for creating a new class or changing the format of an existing class (from a class definition in a browser or a fileIn). This includes validating the definition, computing the format of instances, creating or modifying the accompanying Metaclass, setting up the class and metaclass objects themselves, registering the class as a global, recompiling methods, modifying affected subclasses, mutating existing instances to the new format, and more. - - You typically only need to use or modify this class, or even know how it works, when making fundamental changes to how the Smalltalk system and language works. - - Implementation notes: - ClassBuilder relies on the assumption that it can see ALL subclasses of some class. If there are any existing subclasses of some class, regardless of whether they have instances or not, regardless of whether they are considered obsolete or not, ClassBuilder MUST SEE THEM. - ! Item was removed: - ----- Method: ClassBuilder class>>beSilent: (in category 'accessing') ----- - beSilent: aBool - "ClassDefiner beSilent: true" - "ClassDefiner beSilent: false" - QuietMode := aBool.! Item was removed: - ----- Method: ClassBuilder class>>beSilentDuring: (in category 'accessing') ----- - beSilentDuring: aBlock - "Temporarily suppress information about what is going on" - | wasSilent result | - wasSilent := self isSilent. - self beSilent: true. - result := aBlock value. - self beSilent: wasSilent. - ^result! Item was removed: - ----- Method: ClassBuilder class>>checkClassHierarchyConsistency (in category 'cleanup obsolete classes') ----- - checkClassHierarchyConsistency - "Check the consistency of the class hierarchy. The class hierarchy is consistent if the following - two logical equivalences hold for classes A and B: - - B is obsolete and 'B superclass' yields A <--> 'A obsoleteSubclasses' contains B - - B is not obsolete and 'B superclass' yields A <--> 'A subclasses' contains B" - self informUserDuring:[:bar| - self checkClassHierarchyConsistency: bar. - ].! Item was removed: - ----- Method: ClassBuilder class>>checkClassHierarchyConsistency: (in category 'cleanup obsolete classes') ----- - checkClassHierarchyConsistency: informer - "Check the consistency of the class hierarchy. The class hierarchy is consistent if the following - two logical equivalences hold for classes A and B: - - B is obsolete and 'B superclass' yields A <--> 'A obsoleteSubclasses' contains B - - B is not obsolete and 'B superclass' yields A <--> 'A subclasses' contains B" - | classes | - Transcript cr; show: 'Start checking the class hierarchy...'. - Smalltalk garbageCollect. - classes := Metaclass allInstances. - classes keysAndValuesDo: [:index :meta | - informer value:'Validating class hierarchy ', (index * 100 // classes size) printString,'%'. - meta allInstances do: [:each | self checkClassHierarchyConsistencyFor: each]. - self checkClassHierarchyConsistencyFor: meta. - ]. - Transcript show: 'OK'.! Item was removed: - ----- Method: ClassBuilder class>>checkClassHierarchyConsistencyFor: (in category 'cleanup obsolete classes') ----- - checkClassHierarchyConsistencyFor: aClassDescription - "Check whether aClassDescription has a consistent superclass and consistent regular and obsolete - subclasses" - - | mySuperclass | - mySuperclass := aClassDescription superclass. - (mySuperclass subclasses includes: aClassDescription) = aClassDescription isObsolete - ifTrue: [self error: 'Something wrong!!']. - mySuperclass ifNil: [^ self]. "Obsolete subclasses of nil cannot be stored" - (mySuperclass obsoleteSubclasses includes: aClassDescription) = aClassDescription isObsolete - ifFalse: [self error: 'Something wrong!!']. - - aClassDescription subclasses do: [:each | - each isObsolete ifTrue: [self error: 'Something wrong!!']. - each superclass == aClassDescription ifFalse: [self error: 'Something wrong!!'] - ]. - aClassDescription obsoleteSubclasses do: [:each | - each isObsolete ifFalse: [self error: 'Something wrong!!']. - each superclass == aClassDescription ifFalse: [self error: 'Something wrong!!'] - ].! Item was removed: - ----- Method: ClassBuilder class>>cleanupAndCheckClassHierarchy (in category 'cleanup obsolete classes') ----- - cleanupAndCheckClassHierarchy - "Makes the class hierarchy consistent and removes obsolete classes from the SystemDictionary. - Afterwards it checks whether the hierarchy is really consistent." - self informUserDuring:[:bar| - self cleanupAndCheckClassHierarchy: bar. - ]. - ! Item was removed: - ----- Method: ClassBuilder class>>cleanupAndCheckClassHierarchy: (in category 'cleanup obsolete classes') ----- - cleanupAndCheckClassHierarchy: informer - "Makes the class hierarchy consistent and removes obsolete classes from the SystemDictionary. - Afterwards it checks whether the hierarchy is really consistent." - - Transcript cr; show: '*** Before cleaning up ***'. - self countReallyObsoleteClassesAndMetaclasses. - self cleanupClassHierarchy: informer. - self checkClassHierarchyConsistency: informer. - Transcript cr; cr; show: '*** After cleaning up ***'. - self countReallyObsoleteClassesAndMetaclasses.! Item was removed: - ----- Method: ClassBuilder class>>cleanupClassHierarchy (in category 'cleanup obsolete classes') ----- - cleanupClassHierarchy - "Makes the class hierarchy consistent and removes obsolete classes from the SystemDictionary." - self informUserDuring:[:bar| - self cleanupClassHierarchy: bar. - ].! Item was removed: - ----- Method: ClassBuilder class>>cleanupClassHierarchy: (in category 'cleanup obsolete classes') ----- - cleanupClassHierarchy: informer - "Makes the class hierarchy consistent and removes obsolete classes from the SystemDictionary." - | classes | - Transcript cr; show: 'Start fixing the class hierarchy and cleaning up...'. - Smalltalk garbageCollect. - classes := Metaclass allInstances. - classes keysAndValuesDo: [:index :meta | - informer value:'Fixing class hierarchy ', (index * 100 // classes size) printString,'%'. - "Check classes before metaclasses (because Metaclass>>isObsolete - checks whether the related class is obsolete)" - meta allInstances do: [:each | self cleanupClassHierarchyFor: each]. - self cleanupClassHierarchyFor: meta. - ]. - Transcript show: 'DONE'.! Item was removed: - ----- Method: ClassBuilder class>>cleanupClassHierarchyFor: (in category 'cleanup obsolete classes') ----- - cleanupClassHierarchyFor: aClassDescription - - | myName mySuperclass | - mySuperclass := aClassDescription superclass. - (self isReallyObsolete: aClassDescription) ifTrue: [ - - "Remove class >>>from SystemDictionary if it is obsolete" - myName := aClassDescription name asString. - Smalltalk globals keys do: [:each | - (each asString = myName and: [(Smalltalk at: each) == aClassDescription]) - ifTrue: [Smalltalk globals removeKey: each]]. - - "Make class officially obsolete if it is not" - (aClassDescription name asString beginsWith: 'AnObsolete') - ifFalse: [aClassDescription obsolete]. - - aClassDescription isObsolete - ifFalse: [self error: 'Something wrong!!']. - - "Add class to obsoleteSubclasses of its superclass" - mySuperclass - ifNil: [self error: 'Obsolete subclasses of nil cannot be stored']. - (mySuperclass obsoleteSubclasses includes: aClassDescription) - ifFalse: [mySuperclass addObsoleteSubclass: aClassDescription]. - ] ifFalse:[ - "check if superclass has aClassDescription in its obsolete subclasses" - mySuperclass ifNil:[mySuperclass := Class]. "nil subclasses" - mySuperclass removeObsoleteSubclass: aClassDescription. - ]. - "And remove its obsolete subclasses if not actual superclass" - aClassDescription obsoleteSubclasses do:[:obs| - obs superclass == aClassDescription ifFalse:[ - aClassDescription removeObsoleteSubclass: obs]]. - ! Item was removed: - ----- Method: ClassBuilder class>>countReallyObsoleteClassesAndMetaclasses (in category 'cleanup obsolete classes') ----- - countReallyObsoleteClassesAndMetaclasses - "Counting really obsolete classes and metaclasses" - - | metaSize classSize | - Smalltalk garbageCollect. - metaSize := self reallyObsoleteMetaclasses size. - Transcript cr; show: 'Really obsolete metaclasses: ', metaSize printString. - classSize := self reallyObsoleteClasses size. - Transcript cr; show: 'Really obsolete classes: ', classSize printString; cr. - "Metaclasses must correspond to classes!!" - metaSize ~= classSize - ifTrue: [self error: 'Serious metalevel inconsistency!!!!'].! Item was removed: - ----- Method: ClassBuilder class>>isReallyObsolete: (in category 'cleanup obsolete classes') ----- - isReallyObsolete: aClassDescription - "Returns whether the argument class is *really* obsolete. (Due to a bug, the method isObsolete - isObsolete does not always return the right answer" - - ^ aClassDescription isObsolete or: [(aClassDescription superclass subclasses includes: aClassDescription) not]! Item was removed: - ----- Method: ClassBuilder class>>isSilent (in category 'accessing') ----- - isSilent - ^QuietMode == true! Item was removed: - ----- Method: ClassBuilder class>>reallyObsoleteClasses (in category 'cleanup obsolete classes') ----- - reallyObsoleteClasses - | obsoleteClasses | - obsoleteClasses := OrderedCollection new. - Metaclass allInstances do: [:meta | meta allInstances do: [:each | - (self isReallyObsolete: each) ifTrue: [obsoleteClasses add: each]]]. - ^ obsoleteClasses! Item was removed: - ----- Method: ClassBuilder class>>reallyObsoleteMetaclasses (in category 'cleanup obsolete classes') ----- - reallyObsoleteMetaclasses - ^ Metaclass allInstances select: [:each | self isReallyObsolete: each].! Item was removed: - ----- Method: ClassBuilder>>class:instanceVariableNames: (in category 'public') ----- - class: oldClass instanceVariableNames: instVarString - "This is the basic initialization message to change the definition of - an existing Metaclass" - oldClass isMeta ifFalse:[^self error: oldClass name, 'is not a Metaclass']. - ^self class: oldClass instanceVariableNames: instVarString unsafe: false! Item was removed: - ----- Method: ClassBuilder>>class:instanceVariableNames:unsafe: (in category 'class definition') ----- - class: oldClass instanceVariableNames: instVarString unsafe: unsafe - "This is the basic initialization message to change the definition of - an existing Metaclass" - | instVars newClass needNew copyOfOldClass | - environ := oldClass environment. - instVars := Scanner new scanFieldNames: instVarString. - unsafe ifFalse:[ - "Run validation checks so we know that we have a good chance for recompilation" - (self validateInstvars: instVars from: oldClass forSuper: oldClass superclass) ifFalse:[^nil]. - (self validateSubclassFormat: oldClass typeOfClass from: oldClass forSuper: oldClass superclass extra: instVars size) ifFalse:[^nil]]. - "See if we need a new subclass or not" - needNew := self needsSubclassOf: oldClass superclass type: oldClass typeOfClass instanceVariables: instVars from: oldClass. - needNew ifNil:[^nil]. "some error" - needNew ifFalse:[^oldClass]. "no new class needed" - - "Create the new class" - copyOfOldClass := oldClass copy. - newClass := self - newSubclassOf: oldClass superclass - type: oldClass typeOfClass - instanceVariables: instVars - from: oldClass. - - newClass := self recompile: false from: oldClass to: newClass mutate: false. - self doneCompiling: newClass. - SystemChangeNotifier uniqueInstance classDefinitionChangedFrom: copyOfOldClass to: newClass. - ^newClass! Item was removed: - ----- Method: ClassBuilder>>computeFormat:instSize:forSuper: (in category 'class format') ----- - computeFormat: type instSize: newInstSize forSuper: newSuper - "Compute the new format for making oldClass a subclass of newSuper. - Answer the format or nil if there is any problem." - | instSize isVar isPointers isWeak bitsUnitSize | - type == #compiledMethod ifTrue: - [newInstSize > 0 ifTrue: - [self error: 'A compiled method class cannot have named instance variables'. - ^nil]. - ^CompiledMethod format]. - instSize := newInstSize + (newSuper ifNil:[0] ifNotNil:[newSuper instSize]). - instSize > 65535 ifTrue: - [self error: 'Class has too many instance variables (', instSize printString,')'. - ^nil]. - type == #normal ifTrue:[isVar := isWeak := false. isPointers := true]. - type == #bytes ifTrue:[isVar := true. bitsUnitSize := 1. isPointers := isWeak := false]. - type == #shorts ifTrue:[isVar := true. bitsUnitSize := 2. isPointers := isWeak := false]. - type == #words ifTrue:[isVar := true. bitsUnitSize := 4. isPointers := isWeak := false]. - type == #longs ifTrue:[isVar := true. bitsUnitSize := 8. isPointers := isWeak := false]. - type == #variable ifTrue:[isVar := isPointers := true. isWeak := false]. - type == #weak ifTrue:[isVar := isWeak := isPointers := true]. - type == #ephemeron ifTrue:[isVar := false. isWeak := isPointers := true]. - type == #immediate ifTrue:[isVar := isWeak := isPointers := false]. - (isPointers not and: [instSize > 0]) ifTrue: - [self error: 'A non-pointer class cannot have named instance variables'. - ^nil]. - ^self format: instSize variable: isVar bitsUnitSize: bitsUnitSize pointers: isPointers weak: isWeak! Item was removed: - ----- Method: ClassBuilder>>doneCompiling: (in category 'initialize') ----- - doneCompiling: aClass - "The receiver has finished modifying the class hierarchy. - Do any necessary cleanup." - aClass doneCompiling. - Behavior flushObsoleteSubclasses.! Item was removed: - ----- Method: ClassBuilder>>format:variable:bitsUnitSize:pointers:weak: (in category 'class format') ----- - format: nInstVars variable: isVar bitsUnitSize: bitsUnitSize 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 (Context BlockClosure 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, SmallFloat64) - 8 = unused - 9 = 64-bit indexable - 10-11 = 32-bit indexable (Bitmap, WideString) - 12-15 = 16-bit indexable - 16-23 = 8-bit indexable (ByteString) - 24-31 = compiled methods (CompiledMethod)" - | instSpec | - 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: [bitsUnitSize caseOf: { - [1] -> [16]. - [2] -> [12]. - [4] -> [10]. - [8] -> [9] }] - ifFalse: [7]]]. - ^(instSpec bitShift: 16) + nInstVars! Item was removed: - ----- Method: ClassBuilder>>informUserDuring: (in category 'private') ----- - informUserDuring: aBlock - self class isSilent ifTrue:[^aBlock value]. - UIManager default informUserDuring:[:bar| - progress := bar. - aBlock value]. - progress := nil.! Item was removed: - ----- Method: ClassBuilder>>initialize (in category 'initialize') ----- - initialize - environ := Smalltalk. - instVarMap := IdentityDictionary new.! Item was removed: - ----- Method: ClassBuilder>>moveInstVarNamed:from:to:after: (in category 'public') ----- - moveInstVarNamed: instVarName from: srcClass to: dstClass after: prevInstVarName - "Move the given instVar from srcClass to dstClass" - (srcClass instVarNames includes: instVarName) - ifFalse:[^self error: instVarName,' is not an instance variable of ', srcClass name]. - (prevInstVarName isNil or:[dstClass instVarNames includes: prevInstVarName]) - ifFalse:[^self error: prevInstVarName, 'is not an instance variable of', dstClass name]. - (srcClass inheritsFrom: dstClass) ifTrue:[ - "Move the instvar up the hierarchy." - (self validateClass: srcClass forMoving: instVarName upTo: dstClass) - ifFalse:[^false]. - ]. - (dstClass inheritsFrom: srcClass) ifTrue:[ - "Move the instvar down the hierarchy" - (self validateClass: srcClass forMoving: instVarName downTo: dstClass) - ifFalse:[^false]. - ]. - ^self silentlyMoveInstVarNamed: instVarName from: srcClass to: dstClass after: prevInstVarName! Item was removed: - ----- Method: ClassBuilder>>mutate:to: (in category 'class mutation') ----- - mutate: oldClass to: newClass - "Mutate the old class and subclasses into newClass and subclasses. - Note: This method is slightly different from: #mutate:toSuper: since - here we are at the root of reshaping and have two distinct roots." - self showProgressFor: oldClass. - "Convert the subclasses" - oldClass subclasses do:[:oldSubclass| - | newSubclass | - newSubclass := self reshapeClass: oldSubclass toSuper: newClass. - self mutate: oldSubclass to: newSubclass. - ]. - "And any obsolete ones" - oldClass obsoleteSubclasses do:[:oldSubclass| - oldSubclass ifNotNil:[ - | newSubclass | - newSubclass := self reshapeClass: oldSubclass toSuper: newClass. - self mutate: oldSubclass to: newSubclass. - ]. - ]. - self update: oldClass to: newClass. - ^newClass! Item was removed: - ----- Method: ClassBuilder>>name:inEnvironment:subclassOf:type:instanceVariableNames:classVariableNames:poolDictionaries:category: (in category 'class definition') ----- - name: className inEnvironment: env subclassOf: newSuper type: type instanceVariableNames: instVarString classVariableNames: classVarString poolDictionaries: poolString category: category - "Define a new class in the given environment" - ^self - name: className - inEnvironment: env - subclassOf: newSuper - type: type - instanceVariableNames: instVarString - classVariableNames: classVarString - poolDictionaries: poolString - category: category - unsafe: false! Item was removed: - ----- Method: ClassBuilder>>name:inEnvironment:subclassOf:type:instanceVariableNames:classVariableNames:poolDictionaries:category:unsafe: (in category 'class definition') ----- - name: className inEnvironment: env subclassOf: newSuper type: type instanceVariableNames: instVarString classVariableNames: classVarString poolDictionaries: poolString category: category unsafe: unsafe - "Define a new class in the given environment. - If unsafe is true do not run any validation checks. - This facility is provided to implement important system changes." - | oldClass instVars classVars copyOfOldClass newClass | - - environ := env. - instVars := Scanner new scanFieldNames: instVarString. - classVars := (Scanner new scanFieldNames: classVarString) collect: [:x | x asSymbol]. - - "Validate the proposed name" - unsafe ifFalse:[(self validateClassName: className) ifFalse:[^nil]]. - oldClass := env at: className ifAbsent:[nil]. - oldClass isBehavior - ifFalse: [oldClass := nil] "Already checked in #validateClassName:" - ifTrue: [ - copyOfOldClass := oldClass copy. - copyOfOldClass superclass addSubclass: copyOfOldClass]. - - - [ | newCategory needNew force organization oldCategory | - unsafe ifFalse:[ - "Run validation checks so we know that we have a good chance for recompilation" - (self validateSuperclass: newSuper forSubclass: oldClass) ifFalse:[^nil]. - (self validateInstvars: instVars from: oldClass forSuper: newSuper) ifFalse:[^nil]. - (self validateClassvars: classVars from: oldClass forSuper: newSuper) ifFalse:[^nil]. - (self validateSubclassFormat: type from: oldClass forSuper: newSuper extra: instVars size) ifFalse:[^nil]]. - - "See if we need a new subclass" - needNew := self needsSubclassOf: newSuper type: type instanceVariables: instVars from: oldClass. - needNew == nil ifTrue:[^nil]. "some error" - - (needNew and:[unsafe not]) ifTrue:[ - "Make sure we don't redefine any dangerous classes" - (self tooDangerousClasses includes: oldClass name) ifTrue:[ - self error: oldClass name, ' cannot be changed'. - ]. - "Check if the receiver should not be redefined" - (oldClass ~~ nil and:[oldClass shouldNotBeRedefined]) ifTrue:[ - self notify: oldClass name asText allBold, - ' should not be redefined. \Proceed to store over it.' withCRs]]. - - needNew ifTrue:[ - "Create the new class" - newClass := self - newSubclassOf: newSuper - type: type - instanceVariables: instVars - from: oldClass. - newClass == nil ifTrue:[^nil]. "Some error" - newClass setName: className. - newClass environment: environ. - ] ifFalse:[ - "Reuse the old class" - newClass := oldClass. - ]. - - "Install the class variables and pool dictionaries... " - force := (newClass declare: classVarString) | (newClass sharing: poolString). - - "... classify ..." - category ifNotNil: [ - newCategory := category asSymbol. - organization := environ ifNotNil:[environ organization]. - oldClass isNil ifFalse: [oldCategory := (organization categoryOfElement: oldClass name) asSymbol]. - organization classify: newClass name under: newCategory suppressIfDefault: true]. - - "... recompile ..." - newClass := self recompile: force from: oldClass to: newClass mutate: false. - - "... export if not yet done ..." - (environ at: newClass name ifAbsent:[nil]) == newClass ifFalse:[ - [environ at: newClass name put: newClass] - on: AttemptToWriteReadOnlyGlobal do:[:ex| ex resume: true]. - environ flushClassNameCache. - ]. - - - newClass doneCompiling. - "... notify interested clients ..." - oldClass isNil ifTrue: [ - SystemChangeNotifier uniqueInstance classAdded: newClass inCategory: newCategory. - ^ newClass]. - newCategory ~= oldCategory - ifTrue: [SystemChangeNotifier uniqueInstance class: newClass recategorizedFrom: oldCategory to: category] - ifFalse: [SystemChangeNotifier uniqueInstance classDefinitionChangedFrom: copyOfOldClass to: newClass.]. - ] ensure: - [copyOfOldClass ifNotNil: [copyOfOldClass superclass removeSubclass: copyOfOldClass]. - Behavior flushObsoleteSubclasses. - ]. - ^newClass! Item was removed: - ----- Method: ClassBuilder>>needsSubclassOf:type:instanceVariables:from: (in category 'class definition') ----- - needsSubclassOf: newSuper type: type instanceVariables: instVars from: oldClass - "Answer whether we need a new subclass to conform to the requested changes" - | newFormat | - "Compute the format of the new class" - newFormat := self computeFormat: type instSize: instVars size forSuper: newSuper. - newFormat ifNil: [^nil]. - - "Check if we really need a new subclass" - oldClass ifNil:[^true]. "yes, it's a new class" - newSuper == oldClass superclass ifFalse:[^true]. "yes, it's a superclass change" - newFormat = oldClass format ifFalse:[^true]. "yes, it's a format change" - instVars = oldClass instVarNames ifFalse:[^true]. "yes, it's an iVar change" - - ^false - ! Item was removed: - ----- Method: ClassBuilder>>newSubclassOf:type:instanceVariables:from: (in category 'class definition') ----- - newSubclassOf: newSuper type: type instanceVariables: instVars from: oldClass - "Create a new subclass of the given superclass with the given specification." - | newFormat newClass | - "Compute the format of the new class" - newFormat := self computeFormat: type instSize: instVars size forSuper: newSuper. - - newFormat ifNil: [^nil]. - - (oldClass == nil or:[oldClass isMeta not]) - ifTrue:[newClass := self privateNewSubclassOf: newSuper from: oldClass] - ifFalse:[newClass := oldClass shallowCopy]. - - newClass - superclass: newSuper - methodDictionary: (oldClass ifNil: [MethodDictionary new] ifNotNil: [oldClass methodDict copy]) - format: newFormat; - setInstVarNames: instVars. - - oldClass ifNotNil:[ - newClass organization: oldClass organization. - "Recompile the new class" - oldClass hasMethods - ifTrue:[newClass compileAllFrom: oldClass]. - - oldClass hasTraitComposition ifTrue: [ - newClass setTraitComposition: oldClass traitComposition copyTraitExpression ]. - oldClass class hasTraitComposition ifTrue: [ - newClass class setTraitComposition: oldClass class traitComposition copyTraitExpression ]. - - self recordClass: oldClass replacedBy: newClass. - ]. - - (oldClass == nil or:[oldClass isObsolete not]) - ifTrue:[newSuper addSubclass: newClass] - ifFalse:[newSuper addObsoleteSubclass: newClass]. - - ^newClass! Item was removed: - ----- Method: ClassBuilder>>privateNewSubclassOf: (in category 'private') ----- - privateNewSubclassOf: newSuper - "Create a new meta and non-meta subclass of newSuper" - "WARNING: This method does not preserve the superclass/subclass invariant!!" - | newSuperMeta newMeta | - newSuperMeta := newSuper ifNil:[Class] ifNotNil:[newSuper class]. - newMeta := Metaclass new. - newMeta - superclass: newSuperMeta - methodDictionary: MethodDictionary new - format: newSuperMeta format. - ^newMeta new - ! Item was removed: - ----- Method: ClassBuilder>>privateNewSubclassOf:from: (in category 'private') ----- - privateNewSubclassOf: newSuper from: oldClass - "Create a new meta and non-meta subclass of newSuper using oldClass as template" - "WARNING: This method does not preserve the superclass/subclass invariant!!" - | newSuperMeta oldMeta newMeta | - oldClass ifNil:[^self privateNewSubclassOf: newSuper]. - newSuperMeta := newSuper ifNil:[Class] ifNotNil:[newSuper class]. - oldMeta := oldClass class. - newMeta := oldMeta shallowCopy. - newMeta - superclass: newSuperMeta - methodDictionary: oldMeta methodDict copy - format: (self computeFormat: oldMeta typeOfClass - instSize: oldMeta instVarNames size - forSuper: newSuperMeta); - setInstVarNames: oldMeta instVarNames; - organization: oldMeta organization. - "Recompile the meta class" - oldMeta hasMethods - ifTrue:[newMeta compileAllFrom: oldMeta]. - "Record the meta class change" - self recordClass: oldMeta replacedBy: newMeta. - "And create a new instance" - ^newMeta adoptInstance: oldClass from: oldMeta! Item was removed: - ----- Method: ClassBuilder>>recompile:from:to:mutate: (in category 'class definition') ----- - recompile: force from: oldClass to: newClass mutate: forceMutation - "Do the necessary recompilation after changine oldClass to newClass. - If required (e.g., when oldClass ~~ newClass) mutate oldClass to newClass - and all its subclasses. If forceMutation is true force a mutation even - if oldClass and newClass are the same." - - oldClass == nil ifTrue:[^ newClass]. - - (newClass == oldClass and:[force not and:[forceMutation not]]) ifTrue:[ - ^newClass]. - - currentClassIndex := 0. - maxClassIndex := oldClass withAllSubclasses size. - - (oldClass == newClass and:[forceMutation not]) ifTrue:[ - "Recompile from newClass without mutating" - self informUserDuring:[ - newClass isSystemDefined ifFalse:[progress := nil]. - CurrentReadOnlySourceFiles cacheDuring: [ - newClass withAllSubclassesDo:[:cl| - self showProgressFor: cl. - cl compileAll]]]. - ^newClass]. - "Recompile and mutate oldClass to newClass" - self informUserDuring:[ - newClass isSystemDefined ifFalse:[progress := nil]. - CurrentReadOnlySourceFiles cacheDuring: [ - self mutate: oldClass to: newClass]. - ]. - ^oldClass "now mutated to newClass"! Item was removed: - ----- Method: ClassBuilder>>recordClass:replacedBy: (in category 'private') ----- - recordClass: oldClass replacedBy: newClass - "Keep the changes up to date when we're moving instVars around" - (instVarMap includesKey: oldClass name) ifTrue:[ - SystemChangeNotifier uniqueInstance classDefinitionChangedFrom: oldClass to: newClass. - ].! Item was removed: - ----- Method: ClassBuilder>>reservedNames (in category 'private') ----- - reservedNames - "Return a list of names that must not be used for variables" - ^#(self super thisContext #true #false #nil)! Item was removed: - ----- Method: ClassBuilder>>reshapeClass:toSuper: (in category 'class mutation') ----- - reshapeClass: oldClass toSuper: newSuper - "Reshape the given class to the new super class. Recompile all the methods in the newly created class. Answer the new class." - | instVars | - instVars := instVarMap at: oldClass name ifAbsent: [oldClass instVarNames]. - - ^self newSubclassOf: newSuper - type: oldClass typeOfClass - instanceVariables: instVars - from: oldClass! Item was removed: - ----- Method: ClassBuilder>>showProgressFor: (in category 'private') ----- - showProgressFor: aClass - "Announce that we're processing aClass" - progress == nil ifTrue:[^self]. - aClass isObsolete ifTrue:[^self]. - currentClassIndex := currentClassIndex + 1. - (aClass hasMethods and: [aClass wantsRecompilationProgressReported]) ifTrue: - [progress value: ('Recompiling ', aClass name,' (', currentClassIndex printString,'/', maxClassIndex printString,')')]! Item was removed: - ----- Method: ClassBuilder>>silentlyMoveInstVarNamed:from:to:after: (in category 'class definition') ----- - silentlyMoveInstVarNamed: instVarName from: srcClass to: dstClass after: prevInstVarName - "Move the instvar from srcClass to dstClass. - Do not perform any checks." - | srcVars dstVars dstIndex newClass copyOfSrcClass copyOfDstClass | - copyOfSrcClass := srcClass copy. - copyOfDstClass := dstClass copy. - - srcVars := srcClass instVarNames copyWithout: instVarName. - srcClass == dstClass - ifTrue:[dstVars := srcVars] - ifFalse:[dstVars := dstClass instVarNames]. - dstIndex := dstVars indexOf: prevInstVarName. - dstVars := (dstVars copyFrom: 1 to: dstIndex), - (Array with: instVarName), - (dstVars copyFrom: dstIndex+1 to: dstVars size). - instVarMap at: srcClass name put: srcVars. - instVarMap at: dstClass name put: dstVars. - (srcClass inheritsFrom: dstClass) ifTrue:[ - newClass := self reshapeClass: dstClass toSuper: dstClass superclass. - self recompile: false from: dstClass to: newClass mutate: true. - ] ifFalse:[ - (dstClass inheritsFrom: srcClass) ifTrue:[ - newClass := self reshapeClass: srcClass toSuper: srcClass superclass. - self recompile: false from: srcClass to: newClass mutate: true. - ] ifFalse:[ "Disjunct hierarchies" - srcClass == dstClass ifFalse:[ - newClass := self reshapeClass: dstClass toSuper: dstClass superclass. - self recompile: false from: dstClass to: newClass mutate: true. - ]. - newClass := self reshapeClass: srcClass toSuper: srcClass superclass. - self recompile: false from: srcClass to: newClass mutate: true. - ]. - ]. - self doneCompiling: srcClass. - self doneCompiling: dstClass. - SystemChangeNotifier uniqueInstance classDefinitionChangedFrom: copyOfSrcClass to: srcClass. - SystemChangeNotifier uniqueInstance classDefinitionChangedFrom: copyOfDstClass to: dstClass.! Item was removed: - ----- Method: ClassBuilder>>superclass:ephemeronSubclass:instanceVariableNames:classVariableNames:poolDictionaries:category: (in category 'public') ----- - superclass: aClass - ephemeronSubclass: t instanceVariableNames: f - classVariableNames: d poolDictionaries: s category: cat - "This is the standard initialization message for creating a new class as a - subclass of an existing class (the receiver) in which the subclass is to - have ephemeron semantics, i.e. where the object will be queued for - finalization when the key (first) inst var is not reachable other than through - the other fields of ephemerons with unreachable keys." - | env | - aClass isPointers ifFalse: - [^self error: 'cannot make a pointer subclass of a class with non-pointer fields']. - aClass instSize + f substrings size < 2 ifTrue: - [^self error: 'cannot make an ephemeron class with less than two named instance variables']. - env := CurrentEnvironment signal ifNil: [aClass environment]. - ^self - name: t - inEnvironment: env - subclassOf: aClass - type: #ephemeron - instanceVariableNames: f - classVariableNames: d - poolDictionaries: s - category: cat! Item was removed: - ----- 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 removed: - ----- Method: ClassBuilder>>superclass:subclass:instanceVariableNames:classVariableNames:poolDictionaries:category: (in category 'public') ----- - superclass: newSuper - subclass: t instanceVariableNames: f - classVariableNames: d poolDictionaries: s category: cat - "This is the standard initialization message for creating a new class as a - subclass of an existing class." - | env | - env := CurrentEnvironment signal ifNil: [newSuper environment]. - ^self - name: t - inEnvironment: env - subclassOf: newSuper - type: newSuper typeOfClass - instanceVariableNames: f - classVariableNames: d - poolDictionaries: s - category: cat! Item was removed: - ----- Method: ClassBuilder>>superclass:variableByteSubclass:instanceVariableNames:classVariableNames:poolDictionaries:category: (in category 'public') ----- - superclass: aClass - variableByteSubclass: n instanceVariableNames: f - classVariableNames: d poolDictionaries: s category: cat - "This is the standard initialization message for creating a new class as a subclass of an - existing class in which the subclass is to have indexable 8-bit byte-sized nonpointer variables." - | existingOrSuperclass actualType env | - aClass instSize > 0 ifTrue: - [^self error: 'cannot make a byte subclass of a class with named fields']. - (aClass isVariable and: [aClass isBytes not]) ifTrue: - [^self error: 'cannot make an 8-bit byte subclass of a class with 16, 32 or 64 bit fields']. - (aClass isVariable and: [aClass isPointers]) ifTrue: - [^self error: 'cannot make a byte subclass of a class with pointer fields']. - existingOrSuperclass := aClass environment at: n ifAbsent: [aClass]. - actualType := existingOrSuperclass typeOfClass == #compiledMethod - ifTrue: [#compiledMethod] - ifFalse: [#bytes]. - env := CurrentEnvironment signal ifNil: [aClass environment]. - ^self - name: n - inEnvironment: env - subclassOf: aClass - type: actualType - instanceVariableNames: f - classVariableNames: d - poolDictionaries: s - category: cat! Item was removed: - ----- Method: ClassBuilder>>superclass:variableDoubleByteSubclass:instanceVariableNames:classVariableNames:poolDictionaries:category: (in category 'public') ----- - superclass: aClass - variableDoubleByteSubclass: t instanceVariableNames: f - classVariableNames: d poolDictionaries: s category: cat - "This is the standard initialization message for creating a new class as a subclass of an - existing class in which the subclass is to have indexable 16-bit-sized nonpointer variables." - | oldClassOrNil env | - aClass instSize > 0 - ifTrue: [^self error: 'cannot make a byte subclass of a class with named fields']. - (aClass isVariable and: [aClass isShorts not]) - ifTrue: [^self error: 'cannot make a 16-bit short subclass of a class with 8, 32 or 64 bit fields']. - (aClass isVariable and: [aClass isPointers]) - ifTrue: [^self error: 'cannot make a byte subclass of a class with pointer fields']. - oldClassOrNil := aClass environment at: t ifAbsent:[nil]. - env := CurrentEnvironment signal ifNil: [aClass environment]. - ^self - name: t - inEnvironment: env - subclassOf: aClass - type: #shorts - instanceVariableNames: f - classVariableNames: d - poolDictionaries: s - category: cat! Item was removed: - ----- Method: ClassBuilder>>superclass:variableDoubleWordSubclass:instanceVariableNames:classVariableNames:poolDictionaries:category: (in category 'public') ----- - superclass: aClass - variableDoubleWordSubclass: t instanceVariableNames: f - classVariableNames: d poolDictionaries: s category: cat - "This is the standard initialization message for creating a new class as a subclass of an - existing class in which the subclass is to have indexable 16-bit-sized nonpointer variables." - | oldClassOrNil env | - aClass instSize > 0 - ifTrue: [^self error: 'cannot make a byte subclass of a class with named fields']. - (aClass isVariable and: [aClass isLongs not]) - ifTrue: [^self error: 'cannot make a 64-bit long subclass of a class with 8, 16 or 32 bit fields']. - (aClass isVariable and: [aClass isPointers]) - ifTrue: [^self error: 'cannot make a byte subclass of a class with pointer fields']. - oldClassOrNil := aClass environment at: t ifAbsent:[nil]. - env := CurrentEnvironment signal ifNil: [aClass environment]. - ^self - name: t - inEnvironment: env - subclassOf: aClass - type: #longs - instanceVariableNames: f - classVariableNames: d - poolDictionaries: s - category: cat! Item was removed: - ----- Method: ClassBuilder>>superclass:variableSubclass:instanceVariableNames:classVariableNames:poolDictionaries:category: (in category 'public') ----- - superclass: aClass - variableSubclass: t instanceVariableNames: f - classVariableNames: d poolDictionaries: s category: cat - "This is the standard initialization message for creating a new class as a - subclass of an existing class in which the subclass is to - have indexable pointer variables." - - | env | - aClass isBits ifTrue: - [^self error: 'cannot make a pointer subclass of a class with non-pointer fields']. - env := CurrentEnvironment signal ifNil: [aClass environment]. - ^self - name: t - inEnvironment: env - subclassOf: aClass - type: #variable - instanceVariableNames: f - classVariableNames: d - poolDictionaries: s - category: cat! Item was removed: - ----- Method: ClassBuilder>>superclass:variableWordSubclass:instanceVariableNames:classVariableNames:poolDictionaries:category: (in category 'public') ----- - superclass: aClass - variableWordSubclass: t instanceVariableNames: f - classVariableNames: d poolDictionaries: s category: cat - "This is the standard initialization message for creating a new class as a subclass of an - existing class in which the subclass is to have indexable 32-bit word-sized nonpointer variables." - | env | - aClass instSize > 0 - ifTrue: [^self error: 'cannot make a word subclass of a class with named fields']. - (aClass isVariable and: [aClass isWords not]) - ifTrue: [^self error: 'cannot make a 32-bit word subclass of a class with 8, 16 or 64 bit fields']. - (aClass isVariable and: [aClass isPointers]) - ifTrue: [^self error: 'cannot make a word subclass of a class with pointer fields']. - env := CurrentEnvironment signal ifNil: [aClass environment]. - ^self - name: t - inEnvironment: env - subclassOf: aClass - type: #words - instanceVariableNames: f - classVariableNames: d - poolDictionaries: s - category: cat! Item was removed: - ----- Method: ClassBuilder>>superclass:weakSubclass:instanceVariableNames:classVariableNames:poolDictionaries:category: (in category 'public') ----- - superclass: aClass - weakSubclass: t instanceVariableNames: f - classVariableNames: d poolDictionaries: s category: cat - "This is the standard initialization message for creating a new class as a - subclass of an existing class (the receiver) in which the subclass is to - have weak indexable pointer variables." - | env | - aClass isBits - ifTrue: [^self error: 'cannot make a pointer subclass of a class with non-pointer fields']. - env := CurrentEnvironment signal ifNil: [aClass environment]. - ^self - name: t - inEnvironment: env - subclassOf: aClass - type: #weak - instanceVariableNames: f - classVariableNames: d - poolDictionaries: s - category: cat! Item was removed: - ----- Method: ClassBuilder>>tooDangerousClasses (in category 'private') ----- - tooDangerousClasses - "Return a list of class names which will not be modified in the public interface" - ^#( - "Object will break immediately" - ProtoObject Object - "Contexts and their superclasses" - InstructionStream Context BlockClosure - "Superclasses of basic collections" - Collection SequenceableCollection ArrayedCollection - "Collections known to the VM" - Array Bitmap String Symbol ByteArray CompiledCode CompiledMethod CompiledBlock - "Basic Numbers & Magnitudes" - Magnitude Number SmallInteger Float BoxedFloat64 SmallFloat64 Character - "Misc other" - LookupKey Association Link Point Rectangle Behavior PositionableStream UndefinedObject - ) - ! Item was removed: - ----- 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" - | 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." - - 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} elementsForwardIdentityAndHashTo: {newClass}. - oldClass updateMethodBindingsTo: oldClass binding] - ifFalse: - [{oldClass. oldClass class} elementsForwardIdentityAndHashTo: {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! Item was removed: - ----- Method: ClassBuilder>>validateClass:forMoving:downTo: (in category 'validation') ----- - validateClass: srcClass forMoving: iv downTo: dstClass - "Make sure that we don't have any accesses to the instVar left" - srcClass withAllSubclassesDo:[:cls| - (cls == dstClass or:[cls inheritsFrom: dstClass]) ifFalse:[ - (cls whichSelectorsAccess: iv) isEmpty ifFalse:[ - self notify: (iv printString asText allBold), ' is still used in ', cls name asText allBold,'. - Proceed to move it to Undeclared'. - ]. - ]. - ]. - ^true! Item was removed: - ----- Method: ClassBuilder>>validateClass:forMoving:upTo: (in category 'validation') ----- - validateClass: srcClass forMoving: iv upTo: dstClass - "Make sure we don't have this instvar already" - dstClass withAllSubclassesDo:[:cls| - (cls == srcClass or:[cls inheritsFrom: srcClass]) ifFalse:[ - cls isPointers ifFalse:[ - self error: dstClass name, ' cannot have instance variables'. - ^false]. - cls instSize >= 254 ifTrue:[ - self error: cls name, ' has more than 254 instance variables'. - ^false]. - (cls instVarNames includes: iv) ifTrue:[ - self notify: (iv printString asText allBold),' is defined in ', cls name asText allBold,' - Proceed to move it up to ', dstClass name asText allBold,' as well'. - instVarMap at: cls name put: (cls instVarNames copyWithout: iv)]. - ]. - ]. - ^true! Item was removed: - ----- Method: ClassBuilder>>validateClassName: (in category 'validation') ----- - validateClassName: aString - "Validate the new class name" - aString first canBeGlobalVarInitial ifFalse:[ - self error: 'Class names must be capitalized'. - ^false]. - environ at: aString ifPresent:[:old| - (old isKindOf: Behavior) ifFalse:[ - self notify: aString asText allBold, - ' already exists!!\Proceed will store over it.' withCRs]]. - ^true! Item was removed: - ----- Method: ClassBuilder>>validateClassvars:from:forSuper: (in category 'validation') ----- - validateClassvars: classVarArray from: oldClass forSuper: newSuper - "Check if any of the classVars of oldClass conflict with the new superclass" - | usedNames classVars temp | - classVarArray isEmpty ifTrue:[^true]. "Okay" - - "Validate the class var names" - usedNames := classVarArray asSet. - usedNames size = classVarArray size - ifFalse:[ classVarArray do:[:var| - usedNames remove: var ifAbsent:[temp := var]]. - self error: temp,' is multiply defined'. ^false]. - (usedNames includesAnyOf: self reservedNames) - ifTrue:[ self reservedNames do:[:var| - (usedNames includes: var) ifTrue:[temp := var]]. - self error: temp,' is a reserved name'. ^false]. - - newSuper == nil ifFalse:[ - usedNames := newSuper allClassVarNames asSet. - classVarArray do:[:iv| - (usedNames includes: iv) ifTrue:[ - newSuper withAllSuperclassesDo:[:cl| - (cl classVarNames includes: iv) ifTrue:[temp := cl]]. - (DuplicateVariableError new) - superclass: temp; - variable: iv; - signal: iv,' is already defined in ', temp name]]]. - - oldClass == nil ifFalse:[ - usedNames := Set new: 20. - oldClass allSubclassesDo:[:cl| usedNames addAll: cl classVarNames]. - classVars := classVarArray. - newSuper == nil ifFalse:[classVars := classVars, newSuper allClassVarNames asArray]. - classVars do:[:iv| - (usedNames includes: iv) ifTrue:[ - (DuplicateVariableError new) - superclass: oldClass; - variable: iv; - signal: iv, ' is already defined in a subclass of ', oldClass name]]]. - ^true! Item was removed: - ----- Method: ClassBuilder>>validateInstvars:from:forSuper: (in category 'validation') ----- - validateInstvars: instVarArray from: oldClass forSuper: newSuper - "Check if any of the instVars of oldClass conflict with the new superclass" - | usedNames | - usedNames := instVarArray asSet. - oldClass ifNotNil: [ oldClass withAllSubclassesDo: [ : each | each == oldClass ifFalse: [usedNames addAll: each instVarNames] ] ]. - "Anything to possibly conflict?" - usedNames isEmpty ifTrue: [ ^ true ]. - newSuper allowsSubInstVars ifFalse: - [ self error: newSuper printString , ' does not allow subclass inst vars. See allowsSubInstVars.'. - ^ false ]. - instVarArray asSet size = instVarArray size ifFalse: - [ self error: instVarArray asBag sortedCounts first value, ' is multply defined.'. - ^ false ]. - (usedNames intersection: self reservedNames) ifNotEmpty: - [ : reservedWords | self error: reservedWords anyOne , ' is a reserved name'. - ^ false ]. - newSuper ifNotNil: - [ | offendingVars | - "If any variable names in subclasses conflict names in the new superclass, report the offending class and instVar name." - newSuper withAllSuperclasses - detect: [ : each | (offendingVars := each instVarNames intersection: usedNames) notEmpty ] - ifFound: - [ : offendingSuperclass | - DuplicateVariableError new - superclass: offendingSuperclass ; - variable: offendingVars anyOne ; - signal: offendingVars anyOne , ' is already defined in ' , offendingSuperclass name ] - ifNone: [ "no name conflicts" ] ]. - ^ true! Item was removed: - ----- Method: ClassBuilder>>validateSubclass:canKeepLayoutFrom:forSubclassFormat: (in category 'validation') ----- - validateSubclass: subclass canKeepLayoutFrom: oldClass forSubclassFormat: newType - "Returns whether the immediate subclasses of oldClass can keep its layout" - "Note: Squeak does not appear to model classFormat relationships.. so I'm putting some logic here. bkv 4/2/2003" - - "Only run this test for a real subclass - otherwise this prevents changing - a class from #subclass: to #variableSubclass: etc." - subclass = oldClass ifTrue:[^true]. - - "isWeak implies isVariant" - (oldClass isVariable and: [ subclass isWeak ]) - ifFalse: [ "In general we discourage format mis-matches" - (subclass typeOfClass == newType) - ifFalse: [ self error: subclass name,' cannot be recompiled'. - ^ false ]]. - ^ true! Item was removed: - ----- Method: ClassBuilder>>validateSubclassFormat:from:forSuper:extra: (in category 'validation') ----- - validateSubclassFormat: newType from: oldClass forSuper: newSuper extra: newInstSize - "Validate the # of instVars and the format of the subclasses" - | deltaSize | - oldClass == nil ifTrue: [^ true]. "No subclasses" - "Compute the # of instvars needed for all subclasses" - deltaSize := newInstSize. - (oldClass notNil) - ifTrue: [deltaSize := deltaSize - oldClass instVarNames size]. - (newSuper notNil) - ifTrue: [deltaSize := deltaSize + newSuper instSize]. - (oldClass notNil and: [oldClass superclass notNil]) - ifTrue: [deltaSize := deltaSize - oldClass superclass instSize]. - (oldClass == nil) - ifTrue: [ (deltaSize > 254) - ifTrue: [ self error: 'More than 254 instance variables'. - ^ false]. - ^ true]. - - oldClass withAllSubclassesDo: [:sub | ( sub instSize + deltaSize > 254 ) - ifTrue: [ self error: sub name,' has more than 254 instance variables'. - ^ false]. - - "If we get this far, check whether the immediate subclasses of oldClass can keep its layout." - (newType ~~ #normal) - ifTrue: [ self validateSubclass: sub canKeepLayoutFrom: oldClass forSubclassFormat: newType ]]. - - ^ true! Item was removed: - ----- Method: ClassBuilder>>validateSuperclass:forSubclass: (in category 'validation') ----- - validateSuperclass: aSuperClass forSubclass: aClass - "Check if it is okay to use aSuperClass as the superclass of aClass" - aClass == nil ifTrue:["New class" - (aSuperClass == nil or:[aSuperClass isBehavior and:[aSuperClass isMeta not]]) - ifFalse:[self error: aSuperClass name,' is not a valid superclass'. - ^false]. - ^true]. - aSuperClass == aClass superclass ifTrue:[^true]. "No change" - (aClass isMeta) "Not permitted - meta class hierarchy is derived from class hierarchy" - ifTrue:[^self error: aClass name, ' must inherit from ', aClass superclass name]. - "Check for circular references" - (aSuperClass ~~ nil and:[aSuperClass == aClass or:[aSuperClass inheritsFrom: aClass]]) - ifTrue:[self error: aSuperClass name,' inherits from ', aClass name. - ^false]. - ^true! Item was removed: - Object subclass: #ClassCategoryReader - instanceVariableNames: 'class category changeStamp' - classVariableNames: '' - poolDictionaries: '' - category: 'Kernel-Classes'! - - !ClassCategoryReader commentStamp: '<historical>' prior: 0! - I represent a mechanism for retrieving class descriptions stored on a file.! Item was removed: - ----- Method: ClassCategoryReader>>scanFrom: (in category 'fileIn/Out') ----- - scanFrom: aStream - "File in methods from the stream, aStream." - | methodText | - [methodText := aStream nextChunkText. - methodText size > 0] - whileTrue: - [class compile: methodText classified: category - withStamp: changeStamp notifying: nil]! Item was removed: - ----- Method: ClassCategoryReader>>scanFrom:environment: (in category 'fileIn/Out') ----- - scanFrom: aStream environment: anEnvironment - "File in methods from the stream, aStream." - | methodText | - [methodText := aStream nextChunkText. - methodText size > 0] whileTrue: - [class - compile: methodText - environment: anEnvironment - classified: category - withStamp: changeStamp - notifying: nil]! Item was removed: - ----- Method: ClassCategoryReader>>scanFromNoCompile: (in category 'fileIn/Out') ----- - scanFromNoCompile: aStream - "Just move the source code for the methods from aStream." - | methodText selector | - - [methodText := aStream nextChunkText. - methodText size > 0] - whileTrue: - [(SourceFiles at: 2) ifNotNil: [ - selector := class newParser parseSelector: methodText. - (class compiledMethodAt: selector) putSource: methodText - fromParseNode: nil class: class category: category - withStamp: changeStamp inFile: 2 priorMethod: nil]]! Item was removed: - ----- Method: ClassCategoryReader>>scanFromNoCompile:forSegment: (in category 'fileIn/Out') ----- - scanFromNoCompile: aStream forSegment: anImageSegment - - ^self scanFromNoCompile: aStream "subclasses may care about the segment"! Item was removed: - ----- Method: ClassCategoryReader>>setClass:category: (in category 'private') ----- - setClass: aClass category: aCategory - ^ self setClass: aClass category: aCategory changeStamp: String new - ! Item was removed: - ----- Method: ClassCategoryReader>>setClass:category:changeStamp: (in category 'private') ----- - setClass: aClass category: aCategory changeStamp: aString - - class := aClass. - category := aCategory. - changeStamp := aString - ! Item was removed: - ----- Method: ClassCategoryReader>>theClass (in category 'private') ----- - theClass - - ^ class! Item was removed: - ClassCategoryReader subclass: #ClassCommentReader - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Kernel-Classes'! Item was removed: - ----- Method: ClassCommentReader>>scanFrom: (in category 'filein/Out') ----- - scanFrom: aStream - "File in the class comment from aStream. Not string-i-fied, just a text, exactly as it is in the browser. Move to changes file." - - class theNonMetaClass classComment: (aStream nextChunkText) stamp: changeStamp - "Writes it on the disk and saves a RemoteString ref"! Item was removed: - ----- Method: ClassCommentReader>>scanFrom:environment: (in category 'filein/Out') ----- - scanFrom: aStream environment: anEnvironment - ^ self scanFrom: aStream! Item was removed: - ----- Method: ClassCommentReader>>scanFromNoCompile: (in category 'filein/Out') ----- - scanFromNoCompile: aStream - "File in the class comment from aStream. Not string-i-fied, just a text, exactly as it is in the browser. Move to changes file." - - self scanFrom: aStream. "for comments, the same as usual"! Item was removed: - Behavior subclass: #ClassDescription - instanceVariableNames: 'instanceVariables organization' - classVariableNames: 'AcceptsLoggingOfCompilation TraitImpl' - poolDictionaries: '' - category: 'Kernel-Classes'! - - !ClassDescription commentStamp: '<historical>' prior: 0! - I add a number of facilities to basic Behaviors: - Named instance variables - Category organization for methods - The notion of a name of this class (implemented as subclass responsibility) - The maintenance of a ChangeSet, and logging changes on a file - Most of the mechanism for fileOut. - - I am an abstract class, in particular, my facilities are intended for inheritance by two subclasses, Class and Metaclass. - - The slots 'organization' and 'methodDict' should ONLY be accessed by message in order for things to work during ImageSegment>>discoverActiveClasses (q.v.).! Item was removed: - ----- Method: ClassDescription class>>logCompiledSources (in category 'compiling') ----- - logCompiledSources - <preference: 'Log compilations to changes file' - category: 'general' - description: 'If enabled, the code being compiled will get logged to the changes file. Disabling allows loading code with no changes file in use. See also #warnIfNoChangesFile and #warnIfNoSourcesFile and #readDocumentAtStartup. You can configure a silent image/DoItFirst for, e.g., server environments.' - type: #Boolean> - - ^ AcceptsLoggingOfCompilation ifNil: [true]! Item was removed: - ----- Method: ClassDescription class>>logCompiledSources: (in category 'compiling') ----- - logCompiledSources: aBoolean - ^ AcceptsLoggingOfCompilation := aBoolean! Item was removed: - ----- Method: ClassDescription>>acceptsLoggingOfCompilation (in category 'compiling') ----- - acceptsLoggingOfCompilation - "weird name is so that it will come lexically before #compile, so that a clean build can make it through. 7/7/96 sw" - - ^AcceptsLoggingOfCompilation ifNil: [true]! Item was removed: - ----- Method: ClassDescription>>addAndClassifySelector:withMethod:inProtocol:notifying: (in category 'accessing method dictionary') ----- - addAndClassifySelector: selector withMethod: compiledMethod inProtocol: category notifying: requestor - | priorMethodOrNil | - priorMethodOrNil := self compiledMethodAt: selector ifAbsent: [nil]. - self addSelectorSilently: selector withMethod: compiledMethod. - SystemChangeNotifier uniqueInstance - doSilently: [self organization classify: selector under: category]. - priorMethodOrNil isNil - ifTrue: [SystemChangeNotifier uniqueInstance methodAdded: compiledMethod selector: selector inProtocol: category class: self requestor: requestor] - ifFalse: [SystemChangeNotifier uniqueInstance methodChangedFrom: priorMethodOrNil to: compiledMethod selector: selector inClass: self requestor: requestor].! Item was removed: - ----- Method: ClassDescription>>addInstVarName: (in category 'instance variables') ----- - addInstVarName: aString - "Add the argument, aString, as one of the receiver's instance variables." - - self subclassResponsibility! Item was removed: - ----- Method: ClassDescription>>addSelector:withMethod:notifying: (in category 'accessing method dictionary') ----- - addSelector: selector withMethod: compiledMethod notifying: requestor - | priorMethodOrNil | - priorMethodOrNil := self compiledMethodAt: selector ifAbsent: [nil]. - self addSelectorSilently: selector withMethod: compiledMethod. - priorMethodOrNil isNil - ifTrue: [SystemChangeNotifier uniqueInstance methodAdded: compiledMethod selector: selector inClass: self requestor: requestor] - ifFalse: [SystemChangeNotifier uniqueInstance methodChangedFrom: priorMethodOrNil to: compiledMethod selector: selector inClass: self requestor: requestor].! Item was removed: - ----- Method: ClassDescription>>addSelectorSilently:withMethod: (in category 'accessing method dictionary') ----- - addSelectorSilently: selector withMethod: compiledMethod - super addSelectorSilently: selector withMethod: compiledMethod. - self instanceSide noteAddedSelector: selector meta: self isMeta.! Item was removed: - ----- Method: ClassDescription>>allInstVarNamesEverywhere (in category 'instance variables') ----- - allInstVarNamesEverywhere - "Answer the set of inst var names used by the receiver, all superclasses, and all subclasses" - - | aList | - aList := OrderedCollection new. - (self allSuperclasses , self withAllSubclasses asOrderedCollection) do: - [:cls | aList addAll: cls instVarNames]. - ^ aList asSet - - "BorderedMorph allInstVarNamesEverywhere"! Item was removed: - ----- Method: ClassDescription>>allMethodCategoriesIntegratedThrough: (in category 'accessing method dictionary') ----- - allMethodCategoriesIntegratedThrough: mostGenericClass - "Answer a list of all the method categories of the receiver and all its superclasses, up through mostGenericClass" - - | aColl | - aColl := Set new. - self withAllSuperclasses do: - [:aClass | - (aClass includesBehavior: mostGenericClass) ifTrue: - [aColl addAll: aClass organization categories]]. - aColl remove: 'no messages' asSymbol ifAbsent: []. - - ^aColl asArray sort: [:a :b | a asLowercase < b asLowercase] - - "ColorTileMorph allMethodCategoriesIntegratedThrough: TileMorph"! Item was removed: - ----- Method: ClassDescription>>allMethodsInCategory: (in category 'accessing method dictionary') ----- - allMethodsInCategory: aName - "Answer a list of all the method categories of the receiver and all its - superclasses " - | set | - set := Set new. - self withAllSuperclassesDo: [:aClass | - set addAll: ( - aName = ClassOrganizer allCategory - ifTrue: [aClass organization allMethodSelectors] - ifFalse: [aClass organization listAtCategoryNamed: aName])]. - ^set sorted - - "TileMorph allMethodsInCategory: #initialization"! Item was removed: - ----- Method: ClassDescription>>category (in category 'organization') ----- - category - "Answer the system organization category for the receiver." - - ^ self environment organization categoryOfElement: self name! Item was removed: - ----- Method: ClassDescription>>checkForInstVarsOK: (in category 'instance variables') ----- - checkForInstVarsOK: instVarString - "Return true if instVarString does no include any names used in a subclass" - | instVarArray | - instVarArray := Scanner new scanFieldNames: instVarString. - self allSubclasses do: - [:cl | cl instVarNames do: - [:n | (instVarArray includes: n) - ifTrue: [self error: n , ' is already used in ' , cl name. - ^ false]]]. - ^ true! Item was removed: - ----- Method: ClassDescription>>chooseInstVarAlphabeticallyThenDo: (in category 'instance variables') ----- - chooseInstVarAlphabeticallyThenDo: aBlock - | allVars index | - "Put up a menu of all the instance variables in the receiver, presented in alphabetical order, and when the user chooses one, evaluate aBlock with the chosen variable as its parameter." - - allVars := self allInstVarNames. - allVars isEmpty ifTrue: [^ self inform: 'There are no - instance variables']. - allVars sort. - - index := (UIManager default chooseFrom: allVars lines: #() title: 'Instance variables in - ', self name). - index = 0 ifTrue: [^ self]. - aBlock value: (allVars at: index)! Item was removed: - ----- Method: ClassDescription>>chooseVarThenDo: (in category 'instance variables') ----- - chooseVarThenDo: aBlock - "Put up a menu of all the instance variables in the receiver, and when - the user chooses one, evaluate aBlock with the chosen variable as its - parameter." - | lines labelStream allVars index | - (self allInstVarNames size + self theNonMetaClass allClassVarNames size) = 0 ifTrue: [ ^ self inform: 'There are no variables.' ]. - allVars := OrderedCollection new. - lines := OrderedCollection new. - labelStream := WriteStream on: (String new: 200). - self withAllSuperclasses do: - [ : class | | vars | - vars := class instVarNames , class theNonMetaClass classVarNames. - vars do: - [ : var | labelStream - nextPutAll: var ; - cr. - allVars add: var ]. - vars isEmpty ifFalse: [ lines add: allVars size ] ]. - labelStream skip: -1. - "cut last CR" - (lines size > 0 and: [ lines last = allVars size ]) ifTrue: [ lines removeLast ]. - "dispense with inelegant line beneath last item" - index := Project uiManager - chooseFrom: (labelStream contents lines) - lines: lines - title: 'Variables in ' , self name. - index = 0 ifTrue: [ ^ self ]. - aBlock value: (allVars at: index)! Item was removed: - ----- Method: ClassDescription>>classComment: (in category 'fileIn/Out') ----- - classComment: aString - "Store the comment, aString or Text or RemoteString, associated with the class we are orgainzing. Empty string gets stored only if had a non-empty one before." - ^ self classComment: aString stamp: '<historical>'! Item was removed: - ----- Method: ClassDescription>>classComment:stamp: (in category 'fileIn/Out') ----- - classComment: aString stamp: aStamp - "Store the comment, aString or Text or RemoteString, associated with the class we are organizing. Empty string gets stored only if had a non-empty one before." - - | ptr header file oldCommentRemoteStr | - (aString isKindOf: RemoteString) ifTrue: - [SystemChangeNotifier uniqueInstance classCommented: self. - ^ self organization classComment: aString stamp: aStamp]. - - oldCommentRemoteStr := self organization commentRemoteStr. - (aString size = 0) & (oldCommentRemoteStr == nil) ifTrue: [^ self organization classComment: nil]. - "never had a class comment, no need to write empty string out" - - ptr := oldCommentRemoteStr ifNil: [0] ifNotNil: [oldCommentRemoteStr sourcePointer]. - SourceFiles ifNotNil: [(file := SourceFiles at: 2) ifNotNil: - [file setToEnd; cr; nextPut: $!!. "directly" - "Should be saying (file command: 'H3') for HTML, but ignoring it here" - header := String streamContents: [:strm | strm nextPutAll: self name; - nextPutAll: ' commentStamp: '. - aStamp storeOn: strm. - strm nextPutAll: ' prior: '; nextPutAll: ptr printString]. - file nextChunkPut: header]]. - self organization classComment: (RemoteString newString: aString onFileNumber: 2) stamp: aStamp. - file ifNotNil: [ InMidstOfFileinNotification signal ifFalse: [ file flush ] ]. - SystemChangeNotifier uniqueInstance classCommented: self. - ! Item was removed: - ----- Method: ClassDescription>>classCommentBlank (in category 'accessing comment') ----- - classCommentBlank - - ^String streamContents: - [:stream| - stream - nextPutAll: 'A'; - nextPutAll: (self name first isVowel ifTrue: ['n '] ifFalse: [' ']); - nextPutAll: self name; - nextPutAll: ' is xxxxxxxxx.'; - cr; cr; - nextPutAll: 'Instance Variables'. - - self instVarNames sorted do: [:each | - stream - crtab; nextPutAll: each; - nextPut: $:; - tab: 2; - nextPutAll: '<Object>']. - stream cr. - self instVarNames sorted do: [:each | - stream - cr; nextPutAll: each; - crtab; nextPutAll: '- xxxxx'; cr]]! Item was removed: - ----- Method: ClassDescription>>classSide (in category 'accessing parallel hierarchy') ----- - classSide - ^self theMetaClass! Item was removed: - ----- Method: ClassDescription>>classThatDefinesClassVariable: (in category 'instance variables') ----- - classThatDefinesClassVariable: classVarName - "Answer the class that defines the given class variable" - - (self classPool includesKey: classVarName asSymbol) ifTrue: [^ self]. - ^self superclass ifNotNil: [self superclass classThatDefinesClassVariable: classVarName]! Item was removed: - ----- Method: ClassDescription>>classThatDefinesInstanceVariable: (in category 'instance variables') ----- - classThatDefinesInstanceVariable: instVarName - (self instVarNames notNil and: [self instVarNames includes: instVarName asString]) ifTrue: [^ self]. - ^self superclass ifNotNil: [self superclass classThatDefinesInstanceVariable: instVarName]! Item was removed: - ----- Method: ClassDescription>>classVariablesString (in category 'printing') ----- - classVariablesString - "Answer a string of my class variable names separated by spaces." - - ^String streamContents: [ :stream | - self classVarNames - do: [ :each | stream nextPutAll: each ] - separatedBy: [ stream space ] ]! Item was removed: - ----- Method: ClassDescription>>classVersion (in category 'accessing') ----- - classVersion - "Default. Any class may return a later version to inform readers that use ReferenceStream. 8/17/96 tk" - "This method allows you to distinguish between class versions when the shape of the class - hasn't changed (when there's no change in the instVar names). - In the conversion methods you usually can tell by the inst var names - what old version you have. In a few cases, though, the same inst var - names were kept but their interpretation changed (like in the layoutFrame). - By changing the class version when you keep the same instVars you can - warn older and newer images that they have to convert." - ^ 0! Item was removed: - ----- Method: ClassDescription>>classesThatImplementAllOf: (in category 'accessing class hierarchy') ----- - classesThatImplementAllOf: selectorSet - "Return an array of any classes that implement all the messages in selectorSet." - - | found remaining | - found := OrderedCollection new. - selectorSet do: - [:sel | (self methodDict includesKey: sel) ifTrue: [found add: sel]]. - found isEmpty - ifTrue: [^ self subclasses inject: Array new - into: [:subsThatDo :sub | - subsThatDo , (sub classesThatImplementAllOf: selectorSet)]] - ifFalse: [remaining := selectorSet copyWithoutAll: found. - remaining isEmpty ifTrue: [^ Array with: self]. - ^ self subclasses inject: Array new - into: [:subsThatDo :sub | - subsThatDo , (sub classesThatImplementAllOf: remaining)]]! Item was removed: - ----- Method: ClassDescription>>comment (in category 'accessing comment') ----- - comment - "Answer the receiver's comment. (If missing, supply a template) " - | aString | - aString := self instanceSide organization classComment. - aString isEmpty ifFalse: [^ aString]. - ^self classCommentBlank! Item was removed: - ----- Method: ClassDescription>>comment: (in category 'accessing comment') ----- - comment: aStringOrText - "Set the receiver's comment to be the argument, aStringOrText." - - self instanceSide classComment: aStringOrText.! Item was removed: - ----- Method: ClassDescription>>comment:stamp: (in category 'accessing comment') ----- - comment: aStringOrText stamp: aStamp - "Set the receiver's comment to be the argument, aStringOrText." - - self instanceSide classComment: aStringOrText stamp: aStamp.! Item was removed: - ----- Method: ClassDescription>>commentFollows (in category 'fileIn/Out') ----- - commentFollows - "Answer a ClassCommentReader who will scan in the comment." - - ^ ClassCommentReader new setClass: self category: #Comment - - "False commentFollows inspect"! Item was removed: - ----- Method: ClassDescription>>commentInventory (in category 'accessing class hierarchy') ----- - commentInventory - "Answer a string with a count of the classes with and without comments - for all the classes in the package of which this class is a member." - - "Morph commentInventory" - - ^ SystemOrganization commentInventory: (self category copyUpTo: $-), '*'! Item was removed: - ----- Method: ClassDescription>>commentStamp: (in category 'fileIn/Out') ----- - commentStamp: changeStamp - self organization commentStamp: changeStamp. - ^ self commentStamp: changeStamp prior: 0! Item was removed: - ----- Method: ClassDescription>>commentStamp:prior: (in category 'fileIn/Out') ----- - commentStamp: changeStamp prior: indexAndOffset - "Prior source link ignored when filing in." - - ^ ClassCommentReader new setClass: self - category: #Comment - changeStamp: changeStamp! Item was removed: - ----- Method: ClassDescription>>compile:classified: (in category 'compiling') ----- - compile: code classified: heading - "Compile the argument, code, as source code in the context of the - receiver and install the result in the receiver's method dictionary under - the classification indicated by the second argument, heading. nil is to be - notified if an error occurs. The argument code is either a string or an - object that converts to a string or a PositionableStream on an object that - converts to a string." - - ^self - compile: code - classified: heading - notifying: nil! Item was removed: - ----- Method: ClassDescription>>compile:classified:notifying: (in category 'compiling') ----- - compile: text classified: category notifying: requestor - | stamp | - stamp := self acceptsLoggingOfCompilation ifTrue: [Utilities changeStamp] ifFalse: [nil]. - ^ self compile: text classified: category - withStamp: stamp notifying: requestor! Item was removed: - ----- Method: ClassDescription>>compile:classified:withStamp:notifying: (in category 'compiling') ----- - compile: text classified: category withStamp: changeStamp notifying: requestor - ^ self compile: text classified: category withStamp: changeStamp notifying: requestor logSource: self acceptsLoggingOfCompilation! Item was removed: - ----- Method: ClassDescription>>compile:classified:withStamp:notifying:logSource: (in category 'compiling') ----- - compile: text classified: category withStamp: changeStamp notifying: requestor logSource: logSource - - ^self - compile: text - environment: (CurrentEnvironment signal ifNil: [ self environment ]) - classified: category - withStamp: changeStamp - notifying: requestor - logSource: logSource! Item was removed: - ----- Method: ClassDescription>>compile:environment:classified:withStamp:notifying: (in category 'compiling') ----- - compile: text environment: anEnvironment classified: category withStamp: changeStamp notifying: requestor - ^ self - compile: text - environment: anEnvironment - classified: category - withStamp: changeStamp - notifying: requestor - logSource: self acceptsLoggingOfCompilation! Item was removed: - ----- Method: ClassDescription>>compile:environment:classified:withStamp:notifying:logSource: (in category 'compiling') ----- - compile: text environment: anEnvironment classified: category withStamp: changeStamp notifying: requestor logSource: logSource - - ^self - compileCue: (CompilationCue - source: text - class: self - environment: anEnvironment - requestor: requestor) - classified: category - withStamp: changeStamp - logSource: logSource! Item was removed: - ----- Method: ClassDescription>>compile:notifying: (in category 'compiling') ----- - compile: code notifying: requestor - "Refer to the comment in Behavior|compile:notifying:." - - ^self compile: code - classified: ClassOrganizer default - notifying: requestor! Item was removed: - ----- Method: ClassDescription>>compileCue:classified:withStamp:logSource: (in category 'compiling') ----- - compileCue: compilationCue classified: category withStamp: changeStamp logSource: logSource - - | methodAndNode methodNode selector | - methodNode := self newCompiler compile: compilationCue ifFail: [^nil]. - methodAndNode := CompiledMethodWithNode - generateMethodFromNode: methodNode - trailer: (compilationCue methodTrailer ifNil: - [self defaultMethodTrailerIfLogSource: logSource]). - selector := methodAndNode selector. - logSource ifTrue: - [self - logMethodSource: compilationCue source - forMethodWithNode: methodAndNode - inCategory: category - withStamp: changeStamp - notifying: compilationCue requestor. - RecentMessages default - recordSelector: selector - forClass: methodAndNode method methodClass - inEnvironment: compilationCue environment]. - self - addAndClassifySelector: selector - withMethod: methodAndNode method - inProtocol: category - notifying: compilationCue requestor. - self instanceSide - noteCompilationOf: selector - meta: self isClassSide. - ^selector! Item was removed: - ----- Method: ClassDescription>>compileSilently: (in category 'compiling') ----- - compileSilently: code - "Compile the code, leaving no trail in the system log, nor in any change set, nor in the 'recent submissions' list. This should only be used when you know for sure that the compilation will succeed." - - ^ self compileSilently: code classified: ClassOrganizer default.! Item was removed: - ----- Method: ClassDescription>>compileSilently:classified: (in category 'compiling') ----- - compileSilently: code classified: category - "Compile the code and classify the resulting method in the given category, leaving no trail in the system log, nor in any change set, nor in the 'recent submissions' list. This should only be used when you know for sure that the compilation will succeed." - - ^ self compileSilently: code classified: category notifying: nil.! Item was removed: - ----- Method: ClassDescription>>compileSilently:classified:notifying: (in category 'compiling') ----- - compileSilently: code classified: category notifying: requestor - "Compile the code and classify the resulting method in the given category, leaving no trail in the system log, nor in any change set, nor in the 'recent submissions' list. This should only be used when you know for sure that the compilation will succeed." - - ^self - compileSilently: code - environment: (CurrentEnvironment signal ifNil: [ self environment ]) - classified: category - notifying: requestor! Item was removed: - ----- Method: ClassDescription>>compileSilently:environment:classified:notifying: (in category 'compiling') ----- - compileSilently: code environment: anEnvironment classified: category notifying: requestor - "Compile the code and classify the resulting method in the given category, leaving no trail in the system log, nor in any change set, nor in the 'recent submissions' list. This should only be used when you know for sure that the compilation will succeed." - - ^SystemChangeNotifier uniqueInstance doSilently: [ - self - compile: code - environment: anEnvironment - classified: category - withStamp: nil - notifying: requestor - logSource: false ]! Item was removed: - ----- Method: ClassDescription>>copy:from: (in category 'copying') ----- - copy: sel from: class - "Install the method associated with the first argument, sel, a message - selector, found in the method dictionary of the second argument, class, - as one of the receiver's methods. Classify the message under -As yet not - classified-." - - self copy: sel - from: class - classified: nil! Item was removed: - ----- Method: ClassDescription>>copy:from:classified: (in category 'copying') ----- - copy: sel from: class classified: cat - "Install the method associated with the first arugment, sel, a message - selector, found in the method dictionary of the second argument, class, - as one of the receiver's methods. Classify the message under the third - argument, cat." - - "Useful when modifying an existing class" - (class sourceCodeAt: sel ifAbsent: []) ifNotNil: - [:code| | method category | - method := class compiledMethodAt: sel. - category := cat == nil - ifTrue: [class organization categoryOfElement: sel] - ifFalse: [cat]. - ((self methodDict includesKey: sel) - and: [code asString ~= (self sourceCodeAt: sel) asString]) ifTrue: - [self error: self name , ' ' , sel , ' will be redefined if you proceed.']. - self compile: code classified: category withStamp: method timeStamp notifying: nil]! Item was removed: - ----- Method: ClassDescription>>copyAll:from: (in category 'copying') ----- - copyAll: selArray from: class - "Install all the methods found in the method dictionary of the second - argument, class, as the receiver's methods. Classify the messages under - -As yet not classified-." - - self copyAll: selArray - from: class - classified: nil! Item was removed: - ----- Method: ClassDescription>>copyAll:from:classified: (in category 'copying') ----- - copyAll: selArray from: class classified: cat - "Install all the methods found in the method dictionary of the second - argument, class, as the receiver's methods. Classify the messages under - the third argument, cat." - - selArray do: - [:s | self copy: s - from: class - classified: cat]! Item was removed: - ----- Method: ClassDescription>>copyAllCategoriesFrom: (in category 'copying') ----- - copyAllCategoriesFrom: aClass - "Specify that the categories of messages for the receiver include all of - those found in the class, aClass. Install each of the messages found in - these categories into the method dictionary of the receiver, classified - under the appropriate categories." - - aClass organization categories do: [:cat | self copyCategory: cat from: aClass]! Item was removed: - ----- Method: ClassDescription>>copyAllCategoriesUnobtrusivelyFrom: (in category 'copying') ----- - copyAllCategoriesUnobtrusivelyFrom: aClass - "Specify that the categories of messages for the receiver include all of - those found in the class, aClass. Install each of the messages found in - these categories into the method dictionary of the receiver, classified - under the appropriate categories." - - aClass organization categories do: [:cat | self copyCategoryUnobtrusively: cat from: aClass]! Item was removed: - ----- Method: ClassDescription>>copyAllUnobtrusively:from:classified: (in category 'copying') ----- - copyAllUnobtrusively: selArray from: class classified: cat - "Install all the methods found in the method dictionary of the second - argument, class, as the receiver's methods. Classify the messages under - the third argument, cat." - - selArray do: - [:s | self copyUnobtrusively: s - from: class - classified: cat]! Item was removed: - ----- Method: ClassDescription>>copyCategory:from: (in category 'copying') ----- - copyCategory: cat from: class - "Specify that one of the categories of messages for the receiver is cat, as - found in the class, class. Copy each message found in this category." - - self copyCategory: cat - from: class - classified: cat! Item was removed: - ----- Method: ClassDescription>>copyCategory:from:classified: (in category 'copying') ----- - copyCategory: cat from: aClass classified: newCat - "Specify that one of the categories of messages for the receiver is the - third argument, newCat. Copy each message found in the category cat in - class aClass into this new category." - - self copyAll: (aClass organization listAtCategoryNamed: cat) - from: aClass - classified: newCat! Item was removed: - ----- Method: ClassDescription>>copyCategoryUnobtrusively:from: (in category 'copying') ----- - copyCategoryUnobtrusively: cat from: class - "Specify that one of the categories of messages for the receiver is cat, as - found in the class, class. Copy each message found in this category." - - self copyUnobtrusivelyCategory: cat - from: class - classified: cat! Item was removed: - ----- Method: ClassDescription>>copyMethodDictionaryFrom: (in category 'copying') ----- - copyMethodDictionaryFrom: donorClass - "Copy the method dictionary of the donor class over to the receiver" - - self methodDict: donorClass copyOfMethodDictionary. - self organization: donorClass organization deepCopy.! Item was removed: - ----- Method: ClassDescription>>copyUnobtrusively:from:classified: (in category 'copying') ----- - copyUnobtrusively: sel from: class classified: cat - "Install the method associated with the first arugment, sel, a message - selector, found in the method dictionary of the second argument, class, - as one of the receiver's methods. Classify the message under the third - argument, cat." - - | code category | - "Useful when modifying an existing class" - code := class sourceMethodAt: sel. - code == nil - ifFalse: - [cat == nil - ifTrue: [category := class organization categoryOfElement: sel] - ifFalse: [category := cat]. - (self methodDict includesKey: sel) - ifTrue: []. - self compileSilently: code classified: category]! Item was removed: - ----- Method: ClassDescription>>copyUnobtrusivelyCategory:from:classified: (in category 'copying') ----- - copyUnobtrusivelyCategory: cat from: aClass classified: newCat - "Specify that one of the categories of messages for the receiver is the - third argument, newCat. Copy each message found in the category cat in - class aClass into this new category." - - self copyAllUnobtrusively: (aClass organization listAtCategoryNamed: cat) - from: aClass - classified: newCat! Item was removed: - ----- Method: ClassDescription>>definition (in category 'fileIn/Out') ----- - definition - "Answer a String that defines the receiver." - - | aStream path | - aStream := WriteStream on: (String new: 300). - superclass == nil - ifTrue: [aStream nextPutAll: 'ProtoObject'] - ifFalse: [path := ''. - self environment scopeFor: superclass name from: nil - envtAndPathIfFound: [:envt :remotePath | path := remotePath]. - aStream nextPutAll: path , superclass name]. - aStream nextPutAll: self kindOfSubclass; - store: self name. - (self hasTraitComposition and: [self traitComposition notEmpty]) ifTrue: [ - aStream cr; tab; nextPutAll: 'uses: '; - nextPutAll: self traitCompositionString]. - aStream cr; tab; nextPutAll: 'instanceVariableNames: '; - store: self instanceVariablesString. - aStream cr; tab; nextPutAll: 'classVariableNames: '; - store: self classVariablesString. - aStream cr; tab; nextPutAll: 'poolDictionaries: '; - store: self sharedPoolsString. - aStream cr; tab; nextPutAll: 'category: '; - store: (self environment organization categoryOfElement: self name) asString. - - superclass ifNil: [ - aStream nextPutAll: '.'; cr. - aStream nextPutAll: self name. - aStream space; nextPutAll: 'superclass: nil'. ]. - - ^ aStream contents! Item was removed: - ----- Method: ClassDescription>>doneCompiling (in category 'compiling') ----- - doneCompiling - "A ClassBuilder has finished the compilation of the receiver. - This message is a notification for a class that needs to do some - cleanup / reinitialization after it has been recompiled."! Item was removed: - ----- Method: ClassDescription>>errorCategoryName (in category 'private') ----- - errorCategoryName - self error: 'Category name must be a String'! Item was removed: - ----- Method: ClassDescription>>fileOutCategory: (in category 'fileIn/Out') ----- - fileOutCategory: catName - ^ self fileOutCategory: catName asHtml: false! Item was removed: - ----- Method: ClassDescription>>fileOutCategory:asHtml: (in category 'fileIn/Out') ----- - fileOutCategory: catName asHtml: useHtml - "FileOut the named category, possibly in Html format." - | internalStream | - internalStream := WriteStream on: (String new: 1000). - internalStream header; timeStamp. - self fileOutCategory: catName on: internalStream moveSource: false toFile: 0. - internalStream trailer. - - FileStream writeSourceCodeFrom: internalStream baseName: (self name , '-' , catName) isSt: true useHtml: useHtml.! Item was removed: - ----- Method: ClassDescription>>fileOutCategory:on:moveSource:toFile: (in category 'fileIn/Out') ----- - fileOutCategory: aSymbol on: aFileStream moveSource: moveSource toFile: fileIndex - "File a description of the receiver's category, aString, onto aFileStream. If - moveSource, is true, then set the method source pointer to the new file position. - Note when this method is called with moveSource=true, it is condensing the - .sources file, and should only write one preamble per method category." - - | selectors | - - aFileStream cr. - selectors := (aSymbol asString = ClassOrganizer allCategory) - ifTrue: [ self organization allMethodSelectors ] - ifFalse: [ self organization listAtCategoryNamed: aSymbol ]. - - selectors := selectors select: [:each | (self includesLocalSelector: each)]. - - "Overridden to preserve author stamps in sources file regardless" - selectors do: [:sel | - self printMethodChunk: sel - withPreamble: true - on: aFileStream - moveSource: moveSource - toFile: fileIndex]. - ^ self! Item was removed: - ----- Method: ClassDescription>>fileOutCategoryHistorically:on:moveSource:toFile: (in category 'fileIn/Out') ----- - fileOutCategoryHistorically: aSymbol on: aFileStream moveSource: moveSource toFile: fileIndex - "File a description of the receiver's category, aString, onto aFileStream, preserving direct - history, but excluding branches . If moveSource, is true, then set the method source pointer - to the new file position. Note when this method is called with moveSource=true, it is - condensing the sources file, and should only write one preamble per method category." - - | selectors | - aFileStream cr. - selectors := aSymbol asString = ClassOrganizer allCategory - ifTrue: [self organization allMethodSelectors] - ifFalse: [self organization listAtCategoryNamed: aSymbol]. - - selectors := selectors select: [:each | self includesLocalSelector: each]. - - "Overridden to preserve author stamps in sources file regardless." - selectors do: [:sel | - self printMethodChunkHistorically: sel - on: aFileStream - moveSource: moveSource - toFile: fileIndex]! Item was removed: - ----- Method: ClassDescription>>fileOutChangedMessages:on: (in category 'fileIn/Out') ----- - fileOutChangedMessages: aSet on: aFileStream - "File a description of the messages of the receiver that have been - changed (i.e., are entered into the argument, aSet) onto aFileStream." - - self fileOutChangedMessages: aSet - on: aFileStream - moveSource: false - toFile: 0! Item was removed: - ----- Method: ClassDescription>>fileOutChangedMessages:on:moveSource:toFile: (in category 'fileIn/Out') ----- - fileOutChangedMessages: aSet on: aFileStream moveSource: moveSource toFile: fileIndex - "File a description of the messages of this class that have been - changed (i.e., are entered into the argument, aSet) onto aFileStream. If - moveSource, is true, then set the method source pointer to the new file position. - Note when this method is called with moveSource=true, it is condensing the - .changes file, and should only write a preamble for every method." - | org | - (org := self organization) categories do: - [:cat | | sels | - sels := (org listAtCategoryNamed: cat) select: [:sel | aSet includes: sel]. - (moveSource == #historically - or: [moveSource and: [(cat beginsWith: '*') and: [cat endsWith: '-override']]]) - ifTrue: "when condensing sources/changes, preserve overridden methods" - [sels do: - [:sel | - self printMethodChunkHistorically: sel on: aFileStream - moveSource: moveSource ~~ false toFile: fileIndex]] - ifFalse: - [sels do: - [:sel | self printMethodChunk: sel withPreamble: true on: aFileStream - moveSource: moveSource toFile: fileIndex]]]! Item was removed: - ----- Method: ClassDescription>>fileOutChangedMessagesHistorically:on:moveSource:toFile: (in category 'fileIn/Out') ----- - fileOutChangedMessagesHistorically: aSet on: aFileStream moveSource: moveSource toFile: fileIndex - "File all historical description of the messages of this class that have been - changed (i.e., are entered into the argument, aSet) onto aFileStream. If - moveSource, is true, then set the method source pointer to the new file position. - Note when this method is called with moveSource=true, it is condensing the - .changes file, and should only write a preamble for every method." - | org | - (org := self organization) categories do: - [:cat | - | sels | - sels := (org listAtCategoryNamed: cat) select: [:sel | aSet includes: sel]. - sels do: - [:sel | self printMethodChunkHistorically: sel on: aFileStream - moveSource: moveSource toFile: fileIndex]]! Item was removed: - ----- Method: ClassDescription>>fileOutInitializerOn: (in category 'fileIn/Out') ----- - fileOutInitializerOn: aStream - "If the receiver has initialization, file it out. Backstop for subclasses."! Item was removed: - ----- Method: ClassDescription>>fileOutMethod: (in category 'fileIn/Out') ----- - fileOutMethod: selector - "Write source code of a single method on a file. Make up a name for the file." - self fileOutMethod: selector asHtml: false! Item was removed: - ----- Method: ClassDescription>>fileOutMethod:asHtml: (in category 'fileIn/Out') ----- - fileOutMethod: selector asHtml: useHtml - "Write source code of a single method on a file in .st or .html format" - - | internalStream | - (selector == #Comment) ifTrue: [^ self inform: 'Sorry, cannot file out class comment in isolation.']. - (self includesSelector: selector) ifFalse: [^ self error: 'Selector ', selector asString, ' not found']. - internalStream := WriteStream on: (String new: 1000). - internalStream header; timeStamp. - self printMethodChunk: selector withPreamble: true - on: internalStream moveSource: false toFile: 0. - - FileStream writeSourceCodeFrom: internalStream baseName: (self name , '-' , (selector copyReplaceAll: ':' with: '')) isSt: true useHtml: useHtml. - ! Item was removed: - ----- Method: ClassDescription>>fileOutOn: (in category 'fileIn/Out') ----- - fileOutOn: aFileStream - "File a description of the receiver on aFileStream." - - self fileOutOn: aFileStream - moveSource: false - toFile: 0! Item was removed: - ----- Method: ClassDescription>>fileOutOn:moveSource:toFile: (in category 'fileIn/Out') ----- - fileOutOn: aFileStream moveSource: moveSource toFile: fileIndex - "File a description of the receiver on aFileStream. moveSOurce is one of - true, false or #historically. If the argument, moveSource, is not false, then - set the trailing bytes to the position of aFileStream and to fileIndex in order - to indicate where to find the source code. If moveSource == #historically, - print out each method's history, excluding branches" - - aFileStream command: 'H3'; nextChunkPut: self definition; command: '/H3'. - - self organization - putCommentOnFile: aFileStream - numbered: fileIndex - moveSource: moveSource ~~ false - forClass: self. - self organization categories do: - [:heading | - moveSource == #historically - ifTrue: - [self fileOutCategoryHistorically: heading - on: aFileStream - moveSource: true - toFile: fileIndex] - ifFalse: - [self fileOutCategory: heading - on: aFileStream - moveSource: moveSource - toFile: fileIndex]]! Item was removed: - ----- Method: ClassDescription>>fileOutOn:moveSource:toFile:initializing: (in category 'fileIn/Out') ----- - fileOutOn: aFileStream moveSource: moveSource toFile: fileIndex initializing: aBool - "File out the receiver. Backstop for subclasses." - ^self fileOutOn: aFileStream moveSource: moveSource toFile: fileIndex! Item was removed: - ----- Method: ClassDescription>>fileOutOrganizationOn: (in category 'fileIn/Out') ----- - fileOutOrganizationOn: aFileStream - "File a description of the receiver's organization on aFileStream." - - aFileStream cr; nextPut: $!!. - aFileStream nextChunkPut: self name, ' reorganize'; cr. - aFileStream nextChunkPut: self organization printString; cr! Item was removed: - ----- Method: ClassDescription>>forceNewFrom: (in category 'instance variables') ----- - forceNewFrom: anArray - "Create a new instance of the class and fill - its instance variables up with the array." - | object max | - - object := self new. - max := self instSize. - anArray withIndexDo: [:each :index | - index > max ifFalse: - [object instVarAt: index put: each]]. - ^ object! Item was removed: - ----- Method: ClassDescription>>hasComment (in category 'accessing comment') ----- - hasComment - "return whether this class truly has a comment other than the default" - | org | - org := self instanceSide organization. - ^org classComment isEmptyOrNil not! Item was removed: - ----- Method: ClassDescription>>induceMDFault (in category 'accessing method dictionary') ----- - induceMDFault - "Stache a copy of the methodDict in the organization slot (hack!!), - and set the methodDict to nil. This will induce an MD fault on any message send. - See: ClassDescription>>recoverFromMDFault - and ImageSegment>>discoverActiveClasses." - - organization := Array with: methodDict with: organization. - methodDict := nil. - self flushCache! Item was removed: - ----- Method: ClassDescription>>instVarIndexFor:ifAbsent: (in category 'instance variables') ----- - instVarIndexFor: instVarName ifAbsent: aBlock - "Answer the index of the named instance variable." - - | index | - index := instanceVariables - ifNil: [ 0 ] - ifNotNil: [ instanceVariables indexOf: instVarName ]. - index = 0 ifTrue: [ - ^superclass - ifNil: [ aBlock value ] - ifNotNil: [ superclass instVarIndexFor: instVarName ifAbsent: aBlock ] ]. - ^superclass - ifNil: [ index ] - ifNotNil: [ index + superclass instSize ]! Item was removed: - ----- Method: ClassDescription>>instVarMappingFrom: (in category 'private') ----- - instVarMappingFrom: oldClass - "Return the mapping from instVars of oldClass to new class that is used for converting old instances of oldClass." - | oldInstVarNames | - oldInstVarNames := oldClass allInstVarNames. - "Using #lastIndexOf: to ensure proper behavior in case where we have duplicate ivars." - ^self allInstVarNames collect: [:instVarName | oldInstVarNames lastIndexOf: instVarName].! Item was removed: - ----- Method: ClassDescription>>instVarNameForIndex: (in category 'instance variables') ----- - instVarNameForIndex: index - "Answer the named instance variable with index index or nil if none." - - | superInstSize | - index > self instSize ifTrue: [^nil]. - superInstSize := superclass isNil ifTrue: [0] ifFalse: [superclass instSize]. - index > superInstSize ifTrue: - [^instanceVariables at: index - superInstSize]. - superclass isNil ifTrue: [^nil]. - ^superclass instVarNameForIndex: index! Item was removed: - ----- Method: ClassDescription>>instVarNames (in category 'instance variables') ----- - instVarNames - "Answer an Array of the receiver's instance variable names." - - instanceVariables == nil - ifTrue: [^#()] - ifFalse: [^instanceVariables]! Item was removed: - ----- Method: ClassDescription>>instVarNamesAndOffsetsDo: (in category 'compiling') ----- - instVarNamesAndOffsetsDo: aBinaryBlock - "This is part of the interface between the compiler and a class's instance or field names. - The class should enumerate aBinaryBlock with the instance variable name strings and - their integer offsets. The order is important. Names evaluated later will override the - same names occurring earlier." - - | superInstSize | - (superInstSize := superclass notNil ifTrue: [superclass instSize] ifFalse: [0]) > 0 ifTrue: - [superclass instVarNamesAndOffsetsDo: aBinaryBlock]. - 1 to: self instSize - superInstSize do: - [:i| aBinaryBlock value: (instanceVariables at: i) value: i + superInstSize]! Item was removed: - ----- Method: ClassDescription>>instanceSide (in category 'accessing parallel hierarchy') ----- - instanceSide - ^ self theNonMetaClass! Item was removed: - ----- Method: ClassDescription>>instanceVariablesString (in category 'printing') ----- - instanceVariablesString - "Answer a string of my instance variable names separated by spaces." - - ^String streamContents: [ :stream | - self instVarNames - do: [ :each | stream nextPutAll: each ] - separatedBy: [ stream space ] ]! Item was removed: - ----- Method: ClassDescription>>isClassSide (in category 'accessing parallel hierarchy') ----- - isClassSide - ^self isMeta! Item was removed: - ----- Method: ClassDescription>>isDeprecated (in category 'testing') ----- - isDeprecated - "Check for \d\d(Deprecated).* name." - - ^ (self category findString: 'Deprecated' startingAt: 3 caseSensitive: true) > 0! Item was removed: - ----- Method: ClassDescription>>isInstanceSide (in category 'accessing parallel hierarchy') ----- - isInstanceSide - ^self isClassSide not! Item was removed: - ----- Method: ClassDescription>>isSelectorOverridden: (in category 'testing') ----- - isSelectorOverridden: aSelector - - (self includesSelector: aSelector) - ifFalse: [^ false]. - - self allSubclassesDo: [ :class | - (class includesSelector: aSelector) - ifTrue: [ ^ true ] ]. - ^ false! Item was removed: - ----- Method: ClassDescription>>isSelectorOverride: (in category 'testing') ----- - isSelectorOverride: aSelector - - (self includesSelector: aSelector) - ifFalse: [^ false]. - - self allSuperclassesDo: [ :class | - (class includesSelector: aSelector) - ifTrue: [ ^ true ] ]. - ^ false! Item was removed: - ----- Method: ClassDescription>>isUniClass (in category 'accessing method dictionary') ----- - isUniClass - "Answer whether the receiver is a uniclass." - - ^ self name endsWithDigit! Item was removed: - ----- Method: ClassDescription>>linesOfCode (in category 'private') ----- - linesOfCode - "An approximate measure of lines of code. - Includes comments, but excludes blank lines." - | lines | - lines := self methodDict inject: 0 into: [:sum :each | sum + each linesOfCode]. - self isMeta - ifTrue: [^ lines] - ifFalse: [^ lines + self class linesOfCode]! Item was removed: - ----- Method: ClassDescription>>logMethodSource:forMethodWithNode:inCategory:withStamp:notifying: (in category 'private') ----- - logMethodSource: aText forMethodWithNode: aCompiledMethodWithNode inCategory: category withStamp: changeStamp notifying: requestor - | priorMethodOrNil newText | - priorMethodOrNil := self compiledMethodAt: aCompiledMethodWithNode selector ifAbsent: []. - (priorMethodOrNil notNil and: [priorMethodOrNil hasBreakpoint]) ifTrue: - [priorMethodOrNil := priorMethodOrNil getAndForgetUnbreakpointedOriginal]. - newText := (requestor notNil and: [Preferences confirmFirstUseOfStyle]) - ifTrue: [aText askIfAddStyle: priorMethodOrNil req: requestor] - ifFalse: [aText]. - aCompiledMethodWithNode method - putSource: newText - fromParseNode: aCompiledMethodWithNode node - class: self - category: category - withStamp: changeStamp - inFile: 2 - priorMethod: priorMethodOrNil! Item was removed: - ----- Method: ClassDescription>>methods (in category 'fileIn/Out') ----- - methods - "Answer a ClassCategoryReader for compiling messages that are not classified, as in fileouts made with Smalltalk/V" - - ^ ClassCategoryReader new setClass: self category: ClassOrganizer default! Item was removed: - ----- Method: ClassDescription>>methodsFor: (in category 'fileIn/Out') ----- - methodsFor: categoryName - "Answer a ClassCategoryReader for compiling the messages in the category, categoryName, of the receiver." - - ^ ClassCategoryReader new setClass: self category: categoryName asSymbol - - "(False methodsFor: 'logical operations') inspect"! Item was removed: - ----- Method: ClassDescription>>methodsFor:priorSource:inFile: (in category 'fileIn/Out') ----- - methodsFor: aString priorSource: sourcePosition inFile: fileIndex - "Prior source pointer ignored when filing in." - ^ self methodsFor: aString! Item was removed: - ----- Method: ClassDescription>>methodsFor:stamp: (in category 'fileIn/Out') ----- - methodsFor: categoryName stamp: changeStamp - ^ self methodsFor: categoryName stamp: (Utilities fixStamp: changeStamp) prior: 0! Item was removed: - ----- Method: ClassDescription>>methodsFor:stamp:prior: (in category 'fileIn/Out') ----- - methodsFor: categoryName stamp: changeStamp prior: indexAndOffset - "Prior source link ignored when filing in." - ^ ClassCategoryReader new setClass: self - category: categoryName asSymbol - changeStamp: changeStamp - - "Most importantly, return the new ClassCategoryReader, so a fileIn will let it seize control. So method will be placed in the proper category. See the transfer of control where ReadWriteStream fileIn calls scanFrom:"! Item was removed: - ----- Method: ClassDescription>>methodsInCategory: (in category 'accessing method dictionary') ----- - methodsInCategory: aName - "Answer a list of the methods of the receiver that are in category named aName" - - | aColl | - aColl := Set withAll: (aName = ClassOrganizer allCategory - ifTrue: [self organization allMethodSelectors] - ifFalse: [self organization listAtCategoryNamed: aName]). - ^ aColl asArray sort! Item was removed: - ----- Method: ClassDescription>>moveChangesTo: (in category 'fileIn/Out') ----- - moveChangesTo: newFile - "Used in the process of condensing changes, this message requests that - the source code of all methods of the receiver that have been changed - should be moved to newFile." - - | changes | - changes := self methodDict keys select: - [:sel | (self compiledMethodAt: sel) fileIndex > 1]. - changes isEmpty ifTrue: - [^self]. - newFile cr; cr; command: 'H3'; nextChunkPut: self definition; command: '/H3'; cr. - self - fileOutChangedMessages: changes - on: newFile - moveSource: #historically - toFile: 2! Item was removed: - ----- Method: ClassDescription>>moveChangesWithVersionsTo: (in category 'filein/out') ----- - moveChangesWithVersionsTo: newFile - "Used in the process of condensing changes, this message requests that - the source code of all methods of the receiver that have been changed - should be moved to newFile." - - | changes | - changes := self selectors select: [:sel | (self methodDict at: sel) fileIndex > 1]. - self fileOutChangedMessagesHistorically: changes - on: newFile - moveSource: true - toFile: 2! Item was removed: - ----- Method: ClassDescription>>moveClassCommentTo:fileIndex: (in category 'fileIn/Out') ----- - moveClassCommentTo: aFileStream fileIndex: newFileIndex - "Called when condensing changes. If the receiver has a class comment, and if that class comment does not reside in the .sources file, then write it to the given filestream, with the resulting RemoteString being reachable from the source file fileIndex. Note that any existing backpointer into the .sources file is lost by this process -- a situation that maybe should be fixed someday." - - | header aStamp aCommentRemoteStr | - self isMeta ifTrue: [^ self]. "bulletproofing only" - ((aCommentRemoteStr := self organization commentRemoteStr) isNil or: - [aCommentRemoteStr sourceFileNumber = 1]) ifTrue: [^ self]. - - aFileStream cr; nextPut: $!!. - header := String streamContents: [:strm | strm nextPutAll: self name; - nextPutAll: ' commentStamp: '. - (aStamp := self organization commentStamp ifNil: ['<historical>']) storeOn: strm. - strm nextPutAll: ' prior: 0']. - aFileStream nextChunkPut: header. - aFileStream cr. - self organization classComment: (RemoteString newString: self organization classComment onFileNumber: newFileIndex toFile: aFileStream) stamp: aStamp! Item was removed: - ----- Method: ClassDescription>>moveInstVarNamed:to:after: (in category 'compiling') ----- - moveInstVarNamed: instVarName to: anotherClass after: prevInstVarName - "Move the given instance variable to another class." - self == anotherClass ifFalse:[ - self notify:'Warning:' asText allBold,' moving ', instVarName printString,' from ', self name,' to ', anotherClass name,' will not be recorded in the change set correctly. - Proceed to do it anyways.']. - ^(ClassBuilder new) - moveInstVarNamed: instVarName - from: self - to: anotherClass - after: prevInstVarName! Item was removed: - ----- Method: ClassDescription>>newInstanceFrom:variable:size:map: (in category 'private') ----- - newInstanceFrom: oldInstance variable: variable size: instSize map: map - "Create a new instance of the receiver based on the given old instance. - The supplied map contains a mapping of the old instVar names into - the receiver's instVars" - | new | - variable - ifTrue: [new := self basicNew: oldInstance basicSize] - ifFalse: [new := self basicNew]. - 1 to: instSize do: - [:offset | (map at: offset) > 0 ifTrue: - [new instVarAt: offset - put: (oldInstance instVarAt: (map at: offset))]]. - variable - ifTrue: [1 to: oldInstance basicSize do: - [:offset | - new basicAt: offset put: (oldInstance basicAt: offset)]]. - ^new! Item was removed: - ----- Method: ClassDescription>>noteAddedSelector:meta: (in category 'accessing method dictionary') ----- - noteAddedSelector: aSelector meta: isMeta - "A hook allowing some classes to react to adding of certain selectors"! Item was removed: - ----- Method: ClassDescription>>noteCompilationOf:meta: (in category 'compiling') ----- - noteCompilationOf: aSelector meta: isMeta - "A hook allowing some classes to react to recompilation of certain selectors"! Item was removed: - ----- Method: ClassDescription>>notifyOfRecategorizedSelector:from:to: (in category 'organization') ----- - notifyOfRecategorizedSelector: element from: oldCategory to: newCategory - SystemChangeNotifier uniqueInstance selector: element recategorizedFrom: oldCategory to: newCategory inClass: self! Item was removed: - ----- Method: ClassDescription>>obsolete (in category 'initialize-release') ----- - obsolete - "Make the receiver obsolete." - self hasTraitComposition ifTrue: [ - self traitComposition do: [:each | - each removeTraitUser: self]]. - superclass removeSubclass: self. - self organization: nil. - super obsolete.! Item was removed: - ----- Method: ClassDescription>>organization (in category 'organization') ----- - organization - "Answer the instance of ClassOrganizer that represents the organization - of the messages of the receiver." - - organization ifNil: [ - self organization: (ClassOrganizer defaultList: self methodDict keys sort) ]. - (organization isMemberOf: Array) ifTrue: [ - self recoverFromMDFaultWithTrace ]. - - "Making sure that subject is set correctly. It should not be necessary." - organization ifNotNil: [ organization setSubject: self ]. - ^organization! Item was removed: - ----- Method: ClassDescription>>organization: (in category 'organization') ----- - organization: aClassOrg - "Install an instance of ClassOrganizer that represents the organization of the messages of the receiver." - - aClassOrg ifNotNil: [aClassOrg setSubject: self]. - organization := aClassOrg! Item was removed: - ----- Method: ClassDescription>>printCategoryChunk:on: (in category 'fileIn/Out') ----- - printCategoryChunk: categoryName on: aFileStream - ^ self printCategoryChunk: categoryName withStamp: '' on: aFileStream! Item was removed: - ----- Method: ClassDescription>>printCategoryChunk:on:priorMethod: (in category 'fileIn/Out') ----- - printCategoryChunk: category on: aFileStream priorMethod: priorMethod - ^ self printCategoryChunk: category on: aFileStream - withStamp: Utilities changeStamp priorMethod: priorMethod! Item was removed: - ----- Method: ClassDescription>>printCategoryChunk:on:withStamp:priorMethod: (in category 'fileIn/Out') ----- - printCategoryChunk: category on: aFileStream withStamp: changeStamp priorMethod: priorMethod - "Print a method category preamble. This must have a category name. - It may have an author/date stamp, and it may have a prior source link. - If it has a prior source link, it MUST have a stamp, even if it is empty." - - "The current design is that changeStamps and prior source links are preserved in the changes file. All fileOuts include changeStamps. Condensing sources, however, eliminates all stamps (and links, natch)." - - aFileStream cr; command: 'H3'; nextPut: $!!. - aFileStream nextChunkPut: (String streamContents: - [:strm | - strm nextPutAll: self name; nextPutAll: ' methodsFor: '; print: category asString. - (changeStamp ~~ nil and: - [changeStamp size > 0 or: [priorMethod ~~ nil]]) ifTrue: - [strm nextPutAll: ' stamp: '; print: changeStamp]. - priorMethod ~~ nil ifTrue: - [strm nextPutAll: ' prior: '; print: priorMethod sourcePointer]]). - aFileStream command: '/H3'.! Item was removed: - ----- Method: ClassDescription>>printCategoryChunk:withStamp:on: (in category 'fileIn/Out') ----- - printCategoryChunk: categoryName withStamp: changeStamp on: aFileStream - ^ self printCategoryChunk: categoryName on: aFileStream withStamp: changeStamp - priorMethod: nil! Item was removed: - ----- Method: ClassDescription>>printMethodChunk:withPreamble:on:moveSource:toFile: (in category 'fileIn/Out') ----- - printMethodChunk: selector withPreamble: doPreamble on: outStream - moveSource: moveSource toFile: fileIndex - "Copy the source code for the method associated with selector onto the fileStream. If moveSource true, then also set the source code pointer of the method." - | preamble method oldPos newPos sourceFile endPos | - doPreamble - ifTrue: [preamble := self name , ' methodsFor: ' , - (self organization categoryOfElement: selector) asString printString] - ifFalse: [preamble := '']. - method := self methodDict at: selector ifAbsent: - [outStream nextPutAll: selector; cr. - outStream tab; nextChunkPut: '** ERROR!! THIS SCRIPT IS MISSING ** ' translated; cr; cr. - outStream nextPutAll: ' '. - ^ outStream]. - - ((method fileIndex = 0 - or: [(SourceFiles at: method fileIndex) == nil]) - or: [(oldPos := method filePosition) = 0]) - ifTrue: - ["The source code is not accessible. We must decompile..." - preamble size > 0 ifTrue: [outStream cr; nextPut: $!!; nextChunkPut: preamble; cr]. - outStream nextChunkPut: method decompileString] - ifFalse: - [sourceFile := SourceFiles at: method fileIndex. - preamble size > 0 - ifTrue: "Copy the preamble" - [outStream copyPreamble: preamble from: sourceFile at: oldPos] - ifFalse: - [sourceFile position: oldPos]. - "Copy the method chunk" - newPos := outStream position. - outStream copyMethodChunkFrom: sourceFile. - sourceFile skipSeparators. "The following chunk may have ]style[" - sourceFile peek == $] ifTrue: [ - outStream cr; copyMethodChunkFrom: sourceFile]. - moveSource ifTrue: "Set the new method source pointer" - [endPos := outStream position. - method checkOKToAdd: endPos - newPos at: newPos. - method setSourcePosition: newPos inFile: fileIndex]]. - preamble size > 0 ifTrue: [outStream nextChunkPut: ' ']. - ^ outStream cr! Item was removed: - ----- Method: ClassDescription>>printMethodChunkHistorically:on:moveSource:toFile: (in category 'fileIn/Out') ----- - printMethodChunkHistorically: selector on: outStream moveSource: moveSource toFile: fileIndex - "Copy all source codes historically for the method associated with selector onto the - fileStream. If moveSource is true, then also set the source code pointer of the method. - N.B. fileIndex is interpreted as follows, 0 => just a fileOut; 1 => condensing sources; - 2 => condensing changes; therefore only changes on the chnages file before the last - version in the sources file are recorded." - - | preamble method newPos category changeList priorPos index | - category := self organization categoryOfElement: selector. - preamble := self name , ' methodsFor: ', category asString printString. - method := self methodDict at: selector. - (method filePosition = 0 - or: [method fileIndex = 0 - or: [(SourceFiles at: method fileIndex) isNil]]) - ifTrue: "no source; must decompile" - [outStream cr; nextPut: $!!; nextChunkPut: preamble; cr. - outStream nextChunkPut: method decompileString. - outStream nextChunkPut: ' '; cr] - ifFalse: - [changeList := ChangeSet directAncestryOfVersions: (ChangeSet - scanVersionsOf: method - class: self - meta: self isMeta - category: category - selector: selector). - newPos := priorPos := nil. - (fileIndex = 2 "condensing changes; select changes file code and find last sources file change" - and: [(index := changeList findFirst: [:chgRec| chgRec fileIndex = 1]) > 0]) ifTrue: - [priorPos := SourceFiles - sourcePointerFromFileIndex: 1 - andPosition: (changeList at: index) position. - changeList := changeList copyFrom: 1 to: index - 1]. - changeList reverseDo: - [:chgRec| - chgRec file closed ifTrue: - [chgRec file reopen; setToEnd]. - outStream copyPreamble: preamble from: chgRec file at: chgRec position. - priorPos ifNotNil: - [outStream - position: outStream position - 2; - nextPutAll: ' prior: '; print: priorPos; nextPut: $!!; cr]. - "Copy the method chunk" - newPos := outStream position. - outStream copyMethodChunkFrom: chgRec file at: chgRec position. - chgRec file skipSeparators. "The following chunk may have ]style[" - chgRec file peek == $] ifTrue: - [outStream cr; copyMethodChunkFrom: chgRec file]. - outStream nextChunkPut: ' '; cr. - chgRec position: newPos. - priorPos := SourceFiles - sourcePointerFromFileIndex: fileIndex - andPosition: newPos]. - moveSource ifTrue: - [method setSourcePosition: newPos inFile: fileIndex]]. - ^outStream! Item was removed: - ----- Method: ClassDescription>>printOn: (in category 'printing') ----- - printOn: aStream - aStream nextPutAll: self name! Item was removed: - ----- Method: ClassDescription>>printSubclassesOn:level: (in category 'accessing class hierarchy') ----- - printSubclassesOn: aStream level: level - "As part of the algorithm for printing a description of the receiver, print the - subclass on the file stream, aStream, indenting level times." - - | subclassNames | - aStream crtab: level. - aStream nextPutAll: self name. - aStream space; print: self instVarNames. - self == Class - ifTrue: - [aStream crtab: level + 1; nextPutAll: '[ ... all the Metaclasses ... ]'. - ^self]. - subclassNames := self subclasses sort:[:c1 :c2| c1 name <= c2 name]. - "Print subclasses in alphabetical order" - subclassNames do: - [:subclass | subclass printSubclassesOn: aStream level: level + 1]! Item was removed: - ----- Method: ClassDescription>>printWithClosureAnalysisOn: (in category 'printing') ----- - printWithClosureAnalysisOn: aStream - - aStream nextPutAll: self name! Item was removed: - ----- Method: ClassDescription>>putClassCommentToCondensedChangesFile: (in category 'fileIn/Out') ----- - putClassCommentToCondensedChangesFile: aFileStream - "Called when condensing changes. If the receiver has a class comment, and if that class comment does not reside in the .sources file, then write it to the given filestream, with the resulting RemoteString being reachable from the source file #2. Note that any existing backpointer into the .sources file is lost by this process -- a situation that maybe should be fixed someday." - ^self moveClassCommentTo: aFileStream fileIndex: 2! Item was removed: - ----- Method: ClassDescription>>recoverFromMDFault (in category 'accessing method dictionary') ----- - recoverFromMDFault - "This method handles methodDict faults to support, eg, discoverActiveClasses (qv)." - (organization isMemberOf: Array) ifFalse: [^ self error: 'oops']. - methodDict := organization first. - organization := organization second. - ! Item was removed: - ----- Method: ClassDescription>>recoverFromMDFaultWithTrace (in category 'accessing method dictionary') ----- - recoverFromMDFaultWithTrace - "This method handles emthodDict faults to support, eg, discoverActiveClasses (qv)." - self recoverFromMDFault. - self environment at: #MDFaultDict ifPresent: - [:faultDict | faultDict at: self name put: - (String streamContents: - [:strm | (thisContext stackOfSize: 20) do: [:item | strm print: item; cr]])] - - "Execute the following statement to induce MD fault tracing. This means that, not only will all active classes be recorded but, after a test run, MDFaultDict will contain, for every class used, a stack trace showing how it came to be used. This statement should be executed just prior to any such text, in order to clear the traces. - - Smalltalk at: #MDFaultDict put: Dictionary new. - - "! Item was removed: - ----- Method: ClassDescription>>reformatAll (in category 'compiling') ----- - reformatAll - "Reformat all methods in this class. - Leaves old code accessible to version browsing" - self selectorsDo: [:sel | self reformatMethodAt: sel]! Item was removed: - ----- Method: ClassDescription>>reformatMethodAt: (in category 'compiling') ----- - reformatMethodAt: selector - | newCodeString method | - newCodeString := self prettyPrinterClass - format: (self sourceCodeAt: selector) - in: self - notifying: nil - decorated: false. - method := self compiledMethodAt: selector. - method - putSource: newCodeString - fromParseNode: nil - class: self - category: (self organization categoryOfElement: selector) - inFile: 2 - priorMethod: method - ! Item was removed: - ----- Method: ClassDescription>>removeCategory: (in category 'accessing method dictionary') ----- - removeCategory: aString - "Remove each of the messages categorized under aString in the method - dictionary of the receiver. Then remove the category aString." - | categoryName | - categoryName := aString asSymbol. - (self organization listAtCategoryNamed: categoryName) do: - [:sel | self removeSelector: sel]. - self organization removeCategory: categoryName! Item was removed: - ----- Method: ClassDescription>>removeInstVarName: (in category 'instance variables') ----- - removeInstVarName: aString - "Remove the argument, aString, as one of the receiver's instance - variables. Create an error notification if the argument is not found." - - self subclassResponsibility! Item was removed: - ----- Method: ClassDescription>>removeSelector: (in category 'accessing method dictionary') ----- - removeSelector: selector - "Remove the message whose selector is given from the method - dictionary of the receiver, if it is there. Answer nil otherwise." - - | priorMethod priorProtocol | - priorMethod := self compiledMethodAt: selector ifAbsent: [^ nil]. - priorProtocol := self whichCategoryIncludesSelector: selector. - - SystemChangeNotifier uniqueInstance doSilently: [ - self organization removeElement: selector]. - - super removeSelector: selector. - - SystemChangeNotifier uniqueInstance - methodRemoved: priorMethod selector: selector inProtocol: priorProtocol class: self.! Item was removed: - ----- Method: ClassDescription>>removeUninstantiatedSubclassesSilently (in category 'accessing class hierarchy') ----- - removeUninstantiatedSubclassesSilently - "Remove the classes of any subclasses that have neither instances nor subclasses. Answer the number of bytes reclaimed" - "self removeUninstantiatedSubclassesSilently" - - | oldFree | - oldFree := Smalltalk garbageCollect. - - self subclasses - select: [:c | (c isSystemDefined not and: [c instanceCount = 0]) and: [c subclasses isEmpty]] - thenDo: [:c | c removeFromSystem]. - - ^ Smalltalk garbageCollect - oldFree! Item was removed: - ----- Method: ClassDescription>>renameInstVar:to: (in category 'instance variables') ----- - renameInstVar: oldName to: newName - - (self confirm: 'WARNING: Renaming of instance variables - is subject to substitution ambiguities. - Do you still wish to attempt it?') ifFalse: [self halt]. - "...In other words, this does a dumb text search-and-replace, - which might improperly alter, eg, a literal string. As long as - the oldName is unique, everything should work jes' fine. - di" - - ^ self renameSilentlyInstVar: oldName to: newName! Item was removed: - ----- Method: ClassDescription>>renameSilentlyInstVar:to: (in category 'instance variables') ----- - renameSilentlyInstVar: old to: new - | i oldName newName | - oldName := old asString. - newName := new asString. - (i := self instVarNames indexOf: oldName) = 0 ifTrue: - [self error: oldName , ' is not defined in ', self name]. - self allSuperclasses , self withAllSubclasses asOrderedCollection do: - [:cls | (cls instVarNames includes: newName) ifTrue: - [self error: newName , ' is already used in ', cls name]]. - - self instVarNames replaceFrom: i to: i with: (Array with: newName). - self replaceSilently: oldName to: newName. "replace in text body of all methods"! Item was removed: - ----- Method: ClassDescription>>reorganize (in category 'organization') ----- - reorganize - "During fileIn, !!Rectangle reorganize!! allows Rectangle to seize control and treat the next chunk as its organization. See the transfer of control where ReadWriteStream fileIn calls scanFrom:" - - ^self organization! Item was removed: - ----- Method: ClassDescription>>replaceSilently:to: (in category 'instance variables') ----- - replaceSilently: old to: new - "text-replace any part of a method. Used for class and pool variables. Don't touch the header. Not guaranteed to work if name appears in odd circumstances" - | oldName newName | - oldName := old asString. - newName := new asString. - self withAllSubclasses do: - [:cls | - | sels | - sels := cls selectors copyWithoutAll: #(DoIt DoItIn:). - sels do: - [:sel | - | oldCode newCode parser header body | - oldCode := cls sourceCodeAt: sel. - "Don't make changes in the method header" - (parser := cls newParser) parseSelector: oldCode. - header := oldCode copyFrom: 1 to: (parser endOfLastToken min: oldCode size). - body := header size > oldCode size - ifTrue: [''] - ifFalse: [oldCode copyFrom: header size+1 to: oldCode size]. - newCode := header , (body copyReplaceTokens: oldName with: newName). - newCode ~= oldCode ifTrue: - [cls compile: newCode - classified: (cls organization categoryOfElement: sel) - notifying: nil]]. - cls isMeta ifFalse: - [| oldCode newCode | - oldCode := cls comment. - newCode := oldCode copyReplaceTokens: oldName with: newName. - newCode ~= oldCode ifTrue: - [cls comment: newCode]]]! Item was removed: - ----- Method: ClassDescription>>setInstVarNames: (in category 'private') ----- - setInstVarNames: instVarArray - "Private - for class initialization only" - | required | - required := self instSize. - superclass notNil ifTrue:[required := required - superclass instSize]. - instVarArray size = required - ifFalse:[^self error: required printString, ' instvar names are required']. - instVarArray isEmpty - ifTrue:[instanceVariables := nil] - ifFalse:[instanceVariables := instVarArray asArray].! Item was removed: - ----- Method: ClassDescription>>sharedPoolsString (in category 'printing') ----- - sharedPoolsString - "Answer a string of my shared pool names separated by spaces." - - ^String streamContents: [ :stream | - self sharedPools - do: [ :each | - stream nextPutAll: (self environment - keyAtIdentityValue: each - ifAbsent: [ 'private' ]) ] - separatedBy: [ stream space ] ]! Item was removed: - ----- Method: ClassDescription>>storeOn: (in category 'printing') ----- - storeOn: aStream - "Classes and Metaclasses have global names." - - aStream nextPutAll: self name! Item was removed: - ----- Method: ClassDescription>>subclasses (in category 'accessing class hierarchy') ----- - subclasses - ^ Array new! Item was removed: - ----- Method: ClassDescription>>subclassesDo: (in category 'accessing class hierarchy') ----- - subclassesDo: aBlock - "Evaluate the argument, aBlock, for each of the receiver's immediate subclasses." - ^self subclasses do: aBlock! Item was removed: - ----- Method: ClassDescription>>superclass:methodDictionary:format: (in category 'initialize-release') ----- - superclass: aClass methodDictionary: mDict format: fmt - "Basic initialization of the receiver" - super superclass: aClass methodDictionary: mDict format: fmt. - instanceVariables := nil. - self organization: nil.! Item was removed: - ----- Method: ClassDescription>>theMetaClass (in category 'accessing parallel hierarchy') ----- - theMetaClass - "Sent to a class or metaclass, always return the metaclass" - - ^self class! Item was removed: - ----- Method: ClassDescription>>theNonMetaClass (in category 'accessing parallel hierarchy') ----- - theNonMetaClass - "Sent to a class or metaclass, always return the class" - - ^self! Item was removed: - ----- 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," - | map variable instSize newInstances | - - oldInstances isEmpty ifTrue: - [^nil]. "no instances to convert" - isMeta ifTrue: - [(oldInstances size = 1 - and: [self soleInstance class == self - or: [self soleInstance class == oldClass]]) ifFalse: - [^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)]. - "Now perform a bulk mutation of old instances into new ones" - oldInstances elementsForwardIdentityAndHashTo: newInstances. - ^nil! Item was removed: - ----- 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." - "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. - ^nil - - "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"! Item was removed: - ----- Method: ClassDescription>>updateMethodBindingsTo: (in category 'initialize-release') ----- - updateMethodBindingsTo: aBinding - "ClassBuilder support for maintaining valid method bindings." - methodDict do: [:method| method methodClassAssociation: aBinding]! Item was removed: - ----- Method: ClassDescription>>version (in category 'accessing') ----- - version - "Allows polymoprhism with TraitDescription>>version" - - ^ self classVersion! Item was removed: - ----- Method: ClassDescription>>wantsChangeSetLogging (in category 'compiling') ----- - wantsChangeSetLogging - "Answer whether code submitted for the receiver should be remembered by the changeSet mechanism. 7/12/96 sw" - - ^ true! Item was removed: - ----- Method: ClassDescription>>wantsRecompilationProgressReported (in category 'compiling') ----- - wantsRecompilationProgressReported - "Answer whether the receiver would like progress of its recompilation reported interactively to the user." - - ^ true! Item was removed: - ----- Method: ClassDescription>>whichCategoryIncludesSelector: (in category 'organization') ----- - whichCategoryIncludesSelector: aSelector - "Answer the category of the argument, aSelector, in the organization of - the receiver, or answer nil if the receiver does not inlcude this selector." - - (self includesSelector: aSelector) - ifTrue: [^ self organization categoryOfElement: aSelector] - ifFalse: [^nil]! Item was removed: - ----- Method: ClassDescription>>whichMethodsStoreInto: (in category 'testing') ----- - whichMethodsStoreInto: varName - "Answer a collection of CompiledMethod whose methods access the argument, varName, - as a named class or pool variable. Or let super try with a named instance variable." - ^(self bindingOf: varName) - ifNil: [super whichMethodsStoreInto: varName] - ifNotNil: [:ref| self methodDict values select: [:eachMethod| eachMethod writesRef: ref]]! Item was removed: - ----- Method: ClassDescription>>zapOrganization (in category 'organization') ----- - zapOrganization - "Remove the organization of this class by message categories. - This is typically done to save space in small systems. Classes and methods - created or filed in subsequently will, nonetheless, be organized" - - self hasTraitComposition ifFalse:[ - self organization: nil. - self isClassSide ifFalse: [self classSide zapOrganization] - ].! Item was removed: - BasicClassOrganizer subclass: #ClassOrganizer - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Kernel-Classes'! - - !ClassOrganizer commentStamp: 'NS 4/6/2004 16:13' prior: 0! - I represent method categorization information for classes. The handling of class comments has gone through a tortuous evolution. Grandfathered class comments (before late aug 98) have no time stamps, and historically, fileouts of class comments always substituted the timestamp reflecting the author and date/time at the moment of fileout; and historically any timestamps in a filed out class comment were dropped on the floor, with the author & time prevailing at the moment of filein being substituted. Such grandfathered comments now go out on fileouts with '<historical>' timestamp; class comments created after the 8/98 changes will have their correct timestamps preserved, though there is not yet a decent ui for reading those stamps other than filing out and looking at the file; nor is there yet any ui for browsing and recovering past versions of such comments. Everything in good time!!! Item was removed: - ----- Method: ClassOrganizer class>>cleanUp: (in category 'class initialization') ----- - cleanUp: aggressive - "Remove empty method categories when cleaning aggressively" - - aggressive ifTrue: [ - SystemChangeNotifier uniqueInstance doSilently: [ - Smalltalk removeEmptyMessageCategories]]. - ! Item was removed: - ----- Method: ClassOrganizer>>addCategory:before: (in category 'accessing') ----- - addCategory: catString before: nextCategory - SystemChangeNotifier uniqueInstance - doSilently: [super addCategory: catString before: nextCategory]; - protocolAdded: catString inClass: self subject! Item was removed: - ----- Method: ClassOrganizer>>changeFromCategorySpecs: (in category 'accessing') ----- - changeFromCategorySpecs: categorySpecs - | oldDict oldCategories | - oldDict := self elementCategoryDict. - oldCategories := self categories copy. - SystemChangeNotifier uniqueInstance doSilently: [ - super changeFromCategorySpecs: categorySpecs]. - self notifyOfChangedSelectorsOldDict: oldDict newDict: self elementCategoryDict. - self notifyOfChangedCategoriesFrom: oldCategories to: self categories.! Item was removed: - ----- Method: ClassOrganizer>>classComment: (in category 'accessing') ----- - classComment: aString - "Guards against setting the comment in a metaclass which is invalid" - subject isMeta ifTrue:[^self error: 'Cannot set metaclass comments']. - ^super classComment: aString! Item was removed: - ----- Method: ClassOrganizer>>classComment:stamp: (in category 'accessing') ----- - classComment: aString stamp: aStamp - "Guards against setting the comment in a metaclass which is invalid" - subject isMeta ifTrue:[^self error: 'Cannot set metaclass comments']. - ^super classComment: aString stamp: aStamp! Item was removed: - ----- Method: ClassOrganizer>>classify:under:logged: (in category 'classifying') ----- - classify: element under: heading logged: aBoolean - self classify: element under: heading suppressIfDefault: true logged: aBoolean - ! Item was removed: - ----- Method: ClassOrganizer>>classify:under:suppressIfDefault: (in category 'classifying') ----- - classify: element under: heading suppressIfDefault: aBoolean - self classify: element under: heading suppressIfDefault: aBoolean logged: false - ! Item was removed: - ----- Method: ClassOrganizer>>classify:under:suppressIfDefault:logged: (in category 'classifying') ----- - classify: element under: heading suppressIfDefault: aBoolean logged: logged - | oldCat newCat | - oldCat := self categoryOfElement: element. - SystemChangeNotifier uniqueInstance doSilently: [ - super classify: element under: heading suppressIfDefault: aBoolean]. - newCat := self categoryOfElement: element. - self notifyOfChangedSelector: element from: oldCat to: newCat. - logged ifTrue: [self logChangedSelector: element category: newCat]. - ! Item was removed: - ----- Method: ClassOrganizer>>classifyAllUnclassified (in category 'classifying') ----- - classifyAllUnclassified - - | organizers | - organizers := self subject withAllSuperclasses collect: [:ea | ea organization]. - (self listAtCategoryNamed: ClassOrganizer default) do: [:sel | | found | - found := (organizers collect: [ :org | org categoryOfElement: sel]) - detect: [:ea | ea ~= ClassOrganizer default and: [ ea ~= nil]] - ifNone: []. - found ifNotNil: [self classify: sel under: found]]. - ! Item was removed: - ----- Method: ClassOrganizer>>logChangedSelector:category: (in category 'private') ----- - logChangedSelector: element category: newCategory - "make an entry in the changes to record the changed category" - | method | - "if we do not have a changes file, the code below would try to make a new method" - (subject == nil or: [SourceFiles == nil or: [(SourceFiles at: 2) == nil]]) ifTrue: [^self]. - method := subject compiledMethodAt: element ifAbsent: [^self]. - subject logMethodSource: (method getSourceFor: element in: subject) - forMethodWithNode: (CompiledMethodWithNode method: method node: method) - inCategory: newCategory withStamp: method timeStamp notifying: nil. - ! Item was removed: - ----- Method: ClassOrganizer>>logSelectorsInChangedCategory: (in category 'private') ----- - logSelectorsInChangedCategory: newCategory - "make an entry in the changes file for each method in the changed category" - (self listAtCategoryNamed: newCategory) do: [:element | - self logChangedSelector: element category: newCategory]. - ! Item was removed: - ----- Method: ClassOrganizer>>notifyOfChangedCategoriesFrom:to: (in category 'private') ----- - notifyOfChangedCategoriesFrom: oldCollectionOrNil to: newCollectionOrNil - (self hasSubject and: [oldCollectionOrNil ~= newCollectionOrNil]) - ifTrue: [SystemChangeNotifier uniqueInstance classReorganized: self subject].! Item was removed: - ----- Method: ClassOrganizer>>notifyOfChangedSelector:from:to: (in category 'private') ----- - notifyOfChangedSelector: element from: oldCategory to: newCategory - (self hasSubject and: [(oldCategory ~= newCategory)]) ifTrue: [ - self subject notifyOfRecategorizedSelector: element from: oldCategory to: newCategory. - ].! Item was removed: - ----- Method: ClassOrganizer>>notifyOfChangedSelectorsOldDict:newDict: (in category 'private') ----- - notifyOfChangedSelectorsOldDict: oldDictionaryOrNil newDict: newDictionaryOrNil - (oldDictionaryOrNil isNil and: [newDictionaryOrNil isNil]) - ifTrue: [^ self]. - - oldDictionaryOrNil isNil ifTrue: [ - newDictionaryOrNil keysAndValuesDo: [:el :cat | - self notifyOfChangedSelector: el from: nil to: cat]. - ^ self. - ]. - - newDictionaryOrNil isNil ifTrue: [ - oldDictionaryOrNil keysAndValuesDo: [:el :cat | - self notifyOfChangedSelector: el from: cat to: nil]. - ^ self. - ]. - - oldDictionaryOrNil keysAndValuesDo: [:el :cat | - | newCat | - newCat := newDictionaryOrNil at: el. - self notifyOfChangedSelector: el from: cat to: newCat. - ].! Item was removed: - ----- Method: ClassOrganizer>>removeCategory: (in category 'accessing') ----- - removeCategory: cat - SystemChangeNotifier uniqueInstance - doSilently: [super removeCategory: cat]; - protocolRemoved: cat inClass: self subject! Item was removed: - ----- Method: ClassOrganizer>>removeElement: (in category 'accessing') ----- - removeElement: element - | oldCat | - oldCat := self categoryOfElement: element. - SystemChangeNotifier uniqueInstance doSilently: [ - super removeElement: element]. - self notifyOfChangedSelector: element from: oldCat to: (self categoryOfElement: element).! Item was removed: - ----- Method: ClassOrganizer>>removeEmptyCategories (in category 'accessing') ----- - removeEmptyCategories - | oldCategories | - oldCategories := self categories copy. - SystemChangeNotifier uniqueInstance doSilently: [ - super removeEmptyCategories]. - self notifyOfChangedCategoriesFrom: oldCategories to: self categories.! Item was removed: - ----- Method: ClassOrganizer>>renameCategory:toBe: (in category 'accessing') ----- - renameCategory: oldCatString toBe: newCatString - SystemChangeNotifier uniqueInstance - doSilently: [super renameCategory: oldCatString toBe: newCatString]; - protocolRenamedFrom: oldCatString asSymbol to: newCatString asSymbol inClass: self subject. - self logSelectorsInChangedCategory: newCatString. - ! Item was removed: - ----- Method: ClassOrganizer>>setDefaultList: (in category 'accessing') ----- - setDefaultList: aSortedCollection - | oldDict oldCategories | - oldDict := self elementCategoryDict. - oldCategories := self categories copy. - SystemChangeNotifier uniqueInstance doSilently: [ - super setDefaultList: aSortedCollection]. - self notifyOfChangedSelectorsOldDict: oldDict newDict: self elementCategoryDict. - self notifyOfChangedCategoriesFrom: oldCategories to: self categories.! Item was removed: - ----- Method: ClassOrganizer>>sortCategories (in category 'accessing') ----- - sortCategories - | oldCategories | - oldCategories := self categories copy. - SystemChangeNotifier uniqueInstance doSilently: [ - super sortCategories]. - self notifyOfChangedCategoriesFrom: oldCategories to: self categories.! Item was removed: - InstructionClient subclass: #ClosureExtractor - instanceVariableNames: 'action scanner currentContext' - classVariableNames: '' - poolDictionaries: '' - category: 'Kernel-Methods'! - - !ClosureExtractor commentStamp: 'mha 9/21/2010 11:16' prior: 0! - A ClosureExtractor is a utility class that is used to extract all BlockClosures from a CompiledMethod. It inherits from InstructionClient and understands only one single message, namely that corresponding to the push closure bytecode instruction. Being sent this message, a ClosureExtractor will create a BlockClosure instance and evaluate the block it holds as an instance variable with that closure as parameter.! Item was removed: - ----- Method: ClosureExtractor class>>withAction:andScanner: (in category 'instance creation') ----- - withAction: aBlock andScanner: anInstructionStream - "The passed block must accept one value, which will be a BlockClosure." - ^ self new action: aBlock; scanner: anInstructionStream! Item was removed: - ----- Method: ClosureExtractor>>action (in category 'accessing') ----- - action - ^ action! Item was removed: - ----- Method: ClosureExtractor>>action: (in category 'accessing') ----- - action: aBlock - action := aBlock! Item was removed: - ----- Method: ClosureExtractor>>blockReturnConstant: (in category 'instruction decoding') ----- - blockReturnConstant: value - currentContext := currentContext sender! Item was removed: - ----- Method: ClosureExtractor>>blockReturnTop (in category 'instruction decoding') ----- - blockReturnTop - currentContext := currentContext sender! Item was removed: - ----- Method: ClosureExtractor>>pushClosureCopyNumCopiedValues:numArgs:blockSize: (in category 'instruction decoding') ----- - pushClosureCopyNumCopiedValues: numCopied numArgs: numArgs blockSize: blockSize - "Create a BlockClosure corresponding to the closure bytecode - and execute the action block with it. The created BlockClosure is only a pseudo value, - it is not populated with meaningful context and argument information." - | block | - block := BlockClosure - outerContext: currentContext - startpc: scanner pc - numArgs: numArgs - copiedValues: (Array new: numCopied).. - currentContext := block asContextWithSender: currentContext. - action value: block! Item was removed: - ----- Method: ClosureExtractor>>pushFullClosure:numCopied: (in category 'instruction decoding') ----- - pushFullClosure: aCompiledBlock numCopied: numCopied - "Create a BlockClosure corresponding to the closure bytecode - and execute the action block with it. The created BlockClosure is only a pseudo value, - it is not populated with meaningful context and argument information." - self pushFullClosure: aCompiledBlock numCopied: numCopied receiverOnStack: false ignoreOuterContext: false! Item was removed: - ----- Method: ClosureExtractor>>pushFullClosure:numCopied:receiverOnStack:ignoreOuterContext: (in category 'instruction decoding') ----- - pushFullClosure: aCompiledBlock numCopied: numCopied receiverOnStack: rcvrOnStack ignoreOuterContext: ignoreOuterContext - "Create a BlockClosure corresponding to the closure bytecode - and execute the action block with it. The created BlockClosure is only a pseudo value, - it is not populated with meaningful context and argument information." - | block encoderClass endPC extractor subScanner | - block := FullBlockClosure - receiver: (rcvrOnStack ifTrue: [#onStackReceiver]) - outerContext: (ignoreOuterContext ifFalse: [currentContext]) - method: aCompiledBlock - copiedValues: (Array new: numCopied). - currentContext := block asContextWithSender: currentContext. - action value: block. - subScanner := aCompiledBlock scanner. - extractor := self class withAction: action andScanner: subScanner. - endPC := aCompiledBlock endPC. - encoderClass := aCompiledBlock encoderClass. - [subScanner pc <= endPC] whileTrue: - [encoderClass interpretNextInstructionFor: extractor in: subScanner]! Item was removed: - ----- Method: ClosureExtractor>>scanner (in category 'accessing') ----- - scanner - ^ scanner! Item was removed: - ----- Method: ClosureExtractor>>scanner: (in category 'accessing') ----- - scanner: anInstructionStream - scanner := anInstructionStream. - currentContext := Context - sender: nil - receiver: nil - method: scanner method - arguments: (Array new: scanner method numArgs)! Item was removed: - CompiledCode variableByteSubclass: #CompiledBlock - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Kernel-Methods'! - - !CompiledBlock commentStamp: 'eem 2/27/2018 12:27' prior: 0! - CompiledBlock instances are blocks suitable for interpretation by the virtual machine. They are a specialization of CompiledCode. This requires both bytecode set and compiler support. The V3 bytecode (EncoderForV3PlusClosures) does not provide support for CompiledBlock. The SistaV1 set does (EncoderForSistaV1). - - The last literal in a CompiledBlock is reserved for a reference to its enclosing CompiledBlock or CompiledMethod. Super sends in CompiledBlocks must use the directed super send bytecode. - - By convention the penultimate literal of a method is either its selector or an instance of AdditionalMethodState. AdditionalMethodState may be used to add instance variables to a method, albeit ones held in the method's AdditionalMethodState. Subclasses of CompiledBlock that want to add state should subclass AdditionalMethodState to add the state they want, and implement methodPropertiesClass on the class side of the CompiledBlock subclass to answer the specialized subclass of AdditionalMethodState. Enterprising programmers are encouraged to try and implement this support automatically through suitable modifications to the compiler and class builder.! Item was removed: - ----- Method: CompiledBlock>>anyAndAllMessages (in category 'literals') ----- - anyAndAllMessages - ^self homeMethod anyAndAllMessages! Item was removed: - ----- Method: CompiledBlock>>codeLiteralsDo: (in category 'literals') ----- - codeLiteralsDo: aBlock - "Overwritten to not cause infinite loop." - - aBlock value: self. - - self literalsDo: [:literal | - (literal isCompiledCode and: [literal ~~ self outerCode]) ifTrue: [ - literal codeLiteralsDo: aBlock]].! Item was removed: - ----- Method: CompiledBlock>>copyWithOuterCode: (in category 'private-copying') ----- - copyWithOuterCode: aCompiledCode - "Private; answer a shallow copy of the receiver updated with deep copies of - embedded block methods and a reference to aCompiledCode as the outer code." - | numLiterals copy | - copy := self shallowCopy. - 1 to: (numLiterals := self numLiterals) - 1 do: - [:i| | lit | - (lit := copy literalAt: i) isCompiledCode ifTrue: - [copy literalAt: i put: (lit copyWithOuterCode: copy)]]. - copy literalAt: numLiterals put: aCompiledCode. - ^copy! Item was removed: - ----- Method: CompiledBlock>>encoderClass (in category 'accessing') ----- - encoderClass - "Answer the encoder class that encoded the bytecodes in this method. - The sign flag bit is used by the VM to select a bytecode set. This formulation - may seem odd but this has to be fast, so no property probe unless needed." - - ^self header >= 0 - ifTrue: - [PrimaryBytecodeSetEncoderClass] - ifFalse: - [PrimaryBytecodeSetEncoderClass == SecondaryBytecodeSetEncoderClass - ifTrue: "Support for testing prior to installing another set" - [(self homeMethod propertyValueAt: #encoderClass) ifNil: [SecondaryBytecodeSetEncoderClass]] - ifFalse: - [SecondaryBytecodeSetEncoderClass]]! Item was removed: - ----- Method: CompiledBlock>>hasSameLiteralsAs: (in category 'comparing') ----- - hasSameLiteralsAs: aMethod - "Answer whether the receiver has the same sequence of literals as the argument. - Do not fully compare the last literal as this is the outerCode back pointer to the - containing method or block, and following it would cause infinite recursion. In any - case this is a useful definition because it considers identical block methods in other- - wise different containing blocks or methods to be the same, which makes sense." - | numLits | - numLits := self numLiterals. - numLits = aMethod numLiterals ifFalse: [^false]. - 1 to: numLits - 1 do: - [:i| | lit1 lit2 | - lit1 := self literalAt: i. - lit2 := aMethod literalAt: i. - (lit1 == lit2 or: [lit1 literalEqual: lit2]) ifFalse: - [^false]]. - ^(self literalAt: numLits) isCompiledCode = (aMethod literalAt: numLits) isCompiledCode! Item was removed: - ----- Method: CompiledBlock>>headerDescription (in category 'printing') ----- - headerDescription - "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: '"block full'; 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! Item was removed: - ----- Method: CompiledBlock>>holdsTempNames (in category 'source code management') ----- - holdsTempNames - ^self homeMethod holdsTempNames! Item was removed: - ----- Method: CompiledBlock>>homeMethod (in category 'accessing') ----- - homeMethod - "answer the compiled method that I am installed in, or nil if none." - ^self outerCode homeMethod! Item was removed: - ----- Method: CompiledBlock>>isCompiledBlock (in category 'testing') ----- - isCompiledBlock - ^true! Item was removed: - ----- Method: CompiledBlock>>isQuick (in category 'testing') ----- - isQuick - ^false! Item was removed: - ----- Method: CompiledBlock>>longPrintOn:indent: (in category 'printing') ----- - longPrintOn: aStream indent: tabs - "List of all the byte codes in a method with a short description of each" - (InstructionPrinter on: self) indent: tabs; printInstructionsOn: aStream! Item was removed: - ----- Method: CompiledBlock>>method (in category 'accessing') ----- - method - "answer the compiled method that I am installed in, or nil if none." - ^self outerCode method! Item was removed: - ----- Method: CompiledBlock>>methodClass (in category 'accessing') ----- - methodClass - "Answer the class that I am installed in." - ^self homeMethod methodClass! Item was removed: - ----- Method: CompiledBlock>>methodForDecompile (in category 'decompiling') ----- - methodForDecompile - ^self homeMethod methodForDecompile! Item was removed: - ----- Method: CompiledBlock>>methodNode (in category 'accessing') ----- - methodNode - ^ self homeMethod methodNode! Item was removed: - ----- Method: CompiledBlock>>numCopiedValues (in category 'accessing') ----- - numCopiedValues - "Answer the number of copied values the receiver expects. - This is not fast as it is not expected to be needed from the - compiled block itself. It is available cheaply from a block - closure for the method." - - | locator scanner pc | - locator := BlockStartLocator new. - scanner := InstructionStream on: self outerCode. - [pc := scanner pc. - self == (scanner interpretNextInstructionFor: locator) ifTrue: - [^(self outerCode abstractBytecodeMessageAt: pc) arguments second]. - scanner atEnd] whileFalse. - self error: 'cannot find the block creation bytecode for this compiled block in its outer code.'! Item was removed: - ----- Method: CompiledBlock>>outerCode (in category 'accessing') ----- - outerCode - "answer the compiled code that I am installed in, or nil if none." - ^self literalAt: self numLiterals! Item was removed: - ----- Method: CompiledBlock>>outerCode: (in category 'accessing') ----- - outerCode: aCompiledCode - ^self literalAt: self numLiterals put: aCompiledCode! Item was removed: - ----- Method: CompiledBlock>>postCopy (in category 'copying') ----- - postCopy - 1 to: self numLiterals - 1 do: - [:index| | lit | - (lit := self literalAt: index) isCompiledCode ifTrue: - [lit outerCode: self; postCopy]]! Item was removed: - ----- Method: CompiledBlock>>pragmaAt: (in category 'accessing-pragmas & properties') ----- - pragmaAt: aKey - "Answer the pragma with selector aKey, or nil if none." - ^self homeMethod pragmaAt: aKey! Item was removed: - ----- Method: CompiledBlock>>pragmas (in category 'accessing-pragmas & properties') ----- - pragmas - ^self homeMethod pragmas! Item was removed: - ----- Method: CompiledBlock>>pragmasAt: (in category 'accessing-pragmas & properties') ----- - pragmasAt: aSelector - "Answer all pragmas with selector aSelector." - ^self homeMethod pragmasAt: aSelector! Item was removed: - ----- Method: CompiledBlock>>primitive (in category 'accessing') ----- - primitive - ^0! Item was removed: - ----- Method: CompiledBlock>>printReferenceOn: (in category 'printing') ----- - printReferenceOn: aStream - "Override to indicate that this is a block, and to print a null reference when - the CompiledBlock is only partially initialized, as it is during compilation." - aStream nextPutAll: '[] in '. - self outerCode isVariableBinding - ifTrue: [aStream nextPutAll: ' (as yet unbound)'] - ifFalse: [super printReferenceOn: aStream]! Item was removed: - ----- Method: CompiledBlock>>propertyKeysAndValuesDo: (in category 'accessing-pragmas & properties') ----- - propertyKeysAndValuesDo: aBlock - "Enumerate the receiver with all the keys and values." - ^self homeMethod propertyKeysAndValuesDo: aBlock! Item was removed: - ----- Method: CompiledBlock>>propertyValueAt: (in category 'accessing-pragmas & properties') ----- - propertyValueAt: propName - ^self homeMethod propertyValueAt: propName! Item was removed: - ----- Method: CompiledBlock>>propertyValueAt:ifAbsent: (in category 'accessing-pragmas & properties') ----- - propertyValueAt: propName ifAbsent: aBlock - ^self homeMethod propertyValueAt: propName ifAbsent: aBlock! Item was removed: - ----- Method: CompiledBlock>>propertyValueAt:put: (in category 'accessing-pragmas & properties') ----- - propertyValueAt: propName put: propValue - "Set or add the property with key propName and value propValue. - If the receiver does not yet have a method properties create one and replace - the selector with it. Otherwise, either relace propValue in the method properties - or replace method properties with one containing the new property." - ^self homeMethod propertyValueAt: propName put: propValue! Item was removed: - ----- Method: CompiledBlock>>removeProperty: (in category 'accessing-pragmas & properties') ----- - removeProperty: propName - "Remove the property propName if it exists. - Do _not_ raise an error if the property is missing." - ^self homeMethod removeProperty: propName! Item was removed: - ----- Method: CompiledBlock>>removeProperty:ifAbsent: (in category 'accessing-pragmas & properties') ----- - removeProperty: propName ifAbsent: aBlock - "Remove the property propName if it exists. - Answer the evaluation of aBlock if the property is missing." - ^self homeMethod removeProperty: propName ifAbsent: aBlock! Item was removed: - ----- Method: CompiledBlock>>selector (in category 'accessing') ----- - selector - ^ self homeMethod selector! Item was removed: - ByteArray variableByteSubclass: #CompiledCode - instanceVariableNames: '' - classVariableNames: 'LargeFrame PreferredBytecodeSetEncoderClass PrimaryBytecodeSetEncoderClass SecondaryBytecodeSetEncoderClass SmallFrame' - poolDictionaries: '' - category: 'Kernel-Methods'! - - !CompiledCode commentStamp: 'eem 2/27/2018 12:23' prior: 0! - CompiledCode instances are methods suitable for execution by the virtual machine. Instances of CompiledCode and its subclasses are the only objects in the system that have both indexable pointer fields and indexable 8-bit integer fields. The pointer fields are used for literals and metadata, and the bytes are used for bytecodes and a variety of encoded informaton such as source code, source code position, etc. The first part of a CompiledCode object is pointers, the second part is bytes. CompiledCode inherits from ByteArray to avoid duplicating some of ByteArray's methods, not because a CompiledCode is-a ByteArray. - - Instance variables: *indexed* (no named inst vars) - - 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 CompiledCode object is as follows: - - header (4 or 8 bytes, SmallInteger) - literals (4 or 8 bytes each, Object, see "The last literal..." below) - bytecodes (variable, bytes) - trailer (variable, bytes) - - The header is a SmallInteger (which in the 32-bit system has 31 bits, and in the 64-bit system, 61 bits) in the following format: - - (index 0) 15 bits: number of literals (#numLiterals) - (index 15) 1 bit: jit without counters - reserved for methods that have been optimized by Sista - (index 16) 1 bit: has primitive - (index 17) 1 bit: whether a large frame size is needed (#frameSize => either SmallFrame or LargeFrame) - (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). - sign bit: 1 bit: selects the instruction set, >= 0 Primary, < 0 Secondary (#signFlag) - - If the method has a primitive then the first bytecode of the method must be a callPrimitive: bytecode that encodes the primitive index. This bytecode can encode a primitive index from 0 to 65535. - - 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. - - While there are disadvantages to this "flat" representation (it is impossible to add named instance variables to CompiledCode or its subclasses, but it is possible indirectly; see AdditionalMethodState) it is effective for interpreters. It means that both bytecodes and literals can be fetched directly from a single method object, and that only one object, the method, must be saved and restored on activation and return. A more natural representation, in which there are searate instance variables for the bytecode, and (conveniently) the literals, requires either much more work on activation and return setting up references to the literals and bytecodes, or slower access to bytecodes and literals, indirecting on each access. - - The last literal of a CompiledCode object is reserved for special use by the kernel and/or the virtual machine. In CompiledMethod instances it must either be the methodClassAssociation, used to implement super sends, or nil, if the method is anonymous. In CompiledBlock it is to be used for a reference to the enclosing method or block object. - - By convention, the penultimate literal is reserved for special use by the kernel. In CompiledMethod instances it must either be the method selector, or an instance of AdditionalMethodState which holds the selector and any pragmas or properties in the method. In CompiledBlock it is reserved for use for an AdditionalMethodState. - - Note that super sends in CompiledBlock instances do not use a methodClass association, but expect a directed supersend bytecode, in which the method class (the subclass of the class in which to start the lookup) is a literal. Logically when we switch to a bytecode set that supports the directed super send bytecode, and discard the old super send bytecodes, we can use the last literal to store the selector or the enclosing method/block or an AdditionalMethodState, and the AdditionalMethodState can hold the selector and/or the enclosing method/block.! Item was removed: - ----- Method: CompiledCode class>>basicNew (in category 'instance creation') ----- - basicNew - ^self newMethodViaNewError! Item was removed: - ----- Method: CompiledCode class>>basicNew: (in category 'instance creation') ----- - basicNew: size - ^self newMethodViaNewError! Item was removed: - ----- Method: CompiledCode class>>byteCodeSetsKnownToTheVM (in category 'method encoding') ----- - byteCodeSetsKnownToTheVM - "Answer the encoder names for the bytecode sets reported to be supported - by the virtual machine. Informational, failure indicates only that the VM does - not support the primitive query." - - "CompiledCode byteCodeSetsKnownToTheVM" - - <primitive: 'primitiveBytecodeSetsAvailable'> - ^ self primitiveFailed - ! Item was removed: - ----- Method: CompiledCode class>>fullFrameSize (in category 'constants') ----- - fullFrameSize "CompiledMethod fullFrameSize" - ^ LargeFrame! Item was removed: - ----- Method: CompiledCode 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 removed: - ----- Method: CompiledCode 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 removed: - ----- Method: CompiledCode class>>headerFlagForEncoder: (in category 'method encoding') ----- - headerFlagForEncoder: anEncoder - "This allows subclasses for compiler variants such as the ScriptEncoder in EToys - to continue to function." - (anEncoder isKindOf: PrimaryBytecodeSetEncoderClass) ifTrue: - [^0]. - (anEncoder isKindOf: SecondaryBytecodeSetEncoderClass) ifTrue: - [^SmallInteger minVal]. - self error: 'The encoder is not one of the two installed bytecode sets'! Item was removed: - ----- Method: CompiledCode class>>initialize (in category 'class initialization') ----- - initialize "CompiledMethod initialize" - "Initialize class variables specifying the size of the temporary frame - needed to run instances of me." - - SmallFrame := 16. "Context range for temps+stack" - LargeFrame := 56. - PrimaryBytecodeSetEncoderClass ifNil: - [PrimaryBytecodeSetEncoderClass := EncoderForV3PlusClosures]. - SecondaryBytecodeSetEncoderClass ifNil: - [SecondaryBytecodeSetEncoderClass := EncoderForSistaV1]! Item was removed: - ----- Method: CompiledCode class>>initializedInstance (in category 'instance creation') ----- - initializedInstance - "Don't even think of it. - This low level machinery is not for general use." - - ^nil! Item was removed: - ----- Method: CompiledCode 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 removed: - ----- Method: CompiledCode 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 removed: - ----- Method: CompiledCode class>>isCompiledCodeClass (in category 'testing') ----- - isCompiledCodeClass - ^true! Item was removed: - ----- Method: CompiledCode class>>maxNumLiterals (in category 'constants') ----- - maxNumLiterals - "The current header format and the VM's interpretation of it allows for a maximum of 32767 literals." - ^32767! Item was removed: - ----- Method: CompiledCode class>>multipleBytecodeSetsActive (in category 'method encoding') ----- - multipleBytecodeSetsActive - "Answer if the VM supports multiple bytecode sets, typically the Sista bytecodes - in addition to the traditional V3 bytecode set." - - <primitive: 'primitiveMultipleBytecodeSetsActive'> - self primitiveFailed - ! Item was removed: - ----- Method: CompiledCode class>>multipleBytecodeSetsActive: (in category 'method encoding') ----- - multipleBytecodeSetsActive: aBoolean - "Inform the VM when multiple bytecode sets, typically the Sista bytecodes - in addition to the traditional V3 bytecode set, are now in use is this image. - The VM may use this information to update the image format number when - saving the image to the file system." - - <primitive: 'primitiveMultipleBytecodeSetsActive'> - ! Item was removed: - ----- Method: CompiledCode class>>new (in category 'instance creation') ----- - new - ^self newMethodViaNewError! Item was removed: - ----- Method: CompiledCode class>>new: (in category 'instance creation') ----- - new: size - ^self newMethodViaNewError! Item was removed: - ----- Method: CompiledCode 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']. - nTemps > 63 ifTrue: - [^self error: 'Cannot compile -- too many temporary variables']. - nLits > 32767 ifTrue: - [^self error: 'Cannot compile -- too many literals']. - - 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! Item was removed: - ----- Method: CompiledCode 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']. - nTemps > 63 ifTrue: - [^self error: 'Cannot compile -- too many temporary variables']. - nLits > 32767 ifTrue: - [^self error: 'Cannot compile -- too many literals']. - - 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! Item was removed: - ----- Method: CompiledCode class>>newFrom: (in category 'instance creation') ----- - newFrom: aCompiledMethod - "Clone the argument, aCompiledMethod" - | inst | - "CompiledMethod newFrom: CompiledMethod class >> #newFrom:" - inst := self newMethod: aCompiledMethod basicSize - aCompiledMethod initialPC + 1 - header: aCompiledMethod header. - 1 to: aCompiledMethod numLiterals do: - [:index| - inst literalAt: index put: (aCompiledMethod literalAt: index)]. - aCompiledMethod initialPC to: aCompiledMethod size do: - [:index | - inst at: index put: (aCompiledMethod at: index)]. - inst postCopy. - ^inst! Item was removed: - ----- Method: CompiledCode class>>newInstanceFrom:variable:size:map: (in category 'instance creation') ----- - newInstanceFrom: oldInstance variable: variable size: instSize map: map - "Create a new instance of the receiver based on the given old instance. - The supplied map contains a mapping of the old instVar names into - the receiver's instVars" - | new | - new := self newFrom: oldInstance. - 1 to: instSize do: - [:offset | (map at: offset) > 0 ifTrue: - [new instVarAt: offset - put: (oldInstance instVarAt: (map at: offset))]]. - ^new! Item was removed: - ----- Method: CompiledCode class>>newMethod:header: (in category 'instance creation') ----- - 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." - - <primitive: 79 error: ec> - ec == #'insufficient object memory' ifTrue: - [^self handleFailingNewMethod: numberOfBytes header: headerWord]. - ^self primitiveFailed! Item was removed: - ----- Method: CompiledCode class>>newMethodViaNewError (in category 'private') ----- - newMethodViaNewError - - ^self error: self class name, 's may only be created with newMethod:header:'! Item was removed: - ----- Method: CompiledCode class>>preferredBytecodeSetEncoderClass (in category 'preferences') ----- - preferredBytecodeSetEncoderClass - <preference: 'Preferred bytecode set encoder class' - category: 'Compiler' - description: 'The system supports up to two bytecode sets; select the preferred one to use here. See CompiledCode class variables PrimaryBytecodeSetEncoderClass and SecondaryBytecodeSetEncoderClass.' - type: #Class> - ^PreferredBytecodeSetEncoderClass ifNil: [SecondaryBytecodeSetEncoderClass]! Item was removed: - ----- Method: CompiledCode class>>preferredBytecodeSetEncoderClass: (in category 'preferences') ----- - preferredBytecodeSetEncoderClass: aBytecodeEncoderSubclass - "Set the class that determines the bytecode set used to compile methods with. - [| nPrimary nSecondary | - nPrimary := nSecondary := 0. - self allSubInstancesDo: - [:cm| - cm header >= 0 - ifTrue: [nPrimary := nPrimary + 1] - ifFalse: [nSecondary := nSecondary + 1]]. - {nPrimary. nSecondary}]" - | nPrimary nSecondary | - aBytecodeEncoderSubclass ifNil: [ "Use default value." - PreferredBytecodeSetEncoderClass := nil. - ^ self preferredBytecodeSetEncoderClass: self preferredBytecodeSetEncoderClass]. - self assert: (aBytecodeEncoderSubclass includesBehavior: BytecodeEncoder). - (aBytecodeEncoderSubclass == PrimaryBytecodeSetEncoderClass - or: [aBytecodeEncoderSubclass == SecondaryBytecodeSetEncoderClass]) ifTrue: - [PreferredBytecodeSetEncoderClass := aBytecodeEncoderSubclass. - ^self]. - nPrimary := nSecondary := 0. - self allSubInstancesDo: - [:cm| - cm header >= 0 - ifTrue: [nPrimary := nPrimary + 1] - ifFalse: [nSecondary := nSecondary + 1]]. - nPrimary = 0 ifTrue: - [self installPrimaryBytecodeSet: aBytecodeEncoderSubclass. - ^self preferredBytecodeSetEncoderClass: aBytecodeEncoderSubclass]. - nSecondary = 0 ifTrue: - [self installSecondaryBytecodeSet: aBytecodeEncoderSubclass. - ^self preferredBytecodeSetEncoderClass: aBytecodeEncoderSubclass]. - self error: 'Cannot set preferred bytecode set. Both of the current sets appear to be in use.'! Item was removed: - ----- Method: CompiledCode class>>primaryBytecodeSetEncoderClass (in category 'method encoding') ----- - primaryBytecodeSetEncoderClass - ^PrimaryBytecodeSetEncoderClass! Item was removed: - ----- Method: CompiledCode class>>scanBlocksForLiteral:do: (in category 'scanning') ----- - scanBlocksForLiteral: aLiteral do: aBinaryBlock - "Evaluate aBinaryBlock with the literal scanners for aLiteral (which will be nil - if there are no special bytecodes that access aLiteral), and answer its value." - ^aBinaryBlock - value: (PrimaryBytecodeSetEncoderClass scanBlockOrNilForLiteral: aLiteral) - value: (SecondaryBytecodeSetEncoderClass scanBlockOrNilForLiteral: aLiteral)! Item was removed: - ----- Method: CompiledCode class>>secondaryBytecodeSetEncoderClass (in category 'method encoding') ----- - secondaryBytecodeSetEncoderClass - ^SecondaryBytecodeSetEncoderClass! Item was removed: - ----- Method: CompiledCode class>>smallFrameSize (in category 'constants') ----- - smallFrameSize - - ^ SmallFrame! Item was removed: - ----- Method: CompiledCode class>>useSistaBytecodeSet: (in category 'method encoding') ----- - useSistaBytecodeSet: useSistaEncoder - "Switch to or from the Sista bytecode encoder, and recompile the system - using that encoder. Assumes that Compiler recompileAll is working for the - existing system. Assumes that the currently available primary and secondary - bytecode encoders are EncoderForV3PlusClosures and EncoderForSistaV1. - This is a convenience method that must be updated as the available encoders - are changed." - - "CompiledCode useSistaBytecodeSet: true" - "CompiledCode useSistaBytecodeSet: false" - - | standardEncoder sistaEncoder activeEncoder | - standardEncoder := Smalltalk classNamed: #EncoderForV3PlusClosures. - sistaEncoder := Smalltalk classNamed: #EncoderForSistaV1. - activeEncoder := self preferredBytecodeSetEncoderClass. - useSistaEncoder - ifTrue: [sistaEncoder ifNil: [self error: 'EncoderForSistaV1 not present in this image']. - self preferredBytecodeSetEncoderClass: sistaEncoder. - activeEncoder ~= sistaEncoder - ifTrue: [(Smalltalk classNamed: #Compiler) recompileAll. - self multipleBytecodeSetsActive: true "VM should support Sista plus V3" ]] - ifFalse: [standardEncoder ifNil: [self error: 'EncoderForV3PlusClosures not present in this image']. - self preferredBytecodeSetEncoderClass: standardEncoder. - activeEncoder ~= standardEncoder - ifTrue: [(Smalltalk classNamed: #Compiler) recompileAll. - self multipleBytecodeSetsActive: false "VM needs to support V3 only" ]]. - - ! Item was removed: - ----- Method: CompiledCode>>= (in category 'comparing') ----- - = aMethod - "Answer whether the receiver implements the same code as the argument, aMethod. - Here ``same code'' means that if the receiver's source is compiled with the same - compiler it should produce the same sequence of bytecodes and literals, same - trailer and same properties. Hence this definition of #= (only one of many plausible - definitions) can be used to quickly identify changes in the compiler's output." - self == aMethod ifTrue: - [^true]. - (aMethod isCompiledCode - and: [self size = aMethod size - and: [self header = aMethod header]]) ifFalse:"N.B. includes numLiterals comparison." - [^false]. - self initialPC to: self endPC do: - [:i | (self at: i) = (aMethod at: i) ifFalse: [^false]]. - ^self hasSameLiteralsAs: aMethod! Item was removed: - ----- Method: CompiledCode>>abstractBytecodeMessageAt: (in category 'scanning') ----- - abstractBytecodeMessageAt: pc - "Answer the abstract bytecode message at pc in the receiver." - ^[(InstructionStream new method: self pc: pc) interpretNextInstructionFor: ImplicitLiteralInstructionClientHook new] - on: MessageNotUnderstood - do: [:ex| ex message]! Item was removed: - ----- Method: CompiledCode>>abstractBytecodeMessagesAndPCs (in category 'scanning') ----- - abstractBytecodeMessagesAndPCs - "Answer the receiver's sequence of abstract bytecodes as a sequence of tuples of bytecode message and pc." - "(CompiledCode >> #abstractBytecodeMessagesAndPCs) abstractBytecodeMessagesAndPCs" - | msgs initial endpc pc scanner encoderClass implciitLiteralHook | - scanner := InstructionStream new method: self pc: (initial := self initialPC). - msgs := OrderedCollection new: (endpc := self endPC) - initial. - encoderClass := self encoderClass. - implciitLiteralHook := ImplicitLiteralInstructionClientHook new. - [(pc := scanner pc) <= endpc] whileTrue: - "i.e. nil will not understand any message and so the exception block will collect all of them." - [[encoderClass interpretNextInstructionFor: implciitLiteralHook in: scanner] - on: MessageNotUnderstood - do: [:ex| msgs addLast: { ex message. pc }]]. - ^msgs! Item was removed: - ----- Method: CompiledCode>>abstractBytecodeMessagesDo: (in category 'scanning') ----- - abstractBytecodeMessagesDo: aBlock - "Evaluate aBlock with the sequence of abstract bytecodes in the receiver" - self abstractBytecodeMessagesFrom: self initialPC - to: self endPC - do: aBlock - - "| msgs | - msgs := OrderedCollection new. - CompiledCode >> #abstractBytecodeMessagesFrom:to: abstractBytecodeMessagesDo: - [:msg| msgs addLast: msg selector]. - msgs"! Item was removed: - ----- Method: CompiledCode>>abstractBytecodeMessagesFrom:to:do: (in category 'scanning') ----- - abstractBytecodeMessagesFrom: startpc to: endpc do: aBlock - "Evaluate aBlock with the sequence of abstract bytecodes from startpc through endpc in the receiver" - | scanner encoderClass implciitLiteralHook | - scanner := InstructionStream new method: self pc: startpc. - encoderClass := self encoderClass. - implciitLiteralHook := ImplicitLiteralInstructionClientHook new. - [scanner pc <= endpc] whileTrue: - "i.e. nil will not understand any message and so the exception block will collect all of them." - [[encoderClass interpretNextInstructionFor: implciitLiteralHook in: scanner] - on: MessageNotUnderstood - do: [:ex| aBlock value: ex message]] - - "| m msgs | - msgs := OrderedCollection new. - (m := CompiledCode >> #abstractBytecodeMessagesFrom:to:do:) - abstractBytecodeMessagesFrom: m initialPC - to: m endPC - do: [:msg| msgs add: msg selector]. - msgs"! Item was removed: - ----- Method: CompiledCode>>allLiterals (in category 'literals') ----- - allLiterals - "Skip compiled-code objects. Keep literal arrays, bindings, etc." - - ^ Array streamContents: [:result | - self allLiteralsDo: [:literal | result nextPut: literal]]! Item was removed: - ----- Method: CompiledCode>>allLiteralsDo: (in category 'literals') ----- - allLiteralsDo: aBlock - "Enumerate all literals thoroughly. Follow nested instances of CompiledCode. Do not treat compiled code as literals here." - - self codeLiteralsDo: - [:compiledCode | - compiledCode literalsDo: - [:literal | - literal isCompiledCode ifFalse: - [literal allLiteralsDo: aBlock]]. - compiledCode implicitLiteralsDo: aBlock]! Item was removed: - ----- Method: CompiledCode>>asString (in category 'converting') ----- - asString - - ^self printString! Item was removed: - ----- Method: CompiledCode>>at:ifAbsent: (in category 'accessing') ----- - at: index ifAbsent: exceptionBlock - "Answer the element at my position index. If I do not contain an element - at index, answer the result of evaluating the argument, exceptionBlock." - - (index <= self size and: [self initialPC <= index]) ifTrue: [^self at: index]. - ^exceptionBlock value! Item was removed: - ----- Method: CompiledCode>>bytecodeSetName (in category 'accessing') ----- - bytecodeSetName - ^self encoderClass bytecodeSetName! Item was removed: - ----- Method: CompiledCode>>clearFlag (in category 'accessing') ----- - clearFlag - "Clear the user-level flag bit" - - self objectAt: 1 put: (self header bitAnd: (1 << 29) bitInvert)! Item was removed: - ----- Method: CompiledCode>>clearSignFlag (in category 'accessing') ----- - clearSignFlag - "Clear the sign flag bit. The sign flag bit may be - used by the VM to select an alternate bytecode set." - - self signFlag ifTrue: - [self objectAt: 1 put: self header - SmallInteger minVal]! Item was removed: - ----- Method: CompiledCode>>codeLiterals (in category 'literals') ----- - codeLiterals - - ^ Array streamContents: [:stream | - self codeLiteralsDo: [:compiledCode | stream nextPut: compiledCode]]! Item was removed: - ----- Method: CompiledCode>>codeLiteralsDo: (in category 'literals') ----- - codeLiteralsDo: aBlock - "Enumerate all literals that represent instances of CompiledCode. This is especially required for SistaV1." - - aBlock value: self. - - self literalsDo: [:literal | literal isCompiledCode ifTrue: [ - literal codeLiteralsDo: aBlock]].! Item was removed: - ----- Method: CompiledCode>>copyFrom: (in category 'copying') ----- - copyFrom: anotherObject - "Copy to myself all instance variables I have in common with anotherObject. - This is dangerous because it ignores an object's control over its own inst vars." - - <primitive: 168> - anotherObject isCompiledCode - ifTrue: - [1 to: self numLiterals do: - [:i| self literalAt: i put: (anotherObject literalAt: i)]] - ifFalse: - [1 to: self numLiterals do: - [:i| self literalAt: i put: (anotherObject at: i)]]. - self initialPC to: (self basicSize min: anotherObject basicSize) do: - [:i| - self basicAt: i put: (anotherObject basicAt: i)]! Item was removed: - ----- Method: CompiledCode>>decompile (in category 'decompiling') ----- - decompile - "Return the decompiled parse tree that represents self" - - | class selector | - class := self methodClass ifNil: [Object]. - selector := self selector ifNil: [self defaultSelector]. - ^class decompilerClass new decompile: selector in: class method: self methodForDecompile! Item was removed: - ----- Method: CompiledCode>>decompileWithTemps (in category 'decompiling') ----- - decompileWithTemps - "Answer the decompiled parse tree that represents self, but with the temp names obtained - either by compiling the source code, or directly if the method has temps in its trailer." - - ^self homeMethod decompileWithTemps! Item was removed: - ----- Method: CompiledCode>>encoderClass (in category 'accessing') ----- - encoderClass - "Answer the encoder class that encoded the bytecodes in this method. - The sign flag bit is used by the VM to select a bytecode set. This formulation - may seem odd but this has to be fast, so no property probe unless needed." - - ^self header >= 0 - ifTrue: - [PrimaryBytecodeSetEncoderClass] - ifFalse: - [PrimaryBytecodeSetEncoderClass == SecondaryBytecodeSetEncoderClass - ifTrue: "Support for testing prior to installing another set" - [(self propertyValueAt: #encoderClass) ifNil: [SecondaryBytecodeSetEncoderClass]] - ifFalse: - [SecondaryBytecodeSetEncoderClass]]! Item was removed: - ----- Method: CompiledCode>>endPC (in category 'accessing') ----- - endPC - "Answer the index of the last bytecode." - ^ self trailer endPC - ! Item was removed: - ----- Method: CompiledCode>>flag (in category 'accessing') ----- - flag - "Answer the user-level flag bit" - - ^((self header bitShift: -29) bitAnd: 1) = 1! Item was removed: - ----- Method: CompiledCode>>flushCache (in category 'cleaning') ----- - flushCache - "Tell the virtual machine to remove all references to this method from its method - lookup cache(s), if it has them. This is provided for backwards compatibility. - When a method is redefined (added to, removed from, or replaced in, a method - dictionary) then Symbol flushCache should be used. This is because adding or - removing a method may alter the method that a given selector should invoke - for methods other than the receiver. For example, if a subclass inherits a - method and this is overridden, flushing the new method will not flush the existing - method. - - If a method is modified in-place (for example, some bytecode is replaced by - bytecode that effects a breakpoint) then voidCogVMState should be used." - - <primitive: 116>! Item was removed: - ----- Method: CompiledCode>>frameSize (in category 'accessing') ----- - frameSize - "Answer the size of temporary frame needed to run the receiver." - "NOTE: Versions 2.7 and later use two sizes of contexts." - - (self header noMask: 16r20000) - ifTrue: [^ SmallFrame] - ifFalse: [^ LargeFrame] - ! Item was removed: - ----- Method: CompiledCode>>getSource (in category 'source code management') ----- - getSource - ^ self getSourceFor: self selector in:self methodClass.! Item was removed: - ----- Method: CompiledCode>>getSourceFor:in: (in category 'source code management') ----- - getSourceFor: selector in: class - "Retrieve or reconstruct the source code for this method." - - ^self method getSourceFor: selector in: class! Item was removed: - ----- Method: CompiledCode>>hasBreakpoint (in category '*Kernel-tool support') ----- - hasBreakpoint - ^ self class environment - at: #BreakpointManager - ifPresent: [:bpm | bpm methodHasBreakpoint: self] - ifAbsent: [false]! Item was removed: - ----- Method: CompiledCode>>hasLiteral: (in category 'literals') ----- - hasLiteral: aLiteral - "Overwrite this method to invoke the bytecode encoder scanner explicitly. This might be removed if there would be a way to enumerate special literals in a compiled-code object. See #allLiteralsDo:." - - ^ self - hasLiteral: aLiteral - scanForSpecial: (self encoderClass canBeSpecialLiteral: aLiteral)! Item was removed: - ----- Method: CompiledCode>>hasLiteral:scanForSpecial: (in category 'literals') ----- - hasLiteral: aLiteral scanForSpecial: aBoolean - "Like #hasLiteral: but can scan for encoder-specific special literals. Not that scanning has a noticeable performance impact." - - | scanBlock | - (super hasLiteral: aLiteral) ifTrue: [^ true]. - - aBoolean ifFalse: [^ false]. - - scanBlock := self class - scanBlocksForLiteral: aLiteral - do: [:primaryScanner :secondaryScanner | - "E.g., scanner for SistaV1 or scanner for V3PlusClosures" - self signFlag ifTrue: [secondaryScanner] ifFalse: [primaryScanner]]. - - self codeLiteralsDo: [:compiledCode | - (compiledCode scanFor: scanBlock) ifTrue: [^ true]]. - - ^ false! Item was removed: - ----- Method: CompiledCode>>hasMethodReturn (in category 'testing') ----- - hasMethodReturn - "Answer whether the receiver has a method-return ('^') in its code." - - | scanner | - self codeLiteralsDo: [:compiledCode | - scanner := InstructionStream on: compiledCode. - (scanner scanFor: [:x | (scanner willReturn - and: [scanner willBlockReturn not]) - "and: [scanner willReturnTopFromMethod not]" "-> Not supported in EncoderForSistaV1"]) - ifTrue: [^ true]]. - ^ false! Item was removed: - ----- Method: CompiledCode>>hasNoCountersFlag (in category 'accessing') ----- - hasNoCountersFlag - "The Cog Sista VMs interpret bit 16 of the method header as suppressing the generation of performance counters." - ^self header anyMask: 16r8000! Item was removed: - ----- Method: CompiledCode>>hasSameLiteralsAs: (in category 'comparing') ----- - hasSameLiteralsAs: aMethod - "Answer whether the receiver has the same sequence of literals as the argument." - self subclassResponsibility! Item was removed: - ----- Method: CompiledCode>>hash (in category 'comparing') ----- - hash - "CompiledCode>>#= compares code, i.e. same literals and same bytecode. - So we look at the size, the header and some bytes between initialPC and endPC, - but neither selector nor methodClass because the #= does not either.. - Note that we must override ByteArray>>#hash which looks at all bytes of the receiver. - Using bytes from the pointer part of a CompiledCode can lead to a variable hash - if and when when the GC moves literals in the receiver." - - | initialPC endPC hash | - initialPC := self initialPC. - endPC := self endPC. - hash := (((self size hashMultiply + self header) hashMultiply + initialPC) hashMultiply + endPC) hashMultiply. - "sample approximately 20 bytes" - initialPC to: endPC by: (endPC - initialPC // 20 max: 1) do: - [:i| hash := (hash + (self at: i)) hashMultiply]. - ^hash - - "(CompiledCode>>#hash) hash"! Item was removed: - ----- Method: CompiledCode>>header (in category 'literals') ----- - header - "Answer the word containing the information about the form of the - receiver and the form of the context needed to run the receiver. - - sign:1 29-28:accessModifier 27-24:numArgs 23-18:numTemps 17:largeFrameFlag 16:hasPrimitive 15:isOptimized 14-0:numLits" - - ^self objectAt: 1! Item was removed: - ----- Method: CompiledCode>>headerDescription (in category 'printing') ----- - headerDescription - "Answer a description containing the information about the form of the - receiver and the form of the context needed to run the receiver." - - self subclassResponsibility! Item was removed: - ----- Method: CompiledCode>>homeMethod (in category 'accessing') ----- - homeMethod - "Answer the home method associated with the receiver." - - ^self subclassResponsibility! Item was removed: - ----- Method: CompiledCode>>implicitLiteralsDo: (in category 'literals') ----- - implicitLiteralsDo: aBlock - "Enumerate the implicit literals in bytecodes of the receiver." - - | stream client encoderClass endPC | - "Enumerate special selectors & special literals such as true and false." - stream := InstructionStream on: self. - encoderClass := self encoderClass. - "cache endPC for methods with embedded source; finding out the endPC is very slow in this case..." - endPC := self endPC. - client := ImplicitLiteralFinder new. - [stream pc <= endPC] whileTrue: - [| literalOrClient | - literalOrClient := encoderClass interpretNextInstructionFor: client in: stream. - literalOrClient ~~ client ifTrue: - [aBlock value: literalOrClient]]! Item was removed: - ----- Method: CompiledCode>>indexOfLiteral: (in category 'literals') ----- - indexOfLiteral: literal - "Answer the literal index of the argument, literal, or zero if none." - 2 to: self numLiterals - 1 "exclude selector/properties + methodClass" - do: - [:index | - literal == (self objectAt: index) ifTrue: [^index - 1]]. - ^0! Item was removed: - ----- Method: CompiledCode>>initialPC (in category 'accessing') ----- - initialPC - "Answer the program counter for the receiver's first bytecode." - - ^ (self numLiterals + 1) * Smalltalk wordSize + 1 - ! Item was removed: - ----- Method: CompiledCode>>isCompiledBlock (in category 'testing') ----- - isCompiledBlock - ^false! Item was removed: - ----- Method: CompiledCode>>isCompiledCode (in category 'testing') ----- - isCompiledCode - ^true! Item was removed: - ----- Method: CompiledCode>>isCompiledMethod (in category 'testing') ----- - isCompiledMethod - ^false! Item was removed: - ----- Method: CompiledCode>>isQuick (in category 'testing') ----- - isQuick - - self subclassResponsibility.! Item was removed: - ----- Method: CompiledCode>>literalAt: (in category 'literals') ----- - literalAt: index - "Answer the literal indexed by the argument." - - ^self objectAt: index + 1! Item was removed: - ----- Method: CompiledCode>>literalAt:put: (in category 'literals') ----- - literalAt: index put: value - "Replace the literal indexed by the first argument with the second - argument. Answer the second argument." - - ^self objectAt: index + 1 put: value! Item was removed: - ----- Method: CompiledCode>>literals (in category 'literals') ----- - literals - - ^ Array streamContents: [:result | - self literalsDo: [:lit | result nextPut: lit]]! Item was removed: - ----- Method: CompiledCode>>literalsDo: (in category 'literals') ----- - literalsDo: aBlock - "Evaluate aBlock for each of the literals referenced by the receiver. Note that this (raw) enumeration addresses *all* objects stored *after* the method header and *before* the first byte code. If you require a deep and meaningful enumeration of literals use #allLiteralsDo: or #codeLiteralsDo:." - - 1 to: self numLiterals do: [:index | - aBlock value: (self literalAt: index)].! Item was removed: - ----- Method: CompiledCode>>longPrintOn: (in category 'printing') ----- - longPrintOn: aStream - "List of all the byte codes in a method with a short description of each" - - self longPrintOn: aStream indent: 0! Item was removed: - ----- Method: CompiledCode>>messages (in category 'scanning') ----- - messages - "Answer a Set of all the message selectors sent by this method." - - | result | - result := Set new. - self selectorsDo: [:selector | result add: selector]. - ^ result! Item was removed: - ----- Method: CompiledCode>>messagesSequence (in category 'scanning') ----- - messagesSequence - "Answer a sequence of all the message selectors sent by this method in the order they are sent. Unlike #messages this may include duplicates. Note that both the sources and the decompiled sources might suggest different results. The returned information reflect the actual bytecode." - - ^ Array streamContents: [:result | - self selectorsDo: [:selector | result nextPut: selector]]! Item was removed: - ----- Method: CompiledCode>>method (in category 'accessing') ----- - method - "Answer the home method associated with the receiver." - - ^self subclassResponsibility! Item was removed: - ----- Method: CompiledCode>>methodClass (in category 'accessing') ----- - methodClass - "Answer the class that I am installed in." - ^self subclassResponsibility! Item was removed: - ----- Method: CompiledCode>>needsFrameSize: (in category 'initialize-release') ----- - needsFrameSize: newFrameSize - "Set the largeFrameBit to accomodate the newFrameSize" - | largeFrameBit header | - largeFrameBit := 16r20000. - (self numTemps + newFrameSize) > LargeFrame ifTrue: - [^ self error: 'Cannot compile -- stack including temps is too deep']. - header := self objectAt: 1. - (header bitAnd: largeFrameBit) ~= 0 - ifTrue: [header := header - largeFrameBit]. - self objectAt: 1 put: header - + ((self numTemps + newFrameSize) > SmallFrame - ifTrue: [largeFrameBit] - ifFalse: [0])! Item was removed: - ----- Method: CompiledCode>>numArgs (in category 'accessing') ----- - numArgs - "Answer the number of arguments the receiver takes." - - ^ (self header bitShift: -24) bitAnd: 16r0F! Item was removed: - ----- Method: CompiledCode>>numLiterals (in category 'accessing') ----- - numLiterals - "Answer the number of literals used by the receiver." - ^self header bitAnd: 16r7FFF! Item was removed: - ----- Method: CompiledCode>>numTemps (in category 'accessing') ----- - numTemps - "Answer the number of temporary variables used by the receiver." - - ^ (self header bitShift: -18) bitAnd: 16r3F! Item was removed: - ----- Method: CompiledCode>>objectAt: (in category 'literals') ----- - objectAt: index - "Primitive. Answer the method header (if index=1) or a literal (if index - >1) from the receiver. Essential. See Object documentation - whatIsAPrimitive." - - <primitive: 68> - self primitiveFailed! Item was removed: - ----- Method: CompiledCode>>objectAt:put: (in category 'literals') ----- - objectAt: index put: value - "Primitive. Store the value argument into a literal in the receiver. An - index of 2 corresponds to the first literal. Fails if the index is less than 2 - or greater than the number of literals. Answer the value as the result. - Normally only the compiler sends this message, because only the - compiler stores values in CompiledMethods. Essential. See Object - documentation whatIsAPrimitive." - - <primitive: 69> - self primitiveFailed! Item was removed: - ----- Method: CompiledCode>>outboundPointersDo: (in category 'tracing') ----- - outboundPointersDo: aBlock - - | numLiterals | - aBlock value: self class. - numLiterals := self numLiterals. - 1 to: numLiterals do: [:i | aBlock value: (self literalAt: i)]! Item was removed: - ----- Method: CompiledCode>>pcPreviousTo: (in category 'scanning') ----- - pcPreviousTo: thePC - "Answer the pc of the bytecode before the bytecode at thePC." - | pc prevPc byte encoderClass | - thePC > self endPC ifTrue: [^self endPC]. - pc := self initialPC. - encoderClass := self encoderClass. - [pc < thePC] whileTrue: - [byte := self at: (prevPc := pc). - [pc := pc + (encoderClass bytecodeSize: byte). - encoderClass isExtension: byte] whileTrue: - [byte := self at: pc]]. - ^prevPc! Item was removed: - ----- Method: CompiledCode>>printOn: (in category 'printing') ----- - printOn: aStream - "Overrides method inherited from the byte arrayed collection." - aStream nextPut: $(. - self printReferenceOn: aStream. - aStream space; nextPut: $". - self printNameOn: aStream. - aStream nextPut: $(; - print: self identityHash; - nextPut: $); - nextPut: $"; - nextPut: $)! Item was removed: - ----- Method: CompiledCode>>printReferenceOn: (in category 'printing') ----- - printReferenceOn: aStream - "Print a string that can be used to access the currently installed method." - aStream print: self methodClass; - nextPutAll: '>>'; - nextPutAll: self selector storeString! Item was removed: - ----- Method: CompiledCode>>protocol (in category 'accessing') ----- - protocol - ^self methodClass ifNotNil: - [:class| - self selector ifNotNil: - [:selector| - class whichCategoryIncludesSelector: selector]]! Item was removed: - ----- Method: CompiledCode>>readDataFrom:size: (in category 'file in/out') ----- - readDataFrom: aDataStream size: varsOnDisk - "Fill in my fields. My header and number of literals are already installed. Must read both objects for the literals and bytes for the bytecodes." - - self error: 'Must use readMethod'.! Item was removed: - ----- Method: CompiledCode>>reference (in category 'printing') ----- - reference - ^ String streamContents: [ : stream | self printReferenceOn: stream ]! Item was removed: - ----- Method: CompiledCode>>referredInstVars (in category 'accessing') ----- - referredInstVars - "Answer a Set of the inst var names the receiver accesses." - | allInstVarNames instVarNames | - allInstVarNames := self methodClass allInstVarNames. - self isReturnField ifTrue: - [^Set with: (allInstVarNames at: self returnField + 1)]. - instVarNames := Set new. - self abstractBytecodeMessagesDo: - [:msg| - (#(#popIntoReceiverVariable: - #pushReceiverVariable: - #storeIntoReceiverVariable:) includes: msg selector) ifTrue: - [instVarNames add: (allInstVarNames at: msg argument + 1)]]. - ^instVarNames - - "Dictionary newFromPairs: (Point selectors collect: [:s| { s. (Point >> s) referredInstVars}])"! Item was removed: - ----- Method: CompiledCode>>scanFor: (in category 'scanning') ----- - scanFor: byteOrClosure - "Answer whether the receiver contains the argument as a bytecode, if it is a number, - or evaluates to true if a block. If a block it can take from one to four bytes." - | s end | - ^(s := InstructionStream on: self) - scanFor: (byteOrClosure isBlock - ifTrue: [byteOrClosure numArgs caseOf: { - [1] -> [byteOrClosure]. - [2] -> [[:byte| byteOrClosure value: byte value: s secondByte]]. - [3] -> [end := self endPC - 2. - [:byte| - s pc <= end - and: [byteOrClosure - value: byte - value: s secondByte - value: s thirdByte]]]. - [4] -> [end := self endPC - 3. - [:byte| - s pc <= end - and: [byteOrClosure - value: byte - value: s secondByte - value: s thirdByte - value: s fourthByte]]] }] - ifFalse: [[:instr | instr = byteOrClosure]]) - " - SystemNavigation default browseAllSelect: [:m | m scanFor: 134] - "! Item was removed: - ----- Method: CompiledCode>>scanner (in category 'accessing') ----- - scanner - - ^ InstructionStream on: self! Item was removed: - ----- Method: CompiledCode>>selector (in category 'accessing') ----- - selector - ^self subclassResponsibility! Item was removed: - ----- Method: CompiledCode>>selectorsDo: (in category 'scanning') ----- - selectorsDo: workBlock - "Evaluate aBlock with all the message selectors sent by me. Duplicate selectors are possible." - - | encoderClass | - self isQuick ifTrue: [^self]. - encoderClass := self encoderClass. - self codeLiteralsDo: - [:compiledCode | | scanner limit | - limit := compiledCode size - 1. - (scanner := InstructionStream on: compiledCode) scanFor: - [:byte| | selector | - (selector := scanner selectorToSendOrSelf) ~~ scanner ifTrue: - [workBlock value: selector]. - ((encoderClass isExtension: byte) - and: [scanner pc < limit]) ifTrue: - [scanner pc: scanner pc + (encoderClass bytecodeSize: (compiledCode at: scanner pc + 2))]. - false "keep scanning"]]! Item was removed: - ----- Method: CompiledCode>>sendsSelector: (in category 'testing') ----- - sendsSelector: aSelector - "Answer if the receiver sends a message whose selector is aSelector." - - self selectorsDo: - [:selector | selector = aSelector ifTrue: [^true]]. - self flag: #todo. "The use of #= instead of #== is extremely dubious, and IMO erroneous. eem 2/18/2020" - ^false! Item was removed: - ----- Method: CompiledCode>>sendsToSuper (in category 'testing') ----- - sendsToSuper - "Answer whether the receiver sends any message to super." - - | scanner | - self codeLiteralsDo: [:compiledCode | - scanner := InstructionStream on: compiledCode. - (scanner scanFor: (self encoderClass superSendScanBlockUsing: scanner)) - ifTrue: [^ true]]. - ^ false! Item was removed: - ----- Method: CompiledCode>>setHasNoCountersFlag (in category 'accessing') ----- - setHasNoCountersFlag - "The Cog Sista VMs interpret bit 16 of the method header as suppressing the generation of performance counters." - self objectAt: 1 put: (self header bitOr: 16r8000)! Item was removed: - ----- Method: CompiledCode>>setSignFlag (in category 'accessing') ----- - setSignFlag - "Set the sign flag bit. The sign flag bit may be - used by the VM to select an alternate bytecode set." - - self signFlag ifFalse: - [self objectAt: 1 put: self header + SmallInteger minVal]! Item was removed: - ----- Method: CompiledCode>>signFlag (in category 'accessing') ----- - signFlag - "Answer the sign flag bit. The sign flag bit may be - used by the VM to select an alternate bytecode set." - - ^self header < 0! Item was removed: - ----- Method: CompiledCode>>storeDataOn: (in category 'file in/out') ----- - storeDataOn: aDataStream - "Store myself on a DataStream. I am a mixture of objects and raw data bytes. Only use this for blocks. Normal methodDictionaries should not be put out using ReferenceStreams. Their fileOut should be attached to the beginning of the file." - - | byteLength lits | - "No inst vars of the normal type" - byteLength := self basicSize. - aDataStream - beginInstance: self class - size: byteLength. - lits := self numLiterals + 1. "counting header" - 1 to: lits do: - [:ii | aDataStream nextPut: (self objectAt: ii)]. - self initialPC to: byteLength do: - [:ii | aDataStream byteStream nextPut: (self basicAt: ii)]. - "write bytes straight through to the file"! Item was removed: - ----- Method: CompiledCode>>storeOn: (in category 'printing') ----- - storeOn: aStream - | noneYet | - aStream nextPutAll: '(('. - aStream nextPutAll: self class name. - aStream nextPutAll: ' newMethod: '. - aStream store: self size - self initialPC + 1. - aStream nextPutAll: ' header: '. - aStream store: self header. - aStream nextPut: $). - noneYet := self storeElementsFrom: self initialPC to: self endPC on: aStream. - 1 to: self numLiterals do: - [:index | - noneYet - ifTrue: [noneYet := false] - ifFalse: [aStream nextPut: $;]. - aStream nextPutAll: ' literalAt: '. - aStream store: index. - aStream nextPutAll: ' put: '. - aStream store: (self literalAt: index)]. - noneYet ifFalse: [aStream nextPutAll: '; yourself']. - aStream nextPut: $)! Item was removed: - ----- Method: CompiledCode>>symbolic (in category 'printing') ----- - symbolic - "Answer a String that contains a list of all the byte codes in a method - with a short description of each." - - | aStream | - aStream := WriteStream on: (String new: 1000). - self longPrintOn: aStream. - ^aStream contents! Item was removed: - ----- Method: CompiledCode>>symbolicLinesDo: (in category 'printing') ----- - symbolicLinesDo: aBlock - "Evaluate aBlock with each of the lines in the symbolic output." - - | aStream pc | - aStream := (String new: 64) writeStream. - self isQuick ifTrue: - [self longPrintOn: aStream. - aBlock value: 0 value: aStream contents. - ^self]. - - self primitive ~= 0 ifTrue: - [self printPrimitiveOn: aStream. - aBlock value: 1 value: aStream contents. - aStream resetContents]. - - pc := self initialPC. - (InstructionPrinter on: self) - indent: 0; - printPC: false; "explorer provides pc anyway" - printInstructionsOn: aStream - do: [:printer :scanner :stream| | line index | - line := stream contents allButLast. - (line includes: Character cr) ifTrue: - [line := (line copyUpTo: Character cr), '...'' (continues)']. - (index := line indexOf: $>) > 0 ifTrue: - [[(line at: index + 1) isSeparator] whileTrue: [index := index + 1]. - line := ((line copyFrom: 1 to: index) copyReplaceAll: (String with: Character tab) with: (String new: 8 withAll: Character space)), - (line copyFrom: index + 1 to: line size)]. - aBlock value: pc value: line. - pc := scanner pc. - stream resetContents]! Item was removed: - ----- Method: CompiledCode>>trailer (in category 'accessing') ----- - trailer - "Answer the receiver's trailer" - ^ CompiledMethodTrailer new method: self - ! Item was removed: - ----- Method: CompiledCode>>veryDeepCopyWith: (in category 'file in/out') ----- - veryDeepCopyWith: deepCopier - "Return self. I am always shared. Do not record me. Only use this for blocks. Normally methodDictionaries should not be copied this way."! Item was removed: - ----- Method: CompiledCode>>voidCogVMState (in category 'cleaning') ----- - voidCogVMState - "Tell the VM to remove all references to any machine code form of the method. - This primitive must be called whenever a method is in use and modified. This is - more aggressive (and *much* more costly) than flushCache since it must search - through all context objects, making sure that none have a (hidden) machine code pc - in the receiver. Since modifying a method will likely change the generated machine code, - modifying a method (rather than redefining it) requires this more aggressive flush." - - <primitive: 215> - ^self flushCache! Item was removed: - CompiledCode variableByteSubclass: #CompiledMethod - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Kernel-Methods'! - - !CompiledMethod commentStamp: 'eem 2/27/2018 12:48' prior: 0! - CompiledMethod instances are methods suitable for interpretation by the virtual machine. They are a specialization of CompiledCode. They represent methods, and may also, depending on the bytecode set, include nested blocks. Bytecode sets that support non-nested blocks use CompiledBlock instances to implement nested block methods, that are separate from their enclosing method. Bytecode sets that do not support non-nested blocks require the literals and bytecodes for a block to occur within the literals and bytecodes of a single CompiledMethod. For example, the inject:into: method in the EncoderForV3PlusClosures bytecode set is as follows - - Collection>>#inject:into: - header ((primitive: 0) (numArgs: 2) (numTemps: 3) (numLiterals: 3) (frameSize: 16) (bytecodeSet: V3PlusClosures)) - literal1 #value:value: - literal2 #inject:into: - literal3 #Collection=>Collection - 33 <8A 01> push: (Array new: 1) - 35 <6A> popIntoTemp: 2 - 36 <10> pushTemp: 0 - 37 <8E 00 02> popIntoTemp: 0 inVectorAt: 2 - 40 <70> self - 41 <11> pushTemp: 1 - 42 <12> pushTemp: 2 - 43 <8F 21 00 0A> closureNumCopied: 2 numArgs: 1 bytes 47 to 56 - 47 <11> pushTemp: 1 - 48 <8C 00 02> pushTemp: 0 inVectorAt: 2 - 51 <10> pushTemp: 0 - 52 <F0> send: value:value: - 53 <8D 00 02> storeIntoTemp: 0 inVectorAt: 2 - 56 <7D> blockReturn - 57 <CB> send: do: - 58 <87> pop - 59 <8C 00 02> pushTemp: 0 inVectorAt: 2 - 62 <7C> returnTop - - whereas using the encoderForSistaV1 bytecode set it is - - Collection>>#inject:into: - header ((primitive: 0) (numArgs: 2) (numTemps: 3) (numLiterals: 3) (frameSize: 16) (bytecodeSet: #SistaV1)) - literal1 ([] in Collection>>#inject:into: "a CompiledBlock(3755867)") - literal2 #inject:into: - literal3 #Collection=>Collection - 33 <E7 01> push: (Array new: 1) - 35 <D2> popIntoTemp: 2 - 36 <40> pushTemp: 0 - 37 <FD 00 02> popIntoTemp: 0 inVectorAt: 2 - 40 <4C> self - 41 <41> pushTemp: 1 - 42 <42> pushTemp: 2 - 43 <F9 00 02> closureNumCopied: 2 numArgs: 1 - 46 <7B> send: do: - 47 <D8> pop - 48 <FB 00 02> pushTemp: 0 inVectorAt: 2 - 51 <5C> returnTop - - [] in Collection>>#inject:into: "a CompiledBlock(3755867)" - header ((block #full) (numArgs: 1) (numTemps: 3) (numLiterals: 3) (frameSize: 16) (bytecodeSet: #SistaV1)) - literal1 #value:value: - literal2 nil - literal3 (Collection>>#inject:into: "a CompiledMethod(736427)") - 33 <41> pushTemp: 1 - 34 <FB 00 02> pushTemp: 0 inVectorAt: 2 - 37 <40> pushTemp: 0 - 38 <A0> send: value:value: - 39 <FC 00 02> storeIntoTemp: 0 inVectorAt: 2 - 42 <5E> blockReturn - - 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 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 the method's selector and any pragmas and properties of the method. AdditionalMethodState 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. Enterprising programmers are encouraged to try and implement this support automatically through suitable modifications to the compiler and class builder.! Item was removed: - ----- Method: CompiledMethod class>>abstractMarkers (in category 'constants') ----- - abstractMarkers - ^ #(subclassResponsibility shouldNotImplement)! Item was removed: - ----- Method: CompiledMethod class>>addCompiledCodeAndCompiledBlock (in category 'full block bootstrap') ----- - addCompiledCodeAndCompiledBlock - | cmHash cmInstCount cc | - "Ensure that - - CompiledMethod is a subclass of CompiledCode - - CompiledMethod has a sibling called CompiledBlock, - - CompiledMethod's class vars are moved to CompiledCode - - CompiledMethod preserves its identityHash and instances" - self compiledCodeAndCompiledBlockArePresent ifTrue: - [^self]. - cmHash := CompiledMethod identityHash. - cmInstCount := CompiledMethod instanceCount. - cc := CompiledMethod variableByteSubclass: #CompiledCode - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Kernel-Methods'. - self assert: cc == (ByteArray variableByteSubclass: #CompiledCode - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Kernel-Methods'). - self assert: cc typeOfClass == #compiledMethod. - cc ensureClassPool. - CompiledMethod classPool keys do: - [:classVar| - cc classPool declare: classVar from: CompiledMethod classPool]. - self assert: CompiledMethod classPool isEmpty. - CompiledMethod superclass: cc. - CompiledMethod class superclass: cc class. - cc addSubclass: CompiledMethod. - self assert: cmHash = CompiledMethod identityHash. - self assert: cmInstCount = CompiledMethod instanceCount. - self assert: (CompiledMethod inheritsFrom: cc). - self assert: (CompiledMethod class inheritsFrom: cc class). - cc variableByteSubclass: #CompiledBlock - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Kernel-Methods'. - self assert: self compiledCodeAndCompiledBlockArePresent! Item was removed: - ----- Method: CompiledMethod class>>compiledCodeAndCompiledBlockArePresent (in category 'full block bootstrap') ----- - compiledCodeAndCompiledBlockArePresent - ^((Smalltalk classNamed: #CompiledCode) notNil - and: [((Smalltalk classNamed: #CompiledCode) subclasses collect: [:ea| ea name]) - = #(CompiledMethod CompiledBlock)])! Item was removed: - ----- Method: CompiledMethod class>>disabledMarker (in category 'constants') ----- - disabledMarker - ^ #shouldNotImplement! Item was removed: - ----- Method: CompiledMethod class>>methodPropertiesClass (in category 'accessing class hierarchy') ----- - methodPropertiesClass - "Answer the class to use to create a method's properties, which can be a poor man's way - to add instance variables to subclassses of CompiledMethod. Subclasses of CompiledMethod - should define a corresponding subclass of AdditionalMethodState that adds any instance variables - required, and override this method to answer that class." - ^AdditionalMethodState! Item was removed: - ----- Method: CompiledMethod class>>primitive:numArgs:numTemps:stackSize:literals:bytecodes:trailer: (in category 'instance creation') ----- - primitive: primNum numArgs: numArgs numTemps: numTemps stackSize: stackSize literals: literals bytecodes: bytecodes trailer: trailerBytes - "Create method with given attributes. numTemps includes numArgs. stackSize does not include numTemps." - - | compiledMethod | - compiledMethod := self - newBytes: bytecodes size - trailerBytes: trailerBytes - nArgs: numArgs - nTemps: numTemps - nStack: stackSize - nLits: literals size - primitive: primNum. - (WriteStream with: compiledMethod) - position: compiledMethod initialPC - 1; - nextPutAll: bytecodes. - literals withIndexDo: [:obj :i | compiledMethod literalAt: i put: obj]. - ^ compiledMethod! Item was removed: - ----- Method: CompiledMethod class>>receiver:withArguments:executeMethod: (in category 'evaluating') ----- - receiver: receiver withArguments: argArray executeMethod: compiledMethod - "Execute compiledMethod against the receiver and the arguments in argArray" - - <primitive: 188 error: ec> - self primitiveFailed! Item was removed: - ----- Method: CompiledMethod class>>subclassResponsibilityMarker (in category 'constants') ----- - subclassResponsibilityMarker - ^ #subclassResponsibility! Item was removed: - ----- 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! Item was removed: - ----- 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! Item was removed: - ----- Method: CompiledMethod class>>toReturnSelf (in category 'instance creation') ----- - toReturnSelf - "Answer an instance of me that is a quick return of the instance (^self)." - - ^ self toReturnSelfTrailerBytes: CompiledMethodTrailer empty! Item was removed: - ----- 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! Item was removed: - ----- Method: CompiledMethod>>abstractSymbolic (in category 'printing') ----- - abstractSymbolic - "Answer a String that contains a list of all the byte codes in a method with a - short description of each, using relative addresses and not including code bytes." - - | aStream | - aStream := WriteStream on: (String new: 1000). - self longPrintRelativeOn: aStream indent: 0. - ^aStream contents! Item was removed: - ----- Method: CompiledMethod>>allLiteralsDo: (in category 'literals') ----- - allLiteralsDo: aBlock - "Overwritten to skip certain (raw) literals." - - " Exclude method selector (or properties) and the method's class." - 1 to: self numLiterals - 2 do: [:index | - (self literalAt: index) allLiteralsDo: aBlock]. - - "Enumerate the implicit literals in bytecodes of the receiver." - self implicitLiteralsDo: aBlock. - - "Enumerate method selector only through additional method state." - self penultimateLiteral isMethodProperties - ifTrue: [self penultimateLiteral allLiteralsDo: aBlock]! Item was removed: - ----- Method: CompiledMethod>>anyAndAllMessages (in category 'literals') ----- - anyAndAllMessages - "Answer a Set of all the message selectors sent by this method, and all literals that look like message selectors." - - | result | - result := Set new. - self anyAndAllSelectorsDo: [:selector | result add: selector]. - ^result! Item was removed: - ----- Method: CompiledMethod>>anyAndAllSelectorsDo: (in category 'literals') ----- - anyAndAllSelectorsDo: workBlock - "Evaluate aBlock with all the message selectors sent by me, including - my literals that look like selectors, and selectors in my pragmas. - Duplicate selectors are possible." - - | encoderClass selectorLiteralCollector | - encoderClass := self encoderClass. - selectorLiteralCollector := [:literal| - literal isCollection ifTrue: - [literal isSymbol - ifTrue: - [literal isMessageSelector ifTrue: - [workBlock value: literal]] - ifFalse: - [literal isArray ifTrue: - [literal do: selectorLiteralCollector]]]]. - self pragmas do: - [:pragma| - selectorLiteralCollector - value: pragma keyword; - value: pragma arguments]. - self isQuick ifTrue: [^self]. - self codeLiteralsDo: - [:compiledCode | | scanner limit | - limit := compiledCode size - 1. - (scanner := InstructionStream on: compiledCode) scanFor: - [:byte| | selector | - (selector := scanner selectorToSendOrSelf) ~~ scanner ifTrue: - [workBlock value: selector]. - ((encoderClass isExtension: byte) - and: [scanner pc < limit]) ifTrue: - [scanner pc: scanner pc + (encoderClass bytecodeSize: (compiledCode at: scanner pc + 2))]. - false "keep scanning"]. - compiledCode literalsDo: selectorLiteralCollector]! Item was removed: - ----- Method: CompiledMethod>>checkOKToAdd:at: (in category 'source code management') ----- - checkOKToAdd: size at: filePosition - "Issue several warnings if the end of the changes file is approaching - a fixed size limit, and finally halt with an error if the limit is reached." - - ^ SourceFiles checkOKToAdd: size at: filePosition - ! Item was removed: - ----- Method: CompiledMethod>>compilerClass (in category 'decompiling') ----- - compilerClass - ^self methodClass - ifNil: [Compiler] - ifNotNil: [:class | class compilerClass].! Item was removed: - ----- Method: CompiledMethod>>containsBlockClosures (in category 'closures') ----- - containsBlockClosures - ^self scanner scanFor: self encoderClass createClosureScanBlock! Item was removed: - ----- Method: CompiledMethod>>copyWithSourceCode: (in category 'source code management') ----- - copyWithSourceCode: sourceCode - "Create a copy of the receiver whose source is embedded in the method. Used for breakpoints." - ^self copyWithTrailerBytes: (CompiledMethodTrailer new sourceCode: sourceCode)! Item was removed: - ----- Method: CompiledMethod>>copyWithTempNames: (in category 'source code management') ----- - copyWithTempNames: tempNames - "Minimal temp name copy that only works for methods containing no temporaries or blocks with arguments. - Used by the Traits system for creating conflict and required methdos that generate warnings. - For generic use use copyWithTempsFromMethodNode:" - | tempString | - tempString := String streamContents: - [:str| - tempNames - do: [:temp| str nextPutAll: temp] - separatedBy: [str space]. - str space]. - ^self copyWithTrailerBytes: (CompiledMethodTrailer new tempNames: tempString) - ! Item was removed: - ----- Method: CompiledMethod>>copyWithTempsFromMethodNode: (in category 'source code management') ----- - copyWithTempsFromMethodNode: aMethodNode - ^self copyWithTrailerBytes: ( - CompiledMethodTrailer new tempNames: aMethodNode schematicTempNamesString)! Item was removed: - ----- Method: CompiledMethod>>copyWithTrailerBytes: (in category 'copying') ----- - copyWithTrailerBytes: trailer - "Testing: - CompiledMethod >> #copyWithTrailerBytes: - copyWithTempsFromMethodNode: (CompiledMethod >> #copyWithTrailerBytes:) methodNode" - | copy end start | - start := self initialPC. - end := self endPC. - copy := trailer createMethod: end - start + 1 class: self class header: self header. - 1 to: self numLiterals do: - [:i | | lit | - lit := self literalAt: i. - copy literalAt: i put: ((lit isCompiledCode and: [lit isCompiledBlock]) - ifTrue: [lit copyWithOuterCode: copy] - ifFalse: [lit])]. - start to: end do: [:i | copy at: i put: (self at: i)]. - copy postCopy. - ^copy! Item was removed: - ----- Method: CompiledMethod>>dateMethodLastSubmitted (in category 'printing') ----- - dateMethodLastSubmitted - "Answer a Date object indicating when a method was last submitted. If there is no date stamp, return nil" - "(CompiledMethod compiledMethodAt: #dateMethodLastSubmitted) dateMethodLastSubmitted" - - | aStamp tokens | - aStamp := self timeStamp. - tokens := aStamp findBetweenSubStrs: ' - '. "space is expected delimiter, but cr is sometimes seen, though of mysterious provenance" - ^ tokens size > 1 - ifTrue: - [[tokens second asDate] ifError: [nil]] - ifFalse: - [nil]! Item was removed: - ----- Method: CompiledMethod>>decompileString (in category 'printing') ----- - decompileString - ^self decompile decompileString! Item was removed: - ----- Method: CompiledMethod>>decompileWithTemps (in category 'decompiling') ----- - decompileWithTemps - "Return the decompiled parse tree that represents self, but with the temp names obtained - either by compiling the sourcecode, or directly if the method has temps in its trailer." - - | class selector tempNames source | - class := self methodClass ifNil: [Object]. - selector := self selector ifNil: [self defaultSelector]. - - self holdsTempNames - ifTrue: [tempNames := self tempNamesString] - ifFalse: - [| compiler | - "No source file or no source (e.g. doits) and no temp names - -- decompile without temp names " - ((self fileIndex > 0 and: [(SourceFiles at: self fileIndex) isNil]) - or: [(source := self getSourceFromFile) isNil]) ifTrue: - [^self decompile]. - compiler := class newCompiler. - compiler parser encoderClass: self encoderClass. - tempNames := [(compiler - parse: source asString - in: class - notifying: nil) - generate: CompiledMethodTrailer empty; - schematicTempNamesString] on: SyntaxErrorNotification do: [:ex | nil]. - tempNames ifNil: ["broken source, give up tempNames" ^self decompile]]. - - ^(self decompilerClass new withTempNames: tempNames) - decompile: selector - in: class - method: self methodForDecompile! Item was removed: - ----- Method: CompiledMethod>>decompilerClass (in category 'decompiling') ----- - decompilerClass - ^self compilerClass decompilerClass! Item was removed: - ----- Method: CompiledMethod>>defaultSelector (in category 'accessing') ----- - defaultSelector - "Invent and answer an appropriate message selector (a Symbol) for me, - that is, one that will parse with the correct number of arguments." - - ^#DoIt numArgs: self numArgs! Item was removed: - ----- Method: CompiledMethod>>dragLabel (in category 'accessing') ----- - dragLabel - "The label we use for dragging compiled methods" - ^self methodClass name, '>>', self selector! Item was removed: - ----- Method: CompiledMethod>>embeddedBlockClosures (in category 'closures') ----- - embeddedBlockClosures - | bms extractor scanner endPC encoderClass | - bms := OrderedCollection new. - scanner := self scanner. - extractor := ClosureExtractor withAction: [:c| bms add: c] andScanner: scanner. - endPC := self endPC. - encoderClass := self encoderClass. - [scanner pc <= endPC] whileTrue: - [encoderClass interpretNextInstructionFor: extractor in: scanner]. - ^bms! Item was removed: - ----- Method: CompiledMethod>>equivalentTo: (in category 'comparing') ----- - equivalentTo: aCompiledMethod - | parseTree | - ^self = aCompiledMethod - or: [self class == aCompiledMethod class - and: [self numArgs = aCompiledMethod numArgs - and: [self numLiterals = aCompiledMethod numLiterals - and: [parseTree := self decompile. - (parseTree isKindOf: MethodNode) - ifTrue: [parseTree asString = aCompiledMethod decompile asString "Standard compiler"] - ifFalse: [parseTree = aCompiledMethod decompile "RB parse trees, we hope"]]]]]! Item was removed: - ----- Method: CompiledMethod>>fileIndex (in category 'source code management') ----- - fileIndex - ^SourceFiles fileIndexFromSourcePointer: self sourcePointer! Item was removed: - ----- Method: CompiledMethod>>filePosition (in category 'source code management') ----- - filePosition - ^SourceFiles filePositionFromSourcePointer: self sourcePointer! Item was removed: - ----- Method: CompiledMethod>>getPreambleFrom:at: (in category 'source code management') ----- - getPreambleFrom: aFileStream at: endPosition - | chunk | - aFileStream position: endPosition + 2. - [(chunk := aFileStream backChunk) beginsWith: ']lang['] whileTrue. - ^ chunk! Item was removed: - ----- Method: CompiledMethod>>getSourceFor:in: (in category 'source code management') ----- - getSourceFor: selector in: class - "Retrieve or reconstruct the source code for this method." - | trailer source | - (self properties includesKey: #source) ifTrue: - [^self properties at: #source]. - trailer := self trailer. - - trailer tempNames ifNotNil: [:namesString | - "Magic sources -- decompile with temp names" - ^ ((class decompilerClass new withTempNames: namesString) - decompile: selector in: class method: self methodForDecompile) - decompileString]. - - trailer sourceCode ifNotNil: [:code | ^ code ]. - - trailer hasSourcePointer ifFalse: [ - "No source pointer -- decompile without temp names" - ^ (class decompilerClass new decompile: selector in: class method: self methodForDecompile) - decompileString]. - - "Situation normal; read the sourceCode from the file" - source := [self getSourceFromFileAt: trailer sourcePointer] - on: Error - "An error can happen here if, for example, the changes file has been truncated by an aborted download. The present solution is to ignore the error and fall back on the decompiler. A more thorough solution should probably trigger a systematic invalidation of all source pointers past the end of the changes file. Consider that, as time goes on, the changes file will eventually grow large enough to cover the lost code, and then instead of falling into this error case, random source code will get returned." - do: [ :ex | ex return: nil]. - - ^source ifNil: [ - "Something really wrong -- decompile blind (no temps)" - (class decompilerClass new decompile: selector in: class method: self methodForDecompile) - decompileString]! Item was removed: - ----- Method: CompiledMethod>>getSourceFromFile (in category 'source code management') ----- - getSourceFromFile - - ^self getSourceFromFileAt: self sourcePointer! Item was removed: - ----- Method: CompiledMethod>>getSourceFromFileAt: (in category 'source code management') ----- - getSourceFromFileAt: sourcePointer - - | position index | - position := SourceFiles filePositionFromSourcePointer: sourcePointer. - position = 0 ifTrue: [ ^nil ]. - index := SourceFiles fileIndexFromSourcePointer: sourcePointer. - ^(RemoteString newFileNumber: index position: position) - text! Item was removed: - ----- Method: CompiledMethod>>hasInstVarRef (in category 'scanning') ----- - hasInstVarRef - "Answer whether the method references an instance variable." - - | scanner end printer | - - scanner := InstructionStream on: self. - printer := InstVarRefLocator new. - end := self endPC. - - [scanner pc <= end] whileTrue: [ - (printer interpretNextInstructionUsing: scanner) ifTrue: [^true]. - ]. - ^false! Item was removed: - ----- Method: CompiledMethod>>hasPragma: (in category 'accessing-pragmas & properties') ----- - hasPragma: aSymbol - - ^ (self pragmaAt: aSymbol) notNil! Item was removed: - ----- Method: CompiledMethod>>hasReportableSlip (in category 'testing') ----- - hasReportableSlip - "Answer whether the receiver contains anything that should be brought - to the attention of the author when filing out. Customize the lists here - to suit your preferences. If slips do not get reported in spite of your - best efforts here, make certain that the Preference 'checkForSlips' is set - to true." - #(#doOnlyOnce: #halt #halt: #hottest #printDirectlyToDisplay #toRemove #personal #urgent #haltOnce #haltOnce: #haltIf: ) - do: [:aLit | (self hasLiteral: aLit) - ifTrue: [^ true]]. - #(#Transcript #AA #BB #CC #DD #EE ) - do: [:aSymbol | - | assoc | - (assoc := Smalltalk globals - associationAt: aSymbol - ifAbsent: []) - ifNotNil: [(self hasLiteral: assoc) - ifTrue: [^ true]]]. - ^ false! Item was removed: - ----- Method: CompiledMethod>>hasSameLiteralsAs: (in category 'comparing') ----- - hasSameLiteralsAs: aMethod - "Answer whether the receiver has the same sequence of literals as the argument. - Compare the last literal, which is the class association, specially so as not to - differentiate between otherwise identical methods installed in different classes. - Compare the first literal carefully if it is the binding informaiton for an FFI or - external primitive call. Don't compare all of the state so that linked and unlinked - methods are still considered equal." - | numLits | - numLits := self numLiterals. - numLits = aMethod numLiterals ifFalse: [^false]. - 1 to: numLits do: - [:i| | lit1 lit2 | - lit1 := self literalAt: i. - lit2 := aMethod literalAt: i. - (lit1 == lit2 or: [lit1 literalEqual: lit2]) ifFalse: - [(i = 1 and: [#(117 120) includes: self primitive]) - ifTrue: - [lit1 isArray - ifTrue: - [(lit2 isArray and: [(lit1 first: 2) = (lit2 first: 2)]) ifFalse: - [^false]] - ifFalse: "ExternalLibraryFunction" - [(lit1 analogousCodeTo: lit2) ifFalse: - [^false]]] - ifFalse: - [i = (numLits - 1) - ifTrue: "properties" - [(self properties analogousCodeTo: aMethod properties) - ifFalse: [^false]] - ifFalse: "last literal (methodClassAssociation) of class-side methods is not unique" - "last literal of CompiledBlock is outerMethod and may not be unique." - [(self isCompiledBlock - and: [lit1 isCompiledCode - and: [lit2 isCompiledCode]]) ifTrue: - [^true]. - (i = numLits - and: [lit1 isVariableBinding and: [lit1 value isBehavior - and: [lit2 isVariableBinding and: [lit2 value isBehavior]]]]) ifFalse: - [^false]]]]]. - ^true! Item was removed: - ----- Method: CompiledMethod>>headerDescription (in category 'printing') ----- - headerDescription - "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! Item was removed: - ----- Method: CompiledMethod>>holdsTempNames (in category 'source code management') ----- - holdsTempNames - "Are tempNames stored in trailer bytes" - - ^ self trailer hasTempNames! Item was removed: - ----- Method: CompiledMethod>>homeMethod (in category 'accessing') ----- - homeMethod - "Answer the home method associated with the receiver. - This is polymorphic with closure, CompiledBlock, Context etc" - - ^self! Item was removed: - ----- Method: CompiledMethod>>isAbstract (in category 'testing') ----- - isAbstract - | marker | - marker := self markerOrNil. - ^ marker notNil and: [self class abstractMarkers includes: marker].! Item was removed: - ----- Method: CompiledMethod>>isBlueBookCompiled (in category 'testing') ----- - isBlueBookCompiled - "Answer whether the receiver was compiled using the old Smalltalk-80 blocks - compiler. This is used to help DebuggerMethodMap choose which mechanisms - to use to inspect (debug) activations of the receiver." - - ^self encoderClass supportsClosures not! Item was removed: - ----- Method: CompiledMethod>>isClosureCompiled (in category 'testing') ----- - isClosureCompiled - "Answer whether the receiver was compiled using the closure compiler. - This is used to help DebuggerMethodMap choose which mechanisms to - use to inspect (debug) activations of the receiver." - - ^self encoderClass supportsClosures! Item was removed: - ----- Method: CompiledMethod>>isCompiledMethod (in category 'testing') ----- - isCompiledMethod - - ^ true! Item was removed: - ----- Method: CompiledMethod>>isDeprecated (in category 'testing') ----- - isDeprecated - "Note that #literalsDo: is faster than #hasLiteral: (and #hasLiteral:scanForSpecial:). We already know that 'self deprecated' should be the first statement in a deprecated method, which is directly accessible in this method's literals. No need to check compiled blocks or other nested structures. We expand the implementation of #literalsDo: here to gain twice the speed. - - Note that both #isQuick and is-this-method check make no sense performance-wise. Maybe bench again in the future." - - | literal | - 1 to: self numLiterals do: [:index | - ((literal := self literalAt: index) == #deprecated: or: [ literal == #deprecated ]) - ifTrue: [ ^true ] ]. - ^ false! Item was removed: - ----- Method: CompiledMethod>>isDisabled (in category 'testing') ----- - isDisabled - ^ self isDisabled: self markerOrNil! Item was removed: - ----- Method: CompiledMethod>>isDisabled: (in category 'testing') ----- - isDisabled: marker - ^ marker == self class disabledMarker! Item was removed: - ----- Method: CompiledMethod>>isImplicitlyRequired (in category 'testing') ----- - isImplicitlyRequired - ^ self isImplicitlyRequired: self markerOrNil! Item was removed: - ----- Method: CompiledMethod>>isInstalled (in category 'testing') ----- - isInstalled - self methodClass ifNotNil: - [:class| - self selector ifNotNil: - [:selector| - ^self == (class methodDict at: selector ifAbsent: [])]]. - ^false! Item was removed: - ----- Method: CompiledMethod>>isLinkedNamedPrimitive (in category 'testing') ----- - isLinkedNamedPrimitive - "Answer if the receiver invokes a named primitive, and the method is linked to an actual primitive. - For example if the method hasn't yet been used in the current session, it won't be linked" - ^self isNamedPrimitive and: [(self literalAt: 1) fourth ~= 0] - - "self systemNavigation browseAllSelect: [:m| m isLinkedNamedPrimitive]"! Item was removed: - ----- Method: CompiledMethod>>isNamedPrimitive (in category 'testing') ----- - isNamedPrimitive - "Answer if the receiver invokes a named primitive." - ^self primitive = 117 - - "self systemNavigation browseAllSelect: [:m| m isNamedPrimitive]"! Item was removed: - ----- Method: CompiledMethod>>isQuick (in category 'testing') ----- - isQuick - "Answer whether the receiver is a quick return (of self or of an instance - variable)." - ^ self primitive between: 256 and: 519! Item was removed: - ----- Method: CompiledMethod>>isReturnField (in category 'testing') ----- - isReturnField - "Answer whether the receiver is a quick return of an instance variable." - ^ self primitive between: 264 and: 519! Item was removed: - ----- Method: CompiledMethod>>isReturnSelf (in category 'testing') ----- - isReturnSelf - "Answer whether the receiver is a quick return of self." - - ^ self primitive = 256! Item was removed: - ----- Method: CompiledMethod>>isReturnSpecial (in category 'testing') ----- - isReturnSpecial - "Answer whether the receiver is a quick return of self or constant." - - ^ self primitive between: 256 and: 263! Item was removed: - ----- Method: CompiledMethod>>isSubclassResponsibility (in category 'testing') ----- - isSubclassResponsibility - ^ self isSubclassResponsibility: self markerOrNil! Item was removed: - ----- Method: CompiledMethod>>isSubclassResponsibility: (in category 'testing') ----- - isSubclassResponsibility: marker - ^ marker == self class subclassResponsibilityMarker! Item was removed: - ----- Method: CompiledMethod>>linesOfCode (in category 'source code management') ----- - linesOfCode - "An approximate measure of lines of code. - Includes comments, but excludes empty lines." - | lines | - lines := 0. - self getSource asString lineIndicesDo: [:start :endWithoutDelimiters :end | - endWithoutDelimiters > start ifTrue: [lines := lines+1]]. - ^lines! Item was removed: - ----- Method: CompiledMethod>>literalStrings (in category 'literals') ----- - literalStrings - | litStrs | - litStrs := OrderedCollection new: self numLiterals. - self literalsDo: - [:lit | - (lit isVariableBinding) - ifTrue: [litStrs addLast: lit key] - ifFalse: [(lit isSymbol) - ifTrue: [litStrs addAll: lit keywords] - ifFalse: [litStrs addLast: lit printString]]]. - ^ litStrs! Item was removed: - ----- Method: CompiledMethod>>longPrintOn:indent: (in category 'printing') ----- - longPrintOn: aStream indent: tabs - "List of all the byte codes in a method with a short description of each" - - self isQuick ifTrue: - [self isReturnSpecial ifTrue: - [^ aStream tab: tabs; nextPutAll: 'Quick return ' , - (#('self' 'true' 'false' 'nil' '-1' '0' '1' '2') at: self primitive - 255)]. - ^ aStream nextPutAll: 'Quick return field ' , self returnField printString , ' (0-based)']. - - self primitive = 0 ifFalse: [ - aStream tab: tabs. - self printPrimitiveOn: aStream. - ]. - (InstructionPrinter on: self) indent: tabs; printInstructionsOn: aStream. - ! Item was removed: - ----- Method: CompiledMethod>>longPrintRelativeOn:indent: (in category 'printing') ----- - longPrintRelativeOn: aStream indent: tabs - "List of all the byte codes in a method with a short description of each" - - self isQuick ifTrue: - [^self longPrintOn: aStream indent: tabs]. - self primitive = 0 ifFalse: - [aStream tab: tabs. self printPrimitiveOn: aStream]. - (RelativeInstructionPrinter on: self) - indent: tabs; - printCode: false; - printInstructionsOn: aStream. - ! Item was removed: - ----- Method: CompiledMethod>>markerOrNil (in category 'private') ----- - markerOrNil - "If I am a marker method, answer the symbol used to mark me. Otherwise - answer nil. What is a marker method? It is method with body like - 'self subclassResponsibility' or '^ self subclassResponsibility' - used to indicate ('mark') a special property." - - ^self encoderClass markerOrNilFor: self! Item was removed: - ----- Method: CompiledMethod>>method (in category 'accessing') ----- - method - "Answer the home method associated with the receiver. - This is polymorphic with closure, CompiledBlock, Context etc" - - ^self! Item was removed: - ----- Method: CompiledMethod>>methodClass (in category 'accessing') ----- - methodClass - "answer the class that I am installed in" - ^(self literalAt: self numLiterals) value.! Item was removed: - ----- Method: CompiledMethod>>methodClass: (in category 'accessing') ----- - methodClass: aClass - "set the class binding in the last literal to aClass" - self literalAt: self numLiterals put: aClass binding! Item was removed: - ----- Method: CompiledMethod>>methodClassAssociation (in category 'accessing') ----- - methodClassAssociation - "answer the association to the class that I am installed in, or nil if none." - ^self literalAt: self numLiterals! Item was removed: - ----- Method: CompiledMethod>>methodClassAssociation: (in category 'accessing') ----- - methodClassAssociation: aBinding - "sets the association to the class that I am installed in" - ^self literalAt: self numLiterals put: aBinding! Item was removed: - ----- Method: CompiledMethod>>methodForDecompile (in category 'decompiling') ----- - methodForDecompile - "This is a hook to allow recursive methods like MwMethodWrapper to avoid infinite recursion." - ^self! Item was removed: - ----- Method: CompiledMethod>>methodHome (in category 'accessing') ----- - methodHome - "The behavior (trait/class) this method was originally defined in. - Can be different from methodClass if the method was recompiled." - ^self properties methodHome! Item was removed: - ----- Method: CompiledMethod>>methodNode (in category 'decompiling') ----- - methodNode - "Return the parse tree that represents self. If parsing fails, decompile the method." - | aClass source | - aClass := self methodClass. - source := self - getSourceFor: (self selector ifNil: [self defaultSelector]) - in: aClass. - ^[(aClass newParser - encoderClass: self encoderClass; - parse: source class: aClass) - sourceText: source; - yourself] - on: SyntaxErrorNotification - do: [:ex | ex return: self decompileWithTemps]! Item was removed: - ----- Method: CompiledMethod>>methodNodeFormattedAndDecorated: (in category 'decompiling') ----- - methodNodeFormattedAndDecorated: decorate - "Answer a method node made from pretty-printed (and colorized, if decorate is true) - source text." - - | class source node | - - source := self getSourceFromFile. - class := self methodClass ifNil: [self sourceClass]. - source ifNil: [^self decompile]. - source := class prettyPrinterClass - format: source - in: class - notifying: nil - decorated: decorate. - node := class newParser parse: source class: class. - node sourceText: source. - ^node! Item was removed: - ----- Method: CompiledMethod>>nestedBlockMethods (in category 'closures') ----- - nestedBlockMethods - "Answer a collection of the block methods of blocks within the receiver, if any." - | nestedBlockMethods iterator | - nestedBlockMethods := OrderedCollection new. - iterator := [:m| | nLits | - nLits := m numLiterals. - 2 to: (m isCompiledBlock ifTrue: [nLits] ifFalse: [nLits - 1]) do: - [:index | | lit | - lit := m objectAt: index. - lit isCompiledCode ifTrue: - [iterator value: (nestedBlockMethods add: lit)]]]. - iterator value: self. - ^nestedBlockMethods - ! Item was removed: - ----- Method: CompiledMethod>>objectForDataStream: (in category 'file in/out') ----- - objectForDataStream: refStrm - "Reconfigure pragma. Example: #(#FFTPlugin #primitiveFFTTransformData 0 0). See FFT >> #pluginTransformData:." - - self primitive = 117 ifTrue: [(self literalAt: 1) at: 4 put: 0].! Item was removed: - ----- Method: CompiledMethod>>parserClass (in category 'decompiling') ----- - parserClass - ^self methodClass - ifNil: [Compiler parserClass] - ifNotNil: [:class | class parserClass].! Item was removed: - ----- Method: CompiledMethod>>penultimateLiteral (in category 'private') ----- - penultimateLiteral - "Answer the penultimate literal of the receiver, which holds either - the receiver's selector or its properties (which will hold the selector)." - | pIndex | - ^(pIndex := self numLiterals - 1) > 0 - ifTrue: [self literalAt: pIndex] - ifFalse: [nil]! Item was removed: - ----- Method: CompiledMethod>>penultimateLiteral: (in category 'private') ----- - penultimateLiteral: anObject - "Set the penultimate literal of the receiver, which holds either the - receiver's selector or its properties (which will hold the selector). - If it is an AdditionalMethodState set the state's ownership to this - method" - | pIndex | - (pIndex := self numLiterals - 1) <= 0 ifTrue: - [self error: 'insufficient literals']. - self literalAt: pIndex put: anObject. - anObject isMethodProperties ifTrue: - [(anObject method ~~ nil - and: [anObject method ~~ self - and: [anObject method penultimateLiteral == anObject]]) ifTrue: - [self error: 'a method''s AdditionalMethodState should not be shared']. - anObject setMethod: self. - anObject pragmas do: [:p| p setMethod: self]]! Item was removed: - ----- Method: CompiledMethod>>postCopy (in category 'copying') ----- - postCopy - | penultimateLiteral | - (penultimateLiteral := self penultimateLiteral) isMethodProperties ifTrue: - [self penultimateLiteral: penultimateLiteral copy]. - self encoderClass supportsFullBlocks ifTrue: - [1 to: self numLiterals - 2 do: - [:index| | lit | - (lit := self literalAt: index) isCompiledCode ifTrue: - [lit outerCode: self; postCopy]]]! Item was removed: - ----- Method: CompiledMethod>>pragmaAt: (in category 'accessing-pragmas & properties') ----- - pragmaAt: aKey - "Answer the pragma with selector aKey, or nil if none." - | propertiesOrSelector | - ^(propertiesOrSelector := self penultimateLiteral) isMethodProperties - ifTrue: [propertiesOrSelector at: aKey ifAbsent: nil] - ifFalse: [nil]! Item was removed: - ----- Method: CompiledMethod>>pragmas (in category 'accessing-pragmas & properties') ----- - pragmas - | selectorOrProperties | - ^(selectorOrProperties := self penultimateLiteral) isMethodProperties - ifTrue: [selectorOrProperties pragmas] - ifFalse: [#()]! Item was removed: - ----- Method: CompiledMethod>>pragmasAt: (in category 'accessing-pragmas & properties') ----- - pragmasAt: aSelector - ^self pragmas select: [:p| p keyword = aSelector]! Item was removed: - ----- Method: CompiledMethod>>preamble (in category 'printing') ----- - preamble - "Return the preamble of this method stored in the source files." - - ^SourceFiles - fileIndexAndPositionFromSourcePointer: self sourcePointer - do: [ :fileIndex :filePosition | - fileIndex = 0 - ifTrue: [ String new "no source pointer for this method" ] - ifFalse: [ - (CurrentReadOnlySourceFiles at: fileIndex) - ifNil: [ String new "sources file not available" ] - ifNotNil: [ :file | - self - getPreambleFrom: file - at: (0 max: filePosition - 3) ] ] ]! Item was removed: - ----- 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]! Item was removed: - ----- Method: CompiledMethod>>primitiveErrorVariableName (in category 'printing') ----- - primitiveErrorVariableName - "Answer the primitive error code temp name, or nil if none." - self primitive > 0 ifTrue: - [self pragmas do: - [:pragma| | kwds ecIndex | - ((kwds := pragma keyword keywords) first = 'primitive:' - and: [(ecIndex := kwds indexOf: 'error:') > 0]) ifTrue: - [^pragma argumentAt: ecIndex]]]. - ^nil! Item was removed: - ----- Method: CompiledMethod>>printPrimitiveOn: (in category 'printing') ----- - printPrimitiveOn: aStream - "Print the primitive on aStream" - | primIndex primDecl | - (primIndex := self primitive) = 0 ifTrue: - [^self]. - primIndex = 120 ifTrue: "External call spec" - [^aStream print: (self literalAt: 1); cr]. - aStream nextPutAll: '<primitive: '. - primIndex = 117 - ifTrue: - [primDecl := self literalAt: 1. - (primDecl at: 2) asString printOn: aStream. - (primDecl at: 1) ifNotNil: - [:moduleName| - aStream nextPutAll:' module: '. - moduleName asString printOn: aStream]] - ifFalse: - [aStream print: primIndex]. - self primitiveErrorVariableName ifNotNil: - [:primitiveErrorVariableName| - aStream nextPutAll: ' error: '; nextPutAll: primitiveErrorVariableName]. - aStream nextPut: $>; cr! Item was removed: - ----- Method: CompiledMethod>>properties (in category 'accessing') ----- - properties - "Answer the method properties of the receiver." - | propertiesOrSelector | - ^(propertiesOrSelector := self penultimateLiteral) isMethodProperties - ifTrue: [propertiesOrSelector] - ifFalse: [self class methodPropertiesClass forMethod: self selector: propertiesOrSelector]! Item was removed: - ----- Method: CompiledMethod>>properties: (in category 'accessing') ----- - properties: aMethodProperties - "Set the method-properties of the receiver to aMethodProperties." - self literalAt: self numLiterals - 1 - put: (aMethodProperties isEmpty - ifTrue: [aMethodProperties selector] - ifFalse: [aMethodProperties - setMethod: self; - yourself])! Item was removed: - ----- Method: CompiledMethod>>propertyKeysAndValuesDo: (in category 'accessing-pragmas & properties') ----- - propertyKeysAndValuesDo: aBlock - "Enumerate the receiver with all the keys and values." - - | propertiesOrSelector | - (propertiesOrSelector := self penultimateLiteral) isMethodProperties ifTrue: - [propertiesOrSelector propertyKeysAndValuesDo: aBlock]! Item was removed: - ----- Method: CompiledMethod>>propertyValueAt: (in category 'accessing-pragmas & properties') ----- - propertyValueAt: propName - | propertiesOrSelector | - ^(propertiesOrSelector := self penultimateLiteral) isMethodProperties - ifTrue: [propertiesOrSelector propertyValueAt: propName ifAbsent: nil] - ifFalse: [nil]! Item was removed: - ----- Method: CompiledMethod>>propertyValueAt:ifAbsent: (in category 'accessing-pragmas & properties') ----- - propertyValueAt: propName ifAbsent: aBlock - | propertiesOrSelector | - ^(propertiesOrSelector := self penultimateLiteral) isMethodProperties - ifTrue: [propertiesOrSelector propertyValueAt: propName ifAbsent: aBlock] - ifFalse: [aBlock value]! Item was removed: - ----- Method: CompiledMethod>>propertyValueAt:put: (in category 'accessing-pragmas & properties') ----- - propertyValueAt: propName put: propValue - "Set or add the property with key propName and value propValue. - If the receiver does not yet have a method properties create one and replace - the selector with it. Otherwise, either relace propValue in the method properties - or replace method properties with one containing the new property." - | propertiesOrSelector | - (propertiesOrSelector := self penultimateLiteral) isMethodProperties ifFalse: - [self penultimateLiteral: (self class methodPropertiesClass - selector: propertiesOrSelector - with: (Association - key: propName asSymbol - value: propValue)). - ^propValue]. - (propertiesOrSelector includesProperty: propName) ifTrue: - [^propertiesOrSelector at: propName put: propValue]. - self penultimateLiteral: (propertiesOrSelector - copyWith: (Association - key: propName asSymbol - value: propValue)). - ^propValue! Item was removed: - ----- Method: CompiledMethod>>putSource:fromParseNode:class:category:inFile:priorMethod: (in category 'source code management') ----- - putSource: sourceStr fromParseNode: methodNode class: class category: catName - inFile: fileIndex priorMethod: priorMethod - - ^ self putSource: sourceStr fromParseNode: methodNode inFile: fileIndex withPreamble: - [:file | class printCategoryChunk: catName on: file priorMethod: priorMethod. - file cr]! Item was removed: - ----- Method: CompiledMethod>>putSource:fromParseNode:class:category:withStamp:inFile:priorMethod: (in category 'source code management') ----- - putSource: sourceStr fromParseNode: methodNode class: class category: catName - withStamp: changeStamp inFile: fileIndex priorMethod: priorMethod - - ^ self putSource: sourceStr fromParseNode: methodNode inFile: fileIndex withPreamble: - [:file | - class printCategoryChunk: catName on: file - withStamp: changeStamp priorMethod: priorMethod. - file cr]! Item was removed: - ----- Method: CompiledMethod>>putSource:fromParseNode:inFile:withPreamble: (in category 'source code management') ----- - putSource: sourceStr fromParseNode: methodNode inFile: fileIndex withPreamble: preambleBlock - "Store the source code for the receiver on an external file. - If no sources are available, i.e., SourceFile is nil, then store - temp names for decompilation at the end of the method. - If the fileIndex is 1, print on *.sources; if it is 2, print on *.changes, - in each case, storing a 4-byte source code pointer at the method end." - - | file remoteString | - (SourceFiles == nil or: [(file := SourceFiles at: fileIndex) == nil]) ifTrue: - [^self becomeForward: (self copyWithTempsFromMethodNode: methodNode)]. - - Smalltalk assureStartupStampLogged. - file setToEnd. - - preambleBlock value: file. "Write the preamble" - remoteString := RemoteString newString: sourceStr onFileNumber: fileIndex toFile: file. - file nextChunkPut: ' '. - InMidstOfFileinNotification signal ifFalse: [file flush]. - self checkOKToAdd: sourceStr size at: remoteString position. - self setSourcePosition: remoteString position inFile: fileIndex! Item was removed: - ----- Method: CompiledMethod>>readsField: (in category 'scanning') ----- - readsField: varIndex - "Answer whether the receiver loads the instance variable indexed by the argument." - - | varIndexCode scanner | - varIndexCode := varIndex - 1. - self isQuick ifTrue: [^ self isReturnField and: [self returnField = varIndexCode]]. - - self codeLiteralsDo: [:compiledCode | - scanner := InstructionStream on: compiledCode. - (scanner scanFor: (self encoderClass instVarReadScanBlockFor: varIndexCode using: scanner)) - ifTrue: [^ true]]. - - ^ false! Item was removed: - ----- Method: CompiledMethod>>readsRef: (in category 'scanning') ----- - readsRef: variableBinding - "Answer whether the receiver reads the value of the argument." - - self codeLiteralsDo: [:compiledCode | - | litIndex scanner | - (litIndex := compiledCode indexOfLiteral: variableBinding) = 0 - ifFalse: - [scanner := InstructionStream on: compiledCode. - (scanner scanFor: (compiledCode encoderClass bindingReadScanBlockFor: litIndex - 1 using: scanner)) - ifTrue: [^ true]]]. - - ^ false! Item was removed: - ----- Method: CompiledMethod>>removeProperty: (in category 'accessing-pragmas & properties') ----- - removeProperty: propName - "Remove the property propName if it exists. - Do _not_ raise an error if the property is missing." - | value newAdditionalState | - value := self propertyValueAt: propName ifAbsent: [^nil]. - newAdditionalState := self penultimateLiteral copyWithout: - (Association - key: propName - value: value). - self penultimateLiteral: (newAdditionalState isEmpty - ifTrue: [newAdditionalState selector] - ifFalse: [newAdditionalState]). - ^value! Item was removed: - ----- Method: CompiledMethod>>removeProperty:ifAbsent: (in category 'accessing-pragmas & properties') ----- - removeProperty: propName ifAbsent: aBlock - "Remove the property propName if it exists. - Answer the evaluation of aBlock if the property is missing." - | value newAdditionalState | - value := self propertyValueAt: propName ifAbsent: [^aBlock value]. - newAdditionalState := self penultimateLiteral copyWithout: - (Association - key: propName - value: value). - self penultimateLiteral: (newAdditionalState isEmpty - ifTrue: [newAdditionalState selector] - ifFalse: [newAdditionalState]). - ^value! Item was removed: - ----- Method: CompiledMethod>>replace:with:in: (in category 'private') ----- - replace: oldSelector with: newSelector in: aText - | oldKeywords newKeywords args newSelectorWithArgs startOfSource lastSelectorToken | - oldKeywords := oldSelector keywords. - newKeywords := (newSelector ifNil: [self defaultSelector]) keywords. - self assert: oldKeywords size = newKeywords size. - args := self methodClass newParser parseParameterNames: aText string. - newSelectorWithArgs := String streamContents: [:stream | - newKeywords withIndexDo: [:keyword :index | - stream nextPutAll: keyword. - stream space. - args size >= index ifTrue: [ - stream nextPutAll: (args at: index); space]]]. - lastSelectorToken := args isEmpty - ifFalse: [args last] - ifTrue: [oldKeywords last]. - startOfSource := (aText string - indexOfSubCollection: lastSelectorToken startingAt: 1) + lastSelectorToken size. - ^newSelectorWithArgs withBlanksTrimmed asText , (aText copyFrom: startOfSource to: aText size)! Item was removed: - ----- Method: CompiledMethod>>returnField (in category 'accessing') ----- - returnField - "Answer the index of the instance variable returned by a quick return - method." - | prim | - prim := self primitive. - prim < 264 - ifTrue: [self error: 'only meaningful for quick-return'] - ifFalse: [^ prim - 264]! Item was removed: - ----- Method: CompiledMethod>>scanForInstructionPattern: (in category 'scanning') ----- - scanForInstructionPattern: tuple - "Convenient use of scanForInstructionSequence: - e.g. self systemNavigation browseAllSelect: [:m| m scanForInstructionPattern: #((pushConstant: true) (send:super:numArgs: spilled: false 1))] - self systemNavigation browseAllSelect: [:m| m scanForInstructionPattern: #((send:super:numArgs: arguments false 0) (send:super:numArgs: = false 1))]" - | first firstArgs second secondArgs third thirdArgs | - ^(InstructionStream on: self) scanForInstructionSequence: - (tuple size caseOf: { - [1] -> [first := tuple first. - firstArgs := first allButFirst. - first := first first. - [:a| - a selector == first and: [a arguments = firstArgs]]]. - [2] -> [first := tuple first. - firstArgs := first allButFirst. - second := tuple second. - secondArgs := second allButFirst. - first := first first. - second := second first. - [:a :b| - a selector == first and: [a arguments = firstArgs - and: [b selector == second and: [b arguments = secondArgs]]]]]. - [3] -> [first := tuple first. - firstArgs := first allButFirst. - second := tuple second. - secondArgs := second allButFirst. - third := tuple third. - thirdArgs := third allButFirst. - first := first first. - second := second first. - third := third first. - [:a :b :c| - a selector == first and: [a arguments = firstArgs - and: [b selector == second and: [b arguments = secondArgs - and: [c selector == third and: [c arguments = thirdArgs]]]]]]] })! Item was removed: - ----- Method: CompiledMethod>>scanForInstructionSequence: (in category 'scanning') ----- - scanForInstructionSequence: naryBlock - "naryBlock is a block taking one or more arguments. - Evaluate it for each sequence of instructions of length - n in the receiver until naryBlock evaluates to true. - Answer if naryBlock evaluated to true." - ^(InstructionStream on: self) scanForInstructionSequence: naryBlock - " - self systemNavigation browseAllSelect: [:m | m scanForInstructionSequence: [:msg| msg selector = #send:super:numArgs: and: [msg arguments second]]] localTo: thisContext class - "! Item was removed: - ----- Method: CompiledMethod>>searchForClass (in category 'accessing') ----- - searchForClass - "search me in all classes, if found, return my class. Slow!!" - self systemNavigation allBehaviorsDo: [:class | - (class methodDict keyAtIdentityValue: self ifAbsent: [nil]) ifNotNil: [^class]]. - ^nil.! Item was removed: - ----- Method: CompiledMethod>>searchForSelector (in category 'accessing') ----- - searchForSelector - "search me in all classes, if found, return my selector. Slow!!" - self systemNavigation allBehaviorsDo: [:class | - | selector | - (selector := class methodDict keyAtIdentityValue: self ifAbsent: [nil]) ifNotNil: [^selector]]. - ^nil.! Item was removed: - ----- Method: CompiledMethod>>selector (in category 'accessing') ----- - selector - "Answer a method's selector. This is either the penultimate literal, - or, if the method has any properties or pragmas, the selector of - the AdditionalMethodState stored in the penultimate literal." - | penultimateLiteral | - ^(penultimateLiteral := self penultimateLiteral) isMethodProperties - ifTrue: [penultimateLiteral selector] - ifFalse: [penultimateLiteral]! Item was removed: - ----- Method: CompiledMethod>>selector: (in category 'accessing') ----- - selector: aSelector - "Set a method's selector. This is either the penultimate literal, - or, if the method has any properties or pragmas, the selector of - the MethodProperties stored in the penultimate literal." - | penultimateLiteral nl | - (penultimateLiteral := self penultimateLiteral) isMethodProperties - ifTrue: [penultimateLiteral selector: aSelector] - ifFalse: [(nl := self numLiterals) < 2 ifTrue: - [self error: 'insufficient literals to hold selector']. - self literalAt: nl - 1 put: aSelector]! Item was removed: - ----- Method: CompiledMethod>>setSourcePointer: (in category 'source code management') ----- - setSourcePointer: srcPointer - "We can't necessarily change the trailer of existing method, since - it could have a completely different format. If so, generate a copy - with a new trailer, containing a srcPointer, and then become it." - | newTrailer myTrailer | - myTrailer := self trailer. - srcPointer = 0 - ifTrue: "catch the common case of setting the source pointer to 0 when already 0" - [myTrailer sourcePointer = 0 ifTrue: - [^self]. - newTrailer := CompiledMethodTrailer empty] - ifFalse: - [newTrailer := CompiledMethodTrailer new sourcePointer: srcPointer]. - (myTrailer size = newTrailer size - and: [myTrailer kind = newTrailer kind]) ifTrue: - [^newTrailer copyToMethod: self]. - - ^self becomeForward: (self copyWithTrailerBytes: newTrailer)! Item was removed: - ----- Method: CompiledMethod>>setSourcePosition:inFile: (in category 'source code management') ----- - setSourcePosition: position inFile: fileIndex - self setSourcePointer: (SourceFiles sourcePointerFromFileIndex: fileIndex andPosition: position)! Item was removed: - ----- Method: CompiledMethod>>sourceClass (in category 'source code management') ----- - sourceClass - "Get my receiver class (method class) from the preamble of my source. Return nil if not found." - - ^ [(Compiler evaluate: (self sourceFileStream backChunk "blank"; backChunk "preamble")) theClass] on: Error do: [nil]! Item was removed: - ----- Method: CompiledMethod>>sourceFileStream (in category 'source code management') ----- - sourceFileStream - "Answer the sources file stream with position set at the beginning of my source string" - - | pos | - (pos := self filePosition) = 0 ifTrue: [^ nil]. - ^ (RemoteString newFileNumber: self fileIndex position: pos) fileStream! Item was removed: - ----- Method: CompiledMethod>>sourcePointer (in category 'source code management') ----- - sourcePointer - "Answer the integer which can be used to find the source file and position for this method. - The actual interpretation of this number is up to the SourceFileArray stored in the global variable SourceFiles." - - ^ self trailer sourcePointer - ! Item was removed: - ----- Method: CompiledMethod>>sourceSelector (in category 'source code management') ----- - sourceSelector - "Answer my selector extracted from my source. If no source answer nil" - - | sourceString | - sourceString := self getSourceFromFile ifNil: [^ nil]. - ^self methodClass newParser parseSelector: sourceString! Item was removed: - ----- Method: CompiledMethod>>storeLiteralsOn:forClass: (in category 'printing') ----- - storeLiteralsOn: aStream forClass: aBehavior - "Store the literals referenced by the receiver on aStream, each terminated by a space." - - | literal | - 2 to: self numLiterals + 1 do: - [:index | - aBehavior storeLiteral: (self objectAt: index) on: aStream. - aStream space]! Item was removed: - ----- Method: CompiledMethod>>tempNames (in category 'source code management') ----- - tempNames - ^self debuggerMap tempNamesForMethod: self! Item was removed: - ----- Method: CompiledMethod>>tempNamesString (in category 'source code management') ----- - tempNamesString - "Answer the schematicTempNames string, or nil if receiver has no temps names encoded in trailer" - ^ self trailer tempNames! Item was removed: - ----- Method: CompiledMethod>>timeStamp (in category 'printing') ----- - timeStamp - "Answer the authoring time-stamp for the given method, retrieved from the sources or changes file. Answer the empty string if no time stamp is available." - "(CompiledMethod compiledMethodAt: #timeStamp) timeStamp" - - | preamble stamp tokens tokenCount | - stamp := nil. - preamble := self preamble. - tokens := (preamble findString: 'methodsFor:' startingAt: 1) > 0 - ifTrue: [Scanner new scanTokens: preamble] - ifFalse: [#() "ie cant be back ref"]. - (((tokenCount := tokens size) between: 7 and: 8) and: [(tokens at: tokenCount - 5) == #methodsFor:]) - ifTrue: - [(tokens at: tokenCount - 3) == #stamp: - ifTrue: ["New format gives change stamp and unified prior pointer" - stamp := tokens at: tokenCount - 2]]. - ((tokenCount between: 5 and: 6) and: [(tokens at: tokenCount - 3) == #methodsFor:]) - ifTrue: - [(tokens at: tokenCount - 1) == #stamp: - ifTrue: ["New format gives change stamp and unified prior pointer" - stamp := tokens at: tokenCount]]. - ^stamp ifNil: [ String new ] - ! Item was removed: - ----- Method: CompiledMethod>>usesClosureBytecodes (in category 'testing') ----- - usesClosureBytecodes - "Answer whether the receiver was compiled using the closure compiler. - This is used to help DebuggerMethodMap choose which mechanisms to - use to inspect activations of the receiver. - This method answers false negatives in that it only identifies methods - that use the new BlockClosure bytecodes. - But since methods that don't create blocks have essentially the same - code when compiled with either compiler this makes little difference." - - ^self encoderClass supportsClosures! Item was removed: - ----- Method: CompiledMethod>>valueWithReceiver:arguments: (in category 'evaluating') ----- - valueWithReceiver: aReceiver arguments: anArray - - ^self class receiver: aReceiver withArguments: anArray executeMethod: self! Item was removed: - ----- Method: CompiledMethod>>withoutPrimitive (in category 'converting') ----- - withoutPrimitive - "Answers a copy of self without primitive call. - That may serve for example for testing fallback code." - - | copy skipPrimitiveCall | - self primitive = 0 ifTrue: [^self]. - skipPrimitiveCall := 3. - copy := CompiledMethod - newMethod: self basicSize - self initialPC + 1 - skipPrimitiveCall - header: (self header bitClear: 16r10000). - 1 to: self numLiterals do: [:index| copy literalAt: index put: (self literalAt: index)]. - self initialPC + skipPrimitiveCall to: self size do: [:index | copy at: index - skipPrimitiveCall put: (self at: index)]. - copy postCopy. - ^copy! Item was removed: - ----- Method: CompiledMethod>>writesField: (in category 'scanning') ----- - writesField: varIndex - "Answer whether the receiver stores into the instance variable indexed by the argument." - - | varIndexCode scanner | - self isQuick ifTrue: [^ false]. - varIndexCode := varIndex - 1. - - self codeLiteralsDo: [:compiledCode | - scanner := InstructionStream on: compiledCode. - (scanner scanFor: (self encoderClass instVarWriteScanBlockFor: varIndex - 1 using: scanner)) - ifTrue: [^ true]]. - - ^ false! Item was removed: - ----- Method: CompiledMethod>>writesRef: (in category 'scanning') ----- - writesRef: variableBinding - "Answer whether the receiver writes the value of the argument." - - self codeLiteralsDo: [:compiledCode | - | litIndex scanner | - (litIndex := compiledCode indexOfLiteral: variableBinding) = 0 - ifFalse: - [scanner := InstructionStream on: compiledCode. - (scanner scanFor: (compiledCode encoderClass bindingWriteScanBlockFor: litIndex - 1 using: scanner)) - ifTrue: [^ true]]]. - - ^ false! Item was removed: - ----- Method: CompiledMethod>>zapSourcePointer (in category 'file in/out') ----- - zapSourcePointer - - "clobber the source pointer since it will be wrong" - | copy | - copy := self copyWithTrailerBytes: CompiledMethodTrailer empty. - self becomeForward: copy. - ^ copy - ! Item was removed: - Object subclass: #CompiledMethodTrailer - instanceVariableNames: 'data encodedData kind size method' - classVariableNames: '' - poolDictionaries: '' - category: 'Kernel-Methods'! - - !CompiledMethodTrailer commentStamp: 'ul 12/31/2009 19:03' prior: 0! - I am responsible for encoding and decoding various kinds of compiled method trailer data. - I should not expose any binary data outside of myself, so all tools which working with compiled methods - should ask me to encode the meta-data, they want to be added to the compiled method trailer, as well as retrieve it. - - To add a new kind of trailer, you should give it a proper name and define it in the #trailerKinds method at my class side. - Then you need to implement a corresponding #encode<your name> and #decode<your name> methods at instance side. Then add any public accessor methods, which will use a newly introduced trailer kind for communicating with outer layer(s). And finally evaluate: self generateTrailerKindDecoders. - - An encodeXXX methods should store result (byte array) into encodedData instance variable. - - A decodeXXX methods should read the data from compiled method instance, held by 'method' ivar, - and always set 'size' ivar (denoting a total length of trailer in compiled method) and optionally 'data' ivar which should keep a decoded data, ready to be used by outer layer(s) using accessor method(s) you providing. - - The kind of compiled method trailer is determined by the last byte of compiled method. - - The byte format used is following: - "2rkkkkkkdd" - - where 'k' bits stands for 'kind' , allowing totally 64 different kinds of method trailer - and 'd' bits is data. - - Following is the list of currently defined trailer kinds: - - NoTrailer , k = 000000, dd unused - method has no trailer, and total trailer size bytes is always 1 - - ClearedTrailer, k = 000001, - method has cleared trailer (it was set to something else, but then cleared) - dd+1 determines the number of bytes for size field, and size is a total length of trailer bytes - So a total length of trailer is: 1 + (dd + 1) + size - - TempsNamesQCompress, k = 000010 - the trailer contains a list of method temp names, compressed using qCompress: method. - dd+1 determines the number of bytes for size field, and size is a number of bytes of compressed buffer. - So a total length of trailer is: 1 + (dd + 1) + size - - TempsNamesZip, k = 000011 - the trailer contains a list of method temp names, compressed using GZIP compression method. - dd+1 determines the number of bytes for size field, and size is a number of bytes of compressed buffer - So a total length of trailer is: 1 + (dd + 1) + size - - SourceBySelector, k = 000100 - the trailer indicates , that method source is determined by a class + selector where it is installed to. - Trailer size = 1. - - SourceByStringIdentifier, k = 000101 - the trailer indicates , that method source is determined by a class + some ByteString identifier. - dd+1 determines the number of bytes for size of ByteString identifier, and size is number of bytes of string. - A total length of trailer is: 1 + (dd + 1) + size - - EmbeddedSourceQCompress, k = 000110 - the trailer contains an utf-8 encoded method source code, compressed using qCompress method - dd+1 determines the number of bytes for size field, and size is a number of bytes of compressed source code - A total length of trailer is: 1 + (dd + 1) + size - - EmbeddedSourceZip, k = 000111 - the trailer contains an utf-8 encoded method source code, comressed using GZIP - dd+1 determines the number of bytes for size field, and size is a number of bytes of compressed buffer - A total length of trailer is: 1 + (dd + 1) + size - - VarLengthSourcePointer, k = 001000 - the trailer is variable-length encoded source pointer. - dd bits is unused. - - ExtendedKind, k = 001001 - the next byte of trailer (one that prepends the last byte of compiled method) - denotes an extended kind of trailer, allowing to use additional 256 kinds of encoding method's trailer in future. - - SourcePointer, k = 111111 - the trailer is encoded source pointer. Total trailer size is 4-bytes - (this kind of encoding is backwards compatible with most of existing compiled methods) - - ! Item was removed: - ----- Method: CompiledMethodTrailer class>>empty (in category 'as yet unclassified') ----- - empty - "answer the empty trailer" - ^ self new! Item was removed: - ----- Method: CompiledMethodTrailer class>>generateTrailerKindDecoders (in category 'as yet unclassified') ----- - generateTrailerKindDecoders - - self class - compile: (String streamContents: [ :stream | - stream - nextPutAll: 'trailerKindDecoders'; cr; - cr; - tab; nextPut: $^; print: ( - self trailerKinds collect: [ :each | - ('decode', each) asSymbol ]) ]) - classified: 'generated' - ! Item was removed: - ----- Method: CompiledMethodTrailer class>>sourcePointerInFile: (in category 'as yet unclassified') ----- - sourcePointerInFile: fileIndex - - ^self new - sourcePointer: (SourceFiles - sourcePointerFromFileIndex: fileIndex - andPosition: (SourceFiles at: fileIndex) position); - yourself - ! Item was removed: - ----- Method: CompiledMethodTrailer class>>trailerKindDecoders (in category 'generated') ----- - trailerKindDecoders - - ^#(#decodeNoTrailer #decodeClearedTrailer #decodeTempsNamesQCompress #decodeTempsNamesZip #decodeSourceBySelector #decodeSourceByStringIdentifier #decodeEmbeddedSourceQCompress #decodeEmbeddedSourceZip #decodeVarLengthSourcePointer #decodeExtendedKind #decodeUndefined #decodeUndefined #decodeUndefined #decodeUndefined #decodeUndefined #decodeUndefined #decodeUndefined #decodeUndefined #decodeUndefined #decodeUndefined #decodeUndefined #decodeUndefined #decodeUndefined #decodeUndefined #decodeUndefined #decodeUndefined #decodeUndefined #decodeUndefined #decodeUndefined #decodeUndefined #decodeUndefined #decodeUndefined #decodeUndefined #decodeUndefined #decodeUndefined #decodeUndefined #decodeUndefined #decodeUndefined #decodeUndefined #decodeUndefined #decodeUndefined #decodeUndefined #decodeUndefined #decodeUndefined #decodeUndefined #decodeUndefined #decodeUndefined #decodeUndefined #decodeUndefined #decodeUndefined #decodeUndefined #decodeUndefined #decodeUndefined #decodeUndef ined #decodeUndefined #decodeUndefined #decodeUndefined #decodeUndefined #decodeUndefined #decodeUndefined #decodeUndefined #decodeUndefined #decodeUndefined #decodeSourcePointer)! Item was removed: - ----- Method: CompiledMethodTrailer class>>trailerKinds (in category 'as yet unclassified') ----- - trailerKinds - " see class comment for description. If you change this method, evaluate this: - self generateTrailerKindDecoders" - - ^#( - "000000" #NoTrailer - "000001" #ClearedTrailer - "000010" #TempsNamesQCompress - "000011" #TempsNamesZip - "000100" #SourceBySelector - "000101" #SourceByStringIdentifier - "000110" #EmbeddedSourceQCompress - "000111" #EmbeddedSourceZip - "001000" #VarLengthSourcePointer - "001001" #ExtendedKind - "001010" #Undefined - "001011" #Undefined - "001100" #Undefined - "001101" #Undefined - "001110" #Undefined - "001111" #Undefined - "010000" #Undefined - "010001" #Undefined - "010010" #Undefined - "010011" #Undefined - "010100" #Undefined - "010101" #Undefined - "010110" #Undefined - "010111" #Undefined - "011000" #Undefined - "011001" #Undefined - "011010" #Undefined - "011011" #Undefined - "011100" #Undefined - "011101" #Undefined - "011110" #Undefined - "011111" #Undefined - "100000" #Undefined - "100001" #Undefined - "100010" #Undefined - "100011" #Undefined - "100100" #Undefined - "100101" #Undefined - "100110" #Undefined - "100111" #Undefined - "101000" #Undefined - "101001" #Undefined - "101010" #Undefined - "101011" #Undefined - "101100" #Undefined - "101101" #Undefined - "101110" #Undefined - "101111" #Undefined - "110000" #Undefined - "110001" #Undefined - "110010" #Undefined - "110011" #Undefined - "110100" #Undefined - "110101" #Undefined - "110110" #Undefined - "110111" #Undefined - "111000" #Undefined - "111001" #Undefined - "111010" #Undefined - "111011" #Undefined - "111100" #Undefined - "111101" #Undefined - "111110" #Undefined - "111111" #SourcePointer - )! Item was removed: - ----- Method: CompiledMethodTrailer>>clear (in category 'initialize-release') ----- - clear - kind := #NoTrailer. - size := 1. - data := encodedData := method := nil! Item was removed: - ----- Method: CompiledMethodTrailer>>compiledMethodClass (in category 'creating a method') ----- - compiledMethodClass - "Allow subclasses to create instyances of classes other than CompiledMethod." - - ^CompiledMethod! Item was removed: - ----- Method: CompiledMethodTrailer>>copyToMethod: (in category 'creating a method') ----- - copyToMethod: aCompiledMethod - "Copy the encoded trailer data to aCompiledMethod. Answer aCompiledMethod." - | delta | - delta := aCompiledMethod size - self size. - 1 to: size do: - [:i | aCompiledMethod at: delta + i put: (encodedData at: i)]. - ^aCompiledMethod! Item was removed: - ----- Method: CompiledMethodTrailer>>createMethod:class:header: (in category 'creating a method') ----- - createMethod: numberOfBytesForAllButTrailer class: aCompiledMethodClass header: headerWord - "Answer a new compiled method of the given class, headerWord (which defines the number of literals) - and with the receiver asd its encoded trailer." - ^self copyToMethod: (aCompiledMethodClass newMethod: numberOfBytesForAllButTrailer + self size header: headerWord)! Item was removed: - ----- Method: CompiledMethodTrailer>>decodeClearedTrailer (in category 'decoding') ----- - decodeClearedTrailer - "Size is set in #decodeLengthField" - - self decodeLengthField. - ! Item was removed: - ----- Method: CompiledMethodTrailer>>decodeEmbeddedSourceQCompress (in category 'decoding') ----- - decodeEmbeddedSourceQCompress - - "data is string with method's source code, encoded using qCompress method" - self qDecompress.! Item was removed: - ----- Method: CompiledMethodTrailer>>decodeExtendedKind (in category 'encoding') ----- - decodeExtendedKind - - "reserved for future use" - self shouldBeImplemented. - ! Item was removed: - ----- Method: CompiledMethodTrailer>>decodeLengthField (in category 'private') ----- - decodeLengthField - - "used in various encodings, where length field is preceeding the last trailer byte. - Two least significant bits in last byte denoting the number of bytes for length field" - - | numBytes pos length | - - pos := method size. - numBytes := ((method at: pos) bitAnd: 3) + 1. - - length := 0. - 1 to: numBytes do: [:i | - length := length << 8 + (method at: pos - i ). - ]. - size := 1 + numBytes + length. - - ^ length! Item was removed: - ----- Method: CompiledMethodTrailer>>decodeNoTrailer (in category 'decoding') ----- - decodeNoTrailer - "Not much to decode here" - size := 1. ! Item was removed: - ----- Method: CompiledMethodTrailer>>decodeSourceBySelector (in category 'decoding') ----- - decodeSourceBySelector - - "no data, size = 1" - - size := 1.! Item was removed: - ----- Method: CompiledMethodTrailer>>decodeSourceByStringIdentifier (in category 'decoding') ----- - decodeSourceByStringIdentifier - - "A method source is determined by a class + string identifier" - | len | - - len := self decodeLengthField. - - data := (ReadStream on: method from: method size - size+1 to: method size - size + len) contents asString convertFromEncoding: 'utf8'! Item was removed: - ----- Method: CompiledMethodTrailer>>decodeSourcePointer (in category 'decoding') ----- - decodeSourcePointer - - "Trailer is a source pointer" - | msz | - - size := 4. - msz := method size. - data := (method at: msz) - 251 << 8 + (method at: msz-1) << 8 - + (method at: msz-2) << 8 + (method at: msz-3). - - ! Item was removed: - ----- Method: CompiledMethodTrailer>>decodeTempsNamesQCompress (in category 'decoding') ----- - decodeTempsNamesQCompress - - "data is string with method's temporary names, encoded using qCompress method" - self qDecompress.! Item was removed: - ----- Method: CompiledMethodTrailer>>decodeUndefined (in category 'decoding') ----- - decodeUndefined - self error: 'undefined method encoding'! Item was removed: - ----- Method: CompiledMethodTrailer>>decodeVarLengthSourcePointer (in category 'decoding') ----- - decodeVarLengthSourcePointer - - | pos shift | - - pos := method size-1. - shift := data := 0. - - [ | value | - value := method at: pos. - data := (value bitAnd: 16r7F) << shift + data. - pos := pos - 1. - shift := shift + 7. - value > 127 ] whileTrue. - - size := method size - pos.! Item was removed: - ----- Method: CompiledMethodTrailer>>encode (in category 'encoding') ----- - encode - - encodedData := nil. - - "encode the trailer into byte array" - self perform: ('encode' , kind) asSymbol. - - self assert: (encodedData notNil and: [encodedData size > 0 ]). - - "set the size" - size := encodedData size.! Item was removed: - ----- Method: CompiledMethodTrailer>>encodeClearedTrailer (in category 'encoding') ----- - encodeClearedTrailer - - "A cleared trailer is replaced by #NoTrailer, when used for encoding" - self clear. - kind := #NoTrailer. - - ^ self encode! Item was removed: - ----- Method: CompiledMethodTrailer>>encodeEmbeddedSourceQCompress (in category 'encoding') ----- - encodeEmbeddedSourceQCompress - - "data is string with method's source code, encode it using qCompress method" - self encodeUsingQCompress - ! Item was removed: - ----- Method: CompiledMethodTrailer>>encodeExtendedKind (in category 'encoding') ----- - encodeExtendedKind - - "reserved for future use" - self error: 'Not yet implemented'. - ! Item was removed: - ----- Method: CompiledMethodTrailer>>encodeLengthField: (in category 'private') ----- - encodeLengthField: integer - - | bytes value | - self assert: (integer > 0). - - value := integer. - - bytes := ByteArray streamContents: [:str | - [ value > 0 ] whileTrue: [ - str nextPut: (value bitAnd: 255). - value := value >> 8 ]]. - - "no more than 4 bytes for length field" - self assert: (bytes size <=4). - - ^ bytes! Item was removed: - ----- Method: CompiledMethodTrailer>>encodeNoTrailer (in category 'encoding') ----- - encodeNoTrailer - - encodedData := ByteArray with: self kindAsByte! Item was removed: - ----- Method: CompiledMethodTrailer>>encodeSourceBySelector (in category 'encoding') ----- - encodeSourceBySelector - - "A method source is determined by a class + selector where it is installed to" - encodedData := ByteArray with: self kindAsByte! Item was removed: - ----- Method: CompiledMethodTrailer>>encodeSourceByStringIdentifier (in category 'encoding') ----- - encodeSourceByStringIdentifier - - "A method source is determined by a class + string identifier" - - self assert: (data isString). - - encodedData := ByteArray streamContents: [:str | - | utf8str len | - utf8str := (data convertToEncoding: 'utf8') asByteArray. - str nextPutAll: utf8str. - len := self encodeLengthField: utf8str size. - str nextPutAll: len. - str nextPut: self kindAsByte + (len size -1) - ]! Item was removed: - ----- Method: CompiledMethodTrailer>>encodeSourcePointer (in category 'encoding') ----- - encodeSourcePointer - - encodedData := ByteArray new: 4. - encodedData at: 4 put: (data >> 24) + 251. - - 1 to: 3 do: [:i | - encodedData at: 4-i put: ((data bitShift: (i-3)*8) bitAnd: 16rFF)]! Item was removed: - ----- Method: CompiledMethodTrailer>>encodeTempsNamesQCompress (in category 'encoding') ----- - encodeTempsNamesQCompress - - "data is string with method's temporary names, encode it using qCompress method" - self encodeUsingQCompress - ! Item was removed: - ----- Method: CompiledMethodTrailer>>encodeUndefined (in category 'encoding') ----- - encodeUndefined - - self error: 'use of an undefined kind of trailer encoding'! Item was removed: - ----- Method: CompiledMethodTrailer>>encodeUsingQCompress (in category 'encoding') ----- - encodeUsingQCompress - - "data is string, encode it using qCompress method" - | str length encodedLength | - - self assert: data isString. - str := self qCompress: data. - length := str position. - encodedLength := self encodeLengthField: length. - - str nextPutAll: encodedLength. - "trailing byte" - str nextPut: (self kindAsByte + encodedLength size - 1). - - encodedData := str contents - ! Item was removed: - ----- Method: CompiledMethodTrailer>>encodeVarLengthSourcePointer (in category 'encoding') ----- - encodeVarLengthSourcePointer - - "source pointer must be >=0" - [data >= 0] assert. - - encodedData := - data = 0 ifTrue: [ #[0] ] - ifFalse: [ ByteArray streamContents: [:str | - | value | - value := data. - [value > 0] whileTrue: [ - value > 127 ifTrue: [ str nextPut: 128 + (value bitAnd: 16r7F) ] - ifFalse: [ str nextPut: value. ]. - value := value >> 7. - ]. - ]]. - encodedData := encodedData reversed copyWith: (self kindAsByte)! Item was removed: - ----- Method: CompiledMethodTrailer>>endPC (in category 'accessing') ----- - endPC - "Answer the index of the last bytecode." - - method ifNil: [ self error: 'Cannot determine the endPC without compiled method' ]. - - "if method set, then size should be set as well" - ^ method size - size! Item was removed: - ----- Method: CompiledMethodTrailer>>hasSourcePointer (in category 'testing') ----- - hasSourcePointer - ^ kind == #SourcePointer or: [ kind == #VarLengthSourcePointer ] ! Item was removed: - ----- Method: CompiledMethodTrailer>>hasTempNames (in category 'testing') ----- - hasTempNames - ^ kind == #TempsNamesQCompress or: [ kind == #TempsNamesZip ]! Item was removed: - ----- Method: CompiledMethodTrailer>>initialize (in category 'initialize-release') ----- - initialize - self clear! Item was removed: - ----- Method: CompiledMethodTrailer>>isEmpty (in category 'testing') ----- - isEmpty - ^ kind == #NoTrailer or: [ kind == #ClearedTrailer ]! Item was removed: - ----- Method: CompiledMethodTrailer>>kind (in category 'accessing') ----- - kind - "Answer a symbolic name of trailer kind. - See #trailerKinds on class side and class comment for details" - - ^ kind! Item was removed: - ----- Method: CompiledMethodTrailer>>kindAsByte (in category 'private') ----- - kindAsByte - | index | - index := self class trailerKinds indexOf: kind. - self assert: (index ~= 0). - - ^ (index - 1) << 2! Item was removed: - ----- Method: CompiledMethodTrailer>>method: (in category 'initialize-release') ----- - method: aMethod - - | flagByte index | - data := size := nil. - method := aMethod. - flagByte := method at: method size. - - "trailer kind encoded in 6 high bits of last byte" - index := flagByte >> 2 + 1. - kind := self class trailerKinds at: index. - - "decode the trailer bytes" - self perform: (self class trailerKindDecoders at: index). - - "after decoding the trailer, size must be set" - self assert: size notNil - - ! Item was removed: - ----- Method: CompiledMethodTrailer>>qCompress: (in category 'private') ----- - qCompress: string - "A very simple text compression routine designed for method temp names. - Most common 11 chars get values 1-11 packed in one 4-bit nibble; - the next most common get values 12-15 (2 bits) * 16 plus next nibble; - unusual ones get three nibbles, the first being the escape nibble 0. - - Answer the write stream with compressed data inside" - - | utf8str stream oddNibble | - - string isEmpty ifTrue: - [^self qCompress: ' ']. - utf8str := string convertToEncoding: 'utf8'. - - stream := WriteStream on: (ByteArray new: utf8str size). - oddNibble := nil. - - utf8str do: [:char | | ix | - ix := 'ear tonsilcmbdfghjkpquvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ012345[]()' - indexOf: char. - (ix = 0 - ifTrue: - [{ 0. char asInteger // 16. char asInteger \\ 16 }] - ifFalse: - [ix <= 11 - ifTrue: [{ ix }] - ifFalse: [{ ix//16+12. ix\\16 }]]) - do: [:nibble | - oddNibble - ifNotNil: [stream nextPut: oddNibble*16 + nibble. oddNibble := nil] - ifNil: [oddNibble := nibble]]]. - oddNibble ifNotNil: "4 = 'ear tonsil' indexOf: Character space" - [stream nextPut: oddNibble * 16 + 4]. - ^ stream - ! Item was removed: - ----- Method: CompiledMethodTrailer>>qDecompress (in category 'decoding') ----- - qDecompress - "Trailer is compressed string using qCompress method + length field + 1 byte - - Decompress strings compressed by qCompress:. - Most common 11 chars get values 0-10 packed in one 4-bit nibble; - next most common 52 get values 12-15 (2 bits) * 16 plus next nibble; - escaped chars get three nibbles" - | len str input | - - len := self decodeLengthField. - input := (ReadStream on: method from: method size - size+1 to: method size - size + len). - - str := String streamContents: - [:strm | | nextNibble nibble peek charTable | - charTable := "Character encoding table must match qCompress:" - 'ear tonsilcmbdfghjkpquvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ012345[]()'. - peek := true. - nextNibble := [peek - ifTrue: [peek := false. input peek ifNil: [0] ifNotNil: [:b| b // 16]] - ifFalse: [peek := true. input next ifNil: [0] ifNotNil: [:b| b \\ 16]]]. - [input atEnd] whileFalse: - [(nibble := nextNibble value) = 0 - ifTrue: [input atEnd ifFalse: - [strm nextPut: (Character value: nextNibble value * 16 + nextNibble value)]] - ifFalse: - [nibble <= 11 - ifTrue: - [strm nextPut: (charTable at: nibble)] - ifFalse: - [strm nextPut: (charTable at: nibble-12 * 16 + nextNibble value)]]]]. - - data := str convertFromEncoding: 'utf8'! Item was removed: - ----- Method: CompiledMethodTrailer>>setSourceBySelector (in category 'accessing') ----- - setSourceBySelector - - "Trailer is used to indicate that method's source code can be retrieved by - sending #getSourceCodeBySelector: message to method's class" - - self clear. - kind := #SourceBySelector! Item was removed: - ----- Method: CompiledMethodTrailer>>size (in category 'accessing') ----- - size - "Answer the size of method's trailer , in bytes" - encodedData ifNil: [self encode]. - ^size! Item was removed: - ----- Method: CompiledMethodTrailer>>sourceCode (in category 'accessing') ----- - sourceCode - "Answer the source code of compiled method. - Note: it does not attempts to read from source files using sourcePointer, - nor reconstruct the source code using temp names" - - (kind == #EmbeddedSourceQCompress or: [ kind == #EmbeddedSourceZip ]) ifTrue: [ - ^ data ]. - - kind == #SourceBySelector ifTrue: [ - ^ method methodClass getSourceCodeBySelector: method selector ]. - - kind == #SourceByStringIdentifier ifTrue: [ - ^ method methodClass getSourceCodeByIdentifier: data ]. - - ^ nil! Item was removed: - ----- Method: CompiledMethodTrailer>>sourceCode: (in category 'accessing') ----- - sourceCode: aString - "Embed the source code into compiled method trailer, - pick best compression method" - | temp | - self clear. - kind := #EmbeddedSourceQCompress. - data := aString asString. "add Text support in future?" - - self encode. - temp := encodedData. - - kind := #EmbeddedSourceZip. - self encode. - encodedData size > temp size ifTrue: [ - encodedData := temp. - kind := #EmbeddedSourceQCompress. - size := encodedData size. - ]! Item was removed: - ----- Method: CompiledMethodTrailer>>sourceIdentifier (in category 'accessing') ----- - sourceIdentifier - "Trailer is used to indicate that method's source code can be retrieved by - sending #getSourceCodeByIdentifier: message to method's class" - - ^ (kind == #SourceByStringIdentifier) ifTrue: [ data ] ifFalse: [ nil ]. - - ! Item was removed: - ----- Method: CompiledMethodTrailer>>sourceIdentifier: (in category 'accessing') ----- - sourceIdentifier: aString - - "Trailer is used to indicate that method's source code can be retrieved by - sending #getSourceCodeByIdentifier: message to method's class" - - self clear. - data := aString. - kind := #SourceByStringIdentifier. - self encode. - ! Item was removed: - ----- Method: CompiledMethodTrailer>>sourcePointer (in category 'accessing') ----- - sourcePointer - - ^ (kind == #SourcePointer or: [ kind == #VarLengthSourcePointer ] ) - ifTrue: [ data ] - ifFalse: [ 0 ] - ! Item was removed: - ----- Method: CompiledMethodTrailer>>sourcePointer: (in category 'accessing') ----- - sourcePointer: ptr - - self clear. - data := ptr. - "see if we can encode pointer using 4-byte trailer" - kind := (ptr between: 16r1000000 and: 16r4FFFFFF) - ifTrue: [ #SourcePointer ] ifFalse: [ #VarLengthSourcePointer ]. - ! Item was removed: - ----- Method: CompiledMethodTrailer>>tempNames (in category 'accessing') ----- - tempNames - "Answer the string, containing the temps names or nil " - ^ (kind == #TempsNamesQCompress or: [ kind == #TempsNamesZip ]) - ifTrue: [ data ] ifFalse: [ nil ]! Item was removed: - ----- Method: CompiledMethodTrailer>>tempNames: (in category 'accessing') ----- - tempNames: aString - "Embed the temp names string into compiled method trailer, - pick best compression method" - | temp | - self clear. - kind := #TempsNamesQCompress. - data := aString. - - self encode. - temp := encodedData. - - kind := #TempsNamesZip. - self encode. - encodedData size > temp size ifTrue: [ - encodedData := temp. - kind := #TempsNamesQCompress. - size := encodedData size. - ]! Item was removed: - ----- Method: CompiledMethodTrailer>>testEncoding (in category 'testing') ----- - testEncoding - - "Since we are using basic protocol (#at:, #at:put: , #size) for accessing compiled method data, - we can pass the ByteArray instance into #method: accessor and check if encoding/decoding - operations is symmetrical. - Use this method only for unit-testing purposes" - - encodedData ifNil: [ self encode ]. - ^ CompiledMethodTrailer new method: encodedData! Item was removed: - Object subclass: #Complex - instanceVariableNames: 'real imaginary' - classVariableNames: '' - poolDictionaries: '' - category: 'Kernel-Numbers'! - - !Complex commentStamp: 'mk 10/31/2003 22:19' prior: 0! - I represent a complex number. - - real -- real part of the complex number - imaginary -- imaginary part of the complex number - - Complex number constructors: - - 5 i - 6 + 7 i. - 5.6 - 8 i. - Complex real: 10 imaginary: 5. - Complex abs: 5 arg: (Float pi / 4) - - Arithmetic operation with other complex or non-complex numbers work. - - (5 - 6 i) + (-5 + 8 i). "Arithmetic between two complex numbers." - 5 * (5 - 6 i). "Arithmetic between a non-complex and a complex number." - - It is also possible to perform arithmetic operations between a complex number - and a array of (complex) numbers: - - 2 * {1 + 2i. - 3 + 4i. - 5 + 6i} - - 5 + 5i * {1 + 2i. - 3. - 5 + 6i} - - It behaves analogously as it is with normal numbers and an array. - - NOTE: Although Complex something similiar to the Smalltalk's Number class, it would - not be a good idea to make a Complex to be a subclass of a Number because: - - Number is subclass of Magnitude and Complex is certainly not a magnitude. - Complex does not behave very well as a Magnitude. Operations such as - < - > - <= - >= - do not have sense in case of complex numbers. - - Methods in the following Number methods' categories do not have sense for a Complex numbers - trucation and round off - testing - intervals - comparing - - However the following Number methods' categories do have sense for a Complex number - arithmetic (with the exception of operation - // - \\ - quo: - rem: - mathematical functions - - Thus Complex is somewhat similar to a Number but it is not a subclass of it. Some operations - we would like to inherit (e.g. #abs, #negated, #reciprocal) but some of the Number operation - do not have sens to inherit or to overload. Classes are not always neat mechanism. - - !!!!!! We had to COPY the implementation of the - abs - negated - reciprocal - log: - isZero - reciprocal - ... - methods from the Number class to the Complex class. Awful solution. Now I begin to - appreciate the Self. - - Missing methods - String | converting | asComplex - Complex | mathematical functions | arcSin - Complex | mathematical functions | arcCos - Complex | mathematical functions | arcTan! Item was removed: - ----- Method: Complex class>>abs:arg: (in category 'instance creation') ----- - abs: aNumber1 arg: aNumber2 - ^self - real: aNumber1 * aNumber2 cos - imaginary: aNumber1 * aNumber2 sin! Item was removed: - ----- Method: Complex class>>new (in category 'instance creation') ----- - new - ^ self real: 0 imaginary: 0! Item was removed: - ----- Method: Complex class>>one (in category 'instance creation') ----- - one - ^ self real: 1 imaginary: 0! Item was removed: - ----- Method: Complex class>>real:imaginary: (in category 'instance creation') ----- - real: aNumber1 imaginary: aNumber2 - ^self basicNew real: aNumber1 imaginary: aNumber2! Item was removed: - ----- Method: Complex class>>zero (in category 'instance creation') ----- - zero - ^ self real: 0 imaginary: 0! Item was removed: - ----- Method: Complex>>* (in category 'arithmetic') ----- - * anObject - "Answer the result of multiplying the receiver by aNumber." - | a b c d x y newReal newImaginary | - anObject isComplex - ifTrue: - [a := self real. - b := self imaginary. - c := anObject real. - d := anObject imaginary. - newReal := (a * c) - (b * d). - newImaginary := (a * d) + (b * c). - ((newReal isFinite not or: [newImaginary isFinite not]) and: [self isZero not and: [anObject isZero not]]) - ifTrue: - ["intermediate computations do overflow, but the product may be finite, retry with scaling" - x := a abs max: b abs. - y := c abs max: d abs. - a := a / x. - b := b / x. - c := c / y. - d := d / y. - newReal := (a * c) - (b * d) * x * y. - newImaginary := (a * d) + (b * c) * x * y]. - ^ Complex real: newReal imaginary: newImaginary] - ifFalse: - [^ anObject adaptToComplex: self andSend: #*]! Item was removed: - ----- Method: Complex>>+ (in category 'arithmetic') ----- - + anObject - "Answer the sum of the receiver and aNumber." - | a b c d newReal newImaginary | - anObject isComplex - ifTrue: - [a := self real. - b := self imaginary. - c := anObject real. - d := anObject imaginary. - newReal := a + c. - newImaginary := b + d. - ^ Complex real: newReal imaginary: newImaginary] - ifFalse: - [^ anObject adaptToComplex: self andSend: #+]! Item was removed: - ----- Method: Complex>>- (in category 'arithmetic') ----- - - anObject - "Answer the difference between the receiver and aNumber." - | a b c d newReal newImaginary | - anObject isComplex - ifTrue: - [a := self real. - b := self imaginary. - c := anObject real. - d := anObject imaginary. - newReal := a - c. - newImaginary := b - d. - ^ Complex real: newReal imaginary: newImaginary] - ifFalse: - [^ anObject adaptToComplex: self andSend: #-]! Item was removed: - ----- Method: Complex>>/ (in category 'arithmetic') ----- - / anObject - "Answer the result of dividing receiver by aNumber" - | a b c d newReal newImaginary denom | - anObject isComplex ifTrue: - [a := self real. - b := self imaginary. - c := anObject real. - d := anObject imaginary. - denom := c squared + d squared. - [newReal := ((a * c) + (b * d)) / denom. - newImaginary := ((b * c) - (a * d)) / denom] - on: ZeroDivide do: - [:exc | - "This might be a case of underflow - resume with a value that will result in a secured retry" - exc resume: Float infinity]. - (denom isFinite and: [newReal isFinite and: [newImaginary isFinite]]) - ifFalse: - ["case of overflow, retry securedly" - ^self divideSecureBy: anObject]. - ^ Complex real: newReal imaginary: newImaginary]. - ^ anObject adaptToComplex: self andSend: #/.! Item was removed: - ----- Method: Complex>>= (in category 'comparing') ----- - = anObject - anObject isNumber ifFalse: [^false]. - anObject isComplex - ifTrue: [^ (real = anObject real) & (imaginary = anObject imaginary)] - ifFalse: [^ anObject adaptToComplex: self andSend: #=]! Item was removed: - ----- Method: Complex>>abs (in category 'arithmetic') ----- - abs - "Answer the distance of the receiver from zero (0 + 0 i)." - - ^ ((real * real) + (imaginary * imaginary)) sqrt! Item was removed: - ----- Method: Complex>>absSecure (in category 'arithmetic') ----- - absSecure - "Answer the distance of the receiver from zero (0 + 0 i). - Try avoiding overflow and/or underflow" - - | scale | - scale := real abs max: imaginary abs. - ^scale isZero - ifTrue: [scale] - ifFalse: [(self class real: real / scale imaginary: imaginary / scale) squaredNorm sqrt * scale]! Item was removed: - ----- Method: Complex>>adaptToCollection:andSend: (in category 'converting') ----- - adaptToCollection: rcvr andSend: selector - "If I am involved in arithmetic with a Collection, return a Collection of - the results of each element combined with me in that expression." - - ^ rcvr collect: [:element | element perform: selector with: self]! Item was removed: - ----- Method: Complex>>adaptToFloat:andSend: (in category 'converting') ----- - adaptToFloat: rcvr andSend: selector - "If I am involved in arithmetic with a Float, convert it to a Complex number." - ^ rcvr asComplex perform: selector with: self! Item was removed: - ----- Method: Complex>>adaptToFraction:andSend: (in category 'converting') ----- - adaptToFraction: rcvr andSend: selector - "If I am involved in arithmetic with a Fraction, convert it to a Complex number." - ^ rcvr asComplex perform: selector with: self! Item was removed: - ----- Method: Complex>>adaptToInteger:andSend: (in category 'converting') ----- - adaptToInteger: rcvr andSend: selector - "If I am involved in arithmetic with an Integer, convert it to a Complex number." - ^ rcvr asComplex perform: selector with: self! Item was removed: - ----- Method: Complex>>arCosh (in category 'mathematical functions') ----- - arCosh - "Answer receiver's area hyperbolic cosine. - That is the inverse function of cosh. - Some possible implementations: - ^imaginary > 0 - ifTrue: [(self + (self * self - 1) sqrt) ln] - ifFalse: [(self + (self * self - 1) sqrt) ln negated] - ^self arcCos i - This implementation provides an answer with a positive real part. - It also avoids creating intermediate Complex." - - | x y tmp sh2x shx delta ch2x chx | - imaginary = 0 ifTrue: [real abs > 1 - ifTrue: - [y := real < 0 - ifTrue: [Float pi] - ifFalse: [0]. - x := real abs arCosh. - ^self class real: x imaginary: y] - ifFalse: [^self class real: 0 imaginary: real arcCos]]. - tmp := self squaredNorm - 1 / 2. - delta := tmp squared + imaginary squared. - sh2x := tmp + delta sqrt. - shx := sh2x sqrt. - ch2x := 1 + sh2x. - chx := ch2x sqrt. - x := shx arSinh. - y := imaginary copySignTo: (real / chx) arcCos. - ^self class real: x imaginary: y! Item was removed: - ----- Method: Complex>>arSinh (in category 'mathematical functions') ----- - arSinh - "Answer receiver's area hyperbolic sine. - That is the inverse function of sinh." - - "Some possible implementation: - - ^imaginary * real < 0 - ifTrue: [(self + (self * self + 1) sqrt) ln] - ifFalse: [(self - (self * self + 1) sqrt) ln]" - - ^self i arcSin i negated! Item was removed: - ----- Method: Complex>>arTanh (in category 'mathematical functions') ----- - arTanh - "Answer receiver's area hyperbolic tangent. - That is the inverse function of tanh." - - "Some other possible implementation: - - ^((1 + self) / (1 - self)) ln / 2" - - ^self i arcTan i negated! Item was removed: - ----- Method: Complex>>arcCos (in category 'mathematical functions') ----- - arcCos - "Answer the arc cosine of the receiver. - This is the inverse function of cos." - - | x y tmp sh2y shy delta ch2y chy | - imaginary = 0 ifTrue: [real abs > 1 - ifTrue: - [x := real < 0 - ifTrue: [Float pi] - ifFalse: [0]. - y := real copySignTo: real abs arCosh. - ^self class real: x imaginary: y] - ifFalse: [^self class real: real arcCos imaginary: 0]]. - tmp := self squaredNorm - 1 / 2. - delta := tmp squared + imaginary squared. - sh2y := tmp + delta sqrt. - shy := sh2y sqrt. - ch2y := 1 + sh2y. - chy := ch2y sqrt. - y := imaginary copySignTo: shy arSinh. - x := (real / chy) arcCos. - ^self class real: x imaginary: y negated! Item was removed: - ----- Method: Complex>>arcSin (in category 'mathematical functions') ----- - arcSin - "Answer the arc sine of the receiver. - This is the inverse function of sin." - - | x y tmp delta sh2y shy ch2y chy | - imaginary = 0 - ifTrue: - [real abs > 1 - ifTrue: - [x := Float pi / 2 * real sign. - y := (real copySignTo: real abs arCosh) negated. - ^self class real: x imaginary: y] - ifFalse: [^self class real: real arcSin imaginary: 0]]. - tmp := (self squaredNorm - 1) / 2. - delta := tmp squared + imaginary squared. - sh2y := tmp + delta sqrt. - shy := sh2y sqrt. - ch2y := 1 + sh2y. - chy := ch2y sqrt. - y := imaginary copySignTo: shy arSinh. - x := (real / chy) arcSin. - ^self class real: x imaginary: y! Item was removed: - ----- Method: Complex>>arcTan (in category 'mathematical functions') ----- - arcTan - "Answer the arc tangent of the receiver. - This is the inverse function of tan." - - | r2 | - r2 := self squaredNorm. - ^self class - real: (real * 2 arcTan: 1 - r2) / 2 - imaginary: ((r2 + (imaginary * 2) + 1) / (r2 - (imaginary * 2) + 1)) ln / 4! Item was removed: - ----- Method: Complex>>arcTan: (in category 'mathematical functions') ----- - arcTan: denominator - "Answer the four quadrants arc tangent of receiver over denominator." - - ^denominator isZero - ifTrue: - [self isZero - ifTrue: - ["shouldn't it be an error ? ^DomainError signal: '0 arcTan: 0'" - ^self class real: 0 imaginary: 0] - ifFalse: - [self class - real: Float pi / (real copySignTo: 2) - imaginary: 0]] - ifFalse: - [| res | - res := (self / denominator) arcTan. - denominator real < 0 ifTrue: [res := res + Float pi]. - res real > Float pi - ifTrue: [res := res - (Float pi * 2)]. - res]! Item was removed: - ----- Method: Complex>>arg (in category 'arithmetic') ----- - arg - "Answer the argument of the receiver." - - self isZero ifTrue: [self error: 'zero has no argument.']. - ^imaginary arcTan: real! Item was removed: - ----- Method: Complex>>asComplex (in category 'converting') ----- - asComplex - ^self! Item was removed: - ----- Method: Complex>>conjugated (in category 'arithmetic') ----- - conjugated - "Return the complex conjugate of this complex number." - - ^self class real: real imaginary: imaginary negated! Item was removed: - ----- Method: Complex>>cos (in category 'mathematical functions') ----- - cos - "Answer receiver's cosine." - - ^self i cosh! Item was removed: - ----- Method: Complex>>cosh (in category 'mathematical functions') ----- - cosh - "Answer receiver's hyperbolic cosine. - Hyperbolic cosine is defined by same power serie expansion as for real numbers, that is in term of exponential: - ^ (self exp + self negated exp) / 2. - This implementation avoids creating intermediate objects." - - ^self class - real: real cosh * imaginary cos - imaginary: real sinh * imaginary sin! Item was removed: - ----- Method: Complex>>divideFastAndSecureBy: (in category 'arithmetic') ----- - divideFastAndSecureBy: anObject - "Answer the result of dividing receiver by aNumber" - " Both operands are scaled to avoid arithmetic overflow. - This algorithm works for a wide range of values, and it needs only three divisions. - Note: #reciprocal uses #/ for devision " - - | r d newReal newImaginary | - anObject isComplex ifTrue: - [anObject real abs > anObject imaginary abs - ifTrue: - [r := anObject imaginary / anObject real. - d := r*anObject imaginary + anObject real. - newReal := r*imaginary + real/d. - newImaginary := r negated * real + imaginary/d. - ] - ifFalse: - [r := anObject real / anObject imaginary. - d := r*anObject real + anObject imaginary. - newReal := r*real + imaginary/d. - newImaginary := r*imaginary - real/d. - ]. - - ^ Complex real: newReal imaginary: newImaginary]. - ^ anObject adaptToComplex: self andSend: #/.! Item was removed: - ----- Method: Complex>>divideSecureBy: (in category 'arithmetic') ----- - divideSecureBy: anObject - "Answer the result of dividing receiver by aNumber" - " Both operands are scaled to avoid arithmetic overflow. This algorithm - works for a wide range of values, but it requires six divisions. - #divideFastAndSecureBy: is also quite good, but it uses only 3 divisions. - Note: #reciprocal uses #/ for division" - - | s ars ais brs bis newReal newImaginary | - anObject isComplex ifTrue: - [s := anObject real abs max: anObject imaginary abs. - ars := self real / s. - ais := self imaginary / s. - brs := anObject real / s. - bis := anObject imaginary / s. - s := brs squared + bis squared. - brs := brs / s. - bis := bis / s. - - newReal := ars*brs + (ais*bis). - newImaginary := ais*brs - (ars*bis). - ^ Complex real: newReal imaginary: newImaginary]. - ^ anObject adaptToComplex: self andSend: #/.! Item was removed: - ----- Method: Complex>>exp (in category 'mathematical functions') ----- - exp - "Answer the exponential of the receiver." - - ^ real exp * (imaginary cos + imaginary sin i)! Item was removed: - ----- Method: Complex>>hash (in category 'comparing') ----- - hash - "Hash is reimplemented because = is implemented." - - ^ real hash bitXor: imaginary hash.! Item was removed: - ----- Method: Complex>>i (in category 'arithmetic') ----- - i - "Answer the result of multiplying the receiver with pure imaginary. - ^self * 1 i - This is an obvious extension of method i implemented in Number." - - ^self class real: imaginary negated imaginary: real! Item was removed: - ----- Method: Complex>>imaginary (in category 'accessing') ----- - imaginary - ^ imaginary! Item was removed: - ----- Method: Complex>>isComplex (in category 'testing') ----- - isComplex - ^ true! Item was removed: - ----- Method: Complex>>isNumber (in category 'testing') ----- - isNumber - ^ true! Item was removed: - ----- Method: Complex>>isZero (in category 'testing') ----- - isZero - ^ real isZero and: [imaginary isZero]! Item was removed: - ----- Method: Complex>>ln (in category 'mathematical functions') ----- - ln - "Answer the natural log of the receiver." - - ^ self abs ln + self arg i! Item was removed: - ----- Method: Complex>>log: (in category 'mathematical functions') ----- - log: aNumber - "Answer the log base aNumber of the receiver." - - ^self ln / aNumber ln! Item was removed: - ----- Method: Complex>>negated (in category 'arithmetic') ----- - negated - "Answer a Number that is the negation of the receiver." - - ^self class real: real negated imaginary: imaginary negated! Item was removed: - ----- Method: Complex>>printOn: (in category 'printing') ----- - printOn: aStream - real printOn: aStream. - aStream nextPut: Character space. - imaginary signBit = 0 - ifTrue: [aStream nextPut: $+] - ifFalse: [aStream nextPut: $-]. - aStream nextPut: Character space. - imaginary abs printOn: aStream. - aStream nextPut: Character space. - aStream nextPut: $i - ! Item was removed: - ----- Method: Complex>>printOn:showingDecimalPlaces: (in category 'printing') ----- - printOn: aStream showingDecimalPlaces: placesDesired - real printOn: aStream showingDecimalPlaces: placesDesired. - aStream nextPut: Character space. - imaginary signBit = 0 - ifTrue: [aStream nextPut: $+] - ifFalse: [aStream nextPut: $-]. - aStream nextPut: Character space. - imaginary abs printOn: aStream showingDecimalPlaces: placesDesired. - aStream nextPut: Character space. - aStream nextPut: $i - ! Item was removed: - ----- Method: Complex>>raisedTo: (in category 'mathematical functions') ----- - raisedTo: aNumber - "Answer the receiver raised to aNumber." - - aNumber isInteger ifTrue: - ["Do the special case of integer power" - ^ self raisedToInteger: aNumber]. - - 0 = aNumber ifTrue: [^ self class one]. "Special case of exponent=0" - 1 = aNumber ifTrue: [^ self]. "Special case of exponent=1" - 0 = self ifTrue: [ "Special case of self = 0" - aNumber < 0 - ifTrue: [^ (ZeroDivide dividend: self) signal] - ifFalse: [^ self]]. - ^ (aNumber * self ln) exp "Otherwise use logarithms"! Item was removed: - ----- Method: Complex>>raisedToInteger: (in category 'mathematical functions') ----- - raisedToInteger: operand - "Answer the receiver raised to the power operand, an Integer." - - "implementation note: this code is copied from Number. - This suggest that both Number and Complex should have an - ArithmeticValue common superclass like in Visualworks. - Or maybe should it be a Traits (a property of fields ?)" - - | count result | - operand isInteger ifFalse: [^ ArithmeticError signal: 'parameter is not an Integer']. - operand = 0 ifTrue: [^ self class one]. - operand = 1 ifTrue: [^ self]. - operand < 0 ifTrue: [^ (self raisedToInteger: operand negated) reciprocal]. - count := 1 bitShift: (operand-1) highBit. - result := self class one. - [count > 0] - whileTrue: - [result := result squared. - (operand bitAnd: count) - = 0 ifFalse: [result := result * self]. - count := count bitShift: -1]. - ^ result! Item was removed: - ----- Method: Complex>>real (in category 'accessing') ----- - real - ^ real! Item was removed: - ----- Method: Complex>>real:imaginary: (in category 'private') ----- - real: aNumber1 imaginary: aNumber2 - "Private - initialize the real and imaginary parts of a Complex" - real := aNumber1. - imaginary := aNumber2.! Item was removed: - ----- Method: Complex>>reciprocal (in category 'arithmetic') ----- - reciprocal - "Answer 1 divided by the receiver. Create an error notification if the - receiver is 0." - - self = 0 - ifTrue: [^ (ZeroDivide dividend: 1) signal] - ifFalse: [^1 / self] - ! Item was removed: - ----- Method: Complex>>sin (in category 'mathematical functions') ----- - sin - "Answer receiver's sine." - - ^self i sinh i negated! Item was removed: - ----- Method: Complex>>sinh (in category 'mathematical functions') ----- - sinh - "Answer receiver's hyperbolic sine. - Hyperbolic sine is defined by same power serie expansion as for real numbers, that is in term of exponential: - ^ (self exp - self negated exp) / 2. - This implementation avoids creating intermediate objects." - - ^self class - real: real sinh * imaginary cos - imaginary: real cosh * imaginary sin! Item was removed: - ----- Method: Complex>>sqrt (in category 'mathematical functions') ----- - sqrt - "Return the square root of the receiver with a positive real part. - This is the same as (Complex abs: self abs sqrt arg: self arg / 2). - Implementation notes: - the formulation used ensure a protection against floating point overflow/underflow. - it also result in a reasonable precision (around 3 ulp). - It is inspired by following reference, except that it uses pre-scaling rather than eception handling: - Implementing Complex Elementary Function Using Exception Handling - ACM Transactions on Mathematical Software - October 1994 - Ping Tang and 3 other authors" - - | x y r s t scale | - real isZero - ifTrue: - [t := imaginary abs sqrt / 2 sqrt. - ^self class real: t imaginary: (imaginary copySignTo: t)]. - scale := real abs max: imaginary abs. - x := real / scale. - y := imaginary / scale. - r := (x squared + y squared) sqrt. - s := scale sqrt. - t := (r + x abs * 2) sqrt. - ^real > 0 - ifTrue: [self class real: t * s / 2 imaginary: y * s / t] - ifFalse: [self class real: y abs * s / t imaginary: (y copySignTo: t * s / 2)]! Item was removed: - ----- Method: Complex>>squared (in category 'mathematical functions') ----- - squared - "Answer the receiver multipled by itself." - - ^self * self! Item was removed: - ----- Method: Complex>>squaredNorm (in category 'arithmetic') ----- - squaredNorm - "Answer the square of receiver norm." - - ^real * real + (imaginary * imaginary)! Item was removed: - ----- Method: Complex>>stringForReadout (in category 'printing') ----- - stringForReadout - - ^ String streamContents: [:stream | - self printOn: stream showingDecimalPlaces: 0]! Item was removed: - ----- Method: Complex>>tan (in category 'mathematical functions') ----- - tan - "Answer receivers tangent." - - ^ self sin / self cos! Item was removed: - ----- Method: Complex>>tanh (in category 'mathematical functions') ----- - tanh - "Answer receiver's hyperbolic tangent." - - "Some possible implementation are: - - ^self sinh / self cosh - - | tr ti | - tr := real tanh. - ti := imaginary tan i. - ^(tr + ti) / (tr * ti + 1)" - - ^self i tan i negated! Item was removed: - InstructionStream variableSubclass: #Context - instanceVariableNames: 'stackp method closureOrNil receiver' - classVariableNames: 'MaxLengthForASingleDebugLogReport MaxStackDepthForASingleDebugLogReport PrimitiveFailToken QuickStep ValueIndex' - poolDictionaries: '' - category: 'Kernel-Methods'! - - !Context commentStamp: 'eem 4/4/2017 17:45' prior: 0! - My instances hold all the dynamic state associated with the execution of either a method activation resulting from a message send or a block activation resulting from a block evaluation. In addition to their inherited state, this includes the receiver (self), the closure for a BlockClosure activation (which is nil for a method activation), a CompiledMethod, and space in the variable part of the context for arguments, temporary variables, and intermediate results, and the stack pointer to the top of stack in this variable part. - - Contexts are created automatically (at least conceptually (*)) whenever a message send activates a method, or a block evaluation activates a block. The current context can always be accessed via the thisContext pseudo-variable. For example, explore the following: - { thisContext. thisContext copy. thisContext method. thisContext pc. thisContext receiver. thisContext stackPtr. thisContext sender }. - - Contexts refer to the context in which they were created via the sender inst var. An execution stack is made up of of a linked list of contexts, linked through their sender inst var. Returning involves returning back to the sender. When a context is returned from its sender and pc are nilled, and, if the context is still referred to, the virtual machine guarantees to preserve only the arguments after a return. A Smalltalk Process is simply a chain of contexts specific to that process. The debugger is essentially a Process inspector. Stepping in the debugger is done by sending messages to contexts to get them to execute their bytecodes. See methods in the instruction decoding protocol. - - Contexts, though normal in their variable size, are actually only used in two sizes, small and large, which are determined by the temporary space required by the method being executed. - - Contexts must only be created using the method newForMethod:. Note that it is impossible to determine the real object size of a Context except by asking for the frameSize of its method. Any fields above the stack pointer (stackp) are truly invisible -- even (and especially!!) to the garbage collector. Any store into stackp other than by the primitive method stackp: is potentially fatal. - - (*) efficient virtual machines create contexts lazily on demand, avoiding the overhead of creating them on every message send and of copying receiver and arguments from sender context to caller context. This optimization is invisible to the Smalltalk system.! Item was removed: - ----- Method: Context 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 removed: - ----- Method: Context 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." - inst := self someInstance. - [inst == thisContext or: [inst == nil]] whileFalse: - [next := inst nextInstance. - aBlock value: inst. - inst := next]! Item was removed: - ----- Method: Context class>>basicNew: (in category 'instance creation') ----- - basicNew: size - ^ (size = CompiledMethod smallFrameSize or: [ size = CompiledMethod fullFrameSize ]) - ifTrue: [ super basicNew: size ] - ifFalse: [ self error: 'Contexts must be ' , CompiledMethod smallFrameSize , ' or ' , CompiledMethod fullFrameSize , ' bytes.' ]! Item was removed: - ----- Method: Context class>>carefullyPrint:on: (in category 'private') ----- - carefullyPrint: anObject on: aStream - aStream nextPutAll: ([anObject printString] - on: Error - do: ['unprintable ' , anObject class name])! Item was removed: - ----- Method: Context class>>contextEnsure: (in category 'special context creation') ----- - contextEnsure: block - "Create an #ensure: context that is ready to return from executing its receiver. - - As ctxt is *not* a top context as required by #jump, we need to put a (fake) return value (nil) on its stack. Otherwise, #jump will pop something different from the stack. Concretely, this caused the bug described in [1] (Scenario 1) because the latest stack top was the closure vector {chain}. This closure vector was accidently popped away so that in the final return statement, #pushRemoteTemp:inVectorAt: raised an error subscript bounds (because the next stack item was not variable). Read the linked bug report for more details. - - [1] http://forum.world.st/BUG-s-in-Context-control-jump-runUntilErrorOrReturnFrom-td5107263.html" - - | ctxt chain | - ctxt := thisContext. - [chain := thisContext sender cut: ctxt. - ctxt push: nil. "fake return value" - ctxt jump] ensure: block. - "jump above will resume here without unwinding chain" - ^ chain! Item was removed: - ----- Method: Context class>>contextOn:do: (in category 'special context creation') ----- - contextOn: exceptionClass do: block - "Create an #on:do: context that is ready to return from executing its receiver. - - As ctxt is *not* a top context as required by #jump, we need to put a (fake) return value (nil) on its stack. Otherwise, #jump will pop something different from the stack. Concretely, this caused the bug described in [1] (Scenario 1) because the latest stack top was the closure vector {chain}. This closure vector was accidently popped away so that in the final return statement, #pushRemoteTemp:inVectorAt: raised an error subscript bounds (because the next stack item was not variable). Read the linked bug report for more details. - - [1] http://forum.world.st/BUG-s-in-Context-control-jump-runUntilErrorOrReturnFrom-td5107263.html" - - | ctxt chain | - ctxt := thisContext. - [chain := thisContext sender cut: ctxt. - ctxt push: nil. "fake return value" - ctxt jump] on: exceptionClass do: block. - "jump above will resume here without unwinding chain" - ^ chain! Item was removed: - ----- Method: Context class>>initialize (in category 'class initialization') ----- - initialize - ValueIndex := 2. - self assert: (Association instVarNameForIndex:ValueIndex) = 'value'. - PrimitiveFailToken class ~~ Object ifTrue: - [PrimitiveFailToken := Object new]! Item was removed: - ----- Method: Context class>>initializedInstance (in category 'instance creation') ----- - initializedInstance - ^ nil! Item was removed: - ----- Method: Context class>>isContextClass (in category 'private') ----- - isContextClass - ^true! Item was removed: - ----- Method: Context class>>maxLengthForASingleDebugLogReport (in category 'preferences') ----- - maxLengthForASingleDebugLogReport - <preference: 'Max. Debug Report Length' - category: 'debug' - description: 'The description of an Exception stack will be truncated so as to not exceed this value' - type: #Number> - ^MaxLengthForASingleDebugLogReport ifNil: [40000]! Item was removed: - ----- Method: Context class>>maxLengthForASingleDebugLogReport: (in category 'preferences') ----- - maxLengthForASingleDebugLogReport: anInteger - MaxLengthForASingleDebugLogReport := anInteger! Item was removed: - ----- Method: Context class>>maxStackDepthForASingleDebugLogReport (in category 'preferences') ----- - maxStackDepthForASingleDebugLogReport - <preference: 'Max. Debug Report Stack Depth' - category: 'debug' - description: 'In an exception stack, any sender deeper than this value will not be logged.' - type: #Number> - ^MaxStackDepthForASingleDebugLogReport ifNil: [60]! Item was removed: - ----- Method: Context class>>maxStackDepthForASingleDebugLogReport: (in category 'preferences') ----- - maxStackDepthForASingleDebugLogReport: anInteger - MaxStackDepthForASingleDebugLogReport := anInteger! Item was removed: - ----- Method: Context class>>new (in category 'instance creation') ----- - new - - self error: 'Contexts must only be created with newForMethod:'! Item was removed: - ----- Method: Context class>>new: (in category 'instance creation') ----- - new: size - - self error: 'Contexts must only be created with newForMethod:'! Item was removed: - ----- Method: Context class>>newForMethod: (in category 'instance creation') ----- - newForMethod: aMethod - "This is the only method for creating new contexts, other than primitive cloning. - Any other attempts, such as inherited methods like shallowCopy, should be - avoided or must at least be rewritten to determine the proper size from the - method being activated. This is because asking a context its size (even basicSize!!) - will not return the real object size but only the number of fields currently - accessible, as determined by stackp." - - ^ super basicNew: aMethod frameSize! Item was removed: - ----- Method: Context class>>primitiveFailToken (in category 'simulation') ----- - primitiveFailToken - - ^ PrimitiveFailToken! Item was removed: - ----- Method: Context class>>primitiveFailTokenFor: (in category 'simulation') ----- - primitiveFailTokenFor: errorCode - - ^{PrimitiveFailToken. errorCode}! Item was removed: - ----- Method: Context class>>runSimulated: (in category 'simulation') ----- - runSimulated: aBlock - "Simulate the execution of aBlock, until it ends or is curtailed. Answer the result it returns." - - ^thisContext - runSimulated: aBlock - contextAtEachStep: [] - - "Context runSimulated: [Pen new ifNotNil: [:pen| pen defaultNib: 5. 4 timesRepeat: [pen go: 100; turn: 90]]]" - - "Here's a fun example, reaching into the computation to squash the Display>>fillWhite that mandala: begins with..." - "thisContext - runSimulated: [Pen new mandala: 45] - contextAtEachStep: [:ctxt| ctxt selector == #fillWhite ifTrue: [ctxt scanFor: [:ign| ctxt willReturn]]]"! Item was removed: - ----- Method: Context class>>sender:receiver:method:arguments: (in category 'instance creation') ----- - sender: s receiver: r method: m arguments: args - "Answer an instance of me with attributes set to the arguments." - - ^(self newForMethod: m) setSender: s receiver: r method: m arguments: args! Item was removed: - ----- Method: Context class>>tallyInstructions: (in category 'examples') ----- - tallyInstructions: aBlock - "This method uses the simulator to count the number of occurrences of - each of the Smalltalk instructions executed during evaluation of aBlock. - Results appear in order of the byteCode set." - | tallies | - tallies := Bag new. - thisContext - runSimulated: aBlock - contextAtEachStep: - [:current | tallies add: current nextByte]. - ^tallies sortedElements - - "Context tallyInstructions: [3.14159 printString]"! Item was removed: - ----- Method: Context class>>tallyMethods: (in category 'examples') ----- - tallyMethods: aBlock - "This method uses the simulator to count the number of calls on each method - invoked in evaluating aBlock. Results are given in order of decreasing counts." - | prev tallies | - tallies := Bag new. - prev := aBlock. - thisContext - runSimulated: aBlock - contextAtEachStep: - [:current | - current == prev ifFalse: "call or return" - [prev sender == nil ifFalse: "call only" - [tallies add: current printString]. - prev := current]]. - ^tallies sortedCounts - - "Context tallyMethods: [3.14159 printString]"! Item was removed: - ----- Method: Context class>>theReturnMethod (in category 'special context creation') ----- - theReturnMethod - - | meth | - meth := self lookupSelector: #return:. - meth primitive = 0 ifFalse: [^ self error: 'expected #return: to not be a primitive']. - ^ meth! Item was removed: - ----- Method: Context class>>trace: (in category 'examples') ----- - trace: aBlock "Context trace: [3 factorial]" - "This method uses the simulator to print calls and returned values in the Transcript." - - Transcript clear. - ^ self trace: aBlock on: Transcript! Item was removed: - ----- Method: Context class>>trace:on: (in category 'examples') ----- - trace: aBlock on: aStream "Context trace: [3 factorial]" - "This method uses the simulator to print calls to a file." - | prev | - prev := aBlock. - ^thisContext - runSimulated: aBlock - contextAtEachStep: - [:current | - Sensor anyButtonPressed ifTrue: [^nil]. - current == prev ifFalse: - [prev sender ifNil: - [aStream space; nextPut: $^. - self carefullyPrint: current top on: aStream]. - aStream cr. - (current depthBelow: aBlock) timesRepeat: [aStream space]. - self carefullyPrint: current receiver on: aStream. - aStream space; nextPutAll: current selector; flush. - prev := current]]! Item was removed: - ----- Method: Context class>>trace:onFileNamed: (in category 'examples') ----- - trace: aBlock onFileNamed: fileName - "Context trace: [3 factorial] onFileNamed: 'trace'" - "This method uses the simulator to print calls to a file." - - ^FileStream fileNamed: fileName do: [ :file | - self trace: aBlock on: file ]! Item was removed: - ----- Method: Context>>aboutToReturn:through: (in category 'private') ----- - aboutToReturn: result through: firstUnwindContext - "Called from VM when an unwindBlock is found between self and its home. - Return to home's sender, executing unwind blocks on the way." - - self methodReturnContext return: result through: firstUnwindContext! Item was removed: - ----- Method: Context>>activateMethod:withArgs:receiver: (in category 'controlling') ----- - activateMethod: newMethod withArgs: args receiver: rcvr - "Answer a Context initialized with the arguments." - - ^Context - sender: self - receiver: rcvr - method: newMethod - arguments: args! Item was removed: - ----- Method: Context>>activateMethod:withArgs:receiver:class: (in category 'controlling') ----- - activateMethod: newMethod withArgs: args receiver: rcvr class: class - - self deprecated. - ^ self activateMethod: newMethod withArgs: args receiver: rcvr! Item was removed: - ----- Method: Context>>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" - - ^Context - sender: self - receiver: aContext - method: Context theReturnMethod - arguments: {value}! Item was removed: - ----- Method: Context>>activeHome (in category 'accessing') ----- - activeHome - "If executing closure, search senders for the activation of the original - (outermost) method that (indirectly) created my closure (the closureHome). - If the closureHome is not found on the sender chain answer nil." - - | methodReturnContext | - self isExecutingBlock ifFalse: [^self]. - self sender ifNil: [^nil]. - methodReturnContext := self methodReturnContext. - ^self sender findContextSuchThat: [:ctxt | ctxt = methodReturnContext]! Item was removed: - ----- Method: Context>>activeOuterContext (in category 'accessing') ----- - activeOuterContext - "If executing closure, search senders for the activation in which the receiver's - closure was created (the receiver's outerContext). If the outerContext is not - found on the sender chain answer nil." - - | outerContext | - self isExecutingBlock ifFalse: [^self]. - self sender ifNil: [^nil]. - outerContext := self outerContext. - ^self sender findContextSuchThat: [:ctxt | ctxt = outerContext]! Item was removed: - ----- Method: Context>>actualStackSize (in category 'private-debugger') ----- - actualStackSize "For use only by Debugger, Inspectors etc" - ^ stackp - method numTemps! Item was removed: - ----- Method: Context>>arguments (in category 'accessing') ----- - arguments - "Answer the receiver's arguments as an Array. - We could use simply ^(1 to: self numArgs) collect: [:i| self tempAt: i] - but for performance and minimality we use the implementation below." - | n args | - args := Array new: (n := self numArgs). - 1 to: n do: [:i| args at: i put: (self tempAt: i)]. - ^args! Item was removed: - ----- Method: Context>>asContext (in category 'closure support') ----- - asContext - - ^ self! Item was removed: - ----- Method: Context>>asContextWithSender: (in category 'closure support') ----- - asContextWithSender: aContext - self privSender: aContext. - ^ self! Item was removed: - ----- Method: Context>>asMessage (in category 'converting') ----- - asMessage - | selector args | - selector := sender method selector. - args := Array new: selector numArgs. - 1 to: selector numArgs do: [ :i | args at: i put: (sender tempAt: i)]. - ^ Message selector: selector arguments: args.! Item was removed: - ----- Method: Context>>at: (in category 'accessing') ----- - at: index - "Primitive. Assumes receiver is indexable. Answer the value of an - indexable element in the receiver. Fail if the argument index is not an - Integer or is out of bounds. Essential. See Object documentation - whatIsAPrimitive. Override the default primitive to give latitude to - the VM in context management." - - <primitive: 210> - index isInteger ifTrue: - [self errorSubscriptBounds: index]. - index isNumber - ifTrue: [^self at: index asInteger] - ifFalse: [self errorNonIntegerIndex]! Item was removed: - ----- Method: Context>>at:put: (in category 'accessing') ----- - at: index put: value - "Primitive. Assumes receiver is indexable. Answer the value of an - indexable element in the receiver. Fail if the argument index is not - an Integer or is out of bounds. Essential. See Object documentation - whatIsAPrimitive. Override the default primitive to give latitude to - the VM in context management." - - <primitive: 211> - index isInteger ifTrue: - [self errorSubscriptBounds: index]. - index isNumber - ifTrue: [^self at: index asInteger put: value] - ifFalse: [self errorNonIntegerIndex]! Item was removed: - ----- Method: Context>>atEnd (in category 'testing') ----- - atEnd - ^ self isExecutingBlock - ifTrue: [ self closure startpc + self closure size - 1 = self pc ] - ifFalse: [ self pc >= self method endPC ]! Item was removed: - ----- Method: Context>>attemptToAssign:to:withIndex: (in category 'read-only objects') ----- - attemptToAssign: value to: anObject withIndex: index - "Sent by the execution simulation machinery when attempting to assign an instance - variable of an read-only object. This mimics the VM's send of attemptToAssign:withIndex: - when trying to do the same. Upon return, executing will resume *after* the inst var assignment. - This method differs from Object>>attemptToAssign:withIndex: in not doing a Context>>jump, - which does not simulate properly." - - self modificationForbiddenFor: anObject instVarAt: index put: value! Item was removed: - ----- Method: Context>>basicAt: (in category 'accessing') ----- - basicAt: index - "Primitive. Assumes receiver is indexable. Answer the value of an - indexable element in the receiver. Fail if the argument index is not an - Integer or is out of bounds. Essential. See Object documentation - whatIsAPrimitive. Override the default primitive to give latitude to - the VM in context management." - - <primitive: 210> - index isInteger ifTrue: - [self errorSubscriptBounds: index]. - index isNumber - ifTrue: [^self at: index asInteger] - ifFalse: [self errorNonIntegerIndex]! Item was removed: - ----- Method: Context>>basicAt:put: (in category 'accessing') ----- - basicAt: index put: value - "Primitive. Assumes receiver is indexable. Answer the value of an - indexable element in the receiver. Fail if the argument index is not - an Integer or is out of bounds. Essential. See Object documentation - whatIsAPrimitive. Override the default primitive to give latitude to - the VM in context management." - - <primitive: 211> - index isInteger ifTrue: - [self errorSubscriptBounds: index]. - index isNumber - ifTrue: [^self at: index asInteger put: value] - ifFalse: [self errorNonIntegerIndex]! Item was removed: - ----- Method: Context>>basicSize (in category 'accessing') ----- - basicSize - "Primitive. Answer the number of indexable variables in the receiver. - This value is the same as the largest legal subscript. Essential. Do not - override in any subclass. See Object documentation whatIsAPrimitive. Override the default primitive to give latitude to - the VM in context management." - - <primitive: 212> - "The number of indexable fields of fixed-length objects is 0" - ^self primitiveFailed! Item was removed: - ----- Method: Context>>blockReturnConstant: (in category 'instruction decoding') ----- - blockReturnConstant: value - "Simulate the interpreter's action when a ReturnConstantToCaller bytecode is - encountered in the receiver. This should only happen in a closure activation." - self assert: closureOrNil isClosure. - ^self return: value from: self! Item was removed: - ----- Method: Context>>blockReturnTop (in category 'instruction decoding') ----- - blockReturnTop - "Simulate the interpreter's action when a ReturnTopOfStackToCaller bytecode is - encountered in the receiver. This should only happen in a closure activation." - self assert: closureOrNil isClosure. - ^self return: self pop from: self! Item was removed: - ----- Method: Context>>bottomContext (in category 'query') ----- - bottomContext - "Return the last context (the first context invoked) in my sender chain" - - ^ self findContextSuchThat: [:c | c sender isNil]! Item was removed: - ----- Method: Context>>callPrimitive: (in category 'instruction decoding') ----- - callPrimitive: primNumber - "Evaluate the primitive, either normal or inlined, and answer the new context resulting from that - (either the sender if a successful non-inlined primitive, or the current context, if not)." - | maybePrimFailToken | - primNumber >= (1 << 15) ifTrue: "Inlined primitive, cannot fail" - [^self callInlinedPrimitive: primNumber]. - maybePrimFailToken := self doPrimitive: primNumber - method: method - receiver: receiver - args: self arguments. - "Normal primitive. Always at the beginning of methods." - (self isPrimFailToken: maybePrimFailToken) ifFalse: "On success return the result" - [^self methodReturnTop]. - "On failure, store the error code if appropriate and keep interpreting the method" - (method encoderClass isStoreAt: pc in: method) ifTrue: - [self at: stackp put: maybePrimFailToken last]. - ^self! Item was removed: - ----- Method: Context>>canHandleSignal: (in category 'private-exceptions') ----- - canHandleSignal: exception - "Sent to handler (on:do:) contexts only. If my exception class (first arg) handles exception then return true, otherwise forward this message to the next handler context. If none left, return false (see nil>>canHandleSignal:)" - - ^ (self willHandleSignal: exception) - or: [self nextHandlerContext canHandleSignal: exception]. - ! Item was removed: - ----- Method: Context>>cannotReturn: (in category 'private-exceptions') ----- - cannotReturn: result - - closureOrNil ifNotNil: [^ self cannotReturn: result to: self home sender]. - Processor debugWithTitle: 'Computation has been terminated!!' translated full: false.! Item was removed: - ----- Method: Context>>cannotReturn:to: (in category 'private') ----- - cannotReturn: result to: homeContext - "The receiver tried to return result to homeContext that no longer exists." - - ^ BlockCannotReturn new - result: result; - deadHome: homeContext; - signal! Item was removed: - ----- Method: Context>>client (in category 'accessing') ----- - client - "Answer the client, that is, the object that sent the message that created this context." - - ^sender receiver! Item was removed: - ----- Method: Context>>closure (in category 'accessing') ----- - closure - ^closureOrNil! Item was removed: - ----- Method: Context>>completeCallee: (in category 'system simulation') ----- - completeCallee: aContext - "Simulate the execution of bytecodes until a return to the receiver." - | ctxt current ctxt1 | - ctxt := aContext. - [ctxt == current or: [ctxt hasSender: self]] - whileTrue: - [current := ctxt. - ctxt1 := ctxt quickStep. - ctxt1 ifNil: [self halt]. - ctxt := ctxt1]. - ^self stepToSendOrReturn! Item was removed: - ----- Method: Context>>contextForLocalVariables (in category 'accessing') ----- - contextForLocalVariables - "Answer the context in which local variables (temporaries) are stored." - - self flag: #ct. "Deprecate?" - self subclassResponsibility! Item was removed: - ----- Method: Context>>contextStack (in category 'debugger access') ----- - contextStack - "Answer an Array of the contexts on the receiver's sender chain." - - ^self stackOfSize: 100000! Item was removed: - ----- Method: Context>>contextTag (in category 'closure support') ----- - contextTag - "Context tags may be used for referring to contexts instead of contexts themselves as they can be copied and will continue to work in other processes (continuations). By default, we use the context itself to as its tag." - ^self! Item was removed: - ----- Method: Context>>copyStack (in category 'query') ----- - copyStack - - ^ self copyTo: nil! Item was removed: - ----- Method: Context>>copyTo: (in category 'query') ----- - copyTo: aContext - "Copy self and my sender chain down to, but not including, aContext. End of copied chain will have nil sender. Assume that there is no loop in the context chain." - - | currentContext senderContext copy | - self == aContext ifTrue: [ ^nil ]. - currentContext := copy := self copy. - [ - senderContext := currentContext sender ifNil: [ ^copy ]. - senderContext == aContext ifTrue: [ - currentContext privSender: nil. - ^copy ]. - senderContext := senderContext copy. - currentContext privSender: senderContext. - currentContext := senderContext ] repeat! Item was removed: - ----- Method: Context>>copyTo:bottomContextDo: (in category 'query') ----- - copyTo: aContext bottomContextDo: aBlock - "Copy self and my sender chain down to, but not including, aContext. End of copied chain will have nil sender. Evaluate aBlock with the copy of bottom context when it still points to the original sender." - - | copy | - self == aContext ifTrue: [ ^nil ]. - copy := self copy. - sender - ifNil: [ aBlock value: copy ] - ifNotNil: [ - sender == aContext ifTrue: [ aBlock value: copy ]. - copy privSender: (sender copyTo: aContext bottomContextDo: aBlock) ]. - ^copy! Item was removed: - ----- Method: Context>>cut: (in category 'private') ----- - cut: aContext - "Cut aContext and its senders from my sender chain" - - | ctxt callee | - ctxt := self. - [ctxt == aContext] whileFalse: [ - callee := ctxt. - ctxt := ctxt sender. - ctxt ifNil: [aContext ifNotNil: [self error: 'aContext not a sender']]. - ]. - callee privSender: nil. - ! Item was removed: - ----- Method: Context>>deactivateHandler (in category 'private-exceptions') ----- - deactivateHandler - "Private - sent to exception handler context only (on:do:)" - - stackp >= 3 ifTrue: [self tempAt: 3 put: false] "this is temporary handlerActive in #on:do:"! Item was removed: - ----- Method: Context>>depthBelow: (in category 'debugger access') ----- - depthBelow: aContext - "Answer how many calls there are between this and aContext." - - | this depth | - this := self. - depth := 0. - [this == aContext or: [this == nil]] - whileFalse: - [this := this sender. - depth := depth + 1]. - ^depth! Item was removed: - ----- Method: Context>>directedSuperSend:numArgs: (in category 'instruction decoding') ----- - directedSuperSend: selector numArgs: numArgs - "Simulate the action of bytecodes that send a message with selector, selector, - starting the message lookup in the superclass of the class on top of stack. - The arguments of the message are found in the next numArgs locations on - the stack and the receiver just below them." - - | class receiver arguments | - class := self pop. - arguments := Array new: numArgs. - numArgs to: 1 by: -1 do: [ :i | arguments at: i put: self pop]. - receiver := self pop. - QuickStep == self ifTrue: - [QuickStep := nil. - ^self quickSend: selector to: receiver with: arguments lookupIn: class superclass]. - ^self send: selector to: receiver with: arguments lookupIn: class superclass! Item was removed: - ----- Method: Context>>disarmHandler (in category 'private-exceptions') ----- - disarmHandler - "Private - sent to exception handler context only (on:do:)" - - stackp >= 4 ifTrue: [self tempAt: 4 put: false] "this is temporary handlerRearmed in #on:do:"! Item was removed: - ----- Method: Context>>doDup (in category 'instruction decoding') ----- - doDup - "Simulate the action of a 'duplicate top of stack' bytecode." - - self push: self top! Item was removed: - ----- Method: Context>>doPop (in category 'instruction decoding') ----- - doPop - "Simulate the action of a 'remove top of stack' bytecode." - - self pop! Item was removed: - ----- Method: Context>>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." - - | 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 :-)" - "SystemNavigation new browseAllSelect: [:m| m primitive = 19]" - primitiveIndex = 19 ifTrue: [ - [self notify: ('The code being simulated is trying to control a process ({1}). Process controlling cannot be simulated. If you proceed, things may happen outside the observable area of the simulator.' translated format: {meth reference})] - ifCurtailed: [self push: nil "Cheap fix of the context's internal state"]]. - - ((primitiveIndex between: 201 and: 222) - and: [(self objectClass: receiver) includesBehavior: BlockClosure]) ifTrue: - [(primitiveIndex = 206 - or: [primitiveIndex = 208]) ifTrue: "[Full]BlockClosure>>valueWithArguments:" - [^receiver simulateValueWithArguments: arguments first caller: self]. - ((primitiveIndex between: 201 and: 209) "[Full]BlockClosure>>value[:value:...]" - or: [primitiveIndex between: 221 and: 222]) ifTrue: "[Full]BlockClosure>>valueNoContextSwitch[:]" - [^receiver simulateValueWithArguments: arguments caller: self]]. - - primitiveIndex = 83 ifTrue: "afr 9/11/1998 19:50" "Object>>perform:[with:...]" - [| selector | - selector := arguments at: 1 ifAbsent: - [^ self class primitiveFailTokenFor: #'bad argument']. - arguments size - 1 = selector numArgs ifFalse: - [^ self class primitiveFailTokenFor: #'bad number of arguments']. - ^self send: selector to: receiver with: arguments allButFirst]. - primitiveIndex = 84 ifTrue: "afr 9/11/1998 19:50 & eem 8/18/2009 17:04" "Object>>perform:withArguments:" - [| selector args | - arguments size = 2 ifFalse: - [^ self class primitiveFailTokenFor: #'bad argument']. - selector := arguments first. - args := arguments second. - args isArray ifFalse: - [^ self class primitiveFailTokenFor: #'bad argument']. - args size = selector numArgs ifFalse: - [^ self class primitiveFailTokenFor: #'bad number of arguments']. - ^self send: selector to: receiver with: args]. - primitiveIndex = 100 ifTrue: "eem 8/18/2009 16:57" "Object>>perform:withArguments:inSuperclass:" - [| rcvr selector args superclass | - arguments size - caseOf: { - [3] -> [ - rcvr := receiver. - selector := arguments first. - args := arguments second. - superclass := arguments third]. - [4] -> ["mirror primitive" - rcvr := arguments first. - selector := arguments second. - args := arguments third. - superclass := arguments fourth] } - otherwise: [^ self class primitiveFailTokenFor: #'bad number of arguments']. - args isArray ifFalse: - [^ self class primitiveFailTokenFor: #'bad argument']. - args size = selector numArgs ifFalse: - [^ self class primitiveFailTokenFor: #'bad number of arguments']. - ((self objectClass: rcvr) includesBehavior: superclass) ifFalse: - [^ self class primitiveFailTokenFor: #'bad argument']. - ^self send: selector to: rcvr with: args lookupIn: superclass]. - - "Mutex>>primitiveEnterCriticalSection - Mutex>>primitiveTestAndSetOwnershipOfCriticalSection" - (primitiveIndex = 186 or: [primitiveIndex = 187]) ifTrue: - [| effective | - effective := Processor activeProcess effectiveProcess. - "active == effective" - value := primitiveIndex = 186 - ifTrue: [receiver primitiveEnterCriticalSectionOnBehalfOf: effective] - ifFalse: [receiver primitiveTestAndSetOwnershipOfCriticalSectionOnBehalfOf: effective]. - ^(self isPrimFailToken: value) - ifTrue: [value] - ifFalse: [self push: value]]. - - primitiveIndex = 188 ifTrue: "Object>>withArgs:executeMethod: - CompiledMethod class>>receiver:withArguments:executeMethod: - VMMirror>>ifFail:object:with:executeMethod: et al" - [| n args methodArg thisReceiver | - ((n := arguments size) between: 2 and: 4) ifFalse: - [^self class primitiveFailTokenFor: #'unsupported operation']. - ((self objectClass: (args := arguments at: n - 1)) == Array - and: [(self objectClass: (methodArg := arguments at: n)) includesBehavior: CompiledMethod]) ifFalse: - [^self class primitiveFailTokenFor: #'bad argument']. - methodArg numArgs = args size ifFalse: - [^self class primitiveFailTokenFor: #'bad number of arguments']. - thisReceiver := arguments at: n - 2 ifAbsent: [receiver]. - methodArg primitive > 0 ifTrue: - [methodArg isQuick ifTrue: - [^self push: (methodArg valueWithReceiver: thisReceiver arguments: args)]. - ^self doPrimitive: methodArg primitive method: meth receiver: thisReceiver args: args]. - ^self - activateMethod: methodArg - withArgs: args - receiver: thisReceiver]. - - primitiveIndex = 118 ifTrue: "[receiver:]tryPrimitive:withArgs:; avoid recursing in the VM" - [(arguments size = 3 - and: [(self objectClass: arguments second) == SmallInteger - and: [(self objectClass: arguments last) == Array]]) ifTrue: - [^self doPrimitive: arguments second method: meth receiver: arguments first args: arguments last]. - (arguments size = 2 - and: [(self objectClass: arguments first) == SmallInteger - and: [(self objectClass: arguments last) == Array]]) ifFalse: - [^self class 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: "should use self receiver: receiver tryPrimitive: primitiveIndex withArgs: arguments but this is only in later VMs (and appears to be broken)" - [receiver tryPrimitive: primitiveIndex withArgs: arguments]]. - - ^(self isPrimFailToken: value) - ifTrue: [value] - ifFalse: [self push: value]! Item was removed: - ----- Method: Context>>endPC (in category 'private') ----- - endPC - ^closureOrNil - ifNil: [self method endPC] - ifNotNil: [closureOrNil endPC]! Item was removed: - ----- Method: Context>>exceptionMessage (in category 'accessing') ----- - exceptionMessage - ^ self selector caseOf: { - [#doesNotUnderstand:] -> [self tempAt: 1]. - [#notYetImplemented] -> [self asMessage]. - [#shouldBeImplemented] -> [self asMessage]. - [#subclassResponsibility] -> [self asMessage]} - otherwise: [self error: 'This context is not the result of a message exception.'].! Item was removed: - ----- Method: Context>>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 removed: - ----- Method: Context>>findContextSuchThat: (in category 'query') ----- - findContextSuchThat: testBlock - "Search self and my sender chain for first one that satisfies testBlock. Return nil if none satisfy" - - | ctxt | - ctxt := self. - [ctxt isNil] whileFalse: [ - (testBlock value: ctxt) ifTrue: [^ ctxt]. - ctxt := ctxt sender. - ]. - ^ nil! Item was removed: - ----- Method: Context>>findNextHandlerContext (in category 'private-exceptions') ----- - findNextHandlerContext - "find next context marked with <primitive: 199>. - This can be either a handler context (on:do:), - or a handling context (handleSignal:)" - - ^ self sender ifNotNil: [:ctx | ctx findNextHandlerContextStarting]! Item was removed: - ----- Method: Context>>findNextHandlerContextStarting (in category 'private-exceptions') ----- - findNextHandlerContextStarting - "Return the next handler marked context, returning nil if there is none. Search starts with self and proceeds up to nil." - - | ctx | - <primitive: 197> - ctx := self. - [ctx isHandlerContext ifTrue:[^ctx]. - (ctx := ctx sender) == nil ] whileFalse. - ^nil! Item was removed: - ----- Method: Context>>findNextUnwindContextUpTo: (in category 'private-exceptions') ----- - findNextUnwindContextUpTo: aContext - "Return the next unwind marked above the receiver, returning nil if there is none. Search proceeds up to but not including aContext." - - | ctx | - <primitive: 195> - ctx := self. - [(ctx := ctx sender) == nil or: [ctx == aContext]] whileFalse: - [ ctx isUnwindContext ifTrue: [^ctx]]. - ^nil! Item was removed: - ----- Method: Context>>findSecondToOldestSimilarSender (in category 'query') ----- - findSecondToOldestSimilarSender - "Search the stack for the second-to-oldest occurance of self's method. Very useful for an infinite recursion. Gets back to the second call so you can see one complete recursion cycle, and how it was called at the beginning." - - | sec ctxt bot | - sec := self. - ctxt := self. - [ bot := ctxt findSimilarSender. - bot isNil - ] whileFalse: [ - sec := ctxt. - ctxt := bot. - ]. - ^ sec - ! Item was removed: - ----- Method: Context>>findSimilarSender (in category 'query') ----- - findSimilarSender - "Return the closest sender with the same method, return nil if none found" - - | meth | - meth := self method. - self sender ifNil: [^nil]. - ^ self sender findContextSuchThat: [:c | c method == meth]! Item was removed: - ----- Method: Context>>fireHandlerActionForSignal: (in category 'private-exceptions') ----- - fireHandlerActionForSignal: exception - "Sent to handler (on:do:) contexts only. - Perform the second argument, which is the handler action" - - ^(self tempAt: 2) cull: exception! Item was removed: - ----- Method: Context>>handleSignal: (in category 'private-exceptions') ----- - handleSignal: exception - "Sent to handler (on:do:) contexts only. - Execute the handler action block" - - | val | - <primitive: 199> "just a marker, fail and execute the following" - exception privHandlerContext: self contextTag. - self deactivateHandler. "Prevent re-entering the action block, unless it is explicitely rearmed" - val := [self fireHandlerActionForSignal: exception] ensure: [self reactivateHandler]. - self return: val "return from self if not otherwise directed in handle block"! Item was removed: - ----- Method: Context>>hasContext: (in category 'query') ----- - hasContext: aContext - "Answer whether aContext is me or one of my senders" - - ^ (self findContextSuchThat: [:c | c == aContext]) notNil! Item was removed: - ----- Method: Context>>hasInstVarRef (in category 'accessing') ----- - hasInstVarRef - "Answer whether the receiver references an instance variable." - - ^self method hasInstVarRef.! Item was removed: - ----- Method: Context>>hasMethodReturn (in category 'accessing') ----- - hasMethodReturn - ^closureOrNil hasMethodReturn! Item was removed: - ----- Method: Context>>hasSender: (in category 'controlling') ----- - hasSender: context - "Answer whether the receiver is strictly above context on the stack." - - | s | - self == context ifTrue: [^false]. - s := sender. - [s == nil] - whileFalse: - [s == context ifTrue: [^true]. - s := s sender]. - ^false! Item was removed: - ----- Method: Context>>home (in category 'accessing') ----- - home - "Answer the context in which the receiver was defined." - - closureOrNil == nil ifTrue: - [^self]. - ^closureOrNil outerContext home! Item was removed: - ----- Method: Context>>homeMethod (in category 'accessing') ----- - homeMethod - "Answer the home method associated with the receiver. - This is polymorphic with BlockClosure, CompiledCode, etc" - ^method homeMethod! Item was removed: - ----- Method: Context>>insertSender: (in category 'private') ----- - insertSender: aContext - "Insert aContext and its sender chain between me and my sender. Return new callee of my original sender." - - | ctxt | - ctxt := aContext bottomContext. - ctxt privSender: self sender. - self privSender: aContext. - ^ ctxt! Item was removed: - ----- Method: Context>>instVarAt:put: (in category 'private') ----- - instVarAt: index put: value - index = 3 ifTrue: [self stackp: value. ^ value]. - ^ super instVarAt: index put: value! Item was removed: - ----- Method: Context>>isBottomContext (in category 'query') ----- - isBottomContext - "Answer if this is the last context (the first context invoked) in my sender chain" - - ^sender isNil! Item was removed: - ----- Method: Context>>isClosureContext (in category 'closure support') ----- - isClosureContext - ^closureOrNil ~~ nil! Item was removed: - ----- Method: Context>>isContext (in category 'query') ----- - isContext - ^true! Item was removed: - ----- Method: Context>>isDead (in category 'query') ----- - isDead - "Has self finished" - - ^ pc isNil! Item was removed: - ----- Method: Context>>isExecutingBlock (in category 'accessing') ----- - isExecutingBlock - "Is this executing a block versus a method? In the new closure - implemetation this is true if closureOrNil is not nil, in which case - it should be holding a BlockClosure." - - ^closureOrNil isClosure! Item was removed: - ----- Method: Context>>isHandlerActive (in category 'private-exceptions') ----- - isHandlerActive - "Private - sent to exception handler context only (on:do:)" - - ^stackp >= 3 and: [(self tempAt: 3) == true] "this is temporary handlerActive in #on:do:"! Item was removed: - ----- Method: Context>>isHandlerContext (in category 'private-exceptions') ----- - isHandlerContext - "Answer if the receiver is for a method that is marked as an exception handler. - BlockClosure>>#on:do: uses this primitive to identify itself to the VM - as an exception handler method, which the VM uses in primitive 197 - Context>>#findNextHandlerContextStarting, primitiveFindHandlerContext, - to accelerate the search for exception handlers." - ^method primitive = 199! Item was removed: - ----- Method: Context>>isHandlerRearmed (in category 'private-exceptions') ----- - isHandlerRearmed - "Private - sent to exception handler context only (on:do:)" - - ^stackp >= 4 and: [(self tempAt: 4) == true] "this is temporary handlerRearmed in #on:do:"! Item was removed: - ----- Method: Context>>isMethodContext (in category 'testing') ----- - isMethodContext - ^closureOrNil == nil! Item was removed: - ----- Method: Context>>isPrimFailToken: (in category 'private') ----- - isPrimFailToken: contextOrPrimFailToken - "Answer if contextOrPrimFailToken, which will either be a Context object or - a primitive fail token (a tuple of the PrimitiveFailToken unique object and - a primitive failure code), is the latter. This should only be used with the - (possibly indirect) results of Context>>doPrimitive:method:receiver:args:" - ^ (self objectClass: contextOrPrimFailToken) == Array - and: [contextOrPrimFailToken size = 2 - and: [(contextOrPrimFailToken at: 1) == PrimitiveFailToken]]! Item was removed: - ----- Method: Context>>isUnwindContext (in category 'private-exceptions') ----- - isUnwindContext - "Answer if the receiver is for a method that is marked as a non-local return/exception unwind protect. - BlockClosure>>#ensure: and BlockClosure>>#ifCurtailed: use this primitive to identify - themseves to the VM as unwind protect methods. The VM uses this in primitive 195 - Context>>#findNextUnwindContextUpTo:, primitiveFindNextUnwindContext, to - accelerate the search for unwind protects." - ^method primitive = 198! Item was removed: - ----- Method: Context>>jump (in category 'controlling') ----- - jump - "Abandon thisContext and resume self instead (using the same current process). You may want to save thisContext's sender before calling this so you can jump back to it. - Self MUST BE a top context (ie. a suspended context or a abandoned context that was jumped out of). A top context already has its return value on its stack (see Interpreter>>primitiveSuspend and other suspending primitives). - thisContext's sender is converted to a top context (by pushing a nil return value on its stack) so it can be jump back to." - - | top | - "Make abandoned context a top context (has return value (nil)) so it can be jumped back to" - thisContext sender push: nil. - - "Pop self return value then return it to self (since we jump to self by returning to it)" - stackp = 0 ifTrue: [self stepToSendOrReturn]. - stackp = 0 ifTrue: [self push: nil]. "must be quick return self/constant" - top := self pop. - thisContext privSender: self. - ^ top! Item was removed: - ----- Method: Context>>jump: (in category 'instruction decoding') ----- - jump: distance - "Simulate the action of a 'unconditional jump' bytecode whose offset is - the argument, distance." - - pc := pc + distance! Item was removed: - ----- Method: Context>>jump:if: (in category 'instruction decoding') ----- - jump: distance if: condition - "Simulate the action of a 'conditional jump' bytecode whose offset is the - argument, distance, and whose condition is the argument, condition." - - | bool | - bool := self pop. - condition == bool - ifTrue: [self jump: distance] - ifFalse: - [(true == bool or: [false == bool]) ifFalse: - [^self send: #mustBeBooleanIn: to: bool with: {self}]]! Item was removed: - ----- Method: Context>>longStack (in category 'debugger access') ----- - longStack - "Answer a String showing the top 100 contexts on my sender chain." - - ^ String streamContents: - [:strm | - (self stackOfSize: 100) - do: [:item | strm print: item; cr]]! Item was removed: - ----- Method: Context>>method (in category 'accessing') ----- - method - - ^method! Item was removed: - ----- Method: Context>>methodClass (in category 'accessing') ----- - methodClass - "Answer the class in which the receiver's method was found." - - ^self method methodClass ifNil: [self objectClass: self receiver].! Item was removed: - ----- Method: Context>>methodNode (in category 'accessing') ----- - methodNode - ^ self method methodNode.! Item was removed: - ----- Method: Context>>methodNodeFormattedAndDecorated: (in category 'accessing') ----- - methodNodeFormattedAndDecorated: decorate - "Answer a method node made from pretty-printed (and colorized, if decorate is true) - source text." - - ^ self method methodNodeFormattedAndDecorated: decorate.! Item was removed: - ----- Method: Context>>methodReturnConstant: (in category 'instruction decoding') ----- - methodReturnConstant: value - "Simulate the action of a 'return constant' bytecode whose value is the - argument, value. This corresponds to a source expression like '^0'." - - ^self return: value from: self methodReturnContext! Item was removed: - ----- Method: Context>>methodReturnContext (in category 'accessing') ----- - methodReturnContext - "Answer the context from which an ^-return should return from." - - closureOrNil == nil ifTrue: - [^self]. - ^closureOrNil outerContext methodReturnContext! Item was removed: - ----- Method: Context>>methodReturnReceiver (in category 'instruction decoding') ----- - methodReturnReceiver - "Simulate the action of a 'return receiver' bytecode. This corresponds to - the source expression '^self'." - - ^self return: self receiver from: self methodReturnContext! Item was removed: - ----- Method: Context>>methodReturnTop (in category 'instruction decoding') ----- - methodReturnTop - "Simulate the action of a 'return top of stack' bytecode. This corresponds - to source expressions like '^something'." - - ^self return: self pop from: self methodReturnContext! Item was removed: - ----- Method: Context>>modificationForbiddenFor:at:put: (in category 'read-only objects') ----- - modificationForbiddenFor: target at: index put: anObject - ^(ModificationForbidden new - mirror: self - object: target - index: index - newValue: anObject - retrySelector: #object:basicAt:put:) signal! Item was removed: - ----- Method: Context>>modificationForbiddenFor:at:putCharacter: (in category 'read-only objects') ----- - modificationForbiddenFor: target at: index putCharacter: aCharacter - "eem 3/11/2020 13:09 this may be a mistake. Instead perhaps String clients should - send asInteger and use modificationForbiddenFor:at:put:. Opinions appreciated." - ^(ModificationForbidden new - mirror: self - object: target - index: index - newValue: (aCharacter isCharacter ifTrue: [aCharacter asInteger] ifFalse: [aCharacter]) - retrySelector: #object:basicAt:put:) signal! Item was removed: - ----- Method: Context>>modificationForbiddenFor:instVarAt:put: (in category 'read-only objects') ----- - modificationForbiddenFor: target instVarAt: index put: anObject - ^(ModificationForbidden new - mirror: self - object: target - index: index - newValue: anObject - retrySelector: #object:instVarAt:put:) signal! Item was removed: - ----- Method: Context>>nextHandlerContext (in category 'private-exceptions') ----- - nextHandlerContext - "Answer the next handler context (on:do:) in the call chain. - Answer nil if none found" - - | handler | - handler := self findNextHandlerContext. - [handler ifNil: [^nil]. - handler selector == #handleSignal:] - whileTrue: [handler := handler findNextHandlerContext]. - ^handler! Item was removed: - ----- Method: Context>>nextHandlerContextForSignal: (in category 'private-exceptions') ----- - nextHandlerContextForSignal: exception - "Answer the handler context (on:do:) for this exception - Answer nil if none found" - - | handler priorHandler | - handler := self. - [(handler := handler findNextHandlerContext) ifNil: [^nil]. - handler selector == #handleSignal:] - whileFalse: [(handler willHandleSignal: exception) ifTrue: [^handler]]. - - "exception has been signalled in the scope of another signal handler (while #handleSignal:) - Check for a rearmed inner handler. If none, jump to outer handler context." - priorHandler := (handler tempAt: 1) "the exception argument to handleSignal:" - privHandlerContext. - - [(handler := handler nextHandlerContext) ifNil: [^nil]. - (handler isHandlerRearmed and: [handler willHandleSignal: exception]) ifTrue: [^handler]. - handler == priorHandler] whileFalse. - - ^priorHandler nextHandlerContextForSignal: exception! Item was removed: - ----- Method: Context>>numArgs (in category 'accessing') ----- - numArgs - "Answer the number of arguments for this activation." - ^closureOrNil - ifNil: [method numArgs] - ifNotNil: [closureOrNil numArgs]! Item was removed: - ----- Method: Context>>numTemps (in category 'accessing') ----- - numTemps - "Answer the number of temporaries for this activation; this includes - the number of arguments, and for blocks, the number of copied values." - ^closureOrNil - ifNil: [method numTemps] - ifNotNil: [closureOrNil numTemps]! Item was removed: - ----- Method: Context>>object:basicAt: (in category 'mirror primitives') ----- - object: anObject basicAt: index - "Answer the value of an indexable element in the argument anObject without sending - it a message. Fail if the argument index is not an Integer or is out of bounds, or if - anObject is not indexable. This mimics the action of the VM when it indexes an object. - Used to simulate the execution machinery by, for example, the debugger. - Primitive. See Object documentation whatIsAPrimitive." - - <primitive: 60> - index isInteger ifTrue: [self errorSubscriptBounds: index]. - index isNumber - ifTrue: [^self object: anObject basicAt: index asInteger] - ifFalse: [self errorNonIntegerIndex]! Item was removed: - ----- Method: Context>>object:basicAt:put: (in category 'mirror primitives') ----- - object: anObject basicAt: index put: value - "Store the last argument value in the indexable element of the argument anObject - indicated by index without sending anObject a message. Fail if the argument index - is not an Integer or is out of bounds, or if anObject is not indexable, or if anObject is - read-only, or if value is an inappropriate value for anObject's indexable slots. - This mimics the action of the VM when it indexes an object. Used to simulate - the execution machinery by, for example, the debugger. - Primitive. See Object documentation whatIsAPrimitive." - - <primitive: 61 error: ec> - index isInteger ifTrue: - [(index >= 1 and: [index <= (self objectSize: anObject)]) - ifTrue: - [ec == #'no modification' ifTrue: - [^self modificationForbiddenFor: anObject at: index put: value]. - self errorImproperStore] - ifFalse: [self errorSubscriptBounds: index]]. - index isNumber ifTrue: - [^self object: anObject basicAt: index asInteger put: value]. - self errorNonIntegerIndex! Item was removed: - ----- Method: Context>>object:eqeq: (in category 'mirror primitives') ----- - object: anObject eqeq: anOtherObject - "Answer whether the first and second arguments are the same object (have the - same object pointer) without sending a message to the first argument. This - mimics the action of the VM when it compares two object pointers. Used to - simulate the execution machinery by, for example, the debugger. - Primitive. See Object documentation whatIsAPrimitive." - - <primitive: 110> - self primitiveFailed! Item was removed: - ----- Method: Context>>object:instVarAt: (in category 'mirror primitives') ----- - object: anObject instVarAt: anIndex - "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 for the - debugger. See Object documentation whatIsAPrimitive." - - <primitive: 173 error: ec> - self primitiveFailed! Item was removed: - ----- Method: Context>>object:instVarAt:put: (in category 'mirror primitives') ----- - object: anObject instVarAt: anIndex put: aValue - "Primitive. Store a value into a fixed variable in the argument anObject. - 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, or if anObject is read-only. 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 for the debugger. See Object documentation whatIsAPrimitive." - - <primitive: 174 error: ec> - ec == #'no modification' ifTrue: - [^self modificationForbiddenFor: anObject instVarAt: anIndex put: aValue]. - self primitiveFailed! Item was removed: - ----- Method: Context>>object:perform:withArguments:inClass: (in category 'mirror primitives') ----- - object: anObject perform: selector withArguments: argArray inClass: lookupClass - "Send the selector, aSymbol, to anObject with arguments in argArray. - Fail if the number of arguments expected by the selector - does not match the size of argArray, or if lookupClass - cannot be found among the anObject's superclasses. - Primitive. Essential for the debugger." - - <primitive: 100 error: error> - (selector isSymbol) ifFalse: - [^self error: 'selector argument must be a Symbol']. - (argArray isMemberOf: Array) ifFalse: - [^self error: 'argArray must be an Array']. - (selector numArgs = argArray size) - ifFalse: [^self error: 'incorrect number of arguments']. - ((self objectClass: anObject) == lookupClass - or: [(self objectClass: anObject) inheritsFrom: lookupClass]) ifFalse: - [^self error: 'lookupClass is not in anObject''s inheritance chain']. - self primitiveFailed! Item was removed: - ----- Method: Context>>objectClass: (in category 'mirror primitives') ----- - objectClass: anObject - "Answer the class of the argument anObject without sending it a message. - This mimics the action of the VM when it fetches an object's class. Used to - simulate the execution machinery by, for example, the debugger. - Primitive. See Object documentation whatIsAPrimitive." - - <primitive: 111> - self primitiveFailed! Item was removed: - ----- Method: Context>>objectSize: (in category 'mirror primitives') ----- - objectSize: anObject - "Answer the number of indexable variables in the argument anObject without sending - it a message. This mimics the action of the VM when it fetches an object's variable size. - Used to simulate the execution machinery by, for example, the debugger. - Primitive. See Object documentation whatIsAPrimitive." - - <primitive: 62> - "The number of indexable fields of fixed-length objects is 0" - ^0! Item was removed: - ----- Method: Context>>outerContext (in category 'accessing') ----- - outerContext - "Answer the context within which the receiver is nested." - - ^closureOrNil ifNotNil: - [closureOrNil outerContext]! Item was removed: - ----- Method: Context>>pc (in category 'accessing') ----- - pc - "Answer the index of the next bytecode to be executed." - - ^pc! Item was removed: - ----- Method: Context>>pop (in category 'controlling') ----- - pop - "Answer the top of the receiver's stack and remove the top of the stack." - | val | - val := self at: stackp. - self stackp: stackp - 1. - ^ val! Item was removed: - ----- Method: Context>>popIntoLiteralVariable: (in category 'instruction decoding') ----- - popIntoLiteralVariable: value - "Simulate the action of bytecode that removes the top of the stack and - stores it into a literal variable of my method. If the receiver is read-only - this will provoke a send of #attemptToAssign:withIndex:" - - | top result | - top := self pop. - result := self simulatedObject: value instVarAt: ValueIndex put: top. - ^(self object: result eqeq: top) - ifTrue: [self] - ifFalse: [result]! Item was removed: - ----- Method: Context>>popIntoReceiverVariable: (in category 'instruction decoding') ----- - popIntoReceiverVariable: offset - "Simulate the action of bytecode that removes the top of the stack and - stores it into an instance variable of my receiver. If the receiver is read-only - this will provoke a send of #attemptToAssign:withIndex:" - - | top result | - top := self pop. - result := self simulatedObject: self receiver instVarAt: offset + 1 put: top. - ^(self object: result eqeq: top) - ifTrue: [self] - ifFalse: [result]! Item was removed: - ----- Method: Context>>popIntoRemoteTemp:inVectorAt: (in category 'instruction decoding') ----- - popIntoRemoteTemp: remoteTempIndex inVectorAt: tempVectorIndex - "Simulate the action of bytecode that removes the top of the stack and stores - it into an offset in one of my local variables being used as a remote temp vector." - - self object: (self at: tempVectorIndex + 1) basicAt: remoteTempIndex + 1 put: self pop! Item was removed: - ----- Method: Context>>popIntoTemporaryVariable: (in category 'instruction decoding') ----- - popIntoTemporaryVariable: offset - "Simulate the action of bytecode that removes the top of the stack and - stores it into one of my temporary variables." - - self at: offset + 1 put: self pop! Item was removed: - ----- Method: Context>>printDetails: (in category 'printing') ----- - printDetails: strm - "Put my class>>selector and instance variables and arguments and temporaries on the stream. Protect against errors during printing." - - | pe str pos | - self printOn: strm. - strm cr. - strm tab; nextPutAll: 'Receiver: '. - pe := '<<error during printing>>'. - strm nextPutAll: ([receiver printStringLimitedTo: 90] ifError: [:err :rcvr | pe]). - - strm cr; tab; nextPutAll: 'Arguments and temporary variables: '; cr. - str := [(self tempsAndValuesLimitedTo: 80 indent: 2) - padded: #right to: 1 with: $x] ifError: [:err :rcvr | pe]. - strm nextPutAll: (str allButLast). - - strm cr; tab; nextPutAll: 'Receiver''s instance variables: '; cr. - pos := strm position. - [receiver longPrintOn: strm limitedTo: 80 indent: 2] ifError: [:err :rcvr | - strm nextPutAll: pe]. - pos = strm position ifTrue: ["normal printString for an Array (it has no inst vars)" - strm nextPutAll: ([receiver printStringLimitedTo: 90] ifError: [:err :rcvr | pe])]. - strm peekLast == Character cr ifFalse: [strm cr].! Item was removed: - ----- Method: Context>>printOn: (in category 'printing') ----- - printOn: aStream - | class mclass selector | - method ifNil: - [^super printOn: aStream]. - - closureOrNil ifNotNil: - [aStream nextPutAll: '[] in '. - closureOrNil outerContext ifNotNil: - [:outer| - outer printOn: aStream. - ^self]]. - - class := self objectClass: self receiver. - mclass := method methodClass. - selector := method selector ifNil: [method defaultSelector]. - - aStream nextPutAll: class name. - mclass ~~ class ifTrue: - [aStream nextPut: $(; nextPutAll: mclass name; nextPut: $)]. - aStream nextPutAll: '>>'; nextPutAll: selector. - - (selector == #doesNotUnderstand: - and: [(self objectClass: (self tempAt: 1)) == Message]) ifTrue: - [aStream space. - (self tempAt: 1) selector printOn: aStream]! Item was removed: - ----- Method: Context>>printString (in category 'printing') ----- - printString - "Answer an emphasized string in case of a breakpoint method" - - ^(self method notNil and: [self method hasBreakpoint]) - ifTrue:[(super printString , ' [break]') asText allBold] - ifFalse:[super printString]! Item was removed: - ----- Method: Context>>privRefresh (in category 'initialize-release') ----- - privRefresh - "Reinitialize the receiver so that it is in the state it was at its creation." - - closureOrNil - ifNotNil: - [closureOrNil isFullBlock - ifTrue: - [pc := method initialPC. - self stackp: method numTemps. - closureOrNil numArgs + closureOrNil numCopiedValues + 1 to: method numTemps do: - [:i | self tempAt: i put: nil]] - ifFalse: "In non-full blocks temps are established by push btecodes" - [pc := closureOrNil startpc. - self stackp: closureOrNil numArgs + closureOrNil numCopiedValues]. - 1 to: closureOrNil numCopiedValues do: - [:i | self tempAt: closureOrNil numArgs + i put: (closureOrNil at: i)]] - ifNil: - [pc := method initialPC. - self stackp: method numTemps. - method numArgs + 1 to: method numTemps do: - [:i | self tempAt: i put: nil]]! Item was removed: - ----- Method: Context>>privRefreshWith: (in category 'initialize-release') ----- - privRefreshWith: aCompiledMethod - "Reinitialize the receiver as though it had been for a different method. - Used by a Debugger when one of the methods to which it refers is - recompiled." - - aCompiledMethod isCompiledMethod ifFalse: - [self error: 'method can only be set to aCompiledMethod']. - method := aCompiledMethod. - self assert: closureOrNil == nil. - "was: receiverMap := nil." - self privRefresh! Item was removed: - ----- Method: Context>>privSender: (in category 'private') ----- - privSender: aContext - - sender := aContext! Item was removed: - ----- Method: Context>>push: (in category 'controlling') ----- - push: val - "Push val on the receiver's stack." - - self stackp: stackp + 1. - self at: stackp put: val! Item was removed: - ----- Method: Context>>push:fromIndexable: (in category 'private') ----- - push: numObjects fromIndexable: anIndexableCollection - "Push the elements of anIndexableCollection onto the receiver's stack. - Do not call directly. Called indirectly by {1. 2. 3} constructs." - - 1 to: numObjects do: - [:i | self push: (anIndexableCollection at: i)]! Item was removed: - ----- Method: Context>>pushActiveContext (in category 'instruction decoding') ----- - pushActiveContext - "Simulate the action of bytecode that pushes the the active context on the - top of its own stack." - - self push: self! Item was removed: - ----- Method: Context>>pushArgs:from: (in category 'system simulation') ----- - pushArgs: args "<Array>" from: sendr "<Context>" - "Helps simulate action of the value primitive for closures. - This is used by ContextPart>>runSimulated:contextAtEachStep:" - - closureOrNil - ifNil: [self error: 'context needs a closure!!'] - ifNotNil: - ["See BlockClosure>>asContextWithSender:" - stackp ~= (closureOrNil numArgs + closureOrNil numCopiedValues) ifTrue: - [self error: 'stack pointer is incorrect!!'].]. - - 1 to: closureOrNil numArgs do: - [:i| self at: i put: (args at: i)]. - sender := sendr! Item was removed: - ----- Method: Context>>pushClosureCopyNumCopiedValues:numArgs:blockSize: (in category 'instruction decoding') ----- - pushClosureCopyNumCopiedValues: numCopied numArgs: numArgs blockSize: blockSize - "Simulate the action of a 'closure copy' bytecode whose result is the - new BlockClosure for the following code" - | copiedValues | - numCopied > 0 - ifTrue: - [copiedValues := Array new: numCopied. - numCopied to: 1 by: -1 do: - [:i| - copiedValues at: i put: self pop]] - ifFalse: - [copiedValues := nil]. - self push: ((BlockClosure new: numCopied) - outerContext: self - startpc: pc - numArgs: numArgs - copiedValues: copiedValues). - self jump: blockSize! Item was removed: - ----- Method: Context>>pushConsArrayWithElements: (in category 'instruction decoding') ----- - pushConsArrayWithElements: numElements - | array | - array := Array new: numElements. - numElements to: 1 by: -1 do: - [:i| - array at: i put: self pop]. - self push: array! Item was removed: - ----- Method: Context>>pushConstant: (in category 'instruction decoding') ----- - pushConstant: value - "Simulate the action of bytecode that pushes the constant, value, on the - top of the stack." - - self push: value! Item was removed: - ----- Method: Context>>pushFullClosure:numCopied: (in category 'instruction decoding') ----- - pushFullClosure: aCompiledBlock numCopied: numCopied - "Simulate the action of a 'closure copy' bytecode whose result is the - new FullBlockClosure for the supplied compiled block." - | copiedValues | - numCopied > 0 - ifTrue: - [copiedValues := Array new: numCopied. - numCopied to: 1 by: -1 do: - [:i| - copiedValues at: i put: self pop]] - ifFalse: - [copiedValues := nil]. - self push: ((FullBlockClosure new: numCopied) - receiver: receiver - outerContext: self - method: aCompiledBlock - copiedValues: copiedValues)! Item was removed: - ----- Method: Context>>pushLiteralVariable: (in category 'instruction decoding') ----- - pushLiteralVariable: value - "Simulate the action of bytecode that pushes the contents of the literal - variable whose index is the argument, index, on the top of the stack." - - self push: (self object: value instVarAt: ValueIndex)! Item was removed: - ----- Method: Context>>pushNewArrayOfSize: (in category 'instruction decoding') ----- - pushNewArrayOfSize: arraySize - self push: (Array new: arraySize)! Item was removed: - ----- Method: Context>>pushReceiver (in category 'instruction decoding') ----- - pushReceiver - "Simulate the action of bytecode that pushes the active context's receiver - on the top of the stack." - - self push: self receiver! Item was removed: - ----- Method: Context>>pushReceiverVariable: (in category 'instruction decoding') ----- - pushReceiverVariable: offset - "Simulate the action of bytecode that pushes the contents of the receiver's - instance variable whose index is the argument, index, on the top of the - stack." - - self push: (self object: self receiver instVarAt: offset + 1)! Item was removed: - ----- Method: Context>>pushRemoteTemp:inVectorAt: (in category 'instruction decoding') ----- - pushRemoteTemp: remoteTempIndex inVectorAt: tempVectorIndex - "Simulate the action of bytecode that pushes the value at remoteTempIndex - in one of my local variables being used as a remote temp vector." - self push: (self object: (self at: tempVectorIndex + 1) basicAt: remoteTempIndex + 1)! Item was removed: - ----- Method: Context>>pushSpecialConstant: (in category 'instruction decoding implicit literals') ----- - pushSpecialConstant: value - "Simulate the action of bytecode that pushes the constant, value, on the - top of the stack." - - self push: value! Item was removed: - ----- Method: Context>>pushTemporaryVariable: (in category 'instruction decoding') ----- - pushTemporaryVariable: offset - "Simulate the action of bytecode that pushes the contents of the - temporary variable whose index is the argument, index, on the top of - the stack." - - self push: (self at: offset + 1)! Item was removed: - ----- Method: Context>>quickSend:to:with:lookupIn: (in category 'controlling') ----- - quickSend: selector to: rcvr with: arguments lookupIn: lookupClass - "Send the given selector with arguments in an environment which closely resembles - the non-simulating environment, with an interjected unwind-protected block to catch - nonlocal returns. Attention: don't get lost!! This beautiful method is originally due to - Hans-Martin Mosner." - | oldSender contextToReturnTo result | - contextToReturnTo := self. - [oldSender := thisContext sender swapSender: self. - result := self object: rcvr perform: selector withArguments: arguments inClass: lookupClass. - thisContext sender swapSender: oldSender] ifCurtailed: - [contextToReturnTo := thisContext sender receiver. "The block context returning nonlocally" - contextToReturnTo pc: contextToReturnTo previousPc. "skip to front of return bytecode causing this unwind" - contextToReturnTo willReturnTopFromMethod ifTrue: - "If it was a returnTop, push the value to be returned. - Otherwise the value is implicit in the bytecode" - [contextToReturnTo push: (thisContext sender tempAt: 1)]. - thisContext swapSender: thisContext home sender. "Make this block return to the method's sender" - contextToReturnTo]. - contextToReturnTo push: result. - ^contextToReturnTo! Item was removed: - ----- Method: Context>>quickStep (in category 'system simulation') ----- - quickStep - "If the next instruction is a send, just perform it. - Otherwise, do a normal step." - - self willReallySend ifTrue: [QuickStep := self]. - ^self step! Item was removed: - ----- Method: Context>>reactivateHandler (in category 'private-exceptions') ----- - reactivateHandler - "Private - sent to exception handler context only (on:do:)" - - stackp >= 3 ifTrue: [self tempAt: 3 put: true] "this is temporary handlerActive in #on:do:"! Item was removed: - ----- Method: Context>>readDataFrom:size: (in category 'objects from disk') ----- - readDataFrom: aDataStream size: varsOnDisk - "Fill in the fields of self based on the contents of aDataStream. Answer self. - Read in the instance-variables written by Object>>storeDataOn:. - NOTE: This method must send beginReference: before reading any objects from aDataStream that might reference it. - Allow aDataStream to have fewer inst vars. See SmartRefStream. - Override to not store nil stack contents beyond stack pointer." - | cntInstVars cntIndexedVars | - - cntInstVars := self class instSize. - cntIndexedVars := varsOnDisk - cntInstVars. - cntIndexedVars < 0 ifTrue: - [self error: 'Class has changed too much. Define a convertxxx method']. - - aDataStream beginReference: self. - 1 to: cntInstVars do: - [:i | self instVarAt: i put: aDataStream next]. - 1 to: stackp do: - [:i | self basicAt: i put: aDataStream next]. - stackp + 1 to: cntIndexedVars do: - [:i | aDataStream next ~~ nil ifTrue: - [self error: 'Reading a Context''s contents expects only nil beyond top of stack']]. - "Total number read MUST be equal to varsOnDisk!!" - ^self "If we ever answer something other than self, fix calls - on (super readDataFrom: aDataStream size: anInteger)"! Item was removed: - ----- Method: Context>>rearmHandler (in category 'private-exceptions') ----- - rearmHandler - "Private - sent to exception handler context only (on:do:)" - - self reactivateHandler. - stackp >= 4 ifTrue: [self tempAt: 4 put: true] "this is temporary handlerRearmed in #on:do:"! Item was removed: - ----- Method: Context>>rearmHandlerDuring: (in category 'private-exceptions') ----- - rearmHandlerDuring: aBlock - "Sent to handler (on:do:) contexts only. Makes me re-entrant for the duration of aBlock. Only works in a closure-enabled image" - - ^ [self rearmHandler. aBlock value] - ensure: [self disarmHandler]! Item was removed: - ----- Method: Context>>receiver (in category 'accessing') ----- - receiver - "Answer the receiver of the message that created this context." - - ^receiver! Item was removed: - ----- Method: Context>>receiver: (in category 'private-exceptions') ----- - receiver: r - - receiver := r! Item was removed: - ----- Method: Context>>receiver:tryPrimitive:withArgs: (in category 'private') ----- - receiver: receiver tryPrimitive: primIndex withArgs: argumentArray - "Invoke the primitive with number primIndex, with the receiver and arguments - supplied, answering its result, or, if the primiitve fails, the error code." - - <primitive: 118 error: errorCode> - ^self class primitiveFailTokenFor: errorCode! Item was removed: - ----- Method: Context>>release (in category 'debugger access') ----- - release - "Remove information from the receiver and all of the contexts on its - sender chain in order to break circularities." - - self releaseTo: nil! Item was removed: - ----- Method: Context>>releaseTo: (in category 'debugger access') ----- - releaseTo: caller - "Remove information from the receiver and the contexts on its sender - chain up to caller in order to break circularities." - - | c s | - c := self. - [c == nil or: [c == caller]] - whileFalse: - [s := c sender. - c singleRelease. - c := s]! Item was removed: - ----- Method: Context>>removeSelf (in category 'accessing') ----- - removeSelf - "Nil the receiver pointer and answer its former value." - - | tempSelf | - tempSelf := receiver. - receiver := nil. - ^tempSelf! Item was removed: - ----- Method: Context>>restart (in category 'controlling') ----- - restart - "Unwind thisContext to self and resume from beginning. Execute unwind blocks when unwinding. ASSUMES self is a sender of thisContext" - - | ctxt unwindBlock | - self isDead ifTrue: [self cannotReturn: nil to: self]. - self privRefresh. - ctxt := thisContext. - [ ctxt := ctxt findNextUnwindContextUpTo: self. - ctxt isNil - ] whileFalse: [ - (ctxt tempAt: 2) ifNil:[ - ctxt tempAt: 2 put: true. - unwindBlock := ctxt tempAt: 1. - thisContext terminateTo: ctxt. - unwindBlock value]. - ]. - thisContext terminateTo: self. - self jump. - ! Item was removed: - ----- Method: Context>>restartWithNewReceiver: (in category 'private-exceptions') ----- - restartWithNewReceiver: obj - receiver := obj. - self restart! Item was removed: - ----- Method: Context>>resume (in category 'controlling') ----- - resume - "Roll back thisContext to self and resume. Execute unwind blocks when rolling back. ASSUMES self is a sender of thisContext" - - self resume: nil! Item was removed: - ----- Method: Context>>resume: (in category 'controlling') ----- - resume: value - "Unwind thisContext to self and resume with value as result of last send. Execute unwind blocks when unwinding. ASSUMES self is a sender of thisContext" - - ^self resumeEvaluating: [value] - ! Item was removed: - ----- Method: Context>>resume:through: (in category 'controlling') ----- - resume: value through: firstUnwindCtxt - "Unwind thisContext to self and resume with value as result of last send. - Execute any unwind blocks while unwinding. - ASSUMES self is a sender of thisContext." - - | ctxt unwindBlock | - self isDead ifTrue: [self cannotReturn: value to: self]. - ctxt := firstUnwindCtxt. - [ctxt isNil] whileFalse: - [(ctxt tempAt: 2) ifNil: - [ctxt tempAt: 2 put: true. - unwindBlock := ctxt tempAt: 1. - thisContext terminateTo: ctxt. - unwindBlock value]. - ctxt := ctxt findNextUnwindContextUpTo: self]. - thisContext terminateTo: self. - ^value - ! Item was removed: - ----- Method: Context>>resumeEvaluating: (in category 'controlling') ----- - resumeEvaluating: aBlock - "Unwind thisContext to self and resume with value as result of last send. - Execute unwind blocks when unwinding. - ASSUMES self is a sender of thisContext" - - | ctxt unwindBlock | - self isDead ifTrue: [self cannotReturn: aBlock value to: self]. - ctxt := thisContext. - [ ctxt := ctxt findNextUnwindContextUpTo: self. - ctxt isNil - ] whileFalse: [ - (ctxt tempAt: 2) ifNil:[ - "(tempAt: 2) refers to complete temporary in ensure: and ifCurtailed: - or any other method marked with <primitive: 198>" - ctxt tempAt: 2 put: true. - unwindBlock := ctxt tempAt: 1. - thisContext terminateTo: ctxt. - unwindBlock value]. - ]. - thisContext terminateTo: self. - ^ aBlock value - ! Item was removed: - ----- Method: Context>>return (in category 'controlling') ----- - return - "Unwind until my sender is on top" - - self return: self receiver! Item was removed: - ----- Method: Context>>return: (in category 'controlling') ----- - return: value - "Unwind thisContext to self and return value to self's sender. Execute any unwind blocks while unwinding. ASSUMES self is a sender of thisContext" - - sender ifNil: [self cannotReturn: value to: sender]. - sender resume: value! Item was removed: - ----- Method: Context>>return:from: (in category 'instruction decoding') ----- - return: value from: aSender - "For simulation. Roll back self to aSender and return value from it. Execute any unwind blocks on the way. ASSUMES aSender is a sender of self" - - | newTop | - aSender isDead ifTrue: - [^self send: #cannotReturn: to: self with: {value}]. - newTop := aSender sender. - (self findNextUnwindContextUpTo: newTop) ifNotNil: - [:unwindProtectCtxt| - self flag: #knownBug. "Cannot #stepOver '^2' in example '[^2] ensure: []'. - See http://lists.squeakfoundation.org/pipermail/squeak-dev/2022-June/220975.html" - ^self send: #aboutToReturn:through: to: self with: {value. unwindProtectCtxt}]. - self releaseTo: newTop. - newTop ifNotNil: [newTop push: value]. - ^newTop! Item was removed: - ----- Method: Context>>return:through: (in category 'controlling') ----- - return: value through: firstUnwindContext - "Unwind thisContext to self and return value to self's sender. - Execute any unwind blocks while unwinding. - ASSUMES self is a sender of thisContext." - - sender ifNil: [self cannotReturn: value to: sender]. - sender resume: value through: firstUnwindContext! Item was removed: - ----- Method: Context>>return:to: (in category 'controlling') ----- - return: value to: sendr - "Simulate the return of value to sendr." - - self releaseTo: sendr. - sendr ifNil: [^ nil]. - ^ sendr push: value! Item was removed: - ----- Method: Context>>returnEvaluating: (in category 'controlling') ----- - returnEvaluating: aBlock - "Unwind thisContext to self and return aBlock value to self's sender. - Execute any unwind blocks while unwinding. - ASSUMES self is a sender of thisContext" - - sender ifNil: [self cannotReturn: aBlock value to: sender]. - sender resumeEvaluating: aBlock! Item was removed: - ----- Method: Context>>runSimulated:contextAtEachStep: (in category 'system simulation') ----- - runSimulated: aBlock contextAtEachStep: anotherBlock - "Simulate the execution of the argument, aBlock, until it ends or is curtailed. If any exception is signaled during the execution, simulate it being handled on the present caller stack. Evaluate anotherBlock with the current context prior to each instruction executed. Answer the simulated value of aBlock." - - | current resume ensure | - resume := false. - "Affect the context stack of the receiver during the simulation of aBlock." - current := aBlock asContextWithSender: self. - "Insert outer context denoting the end of the simulation." - ensure := (ensure := current) insertSender: (Context contextEnsure: - [resume := true. - ensure privSender: thisContext home sender]). - - (anotherBlock numArgs = 0 - ifTrue: ["optimized" [resume]] - ifFalse: ["stop execution on time, don't expose simulation details to caller" - [current == ensure or: - ["Context >> #resume:" - current size >= 2 and: - [(current at: 2) == ensure]]] ]) - whileFalse: - [anotherBlock cull: current. - current := current step]. - - "Continue with the execution in the previous context." - ^ current jump! Item was removed: - ----- Method: Context>>runUntilErrorOrReturnFrom: (in category 'controlling') ----- - runUntilErrorOrReturnFrom: aSender - "ASSUMES aSender is a sender of self. Execute self's stack until aSender returns or an unhandled exception is raised. Return a pair containing the new top context and a possibly nil exception. The exception is not nil if it was raised before aSender returned and it was not handled. The exception is returned rather than openning the debugger, giving the caller the choice of how to handle it." - "Self is run by jumping directly to it (the active process abandons thisContext and executes self). However, before jumping to self we insert an ensure block under aSender that jumps back to thisContext when evaluated. We also insert an exception handler under aSender that jumps back to thisContext when an unhandled exception is raised. In either case, the inserted ensure and exception handler are removed once control jumps back to thisContext." - - | error ctxt here topContext | - here := thisContext. - - "Insert ensure and exception handler contexts under aSender" - error := nil. - ctxt := aSender insertSender: (Context - contextOn: UnhandledError do: [:ex | - error ifNil: [ - error := ex exception. - topContext := thisContext. - ex resumeUnchecked: here jump] - ifNotNil: [ex pass] - ]). - ctxt := ctxt insertSender: (Context - contextEnsure: [error ifNil: [ - topContext := thisContext. - here jump] - ]). - self jump. "Control jumps to self" - - "Control resumes here once above ensure block or exception handler is executed" - ^ error ifNil: [ - "No error was raised, remove ensure context by stepping until popped" - [ctxt isDead] whileFalse: [topContext := topContext stepToCallee]. - {topContext. nil} - - ] ifNotNil: [ - "Error was raised, remove inserted above contexts then return signaler context" - aSender terminateTo: ctxt sender. "remove above ensure and handler contexts" - {topContext. error} - ]! Item was removed: - ----- Method: Context>>runUntilReturnFrom: (in category 'private-exceptions') ----- - runUntilReturnFrom: aContext - "Run the receiver (which must be its stack top context) until aContext returns. Avoid a context that cannot return. - Note: to avoid infinite recursion of MNU error inside unwind blocks, implement e.g. a wrapper around the message - sentTo: receiver in #doesNotUnderstand:. Note: This method is a trivialized version of #runUntilErrorOrReturnFrom: - and was intended to be used by #unwindTo as a helper method to unwind non-local returns inside unwind blocks." - - | here unwindBottom newTop | - here := thisContext. - "Avoid a context that cannot return between self and aContext (see Note 1 below)." - unwindBottom := self findContextSuchThat: [:ctx | ctx == aContext or: [ctx selector = #cannotReturn:]]. - newTop := unwindBottom sender. - "Insert ensure context under unwindBottom in self's stack (see Note 2 below)" - unwindBottom insertSender: (Context contextEnsure: [here jump]). - self jump. "Control jumps to the receiver's stack (see Note 2 below)" - "Control resumes here once the above inserted ensure block is executed (see #jump comments)" - ^newTop "Return the new top context (see Note 3 below)" - - "Note 1: returning from #cannotReturn's sender would crash the VM so we install a guard ensure context right - above it; after returning here the unwind will continue safely. Try running and debugging this example - (avoid Proceeding the BCR error though; it may indeed crash the image): - [[[] ensure: [^2]] ensure: [^42]] fork" - - "Note 2: the receiver (self) is run by jumping directly to it (the active process abandons thisContext and executes - self on its own stack; self must be its top context). However, before jumping to self we insert an ensure block under - unwindBottom context that will execute a jump back to thisContext when evaluated. The inserted guard ensure - context is removed once control jumps back to thisContext." - - "Note 3: it doesn't matter newTop is not a proper stack top context because #unwindTo will only use it as a starting - point in the search for the next unwind context and the computation will never return here. We could make newTop - a proper top context by pushing nil to its stack (^newTop push: nil) if need be (see #jump comments). - Cf. the pattern in #runUntilErrorOrReturnFrom:: removing the inserted ensure context by stepping until popped - when executing non-local returns wouldn't work here and would fail tests testTerminateInNestedEnsureWithReturn1 - through 4."! Item was removed: - ----- Method: Context>>secondFromBottom (in category 'query') ----- - secondFromBottom - "Return the second from bottom of my sender chain" - - self sender ifNil: [^ nil]. - ^ self findContextSuchThat: [:c | c sender sender isNil]! Item was removed: - ----- Method: Context>>selector (in category 'accessing') ----- - selector - "Answer the selector of the method that created the receiver." - - ^self method selector ifNil: [self method defaultSelector].! Item was removed: - ----- Method: Context>>selectorCategory (in category 'accessing') ----- - selectorCategory - "Answer the category to which this message belongs (relative to the receiver). - If no superclass categorises this message, use the default." - | rcvrClass organizers | - rcvrClass := self objectClass: self receiver. - organizers := rcvrClass withAllSuperclasses collect: [:ea | ea organization]. - organizers addFirst: rcvrClass organization. - ^(organizers collect: [ :org | org categoryOfElement: self selector]) - detect: [:ea | ea ~= ClassOrganizer default and: [ea ~= nil]] - ifNone: [ClassOrganizer default]! Item was removed: - ----- Method: Context>>send:super:numArgs: (in category 'instruction decoding') ----- - send: selector super: superFlag numArgs: numArgs - "Simulate the action of bytecodes that send a message with selector, - selector. The argument, superFlag, tells whether the receiver of the - message was specified with 'super' in the source method. The arguments - of the message are found in the top numArgs locations on the stack and - the receiver just below them." - - | thisReceiver arguments lookupClass | - arguments := Array new: numArgs. - numArgs to: 1 by: -1 do: [ :i | arguments at: i put: self pop]. - thisReceiver := self pop. - lookupClass := superFlag - ifTrue: [method methodClassAssociation value superclass] - ifFalse: [self objectClass: thisReceiver]. - QuickStep == self ifTrue: - [QuickStep := nil. - ^self quickSend: selector to: thisReceiver with: arguments lookupIn: lookupClass]. - ^self send: selector to: thisReceiver with: arguments lookupIn: lookupClass! Item was removed: - ----- Method: Context>>send:to:with: (in category 'controlling') ----- - send: selector to: rcvr with: arguments - "Simulate the action of sending a message with selector arguments to rcvr." - - ^self send: selector to: rcvr with: arguments lookupIn: (self objectClass: rcvr)! Item was removed: - ----- Method: Context>>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: - [selector == #doesNotUnderstand: ifTrue: - [self error: 'Recursive message not understood!!' translated]. - ^self send: #doesNotUnderstand: - to: rcvr - with: {(Message selector: selector arguments: arguments) lookupClass: lookupClass} - lookupIn: lookupClass]. - - (self objectClass: meth) isCompiledCodeClass ifFalse: - ["Object as Methods (OaM) protocol: 'The contract is that, when the VM encounters an ordinary object (rather than a compiled method) in the method dictionary during lookup, it sends it the special selector #run:with:in: providing the original selector, arguments, and receiver.'. DOI: 10.1145/2991041.2991062." - ^self send: #run:with:in: - to: meth - with: {selector. arguments. rcvr}]. - - meth numArgs = arguments size ifFalse: - [^ self error: ('Wrong number of arguments in simulated message {1}' translated format: {selector})]. - (primIndex := meth primitive) > 0 ifTrue: - [val := self doPrimitive: primIndex method: meth receiver: rcvr args: arguments. - (self isPrimFailToken: val) ifFalse: - [^val]]. - - ctxt := self activateMethod: meth withArgs: arguments receiver: rcvr. - (primIndex isInteger and: [primIndex > 0]) ifTrue: - [ctxt failPrimitiveWith: val]. - - ^ctxt! Item was removed: - ----- Method: Context>>sendSpecial:numArgs: (in category 'instruction decoding implicit literals') ----- - sendSpecial: selector numArgs: numArgs - "Simulate the action of bytecodes that send a message with selector, - selector. The arguments of the message are found in the top numArgs - locations on the stack and the receiver just below them." - - | thisReceiver arguments lookupClass | - arguments := Array new: numArgs. - numArgs to: 1 by: -1 do: [ :i | arguments at: i put: self pop]. - thisReceiver := self pop. - lookupClass := self objectClass: thisReceiver. - QuickStep == self ifTrue: - [QuickStep := nil. - ^self quickSend: selector to: thisReceiver with: arguments lookupIn: lookupClass]. - ^self send: selector to: thisReceiver with: arguments lookupIn: lookupClass! Item was removed: - ----- Method: Context>>sender (in category 'accessing') ----- - sender - "Answer the context that sent the message that created the receiver." - - ^sender! Item was removed: - ----- Method: Context>>setSender:receiver:method:arguments: (in category 'private') ----- - setSender: s receiver: r method: m arguments: args - "Create the receiver's initial state." - - sender := s. - receiver := r. - method := m. - closureOrNil := nil. - pc := method initialPC. - self stackp: method numTemps. - 1 to: args size do: [:i | self at: i put: (args at: i)]! Item was removed: - ----- Method: Context>>setSender:receiver:method:closure:startpc: (in category 'private') ----- - setSender: s receiver: r method: m closure: c startpc: startpc - "Create the receiver's initial state." - - sender := s. - receiver := r. - method := m. - closureOrNil := c. - pc := startpc. - stackp := 0! Item was removed: - ----- Method: Context>>shortStack (in category 'debugger access') ----- - shortStack - "Answer a String showing the top ten contexts on my sender chain." - - ^ String streamContents: - [:strm | - (self stackOfSize: 10) - do: [:item | strm print: item; cr]]! Item was removed: - ----- Method: Context>>simulatedObject:instVarAt:put: (in category 'read-only objects') ----- - simulatedObject: anObject instVarAt: anIndex put: aValue - "Primitive. Store a value into a fixed variable in the argument anObject. - 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, or if anObject is read-only. This version correctly simulates - assigning to a read-only object. 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 for - the debugger. See Object documentation whatIsAPrimitive." - - <primitive: 174 error: ec> - ec == #'no modification' ifTrue: - [^self send: #attemptToAssign:to:withIndex: to: self with: {aValue. anObject. anIndex} lookupIn: self class]. - self primitiveFailed! Item was removed: - ----- Method: Context>>singleRelease (in category 'debugger access') ----- - singleRelease - "Remove information from the receiver in order to break circularities." - - stackp == nil ifFalse: [1 to: stackp do: [:i | self at: i put: nil]]. - sender := nil. - pc := nil. - ! Item was removed: - ----- Method: Context>>size (in category 'accessing') ----- - size - "Primitive. Answer the number of indexable variables in the receiver. - This value is the same as the largest legal subscript. Essential. See Object - documentation whatIsAPrimitive. Override the default primitive to give latitude to - the VM in context management." - - <primitive: 212> - "The number of indexable fields of fixed-length objects is 0" - ^self primitiveFailed! Item was removed: - ----- Method: Context>>sourceCode (in category 'accessing') ----- - sourceCode - ^self method getSource. - - "Note: The above is a bit safer than - ^ methodClass sourceCodeAt: selector - which may fail if the receiver's method has been changed in - the debugger (e.g., the method is no longer in the methodDict - and thus the above selector is something like #Doit:with:with:with:) - but the source code is still available."! Item was removed: - ----- Method: Context>>stack (in category 'debugger access') ----- - stack - "Answer an Array of the contexts on the receiver's sender chain." - - ^self stackOfSize: 9999! Item was removed: - ----- Method: Context>>stackOfSize: (in category 'debugger access') ----- - stackOfSize: limit - "Answer an OrderedCollection of the top 'limit' contexts - on the receiver's sender chain." - - | stack ctxt | - stack := OrderedCollection new. - stack addLast: (ctxt := self). - [(ctxt := ctxt sender) ~~ nil - and: [stack size < limit]] whileTrue: - [stack addLast: ctxt]. - ^stack! Item was removed: - ----- Method: Context>>stackPtr (in category 'private') ----- - stackPtr "For use only by the SystemTracer and the Debugger, Inspectors etc" - ^ stackp! Item was removed: - ----- Method: Context>>stackp: (in category 'private') ----- - stackp: newStackp - "Storing into the stack pointer is a potentially dangerous thing. - This primitive stores nil into any cells that become accessible as a result, - and it performs the entire operation atomically." - "Once this primitive is implemented, failure code should cause an error" - - <primitive: 76> - self error: 'stackp store failure'. - " - stackp == nil ifTrue: [stackp := 0]. - newStackp > stackp 'effectively checks that it is a number' - ifTrue: [oldStackp := stackp. - stackp := newStackp. - 'Nil any newly accessible cells' - oldStackp + 1 to: stackp do: [:i | self at: i put: nil]] - ifFalse: [stackp := newStackp] - "! Item was removed: - ----- Method: Context>>startpc (in category 'private') ----- - startpc - ^closureOrNil - ifNil: [self method initialPC] - ifNotNil: [closureOrNil startpc]! Item was removed: - ----- Method: Context>>step (in category 'system simulation') ----- - step - "Simulate the execution of the receiver's next bytecode. Answer the - context that would be the active context after this bytecode." - - ^self interpretNextInstructionFor: self! Item was removed: - ----- Method: Context>>stepToCallee (in category 'system simulation') ----- - stepToCallee - "Step to callee or sender" - - | ctxt | - ctxt := self. - [(ctxt := ctxt step) == self] whileTrue. - ^ ctxt! Item was removed: - ----- Method: Context>>stepToSendOrReturn (in category 'system simulation') ----- - stepToSendOrReturn - "Simulate the execution of bytecodes until either sending a message or - returning a value to the receiver (that is, until switching contexts)." - - | ctxt | - [self willReallySend or: [self willReturn or: [self willReallyStore]]] whileFalse: - [ctxt := self step. - ctxt == self ifFalse: - [self halt. - "Caused by mustBeBoolean handling" - ^ctxt]]! Item was removed: - ----- Method: Context>>storeDataOn: (in category 'objects from disk') ----- - storeDataOn: aDataStream - "Contexts are not always allowed go to out in DataStreams. They must be included inside an ImageSegment, - or be being saved for a closure." - | cntInstVars cntIndexedVars | - - (aDataStream insideASegment - or: [(Notification new tag: self; signal) == self]) ifFalse: "or perhaps ImageSegments were not used at all" - [self error: 'This Context was not included in the ImageSegment']. - - cntInstVars := self class instSize. - cntIndexedVars := self method frameSize. - aDataStream - beginInstance: self class - size: cntInstVars + cntIndexedVars. - 1 to: cntInstVars do: - [:i | aDataStream nextPut: (self instVarAt: i)]. - 1 to: stackp do: - [:i | aDataStream nextPut: (self basicAt: i)]. - stackp + 1 to: cntIndexedVars do: - [:i | aDataStream nextPut: nil]! Item was removed: - ----- Method: Context>>storeIntoLiteralVariable: (in category 'instruction decoding') ----- - storeIntoLiteralVariable: value - "Simulate the action of bytecode that stores the top of the stack into a - literal variable of my method. If the receiver is read-only - this will provoke a send of #attemptToAssign:withIndex:" - - | top result | - top := self top. - result := self simulatedObject: value instVarAt: ValueIndex put: top. - ^(self object: result eqeq: top) - ifTrue: [self] - ifFalse: [result]! Item was removed: - ----- Method: Context>>storeIntoReceiverVariable: (in category 'instruction decoding') ----- - storeIntoReceiverVariable: offset - "Simulate the action of bytecode that stores the top of the stack into an - instance variable of my receiver. If the receiver is read-only - this will provoke a send of #attemptToAssign:withIndex:" - - | top result | - top := self top. - result := self simulatedObject: self receiver instVarAt: offset + 1 put: top. - ^(self object: result eqeq: top) - ifTrue: [self] - ifFalse: [result]! Item was removed: - ----- Method: Context>>storeIntoRemoteTemp:inVectorAt: (in category 'instruction decoding') ----- - storeIntoRemoteTemp: remoteTempIndex inVectorAt: tempVectorIndex - "Simulate the action of bytecode that stores the top of the stack at - an offset in one of my local variables being used as a remote temp vector." - - self object: (self at: tempVectorIndex + 1) basicAt: remoteTempIndex + 1 put: self top! Item was removed: - ----- Method: Context>>storeIntoTemporaryVariable: (in category 'instruction decoding') ----- - storeIntoTemporaryVariable: offset - "Simulate the action of bytecode that stores the top of the stack into one - of my temporary variables." - - self at: offset + 1 put: self top! Item was removed: - ----- Method: Context>>swapReceiver: (in category 'private-exceptions') ----- - swapReceiver: r - | oldReceiver | - oldReceiver := receiver. - receiver := r. - ^oldReceiver! Item was removed: - ----- Method: Context>>swapSender: (in category 'debugger access') ----- - swapSender: coroutine - "Replace the receiver's sender with coroutine and answer the receiver's - previous sender. For use in coroutining." - - | oldSender | - oldSender := sender. - sender := coroutine. - ^oldSender! Item was removed: - ----- Method: Context>>tempAt: (in category 'accessing') ----- - tempAt: index - "Answer the value of the temporary variable whose index is the - argument, index. Primitive. Assumes receiver is indexable. Answer the - value of an indexable element in the receiver. Fail if the argument index - is not an Integer or is out of bounds. Essential. See Object documentation - whatIsAPrimitive. Override the default at: primitive to give latitude to the - VM in context management." - - <primitive: 210> - ^self at: index! Item was removed: - ----- Method: Context>>tempAt:put: (in category 'accessing') ----- - tempAt: index put: value - "Store the argument, value, as the temporary variable whose index is the - argument, index. Primitive. Assumes receiver is indexable. Answer the - value of an indexable element in the receiver. Fail if the argument index - is not an Integer or is out of bounds. Essential. See Object documentation - whatIsAPrimitive. Override the default at:put: primitive to give latitude to - the VM in context management." - - <primitive: 211> - ^self at: index put: value! Item was removed: - ----- Method: Context>>terminate (in category 'controlling') ----- - terminate - "Make myself unresumable." - - sender := nil. - pc := nil. - ! Item was removed: - ----- Method: Context>>terminateTo: (in category 'controlling') ----- - terminateTo: previousContext - "Terminate all the Contexts between me and previousContext, if previousContext is on my Context stack. Make previousContext my sender." - - | currentContext sendingContext | - <primitive: 196> - (self hasSender: previousContext) ifTrue: [ - currentContext := sender. - [currentContext == previousContext] whileFalse: [ - sendingContext := currentContext sender. - currentContext terminate. - currentContext := sendingContext]]. - sender := previousContext! Item was removed: - ----- Method: Context>>top (in category 'controlling') ----- - top - "Answer the top of the receiver's stack." - - ^self at: stackp! Item was removed: - ----- Method: Context>>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." - <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! Item was removed: - ----- Method: Context>>unwindTo: (in category 'private-exceptions') ----- - unwindTo: aContext - "Unwind the receiver to aContext to execute all pending unwind blocks." - - self unwindTo: aContext safely: true! Item was removed: - ----- Method: Context>>unwindTo:safely: (in category 'private-exceptions') ----- - unwindTo: aContext safely: aBoolean - "Unwind self to aContext to execute pending #ensure:/#ifCurtailed: argument blocks between self - and aContext. If aBoolean is false, unwind only blocks that have not run yet, otherwise complete all - pending unwind blocks including those currently in the middle of their execution; these blocks will - just finish their execution. Run all unwinds on their original stack using #runUntilReturnFrom:." - - | top ctx | - ctx := top := self. - aBoolean ifTrue: [ - "If self is the top context of a stack already halfways through an unwind block, complete the outer-most - unfinished unwind block first; all nested pending unwind blocks will be completed in the process; - see testTerminationDuringUnwind and tests in ProcessTest/UnwindTest. - Note: Halfway-through blocks have already set the complete variable (ctxt tempAt: 2) in their - defining #ensure:/#ifCurtailed contexts from nil to true; we'll search for the bottom-most one." - | outerMost | - ctx isUnwindContext ifFalse: [ctx := ctx findNextUnwindContextUpTo: aContext]. - [ctx isNil] whileFalse: [ - (ctx tempAt: 2) ifNotNil: [ - outerMost := ctx]. - ctx := ctx findNextUnwindContextUpTo: aContext]. - outerMost ifNotNil: [top := top runUntilReturnFrom: outerMost]]. - "By now no halfway-through unwind blocks are on the stack. - Note: top points to the former outerMost sender now, i.e. to the next context to be explored." - - ctx := top ifNil: [^self]. - "#findNextUnwindContextUpTo: starts searching from the receiver's sender so we must check - the receiver explicitly whether it is an unwind context; see testTerminateEnsureAsStackTop. - Create a new top context (i.e. a new branch off the original stack) for each pending unwind block - (ctxt tempAt: 1) and execute it on the unwind block's stack to evaluate non-local returns correctly." - ctx isUnwindContext ifFalse: [ctx := ctx findNextUnwindContextUpTo: aContext]. - [ctx isNil] whileFalse: [ - (ctx tempAt: 2) ifNil: [ - ctx tempAt: 2 put: true. - top := (ctx tempAt: 1) asContextWithSender: ctx. - top runUntilReturnFrom: top]. - ctx := ctx findNextUnwindContextUpTo: aContext] - "Note: Cf. the unwind pattern in the previous versions of unwindTo: (1999-2021). Using #value - instead of #runUntilReturnFrom: lead to a failure to evaluate some non-local returns correctly; - a non-local return must be evaluated in the evaluation context (sender chain) in which it was defined."! Item was removed: - ----- Method: Context>>willHandleSignal: (in category 'private-exceptions') ----- - willHandleSignal: exception - "Sent to handler (on:do:) contexts only." - - ^self isHandlerActive and: [(self tempAt: 1) handles: exception] - ! Item was removed: - Object subclass: #Delay - instanceVariableNames: 'delayDuration resumptionTime delaySemaphore beingWaitedOn' - classVariableNames: 'AccessProtect ActiveDelay DelaySuspended FinishedDelay RunTimerEventLoop ScheduledDelay SuspendedDelays TimerEventLoop TimingSemaphore' - poolDictionaries: '' - category: 'Kernel-Processes'! - - !Delay commentStamp: 'eem 1/5/2016 11:58' prior: 0! - I am the main way that a process may pause for some amount of time. The simplest usage is like this: - - (Delay forSeconds: 5) wait. - - An instance of Delay responds to the message 'wait' by suspending the caller's process for a certain amount of time. The duration of the pause is specified when the Delay is created with the message forMilliseconds: or forSeconds:. A Delay can be used again when the current wait has finished. For example, a clock process might repeatedly wait on a one-second Delay. - - A delay in progress when an image snapshot is saved is resumed when the snapshot is re-started. - For a more complex example, see #testDelayOf:for:rect: . - - A word of advice: - This is THE highest priority code which is run in Squeak, in other words it is time-critical. The speed of this code is critical for accurate responses, it is critical for network services, it affects every last part of the system. - - In short: Don't fix it if it ain't broken!! This code isn't supposed to be beautiful, it's supposed to be fast!! The reason for duplicating code is to make it fast. The reason for not using ifNil:[]ifNotNil:[] is that the compiler may not inline those. Since the effect of changes are VERY hard to predict it is best to leave things as they are for now unless there is an actual need to change anything - - - Instance Variables - beingWaitedOn: <UndefinedObject|Boolean> - delayDuration: <Integer> - delaySemaphore: <Semaphore> - resumptionTime: <Integer> - - beingWaitedOn - - this is set when the delay is being waited on or is unscheduled. - - delayDuration - - the duration of the delay in milliseconds - - delaySemaphore - - the semaphore used to suspend process(es) waiting on this delay - - resumptionTime - - the value of the UTC miscrosecond clock at which the delay should resume processes waiting on it'! Item was removed: - ----- Method: Delay class>>anyActive (in category 'testing') ----- - anyActive - "Return true if there is any delay currently active" - ^ActiveDelay notNil! Item was removed: - ----- Method: Delay class>>cleanUp (in category 'class initialization') ----- - cleanUp - - self initialize.! Item was removed: - ----- Method: Delay class>>forDuration: (in category 'instance creation') ----- - forDuration: aDuration - - ^ self forMilliseconds: aDuration asMilliSeconds - ! Item was removed: - ----- Method: Delay class>>forMilliseconds: (in category 'instance creation') ----- - forMilliseconds: anInteger - "Return a new Delay for the given number of milliseconds. Sending 'wait' to this Delay will cause the sender's process to be suspended for approximately that length of time." - - anInteger < 0 ifTrue: [self error: 'delay times cannot be negative']. - ^ self new - setDelay: anInteger asInteger - forSemaphore: Semaphore new - ! Item was removed: - ----- Method: Delay class>>forSeconds: (in category 'instance creation') ----- - forSeconds: aNumber - "Return a new Delay for the given number of seconds. Sending 'wait' to this Delay will cause the sender's process to be suspended for approximately that length of time." - - aNumber < 0 ifTrue: [self error: 'delay times cannot be negative']. - ^ self new - setDelay: (aNumber * 1000) asInteger - forSemaphore: Semaphore new - ! Item was removed: - ----- Method: Delay class>>handleTimerEvent (in category 'timer process') ----- - handleTimerEvent - "Handle a timer event; which can be either: - - a schedule request (ScheduledDelay notNil) - - an unschedule request (FinishedDelay notNil) - - a timer signal (not explicitly specified) - We check for timer expiry every time we get a signal." - | nowTick nextTick | - "Wait until there is work to do." - TimingSemaphore wait. - nowTick := Time utcMicrosecondClock. - - "Process any schedule requests" - ScheduledDelay ifNotNil: - [self scheduleDelay: ScheduledDelay from: nowTick. - ScheduledDelay := nil]. - - "Process any unschedule requests" - FinishedDelay ifNotNil: - [self unscheduleDelay: FinishedDelay. - FinishedDelay := nil]. - - "Signal any expired delays" - [ActiveDelay notNil - and: [nowTick >= ActiveDelay resumptionTime]] whileTrue: - [ActiveDelay signalWaitingProcess. - ActiveDelay := SuspendedDelays isEmpty ifFalse: - [SuspendedDelays removeFirst]]. - - "And signal when the next request is due. We sleep at most 1sec here - as a soft busy-loop so that we don't accidentally miss signals." - nextTick := nowTick + 1000000. - ActiveDelay ifNotNil: - [nextTick := nextTick min: ActiveDelay resumptionTime]. - - "Since we have processed all outstanding requests, reset the timing semaphore so - that only new work will wake us up again. Do this RIGHT BEFORE setting the next - wakeup call from the VM because it is only signaled once so we mustn't miss it." - TimingSemaphore initSignals. - Delay primSignal: TimingSemaphore atUTCMicroseconds: nextTick! Item was removed: - ----- Method: Delay class>>initialize (in category 'class initialization') ----- - initialize - "Delay initialize." - self startTimerEventLoop.! Item was removed: - ----- Method: Delay class>>nextWakeUpTime (in category 'testing') ----- - nextWakeUpTime - ^ AccessProtect - critical: [ActiveDelay isNil - ifTrue: [0] - ifFalse: [ActiveDelay resumptionTime]]! Item was removed: - ----- Method: Delay class>>primSignal:atUTCMicroseconds: (in category 'primitives') ----- - primSignal: aSemaphore atUTCMicroseconds: anInteger - "Signal the semaphore when the UTC microsecond clock reaches the value of the second argument. - Fail if the first argument is neither a Semaphore nor nil, or if the second argument is not an integer. - Essential. See Object documentation whatIsAPrimitive." - <primitive: 242> - ^self primitiveFailed! Item was removed: - ----- Method: Delay class>>restoreResumptionTimes (in category 'timer process') ----- - restoreResumptionTimes - "Private!! Restore the resumption times of all scheduled Delays after a snapshot. - This method should be called only while the AccessProtect semaphore is held." - - | newBaseTime | - newBaseTime := Time utcMicrosecondClock. - SuspendedDelays do: - [:d | d adjustResumptionTimeOldBase: 0 newBase: newBaseTime]. - ActiveDelay ifNotNil: - [ActiveDelay adjustResumptionTimeOldBase: 0 newBase: newBaseTime]! Item was removed: - ----- Method: Delay class>>runTimerEventLoop (in category 'timer process') ----- - runTimerEventLoop - "Run the timer event loop." - [RunTimerEventLoop] whileTrue: [self handleTimerEvent]! Item was removed: - ----- Method: Delay class>>saveResumptionTimes (in category 'timer process') ----- - saveResumptionTimes - "Private!! Record the resumption times of all Delays relative to a base time of zero. - This is done prior to snapshotting. This method should be called only while the - AccessProtect semaphore is held." - - | oldBaseTime | - oldBaseTime := Time utcMicrosecondClock. - ActiveDelay ifNotNil: - [ActiveDelay adjustResumptionTimeOldBase: oldBaseTime newBase: 0]. - SuspendedDelays do: - [:d | d adjustResumptionTimeOldBase: oldBaseTime newBase: 0]! Item was removed: - ----- Method: Delay class>>scheduleDelay:from: (in category 'timer process') ----- - scheduleDelay: aDelay from: nowUsecs - "Private. Schedule this Delay." - - aDelay - resumptionTime: nowUsecs + aDelay microsecondDelayDuration; - beingWaitedOn: true. - ActiveDelay - ifNil: [ActiveDelay := aDelay] - ifNotNil: - [aDelay resumptionTime < ActiveDelay resumptionTime - ifTrue: [SuspendedDelays add: ActiveDelay. - ActiveDelay := aDelay] - ifFalse: [SuspendedDelays add: aDelay]]! Item was removed: - ----- Method: Delay class>>shutDown (in category 'snapshotting') ----- - shutDown - "Suspend the active delay, if any, before snapshotting. It will be reactived when the snapshot is resumed." - "Details: This prevents a timer interrupt from waking up the active delay in the midst snapshoting, since the active delay will be restarted when resuming the snapshot and we don't want to process the delay twice." - - AccessProtect wait. - self primSignal: nil atUTCMicroseconds: 0. - self saveResumptionTimes. - DelaySuspended := true! Item was removed: - ----- Method: Delay class>>startTimerEventLoop (in category 'timer process') ----- - startTimerEventLoop - "Start the timer event loop" - "Delay startTimerEventLoop" - self stopTimerEventLoop. - AccessProtect := Semaphore forMutualExclusion. - SuspendedDelays := - Heap withAll: (SuspendedDelays ifNil:[#()]) - sortBlock: [:d1 :d2 | d1 resumptionTime <= d2 resumptionTime]. - TimingSemaphore := Semaphore new. - RunTimerEventLoop := true. - TimerEventLoop := [self runTimerEventLoop] newProcess. - TimerEventLoop priority: Processor timingPriority. - TimerEventLoop resume. - TimingSemaphore signal "get going"! Item was removed: - ----- Method: Delay class>>startUp (in category 'snapshotting') ----- - startUp - "Restart active delay, if any, when resuming a snapshot." - - DelaySuspended ifFalse:[^self error: 'Trying to activate Delay twice']. - DelaySuspended := false. - self restoreResumptionTimes. - AccessProtect signal. - (Smalltalk classNamed: #DoItFirst) ifNotNil: [ :doit | doit perform: #reevaluateDebug]. - - - ! Item was removed: - ----- Method: Delay class>>stopTimerEventLoop (in category 'timer process') ----- - stopTimerEventLoop - "Stop the timer event loop" - RunTimerEventLoop := false. - TimingSemaphore signal. - TimerEventLoop := nil.! Item was removed: - ----- Method: Delay class>>testDelayOf:for:rect: (in category 'example') ----- - testDelayOf: delay for: testCount rect: r - "Delay testDelayOf: 100 for: 20 rect: (10 at 10 extent: 30 at 30). - Delay testDelayOf: 400 for: 20 rect: (50 at 10 extent: 30 at 30)." - - | onDelay offDelay | - onDelay := Delay forMilliseconds: 50. - offDelay := Delay forMilliseconds: delay - 50. - Display fillBlack: r. - [1 to: testCount do: [:i | - Display fillWhite: r. - onDelay wait. - Display reverse: r. - offDelay wait]. - ] forkAt: Processor userInterruptPriority. - ! Item was removed: - ----- Method: Delay class>>timeoutSemaphore:afterMSecs: (in category 'instance creation') ----- - timeoutSemaphore: aSemaphore afterMSecs: anInteger - "Create and schedule a Delay to signal the given semaphore when the given number of milliseconds has elapsed. Return the scheduled Delay. The timeout can be cancelled by sending 'unschedule' to this Delay." - "Details: This mechanism is used to provide a timeout when waiting for an external event, such as arrival of data over a network connection, to signal a semaphore. The timeout ensures that the semaphore will be signalled within a reasonable period of time even if the event fails to occur. Typically, the waiting process cancels the timeout request when awoken, then determines if the awaited event has actually occurred." - - anInteger < 0 ifTrue: [self error: 'delay times cannot be negative']. - ^ (self new setDelay: anInteger forSemaphore: aSemaphore) schedule - ! Item was removed: - ----- Method: Delay class>>unscheduleDelay: (in category 'timer process') ----- - unscheduleDelay: aDelay - "Private. Unschedule this Delay." - aDelay beingWaitedOn ifFalse:[^self]. - ActiveDelay == aDelay ifTrue: [ - SuspendedDelays isEmpty ifTrue:[ - ActiveDelay := nil. - ] ifFalse: [ - ActiveDelay := SuspendedDelays removeFirst. - ] - ] ifFalse:[ - SuspendedDelays remove: aDelay ifAbsent: []. - ]. - aDelay beingWaitedOn: false.! Item was removed: - ----- Method: Delay>>adjustResumptionTimeOldBase:newBase: (in category 'private') ----- - adjustResumptionTimeOldBase: oldBaseTime newBase: newBaseTime - "Private!! Adjust the value of the system's millisecond clock at which this Delay will be awoken. Used to adjust resumption times after a snapshot or clock roll-over." - - resumptionTime := newBaseTime + (resumptionTime - oldBaseTime). - ! Item was removed: - ----- Method: Delay>>beingWaitedOn (in category 'public') ----- - beingWaitedOn - "Answer whether this delay is currently scheduled, e.g., being waited on" - ^beingWaitedOn! Item was removed: - ----- Method: Delay>>beingWaitedOn: (in category 'public') ----- - beingWaitedOn: aBool - "Indicate whether this delay is currently scheduled, e.g., being waited on" - beingWaitedOn := aBool! Item was removed: - ----- Method: Delay>>delayDuration (in category 'public') ----- - delayDuration - "Answer the receiver's duration in milliseconds." - ^delayDuration! Item was removed: - ----- Method: Delay>>delayDuration: (in category 'public') ----- - delayDuration: milliseconds - "Set teh receiver's duration in milliseconds, iff it is not active." - milliseconds < 0 ifTrue: - [self error: 'Delay times cannot be negative!!']. - beingWaitedOn == true ifTrue: - [self error: 'This delay is scheduled!!']. - delayDuration := milliseconds asInteger! Item was removed: - ----- Method: Delay>>delaySemaphore (in category 'public') ----- - delaySemaphore - - ^ delaySemaphore! Item was removed: - ----- Method: Delay>>isExpired (in category 'delaying') ----- - isExpired - - ^delaySemaphore isSignaled. - ! Item was removed: - ----- Method: Delay>>microsecondDelayDuration (in category 'public') ----- - microsecondDelayDuration - "Answer the receiver's duration in microseconds." - ^delayDuration * 1000! Item was removed: - ----- Method: Delay>>printOn: (in category 'printing') ----- - printOn: aStream - super printOn: aStream. - aStream - nextPut: $(; - print: delayDuration; - nextPutAll: ' msecs'. - beingWaitedOn ifTrue: - [aStream - nextPutAll: '; '; - print: resumptionTime - Time utcMicrosecondClock + 500 // 1000; - nextPutAll: ' msecs remaining']. - aStream nextPut: $)! Item was removed: - ----- Method: Delay>>resumptionTime (in category 'private') ----- - resumptionTime - "Answer the value of the system's millisecondClock at which the receiver's suspended Process will resume." - - ^ resumptionTime - ! Item was removed: - ----- Method: Delay>>resumptionTime: (in category 'private') ----- - resumptionTime: anInteger - "Private!! Set the value of the system's millisecondClock at which the receiver's suspended Process will resumed. - Must only be called from the class-side #scheduleDelay:." - - resumptionTime := anInteger! Item was removed: - ----- Method: Delay>>schedule (in category 'private') ----- - schedule - "Schedule this delay." - - beingWaitedOn ifTrue: [^self error: 'This Delay has already been scheduled.']. - AccessProtect critical: [ - ScheduledDelay := self. - TimingSemaphore signal]! Item was removed: - ----- Method: Delay>>setDelay:forSemaphore: (in category 'private') ----- - setDelay: millisecondCount forSemaphore: aSemaphore - "Private!! Initialize this delay to signal the given semaphore after the given number of milliseconds." - - delayDuration := millisecondCount. - delaySemaphore := aSemaphore. - beingWaitedOn := false. - ! Item was removed: - ----- Method: Delay>>signalWaitingProcess (in category 'private') ----- - signalWaitingProcess - "The delay time has elapsed; signal the waiting process." - - beingWaitedOn := false. - delaySemaphore signal. - ! Item was removed: - ----- Method: Delay>>unschedule (in category 'private') ----- - unschedule - AccessProtect critical:[ - FinishedDelay := self. - TimingSemaphore signal. - ].! Item was removed: - ----- Method: Delay>>unscheduleEvent (in category 'private') ----- - unscheduleEvent - AccessProtect critical:[ - FinishedDelay := self. - TimingSemaphore signal. - ].! Item was removed: - ----- Method: Delay>>wait (in category 'delaying') ----- - wait - "Schedule this Delay, then wait on its semaphore. The current process will be suspended for the amount of time specified when this Delay was created. NOTE THAT for delays shorter than 50 milliseconds, you might want to use #busyWait for greater precision if the higher CPU load and restricted process scheduling are not an issue. See commentary in #busyWait." - - self schedule. - [delaySemaphore wait] ifCurtailed:[self unschedule]. - ! Item was removed: - Delay subclass: #DelayWaitTimeout - instanceVariableNames: 'process expired' - classVariableNames: '' - poolDictionaries: '' - category: 'Kernel-Processes'! - - !DelayWaitTimeout commentStamp: '<historical>' prior: 0! - DelayWaitTimeout is a special kind of Delay used in waitTimeoutMSecs: to avoid signaling the underlying semaphore when the wait times out.! Item was removed: - ----- Method: DelayWaitTimeout>>isExpired (in category 'testing') ----- - isExpired - "Did this timeout fire before the associated semaphore was signaled?" - ^expired! Item was removed: - ----- Method: DelayWaitTimeout>>setDelay:forSemaphore: (in category 'private') ----- - setDelay: anInteger forSemaphore: aSemaphore - super setDelay: anInteger forSemaphore: aSemaphore. - process := Processor activeProcess. - expired := false.! Item was removed: - ----- Method: DelayWaitTimeout>>signalWaitingProcess (in category 'signaling') ----- - signalWaitingProcess - "Release the given process from the semaphore it is waiting on. - This method relies on running at highest priority so that it cannot be preempted - by the process being released." - beingWaitedOn := false. - "Release the process but only if it is still waiting on its original list" - process suspendingList == delaySemaphore ifTrue:[ - expired := true. - process suspendAndUnblock; resume. - ]. - ! Item was removed: - ----- Method: DelayWaitTimeout>>wait (in category 'waiting') ----- - wait - "Wait until either the semaphore is signaled or the delay times out" - [self schedule. - "It is critical that the following has no suspension point so that - the test and the wait primitive are atomic. In addition, if the delay - is no longer being waited on while entering the way we know that it - is expired because the delay has already fired." - beingWaitedOn - ifTrue:[delaySemaphore wait] - ifFalse:[expired := true]] ensure:[self unschedule]. - ^self isExpired - ! Item was removed: - Collection weakSubclass: #DependentsArray - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Kernel-Models'! - - !DependentsArray commentStamp: 'nice 11/11/2009 20:30' prior: 0! - Act as an array of (weak) dependents of some object. - - When dependents are reclaimed, they are replaced by an UndefinedObject in the DependentsArray. - This is why instances of this class will take care to iterate only on non nil elements. - These nil also cause loops written as (1 to: self size do: [:i | (self at: i) doSomething]) to be inefficient. - This is because #size and #at: both require scanning for nils. - For this reason, DependentsArray though sequenceable, is not a subclass of SequenceableCollection.! Item was removed: - ----- Method: DependentsArray class>>with: (in category 'instance creation') ----- - with: anObject - ^(self basicNew: 1) basicAt: 1 put: anObject; yourself! Item was removed: - ----- Method: DependentsArray class>>with:with: (in category 'instance creation') ----- - with: firstObject with: secondObject - ^(self basicNew: 2) - basicAt: 1 put: firstObject; - basicAt: 2 put: secondObject; - yourself! Item was removed: - ----- Method: DependentsArray class>>with:with:with: (in category 'instance creation') ----- - with: firstObject with: secondObject with: thirdObject - ^(self basicNew: 3) - basicAt: 1 put: firstObject; - basicAt: 2 put: secondObject; - basicAt: 3 put: thirdObject; - yourself! Item was removed: - ----- Method: DependentsArray class>>with:with:with:with: (in category 'instance creation') ----- - with: firstObject with: secondObject with: thirdObject with: fourthObject - ^(self basicNew: 4) - basicAt: 1 put: firstObject; - basicAt: 2 put: secondObject; - basicAt: 3 put: thirdObject; - basicAt: 4 put: fourthObject; - yourself! Item was removed: - ----- Method: DependentsArray class>>with:with:with:with:with: (in category 'instance creation') ----- - with: firstObject with: secondObject with: thirdObject with: fourthObject with: fifthObject - ^(self basicNew: 5) - basicAt: 1 put: firstObject; - basicAt: 2 put: secondObject; - basicAt: 3 put: thirdObject; - basicAt: 4 put: fourthObject; - basicAt: 5 put: fifthObject; - yourself! Item was removed: - ----- Method: DependentsArray class>>with:with:with:with:with:with: (in category 'instance creation') ----- - with: firstObject with: secondObject with: thirdObject with: fourthObject with: fifthObject with: sixthObject - ^(self basicNew: 6) - basicAt: 1 put: firstObject; - basicAt: 2 put: secondObject; - basicAt: 3 put: thirdObject; - basicAt: 4 put: fourthObject; - basicAt: 5 put: fifthObject; - basicAt: 6 put: sixthObject; - yourself! Item was removed: - ----- Method: DependentsArray class>>withAll: (in category 'instance creation') ----- - withAll: aCollection - | newInstance | - newInstance := self basicNew: aCollection size. - 1 to: aCollection size do: [:i | - newInstance basicAt: i put: (aCollection at: i)]. - ^newInstance! Item was removed: - ----- Method: DependentsArray>>at: (in category 'accessing') ----- - at: anIndex - | basicSize counter dep | - anIndex > 0 ifTrue: [ - basicSize := self basicSize. - anIndex <= basicSize ifTrue: [ - counter := 0. - 1 to: basicSize do: [:i | - (dep := self basicAt: i) == nil - ifFalse: [(counter := counter + 1) = anIndex ifTrue: [^dep]]]]]. - self error: 'access with an index out of bounds'! Item was removed: - ----- Method: DependentsArray>>at:put: (in category 'accessing') ----- - at: anIndex put: anObject - | basicSize counter | - anIndex > 0 ifTrue: [ - basicSize := self basicSize. - anIndex <= basicSize ifTrue: [ - counter := 0. - 1 to: basicSize do: [:i | - (self basicAt: i) == nil - ifFalse: [(counter := counter + 1) = anIndex ifTrue: [^self basicAt: i put: anObject]]]]]. - self error: 'access with an index out of bounds'! Item was removed: - ----- Method: DependentsArray>>basicReplaceFrom:to:with:startingAt: (in category 'private') ----- - basicReplaceFrom: start to: stop with: replacement startingAt: repStart - "Primitive. This destructively replaces elements from start to stop in the receiver starting at index, repStart, in the collection, replacement. Answer the receiver. Range checks are performed in the primitive only. Optional. See Object documentation whatIsAPrimitive." - <primitive: 105> - start to: stop do: [:i | - self basicAt: i put: (replacement basicAt: repStart - start + i)]! Item was removed: - ----- Method: DependentsArray>>collect: (in category 'enumerating') ----- - collect: aBlock - "Refer to the comment in Collection|select:." - | basicSize newSelf size dep selection | - basicSize := self basicSize. - newSelf := self species new: basicSize. - size := 0. - 1 to: basicSize do: [:i | - (dep := self basicAt: i) notNil ifTrue: [newSelf basicAt: (size := size+1) put: (aBlock value: dep)]]. - selection := self species new: size. - selection basicReplaceFrom: 1 to: size with: newSelf startingAt: 1. - ^selection! Item was removed: - ----- Method: DependentsArray>>copyWith: (in category 'copying') ----- - copyWith: newElement - "Re-implemented to not copy any niled out dependents." - | copy i | - copy := self class new: self size + 1. - i := 0. - self do: [:item | copy basicAt: (i:=i+1) put: item]. - copy basicAt: (i:=i+1) put: newElement. - ^copy! Item was removed: - ----- Method: DependentsArray>>do: (in category 'enumerating') ----- - do: aBlock - "Evaluate a Block on non nil elements of the receiver" - | dep | - 1 to: self basicSize do:[:i| - (dep := self basicAt: i) ifNotNil:[aBlock value: dep]].! Item was removed: - ----- Method: DependentsArray>>first (in category 'accessing') ----- - first - self do: [:dep | ^dep]. - self error: 'this collection is empty'! Item was removed: - ----- Method: DependentsArray>>last (in category 'accessing') ----- - last - self reverseDo: [:dep | ^dep]. - self error: 'this collection is empty'! Item was removed: - ----- Method: DependentsArray>>reverseDo: (in category 'enumerating') ----- - reverseDo: aBlock - "Refer to the comment in Collection|do:." - | dep | - self basicSize to: 1 by: -1 do: [:i | - (dep := self basicAt: i) ifNotNil: [aBlock value: dep]]! Item was removed: - ----- Method: DependentsArray>>select: (in category 'enumerating') ----- - select: aBlock - "Refer to the comment in Collection|select:." - | basicSize newSelf size selection | - basicSize := self basicSize. - newSelf := self species new: basicSize. - size := 0. - 1 to: basicSize do: [ :i | - (self basicAt: i) ifNotNil: [ :dep | - (aBlock value: dep) ifTrue: [ - newSelf basicAt: (size := size+1) put: dep ] ] ]. - selection := self species new: size. - selection basicReplaceFrom: 1 to: size with: newSelf startingAt: 1. - ^selection! Item was removed: - ----- Method: DependentsArray>>size (in category 'accessing') ----- - size - "count each non nil elements in self. - Note: count: will use do: which will already have filtered out nil elements" - - ^self count: [:each | true]! Item was removed: - Warning subclass: #Deprecation - instanceVariableNames: '' - classVariableNames: 'ShowDeprecationWarnings' - poolDictionaries: '' - category: 'Kernel-Exceptions'! - - !Deprecation commentStamp: 'dew 5/21/2003 17:46' prior: 0! - This Warning is signalled by methods which are deprecated. - - The use of Object>>#deprecatedExplanation: aString and Object>>#deprecated: aBlock explanation: aString is recommended. - - Idiom: Imagine I want to deprecate the message #foo. - - foo - ^ 'foo' - - I can replace it with: - - foo - self deprecatedExplanation: 'The method #foo was not good. Use Bar>>newFoo instead.' - ^ 'foo' - - Or, for certain cases such as when #foo implements a primitive, #foo can be renamed to #fooDeprecated. - - fooDeprecated - ^ <primitive> - - foo - ^ self deprecated: [self fooDeprecated] explanation: 'The method #foo was not good. Use Bar>>newFoo instead.' - ! Item was removed: - ----- Method: Deprecation class>>showDeprecationWarnings (in category 'preferences') ----- - showDeprecationWarnings - <preference: 'Show deprecation warnings' category: 'debug' description: 'Warn the user when a deprecated method is used.' type: #Boolean> - ^ ShowDeprecationWarnings ifNil: [false]! Item was removed: - ----- Method: Deprecation class>>showDeprecationWarnings: (in category 'preferences') ----- - showDeprecationWarnings: aBoolean - ShowDeprecationWarnings := aBoolean.! Item was removed: - ----- Method: Deprecation class>>signalForContext:message:explanation: (in category 'instance creation') ----- - signalForContext: context message: messageString explanation: explanationString - - | message | - message := context method reference, ' has been deprecated', messageString, '.'. - explanationString ifNotEmpty: [message := message, ' ', explanationString]. - self signal: message.! Item was removed: - ----- Method: Deprecation class>>suppressed (in category 'accessing') ----- - suppressed - - ^ self showDeprecationWarnings not! Item was removed: - ----- Method: Deprecation class>>suppressed: (in category 'accessing') ----- - suppressed: aBoolean - - self showDeprecationWarnings: aBoolean not. - super suppressed: aBoolean.! Item was removed: - ArithmeticError subclass: #DomainError - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Kernel-Numbers-Exceptions'! - - !DomainError commentStamp: 'nice 4/20/2011 22:13' prior: 0! - A DomainError is an error occuring when a mathematical function is used outside its domain of validity.! Item was removed: - Error subclass: #DuplicateVariableError - instanceVariableNames: 'superclass variable' - classVariableNames: '' - poolDictionaries: '' - category: 'Kernel-Exceptions'! - - !DuplicateVariableError commentStamp: 'ar 2/13/2010 15:05' prior: 0! - DuplicateVariableError is signaled when a (class or instance) variable name is used in both super and subclass.! Item was removed: - ----- Method: DuplicateVariableError>>isResumable (in category 'testing') ----- - isResumable - ^true! Item was removed: - ----- Method: DuplicateVariableError>>superclass (in category 'accessing') ----- - superclass - "The superclass in which the variable is defined" - ^superclass! Item was removed: - ----- Method: DuplicateVariableError>>superclass: (in category 'accessing') ----- - superclass: aClass - "The superclass in which the variable is defined" - superclass := aClass! Item was removed: - ----- Method: DuplicateVariableError>>variable (in category 'accessing') ----- - variable - "Name of the duplicate variable" - ^variable! Item was removed: - ----- Method: DuplicateVariableError>>variable: (in category 'accessing') ----- - variable: aString - "Name of the duplicate variable" - variable := aString! Item was removed: - ProcessSpecificVariable subclass: #DynamicVariable - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Kernel-Processes-Variables'! - - !DynamicVariable commentStamp: 'mvl 3/13/2007 13:55' prior: 0! - My subclasses are dynamic variables: each subclass represents a variable - whose value persists inside the block passed to #value:during:. There is - no way to change the value inside such a block, but it is possible to - temporarirly rebind it in a nested manner.! Item was removed: - ----- Method: DynamicVariable class>>value:during: (in category 'accessing') ----- - value: anObject during: aBlock - - | p oldValue outerScopeWasDynamic | - p := Processor activeProcess. - outerScopeWasDynamic := true. - oldValue := p - environmentAt: self - ifAbsent: [outerScopeWasDynamic := false. nil]. - ^[ - p environmentAt: self put: anObject. - aBlock value ] - ensure: [ outerScopeWasDynamic - ifTrue: [p environmentAt: self put: oldValue] - ifFalse: [p environmentRemoveKey: self ifAbsent: []] ].! Item was removed: - Exception subclass: #Error - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Kernel-Exceptions-Kernel'! - - !Error commentStamp: 'ct 3/25/2022 21:09' prior: 0! - >From the ANSI standard: - This protocol describes the behavior of instances of class Error. These are used to represent error conditions that prevent the normal continuation of processing. Actual error exceptions used by an application may be subclasses of this class. - As Error is explicitly specified to be subclassable, conforming implementations must implement its behavior in a non-fragile manner.! Item was removed: - ----- Method: Error>>defaultAction (in category 'priv handling') ----- - defaultAction - "No one has handled this error, but now give them a chance to decide how to debug it. If none handle this either then open debugger (see UnhandedError-defaultAction)" - - UnhandledError signalForException: self! Item was removed: - ----- Method: Error>>isResumable (in category 'priv handling') ----- - isResumable - "Determine whether an exception is resumable." - - ^ false! Item was removed: - Object subclass: #EventSensor - instanceVariableNames: 'mouseButtons mousePosition mouseWheelDelta keyboardBuffer interruptKey interruptSemaphore eventQueue inputSemaphore lastEventPoll hasInputSemaphore lastEventTime' - classVariableNames: 'ButtonDecodeTable EventPollPeriod EventTicklerProcess InterruptWatcherProcess KeyDecodePreferences KeyDecodeTable VirtualKeyTable' - poolDictionaries: 'EventSensorConstants' - category: 'Kernel-Processes'! - - !EventSensor commentStamp: 'mt 12/13/2019 14:38' prior: 0! - An EventSensor is an interface to the user input devices. - There is at least one instance of EventSensor named Sensor in the system. - - EventSensor is a replacement for the earlier InputSensor implementation based on a set of (optional) event primitives. An EventSensor updates its state when events are received so that all state based users of Sensor (e.g., Sensor keyboard, Sensor leftShiftDown, Sensor mouseButtons) will work exactly as before, by moving the current VM mechanisms into EventSensor itself. An optional input semaphore is part of the new design. - - For platforms that support true asynchronous event notification, the semaphore will be signaled to indicate pending events. - On platforms that do not support asynchronous notifications about events, the UI will have to poll EventSensor periodically to read events from the VM. - - Instance variables: - mouseButtons <Integer> - mouse button state as replacement for primMouseButtons - mousePosition <Point> - mouse position as replacement for primMousePt - keyboardBuffer <SharedQueue> - keyboard input buffer - interruptKey <Integer> - currently defined interrupt key - interruptSemaphore <Semaphore> - the semaphore signaled when the interruptKey is detected - eventQueue <SharedQueue> - an optional event queue for event driven applications - inputSemaphore <Semaphore>- the semaphore signaled by the VM if asynchronous event notification is supported - lastEventPoll <Integer> - the last millisecondClockValue at which we called fetchMoreEvents - hasInputSemaphore <Boolean> - true if my inputSemaphore has actually been signaled at least once. - - Class variables: - ButtonDecodeTable <ByteArray> - maps mouse buttons as reported by the VM to ones reported in the events. - KeyDecodeTable <Dictionary<SmallInteger->SmallInteger>> - maps some keys and their modifiers to other keys (used for instance to map Ctrl-X to Alt-X) - InterruptSemaphore <Semaphore> - signalled by the the VM and/or the event loop upon receiving an interrupt keystroke. - InterruptWatcherProcess <Process> - waits on the InterruptSemaphore and then responds as appropriate. - EventPollPeriod <Integer> - the number of milliseconds to wait between polling for more events in the userInterruptHandler. - EventTicklerProcess <Process> - the process that makes sure that events are polled for often enough (at least every EventPollPeriod milliseconds). - - Event format: - The current event format is very simple. Each event is recorded into an 8 element array. All events must provide some SmallInteger ID (the first field in the event buffer) and a time stamp (the second field in the event buffer), so that the difference between the time stamp of an event and the current time can be reported. - - Currently, the following events are defined: - - Null event - ============= - The Null event is returned when the ST side asks for more events but no more events are available. - Structure: - [1] - event type 0 - [2-8] - unused - - Mouse event structure - ========================== - Mouse events are generated when mouse input is detected. - [1] - event type 1 - [2] - time stamp - [3] - mouse x position - [4] - mouse y position - [5] - button state; bitfield with the following entries: - 1 - 2r001 yellow (e.g., right) button - 2 - 2r010 blue (e.g., middle) button - 4 - 2r100 red (e.g., left) button - [all other bits are currently undefined] - [6] - modifier keys; bitfield with the following entries: - 1 - shift key - 2 - ctrl key - 4 - (Mac specific) option key - 8 - Cmd/Alt key - [all other bits are currently undefined] - [7] - reserved. - [8] - host window id. - - Keyboard events - ==================== - Keyboard events are generated when keyboard input is detected. - [1] - event type 2 - [2] - time stamp - [3] - character code (Ascii) - For now the character code is in Mac Roman encoding. See #macToSqueak. - For key press/release (see [4]), character codes are normalized. - [4] - press state; integer with the following meaning - 0 - character (aka. key stroke or key still pressed) - 1 - key press (aka. key down) - 2 - key release (aka. key up) - [5] - modifier keys (same as in mouse events) - For key press/release (see [4]), modifier keys are still accessible. - [6] - character code (Unicode UTF32) - Manual decoding via KeyboardInputInterpreter possible. - For key press/release (see [4]), character codes are normalized. - [7] - reserved. - [8] - host window id. - - Mouse-wheel event structure - ========================== - Mouse-wheel events are generated when mouse-wheel input is detected. - [1] - event type 7 - [2] - time stamp - [3] - horizontal scroll delta - [4] - vertical scroll delta - [5] - button state (same as in mouse events) - [6] - modifier keys (same as in mouse events) - [7] - reserved. - [8] - host window id. - ! Item was removed: - ----- Method: EventSensor class>>anyMouseButtonMask (in category 'constants') ----- - anyMouseButtonMask - - ^ 2r111! Item was removed: - ----- Method: EventSensor class>>default (in category 'public') ----- - default - "Answer the default system input sensor, Sensor." - - ^ Sensor! Item was removed: - ----- Method: EventSensor class>>duplicateControlAndAltKeys: (in category 'public') ----- - duplicateControlAndAltKeys: aBoolean - "EventSensor duplicateControlAndAltKeys: true" - - self flag: #deprecated. - self - mapControlKeysToCommandKeys: aBoolean; - mapAltKeysToOptionKeys: false.! Item was removed: - ----- Method: EventSensor class>>eventPollPeriod (in category 'class initialization') ----- - eventPollPeriod - ^EventPollPeriod ifNil: [ EventPollPeriod := 500 ].! Item was removed: - ----- Method: EventSensor class>>eventPollPeriod: (in category 'class initialization') ----- - eventPollPeriod: msec - "Set the number of milliseconds between checking for events to msec." - - EventPollPeriod := msec max: 10.! Item was removed: - ----- Method: EventSensor class>>fixControlCharacters (in category 'key decode table') ----- - fixControlCharacters - "Assure that all keyboard events that arrive with the CONTROL modifier actually have control characters set." - - 64 "$@" to: 95 "$_"do: [:upper | - KeyDecodeTable - at: { upper . 2 bitOr: 1 "ctrl+shift" } - put: { upper bitAnd: 16r9F . 2 bitOr: 1 "ctrl+shift" }]. - 96 "$`" to: 126 "$~" do: [:lower | "Ignore 127" - KeyDecodeTable - at: { lower . 2 "ctrl" } - put: { lower bitAnd: 16r9F . 2 "ctrl" }]. - - self flag: #linuxOnly. "mt: For Linux VMs as of version 201911282316, no control characters will be sent from the VM. Avoid check for #platformName because the extra mapping will not affect others anyway." - self flag: #windowsOnly. "mt: CTRL+m would not arrive as CTRL+CR, which is rather inconsistent."! Item was removed: - ----- Method: EventSensor class>>initialize (in category 'class initialization') ----- - initialize - - Smalltalk addToStartUpList: self before: ProcessorScheduler. - Smalltalk addToShutDownList: self. - - KeyDecodePreferences := Dictionary new. - - self installKeyDecodeTable. - self installMouseDecodeTable. - self installVirtualKeyTable.! Item was removed: - ----- Method: EventSensor class>>install (in category 'class initialization') ----- - install "EventSensor install" - "Install an EventSensor in place of the current Sensor." - | newSensor | - Sensor shutDown. - newSensor := self new. - newSensor startUp. - "Note: We must use #become: here to replace all references to the old sensor with the new one, since Sensor is referenced from all the existing controllers." - Sensor becomeForward: newSensor. "done"! Item was removed: - ----- Method: EventSensor class>>installKeyDecodeTable (in category 'class initialization') ----- - installKeyDecodeTable - "Create a decode table that swaps or duplicates some keys if the respective preference is set." - - KeyDecodeTable := Dictionary new. - - self mapControlKeysToCommandKeys - ifTrue: [self installMappingToCommandKeys] - ifFalse: [self mapControlCharactersToPrintableCharacters - ifTrue: [self installMappingToPrintableCharacters] - ifFalse: [self fixControlCharacters "mt: Due to platform-specific VM behavior."]]. - - self mapAltKeysToOptionKeys - ifTrue: [self installMappingToOptionKeys].! Item was removed: - ----- Method: EventSensor class>>installMappingToCommandKeys (in category 'key decode table') ----- - installMappingToCommandKeys - "Maps all keyboard events that arrive with the CONTROL modifier to also have the COMMAND modifier set. This mapping also considers the preference #mapControlCharactersToPrintableCharacters." - - | controlMask | - 0 "NUL" to: 27 "ESC" do: [:control | - controlMask := self mapControlCharactersToPrintableCharacters - ifTrue: [16r60] ifFalse: [0]. - KeyDecodeTable - at: { control . 2r0010 "ctrl" } - put: { control bitOr: controlMask . 2r1010 "cmd+ctrl" }. - controlMask := self mapControlCharactersToPrintableCharacters - ifTrue: [16r40] ifFalse: [0]. - KeyDecodeTable - at: { control . 2r0011 "ctrl+shift" } - put: { control bitOr: controlMask . 2r1011 "cmd+ctrl+shift" }]. - - 28 "arrow keys" to: 126 "$~" do: [:arrowAndPrintable | - KeyDecodeTable - at: { arrowAndPrintable . 2r0010 "ctrl" } - put: { arrowAndPrintable . 2r1010 "cmd+ctrl" }. - KeyDecodeTable - at: { arrowAndPrintable . 2r0011 "ctrl+shift" } - put: { arrowAndPrintable . 2r1011 "cmd+ctrl+shift" }]. - - self mapControlCharactersToPrintableCharacters ifFalse: [ - "See #fixControlCharacters. #linuxOnly" - 64 "$@" to: 95 "$_"do: [:upper | - KeyDecodeTable - at: { upper . 2r0011 "ctrl+shift" } - put: { upper bitAnd: 16r9F . 2r1011 "cmd+ctrl+shift" }]. - 96 "$`" to: 126 "$~" do: [:lower | "Ignore 127" - KeyDecodeTable - at: { lower . 2r0010 "ctrl" } - put: { lower bitAnd: 16r9F . 2r1010 "cmd+ctrl" }]].! Item was removed: - ----- Method: EventSensor class>>installMappingToOptionKeys (in category 'key decode table') ----- - installMappingToOptionKeys - "Maps all keyboard events that arrive with the COMMAND modifier to also have the OPTION modifier set. See preference #mapAltKeysToOptionKeys." - - self flag: #windowsOnly. "mt: In Windows VMs version 202104182333, pressing the (physical) ALT key arrives as CMD modifier in the image. Should this ever change, this mapping MUST be adapted, too." - self flag: #linuxOnly. "mt: See #windowsOnly." - self flag: #macOSOnly. "mt: This mapping should be ignored to not overshadow events that have the actual OPTION modifier set." - - CharacterSet ascii do: [:character | - KeyDecodeTable - at: { character asInteger . 2r1000 "cmd" } - put: { character asInteger . 2r1100 "cmd+opt" }. - KeyDecodeTable - at: { character asInteger . 2r1001 "cmd + shift" } - put: { character asInteger . 2r1101 "cmd + opt + shift" }].! Item was removed: - ----- Method: EventSensor class>>installMappingToPrintableCharacters (in category 'key decode table') ----- - installMappingToPrintableCharacters - "Only applies when the CONTROL modifier is present!! Control characters that can directly be triggered -- such as CR, ENTER, BS, DEL, POS1, END -- will not be mapped." - - self flag: #windowsOnly. "mt: The CONTROL modifier might directly change the control character. Examples: CTRL+CR(13) arrives as CTRL+LF(10), CTRL+BS(8) arrives as CTRL+DEL(127). If you have no other means to input LF(10) or DEL(127), you might have to disable this mapping to printable characters." - - 1 "SOH" to: 27 "ESC" do: [:control | - #(2r0010 "ctrl" 2r0110 "ctrl+opt" 2r1010 "ctrl+cmd" 2r1110 "ctrl+opt+cmd") - do: [:modifiers | "Note that only macOS needs those other combinations." - KeyDecodeTable - at: { control . modifiers } - put: { control bitOr: 16r60 "+96" . modifiers }]. - #(2r0011 "shift+ctrl" 2r0111 "shift+ctrl+opt" 2r1011 "shift+ctrl+cmd" 2r1111 "shift+ctrl+opt+cmd") - do: [:modifiers | "Note that only macOS needs those other combinations." - KeyDecodeTable - at: { control . modifiers } - put: { control bitOr: 16r40 "+64" . modifiers }]]. - - self flag: #macOSOnly. "mt: Ctrl+Space arrives as NUL character, which would be mapped to $@ with the above rules. So, ensure that Ctrl+Space works across platforms." - KeyDecodeTable - at: { 0 "NUL" . 2r0010 "ctrl" } - put: { 32 "SPACE". 2 "ctrl" }. - KeyDecodeTable - at: { 0 "NUL" . 2r0011 "ctrl+shift" } - put: { 32 "SPACE". 2r0011 "ctrl+shift" }.! Item was removed: - ----- Method: EventSensor class>>installMouseDecodeTable (in category 'class initialization') ----- - installMouseDecodeTable - "Create a decode table that swaps the lowest-order 2 bits if - Preferences swapMouseButtons is set" - ButtonDecodeTable := Preferences swapMouseButtons - ifTrue: [ByteArray withAll: - ((0 to: 255) collect: [:ea | - ((ea bitAnd: 1) << 1 - bitOr: (ea bitAnd: 2) >> 1) - bitOr: (ea bitAnd: 16rFC) ])] - ifFalse: [ByteArray - withAll: (0 to: 255)]! Item was removed: - ----- Method: EventSensor class>>installVirtualKeyTable (in category 'class initialization') ----- - installVirtualKeyTable - - VirtualKeyTable := Smalltalk windowSystemName - caseOf: { - ['Windows'] -> [self virtualKeysOnWindows]. - ['Win32' "older VMs"] -> [self virtualKeysOnWindows]. - ['Aqua'] -> [self virtualKeysOnMacOS]. - ['X11'] -> [self virtualKeysOnX11]. - } otherwise: [Dictionary new]. - - "Shift 8 bits to not overwrite virtual-key mappings from above." - self mapControlKeysToCommandKeys ifTrue: [ - VirtualKeyTable - at: (2r0010 "ctrl" bitShift: 8) - put: (2r1010 "cmd+ctrl"). - VirtualKeyTable - at: (2r0011 "ctrl+shift" bitShift: 8) - put: (2r1011 "cmd+ctrl+shift")]. - - self mapAltKeysToOptionKeys ifTrue: [ - VirtualKeyTable - at: (2r1000 "cmd/alt" bitShift: 8) - put: (2r1100 "cmd/alt+opt"). - VirtualKeyTable - at: (2r1001 "cmd/alt+shift" bitShift: 8) - put: (2r1101 "cmd/alt+opt+shift")].! Item was removed: - ----- Method: EventSensor class>>keyDecodeTable (in category 'key decode table') ----- - keyDecodeTable - ^KeyDecodeTable ifNil: [ self installKeyDecodeTable ]! Item was removed: - ----- Method: EventSensor class>>mapAltKeysToOptionKeys (in category 'preferences') ----- - mapAltKeysToOptionKeys - <preference: 'Map ALT keys to OPTION keys' - categoryList: #(keyboard events input) - description: 'On platforms other than macOS, keystrokes involving the (physical) ALT modifier typically arrive as COMMAND modifier. If you now also map CONTROL keys to COMMAND keys, you disable potential input. If you enable this preference, you preserve the possibility of reacting to two different modifiers -- CMD and OPT -- in your code, on all platforms. (This preference replaces older duplicate/swap preferences.)' - type: #Boolean> - - ^ KeyDecodePreferences - at: #mapAltKeysToOptionKeys - ifAbsent: [false]! Item was removed: - ----- Method: EventSensor class>>mapAltKeysToOptionKeys: (in category 'preferences') ----- - mapAltKeysToOptionKeys: aBooleanOrNil - - aBooleanOrNil = self mapAltKeysToOptionKeys - ifTrue: [^ self]. - - aBooleanOrNil - ifNil: [ - KeyDecodePreferences - removeKey: #mapAltKeysToOptionKeys - ifAbsent: []] - ifNotNil: [ - KeyDecodePreferences - at: #mapAltKeysToOptionKeys - put: aBooleanOrNil]. - - self installKeyDecodeTable. - self installVirtualKeyTable.! Item was removed: - ----- Method: EventSensor class>>mapControlCharactersToPrintableCharacters (in category 'preferences') ----- - mapControlCharactersToPrintableCharacters - <preference: 'Map ASCII control characters to printable characters' - categoryList: #(keyboard events input) - description: 'Keystrokes involving the (physical) CONTROL modifier typically have characters codes from 00 to 31 when pressing the physical keys labeled A to Z (or actually ASCII 64 to 95). This means that, for example in CTRL+C, client code cannot check for "anEvent controlKeyPressed and: [anEvent keyCharacter = $C]" but has to resort to "anEvent controlKeyPressed and: [keyCharacter = 3]." If you enable this preference all control characters will be mapped to printable characters.' - type: #Boolean> - - ^ KeyDecodePreferences - at: #mapControlCharactersToPrintableCharacters - ifAbsent: [true]! Item was removed: - ----- Method: EventSensor class>>mapControlCharactersToPrintableCharacters: (in category 'preferences') ----- - mapControlCharactersToPrintableCharacters: aBooleanOrNil - - aBooleanOrNil - ifNil: [ - KeyDecodePreferences - removeKey: #mapControlCharactersToPrintableCharacters - ifAbsent: []] - ifNotNil: [ - KeyDecodePreferences - at: #mapControlCharactersToPrintableCharacters - put: aBooleanOrNil]. - - self installKeyDecodeTable.! Item was removed: - ----- Method: EventSensor class>>mapControlKeysToCommandKeys (in category 'preferences') ----- - mapControlKeysToCommandKeys - <preference: 'Map CONTROL keys to COMMAND keys' - categoryList: #(keyboard events input) - description: 'On platforms other than macOS, users use the CONTROL modifier for many common shortcuts around text editing such as CTRL+C and CTRL+V for copy and paste. For the sake of cross-platform compatibility, however, many tools in this system will check for CMD+C and CMD+V instead. Note that on Linux and Windows platforms, keystrokes involving the (physical) ALT modifier typically arrive as COMMAND modifier. Thus, enable this preference if you still want to use CONTROL key instead of the ALT key for such shortcuts. (This preference replaces older duplicate/swap preferences.)' - type: #Boolean> - - ^ KeyDecodePreferences - at: #mapControlKeysToCommandKeys - ifAbsent: [true]! Item was removed: - ----- Method: EventSensor class>>mapControlKeysToCommandKeys: (in category 'preferences') ----- - mapControlKeysToCommandKeys: aBooleanOrNil - - aBooleanOrNil - ifNil: [ - KeyDecodePreferences - removeKey: #mapControlKeysToCommandKeys - ifAbsent: []] - ifNotNil: [ - KeyDecodePreferences - at: #mapControlKeysToCommandKeys - put: aBooleanOrNil]. - - self installKeyDecodeTable. - self installVirtualKeyTable.! Item was removed: - ----- Method: EventSensor class>>numMouseButtons (in category 'constants') ----- - numMouseButtons - "We support three button mice." - - ^ 3! Item was removed: - ----- Method: EventSensor class>>shutDown (in category 'system startup') ----- - shutDown - self default shutDown.! Item was removed: - ----- Method: EventSensor class>>simplifyVirtualKeyCodes (in category 'preferences') ----- - simplifyVirtualKeyCodes - <preference: 'Simplify virtual-key codes' - categoryList: #(keyboard events input) - description: 'On some platforms, virtual-key codes (aka. scan codes) depend on the language setting (e.g. US, UK, DE), which is unkown to Squeak. Enable this preference to simplify overlapping codes to common symbols #squeak1, #squeak2, etc., which improves cross-platform compatibility but reduces the number of keys available for different handlers.' - type: #Boolean> - - ^ KeyDecodePreferences - at: #simplifyVirtualKeyCodes - ifAbsent: [true]! Item was removed: - ----- Method: EventSensor class>>simplifyVirtualKeyCodes: (in category 'preferences') ----- - simplifyVirtualKeyCodes: aBooleanOrNil - - aBooleanOrNil = self simplifyVirtualKeyCodes - ifTrue: [^ self]. - - aBooleanOrNil - ifNil: [ - KeyDecodePreferences - removeKey: #simplifyVirtualKeyCodes - ifAbsent: []] - ifNotNil: [ - KeyDecodePreferences - at: #simplifyVirtualKeyCodes - put: aBooleanOrNil]. - - self installVirtualKeyTable.! Item was removed: - ----- Method: EventSensor class>>startUp: (in category 'system startup') ----- - startUp: resuming - - resuming ifTrue: [ - Smalltalk platformName = 'Mac OS' - ifTrue: [ - self mapAltKeysToOptionKeys: false. - self mapControlKeysToCommandKeys: false] - ifFalse: [ - self mapAltKeysToOptionKeys: true. - self mapControlKeysToCommandKeys: true]. - self installVirtualKeyTable ]. - - self default startUp.! Item was removed: - ----- Method: EventSensor class>>swapControlAndAltKeys: (in category 'public') ----- - swapControlAndAltKeys: aBoolean - - self deprecated: 'You cannnot swap CONTROL and ALT modifiers anymore. Please use other key-mapping preferences to fit your needs.'.! Item was removed: - ----- Method: EventSensor class>>swapMouseButtons: (in category 'public') ----- - swapMouseButtons: aBoolean - "EventSensor swapMouseButtons: true" - - Preferences setPreference: #swapMouseButtons toValue: aBoolean. - self installMouseDecodeTable.! Item was removed: - ----- Method: EventSensor class>>swapMouseButtonsChanged (in category 'preference change notification') ----- - swapMouseButtonsChanged - - self installMouseDecodeTable.! Item was removed: - ----- Method: EventSensor class>>virtualKeyAt: (in category 'virtual keys') ----- - virtualKeyAt: keyCode - "Answers a representation for the (non-modifier) key, which should be consistent across platforms considering its cause." - - ^ self virtualKeyTable at: keyCode! Item was removed: - ----- Method: EventSensor class>>virtualKeyTable (in category 'virtual keys') ----- - virtualKeyTable - - ^ VirtualKeyTable ifNil: [self installVirtualKeyTable]! Item was removed: - ----- Method: EventSensor class>>virtualKeysOnMacOS (in category 'virtual keys') ----- - virtualKeysOnMacOS - "Based on Carbon's Events.h -- https://snipplr.com/view/42797" - - ^ Dictionary newFromPairs: { - 16r00 . $A. "#'kVK_ANSI_A'" - 16r01 . $S. "#'kVK_ANSI_S'" - 16r02 . $D. "#'kVK_ANSI_D'" - 16r03 . $F. "#'kVK_ANSI_F'" - 16r04 . $H. "#'kVK_ANSI_H'" - 16r05 . $G. "#'kVK_ANSI_G'" - 16r06 . $Z. "#'kVK_ANSI_Z'" - 16r07 . $X. "#'kVK_ANSI_X'" - 16r08 . $C. "#'kVK_ANSI_C'" - 16r09 . $V. "#'kVK_ANSI_V'" - 16r0B . $B. "#'kVK_ANSI_B'" - 16r0C . $Q. "#'kVK_ANSI_Q'" - 16r0D . $W. "#'kVK_ANSI_W'" - 16r0E . $E. "#'kVK_ANSI_E'" - 16r0F . $R. "#'kVK_ANSI_R'" - 16r10 . $Y. "#'kVK_ANSI_Y'" - 16r11 . $T. "#'kVK_ANSI_T'" - 16r12 . $1. "#'kVK_ANSI_1'" - 16r13 . $2. "#'kVK_ANSI_2'" - 16r14 . $3. "#'kVK_ANSI_3'" - 16r15 . $4. "#'kVK_ANSI_4'" - 16r16 . $6. "#'kVK_ANSI_6'" - 16r17 . $5. "#'kVK_ANSI_5'" - 16r18 . (self simplifyVirtualKeyCodes ifTrue: [#squeak2] ifFalse: [#'kVK_ANSI_Equal']). - 16r19 . $9. "#'kVK_ANSI_9'" - 16r1A . $7. "#'kVK_ANSI_7'" - 16r1B . (self simplifyVirtualKeyCodes ifTrue: [#squeak1] ifFalse: [#'kVK_ANSI_Minus']). - 16r1C . $8. "#'kVK_ANSI_8'" - 16r1D . $0. "#'kVK_ANSI_0'" - 16r1E . (self simplifyVirtualKeyCodes ifTrue: [#squeak2] ifFalse: [#'kVK_ANSI_RightBracket']). - 16r1F . $O. "#'kVK_ANSI_O'" - 16r20 . $U. "#'kVK_ANSI_U'" - 16r21 . (self simplifyVirtualKeyCodes ifTrue: [#squeak1] ifFalse: [#'kVK_ANSI_LeftBracket']). - 16r22 . $I. "#'kVK_ANSI_I'" - 16r23 . $P. "#'kVK_ANSI_P'" - 16r25 . $L. "#'kVK_ANSI_L'" - 16r26 . $J. "#'kVK_ANSI_J'" - 16r27 . (self simplifyVirtualKeyCodes ifTrue: [#squeak3] ifFalse: [#'kVK_ANSI_Quote']). - 16r28 . $K. "#'kVK_ANSI_K'" - 16r29 . (self simplifyVirtualKeyCodes ifTrue: [#squeak1] ifFalse: [#'kVK_ANSI_Semicolon']). - 16r2A . (self simplifyVirtualKeyCodes ifTrue: [#squeak1] ifFalse: [#'kVK_ANSI_Backslash']). - 16r2B . #squeakComma. "#'kVK_ANSI_Comma'" - 16r2C . (self simplifyVirtualKeyCodes ifTrue: [#squeak1] ifFalse: [#'kVK_ANSI_Slash']). - 16r2D . $N. "#'kVK_ANSI_N'" - 16r2E . $M. "#'kVK_ANSI_M'" - 16r2F . #squeakPeriod. "#'kVK_ANSI_Period'" - 16r32 . (self simplifyVirtualKeyCodes ifTrue: [#squeak4] ifFalse: [#'kVK_ANSI_Grave']). - 16r41 . #numDec. "#'kVK_ANSI_KeypadDecimal'" - 16r43 . #numMul. "#'kVK_ANSI_KeypadMultiply'" - 16r45 . #numAdd. "#'kVK_ANSI_KeypadPlus'" - 16r47 . #numClr. "#'kVK_ANSI_KeypadClear'" - 16r4B . #numDiv. "#'kVK_ANSI_KeypadDivide'" - 16r4C . (self simplifyVirtualKeyCodes ifTrue: [Character return] ifFalse: [Character enter]). "#'kVK_ANSI_KeypadEnter'" - 16r4E . #numSub. "#'kVK_ANSI_KeypadMinus'" - 16r51 . #numEqu. "#'kVK_ANSI_KeypadEquals'" - 16r52 . #num0. "#'kVK_ANSI_Keypad0'" - 16r53 . #num1. "#'kVK_ANSI_Keypad1'" - 16r54 . #num2. "#'kVK_ANSI_Keypad2'" - 16r55 . #num3. "#'kVK_ANSI_Keypad3'" - 16r56 . #num4. "#'kVK_ANSI_Keypad4'" - 16r57 . #num5. "#'kVK_ANSI_Keypad5'" - 16r58 . #num6. "#'kVK_ANSI_Keypad6'" - 16r59 . #num7. "#'kVK_ANSI_Keypad7'" - 16r5B . #num8. "#'kVK_ANSI_Keypad8'" - 16r5C . #num9. "#'kVK_ANSI_Keypad9'" - 16r24 . Character return. "#'kVK_Return'" - 16r30 . Character tab. "#'kVK_Tab'" - 16r31 . Character space. "#'kVK_Space'" - 16r33 . Character backspace. "#'kVK_Delete'" - 16r35 . Character escape. "#'kVK_Escape'" - 16r36 . #command. "#'kVK_RightCommand'" - 16r37 . #command. "#'kVK_Command'" - 16r38 . #shift. "#'kVK_Shift'" - 16r39 . #capsLock. "#'kVK_CapsLock'" - 16r3A . #option. "#'kVK_Option'" - 16r3B . #control. "#'kVK_Control'" - 16r3C . #shift. "#'kVK_RightShift'" - 16r3D . #option. "#'kVK_RightOption'" - 16r3E . #control. "#'kVK_RightControl'" - 16r3F . #'kVK_Function'. - 16r40 . #F17. "#'kVK_F17'" - 16r48 . #'kVK_VolumeUp'. - 16r49 . #'kVK_VolumeDown'. - 16r4A . #'kVK_Mute'. - 16r4F . #F18. "#'kVK_F18'" - 16r50 . #F19. "#'kVK_F19'" - 16r5A . #F20. "#'kVK_F20'" - 16r60 . #F5. "#'kVK_F5'" - 16r61 . #F6. "#'kVK_F6'" - 16r62 . #F7. "#'kVK_F7'" - 16r63 . #F3. "#'kVK_F3'" - 16r64 . #F8. "#'kVK_F8'" - 16r65 . #F9. "#'kVK_F9'" - 16r67 . #F11. "#'kVK_F11'" - 16r69 . #F13. "#'kVK_F13'" - 16r6A . #F16. "#'kVK_F16'" - 16r6B . #F14. "#'kVK_F14'" - 16r6D . #F10. "#'kVK_F10'" - 16r6F . #F12. "#'kVK_F12'" - 16r71 . #F15. "#'kVK_F15'" - 16r72 . #help. "#'kVK_Help'" - 16r73 . Character home. "#'kVK_Home'" - 16r74 . Character pageUp. "#'kVK_PageUp'" - 16r75 . Character delete. "#'kVK_ForwardDelete'" - 16r76 . #F4. "#'kVK_F4'" - 16r77 . Character end. "#'kVK_End'" - 16r78 . #F2. "#'kVK_F2'" - 16r79 . Character pageDown. "#'kVK_PageDown'" - 16r7A . #F1. "#'kVK_F1'" - 16r7B . Character arrowLeft. "#'kVK_LeftArrow'" - 16r7C . Character arrowRight. "#'kVK_RightArrow'" - 16r7D . Character arrowDown. "#'kVK_DownArrow'" - 16r7E . Character arrowUp. "#'kVK_UpArrow'" - 16r0A . (self simplifyVirtualKeyCodes ifTrue: [#squeak1] ifFalse: [#'kVK_ISO_Section']). - 16r5D . #'kVK_JIS_Yen'. - 16r5E . #'kVK_JIS_Underscore'. - 16r5F . #'kVK_JIS_KeypadComma'. - 16r66 . #'kVK_JIS_Eisu'. - 16r68 . #'kVK_JIS_Kana'. - } - - ! Item was removed: - ----- Method: EventSensor class>>virtualKeysOnWindows (in category 'virtual keys') ----- - virtualKeysOnWindows - "https://docs.microsoft.com/en-us/windows/win32/inputdev/virtual-key-codes - - Tweaked to Windows 10 Version 20H2 (Build 19042.928) - Microsoft Surface Pro 6 (GERMAN)" - - | table | - table := Dictionary new. - { - "16r01" Character home. "#'VK_HOME'" "Overshadows #'VK_LBUTTON' --- Left mouse button" - "16r02" #'VK_RBUTTON'. "Right mouse button" - "16r03" #'VK_CANCEL'. "Control-break processing" - "16r04" Character end. "#'VK_END'" "Overshadows #'VK_MBUTTON' --- Middle mouse button" - "16r05" Character insert. "#'VK_INSERT'" "Overshadows #'VK_XBUTTON1' --- X1 mouse button" - "16r06" #'VK_XBUTTON2'. "X2 mouse button" - "16r07" nil. - "16r08" Character backspace. "#'VK_BACK'" - "16r09" Character tab. "#'VK_TAB'" - "16r0A" nil. - "16r0B" Character pageUp. "#'VK_PRIOR'" "PAGE UP key" - "16r0C" Character pageDown. "#'VK_NEXT'" "PAGE DOWN key --- overshadows #'VK_CLEAR'" - "16r0D" Character return. "#'VK_RETURN'" "ENTER key" - "16r0E" nil. - "16r0F" nil. - "16r10" #shift. "#'VK_SHIFT'" - "16r11" (self mapControlKeysToCommandKeys ifTrue: [#command] ifFalse: [#control]). "#'VK_CONTROL'" - "16r12" (self mapAltKeysToOptionKeys ifTrue: [#option] ifFalse: [#command "aka. #alt"]). "#'VK_MENU'" - "16r13" #'VK_PAUSE'. - "16r14" #capsLock. "#'VK_CAPITAL'" - "16r15" #'VK_KANA'. "IME Kana/Hangul mode" - "16r16" #'VK_IME_ON'. "IME on" - "16r17" #'VK_JUNJA'. "IMA Junja mode" - "16r18" #'VK_FINAL'. "IME final mode" - "16r19" #'VK_KANJI'. "IME Kanji/Hanja mode" - "16r1A" #'VK_IME_OFF'. "IME off" - "16r1B" Character escape. "#'VK_ESCAPE'" - "16r1C" Character arrowLeft. "#'VK_LEFT'" "LEFT ARROW. Overshadows #'VK_CONVERT' --- IME convert" - "16r1D" Character arrowRight. "#'VK_RIGHT'" "RIGHT ARROW. Overshadows 'VK_NONCONVERT' --- IME nonconvert" - "16r1E" Character arrowUp. "#'VK_UP'" "UP ARROW. Overshadows #'VK_ACCEPT' --- IME accept" - "16r1F" Character arrowDown. "#'VK_DOWN'" "DOWN ARROW. Overshadows #'VK_MODECHANGE' --- IME mode change request" - "16r20" Character space. "#'VK_SPACE'" "SPACEBAR" - "16r21" #'VK_PRIOR'. "PAGE UP key. Not needed. See 16r0B" - "16r22" #'VK_NEXT'. "PAGE DOWN key. Not needed. See 16r0C" - "16r23" #'VK_END'. "Not needed. See 16r04" - "16r24" #'VK_HOME'. "Not needed. See 16r01" - "16r25" #'VK_LEFT'. "LEFT ARROW. Not needed. See 16r1C" - "16r26" #'VK_UP'. "UP ARROW. Not needed. See 16r1E" - "16r27" #'VK_RIGHT'. "RIGHT ARROW. Not needed. See 16r1D" - "16r28" #'VK_DOWN'. "DOWN ARROW. Not needed. See 16r1F" - "16r29" #'VK_SELECT'. - "16r2A" #'VK_PRINT'. - "16r2B" #'VK_EXECUTE'. - "16r2C" #'VK_SNAPSHOT'. "PRINT SCREEN key" - "16r2D" #'VK_INSERT'. "Not needed. See 16r05" - "16r2E" #F16. "#'VK_F16' swapped with #'VK_DELETE'. See 16r7F" - "16r2F" #help. "#'VK_HELP'" - "16r30" $0. - "16r31" $1. - "16r32" $2. - "16r33" $3. - "16r34" $4. - "16r35" $5. - "16r36" $6. - "16r37" $7. - "16r38" $8. - "16r39" $9. - "16r3A" nil. - "16r3B" nil. - "16r3C" nil. - "16r3D" nil. - "16r3E" nil. - "16r3F" nil. - "16r40" nil. - "16r41" $A. - "16r42" $B. - "16r43" $C. - "16r44" $D. - "16r45" $E. - "16r46" $F. - "16r47" $G. - "16r48" $H. - "16r49" $I. - "16r4A" $J. - "16r4B" $K. - "16r4C" $L. - "16r4D" $M. - "16r4E" $N. - "16r4F" $O. - "16r50" $P. - "16r51" $Q. - "16r52" $R. - "16r53" $S. - "16r54" $T. - "16r55" $U. - "16r56" $V. - "16r57" $W. - "16r58" $X. - "16r59" $Y. - "16r5A" $Z. - "16r5B" #'VK_LWIN'. "Left Windows key" - "16r5C" #'VK_RWIN'. "Right windows key" - "16r5D" #'VK_APPS'. "Applications key" - "16r5E" nil. - "16r5F" #'VK_SLEEP'. "Computer Sleep Key" - "16r60" #num0. "#'VK_NUMPAD0'" - "16r61" #num1. "#'VK_NUMPAD1'" - "16r62" #num2. "#'VK_NUMPAD2'" - "16r63" #num3. "#'VK_NUMPAD3'" - "16r64" #num4. "#'VK_NUMPAD4'" - "16r65" #num5. "#'VK_NUMPAD5'" - "16r66" #num6. "#'VK_NUMPAD6'" - "16r67" #num7. "#'VK_NUMPAD7'" - "16r68" #num8. "#'VK_NUMPAD8'" - "16r69" #num9. "#'VK_NUMPAD9'" - "16r6A" #numMul. "#'VK_MULTIPLY'" - "16r6B" #numAdd. "#'VK_ADD'" - "16r6C" #'VK_SEPARATOR'. - "16r6D" #numSub. "#'VK_SUBTRACT'" - "16r6E" #numDec. "#'VK_DECIMAL'" - "16r6F" #numDiv. "#'VK_DIVIDE'" - "16r70" #F1. "#'VK_F1'" - "16r71" #F2. "#'VK_F2'" - "16r72" #F3. "#'VK_F3'" - "16r73" #F4. "#'VK_F4'" - "16r74" #F5. "#'VK_F5'" - "16r75" #F6. "#'VK_F6'" - "16r76" #F7. "#'VK_F7'" - "16r77" #F8. "#'VK_F8'" - "16r78" #F9. "#'VK_F9'" - "16r79" #F10. "#'VK_F10'" - "16r7A" #F11. "#'VK_F11'" - "16r7B" #F12. "#'VK_F12'" - "16r7C" #F13. "#'VK_F13'" - "16r7D" #F14. "#'VK_F14'" - "16r7E" #F15. "#'VK_F15'" - "16r7F" Character delete. "#'VK_DELETE' swapped with #'VK_F16'. See 16r2E" - "16r80" #F17. "#'VK_F17'" - "16r81" #F18. "#'VK_F18'" - "16r82" #F19. "#'VK_F19'" - "16r83" #F20. "#'VK_F20'" - "16r84" #F21. "#'VK_F21'" - "16r85" #F22. "#'VK_F22'" - "16r86" #F23. "#'VK_F23'" - "16r87" #F24. "#'VK_F24'" - "16r88" nil. - "16r89" nil. - "16r8A" nil. - "16r8B" nil. - "16r8C" nil. - "16r8D" nil. - "16r8E" nil. - "16r8F" nil. - "16r90" #'VK_NUMLOCK'. - "16r91" #'VK_SCROLL'. - "16r92" nil. - "16r93" nil. - "16r94" nil. - "16r95" nil. - "16r96" nil. - "16r97" nil. - "16r98" nil. - "16r99" nil. - "16r9A" nil. - "16r9B" nil. - "16r9C" nil. - "16r9D" nil. - "16r9E" nil. - "16r9F" nil. - "16rA0" #'VK_LSHIFT'. - "16rA1" #'VK_RSHIFT'. - "16rA2" #'VK_LCONTROL'. - "16rA3" #'VK_RCONTROL'. - "16rA4" #'VK_LMENU'. - "16rA5" #'VK_RMENU'. - "16rA6" #'VK_BROWSER_BACK'. - "16rA7" #'VK_BROWSER_FORWARD'. - "16rA8" #'VK_BROWSER_REFRESH'. - "16rA9" #'VK_BROWSER_STOP'. - "16rAA" #'VK_BROWSER_SEARCH'. - "16rAB" #'VK_BROWSER_FAVORITES'. - "16rAC" #'VK_BROWSER_HOME'. - "16rAD" #'VK_VOLUME_MUTE'. - "16rAE" #'VK_VOLUME_DOWN'. - "16rAF" #'VK_VOLUME_UP'. - "16rB0" #'VK_MEDIA_NEXT_TRACK'. - "16rB1" #'VK_MEDIA_PREV_TRACK'. - "16rB2" #'VK_MEDIA_STOP'. - "16rB3" #'VK_MEDIA_PLAY_PAUSE'. - "16rB4" #'VK_LAUNCH_MAIL'. - "16rB5" #'VK_LAUNCH_MEDIA_SELECT'. - "16rB6" #'VK_LAUNCH_APP1'. - "16rB7" #'VK_LAUNCH_APP2'. - "16rB8" nil. - "16rB9" nil - } withIndexDo: [ :val :i | table at: i put: val] . - - { - 16rBA . (self simplifyVirtualKeyCodes ifTrue: [#squeak1] ifFalse: [#'VK_OEM_1']). - "Used for miscellaneous characters; it can vary by keyboard. For the US standard keyboard, the ;: key" - - 16rBB . (self simplifyVirtualKeyCodes ifTrue: [#squeak2] ifFalse: [#'VK_OEM_PLUS']). - "For any country/region, the + key -- mt. Haha. You wish." - - 16rBC . #squeakComma. "#'VK_OEM_COMMA'" "For any country/region, the , key" - - 16rBD . (self simplifyVirtualKeyCodes ifTrue: [#squeak1] ifFalse: [#'VK_OEM_MINUS']). - "For any country/region, the - key" - - 16rBE . #squeakPeriod. "#'VK_OEM_PERIOD'" "For any country/region, the . key" - - 16rBF . (self simplifyVirtualKeyCodes ifTrue: [#squeak1] ifFalse: [#'VK_OEM_2']). - "Used for miscellaneous characters; it can vary by keyboard. For the US standard keyboard, the /? key" - - 16rC0 . (self simplifyVirtualKeyCodes ifTrue: [#squeak1] ifFalse: [#'VK_OEM_3']). - "Used for miscellaneous characters; it can vary by keyboard. For the US standard keyboard, the `~ key'" - } pairsDo: [ :i :val | table at: i put: val] . - - 16rC1 to: 16rDA - do: [ :e | table at: e put: nil ]. - - { - - 16rDB . (self simplifyVirtualKeyCodes ifTrue: [#squeak1] ifFalse: [#'VK_OEM_4']). - "Used for miscellaneous characters; it can vary by keyboard. For the US standard keyboard, the [{ key" - - 16rDC . (self simplifyVirtualKeyCodes ifTrue: [#squeak1] ifFalse: [#'VK_OEM_5']). - "Used for miscellaneous characters; it can vary by keyboard. For the US standard keyboard, the \| key" - - 16rDD . (self simplifyVirtualKeyCodes ifTrue: [#squeak2] ifFalse: [#'VK_OEM_6']). - "Used for miscellaneous characters; it can vary by keyboard. For the US standard keyboard, the ]} key" - - 16rDE . (self simplifyVirtualKeyCodes ifTrue: [#squeak3] ifFalse: [#'VK_OEM_7']). - "Used for miscellaneous characters; it can vary by keyboard. For the US standard keyboard, the single-quote/double-quote key" - - 16rDF . #'VK_OEM_8'. - "Used for miscellaneous characters; it can vary by keyboard." - - 16rE0 . nil. - 16rE1 . nil. - - 16rE2 . (self simplifyVirtualKeyCodes ifTrue: [#squeak4] ifFalse: [#'VK_OEM_102']). - "Either the angle bracket key or the backslash key on the RT 102-key keyboard" - - 16rE3 . nil. - 16rE4 . nil. - 16rE5 . #'VK_PROCESSKEY'. "IME PROCESS key" - 16rE6 . nil. - 16rE7 . #'VK_PACKET'. "Used to pass Unicode characters as if they were keystrokes. The VK_PACKET key is the low word of a 32-bit Virtual Key value used for non-keyboard input methods." - } pairsDo: [ :i :val | table at: i put: val] . - - 16rE8 to: 16rF5 - do: [ :e | table at: e put: nil ]. - - { - 16rF6 . #'VK_ATTN'. - 16rF7 . #'VK_CRSEL'. - 16rF8 . #'VK_EXSEL'. - 16rF9 . #'VK_EREOF'. "Erase EOF key" - 16rFA . #'VK_PLAY'. - 16rFB . #'VK_ZOOM'. - 16rFC . #'VK_NONAME'. "Reserved" - 16rFD . #'VK_PA1'. - 16rFE . #'VK_OEM_CLEAR'. "Clear key" - - } pairsDo: [ :i :val | table at: i put: val] . - - ^table - - ! Item was removed: - ----- Method: EventSensor class>>virtualKeysOnX11 (in category 'virtual keys') ----- - virtualKeysOnX11 - "Based on the OSVM X11 code as of 202104182333" - "https://code.woboq.org/kde/include/X11/keysymdef.h.html" - - "!!!!!! There are non-printable control keys for keyDown events on X11. Sigh." - self flag: #todo. "Linux VM is broken. We need scancodes but we get actual character codes. It is really hard to determine physical keys from that." - - ^ Dictionary newFromPairs: { - "Regular ASCII" - 16r41 . $A. - 16r42 . $B. - 16r43 . $C. - 16r44 . $D. - 16r45 . $E. - 16r46 . $F. - 16r47 . $G. - 16r48 . $H. - 16r49 . $I. - 16r4A . $J. - 16r4B . $K. - 16r4C . $L. - 16r4D . $M. - 16r4E . $N. - 16r4F . $O. - 16r50 . $P. - 16r51 . $Q. - 16r52 . $R. - 16r53 . $S. - 16r54 . $T. - 16r55 . $U. - 16r56 . $V. - 16r57 . $W. - 16r58 . $X. - 16r59 . $Y. - 16r5A . $Z. - - "Regular ASCII - numbers" - 16r30 . $0. - 16r31 . $1. - 16r32 . $2. - 16r33 . $3. - 16r34 . $4. - 16r35 . $5. - 16r36 . $6. - 16r37 . $7. - 16r38 . $8. - 16r39 . $9. - - "Mapped to uppercase when SHIFT is pressed ... sigh ..." - 16r61 . $A. - 16r62 . $B. - 16r63 . $C. - 16r64 . $D. - 16r65 . $E. - 16r66 . $F. - 16r67 . $G. - 16r68 . $H. - 16r69 . $I. - 16r6A . $J. - 16r6B . $K. - 16r6C . $L. - 16r6D . $M. - 16r6E . $N. - 16r6F . $O. - 16r70 . $P. - 16r71 . $Q. - 16r72 . $R. - 16r73 . $S. - 16r74 . $T. - 16r75 . $U. - 16r76 . $V. - 16r77 . $W. - 16r78 . $X. - 16r79 . $Y. - 16r7A . $Z. - - "most common non-printable control characters" - 16r01 . Character home. - 16r03 . Character enter. - 16r04 . Character end. - 16r05 . Character insert. - 16r08 . Character backspace. - 16r09 . Character tab. - 16r0B . Character pageUp. - 16r0C . Character pageDown. - 16r0D . Character return. - 16r1B . Character escape. - 16r1C . Character arrowLeft. - 16r1D . Character arrowRight. - 16r1E . Character arrowUp. - 16r1F . Character arrowDown. - 16r20 . Character space. - - 16r7F . Character delete. - - "Physical modifier keys" - 16rF7 . (self mapAltKeysToOptionKeys ifTrue: [#option] ifFalse: [#command "aka. #alt"]). "#'XK_Alt_L'" - 16rFE . #shift. "#'XK_Shift_R'" - 16rFF . #shift. "#'XK_Shift_L'." - 16rFA . (self mapControlKeysToCommandKeys ifTrue: [#command] ifFalse: [#control]). "#'XK_Control_R'" - 16rFB . (self mapControlKeysToCommandKeys ifTrue: [#command] ifFalse: [#control]). "#'XK_Control_L'." - 16rFD . #capsLock. "#'XK_Caps_Lock'." - - "Try to make sense of some other key characters. Hmpf." - 16r22 . #squeak1. - 16r23 . #squeak1. - 16r27 . #squeak1. - 16r2D . #squeak1. - 16r2F . #squeak1. - 16r3A . #squeak1. - 16r3B . #squeak1. - 16r3C . #squeak1. - 16r3E . #squeak1. - 16r3F . #squeak1. - 16r5B . #squeak1. - 16r5C . #squeak1. - 16r5E . #squeak1. - 16r5F . #squeak1. - 16r60 . #squeak1. - 16r7B . #squeak1. - 16r7C . #squeak1. - 16r7E . #squeak1. - 16rC2 . #squeak1. - 16rC3 . #squeak1. - - 16r2A . #squeak2. - 16r2B . #squeak2. - 16r3D . #squeak2. - 16r5D . #squeak2. - 16r7D . #squeak2. - - 16r2C . #squeakComma. - 16r2E . #squeakPeriod. - } - - ! Item was removed: - ----- Method: EventSensor>>anyButtonPressed (in category 'mouse') ----- - anyButtonPressed - "Answer whether at least one mouse button is currently being pressed." - - ^ self peekButtons anyMask: 7 - ! Item was removed: - ----- Method: EventSensor>>anyModifierKeyPressed (in category 'modifier keys') ----- - anyModifierKeyPressed - "ignore, however, the shift keys 'cause that's not REALLY a modifier key" - - ^ self peekButtons anyMask: (2r1110 "cmd | opt | ctrl" bitShift: EventSensor numMouseButtons)! Item was removed: - ----- Method: EventSensor>>blueButtonPressed (in category 'mouse') ----- - blueButtonPressed - "Answer whether only the blue mouse button is being pressed. - This is the third mouse button or cmd+click on the Mac." - - ^ (self peekButtons bitAnd: 7) = 1 - ! Item was removed: - ----- Method: EventSensor>>commandKeyPressed (in category 'modifier keys') ----- - commandKeyPressed - "Answer whether the command key on the keyboard is being held down." - - ^ self peekButtons anyMask: (2r1000 "cmd" bitShift: EventSensor numMouseButtons)! Item was removed: - ----- Method: EventSensor>>controlKeyPressed (in category 'modifier keys') ----- - controlKeyPressed - "Answer whether the control key on the keyboard is being held down." - - ^ self peekButtons anyMask: (2r0010 "ctrl" bitShift: EventSensor numMouseButtons)! Item was removed: - ----- Method: EventSensor>>createMouseEvent (in category 'mouse') ----- - createMouseEvent - "create and return a new mouse event from the current mouse - position; this is useful for restarting normal event queue - processing after manual polling" - - | buttons modifiers pos mapped eventBuffer | - eventBuffer := Array new: 8. - buttons := self peekButtons. - pos := self peekPosition. - modifiers := buttons bitShift: -3. - buttons := buttons bitAnd: 7. - mapped := self mapButtons: buttons modifiers: modifiers. - eventBuffer - at: 1 - put: EventTypeMouse; - at: 2 put: self eventTimeNow; - at: 3 put: pos x; - at: 4 put: pos y; - at: 5 put: mapped; - at: 6 put: modifiers. - ^ eventBuffer! Item was removed: - ----- Method: EventSensor>>cursorPoint (in category 'mouse') ----- - cursorPoint - "Answer a Point indicating the cursor location." - - ^ self peekPosition! Item was removed: - ----- Method: EventSensor>>cursorPoint: (in category 'mouse') ----- - cursorPoint: aPoint - "Set aPoint to be the current cursor location." - - ^self primCursorLocPut: aPoint! Item was removed: - ----- Method: EventSensor>>eventQueue (in category 'accessing') ----- - eventQueue - ^ eventQueue! Item was removed: - ----- Method: EventSensor>>eventQueue: (in category 'accessing') ----- - eventQueue: aSharedQueue - eventQueue := aSharedQueue.! Item was removed: - ----- Method: EventSensor>>eventTickler (in category 'private') ----- - eventTickler - "Poll infrequently to make sure that the UI process is not been stuck. - If it has been stuck, then spin the event loop so that I can detect the - interrupt key." - | delay | - delay := Delay forMilliseconds: self class eventPollPeriod. - self lastEventPoll. "ensure not nil." - [| delta | - [ delay wait. - delta := Time millisecondClockValue - lastEventPoll. - (delta < 0 - or: [delta > self class eventPollPeriod]) - ifTrue: - ["force check on rollover" - self fetchMoreEvents]] - on: Error do: [:ex | ]] repeat.! Item was removed: - ----- Method: EventSensor>>eventTicklerProcess (in category 'accessing') ----- - eventTicklerProcess - "Answer my event tickler process, if any" - ^EventTicklerProcess! Item was removed: - ----- Method: EventSensor>>eventTimeNow (in category 'private') ----- - eventTimeNow - "Answer an event timeStamp that is slightly more recent than that of - the most recently processed event. Intended for synthesized events to - be processed in line with those from the real event queue." - - ^ lastEventTime + 1. - ! Item was removed: - ----- Method: EventSensor>>fetchMoreEvents (in category 'private-I/O') ----- - fetchMoreEvents - "Fetch more events from the VM" - | eventBuffer type | - - "Reset input semaphore so clients can wait for the next events after this one." - inputSemaphore isSignaled - ifTrue: [ hasInputSemaphore := true. - inputSemaphore initSignals ]. - - "Remember the last time that I checked for events." - lastEventPoll := Time millisecondClockValue. - - eventBuffer := Array new: 8. - [self primGetNextEvent: eventBuffer. - type := eventBuffer at: 1. - type = EventTypeNone] - whileFalse: [self processEvent: eventBuffer]. - ! Item was removed: - ----- Method: EventSensor>>flushEvents (in category 'accessing') ----- - flushEvents - - keyboardBuffer flush. - mouseWheelDelta := 0 at 0. - - self eventQueue ifNotNil: [:queue | queue flush].! Item was removed: - ----- Method: EventSensor>>hasTablet (in category 'tablet') ----- - hasTablet - "Answer true if there is a pen tablet available on this computer." - - ^ (self primTabletGetParameters: 1) notNil - ! Item was removed: - ----- Method: EventSensor>>initialize (in category 'initialize') ----- - initialize - - mouseButtons := 0. - mousePosition := 0 at 0. - mouseWheelDelta := 0 at 0. - keyboardBuffer := SharedQueue new. - - interruptKey := $. asciiValue bitOr: 16r0800. "cmd-." - interruptSemaphore := Semaphore new. - - eventQueue := SharedQueue new. - - inputSemaphore := Semaphore new. - hasInputSemaphore := false.! Item was removed: - ----- Method: EventSensor>>installEventTickler (in category 'private') ----- - installEventTickler - "Initialize the interrupt watcher process. Terminate the old process if any." - "Sensor installEventTickler" - - EventTicklerProcess ifNotNil: [EventTicklerProcess terminate]. - EventTicklerProcess := [self eventTickler] forkAt: Processor lowIOPriority. - ! Item was removed: - ----- Method: EventSensor>>installInterruptWatcher (in category 'user interrupts') ----- - installInterruptWatcher - "Initialize the interrupt watcher process. Terminate the old process if any." - "Sensor installInterruptWatcher" - - InterruptWatcherProcess ifNotNil: [InterruptWatcherProcess terminate]. - InterruptWatcherProcess := [self userInterruptWatcher] forkAt: Processor lowIOPriority.! Item was removed: - ----- Method: EventSensor>>interruptWatcherProcess (in category 'user interrupts') ----- - interruptWatcherProcess - "Answer my interrupt watcher process, if any" - ^InterruptWatcherProcess! Item was removed: - ----- Method: EventSensor>>isAnyKbdEvent: (in category 'private') ----- - isAnyKbdEvent: buf - ^(buf at: 1) = EventTypeKeyboard! Item was removed: - ----- Method: EventSensor>>isKbdEvent: (in category 'private') ----- - isKbdEvent: buf - ^ (buf at: 1) = EventTypeKeyboard and: [(buf at: 4) = EventKeyChar]! Item was removed: - ----- Method: EventSensor>>joystickButtons: (in category 'joystick') ----- - joystickButtons: index - - ^ ((self primReadJoystick: index) bitShift: -22) bitAnd: 16r71F - ! Item was removed: - ----- Method: EventSensor>>joystickOn: (in category 'joystick') ----- - joystickOn: index - - ^ (((self primReadJoystick: index) bitShift: -27) bitAnd: 1) ~= 0 - ! Item was removed: - ----- Method: EventSensor>>joystickXY: (in category 'joystick') ----- - joystickXY: index - - | inputWord x y | - inputWord := self primReadJoystick: index. - x := (inputWord bitAnd: 16r7FF) - 16r400. - y := ((inputWord bitShift: -11) bitAnd: 16r7FF) - 16r400. - ^ x at y - ! Item was removed: - ----- Method: EventSensor>>lastEventPoll (in category 'private') ----- - lastEventPoll - "Answer the last clock value at which fetchMoreEvents was called." - ^lastEventPoll ifNil: [ lastEventPoll := Time millisecondClockValue ]! Item was removed: - ----- Method: EventSensor>>leftShiftDown (in category 'modifier keys') ----- - leftShiftDown - "Answer whether the shift key on the keyboard is being held down. The name of this message is a throwback to the Alto, which had independent left and right shift keys." - - ^ self peekButtons anyMask: 8! Item was removed: - ----- Method: EventSensor>>mapButtons:modifiers: (in category 'private-I/O') ----- - mapButtons: buttons modifiers: modifiers - "Map the buttons to yellow or blue based on the given modifiers. - If only the red button is pressed, then map - Ctrl-RedButton -> BlueButton. - Cmd-RedButton -> YellowButton. - " - (buttons = RedButtonBit) - ifFalse:[^buttons]. - (modifiers allMask: CtrlKeyBit) - ifTrue:[^BlueButtonBit]. - (modifiers allMask: CommandKeyBit) - ifTrue:[^YellowButtonBit]. - ^buttons! Item was removed: - ----- Method: EventSensor>>mouseButtons (in category 'mouse') ----- - mouseButtons - "Answer a number from 0 to 7 that encodes the state of the three mouse buttons in its lowest 3 bits." - - ^ self peekButtons bitAnd: 7 - ! Item was removed: - ----- Method: EventSensor>>nextEvent (in category 'accessing') ----- - nextEvent - "Return the next event from the receiver. If the queue is empty, try to fetch more events once." - - ^ self eventQueue - ifNil: [ - self fetchMoreEvents. - self nextEventSynthesized] - ifNotNil: [:queue | - keyboardBuffer flush. - mouseWheelDelta := 0 at 0. - queue isEmpty ifTrue: [self fetchMoreEvents]. - queue nextOrNil]! Item was removed: - ----- Method: EventSensor>>nextEventSynthesized (in category 'private') ----- - nextEventSynthesized - - | synthesizedEvent | - synthesizedEvent := self peekEventSynthesized. - keyboardBuffer nextOrNil. - ^ synthesizedEvent! Item was removed: - ----- Method: EventSensor>>noButtonPressed (in category 'mouse') ----- - noButtonPressed - "Answer whether any mouse button is not being pressed." - - ^self anyButtonPressed not - ! Item was removed: - ----- Method: EventSensor>>oldPrimInterruptSemaphore: (in category 'primitives-fallback') ----- - oldPrimInterruptSemaphore: aSemaphore - "Primitive. Install the argument as the semaphore to be signalled whenever the user presses the interrupt key. The semaphore will be signaled once each time the interrupt key is pressed." - - <primitive: 134> - ^self primitiveFailed - "Note: This primitive is obsolete with the new event driven architecture in which EventSensor can handle the interrupts itself. However, for supporting older images running on newer VMs the primitive must still be implemented."! Item was removed: - ----- Method: EventSensor>>oldPrimKbdNext (in category 'primitives-fallback') ----- - oldPrimKbdNext - <primitive: 108> - ^ nil! Item was removed: - ----- Method: EventSensor>>oldPrimMouseButtons (in category 'primitives-fallback') ----- - oldPrimMouseButtons - <primitive: 107> - ^ 0! Item was removed: - ----- Method: EventSensor>>oldPrimMousePt (in category 'primitives-fallback') ----- - oldPrimMousePt - "Primitive. Poll the mouse to find out its position. Return a Point. Fail if - event-driven tracking is used instead of polling. Optional. See Object - documentation whatIsAPrimitive." - - <primitive: 90> - ^ 0 at 0! Item was removed: - ----- Method: EventSensor>>oldPrimSetInterruptKey: (in category 'primitives-fallback') ----- - oldPrimSetInterruptKey: anInteger - "Primitive. Register the given keycode as the user interrupt key. The low byte of the keycode is the ISO character and its next four bits are the Smalltalk modifer bits <cmd><opt><ctrl><shift>." - - <primitive: 133> - ^self primitiveFailed - "Note: This primitive is obsolete with the new event driven architecture in which EventSensor can handle the interrupts itself. However, for supporting older images running on newer VMs the primitive must still be implemented."! Item was removed: - ----- Method: EventSensor>>optionKeyPressed (in category 'modifier keys') ----- - optionKeyPressed - "Answer whether the option key on the Macintosh keyboard is being held down. Macintosh specific. Clients are discouraged from calling this directly, since it circumvents bert's attempt to eradicate option-key checks" - - ^ self peekButtons anyMask: (2r0100 "opt" bitShift: EventSensor numMouseButtons)! Item was removed: - ----- Method: EventSensor>>peekEvent (in category 'accessing') ----- - peekEvent - "Look ahead at the next event. Try to fetch more events first." - - ^ self eventQueue - ifNil: [ - self fetchMoreEvents. - self peekEventSynthesized] - ifNotNil: [:queue | - queue isEmpty ifTrue: [self fetchMoreEvents]. - queue peek]! Item was removed: - ----- Method: EventSensor>>peekEventSynthesized (in category 'private') ----- - peekEventSynthesized - "Return a synthesized event. This method is called if an event driven client wants to receive events but the primary user interface is not event-driven (e.g., the receiver does not have an event queue but only updates its state). This can, for instance, happen if a Morphic World is run in an MVC window. To simplify the clients work this method will always return all available keyboard events first, and then (repeatedly) the mouse events. Since mouse events come last, the client can assume that after one mouse event has been received there are no more to come. Note that it is impossible for EventSensor to determine if a mouse event has been issued before so the client must be aware of the possible problem of getting repeatedly the same mouse events. See HandMorph>>processEvents for an example on how to deal with this." - | kbd array buttons pos modifiers mapped | - "First check for keyboard" - array := Array new: 8. - keyboardBuffer isEmpty ifFalse: - ["simulate keyboard event" - array at: 1 put: EventTypeKeyboard. "evt type" - array at: 2 put: self eventTimeNow. "time stamp" - array at: 3 put: ((kbd := keyboardBuffer peek) bitAnd: 255). "char code" - array at: 4 put: EventKeyChar. "key press/release" - array at: 5 put: (kbd bitShift: -8). "modifier keys" - ^ array]. - - "Then check for mouse" - pos := mousePosition. - buttons := mouseButtons. - modifiers := buttons bitShift: -3. - buttons := buttons bitAnd: 7. - mapped := self mapButtons: buttons modifiers: modifiers. - array - at: 1 put: EventTypeMouse; - at: 2 put: self eventTimeNow; - at: 3 put: pos x; - at: 4 put: pos y; - at: 5 put: mapped; - at: 6 put: modifiers. - ^ array - - ! Item was removed: - ----- Method: EventSensor>>primCursorLocPut: (in category 'private-I/O') ----- - primCursorLocPut: aPoint - "If the primitive fails, try again with a rounded point." - - <primitive: 91> - ^ self primCursorLocPutAgain: aPoint rounded! Item was removed: - ----- Method: EventSensor>>primCursorLocPutAgain: (in category 'private-I/O') ----- - primCursorLocPutAgain: aPoint - "Do nothing if primitive is not implemented." - - <primitive: 91> - ^ self! Item was removed: - ----- Method: EventSensor>>primGetNextEvent: (in category 'private-I/O') ----- - primGetNextEvent: array - "Store the next OS event available into the provided array. - Essential. If the VM is not event driven the ST code will fall - back to the old-style mechanism and use the state based - primitives instead." - | kbd buttons modifiers pos mapped | - <primitive: 94> - "Simulate the events" - array at: 1 put: EventTypeNone. "assume no more events" - - "First check for keyboard" - kbd := self oldPrimKbdNext. - kbd = nil ifFalse:[ - "simulate keyboard event" - array at: 1 put: EventTypeKeyboard. "evt type" - array at: 2 put: self eventTimeNow. "time stamp" - array at: 3 put: (kbd bitAnd: 255). "char code" - array at: 4 put: EventKeyChar. "key press/release" - array at: 5 put: (kbd bitShift: -8). "modifier keys" - ^self]. - - "Then check for mouse" - buttons := self oldPrimMouseButtons. - pos := self oldPrimMousePt. - modifiers := buttons bitShift: -3. - buttons := buttons bitAnd: 7. - mapped := self mapButtons: buttons modifiers: modifiers. - (pos = mousePosition and:[(mapped bitOr: (modifiers bitShift: 3)) = mouseButtons]) - ifTrue:[^self]. - array - at: 1 put: EventTypeMouse; - at: 2 put: self eventTimeNow; - at: 3 put: pos x; - at: 4 put: pos y; - at: 5 put: mapped; - at: 6 put: modifiers. - ! Item was removed: - ----- Method: EventSensor>>primReadJoystick: (in category 'primitives-tablet') ----- - primReadJoystick: index - "Return the joystick input word for the joystick with the given index in the range [1..16]. Returns zero if the index does not correspond to a currently installed joystick." - - <primitive: 'primitiveReadJoystick' module: 'JoystickTabletPlugin'> - ^ 0 - - ! Item was removed: - ----- Method: EventSensor>>primSetInputSemaphore: (in category 'private-I/O') ----- - primSetInputSemaphore: semaIndex - "Set the input semaphore the VM should use for asynchronously signaling the availability of events. Primitive. Optional." - <primitive: 93> - ^nil! Item was removed: - ----- Method: EventSensor>>primTabletGetParameters: (in category 'primitives-tablet') ----- - primTabletGetParameters: cursorIndex - "Answer the pen tablet parameters. For parameters that differ from cursor to cursor, answer those associated with the cursor having the given index. Answer nil if there is no pen tablet. The parameters are: - 1. tablet width, in tablet units - 2. tablet height, in tablet units - 3. number of tablet units per inch - 4. number of cursors (pens, pucks, etc; some tablets have more than one) - 5. this cursor index - 6. and 7. x scale and x offset for scaling tablet coordintes (e.g., to fit the screen) - 8. and 9. y scale and y offset for scaling tablet coordintes (e.g., to fit the screen) - 10. number of pressure levels - 11. presure threshold needed close pen tip switch - 12. number of pen tilt angles" - - <primitive: 'primitiveGetTabletParameters' module: 'JoystickTabletPlugin'> - ^ nil - ! Item was removed: - ----- Method: EventSensor>>primTabletRead: (in category 'primitives-tablet') ----- - primTabletRead: cursorIndex - "Answer the pen tablet data for the cursor having the given index. Answer nil if there is no pen tablet. The data is: - 1. index of the cursor to which this data applies - 2. timestamp of the last state chance for this cursor - 3., 4., and 5. x, y, and z coordinates of the cursor (z is typically 0) - 6. and 7. xTilt and yTilt of the cursor; (signed) - 8. type of cursor (0 = unknown, 1 = pen, 2 = puck, 3 = eraser) - 9. cursor buttons - 10. cursor pressure, downward - 11. cursor pressure, tangential - 12. flags" - - <primitive: 'primitiveReadTablet' module: 'JoystickTabletPlugin'> - self primitiveFailed - ! Item was removed: - ----- Method: EventSensor>>processEvent: (in category 'private-I/O') ----- - processEvent: evt - "Process a single event. This method is run at high priority." - | type buttons window | - type := evt at: 1. - lastEventTime := evt at: 2. - - "Only process main window events, forward others to host window proxies" - window := evt at: 8. - (window isNil or: [window isZero]) ifTrue: - [window := 1. - evt at: 8 put: window]. - window = 1 ifFalse: [ - ^Smalltalk at: #HostWindowProxy ifPresent: [:w | w processEvent: evt]]. - - "Tackle mouse events and mouse wheel events first" - (type = EventTypeMouse or: [type = EventTypeMouseWheel]) - ifTrue: [buttons := (ButtonDecodeTable at: (evt at: 5) + 1). - evt at: 5 put: (Smalltalk platformName = 'Mac OS' - ifTrue: [ buttons ] - ifFalse: [ self mapButtons: buttons modifiers: (evt at: 6) ]). - self queueEvent: evt. - type = EventTypeMouseWheel - ifTrue: [^ self processMouseWheelEvent: evt]. - type = EventTypeMouse - ifTrue: [^ self processMouseEvent: evt]]. - - "Store the event in the queue if there's any" - type = EventTypeKeyboard - ifTrue: [ "Check if the event is a user interrupt" - ((evt at: 4) = EventKeyChar - and: [((evt at: 3) - bitOr: (((evt at: 5) - bitAnd: 8) - bitShift: 8)) - = interruptKey]) - ifTrue: ["interrupt key is meta - not reported as event" - ^ interruptSemaphore signal]. - "Decode keys for characters (e.g., map ctrl -> cmd)." - (evt at: 4) = EventKeyChar - ifTrue: [ | unicode ascii | - "Copy lookup key first in case of key swap." - unicode := {evt at: 6. evt at: 5}. - ascii := {evt at: 3. evt at: 5}. - KeyDecodeTable "Unicode character first" - at: unicode - ifPresent: [:a | evt at: 6 put: a first; - at: 5 put: a second]. - KeyDecodeTable "ASCII character second" - at: ascii - ifPresent: [:a | evt at: 3 put: a first; - at: 5 put: a second]] - ifFalse: ["Replace modifiers for virtual keys. (keyUp/keyDown)" - (evt at: 5) > 0 "Any modifier pressed?" ifTrue: [ - VirtualKeyTable - at: ((evt at: 5) bitShift: 8) - ifPresent: [:a | evt at: 5 put: a]]]. - self queueEvent: evt. - self processKeyboardEvent: evt . - ^self ]. - - "Handle all events other than Keyboard or Mouse." - self queueEvent: evt. - ! Item was removed: - ----- Method: EventSensor>>processKeyboardEvent: (in category 'private-I/O') ----- - processKeyboardEvent: evt - "process a keyboard event, updating EventSensor state" - "Never update keyboardBuffer if we have an eventQueue active" - mouseButtons := (mouseButtons bitAnd: EventSensor anyMouseButtonMask) bitOr: ((evt at: 5) bitShift: EventSensor numMouseButtons). - - (evt at: 3) ifNotNil: "extra characters not handled in MVC" - [:charCode| | pressCode | - (pressCode := evt at: 4) = EventKeyChar ifTrue: "key down/up not handled in MVC" - ["mix in modifiers" - keyboardBuffer nextPut: (charCode bitOr: ((evt at: 5) bitShift: 8))]]! Item was removed: - ----- Method: EventSensor>>processMouseEvent: (in category 'private-I/O') ----- - processMouseEvent: evt - "process a mouse event, updating EventSensor state" - | modifiers buttons mapped | - mousePosition := (evt at: 3) @ (evt at: 4). - buttons := evt at: 5. - modifiers := evt at: 6. - mapped := self mapButtons: buttons modifiers: modifiers. - mouseButtons := mapped bitOr: (modifiers bitShift: EventSensor numMouseButtons)! Item was removed: - ----- Method: EventSensor>>processMouseWheelEvent: (in category 'private-I/O') ----- - processMouseWheelEvent: evt - "process a mouse wheel event, updating EventSensor state" - - | modifiers buttons mapped | - mouseWheelDelta := mouseWheelDelta + ((evt at: 3) @ (evt at: 4)). - buttons := evt at: 5. - modifiers := evt at: 6. - mapped := self mapButtons: buttons modifiers: modifiers. - mouseButtons := mapped bitOr: (modifiers bitShift: EventSensor numMouseButtons)! Item was removed: - ----- Method: EventSensor>>queueEvent: (in category 'private-I/O') ----- - queueEvent: evt - "Queue the given event in the event queue (if any). - Note that the event buffer must be copied since it - will be reused later on." - - self eventQueue ifNotNil: [:queue | - queue nextPut: evt shallowCopy].! Item was removed: - ----- Method: EventSensor>>rawMacOptionKeyPressed (in category 'modifier keys') ----- - rawMacOptionKeyPressed - "Answer whether the option key on the Macintosh keyboard is being held down. Macintosh specific. Clients are discouraged from calling this directly, since it circumvents bert's attempt to eradicate option-key checks" - - self deprecated: 'Use #optionKeyPressed instead.'. - ^ self optionKeyPressed! Item was removed: - ----- Method: EventSensor>>redButtonPressed (in category 'mouse') ----- - redButtonPressed - "Answer true if only the red mouse button is being pressed. - This is the first mouse button, usually the left one." - - ^ (self peekButtons bitAnd: 7) = 4 - ! Item was removed: - ----- Method: EventSensor>>shiftPressed (in category 'modifier keys') ----- - shiftPressed - "Answer whether the shift key on the keyboard is being held down." - - ^ self peekButtons anyMask: (2r0001 "shift" bitShift: EventSensor numMouseButtons)! Item was removed: - ----- Method: EventSensor>>shutDown (in category 'initialize') ----- - shutDown - - InterruptWatcherProcess ifNotNil: [ - InterruptWatcherProcess terminate. - InterruptWatcherProcess := nil ]. - - EventTicklerProcess ifNotNil: [ - EventTicklerProcess terminate. - EventTicklerProcess := nil. ]. - - inputSemaphore ifNotNil:[Smalltalk unregisterExternalObject: inputSemaphore].! Item was removed: - ----- Method: EventSensor>>startUp (in category 'initialize') ----- - startUp - - self initialize. - self primSetInputSemaphore: (Smalltalk registerExternalObject: inputSemaphore). - - self installInterruptWatcher. - self installEventTickler. - - self eventQueue: SharedQueue new. - - "Attempt to discover whether the input semaphore is actually being signaled." - hasInputSemaphore := false. - inputSemaphore initSignals.! Item was removed: - ----- Method: EventSensor>>tabletExtent (in category 'tablet') ----- - tabletExtent - "Answer the full tablet extent in tablet coordinates." - - | params | - params := self primTabletGetParameters: 1. - params ifNil: [^ self error: 'no tablet available']. - ^ (params at: 1)@(params at: 2) - ! Item was removed: - ----- Method: EventSensor>>tabletPoint (in category 'tablet') ----- - tabletPoint - "Answer the current position of the first tablet pointing device (pen, puck, or eraser) in tablet coordinates." - - | data | - data := self primTabletRead: 1. "state of first/primary pen" - ^ (data at: 3) @ (data at: 4) - ! Item was removed: - ----- Method: EventSensor>>tabletPressure (in category 'tablet') ----- - tabletPressure - "Answer the current pressure of the first tablet pointing device (pen, puck, or eraser), a number between 0.0 (no pressure) and 1.0 (max pressure)" - - | params data | - params := self primTabletGetParameters: 1. - params ifNil: [^ self]. - data := self primTabletRead: 1. "state of first/primary pen" - ^ (data at: 10) asFloat / ((params at: 10) - 1) - ! Item was removed: - ----- Method: EventSensor>>tabletTimestamp (in category 'tablet') ----- - tabletTimestamp - "Answer the time (in tablet clock ticks) at which the tablet's primary pen last changed state. This can be used in polling loops; if this timestamp hasn't changed, then the pen state hasn't changed either." - - | data | - data := self primTabletRead: 1. "state of first/primary pen" - ^ data at: 2 - ! Item was removed: - ----- Method: EventSensor>>userInterruptWatcher (in category 'user interrupts') ----- - userInterruptWatcher - "Wait for user interrupts and open a notifier on the active process when one occurs." - [ interruptSemaphore wait. - Display deferUpdates: false. - SoundService stop. - Smalltalk handleUserInterrupt ] repeat! Item was removed: - ----- Method: EventSensor>>waitButton (in category 'mouse') ----- - waitButton - "Wait for the user to press any mouse button and then answer with the - current location of the cursor." - - | delay | - delay := Delay forMilliseconds: 50. - [self anyButtonPressed] whileFalse: [ delay wait ]. - ^self cursorPoint - ! Item was removed: - ----- Method: EventSensor>>waitButtonOrKeyboard (in category 'mouse') ----- - waitButtonOrKeyboard - "Wait for the user to press either any mouse button or any key. - Answer the current cursor location or nil if a keypress occured." - - | delay | - delay := Delay forMilliseconds: 50. - [self anyButtonPressed] - whileFalse: [delay wait. - self keyboardPressed - ifTrue: [^ nil]]. - ^ self cursorPoint - ! Item was removed: - ----- Method: EventSensor>>waitClickButton (in category 'mouse') ----- - waitClickButton - "Wait for the user to click (press and then release) any mouse button and - then answer with the current location of the cursor." - - self waitButton. - ^self waitNoButton! Item was removed: - ----- Method: EventSensor>>waitNoButton (in category 'mouse') ----- - waitNoButton - "Wait for the user to release any mouse button and then answer the current location of the cursor." - - | delay | - delay := Delay forMilliseconds: 50. - [self anyButtonPressed] whileTrue: [ delay wait]. - ^self cursorPoint - ! Item was removed: - ----- Method: EventSensor>>yellowButtonPressed (in category 'mouse') ----- - yellowButtonPressed - "Answer whether only the yellow mouse button is being pressed. - This is the second mouse button or option+click on the Mac." - - ^ (self peekButtons bitAnd: 7) = 2 - ! Item was removed: - SharedPool subclass: #EventSensorConstants - instanceVariableNames: '' - classVariableNames: 'BlueButtonBit CommandKeyBit CtrlKeyBit EventKeyChar EventKeyDown EventKeyUp EventTouchCancelled EventTouchDown EventTouchMoved EventTouchStationary EventTouchUp EventTypeComplex EventTypeDragDropFiles EventTypeKeyboard EventTypeMenu EventTypeMouse EventTypeMouseWheel EventTypeNone EventTypeWindow OptionKeyBit RedButtonBit ShiftKeyBit TouchPhaseBegan TouchPhaseCancelled TouchPhaseEnded TouchPhaseMoved TouchPhaseStationary WindowEventActivated WindowEventClose WindowEventIconise WindowEventMetricChange WindowEventPaint WindowEventScreenChange YellowButtonBit' - poolDictionaries: '' - category: 'Kernel-Processes'! Item was removed: - ----- Method: EventSensorConstants class>>initialize (in category 'pool initialization') ----- - initialize - "EventSensorConstants initialize" - RedButtonBit := 4. - BlueButtonBit := 2. - YellowButtonBit := 1. - - ShiftKeyBit := 1. - CtrlKeyBit := 2. - OptionKeyBit := 4. - CommandKeyBit := 8. - - "Types of events" - EventTypeNone := 0. - EventTypeMouse := 1. - EventTypeKeyboard := 2. - EventTypeDragDropFiles := 3. - EventTypeMenu := 4. - EventTypeWindow := 5. - EventTypeComplex := 6. - EventTypeMouseWheel := 7. - - "Press codes for keyboard events" - EventKeyChar := 0. - EventKeyDown := 1. - EventKeyUp := 2. - - "Host window events" - WindowEventMetricChange := 1. - WindowEventClose := 2. - WindowEventIconise := 3. - WindowEventActivated := 4. - WindowEventPaint := 5. - WindowEventScreenChange := 6. - - "types for touch events" - EventTouchDown := 1. - EventTouchUp := 2. - EventTouchMoved := 3. - EventTouchStationary := 4. - EventTouchCancelled := 5. - - "iOS touch phase constants" - TouchPhaseBegan := 0. - TouchPhaseMoved := 1. - TouchPhaseStationary := 2. - TouchPhaseEnded := 3. - TouchPhaseCancelled := 4. - ! Item was removed: - Object subclass: #Exception - instanceVariableNames: 'messageText tag signalContext handlerContext outerContext' - classVariableNames: '' - poolDictionaries: '' - category: 'Kernel-Exceptions-Kernel'! - - !Exception commentStamp: 'eem 3/30/2017 17:49' prior: 0! - This is the main class used to implement the exception handling system (EHS). It plays two distinct roles: that of the exception, and that of the exception handler. More specifically, it implements the bulk of the protocols laid out in the ANSI specification - those protocol names are reflected in the message categories. - - Exception is an abstract class. Instances should neither be created nor trapped. In most cases, subclasses should inherit from Error or Notification rather than directly from Exception. - - In implementing this EHS, The Fourth Estate Inc. incorporated some ideas and code from Craig Latta's EHS. His insights were crucial in allowing us to implement BlockClosure>>valueUninterruptably (and by extension, #ensure: and #ifCurtailed:), and we imported the following methods with little or no modification: - - Context>>terminateTo: - Context>>terminate - Context>>receiver: - Context>>answer: - - Thanks, Craig!!! Item was removed: - ----- Method: Exception class>>, (in category 'exceptionSelector') ----- - , anotherException - "Create an exception set." - - ^ExceptionSet new - add: self; - add: anotherException; - yourself! Item was removed: - ----- Method: Exception class>>handles: (in category 'exceptionSelector') ----- - handles: exception - "Determine whether an exception handler will accept a signaled exception." - - ^ exception isKindOf: self! Item was removed: - ----- Method: Exception class>>signal (in category 'exceptionInstantiator') ----- - signal - "Signal the occurrence of an exceptional condition." - - ^ self new signal! Item was removed: - ----- Method: Exception class>>signal: (in category 'exceptionInstantiator') ----- - signal: signalerText - "Signal the occurrence of an exceptional condition with a specified textual description." - - ^ self new signal: signalerText! Item was removed: - ----- Method: Exception>>canSearchForSignalerContext (in category 'debug support') ----- - canSearchForSignalerContext - "This method is /only/ to support the debugger's catching of exceptions in stepIntoBlock." - ^signalContext isContext! Item was removed: - ----- Method: Exception>>defaultAction (in category 'priv handling') ----- - defaultAction - "The default action taken if the exception is signaled." - - self subclassResponsibility! Item was removed: - ----- Method: Exception>>defaultResumeValue (in category 'defaults') ----- - defaultResumeValue - "Answer the value that by default should be returned if the exception is resumed" - ^nil! Item was removed: - ----- Method: Exception>>defaultReturnValue (in category 'defaults') ----- - defaultReturnValue - "Answer the value that by default should be returned if the exception is returned" - ^nil! Item was removed: - ----- Method: Exception>>description (in category 'printing') ----- - description - "Return a textual description of the exception." - - | desc mt | - desc := self class name asString. - ^(mt := self messageText) == nil - ifTrue: [desc] - ifFalse: [desc, ': ', mt]! Item was removed: - ----- Method: Exception>>freshCopy (in category 'copying') ----- - freshCopy - - ^ self copy refreshContexts! Item was removed: - ----- Method: Exception>>isNested (in category 'handling') ----- - isNested - "Determine whether the current exception handler is within the scope of another handler for the same exception." - - ^ handlerContext nextHandlerContext canHandleSignal: self! Item was removed: - ----- Method: Exception>>isResumable (in category 'priv handling') ----- - isResumable - "Determine whether an exception is resumable." - - ^ true! Item was removed: - ----- Method: Exception>>messageText (in category 'printing') ----- - messageText - "Return an exception's message text." - ^ messageText ifNil: [ String empty ]! Item was removed: - ----- Method: Exception>>messageText: (in category 'signaling') ----- - messageText: signalerText - "Set an exception's message text." - - messageText := signalerText! Item was removed: - ----- Method: Exception>>outer (in category 'handling') ----- - outer - "Evaluate the enclosing exception action and return to here instead of signal if it resumes (see #resumeUnchecked:)." - - | prevOuterContext currHandlerContext | - self isResumable ifTrue: [ - currHandlerContext := handlerContext. - prevOuterContext := outerContext. - outerContext := thisContext contextTag. - ]. - self pass. - ! Item was removed: - ----- Method: Exception>>pass (in category 'handling') ----- - pass - "Yield control to the enclosing exception action for the receiver." - - (handlerContext nextHandlerContextForSignal: self) handleSignal: self! Item was removed: - ----- Method: Exception>>printDetailsOn: (in category 'printing') ----- - printDetailsOn: aStream - "Allow applications to optionally print extra details without overriding a base package."! Item was removed: - ----- Method: Exception>>printOn: (in category 'printing') ----- - printOn: stream - - stream nextPutAll: self description! Item was removed: - ----- Method: Exception>>privHandlerContext (in category 'priv handling') ----- - privHandlerContext - ^handlerContext! Item was removed: - ----- Method: Exception>>privHandlerContext: (in category 'priv handling') ----- - privHandlerContext: aContextTag - - handlerContext := aContextTag! Item was removed: - ----- Method: Exception>>rearmHandlerDuring: (in category 'handling') ----- - rearmHandlerDuring: aBlock - "Make the current error handler re-entrant while it is running aBlock. Only works in a closure-enabled image" - - ^ handlerContext rearmHandlerDuring: aBlock! Item was removed: - ----- Method: Exception>>receiver (in category 'printing') ----- - receiver - - ^ self signalerContext receiver! Item was removed: - ----- Method: Exception>>refreshContexts (in category 'copying') ----- - refreshContexts - - signalContext := handlerContext := outerContext := nil. - ! Item was removed: - ----- Method: Exception>>resignalAs: (in category 'handling') ----- - resignalAs: replacementException - "Signal an alternative exception in place of the receiver. - Unwind to signalContext before signalling the replacement exception" - - signalContext resumeEvaluating: [replacementException signal]! Item was removed: - ----- Method: Exception>>resume (in category 'handling') ----- - resume - "Return from the message that signaled the receiver." - - self resume: self defaultResumeValue! Item was removed: - ----- Method: Exception>>resume: (in category 'handling') ----- - resume: resumptionValue - "Return resumptionValue as the value of the signal message." - - self isResumable ifFalse: [IllegalResumeAttempt signal]. - self resumeUnchecked: resumptionValue! Item was removed: - ----- Method: Exception>>resumeEvaluating: (in category 'handling') ----- - resumeEvaluating: aBlock - "Return result of evaluating aBlock as the value of #signal, unless this was called after an #outer message, then return resumptionValue as the value of #outer. - The block is only evaluated after unwinding the stack." - - | ctxt | - outerContext ifNil: [ - signalContext returnEvaluating: aBlock - ] ifNotNil: [ - ctxt := outerContext. - outerContext := ctxt tempAt: 1. "prevOuterContext in #outer" - handlerContext := ctxt tempAt: 2. "currHandlerContext in #outer" - ctxt returnEvaluating: aBlock - ]. - ! Item was removed: - ----- Method: Exception>>resumeUnchecked: (in category 'handling') ----- - resumeUnchecked: resumptionValue - "Return resumptionValue as the value of #signal, unless this was called after an #outer message, then return resumptionValue as the value of #outer." - - ^self resumeEvaluating: [resumptionValue]! Item was removed: - ----- Method: Exception>>retry (in category 'handling') ----- - retry - "Abort an exception handler and re-evaluate its protected block." - - handlerContext restart! Item was removed: - ----- Method: Exception>>retryUsing: (in category 'handling') ----- - retryUsing: alternativeBlock - "Abort an exception handler and evaluate a new block in place of the handler's protected block." - - handlerContext restartWithNewReceiver: alternativeBlock - ! Item was removed: - ----- Method: Exception>>return (in category 'handling') ----- - return - "Return nil as the value of the block protected by the active exception handler." - - self return: self defaultReturnValue! Item was removed: - ----- Method: Exception>>return: (in category 'handling') ----- - return: returnValue - "Return the argument as the value of the block protected by the active exception handler." - - handlerContext return: returnValue! Item was removed: - ----- Method: Exception>>searchFrom: (in category 'handling') ----- - searchFrom: aContext - " Set the context where the handler search will start. " - - signalContext := aContext contextTag! Item was removed: - ----- Method: Exception>>signal (in category 'signaling') ----- - signal - "Ask handler contexts in the sender chain to handle this signal. The default is to evaluate my defaultAction and return the result. - Sending #signal to an already signaled exception generates a fresh copy of the receiver." - - signalContext ifNotNil: [^self freshCopy signal]. - signalContext := thisContext contextTag. - ^(thisContext nextHandlerContextForSignal: self) handleSignal: self! Item was removed: - ----- Method: Exception>>signal: (in category 'signaling') ----- - signal: signalerText - "Signal the occurrence of an exceptional condition with a specified textual description." - - self messageText: signalerText. - ^ self signal! Item was removed: - ----- Method: Exception>>signalerContext (in category 'handling') ----- - signalerContext - "Find the first sender of signal(:)" - - ^ signalContext findContextSuchThat: [:ctxt | - (ctxt receiver == self or: [ctxt receiver == self class]) not]! Item was removed: - ----- Method: Exception>>tag (in category 'exceptionDescription') ----- - tag - "Return an exception's tag value." - - ^tag == nil - ifTrue: [self messageText] - ifFalse: [tag]! Item was removed: - ----- Method: Exception>>tag: (in category 'exceptionBuilder') ----- - tag: t - "This message is not specified in the ANSI protocol, but that looks like an oversight because #tag is specified, and the spec states that the signaler may store the tag value." - - tag := t! Item was removed: - Object subclass: #ExceptionSet - instanceVariableNames: 'exceptions' - classVariableNames: '' - poolDictionaries: '' - category: 'Kernel-Exceptions'! - - !ExceptionSet commentStamp: '<historical>' prior: 0! - An ExceptionSet is a grouping of exception handlers which acts as a single handler. Within the group, the most recently added handler will be the last handler found during a handler search (in the case where more than one handler in the group is capable of handling a given exception). ! Item was removed: - ----- Method: ExceptionSet>>, (in category 'exceptionSelector') ----- - , anException - "Return an exception set that contains the receiver and the argument exception. This is commonly used to specify a set of exception selectors for an exception handler." - - self add: anException. - ^self! Item was removed: - ----- Method: ExceptionSet>>add: (in category 'private') ----- - add: anException - - ^exceptions add: anException! Item was removed: - ----- Method: ExceptionSet>>handles: (in category 'exceptionSelector') ----- - handles: anException - "Determine whether an exception handler will accept a signaled exception." - - ^exceptions anySatisfy: [:ex | ex handles: anException]! Item was removed: - ----- Method: ExceptionSet>>initialize (in category 'private') ----- - initialize - - exceptions := OrderedCollection new! Item was removed: - SqNumberParser subclass: #ExtendedNumberParser - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Kernel-Numbers'! - - !ExtendedNumberParser commentStamp: 'eem 8/6/2014 10:34' prior: 0! - An ExtendedNumberParser parses numbers, extending Squeak number syntax with these rules - - - allow partial specification of integer and fraction parts: - 1.e2 .1e3 are both 100.0 - - allow plus sign before number and in exponent - - integers raised to exponents, the results of which are fractional, are answered as Fractions, not Floats - ! Item was removed: - ----- Method: ExtendedNumberParser>>allowPlusSign (in category 'accessing') ----- - allowPlusSign - ^true! Item was removed: - ----- Method: ExtendedNumberParser>>exponentLetters (in category 'accessing') ----- - exponentLetters - "Allow uppercase exponent letter." - - ^'edqEDQ'! Item was removed: - ----- Method: ExtendedNumberParser>>makeIntegerOrScaledInteger (in category 'parsing-private') ----- - makeIntegerOrScaledInteger - "at this point, there is no digit, nor fractionPart. - maybe it can be a scaled decimal with fraction omitted..." - - neg - ifTrue: [integerPart := integerPart negated]. - self readExponent - ifTrue: [^integerPart * (base raisedToInteger: exponent)]. - (self readScaleWithDefaultNumberOfDigits: 0) - ifTrue: [^integerPart asScaledDecimal: scale]. - ^ integerPart! Item was removed: - ----- Method: ExtendedNumberParser>>nextFraction (in category 'parsing-public') ----- - nextFraction - | numerator denominator numberOfTrailingZeroInIntegerPart | - base := self defaultBase. - neg := self peekSignIsMinus. - (integerPart := self nextUnsignedIntegerOrNilBase: base) - ifNil: [numberOfTrailingZeroInIntegerPart := 0] - ifNotNil: [ - numberOfTrailingZeroInIntegerPart := nDigits - lastNonZero. - (sourceStream peekFor: $r) - ifTrue: ["<base>r<integer>" - (base := integerPart) < 2 - ifTrue: [ - sourceStream skip: -1. - ^ self expected: 'an integer greater than 1 as valid radix']. - self peekSignIsMinus - ifTrue: [neg := neg not]. - integerPart := self nextUnsignedIntegerBase: base. - numberOfTrailingZeroInIntegerPart := nDigits - lastNonZero]]. - (sourceStream peekFor: $.) - ifTrue: - [^self readFractionPartNumberOfTrailingZeroInIntegerPart: numberOfTrailingZeroInIntegerPart]. - integerPart - ifNil: - ["No integerPart, raise an error" - ^ self expected: 'a digit']. - numerator := neg - ifTrue: [integerPart negated] - ifFalse: [integerPart]. - self readExponent ifTrue: [numerator := numerator * (base raisedToInteger: exponent)]. - (sourceStream peekFor: $/) ifFalse: [^numerator]. - base := 10. - base := self defaultBase. - (denominator := self nextUnsignedIntegerOrNilBase: base) - ifNil: - [sourceStream skip: -1. "Not a valid denominator, ungobble / and return numerator" - ^numerator]. - (sourceStream peekFor: $r) - ifTrue: ["<base>r<integer>" - (base := denominator) < 2 - ifTrue: [ - sourceStream skip: -1. - ^ self expected: 'an integer greater than 1 as valid radix']. - denominator := self nextUnsignedIntegerBase: base]. - self readExponent ifTrue: [denominator := denominator * (base raisedToInteger: exponent)]. - ^numerator / denominator! Item was removed: - ----- Method: ExtendedNumberParser>>nextNumber (in category 'parsing-public') ----- - nextNumber - "main method for reading a number. - This one can read Float Integer and ScaledDecimal" - - | numberOfTrailingZeroInIntegerPart | - base := self defaultBase. - neg := self peekSignIsMinus. - integerPart := self nextUnsignedIntegerOrNilBase: base. - integerPart ifNil: [(sourceStream peekFor: $.) - ifTrue: [ - "Try .1 syntax" - ^self readNumberWithoutIntegerPart] - ifFalse: [ - "This is not a regular number beginning with a digit - It is time to check for exceptional condition NaN and Infinity" - ^self readNamedFloatOrFail]]. - numberOfTrailingZeroInIntegerPart := nDigits - lastNonZero. - (sourceStream peekFor: $r) - ifTrue: ["<base>r<integer>" - | oldNeg pos | - pos := sourceStream position - 1. - (base := integerPart) < 2 - ifTrue: ["A radix currently need to be greater than 1, ungobble the r and return the integer part" - sourceStream skip: -1. - ^neg - ifTrue: [base negated] - ifFalse: [base]]. - oldNeg := neg. - self peekSignIsMinus ifTrue: [neg := neg not]. - integerPart := self nextUnsignedIntegerOrNilBase: base. - integerPart ifNil: [ - (sourceStream peekFor: $.) ifTrue: [self readNumberWithoutIntegerPartOrNil ifNotNil: [:aNumber | ^aNumber]]. - sourceStream position: pos. - ^oldNeg - ifTrue: [base negated] - ifFalse: [base]]. - numberOfTrailingZeroInIntegerPart := nDigits - lastNonZero]. - ^ (sourceStream peekFor: $.) - ifTrue: [self readNumberWithFractionPartNumberOfTrailingZeroInIntegerPart: numberOfTrailingZeroInIntegerPart] - ifFalse: [self makeIntegerOrScaledInteger]! Item was removed: - ----- Method: ExtendedNumberParser>>readFractionPartNumberOfTrailingZeroInIntegerPart: (in category 'parsing-private') ----- - readFractionPartNumberOfTrailingZeroInIntegerPart: numberOfTrailingZeroInIntegerPart - "at this stage, sign integerPart and a fraction point have been read. - try and form a number with a fractionPart" - - | numberOfNonZeroFractionDigits numberOfTrailingZeroInFractionPart mantissa value | - fractionPart := self nextUnsignedIntegerOrNilBase: base. - fractionPart - ifNil: [ - "No fractionPart found, but can be an extended 1.e2 syntax" - integerPart ifNil: ["No integerPart, nor fractionPart found, ungobble the fraction point and raise an error" - sourceStream skip: -1. - ^self expected: 'a digit']. - fractionPart := 0. - numberOfNonZeroFractionDigits := 0. - numberOfTrailingZeroInFractionPart := 0] - ifNotNil: [. - numberOfNonZeroFractionDigits := lastNonZero. - numberOfTrailingZeroInFractionPart := nDigits - lastNonZero]. - self readExponent. - integerPart ifNil: [integerPart := 0]. - - fractionPart isZero - ifTrue: [mantissa := integerPart - // (base raisedToInteger: numberOfTrailingZeroInIntegerPart). - exponent := exponent + numberOfTrailingZeroInIntegerPart] - ifFalse: [mantissa := integerPart - * (base raisedToInteger: numberOfNonZeroFractionDigits) + (fractionPart // (base raisedToInteger: numberOfTrailingZeroInFractionPart)). - exponent := exponent - numberOfNonZeroFractionDigits]. - - value := exponent positive - ifTrue: [mantissa * (base raisedToInteger: exponent)] - ifFalse: [mantissa / (base raisedToInteger: exponent negated)]. - ^ neg - ifTrue: [value negated] - ifFalse: [value]! Item was removed: - ----- Method: ExtendedNumberParser>>readNumberWithFractionPartNumberOfTrailingZeroInIntegerPart: (in category 'parsing-private') ----- - readNumberWithFractionPartNumberOfTrailingZeroInIntegerPart: numberOfTrailingZeroInIntegerPart - "at this stage, sign integerPart and a decimal point have been read. - try and form a number with a fractionPart" - - | numberOfNonZeroFractionDigits numberOfTrailingZeroInFractionPart mantissa value | - fractionPart := self nextUnsignedIntegerOrNilBase: base. - fractionPart - ifNil: - ["No fractionPart found, but can be a 1.e2 syntax" - fractionPart := 0. - nDigits := 0. - numberOfNonZeroFractionDigits := 0. - numberOfTrailingZeroInFractionPart := 0] - ifNotNil: - [numberOfNonZeroFractionDigits := lastNonZero. - numberOfTrailingZeroInFractionPart := nDigits - lastNonZero]. - self readExponent - ifFalse: [(self readScaleWithDefaultNumberOfDigits: nDigits) - ifTrue: [^self - makeScaledDecimalWithNumberOfNonZeroFractionDigits: numberOfNonZeroFractionDigits - andNumberOfTrailingZeroInFractionPart: numberOfTrailingZeroInFractionPart]]. - - fractionPart isZero - ifTrue: - [mantissa := integerPart - // (base raisedToInteger: numberOfTrailingZeroInIntegerPart). - exponent := exponent + numberOfTrailingZeroInIntegerPart] - ifFalse: - [mantissa := integerPart - * (base raisedToInteger: numberOfNonZeroFractionDigits) - + (fractionPart // (base raisedToInteger: numberOfTrailingZeroInFractionPart)). - exponent := exponent - numberOfNonZeroFractionDigits]. - - value := self makeFloatFromMantissa: mantissa exponent: exponent base: base. - ^ neg - ifTrue: [value isZero - ifTrue: [Float negativeZero] - ifFalse: [value negated]] - ifFalse: [value]! Item was removed: - ----- Method: ExtendedNumberParser>>readNumberWithoutIntegerPart (in category 'parsing-private') ----- - readNumberWithoutIntegerPart - "at this stage, sign followed by a decimal point have been read, but no intergerPart - try and form a number with a fractionPart" - - ^self readNumberWithoutIntegerPartOrNil ifNil: [ - "No integer part, no fractionPart, this does not look like a number..." - ^self expected: 'a digit between 0 and 9'].! Item was removed: - ----- Method: ExtendedNumberParser>>readNumberWithoutIntegerPartOrNil (in category 'parsing-private') ----- - readNumberWithoutIntegerPartOrNil - "at this stage, sign followed by a decimal point have been read, but no intergerPart - try and form a number with a fractionPart" - - | numberOfNonZeroFractionDigits numberOfTrailingZeroInFractionPart mantissa value | - integerPart := 0. - fractionPart := self nextUnsignedIntegerOrNilBase: base. - fractionPart ifNil: [ - "No integer part, no fractionPart, this does not look like a number..." - ^nil]. - numberOfNonZeroFractionDigits := lastNonZero. - numberOfTrailingZeroInFractionPart := nDigits - lastNonZero. - self readExponent - ifFalse: [(self readScaleWithDefaultNumberOfDigits: nDigits) - ifTrue: [^self makeScaledDecimalWithNumberOfNonZeroFractionDigits: numberOfNonZeroFractionDigits - andNumberOfTrailingZeroInFractionPart: numberOfTrailingZeroInFractionPart]]. - - fractionPart isZero - ifTrue: [mantissa := 0] - ifFalse: [mantissa := (fractionPart // (base raisedToInteger: numberOfTrailingZeroInFractionPart)). - exponent := exponent - numberOfNonZeroFractionDigits]. - - value := self makeFloatFromMantissa: mantissa exponent: exponent base: base. - ^ neg - ifTrue: [value isZero - ifTrue: [Float negativeZero] - ifFalse: [value negated]] - ifFalse: [value]! Item was removed: - NumberParser subclass: #FORTRANNumberParser - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Kernel-Numbers'! - - !FORTRANNumberParser commentStamp: 'nice 2/13/2010 00:28' prior: 0! - FORTRANNumberParser is able to parse ASCII representation of numbers generated by FORTRAN programs. - - Possible syntax: - digit = '0' | '1' | '2' | '3' | '4' | '5' | '6' | '7' | '8' | '9' ; - sign = '+' | '-'; - integer = [sign] digit{digit} ; - float = [sign] [digit{digit}] ['.'] digit{digit} [('E' | 'D' ) [sign] digit{digit} ] ; - number = integer | float ; - - Examples: - 124 - +124 - -124 - 1.0 - 1. - .23 - 1E+5 - 1.0E-3 - .1E-22 - 3.01D+55 - - Not accepted: exponent letter is sometimes omitted for double precision with 3 digits exponent... - 1.001-123 - - Not accepted: complex numbers into parentheses - (1.0 , 3.11) - ! Item was removed: - ----- Method: FORTRANNumberParser>>allowPlusSign (in category 'accessing') ----- - allowPlusSign - ^true! Item was removed: - ----- Method: FORTRANNumberParser>>exponentLetters (in category 'accessing') ----- - exponentLetters - "answer the list of possible exponents for Numbers. - Note: this parser will not honour precision attached to the exponent. - different exponent do not lead to different precisions. - only IEEE 754 double precision floating point numbers will be created" - - ^'ED'! Item was removed: - ----- Method: FORTRANNumberParser>>nextFloat (in category 'parsing-public') ----- - nextFloat - ^self nextNumber asFloat! Item was removed: - ----- Method: FORTRANNumberParser>>nextNumber (in category 'parsing-public') ----- - nextNumber - "main method for reading a number with FORTRAN syntax. - This one can read Real and Integer (not complex)" - - | numberOfTrailingZeroInIntegerPart numberOfNonZeroFractionDigits mantissa value numberOfTrailingZeroInFractionPart noInt | - base := self defaultBase.. - (self nextMatchAll: 'NaN') ifTrue: [^Float nan]. - neg := self peekSignIsMinus. - (self nextMatchAll: 'Infinity') - ifTrue: [^neg ifTrue: [Float negativeInfinity] ifFalse: [Float infinity]]. - (noInt := sourceStream peekFor: $.) - ifTrue: - [integerPart := 0. - numberOfTrailingZeroInIntegerPart := 0] - ifFalse: - [integerPart := self nextUnsignedIntegerBase: base. - numberOfTrailingZeroInIntegerPart := nDigits - lastNonZero]. - (noInt or: [sourceStream peekFor: $.]) - ifTrue: - [fractionPart := self nextUnsignedIntegerBase: base ifFail: [nil]. - fractionPart isNil - ifTrue: - [noInt - ifTrue: - ["no interger part, no fraction part..." - self expected: 'a digit 0 to 9'. - ^nil]. - fractionPart := 0] - ifFalse: - [numberOfNonZeroFractionDigits := lastNonZero. - numberOfTrailingZeroInFractionPart := nDigits - lastNonZero]. - self readExponent] - ifFalse: - [self readExponent ifFalse: [^neg ifTrue: [integerPart negated] ifFalse: [integerPart]]. - fractionPart := 0]. - fractionPart isZero - ifTrue: - [mantissa := integerPart // (base raisedTo: numberOfTrailingZeroInIntegerPart). - exponent := exponent + numberOfTrailingZeroInIntegerPart] - ifFalse: - [mantissa := integerPart * (base raisedTo: numberOfNonZeroFractionDigits) - + (fractionPart // (base raisedTo: numberOfTrailingZeroInFractionPart)). - exponent := exponent - numberOfNonZeroFractionDigits]. - value := self - makeFloatFromMantissa: mantissa - exponent: exponent - base: base. - ^neg ifTrue: [value isZero ifTrue: [Float negativeZero] ifFalse: [value negated]] ifFalse: [value]! Item was removed: - Boolean subclass: #False - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Kernel-Objects'! - - !False commentStamp: '<historical>' prior: 0! - False defines the behavior of its single instance, false -- logical negation. Notice how the truth-value checks become direct message sends, without the need for explicit testing. - - Be aware however that most of these methods are not sent as real messages in normal use. Most are inline coded by the compiler as test and jump bytecodes - avoiding the overhead of the full message sends. So simply redefining these methods here will have no effect.! Item was removed: - ----- Method: False class>>initializedInstance (in category 'as yet unclassified') ----- - initializedInstance - ^ false! Item was removed: - ----- Method: False>>& (in category 'logical operations') ----- - & aBoolean - "Evaluating conjunction -- answer false since receiver is false, but let the VM quickly check the type of the argument first." - - aBoolean ifFalse: [ ^false ]. - ^false! Item was removed: - ----- Method: False>>==> (in category 'logical operations') ----- - ==> aBlock - ^true! Item was removed: - ----- Method: False>>and: (in category 'controlling') ----- - and: alternativeBlock - "Nonevaluating conjunction -- answer with false since the receiver is false." - - ^self! Item was removed: - ----- Method: False>>asBit (in category 'printing') ----- - asBit - - ^ 0! Item was removed: - ----- Method: False>>ifFalse: (in category 'controlling') ----- - ifFalse: alternativeBlock - "Answer the value of alternativeBlock. Execution does not actually - reach here because the expression is compiled in-line." - - ^alternativeBlock value! Item was removed: - ----- Method: False>>ifFalse:ifTrue: (in category 'controlling') ----- - ifFalse: falseAlternativeBlock ifTrue: trueAlternativeBlock - "Answer the value of falseAlternativeBlock. Execution does not - actually reach here because the expression is compiled in-line." - - ^falseAlternativeBlock value! Item was removed: - ----- Method: False>>ifTrue: (in category 'controlling') ----- - ifTrue: alternativeBlock - "Since the condition is false, answer the value of the false alternative, - which is nil. Execution does not actually reach here because the - expression is compiled in-line." - - ^nil! Item was removed: - ----- Method: False>>ifTrue:ifFalse: (in category 'controlling') ----- - ifTrue: trueAlternativeBlock ifFalse: falseAlternativeBlock - "Answer the value of falseAlternativeBlock. Execution does not - actually reach here because the expression is compiled in-line." - - ^falseAlternativeBlock value! Item was removed: - ----- Method: False>>not (in category 'logical operations') ----- - not - "Negation -- answer true since the receiver is false." - - ^true! Item was removed: - ----- Method: False>>or: (in category 'controlling') ----- - or: alternativeBlock - "Nonevaluating disjunction -- answer value of alternativeBlock." - - ^alternativeBlock value! Item was removed: - ----- Method: False>>printOn: (in category 'printing') ----- - printOn: aStream - - aStream nextPutAll: 'false'! Item was removed: - ----- Method: False>>xor: (in category 'logical operations') ----- - xor: aBoolean - "aBoolean is either a boolean, or an object who's #value returns a boolean (usually a block)." - ^aBoolean value ifTrue: [ true ] ifFalse: [ false ]! Item was removed: - ----- Method: False>>| (in category 'logical operations') ----- - | aBoolean - "Evaluating disjunction (OR) -- could answer aBoolean since receiver is false, but let the VM quickly check the type of the argument instead." - - aBoolean ifTrue: [ ^true ]. - ^false! Item was removed: - Number subclass: #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 removed: - ----- Method: Float class>>basicNew (in category 'instance creation') ----- - basicNew - ^BoxedFloat64 basicNew: 2! Item was removed: - ----- Method: Float class>>basicNew: (in category 'instance creation') ----- - basicNew: anInteger - ^BoxedFloat64 basicNew: 2! Item was removed: - ----- Method: Float class>>denormalized (in category 'constants') ----- - denormalized - "Answer whether implementation supports denormalized numbers (also known as gradual underflow)." - - ^true! Item was removed: - ----- Method: Float class>>e (in category 'constants') ----- - e - "Answer the constant, E." - - ^E! Item was removed: - ----- Method: Float class>>emax (in category 'constants') ----- - emax - "Answer exponent of maximal representable value" - - ^1023! Item was removed: - ----- Method: Float class>>emin (in category 'constants') ----- - emin - "Answer exponent of minimal normalized representable value" - - ^-1022! Item was removed: - ----- Method: Float class>>epsilon (in category 'constants') ----- - epsilon - "Answer difference between 1.0 and previous representable value" - - ^1.0 timesTwoPower: 1 - self precision! Item was removed: - ----- Method: Float class>>fmax (in category 'constants') ----- - fmax - "Answer the maximum finite floating point value representable." - - ^MaxVal! Item was removed: - ----- Method: Float class>>fmin (in category 'constants') ----- - fmin - "Answer minimum positive representable value." - - ^self denormalized - ifTrue: [self fminDenormalized] - ifFalse: [self fminNormalized]! Item was removed: - ----- Method: Float class>>fminDenormalized (in category 'constants') ----- - fminDenormalized - "Answer the minimum denormalized value representable." - - ^1.0 timesTwoPower: MinValLogBase2! Item was removed: - ----- Method: Float class>>fminNormalized (in category 'constants') ----- - fminNormalized - "Answer the minimum normalized value representable." - - ^1.0 timesTwoPower: -1022! Item was removed: - ----- 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." - - | sign mantissa exponent delta | - word <= 0 ifTrue: - [^word negative - ifTrue: [self error: 'Cannot deal with negative numbers'] - ifFalse: [self 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 - ifTrue: - [sign = 0 - ifTrue: [self infinity] - ifFalse: [self negativeInfinity]] - ifFalse: [self nan]]. - - 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. - 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"! Item was removed: - ----- Method: Float class>>fromIEEE64Bit: (in category 'instance creation') ----- - fromIEEE64Bit: anInteger - "Convert the given 64 bit word (which is supposed to be a positive 64-bit value) from - a 64 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." - | value | - value := self basicNew: 2. - value - basicAt: 1 put: (anInteger bitShift: -32); - basicAt: 2 put: (anInteger bitAnd: 16rFFFFFFFF). - ^value * 1.0 "reduce to SmallFloat64 if possible"! Item was removed: - ----- Method: Float class>>halfPi (in category 'constants') ----- - halfPi - ^ Halfpi! Item was removed: - ----- Method: Float class>>infinity (in category 'constants') ----- - infinity - "Answer the value used to represent an infinite magnitude" - - ^ Infinity! Item was removed: - ----- Method: Float class>>initialize (in category 'class initialization') ----- - initialize - "Float initialize" - "Constants from Computer Approximations, pp. 182-183: - Pi = 3.14159265358979323846264338327950288 - Pi/2 = 1.57079632679489661923132169163975144 - Pi*2 = 6.28318530717958647692528676655900576 - Pi/180 = 0.01745329251994329576923690768488612 - 2.0 ln = 0.69314718055994530941723212145817657 - 2.0 sqrt = 1.41421356237309504880168872420969808" - - Pi := 3.14159265358979323846264338327950288. - Halfpi := Pi / 2.0. - Twopi := Pi * 2.0. - ThreePi := Pi * 3.0. - RadiansPerDegree := Pi / 180.0. - - Ln2 := 0.69314718055994530941723212145817657. - Ln10 := 10.0 ln. - Sqrt2 := 1.41421356237309504880168872420969808. - E := 2.718281828459045235360287471353. - - Epsilon := 0.000000000001. "Defines precision of mathematical functions" - - MaxVal := 1.7976931348623157e308. - MaxValLn := 709.782712893384. - MinValLogBase2 := -1074. - - Infinity := MaxVal * MaxVal. - NegativeInfinity := 0.0 - Infinity. - NaN := Infinity - Infinity. - NegativeZero := 1.0 / Infinity negated. - - {Infinity. NegativeInfinity. NaN} do: [:each| each beReadOnlyObject] - ! Item was removed: - ----- Method: Float class>>ln10 (in category 'constants') ----- - ln10 - ^ Ln10! Item was removed: - ----- Method: Float class>>ln2 (in category 'constants') ----- - ln2 - ^ Ln2! Item was removed: - ----- Method: Float class>>maxExactInteger (in category 'constants') ----- - maxExactInteger - "Answer the biggest integer such that it is exactly represented in a float, and all smaller integers also are" - ^1 bitShift: self precision! Item was removed: - ----- Method: Float class>>nan (in category 'constants') ----- - nan - "Answer the canonical value used to represent Not-A-Number" - - ^ NaN! Item was removed: - ----- Method: Float class>>negativeInfinity (in category 'constants') ----- - negativeInfinity - "Answer the value used to represent a negative infinity." - ^ NegativeInfinity! Item was removed: - ----- Method: Float class>>negativeZero (in category 'constants') ----- - negativeZero - - ^ NegativeZero! Item was removed: - ----- Method: Float class>>one (in category 'constants') ----- - one - - ^1.0! Item was removed: - ----- Method: Float class>>pi (in category 'constants') ----- - pi - "Answer the constant, Pi." - - ^Pi! Item was removed: - ----- Method: Float class>>precision (in category 'constants') ----- - precision - "Answer the apparent precision of the floating point representation. - That is the maximum number of radix-based digits (bits if radix=2) representable in floating point without round off error. - Technically, 52 bits are stored in the representation, and normalized numbers have an implied leading 1 that does not need to be stored. - Note that denormalized floating point numbers don't have the implied leading 1, and thus gradually loose precision. - This format conforms IEEE 754 double precision standard." - - ^53! Item was removed: - ----- Method: Float class>>radix (in category 'constants') ----- - radix - "Answer the radix used for internal floating point representation." - - ^2! Item was removed: - ----- Method: Float class>>readFrom: (in category 'instance creation') ----- - readFrom: aStream - "Answer a new Float as described on the stream, aStream." - - ^(super readFrom: aStream) asFloat! Item was removed: - ----- Method: Float class>>readFrom:ifFail: (in category 'instance creation') ----- - readFrom: aStream ifFail: aBlock - "Answer a new Float as described on the stream, aStream." - - ^(super readFrom: aStream ifFail: [^aBlock value]) asFloat! Item was removed: - ----- Method: Float class>>sqrt2 (in category 'constants') ----- - sqrt2 - - ^ Sqrt2! Item was removed: - ----- Method: Float class>>threePi (in category 'constants') ----- - threePi - - ^ ThreePi - ! Item was removed: - ----- Method: Float class>>twoPi (in category 'constants') ----- - twoPi - - ^ Twopi - ! Item was removed: - ----- Method: Float class>>zero (in category 'constants') ----- - zero - ^ 0.0.! Item was removed: - ----- Method: Float>>abs (in category 'arithmetic') ----- - abs - "This is faster than using Number abs and works for negativeZero." - self <= 0.0 - ifTrue: [^ 0.0 - self] - ifFalse: [^ self]! Item was removed: - ----- Method: Float>>absByteEncode:base: (in category 'printing') ----- - absByteEncode: aStream base: base - "Print my value on a stream in the given base. Assumes that my value is strictly - positive; negative numbers, zero, and NaNs have already been handled elsewhere. - Based upon the algorithm outlined in: - Robert G. Burger and R. Kent Dybvig - Printing Floating Point Numbers Quickly and Accurately - ACM SIGPLAN 1996 Conference on Programming Language Design and Implementation - June 1996. - This version performs all calculations with Floats instead of LargeIntegers, and loses - about 3 lsbs of accuracy compared to an exact conversion." - - | significantBits fBase exp baseExpEstimate r s mPlus mMinus scale d tc1 tc2 fixedFormat decPointCount | - self isInfinite ifTrue: [aStream print: 'Infinity'. ^ self]. - significantBits := 50. "approximately 3 lsb's of accuracy loss during conversion" - fBase := base asFloat. - exp := self exponent. - baseExpEstimate := (exp * fBase reciprocalLogBase2 - 1.0e-10) ceiling. - exp >= 0 - ifTrue: - [r := self. - s := 1.0. - mPlus := 1.0 timesTwoPower: exp - significantBits. - mMinus := self significand ~= 1.0 ifTrue: [mPlus] ifFalse: [mPlus / 2.0]] - ifFalse: - [r := self timesTwoPower: significantBits. - s := 1.0 timesTwoPower: significantBits. - mMinus := 1.0 timesTwoPower: (exp max: -1024). - mPlus := - (exp = MinValLogBase2) | (self significand ~= 1.0) - ifTrue: [mMinus] - ifFalse: [mMinus * 2.0]]. - baseExpEstimate >= 0 - ifTrue: - [s := s * (fBase raisedToInteger: baseExpEstimate). - exp = 1023 - ifTrue: "scale down to prevent overflow to Infinity during conversion" - [r := r / fBase. - s := s / fBase. - mPlus := mPlus / fBase. - mMinus := mMinus / fBase]] - ifFalse: - [exp < -1023 - ifTrue: "scale up to prevent denorm reciprocals overflowing to Infinity" - [d := (53 * fBase reciprocalLogBase2 - 1.0e-10) ceiling. - scale := fBase raisedToInteger: d. - r := r * scale. - mPlus := mPlus * scale. - mMinus := mMinus * scale. - scale := fBase raisedToInteger: (baseExpEstimate + d) negated] - ifFalse: - [scale := fBase raisedToInteger: baseExpEstimate negated]. - s := s / scale]. - (r + mPlus >= s) - ifTrue: [baseExpEstimate := baseExpEstimate + 1] - ifFalse: - [s := s / fBase]. - (fixedFormat := baseExpEstimate between: -3 and: 6) - ifTrue: - [decPointCount := baseExpEstimate. - baseExpEstimate <= 0 - ifTrue: [aStream print: ('0.000000' truncateTo: 2 - baseExpEstimate)]] - ifFalse: - [decPointCount := 1]. - [d := (r / s) truncated. - r := r - (d * s). - (tc1 := r <= mMinus) | (tc2 := r + mPlus >= s)] whileFalse: - [aStream print: (Character digitValue: d). - r := r * fBase. - mPlus := mPlus * fBase. - mMinus := mMinus * fBase. - decPointCount := decPointCount - 1. - decPointCount = 0 ifTrue: [aStream print: $.]]. - tc2 ifTrue: - [tc1 not | (tc1 & (r*2.0 >= s)) ifTrue: [d := d + 1]]. - aStream print: (Character digitValue: d). - decPointCount > 0 - ifTrue: - [decPointCount - 1 to: 1 by: -1 do: [:i | aStream print: $0]. - aStream print: '.0']. - fixedFormat ifFalse: - [aStream print: $e. - aStream print: (baseExpEstimate - 1) printString]! Item was removed: - ----- Method: Float>>absPrintExactlyOn:base: (in category 'printing') ----- - absPrintExactlyOn: aStream base: base - "Print my value on a stream in the given base. Assumes that my value is strictly - positive; negative numbers, zero, and NaNs have already been handled elsewhere. - Based upon the algorithm outlined in: - Robert G. Burger and R. Kent Dybvig - Printing Floating Point Numbers Quickly and Accurately - ACM SIGPLAN 1996 Conference on Programming Language Design and Implementation - June 1996. - This version guarantees that the printed representation exactly represents my value - by using exact integer arithmetic." - - | significand exp baseExpEstimate r s mPlus mMinus scale roundingIncludesLimits d tc1 tc2 fixedFormat decPointCount slowbit shead | - self isInfinite ifTrue: [aStream nextPutAll: 'Infinity'. ^ self]. - significand := self significandAsInteger. - roundingIncludesLimits := significand even. - exp := (self exponent - 52) max: MinValLogBase2. - baseExpEstimate := (self exponent * base asFloat reciprocalLogBase2 - 1.0e-10) ceiling. - exp >= 0 - ifTrue: - [significand ~= 16r10000000000000 - ifTrue: - [r := significand bitShift: 1 + exp. - s := 2. - mPlus := mMinus := 1 bitShift: exp] - ifFalse: - [r := significand bitShift: 2 + exp. - s := 4. - mPlus := 2 * (mMinus := 1 bitShift: exp)]] - ifFalse: - [(exp = MinValLogBase2 or: [significand ~= 16r10000000000000]) - ifTrue: - [r := significand bitShift: 1. - s := 1 bitShift: 1 - exp. - mPlus := mMinus := 1] - ifFalse: - [r := significand bitShift: 2. - s := 1 bitShift: 2 - exp. - mPlus := 2. - mMinus := 1]]. - baseExpEstimate >= 0 - ifTrue: [s := s * (base raisedToInteger: baseExpEstimate)] - ifFalse: - [scale := base raisedToInteger: baseExpEstimate negated. - r := r * scale. - mPlus := mPlus * scale. - mMinus := mMinus * scale]. - ((r + mPlus >= s) and: [roundingIncludesLimits or: [r + mPlus > s]]) - ifTrue: [baseExpEstimate := baseExpEstimate + 1] - ifFalse: - [r := r * base. - mPlus := mPlus * base. - mMinus := mMinus * base]. - (fixedFormat := baseExpEstimate between: -3 and: 6) - ifTrue: - [decPointCount := baseExpEstimate. - baseExpEstimate <= 0 - ifTrue: [aStream nextPutAll: ('0.000000' truncateTo: 2 - baseExpEstimate)]] - ifFalse: - [decPointCount := 1]. - slowbit := 1 - s lowBit . - shead := s bitShift: slowbit. - [d := (r bitShift: slowbit) // shead. - r := r - (d * s). - (tc1 := (r <= mMinus) and: [roundingIncludesLimits or: [r < mMinus]]) | - (tc2 := (r + mPlus >= s) and: [roundingIncludesLimits or: [r + mPlus > s]])] whileFalse: - [aStream nextPut: (Character digitValue: d). - r := r * base. - mPlus := mPlus * base. - mMinus := mMinus * base. - (decPointCount := decPointCount - 1) = 0 ifTrue: [aStream nextPut: $.]]. - tc2 ifTrue: - [(tc1 not or: [r * 2 >= s]) ifTrue: [d := d + 1]]. - aStream nextPut: (Character digitValue: d). - decPointCount > 0 - ifTrue: - [decPointCount - 1 to: 1 by: -1 do: [:i | aStream nextPut: $0]. - aStream nextPutAll: '.0']. - fixedFormat - ifFalse: - [aStream nextPut: $e. - aStream nextPutAll: (baseExpEstimate - 1) printString]! Item was removed: - ----- Method: Float>>absPrintExactlyOn:base:decimalPlaces:showTrailingFractionalZeros: (in category 'printing') ----- - absPrintExactlyOn: aStream base: base decimalPlaces: placesDesired showTrailingFractionalZeros: showtrailingZeros - "Print my value on a stream in the given base with fixed number of digits after floating point. - When placesDesired are beyond Float precision, zeroes are appended. - When showtrailingZeros is false, the trailing zeroes after decimal point will be omitted. - If all fractional digits are zeros, the decimal point is omitted too. - Assumes that my value is strictly positive; negative numbers, zero, and NaNs have already been handled elsewhere. - Based upon the algorithm outlined in: - Robert G. Burger and R. Kent Dybvig - Printing Floating Point Numbers Quickly and Accurately - ACM SIGPLAN 1996 Conference on Programming Language Design and Implementation - June 1996.." - - | significand exp baseExpEstimate r s mPlus mMinus scale roundingLowIncludesLimits roundingHighIncludesLimits d tc1 tc2 decPointCount slowbit shead delta | - self isInfinite ifTrue: [aStream nextPutAll: 'Infinity'. ^ self]. - significand := self significandAsInteger. - exp := (self exponent - 52) max: MinValLogBase2. - exp >= 0 - ifTrue: - [significand ~= 16r10000000000000 - ifTrue: - [r := significand bitShift: 1 + exp. - s := 2. - mPlus := mMinus := 1 bitShift: exp] - ifFalse: - [r := significand bitShift: 2 + exp. - s := 4. - mPlus := 2 * (mMinus := 1 bitShift: exp)]] - ifFalse: - [(exp = MinValLogBase2 or: [significand ~= 16r10000000000000]) - ifTrue: - [r := significand bitShift: 1. - s := 1 bitShift: 1 - exp. - mPlus := mMinus := 1] - ifFalse: - [r := significand bitShift: 2. - s := 1 bitShift: 2 - exp. - mPlus := 2. - mMinus := 1]]. - delta := s / 2 / (base raisedTo: placesDesired). - roundingLowIncludesLimits := (mMinus < delta and: [mMinus := delta. true]) or: [significand even]. - roundingHighIncludesLimits := (mPlus < delta and: [mPlus := delta. true]) or: [significand even]. - baseExpEstimate := (self exponent * base asFloat reciprocalLogBase2 - 1.0e-10) ceiling. - baseExpEstimate >= 0 - ifTrue: [s := s * (base raisedToInteger: baseExpEstimate)] - ifFalse: - [scale := base raisedToInteger: baseExpEstimate negated. - r := r * scale. - mPlus := mPlus * scale. - mMinus := mMinus * scale]. - ((r + mPlus >= s) and: [roundingHighIncludesLimits or: [r + mPlus > s]]) - ifTrue: [baseExpEstimate := baseExpEstimate + 1] - ifFalse: - [r := r * base. - mPlus := mPlus * base. - mMinus := mMinus * base]. - decPointCount := baseExpEstimate. - baseExpEstimate <= 0 - ifTrue: - [placesDesired + baseExpEstimate <= 0 - ifTrue: - [aStream nextPut: $0. - (showtrailingZeros and: [placesDesired > 0]) ifTrue: [aStream nextPut: $.; nextPutAll: (String new: placesDesired withAll: $0)]. - ^self]. - aStream nextPutAll: '0.'; nextPutAll: (String new: 0 - baseExpEstimate withAll: $0)]. - slowbit := 1 - s lowBit . - shead := s bitShift: slowbit. - [d := (r bitShift: slowbit) // shead. - r := r - (d * s). - (tc1 := (r <= mMinus) and: [roundingLowIncludesLimits or: [r < mMinus]]) | - (tc2 := (r + mPlus >= s) and: [roundingHighIncludesLimits or: [r + mPlus > s]])] whileFalse: - [aStream nextPut: (Character digitValue: d). - r := r * base. - mPlus := mPlus * base. - mMinus := mMinus * base. - (decPointCount := decPointCount - 1) = 0 ifTrue: [aStream nextPut: $.]]. - tc2 ifTrue: - [(tc1 not or: [r * 2 >= s]) ifTrue: [d := d + 1]]. - aStream nextPut: (Character digitValue: d). - decPointCount > 0 - ifTrue: - [decPointCount - 1 to: 1 by: -1 do: [:i | aStream nextPut: $0]. - (showtrailingZeros and: [placesDesired > 0]) ifTrue: [aStream nextPut: $.; nextPutAll: (String new: placesDesired withAll: $0)]] - ifFalse: - [(showtrailingZeros and: [placesDesired + decPointCount > 1]) ifTrue: [aStream nextPutAll: (String new: placesDesired + decPointCount - 1 withAll: $0)]].! Item was removed: - ----- Method: Float>>absPrintOn:base: (in category 'printing') ----- - absPrintOn: aStream base: base - "Print my value on a stream in the given base. Assumes that my value is strictly - positive; negative numbers, zero, and NaNs have already been handled elsewhere. - Based upon the algorithm outlined in: - Robert G. Burger and R. Kent Dybvig - Printing Floating Point Numbers Quickly and Accurately - ACM SIGPLAN 1996 Conference on Programming Language Design and Implementation - June 1996. - This version performs all calculations with Floats instead of LargeIntegers, and loses - about 3 lsbs of accuracy compared to an exact conversion." - - | significantBits fBase exp baseExpEstimate r s mPlus mMinus scale d tc1 tc2 fixedFormat decPointCount | - self isInfinite ifTrue: [aStream nextPutAll: 'Infinity'. ^ self]. - significantBits := 50. "approximately 3 lsb's of accuracy loss during conversion" - fBase := base asFloat. - exp := self exponent. - baseExpEstimate := (exp * fBase reciprocalLogBase2 - 1.0e-10) ceiling. - exp >= 0 - ifTrue: - [r := self. - s := 1.0. - mPlus := 1.0 timesTwoPower: exp - significantBits. - mMinus := self significand ~= 1.0 ifTrue: [mPlus] ifFalse: [mPlus / 2.0]] - ifFalse: - [r := self timesTwoPower: significantBits. - s := 1.0 timesTwoPower: significantBits. - mMinus := 1.0 timesTwoPower: (exp max: -1024). - mPlus := - (exp = MinValLogBase2) | (self significand ~= 1.0) - ifTrue: [mMinus] - ifFalse: [mMinus * 2.0]]. - baseExpEstimate >= 0 - ifTrue: - [exp = 1023 - ifTrue: "scale down to prevent overflow to Infinity during conversion" - [r := r / fBase. - s := s * (fBase raisedToInteger: baseExpEstimate - 1). - mPlus := mPlus / fBase. - mMinus := mMinus / fBase] - ifFalse: - [s := s * (fBase raisedToInteger: baseExpEstimate)]] - ifFalse: - [exp < -1023 - ifTrue: "scale up to prevent denorm reciprocals overflowing to Infinity" - [d := (53 * fBase reciprocalLogBase2 - 1.0e-10) ceiling. - scale := fBase raisedToInteger: d. - r := r * scale. - mPlus := mPlus * scale. - mMinus := mMinus * scale. - scale := fBase raisedToInteger: (baseExpEstimate + d) negated] - ifFalse: - [scale := fBase raisedToInteger: baseExpEstimate negated]. - s := s / scale]. - (r + mPlus >= s) - ifTrue: [baseExpEstimate := baseExpEstimate + 1] - ifFalse: - [s := s / fBase]. - (fixedFormat := baseExpEstimate between: -3 and: 6) - ifTrue: - [decPointCount := baseExpEstimate. - baseExpEstimate <= 0 - ifTrue: [aStream nextPutAll: ('0.000000' truncateTo: 2 - baseExpEstimate)]] - ifFalse: - [decPointCount := 1]. - [d := (r / s) truncated. - r := r - (d * s). - (tc1 := r <= mMinus) | (tc2 := r + mPlus >= s)] whileFalse: - [aStream nextPut: (Character digitValue: d). - r := r * fBase. - mPlus := mPlus * fBase. - mMinus := mMinus * fBase. - decPointCount := decPointCount - 1. - decPointCount = 0 ifTrue: [aStream nextPut: $.]]. - tc2 ifTrue: - [tc1 not | (tc1 & (r*2.0 >= s)) ifTrue: [d := d + 1]]. - aStream nextPut: (Character digitValue: d). - decPointCount > 0 - ifTrue: - [decPointCount - 1 to: 1 by: -1 do: [:i | aStream nextPut: $0]. - aStream nextPutAll: '.0']. - fixedFormat ifFalse: - [aStream nextPut: $e. - aStream nextPutAll: (baseExpEstimate - 1) printString]! Item was removed: - ----- Method: Float>>absPrintOn:base:digitCount: (in category 'printing') ----- - absPrintOn: aStream base: base digitCount: digitCount - "Print me in the given base, using digitCount significant figures." - - | fuzz x exp q fBase scale logScale xi | - self isInfinite ifTrue: [^ aStream nextPutAll: 'Inf']. - fBase := base asFloat. - "x is myself normalized to [1.0, fBase), exp is my exponent" - exp := self floorLog: fBase. - scale := 1.0. - logScale := 0. - [(x := fBase raisedTo: (exp + logScale)) = 0] - whileTrue: - [scale := scale * fBase. - logScale := logScale + 1]. - x := self * scale / x. - fuzz := fBase raisedTo: 1 - digitCount. - "round the last digit to be printed" - x := 0.5 * fuzz + x. - x >= fBase - ifTrue: - ["check if rounding has unnormalized x" - x := x / fBase. - exp := exp + 1]. - (exp < 6 and: [exp > -4]) - ifTrue: - ["decimal notation" - q := 0. - exp < 0 ifTrue: [1 to: 1 - exp do: [:i | aStream nextPut: ('0.0000' - at: i)]]] - ifFalse: - ["scientific notation" - q := exp. - exp := 0]. - [x >= fuzz] - whileTrue: - ["use fuzz to track significance" - xi := x asInteger. - aStream nextPut: (Character digitValue: xi). - x := x - xi asFloat * fBase. - fuzz := fuzz * fBase. - exp := exp - 1. - exp = -1 ifTrue: [aStream nextPut: $.]]. - [exp >= -1] - whileTrue: - [aStream nextPut: $0. - exp := exp - 1. - exp = -1 ifTrue: [aStream nextPut: $.]]. - q ~= 0 - ifTrue: - [aStream nextPut: $e. - q printOn: aStream]! Item was removed: - ----- Method: Float>>adaptToFraction:andCompare: (in category 'converting') ----- - adaptToFraction: rcvr andCompare: selector - "If I am involved in comparison with a Fraction, convert myself to a - Fraction. This way, no bit is lost and comparison is exact." - - self isFinite ifFalse: [ - selector == #= ifTrue: [ ^false ]. - selector == #~= ifTrue: [ ^true ]. - (selector == #< or: [ selector == #'<=' ]) - ifTrue: [ ^self >= 0.0]. - (selector == #> or: [ selector == #'>=' ]) - ifTrue: [ ^0.0 >= self ]. - ^self error: 'unknow comparison selector' ]. - - "Try to avoid asTrueFraction because it can cost" - rcvr isAnExactFloat ifTrue: [^rcvr asExactFloat perform: selector with: self]. - selector == #= ifTrue: [^false]. - selector == #~= ifTrue: [^true]. - ^ rcvr perform: selector with: self asTrueFraction! Item was removed: - ----- Method: Float>>adaptToFraction:andSend: (in category 'converting') ----- - adaptToFraction: rcvr andSend: selector - "If I am involved in arithmetic with a Fraction, convert it to a Float." - ^ rcvr asFloat perform: selector with: self! Item was removed: - ----- Method: Float>>adaptToInteger:andCompare: (in category 'converting') ----- - adaptToInteger: rcvr andCompare: selector - "If I am involved in comparison with an Integer, convert myself to a - Fraction. This way, no bit is lost and comparison is exact." - - self isFinite ifFalse: [ - selector == #= ifTrue: [ ^false ]. - selector == #~= ifTrue: [ ^true ]. - (selector == #< or: [ selector == #'<=' ]) - ifTrue: [ ^self >= 0.0 ]. - (selector == #> or: [ selector == #'>=' ]) - ifTrue: [ ^0.0 >= self ]. - ^self error: 'unknow comparison selector']. - - "Try to avoid asTrueFraction because it can cost" - selector == #= ifTrue: [ - self fractionPart = 0.0 ifFalse: [^false]]. - selector == #~= ifTrue: [ - self fractionPart = 0.0 ifFalse: [^true]]. - - rcvr isAnExactFloat ifTrue: [^rcvr asExactFloat perform: selector with: self]. - selector == #= ifTrue: [^false]. - selector == #~= ifTrue: [^true]. - ^ rcvr perform: selector with: self asTrueFraction! Item was removed: - ----- Method: Float>>adaptToInteger:andSend: (in category 'converting') ----- - adaptToInteger: rcvr andSend: selector - "If I am involved in arithmetic with an Integer, convert it to a Float." - ^ rcvr asFloat perform: selector with: self! Item was removed: - ----- Method: Float>>adaptToScaledDecimal:andCompare: (in category 'converting') ----- - adaptToScaledDecimal: rcvr andCompare: selector - "If I am involved in comparison with a scaled Decimal, convert myself to a - Fraction. This way, no bit is lost and comparison is exact." - - self isFinite ifFalse: [ - selector == #= ifTrue: [^false]. - selector == #~= ifTrue: [^true]. - (selector == #< or: [ selector == #'<=' ]) - ifTrue: [ ^self >= 0.0 ]. - (selector == #> or: [ selector == #'>=' ]) - ifTrue: [ ^0.0 >= self ]. - ^self error: 'unknow comparison selector' ]. - - "Try to avoid asTrueFraction because it can cost" - rcvr isAnExactFloat ifTrue: [^rcvr asExactFloat perform: selector with: self]. - selector == #= ifTrue: [^false]. - selector == #~= ifTrue: [^true]. - ^ rcvr perform: selector with: self asTrueFraction! Item was removed: - ----- Method: Float>>adaptToScaledDecimal:andSend: (in category 'converting') ----- - adaptToScaledDecimal: receiverScaledDecimal andSend: arithmeticOpSelector - "Convert receiverScaledDecimal to a Float and do the arithmetic. - receiverScaledDecimal arithmeticOpSelector self." - #Numeric. - "add 200/01/19 For ScaledDecimal support." - ^ receiverScaledDecimal asFloat perform: arithmeticOpSelector with: self! Item was removed: - ----- Method: Float>>arCosh (in category 'mathematical functions') ----- - arCosh - "Answer receiver's area hyperbolic cosine. - That is the inverse function of cosh." - - self < 1 - ifTrue: - [^DomainError signal: 'Receiver must be greater or equal to 1']. - ^self + 1 = self - ifTrue: [self abs ln + 2 ln] - ifFalse: [((self squared - 1) sqrt + self) ln]! Item was removed: - ----- Method: Float>>arSinh (in category 'mathematical functions') ----- - arSinh - "Answer receiver's area hyperbolic sine. - That is the inverse function of sinh." - - self = 0.0 ifTrue: [^self]. "Handle negativeZero" - ^self + 1 = self - ifTrue: [(self abs ln + 2 ln) * self sign] - ifFalse: [((self squared + 1) sqrt + self) ln]! Item was removed: - ----- Method: Float>>arTanh (in category 'mathematical functions') ----- - arTanh - "Answer receiver's area hyperbolic tangent. - That is the inverse function of tanh." - - self = 0.0 ifTrue: [^self]. "Handle negativeZero" - self abs = 1 ifTrue: [^self copySignTo: Float infinity]. - self abs > 1 - ifTrue: - [^DomainError signal: 'Receiver must be between -1.0 and 1.0']. - ^((1 + self) / (1 - self)) ln / 2! Item was removed: - ----- Method: Float>>arcCos (in category 'mathematical functions') ----- - arcCos - "Answer the angle in radians." - - ^ Halfpi - self arcSin! Item was removed: - ----- Method: Float>>arcSin (in category 'mathematical functions') ----- - arcSin - "Answer the angle in radians." - - ((self < -1.0) or: [self > 1.0]) ifTrue: [DomainError signal: 'arcSin only takes values between -1 and 1']. - ((self = -1.0) or: [self = 1.0]) - ifTrue: [^ Halfpi * self] - ifFalse: [^ (self / (1.0 - (self * self)) sqrt) arcTan]! Item was removed: - ----- Method: Float>>arcTan: (in category 'mathematical functions') ----- - arcTan: denominator - "Answer the angle in radians, taking care of 4 quadrants. - Implementation note: use signBit and sign: in order to catch cases of negativeZero" - - self = 0.0 - ifTrue: - [denominator signBit = 0 ifTrue: [ ^0.0 ]. - ^Pi sign: self ]. - denominator = 0.0 ifTrue: [ ^Halfpi sign: self ]. - denominator > 0.0 ifTrue: [ ^(self / denominator) arcTan ]. - ^(self / denominator) arcTan + (Pi sign: self)! Item was removed: - ----- Method: Float>>asApproximateFraction (in category 'converting') ----- - asApproximateFraction - "Answer a Fraction approximating the receiver. This conversion uses the - continued fraction method to approximate a floating point number." - - ^ self asApproximateFractionRelativeDecimalPlaces: 10! Item was removed: - ----- Method: Float>>asApproximateFractionAtOrder: (in category 'converting') ----- - asApproximateFractionAtOrder: maxOrder - "Answer a Fraction approximating the receiver. This conversion uses the - continued fraction method to approximate a floating point number. If maxOrder - is zero, use maximum order" - - ^self - asApproximateFractionAtOrder: maxOrder - precision: self ulp / 2! Item was removed: - ----- Method: Float>>asApproximateFractionAtOrder:precision: (in category 'converting') ----- - asApproximateFractionAtOrder: maxOrder precision: limit - "Answer a Rational number--Integer or Fraction--representing the receiver. - This conversion uses the continued fraction method to approximate a floating point number. - The iteration stops when precision has reached the prescribed limit, - or when the maximum number of iterations has been reached. - If maxOrder is zero, then the number of iterations is not limited." - - | num1 denom1 num2 denom2 int frac newD order | - newD := self asFraction. "use exact arithmetic to avoid both overflow and accumulation of rounding errors" - num1 := denom2 := 1. "Initialize alternating numerators" - num2 := denom1 := 0. "and denominators" - order := maxOrder = 0 ifTrue: [-1] ifFalse: [maxOrder]. - [int := newD integerPart. "get the integer part of this" - frac := newD fractionPart. "and save the fractional part for next time" - num1 := num2 + ((num2 := num1) * int). "Update numerators" - denom1 := denom2 + ((denom2 := denom1) * int). "and denominators" - frac = 0 - or: [order = 0 - or: [((Fraction numerator: num1 denominator: denom1) - self) abs <= limit]]] - whileFalse: - [newD := frac reciprocal "Take reciprocal of the fractional part". - order := order - 1]. - ^denom1 = 1 - ifTrue: ["Am i really an Integer?" - num1"Yes, return Integer result"] - ifFalse: ["Otherwise return Fraction result" - Fraction numerator: num1 denominator: denom1]! Item was removed: - ----- Method: Float>>asApproximateFractionRelativeDecimalPlaces: (in category 'converting') ----- - asApproximateFractionRelativeDecimalPlaces: decimalPlaces - "Answer a Fraction approximating the receiver. This conversion uses the - continued fraction method to approximate a floating point number. - Stop the recursion when precision has reached prescribed number of relative decimalPlaces." - - ^ self - asApproximateFractionAtOrder: 0 - precision: (1.0 timesTwoPower: self exponent - (decimalPlaces * Ln10 / Ln2) rounded)! Item was removed: - ----- Method: Float>>asBytesDescription (in category 'printing') ----- - asBytesDescription - ^ self asInteger asBytesDescription! Item was removed: - ----- Method: Float>>asFloat (in category 'converting') ----- - asFloat - "Answer the receiver itself." - - ^self! Item was removed: - ----- Method: Float>>asFraction (in category 'converting') ----- - asFraction - ^ self asTrueFraction ! Item was removed: - ----- Method: Float>>asIEEE32BitWord (in category 'converting') ----- - asIEEE32BitWord - "Convert the receiver into a 32 bit Integer value representing the same number in IEEE 32 bit format. - Used for conversion in FloatArrays." - - | word1 word2 sign mantissa exponent truncatedBits mask roundToUpper | - - "skip fast positive and nnegative zero" - self = 0.0 ifTrue: [^self basicAt: 1]. - - "retrieve 64 bits of IEEE 754 double" - word1 := self basicAt: 1. - word2 := self basicAt: 2. - - "prepare sign exponent and mantissa of 32 bits float" - sign := word1 bitAnd: 16r80000000. - exponent := ((word1 bitShift: -20) bitAnd: 16r7FF) - 1023 + 127. - mantissa := (word2 bitShift: -29) + ((word1 bitAnd: 16rFFFFF) bitShift: 3). - truncatedBits := (word2 bitAnd: 16r1FFFFFFF). - - "We must now honour default IEEE rounding mode (round to nearest even)" - - "we are below gradual underflow, even if rounded to upper mantissa" - exponent < -24 ifTrue: [^sign]. "this can be negative zero" - - "BEWARE: rounding occurs on less than 23bits when gradual underflow" - exponent <= 0 - ifTrue: - [mask := 1 bitShift: exponent negated. - mantissa := mantissa bitOr: 16r800000. - roundToUpper := (mantissa bitAnd: mask) isZero not - and: [truncatedBits isZero not - or: [(mantissa bitAnd: mask - 1) isZero not - or: [(mantissa bitAnd: mask*2) isZero not]]]. - mantissa := mantissa bitShift: exponent - 1. - "exponent := exponent + 1"] - ifFalse: - [roundToUpper := (truncatedBits bitAnd: 16r10000000) isZero not - and: [(mantissa bitAnd: 16r1) isZero not - or: [(truncatedBits bitAnd: 16r0FFFFFFF) isZero not]]]. - - "adjust mantissa and exponent due to IEEE rounding mode" - roundToUpper ifTrue: - [mantissa := mantissa + 1. - mantissa > 16r7FFFFF ifTrue: - [mantissa := 0. - exponent := exponent+1]]. - - exponent > 254 ifTrue: "Overflow" - [exponent := 255. - self isNaN - ifTrue: [mantissa isZero - ifTrue: ["BEWARE: do not convert a NaN to infinity due to truncatedBits" - mantissa := 1]] - ifFalse: [mantissa := 0]]. - - "Encode the word" - ^(sign bitOr: ((exponent max: 0) bitShift: 23)) bitOr: mantissa! Item was removed: - ----- Method: Float>>asIEEE64BitWord (in category 'converting') ----- - asIEEE64BitWord - "Convert the receiver into a 64 bit Integer value representing the same number in IEEE 64 bit format. - Used for conversion in FloatArrays." - - ^((self basicAt: 1) bitShift: 32) + (self basicAt: 2)! Item was removed: - ----- Method: Float>>asTrueFraction (in category 'converting') ----- - asTrueFraction - " Answer a fraction that EXACTLY represents self, - a double precision IEEE floating point number. - Floats are stored in the same form on all platforms. - (Does handle gradual underflow but not NANs.) - By David N. Smith with significant performance - improvements by Luciano Esteban Notarfrancesco. - (Version of 11April97)" - | signexp positive expPart exp fraction fractionPart signedFraction result zeroBitsCount | - self isInfinite ifTrue: [self error: 'Cannot represent infinity as a fraction']. - self isNaN ifTrue: [self error: 'Cannot represent Not-a-Number as a fraction']. - - - " Extract the sign and the biased exponent " - signexp := (self basicAt: 1) bitShift: -20. - positive := (signexp bitAnd: 16r800) = 0. - expPart := signexp bitAnd: 16r7FF. - - " Extract fractional part; answer 0 if this is a true 0.0 value " - fractionPart := (((self basicAt: 1) bitAnd: 16rFFFFF) bitShift: 32)+ (self basicAt: 2). - ( expPart=0 and: [ fractionPart=0 ] ) ifTrue: [ ^ 0 ]. - - " Replace omitted leading 1 in fraction unless gradual underflow" - fraction := expPart = 0 - ifTrue: [fractionPart bitShift: 1] - ifFalse: [fractionPart bitOr: 16r0010000000000000]. - signedFraction := positive ifTrue: [fraction] ifFalse: [fraction negated]. - - "Unbias exponent: 16r3FF is bias; 52 is fraction width" - exp := 16r3FF + 52 - expPart. - - " Form the result. When exp>52, the exponent is adjusted by - the number of trailing zero bits in the fraction to minimize - the (huge) time otherwise spent in #gcd:. " - exp negative - ifTrue: [ - result := signedFraction bitShift: exp negated ] - ifFalse: [ - zeroBitsCount := fraction lowBit - 1. - exp := exp - zeroBitsCount. - exp <= 0 - ifTrue: [ - zeroBitsCount := zeroBitsCount + exp. - "exp := 0." " Not needed; exp not - refernced again " - result := signedFraction bitShift: - zeroBitsCount negated ] - ifFalse: [ - result := Fraction - numerator: (signedFraction - bitShift: zeroBitsCount negated) - denominator: (1 bitShift: - exp) ] ]. - - "Low cost validation omitted after extensive testing" - "(result asFloat = self) ifFalse: [self error: 'asTrueFraction validation failed']." - ^ result ! Item was removed: - ----- Method: Float>>at: (in category 'accessing') ----- - at: index - "Avoid primitive in Object>>at:" - - ^self basicAt: index! Item was removed: - ----- Method: Float>>at:put: (in category 'accessing') ----- - at: index put: value - "Avoid primitive in Object>>at:put:" - - ^self basicAt: index put: value! Item was removed: - ----- Method: Float>>basicAt: (in category 'accessing') ----- - basicAt: index - "Primitive. Assumes receiver is indexable. Answer the value of an - indexable element in the receiver. Fail if the argument index is not an - Integer or is out of bounds. Essential. Do not override in a subclass. See - Object documentation whatIsAPrimitive. - - This version of basicAt: is specifically for floats, answering the most significant - word for index 1 and the least significant word for index 2. This allows the VM - to store floats in whatever order it chooses while it appears to the image that - they are always in big-endian/PowerPC order." - - <primitive: 38 error: ec> - ec ifNil: "primitive not implemented; floats are in big-endian/PowerPC order." - [^super basicAt: index]. - index isInteger ifTrue: [self errorSubscriptBounds: index]. - index isNumber - ifTrue: [^self basicAt: index asInteger] - ifFalse: [self errorNonIntegerIndex]! Item was removed: - ----- Method: Float>>basicAt:put: (in category 'accessing') ----- - basicAt: index put: value - "Primitive. Assumes receiver is indexable. Store the second argument - value in the indexable element of the receiver indicated by index. Fail - if the index is not an Integer or is out of bounds. Or fail if the value is - not of the right type for this kind of collection. Answer the value that - was stored. Essential. Do not override in a subclass. See Object - documentation whatIsAPrimitive. - - This version of basicAt: is specifically for floats, answering the most significant - word for index 1 and the least significant word for index 2. This allows the VM - to store floats in whatever order it chooses while it appears to the image that - they are always in big-endian/PowerPC order." - - <primitive: 39 error: ec> - ec ifNil: "primitive not implemented; floats are in big-endian/PowerPC order." - [^super basicAt: index put: value]. - index isInteger - ifTrue: [(index >= 1 and: [index <= self size]) - ifTrue: [self errorImproperStore] - ifFalse: [self errorSubscriptBounds: index]]. - index isNumber - ifTrue: [^self basicAt: index asInteger put: value] - ifFalse: [self errorNonIntegerIndex]! Item was removed: - ----- Method: Float>>byteEncode:base: (in category 'printing') ----- - byteEncode: aStream base: base - "Handle sign, zero, and NaNs; all other values passed to absPrintOn:base:" - - self isNaN ifTrue: [aStream print: 'NaN'. ^ self]. "check for NaN before sign" - self > 0.0 - ifTrue: [self absByteEncode: aStream base: base] - ifFalse: - [self signBit = 1 - ifTrue: [aStream print: '-']. - self = 0.0 - ifTrue: [aStream print: '0.0'. ^ self] - ifFalse: [aStream writeNumber:self negated base: base]]! Item was removed: - ----- Method: Float>>closeTo: (in category 'comparing') ----- - closeTo: num - "are these two numbers close?" - num isNumber ifFalse: [^[self = num] ifError: [false]]. - self = 0.0 ifTrue: [^num abs < 0.0001]. - num = 0 ifTrue: [^self abs < 0.0001]. - ^self = num asFloat or: [ - | abs | - (abs := self abs) < 0.0001 ifTrue: [^num abs < 0.0001]. - (self - num) abs / (abs max: num abs) < 0.0001]! Item was removed: - ----- Method: Float>>cos (in category 'mathematical functions') ----- - cos - "Answer the cosine of the receiver taken as an angle in radians." - - ^ (self + Halfpi) sin! Item was removed: - ----- Method: Float>>cosh (in category 'mathematical functions') ----- - cosh - "Answer receivers hyperbolic cosine." - - | ex | - ex := self abs exp. - ^(ex + ex reciprocal) / 2! Item was removed: - ----- Method: Float>>deepCopy (in category 'copying') ----- - deepCopy - - ^self copy! Item was removed: - ----- Method: Float>>degreeCos (in category 'mathematical functions') ----- - degreeCos - "Take care of exceptional values" - - self isFinite ifTrue: [^super degreeCos]. - ^self degreesToRadians cos! Item was removed: - ----- Method: Float>>degreeSin (in category 'mathematical functions') ----- - degreeSin - "Take care of exceptional values" - - self isFinite ifTrue: [^super degreeSin]. - ^self degreesToRadians sin! Item was removed: - ----- Method: Float>>degreesToRadians (in category 'converting') ----- - degreesToRadians - "Answer the receiver in radians. Assumes the receiver is in degrees." - - ^self * RadiansPerDegree! Item was removed: - ----- Method: Float>>exponentFromBitPattern (in category 'truncation and round off') ----- - exponentFromBitPattern - "Extract the exponent from the bit pattern. - This is used only when primitive fails" - - | exponent word1 | - self isFinite ifFalse: [^self error: 'cannot take the exponent of non finite Float']. - self = 0.0 ifTrue: [^-1]. - word1 := self basicAt: 1. - exponent := (word1 bitShift: -20) bitAnd: 16r7FF. - ^exponent = 0 - ifTrue: - [| high | - high := (word1 bitAnd: 16rFFFFF) highBit. - high := high = 0 - ifTrue: [(self basicAt: 2) highBit] - ifFalse: [high + 32]. - self class emin - self class precision + high] - ifFalse: - [exponent + self class emin - 1]! Item was removed: - ----- Method: Float>>floorLog: (in category 'mathematical functions') ----- - floorLog: radix - "Answer the floor of the log base radix of the receiver. - The result may be off by one due to rounding errors, except in base 2." - - (radix = 2 and: [self > 0.0 and: [self isFinite]]) ifTrue: [^self exponent]. - ^ (self log: radix) floor - ! Item was removed: - ----- Method: Float>>hasLimitedPrecision (in category 'testing') ----- - hasLimitedPrecision - ^true! Item was removed: - ----- Method: Float>>hash (in category 'comparing') ----- - hash - "Hash is reimplemented because = is implemented. Both words of the float are used. (The bitShift:'s ensure that the intermediate results do not become a large integer.) Care is taken to answer same hash as an equal Integer." - - (self isFinite and: [self fractionPart = 0.0]) ifTrue: [^self truncated hash]. - ^ ((self basicAt: 1) bitShift: -4) + - ((self basicAt: 2) bitShift: -4) - ! Item was removed: - ----- Method: Float>>hex (in category 'printing') ----- - hex "If ya really want to know..." - ^ String streamContents: - [:strm | - | word nibble | - 1 to: 2 do: - [:i | word := self at: i. - 1 to: 8 do: - [:s | nibble := (word bitShift: -8+s*4) bitAnd: 16rF. - strm nextPut: ('0123456789ABCDEF' at: nibble+1)]]] - " - (-2.0 to: 2.0) collect: [:f | f hex] - "! Item was removed: - ----- Method: Float>>integerPart (in category 'truncation and round off') ----- - integerPart - "Answer a Float whose value is the receiver's truncated value." - - ^self - self fractionPart! Item was removed: - ----- Method: Float>>isAnExactFloat (in category 'testing') ----- - isAnExactFloat - ^true! Item was removed: - ----- Method: Float>>isDenormal (in category 'testing') ----- - isDenormal - "Return true if the receiver is a denormal." - - ^ self exponent < self class emin and: [self isZero not]! Item was removed: - ----- Method: Float>>isFinite (in category 'testing') ----- - isFinite - "simple, byte-order independent test for rejecting Not-a-Number and (Negative)Infinity" - - ^(self - self) = 0.0! Item was removed: - ----- Method: Float>>isFloat (in category 'testing') ----- - isFloat - ^ true! Item was removed: - ----- Method: Float>>isInfinite (in category 'testing') ----- - isInfinite - "Return true if the receiver is positive or negative infinity." - - ^ self = Infinity or: [self = NegativeInfinity] - ! Item was removed: - ----- Method: Float>>isLiteral (in category 'testing') ----- - isLiteral - "There is no literal representation of NaN. - However, there are literal representations of Infinity, like 1.0e1000. - But since they are not able to print properly, only case of finite Float is considered." - - ^self isFinite! Item was removed: - ----- Method: Float>>isNaN (in category 'testing') ----- - isNaN - "simple, byte-order independent test for Not-a-Number" - - ^ self ~= self! Item was removed: - ----- Method: Float>>isPowerOfTwo (in category 'testing') ----- - isPowerOfTwo - "Return true if the receiver is an integral power of two." - ^self significand = 1.0! Item was removed: - ----- Method: Float>>isZero (in category 'testing') ----- - isZero - ^self = 0.0! Item was removed: - ----- Method: Float>>literalEqual: (in category 'comparing') ----- - literalEqual: aFloat - "Two float literals can be replaced by a single one only if their representation have the same bits. - For example, zero and negativeZero are equal, but not literally equal." - - ^self class == aFloat class and: [(self at: 1) = (aFloat at: 1) and: [(self at: 2) = (aFloat at: 2)]]! Item was removed: - ----- Method: Float>>log (in category 'mathematical functions') ----- - log - "Answer the base 10 logarithm of the receiver." - - ^ self ln / Ln10! Item was removed: - ----- Method: Float>>log2 (in category 'mathematical functions') ----- - log2 - "Answer the base 2 logarithm of the receiver. - Arrange to answer exact result in case of exact power of 2." - - | s | - s := self significand. - ^s > 1.3333333333333333 - ifTrue: [(0.5 * s) ln / Ln2 + (1 + self exponent)] - ifFalse: [s ln / Ln2 + self exponent]! Item was removed: - ----- Method: Float>>negated (in category 'arithmetic') ----- - negated - "Answer a Number that is the negation of the receiver. - Implementation note: this version cares of negativeZero." - - ^-1.0 * self! Item was removed: - ----- Method: Float>>nthRoot: (in category 'mathematical functions') ----- - nthRoot: aPositiveInteger - "Answer the nth root of the receiver." - aPositiveInteger = 2 ifTrue: [ - ^self sqrt ]. - - (aPositiveInteger isInteger not or: [ aPositiveInteger negative ]) - ifTrue: [^ ArithmeticError signal: 'nth root only defined for positive Integer n.']. - - ^self negative - ifTrue: [ - aPositiveInteger odd - ifTrue: [ (self negated raisedTo: 1.0 / aPositiveInteger) negated ] - ifFalse: [ ArithmeticError signal: 'Negative numbers don''t have even roots.' ]] - ifFalse: [ self raisedTo: 1.0 / aPositiveInteger ]! Item was removed: - ----- Method: Float>>predecessor (in category 'truncation and round off') ----- - predecessor - | ulp | - self isFinite ifFalse: [ - (self isNaN or: [self negative]) ifTrue: [^self]. - ^Float fmax]. - ulp := self ulp. - ^self - (0.5 * ulp) = self - ifTrue: [self - ulp] - ifFalse: [self - (0.5 * ulp)]! Item was removed: - ----- Method: Float>>printAsLiteralOn: (in category 'printing') ----- - printAsLiteralOn: aStream - ^self storeOn: aStream base: 10! Item was removed: - ----- Method: Float>>printOn:base: (in category 'printing') ----- - printOn: aStream base: base - "Print the receiver with the minimal number of digits that describes it unambiguously. - This way, every two different Float will have a different printed representation. - More over, every Float can be reconstructed from its printed representation with #readFrom:." - - self isNaN ifTrue: [aStream nextPutAll: 'NaN'. ^ self]. "check for NaN before sign" - self > 0.0 - ifTrue: [self absPrintExactlyOn: aStream base: base] - ifFalse: - [self signBit = 1 - ifTrue: [aStream nextPutAll: '-']. - self = 0.0 - ifTrue: [aStream nextPutAll: '0.0'] - ifFalse: [self negated absPrintExactlyOn: aStream base: base]]! Item was removed: - ----- Method: Float>>printOn:maxDecimalPlaces: (in category 'printing') ----- - printOn: aStream maxDecimalPlaces: placesDesired - "Refine super implementation in order to avoid any rounding error caused by rounded or roundTo:" - - self isFinite ifFalse: [^self printOn: aStream]. - self > 0.0 - ifTrue: [self absPrintExactlyOn: aStream base: 10 decimalPlaces: placesDesired showTrailingFractionalZeros: false] - ifFalse: - [self signBit = 1 - ifTrue: [aStream nextPutAll: '-']. - self = 0.0 - ifTrue: [aStream nextPutAll: '0.0'] - ifFalse: [self absPrintExactlyOn: aStream base: 10 decimalPlaces: placesDesired showTrailingFractionalZeros: false]]! Item was removed: - ----- Method: Float>>printOn:showingDecimalPlaces: (in category 'printing') ----- - printOn: aStream showingDecimalPlaces: placesDesired - "Refine super implementation in order to avoid any rounding error caused by rounded or roundTo:" - - self isFinite ifFalse: [^self printOn: aStream]. - self > 0.0 - ifTrue: [self absPrintExactlyOn: aStream base: 10 decimalPlaces: placesDesired showTrailingFractionalZeros: true] - ifFalse: - [self signBit = 1 - ifTrue: [aStream nextPutAll: '-']. - self = 0.0 - ifTrue: - [aStream nextPut: $0. - placesDesired > 0 ifTrue: [aStream nextPut: $.; next: placesDesired put: $0]] - ifFalse: [self absPrintExactlyOn: aStream base: 10 decimalPlaces: placesDesired showTrailingFractionalZeros: true]]! Item was removed: - ----- Method: Float>>printPaddedWith:to: (in category 'printing') ----- - printPaddedWith: aCharacter to: aNumber - "Answer the string containing the ASCII representation of the receiver - padded on the left with aCharacter to be at least on aNumber - integerPart characters and padded the right with aCharacter to be at - least anInteger fractionPart characters." - | aStream digits fPadding fLen iPadding iLen curLen periodIndex | - #Numeric. - "2000/03/04 Harmon R. Added Date and Time support" - aStream := WriteStream on: (String new: 10). - self printOn: aStream. - digits := aStream contents. - periodIndex := digits indexOf: $.. - curLen := periodIndex - 1. - iLen := aNumber integerPart. - curLen < iLen - ifTrue: [iPadding := (String new: (iLen - curLen) asInteger) atAllPut: aCharacter; - yourself] - ifFalse: [iPadding := '']. - curLen := digits size - periodIndex. - "n.b. Treat aNumber as a string format specifier rather than as a number, because - floating point truncation can produce incorrect results for the fraction part." - fLen := (aNumber asString copyAfterLast: $. ) - ifNotEmpty: [:s | s asInteger] - ifEmpty: [ 0 ]. - curLen < fLen - ifTrue: [fPadding := (String new: fLen - curLen) atAllPut: aCharacter; - yourself] - ifFalse: [fPadding := '']. - ^ iPadding , digits , fPadding! Item was removed: - ----- Method: Float>>radiansToDegrees (in category 'converting') ----- - radiansToDegrees - "Answer the receiver in degrees. Assumes the receiver is in radians." - - ^self / RadiansPerDegree! Item was removed: - ----- Method: Float>>reciprocal (in category 'arithmetic') ----- - reciprocal - - "Returns the reciprocal. - If self is 0.0 the / signals a ZeroDivide" - - ^1.0 / self! Item was removed: - ----- Method: Float>>reciprocalFloorLog: (in category 'mathematical functions') ----- - reciprocalFloorLog: radix - "Quick computation of (self log: radix) floor, when self < 1.0. - Avoids infinite recursion problems with denormalized numbers" - - | adjust scale n | - adjust := 0. - scale := 1.0. - [(n := radix / (self * scale)) isInfinite] - whileTrue: - [scale := scale * radix. - adjust := adjust + 1]. - ^ ((n floorLog: radix) + adjust) negated! Item was removed: - ----- Method: Float>>reciprocalLogBase2 (in category 'mathematical functions') ----- - reciprocalLogBase2 - "optimized for self = 10, for use in conversion for printing" - - ^ self = 10.0 - ifTrue: [Ln2 / Ln10] - ifFalse: [Ln2 / self ln]! Item was removed: - ----- Method: Float>>reduce (in category 'truncation and round off') ----- - reduce - "If self is close to an integer, return that integer" - - (self closeTo: self rounded) ifTrue: [^ self rounded]! Item was removed: - ----- Method: Float>>rounded (in category 'truncation and round off') ----- - rounded - "Answer the integer nearest the receiver. - Implementation note: super would not handle tricky inexact arithmetic" - - "self assert: 5000000000000001.0 rounded = 5000000000000001" - - self fractionPart abs < 0.5 - ifTrue: [^self truncated] - ifFalse: [^self truncated + self sign]! Item was removed: - ----- Method: Float>>safeArcCos (in category 'mathematical functions') ----- - safeArcCos - "Answer the angle in radians." - (self between: -1.0 and: 1.0) - ifTrue: [^ self arcCos] - ifFalse: [^ self sign arcCos]! Item was removed: - ----- Method: Float>>signBit (in category 'mathematical functions') ----- - signBit - "Answer 1 if the receiver has sign bit set (including case of IEEE-754 negative-zero). - Answer 0 otherwise" - - ^((self at: 1) bitShift: -31)! Item was removed: - ----- Method: Float>>significand (in category 'truncation and round off') ----- - significand - - ^ self timesTwoPower: (self exponent negated)! Item was removed: - ----- Method: Float>>significandAsInteger (in category 'truncation and round off') ----- - significandAsInteger - "Answer the mantissa of a Float shifted so as to have the ulp equal to 1. - For exceptional values, infinity and nan, just answer the bit pattern." - - self isFinite ifTrue: - [^(self timesTwoPower: self class precision - 1 - (self exponent max: self class emin)) truncated abs]. - ^(((self basicAt: 1) bitAnd: 16r000FFFFF) bitShift: 32) bitOr: (self basicAt: 2)! Item was removed: - ----- Method: Float>>sinh (in category 'mathematical functions') ----- - sinh - "Answer receivers hyperbolic sine" - - | ex | - ex := self abs exp. - ^self copySignTo: (ex - ex reciprocal) / 2! Item was removed: - ----- Method: Float>>sqrt (in category 'mathematical functions') ----- - sqrt - "Fallback code for absent primitives. - Care to answer a correctly rounded result as mandated by IEEE-754." - - | guess selfScaled nextGuess exp secator hi lo remainder maxError | - self <= 0.0 - ifTrue: [self = 0.0 - ifTrue: [^ self] - ifFalse: [^ DomainError signal: 'sqrt undefined for number less than zero.']]. - self isFinite ifFalse: [^self]. - - "scale to avoid loss of precision in case of gradual underflow - (selfScaled between: 1.0 and: 2.0), so it is a good guess by itself" - exp := self exponent // 2. - guess := selfScaled := self timesTwoPower: exp * -2. - - "Use Newton-Raphson iteration - it converges quadratically - (twice many correct bits at each loop)" - [nextGuess := selfScaled - (guess * guess) / (2.0 * guess) + guess. - "test if both guess are within 1 ulp" - (nextGuess + guess) / 2.0 = guess] - whileFalse: - ["always round odd upper - this avoids infinite loop with alternate flip of last bit" - guess := nextGuess + (nextGuess ulp/2.0)]. - - "adjust the rounding - the guess can be 2 ulp up or 1 ulp down - Let u = guess ulp. - if (guess+u/2)^2<self, then guess is under-estimated - if (guess-u/2)^2>self, then guess is over-estimated - Note that they can't be equal (because left term has 55 bits). - (guess+u/2)^2=guess^2 + guess*u + u^2/4 < self - ==> self - guess^2 > guess*u - (guess-u/2)^2=guess^2 - guess*u + u^2/4 > self - ==> guess^2 - self >= guess*u - (guess^2 - self) is evaluated with an emulated fused-multiply-add" - - ["Decompose guess in two 26 bits parts hi,lo - the trick is that they do not necessarily have the same sign - If 53 bits are hi,0,lo => (hi,lo) else hi,1,lo=> (hi+1,-lo)" - secator := "1<<27+1" 134217729.0. - hi := guess * secator. - hi :=hi + (guess - hi). - lo := guess - hi. - - "The operations below are all exact" - remainder := selfScaled - hi squared - (hi * lo * 2.0) - lo squared. - maxError := guess timesTwoPower: 1 - Float precision. - remainder > maxError or: [remainder negated >= maxError]] - whileTrue: [guess :=remainder > 0.0 - ifTrue: [guess successor] - ifFalse: [guess predecessor]]. - - "undo the scaling" - ^ guess timesTwoPower: exp! Item was removed: - ----- Method: Float>>storeOn: (in category 'printing') ----- - storeOn: aStream - "Print the Number exactly so it can be interpreted back unchanged" - - self storeOn: aStream base: 10! Item was removed: - ----- Method: Float>>storeOn:base: (in category 'printing') ----- - storeOn: aStream base: base - "Print the Number exactly so it can be interpreted back unchanged" - self isFinite - ifTrue: [self signBit = 1 ifTrue: [aStream nextPutAll: '-']. - base = 10 ifFalse: [aStream print: base; nextPut: $r]. - self = 0.0 - ifTrue: [aStream nextPutAll: '0.0'] - ifFalse: [self abs absPrintExactlyOn: aStream base: base]] - ifFalse: [self isNaN - ifTrue: [aStream nextPutAll: 'Float nan'] - ifFalse: [self > 0.0 - ifTrue: [aStream nextPutAll: 'Float infinity'] - ifFalse: [aStream nextPutAll: 'Float infinity negated']]]! Item was removed: - ----- Method: Float>>successor (in category 'truncation and round off') ----- - successor - | ulp | - self isFinite ifFalse: [ - (self isNaN or: [self positive]) ifTrue: [^self]. - ^Float fmax negated]. - ulp := self ulp. - ^self + (0.5 * ulp) = self - ifTrue: [self * -1.0 - ulp * -1.0 "This trick is for obtaining a negativeZero"] - ifFalse: [self + (0.5 * ulp)]! Item was removed: - ----- Method: Float>>tan (in category 'mathematical functions') ----- - tan - "Answer the tangent of the receiver taken as an angle in radians." - - ^ self sin / self cos! Item was removed: - ----- Method: Float>>tanh (in category 'mathematical functions') ----- - tanh - "Answer hyperbolic tangent of receiver. - Trivial implementation is: - ^self sinh/self cosh - This implementation takes care not to overflow." - - | ex emx | - self = 0.0 ifTrue: [^self]. "Handle negativeZero" - self > 20.0 ifTrue: [^1.0]. - self < -20.0 ifTrue: [^-1.0]. - ex := self exp. - emx := ex reciprocal. - ^(ex - emx) / (ex + emx)! Item was removed: - ----- Method: Float>>timesTwoPower: (in category 'mathematical functions') ----- - timesTwoPower: anInteger - "Answer with the receiver multiplied by 2.0 raised - to the power of the argument" - - self isFinite ifFalse: [^self]. - self isZero ifTrue: [^self]. - - "Make sure that (2.0 raisedTo: Integer) can be safely used without overflow - For example: - Float fminNormalized * (2.0 raisedTo: 2000) = Float infinity. - while: - (Float fminNormalized timesTwoPower: 2000) = (2.0 raisedTo: 2000+Float emin)." - anInteger > Float emax ifTrue: [^(self timesTwoPower: Float emax) timesTwoPower: anInteger - Float emax]. - - "In case of gradual underflow, timesTwoPower: is not exact, so greatest care must be taken - because two consecutive timesTwoPower: might differ from a single one" - anInteger < (Float emin - Float precision + 1) - ifTrue: - [| deltaToUnderflow | - deltaToUnderflow := Float emin - self exponent max: Float emin - Float precision + 1. - deltaToUnderflow >= 0 ifTrue: - ["self is already near or past underflow, so don't care, result will be zero" - deltaToUnderflow := Float emin]. - ^(self timesTwoPower: deltaToUnderflow) timesTwoPower: anInteger - deltaToUnderflow]. - - "If (2.0 raisedToInteger: anInteger) fit in a positive SmallInteger, then use faster SmallInteger conversion. - Note that SmallInteger maxVal highBit = 30 in a 32 bits image, so 1 can be shifted 29 times." - anInteger > -30 ifTrue: [ - 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>>ulp (in category 'truncation and round off') ----- - ulp - "Answer the unit of least precision of self (the power of two corresponding to last bit of mantissa)" - - | exponent | - self isFinite ifFalse: [^self abs]. - self = 0.0 ifTrue: [^Float fmin]. - exponent := self exponent. - ^exponent < self class emin - ifTrue: [Float fminDenormalized] - ifFalse: [Float epsilon timesTwoPower: exponent]! Item was removed: - ----- Method: Float>>veryDeepCopyWith: (in category 'copying') ----- - veryDeepCopyWith: deepCopier - "Return self. Do not record me." - - ^self shallowCopy! Item was removed: - ArithmeticError subclass: #FloatingPointException - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Kernel-Numbers-Exceptions'! Item was removed: - Number subclass: #Fraction - instanceVariableNames: 'numerator denominator' - classVariableNames: '' - poolDictionaries: '' - category: 'Kernel-Numbers'! - - !Fraction commentStamp: 'nice 11/14/2017 20:39' prior: 0! - Fraction provides methods for dealing with fractions like 1/3 as a ratio of two integers (as apposed to a decimal representation 0.33333...). - - instance variables: - numerator <Integer> the number appearing before the fraction bar (above) - denominator <Integer> the number appearing after the fraction bar (below) - - A Fraction is generally created by sending the message / to an Integer, like in - - 1 / 3 - - Alternatively, it is possible to create a new instance of Fraction by sending #numerator:denominator: to the class. - In this later case, it is then user responsibility to ensure that it conforms to the following invariants: - - - the denominator shall allways be positive. - A negative Fraction shall have a negative numerator, never a negative denominator. - Example: 1 / -3 will return -1/3 - - the denominator shall allways be greater than 1. - A Fraction with denominator 1 shall be reduced to its numerator (an Integer). - Example 3 / 1 will answer 3 (the Integer) not 3/1 - - the numerator and denominator shall never have common multiples. - Common multiples shall allways be simplified until (numerator gcd: denominator) = 1. - Example 8 / 6 will answer 4 / 3, because both 8=2*4 and 6=2*3 are both divisible by 2. - - A Fraction non conforming to above invariants could be the cause of undefined behavior and unexpected results. - If unsure, it is advised to send the message #reduced to the freshly created instance so as to obtain a conforming Fraction, or an Integer. - - Note that Fraction and Integer represent together the set of Rational numbers: - - Integer is a subset of rational (those which are whole numbers) - - Fraction is used for representing the complementary subset of rational (those which are not whole numbers) - - There could have been a Rational superclass to both Integer and Fraction, and a message #isRational for testing if a Number is a Rational, as well as a message #asRational for converting a Number to a Rational. - But this level of indirection is not strictly necessary: instead, the notion of Rational and Fraction are collapsed in Squeak, and Integer are considered as a sort of special Fraction with unitary denominator. - Thus #isFraction is the testing message, to which every Integer will also answer true, since considered as a sort of Fraction. - And #asFraction is the conversion message, that may answer an instance of Fraction or Integer, depending if the corresponding rational number is whole or not. - - All public arithmetic operations will answer reduced fractions. - Examples: - - (2/3) + (2/3) - (2/3) + (1/2) "case showing reduction to common denominator" - (2/3) + (4/3) "case where result is reduced to an Integer" - (2/3) raisedToInteger: 5 "fractions also can be exponentiated" - ! Item was removed: - ----- Method: Fraction class>>numerator:denominator: (in category 'instance creation') ----- - numerator: numInteger denominator: denInteger - "Answer an instance of me (numInteger/denInteger). - NOTE: This primitive initialization method will not reduce improper fractions, - so normal usage should be coded as, eg, - (Fraction numerator: a denominator: b) reduced - or, more simply, as - a / b." - - ^self new setNumerator: numInteger denominator: denInteger! Item was removed: - ----- Method: Fraction class>>readFrom: (in category 'instance creation') ----- - readFrom: stringOrStream - "Answer a fraction as described on aStream. - The fraction may be specified as numerator/denominator, or just a numerator, or as integerPart.fractionPart. - In numerator/denominator form, both parts may have a radix specification and an exponent, but only numerator can have a sign. - In fractional digits form, an alternate radix and an exponent can also be provided, the integer or fraction part being optional." - - ^(ExtendedNumberParser on: stringOrStream) nextFraction! Item was removed: - ----- Method: Fraction class>>readFrom:base: (in category 'instance creation') ----- - readFrom: stringOrStream base: aRadix - "Answer a Fraction as described on aStream. - The Fraction may be specified as numerator/denominator, or just with numerator. - Both numerator and denominator can have an exponent, but only numerator can have a sign." - - ^(ExtendedNumberParser on: stringOrStream) nextFractionBase: aRadix! Item was removed: - ----- Method: Fraction>>* (in category 'arithmetic') ----- - * aNumber - "Answer the result of multiplying the receiver by aNumber." - | d1 d2 | - aNumber isFraction ifTrue: - [d1 := numerator gcd: aNumber denominator. - d2 := denominator gcd: aNumber numerator. - (d2 = denominator and: [d1 = aNumber denominator]) - ifTrue: [^ numerator // d1 * (aNumber numerator // d2)]. - ^ Fraction numerator: numerator // d1 * (aNumber numerator // d2) - denominator: denominator // d2 * (aNumber denominator // d1)]. - ^ aNumber adaptToFraction: self andSend: #*! Item was removed: - ----- Method: Fraction>>+ (in category 'arithmetic') ----- - + aNumber - "Answer the sum of the receiver and aNumber." - | n d d1 d2 | - aNumber isInteger ifTrue: - [^Fraction numerator: numerator + (denominator * aNumber) denominator: denominator]. - aNumber isFraction ifTrue: - [d := denominator gcd: aNumber denominator. - n := numerator * (d1 := aNumber denominator // d) + (aNumber numerator * (d2 := denominator // d)). - d1 := d1 * d2. - n := n // (d2 := n gcd: d). - (d := d1 * (d // d2)) = 1 ifTrue: [^ n]. - ^ Fraction numerator: n denominator: d]. - ^ aNumber adaptToFraction: self andSend: #+! Item was removed: - ----- Method: Fraction>>- (in category 'arithmetic') ----- - - aNumber - "Answer the difference between the receiver and aNumber." - aNumber isInteger ifTrue: - [^Fraction numerator: numerator - (denominator * aNumber) denominator: denominator]. - aNumber isFraction ifTrue: - [^ self + aNumber negated]. - ^ aNumber adaptToFraction: self andSend: #-! Item was removed: - ----- Method: Fraction>>/ (in category 'arithmetic') ----- - / aNumber - "Answer the result of dividing the receiver by aNumber." - aNumber isFraction - ifTrue: [^self * aNumber reciprocal]. - ^ aNumber adaptToFraction: self andSend: #/! Item was removed: - ----- Method: Fraction>>< (in category 'comparing') ----- - < aNumber - aNumber isFraction ifTrue: - [^ numerator * aNumber denominator < (aNumber numerator * denominator)]. - ^ aNumber adaptToFraction: self andCompare: #<! Item was removed: - ----- Method: Fraction>><= (in category 'comparing') ----- - <= aNumber - aNumber isFraction ifTrue: - [^ numerator * aNumber denominator <= (aNumber numerator * denominator)]. - ^ aNumber adaptToFraction: self andCompare: #<=! Item was removed: - ----- Method: Fraction>>= (in category 'comparing') ----- - = aNumber - aNumber isNumber ifFalse: [^ false]. - aNumber isInteger ifTrue: ["If properly reduced, self cannot be an Integer" ^ false]. - aNumber isFraction - ifTrue: ["Assume that both Fraction are reduced" - ^ numerator = aNumber numerator and: - [denominator = aNumber denominator]]. - ^ aNumber adaptToFraction: self andCompare: #=! Item was removed: - ----- Method: Fraction>>> (in category 'comparing') ----- - > aNumber - aNumber isFraction ifTrue: - [^ numerator * aNumber denominator > (aNumber numerator * denominator)]. - ^ aNumber adaptToFraction: self andCompare: #>! Item was removed: - ----- Method: Fraction>>>= (in category 'comparing') ----- - >= aNumber - aNumber isFraction ifTrue: - [^ numerator * aNumber denominator >= (aNumber numerator * denominator)]. - ^ aNumber adaptToFraction: self andCompare: #>=! Item was removed: - ----- Method: Fraction>>adaptToInteger:andCompare: (in category 'converting') ----- - adaptToInteger: rcvr andCompare: selector - "Assuming that self is properly reduced, it cannot be an Integer" - selector == #= ifTrue: [^false]. - selector == #~= ifTrue: [^true]. - "Inequality: avoid division with this transformation: - rcvr op: (num/den) - rcvr - (num/den) op: 0 - rcvr*den op: num" - ^rcvr * denominator perform: selector with: numerator! Item was removed: - ----- Method: Fraction>>adaptToInteger:andSend: (in category 'converting') ----- - adaptToInteger: rcvr andSend: selector - "If I am involved in arithmetic with an Integer, convert it to a Fraction." - ^ (Fraction numerator: rcvr denominator: 1) perform: selector with: self! Item was removed: - ----- Method: Fraction>>adaptToScaledDecimal:andSend: (in category 'converting') ----- - adaptToScaledDecimal: receiverScaledDecimal andSend: arithmeticOpSelector - "Convert self to a ScaledDecimal and do the arithmetic. - receiverScaledDecimal arithmeticOpSelector self." - - ^ receiverScaledDecimal perform: arithmeticOpSelector with: (self asScaledDecimal: receiverScaledDecimal scale)! Item was removed: - ----- Method: Fraction>>asExactFloat (in category 'converting') ----- - asExactFloat - "When we know that this Fraction is an exact Float, this conversion is much faster than asFloat." - - ^numerator asFloat timesTwoPower: 1 - denominator highBit! Item was removed: - ----- Method: Fraction>>asFloat (in category 'converting') ----- - asFloat - "Answer a Float that closely approximates the value of the receiver. - This implementation will answer the closest floating point number to the receiver. - In case of a tie, it will use the IEEE 754 round to nearest even mode. - In case of overflow, it will answer +/- Float infinity." - - | a b mantissa exponent hasTruncatedBits lostBit n ha hb hm | - a := numerator abs. - b := denominator. "denominator is always positive" - ha := a highBitOfMagnitude. - hb := b highBitOfMagnitude. - - "Number of bits to keep in mantissa plus one to handle rounding." - n := 1 + Float precision. - - "If both numerator and denominator are represented exactly in floating point number, - then fastest thing to do is to use hardwired float division." - (ha < n and: [hb < n]) ifTrue: [^numerator asFloat / denominator asFloat]. - - "Shift the fraction by a power of two exponent so as to obtain a mantissa with n bits. - First guess is rough, the mantissa might have n+1 bits." - exponent := ha - hb - n. - exponent >= 0 - ifTrue: [b := b bitShift: exponent] - ifFalse: [a := a bitShift: exponent negated]. - mantissa := a quo: b. - hasTruncatedBits := a > (mantissa * b). - hm := mantissa highBit. - - "Check for gradual underflow, in which case the mantissa will loose bits. - Keep at least one bit to let underflow preserve the sign of zero." - lostBit := Float emin - (exponent + hm - 1). - lostBit > 0 ifTrue: [n := n - lostBit max: 1]. - - "Remove excess bits in the mantissa." - hm > n - ifTrue: - [exponent := exponent + hm - n. - hasTruncatedBits := hasTruncatedBits or: [mantissa anyBitOfMagnitudeFrom: 1 to: hm - n]. - mantissa := mantissa bitShift: n - hm]. - - "Check if mantissa must be rounded upward. - The case of tie (mantissa odd & hasTruncatedBits not) - will be handled by Integer>>asFloat." - (hasTruncatedBits and: [mantissa odd]) - ifTrue: [mantissa := mantissa + 1]. - - ^ (self positive - ifTrue: [mantissa asFloat] - ifFalse: [mantissa asFloat negated]) - timesTwoPower: exponent! Item was removed: - ----- Method: Fraction>>asFraction (in category 'converting') ----- - asFraction - "Answer the receiver itself." - - ^self! Item was removed: - ----- Method: Fraction>>asNonFraction (in category 'converting') ----- - asNonFraction - "Answer a number equivalent to the receiver that is not a fraction." - - - ^self asFloat! Item was removed: - ----- Method: Fraction>>asScaledDecimal (in category 'converting') ----- - asScaledDecimal - "Convert the receiver to a ScaledDecimal. - If there is a finite decimal representation of the receiver, then use the exact number of decimal places required. - Else, use a default number of decimals." - - | pow2 pow5 q q5 | - pow2 := denominator lowBit - 1. - q := denominator bitShift: pow2 negated. - pow5 := 0. - [q = 1] - whileFalse: [ - q5 := q // 5. - (q - (5 * q5)) = 0 ifFalse: [^super asScaledDecimal]. - q := q5. - pow5 := pow5 + 1]. - ^self asScaledDecimal: (pow2 max: pow5)! Item was removed: - ----- Method: Fraction>>denominator (in category 'private') ----- - denominator - - ^denominator! Item was removed: - ----- Method: Fraction>>floorLog: (in category 'mathematical functions') ----- - floorLog: radix - "Unlike super, this version is exact when radix is integer" - - | d n | - radix isInteger ifFalse: [^super floorLog: radix]. - n := numerator floorLog: radix. - d := denominator floorLog: radix. - ^(numerator * (radix raisedTo: d)) - < (denominator * (radix raisedTo: n)) - ifTrue: [n - d - 1] - ifFalse: [n - d]! Item was removed: - ----- Method: Fraction>>gcd: (in category 'arithmetic') ----- - gcd: aFraction - | d | - d := denominator gcd: aFraction denominator. - ^(numerator *(aFraction denominator//d) gcd: aFraction numerator*(denominator//d)) / (denominator//d*aFraction denominator)! Item was removed: - ----- Method: Fraction>>hash (in category 'comparing') ----- - hash - "Hash is reimplemented because = is implemented." - - "Care is taken that a Fraction equal to a Float also has an equal hash" - self isAnExactFloat ifTrue: [^self asExactFloat hash]. - - "Else, I cannot be exactly equal to a Float, use own hash algorithm." - ^numerator hash hashMultiply bitXor: denominator hash! Item was removed: - ----- Method: Fraction>>isAnExactFloat (in category 'testing') ----- - isAnExactFloat - "Answer true if this Fraction can be converted exactly to a Float" - ^ denominator isPowerOfTwo - and: ["I have a reasonable significand: not too big" - numerator highBitOfMagnitude <= Float precision - and: ["I have a reasonable exponent: not too small" - Float emin + denominator highBitOfMagnitude <= Float precision]]! Item was removed: - ----- Method: Fraction>>isFraction (in category 'converting') ----- - isFraction - ^ true! Item was removed: - ----- Method: Fraction>>isPowerOfTwo (in category 'testing') ----- - isPowerOfTwo - "Return true if the receiver is an integral power of two." - - ^numerator = 1 and: [ denominator isPowerOfTwo ]! Item was removed: - ----- Method: Fraction>>lcm: (in category 'arithmetic') ----- - lcm: n - "Answer the least common multiple of the receiver and n." - - ^self // (self gcd: n) * n! Item was removed: - ----- Method: Fraction>>ln (in category 'mathematical functions') ----- - ln - "This function is defined because super ln might overflow." - | res | - self <= 0 ifTrue: [DomainError signal: 'ln is only defined for x > 0']. - "Test self < 1 before converting to float in order to avoid precision loss due to gradual underflow." - numerator < denominator ifTrue: [^self reciprocal ln negated]. - res := super ln. - res isFinite ifTrue: [^res]. - ^numerator ln - denominator ln! Item was removed: - ----- Method: Fraction>>log (in category 'mathematical functions') ----- - log - "This function is defined because super log might overflow." - | res | - self <= 0 ifTrue: [DomainError signal: 'log is only defined for x > 0']. - "Test self < 1 before converting to float in order to avoid precision loss due to gradual underflow." - numerator < denominator ifTrue: [^self reciprocal log negated]. - res := super log. - res isFinite ifTrue: [^res]. - ^numerator log - denominator log! Item was removed: - ----- Method: Fraction>>log2 (in category 'mathematical functions') ----- - log2 - "This function is defined because super log2 might overflow." - | res | - self <= 0 ifTrue: [DomainError signal: 'log2 is only defined for x > 0']. - "Test self < 1 before converting to float in order to avoid precision loss due to gradual underflow." - numerator < denominator ifTrue: [^self reciprocal log2 negated]. - res := super log2. - res isFinite ifTrue: [^res]. - ^numerator log2 - denominator log2! Item was removed: - ----- Method: Fraction>>negated (in category 'arithmetic') ----- - negated - "Refer to the comment in Number|negated." - - ^ Fraction - numerator: numerator negated - denominator: denominator! Item was removed: - ----- Method: Fraction>>negative (in category 'testing') ----- - negative - - ^numerator negative! Item was removed: - ----- Method: Fraction>>nthRoot: (in category 'mathematical functions') ----- - nthRoot: aPositiveInteger - "Answer the nth root of the receiver." - - | guess | - guess := (numerator nthRootTruncated: aPositiveInteger) / (denominator nthRootTruncated: aPositiveInteger). - (guess raisedTo: aPositiveInteger) = self ifTrue: [^guess]. - "There is no exact nth root, so answer a Float approximation" - ^(self abs ln / aPositiveInteger) exp * self sign! Item was removed: - ----- Method: Fraction>>numerator (in category 'private') ----- - numerator - - ^numerator! Item was removed: - ----- Method: Fraction>>printOn: (in category 'printing') ----- - printOn: aStream - - aStream nextPut: $(. - numerator printOn: aStream. - aStream nextPut: $/. - denominator printOn: aStream. - aStream nextPut: $). - ! Item was removed: - ----- Method: Fraction>>printOn:base: (in category 'printing') ----- - printOn: aStream base: base - - aStream nextPut: $(. - numerator printOn: aStream base: base. - aStream nextPut: $/. - denominator printOn: aStream base: base. - aStream nextPut: $). - ! Item was removed: - ----- Method: Fraction>>printOn:showingDecimalPlaces: (in category 'printing') ----- - printOn: aStream showingDecimalPlaces: placesDesired - "Same as super, but provides a faster implementation by inlining some Fraction protocol thus avoiding intermediate Fraction creation." - - | roundedFractionPart integerPart scaling | - placesDesired <= 0 - ifTrue: [self rounded printOn: aStream] - ifFalse: - [scaling := 10 raisedToInteger: placesDesired. - integerPart := numerator abs quo: denominator. - roundedFractionPart := (numerator abs - (integerPart * denominator)) * scaling * 2 + denominator quo: denominator * 2. - roundedFractionPart = scaling - ifTrue: - [integerPart := integerPart + 1. - roundedFractionPart := 0]. - "Don't print minus sign if result is rouded to zero" - (numerator negative and: [integerPart > 0 or: [roundedFractionPart > 0]]) ifTrue: [aStream nextPut: $-]. - integerPart printOn: aStream. - aStream nextPut: $.. - roundedFractionPart printOn: aStream base: 10 length: placesDesired padded: true].! Item was removed: - ----- Method: Fraction>>printTruncatedOn:showingDecimalPlaces: (in category 'printing') ----- - printTruncatedOn: aStream showingDecimalPlaces: placesDesired - "Print a representation of the receiver on aStream in decimal notation with prescribed number of places after decimal separator. - Print as if the receiver was truncated to requested precision." - - | truncatedFractionPart integerPart scaling | - placesDesired <= 0 - ifTrue: [self truncated printOn: aStream] - ifFalse: - [scaling := 10 raisedToInteger: placesDesired. - integerPart := numerator abs quo: denominator. - truncatedFractionPart := (numerator abs - (integerPart * denominator)) * scaling quo: denominator. - numerator negative ifTrue: [aStream nextPut: $-]. - integerPart printOn: aStream. - aStream nextPut: $.. - truncatedFractionPart printOn: aStream base: 10 length: placesDesired padded: true].! Item was removed: - ----- Method: Fraction>>raisedToFraction: (in category 'mathematical functions') ----- - raisedToFraction: aFraction - | root | - root := (self numerator nthRootTruncated: aFraction denominator) / (self denominator nthRootTruncated: aFraction denominator). - (root raisedToInteger: aFraction denominator) = self ifTrue: [^root raisedToInteger: aFraction numerator]. - ^super raisedToFraction: aFraction! Item was removed: - ----- Method: Fraction>>raisedToInteger: (in category 'mathematical functions') ----- - raisedToInteger: anInteger - "See Number | raisedToInteger:" - anInteger = 0 ifTrue: [^ 1]. - anInteger < 0 ifTrue: [^ self reciprocal raisedToInteger: anInteger negated]. - ^ Fraction numerator: (numerator raisedToInteger: anInteger) - denominator: (denominator raisedToInteger: anInteger)! Item was removed: - ----- Method: Fraction>>reciprocal (in category 'private') ----- - reciprocal - - numerator abs = 1 ifTrue: [^denominator * numerator]. - ^self class numerator: denominator denominator: numerator! Item was removed: - ----- Method: Fraction>>reduced (in category 'private') ----- - reduced - - | gcd numer denom | - numerator = 0 ifTrue: [^0]. - gcd := numerator gcd: denominator. - numer := numerator // gcd. - denom := denominator // gcd. - denom = 1 ifTrue: [^numer]. - ^Fraction numerator: numer denominator: denom! Item was removed: - ----- Method: Fraction>>setNumerator:denominator: (in category 'private') ----- - setNumerator: n denominator: d - - d isZero ifTrue: [ ^(ZeroDivide dividend: n) signal ]. - numerator := n asInteger. - (denominator := d asInteger) negative ifTrue: [ "keep sign in numerator" - numerator := numerator negated. - denominator := denominator negated ]! Item was removed: - ----- Method: Fraction>>sqrt (in category 'mathematical functions') ----- - sqrt - | d n | - n := numerator sqrt. - d := denominator sqrt. - "The #sqrt method in integer will only answer a Float if there's no exact square root. - So, we need a float anyway." - (n isInfinite or: [ d isInfinite ]) ifTrue: [ - ^self asFloat sqrt ]. - ^n / d! Item was removed: - ----- Method: Fraction>>squared (in category 'mathematical functions') ----- - squared - "See Fraction (Number) | squared" - ^ Fraction numerator: numerator squared denominator: denominator squared! Item was removed: - ----- Method: Fraction>>storeOn:base: (in category 'printing') ----- - storeOn: aStream base: base - - aStream nextPut: $(. - numerator storeOn: aStream base: base. - aStream nextPut: $/. - denominator storeOn: aStream base: base. - aStream nextPut: $). - ! Item was removed: - ----- Method: Fraction>>truncated (in category 'truncation and round off') ----- - truncated - "Refer to the comment in Number|truncated." - - ^numerator quo: denominator! Item was removed: - BlockClosure variableSubclass: #FullBlockClosure - instanceVariableNames: 'receiver' - classVariableNames: '' - poolDictionaries: '' - category: 'Kernel-Methods'! - - !FullBlockClosure commentStamp: 'eem 5/1/2020 10:24' prior: 0! - Instances of FullBlockClosure represent blocks, a sequence of statements inside square brackets that can be evaluated at any time via one of the value messages (value, value:, value:value:, ..., valueWithArguments:), which answer their last statement. Blocks therefore allow deferred evaluation and so are used to build control structures where a sequence of statements are evaluated or not depending on other values in the program. - - FullBlockClosure is a refinement of BlockClosure that allows the block to use its own method to hold its code instead of embedding that code within its home method. - - Instance Variables (inherited) - numArgs <SmallInteger> - outerContext: <Context|nil> - startpcOrMethod <CompiledBlock> - - Instance Variables - receiver: <Object> - - numArgs - - the number of arguments the block expects. This is superfluous; the number of arguments can be obtained from the receiver's compiledBlock. - - outerContext - - the Context of the method or block activation in which the receiver is created. - - compiledBlock(startpcOrMethod) - - reused to refer to the CompiledBlock that implements the receiver's code. - - receiver - - the receiver of the message that created the block's home method activation. - - - Implementation notes: - - A FullBlockClosure is a closure that can be independent of any outerContext if desired. It has its own method (reusing the startpcOrMethod inst var) and its own receiver. outerContext can be either a Context or nil. - - This closure design, implemented by Eliot Miranda and Clement Bera along with the Sista work, aims to simplify the block closure model while enhacing its capabilities. It allows lazy decompilation of closures and fast machine code dispatch in Cog's JIT, while allowing inlining of methods and blocks to be independent from their enclosing blocks. - - At closure creation time, the Sista closure creation bytecode specifies: - - the compiledBlock to execute when executing this block's code (in the literal frame) - - if the receiver is the current receiver or a receiver passed on stack before the copied values. - - if the closure needs an outerContext. outerContexts are used for non local returns and debugging. Blocks with non-local (up arrow) returns have to set their outerContext. For other blocks (97% of blocks), it's a trade-off between performance and debuggability.! Item was removed: - ----- Method: FullBlockClosure class>>initialize (in category 'class initialization') ----- - initialize - "Also see SmalltalkImage >> #recreateSpecialObjectsArray." - - (Smalltalk specialObjectsArray at: 38) - ifNil: [Smalltalk specialObjectsArray at: 38 put: self].! Item was removed: - ----- Method: FullBlockClosure class>>receiver:outerContext:method:copiedValues: (in category 'instance creation') ----- - receiver: aReceiver outerContext: aContextOrNil method: aCompiledBlock copiedValues: anArrayOrNil - ^(self new: anArrayOrNil basicSize) - receiver: aReceiver - outerContext: aContextOrNil - method: aCompiledBlock - copiedValues: anArrayOrNil! Item was removed: - ----- Method: FullBlockClosure>>= (in category 'comparing') ----- - = aClosure - self == aClosure ifTrue: [^true]. - aClosure class == self class ifFalse: [^false]. - ^startpcOrMethod = aClosure method - and: [outerContext = aClosure outerContext or: [self isClean]]! Item was removed: - ----- Method: FullBlockClosure>>abstractBytecodeMessagesDo: (in category 'scanning') ----- - abstractBytecodeMessagesDo: aBlock - ^startpcOrMethod abstractBytecodeMessagesDo: aBlock! Item was removed: - ----- Method: FullBlockClosure>>asContextWithSender: (in category 'private') ----- - asContextWithSender: aContext - "Inner private support method for evaluation. Do not use unless you know what you're doing." - - ^(Context newForMethod: startpcOrMethod) - setSender: aContext - receiver: self receiver - method: startpcOrMethod - closure: self - startpc: startpcOrMethod initialPC; - privRefresh! Item was removed: - ----- Method: FullBlockClosure>>blockCreationPC (in category 'scanning') ----- - blockCreationPC - self shouldNotImplement! Item was removed: - ----- Method: FullBlockClosure>>cull: (in category 'evaluating') ----- - cull: firstArg - "Activate the receiver, with one or zero arguments." - <primitive: 207> "Handle the one argument case primitively" - numArgs >= 1 ifTrue: [ ^self value: firstArg ]. - ^self value! Item was removed: - ----- Method: FullBlockClosure>>cull:cull: (in category 'evaluating') ----- - cull: firstArg cull: secondArg - "Activate the receiver, with two or less arguments." - <primitive: 207> "Handle the two argument case primitively" - numArgs >= 2 ifTrue: [ ^self value: firstArg value: secondArg ]. - numArgs = 1 ifTrue: [ ^self value: firstArg ]. - ^self value! Item was removed: - ----- Method: FullBlockClosure>>cull:cull:cull: (in category 'evaluating') ----- - cull: firstArg cull: secondArg cull: thirdArg - "Activate the receiver, with three or less arguments." - <primitive: 207> "Handle the three argument case primitively" - numArgs >= 2 ifTrue: - [numArgs >= 3 ifTrue: - [^self value: firstArg value: secondArg value: thirdArg]. - ^self value: firstArg value: secondArg]. - numArgs = 1 ifTrue: - [^self value: firstArg]. - ^self value! Item was removed: - ----- Method: FullBlockClosure>>cull:cull:cull:cull: (in category 'evaluating') ----- - cull: firstArg cull: secondArg cull: thirdArg cull: fourthArg - "Activate the receiver, with four or less arguments." - <primitive: 207> "Handle the four argument case primitively" - numArgs >= 3 ifTrue: - [numArgs >= 4 ifTrue: - [^self value: firstArg value: secondArg value: thirdArg value: fourthArg]. - ^self value: firstArg value: secondArg value: thirdArg]. - numArgs = 2 ifTrue: - [^self value: firstArg value: secondArg]. - numArgs = 1 ifTrue: - [^self value: firstArg]. - ^self value! Item was removed: - ----- Method: FullBlockClosure>>cull:cull:cull:cull:cull: (in category 'evaluating') ----- - cull: firstArg cull: secondArg cull: thirdArg cull: fourthArg cull: fifthArg - "Activate the receiver, with five or less arguments." - <primitive: 207> "Handle the five argument case primitively" - - ^ numArgs - caseOf: { - [5] -> [self value: firstArg value: secondArg value: thirdArg value: fourthArg value: fifthArg]. - [4] -> [self value: firstArg value: secondArg value: thirdArg value: fourthArg]. - [3] -> [self value: firstArg value: secondArg value: thirdArg]. - [2] -> [self value: firstArg value: secondArg]. - [1] -> [self value: firstArg]. - [0] -> [self value] } - otherwise: [self numArgsError: numArgs]! Item was removed: - ----- Method: FullBlockClosure>>endPC (in category 'accessing') ----- - endPC - ^startpcOrMethod endPC! Item was removed: - ----- Method: FullBlockClosure>>hasMethodReturn (in category 'scanning') ----- - hasMethodReturn - "Answer whether the receiver has a method-return ('^') in its code." - ^startpcOrMethod hasMethodReturn! Item was removed: - ----- Method: FullBlockClosure>>home (in category 'accessing') ----- - home - ^ outerContext ifNotNil: [ outerContext home ]! Item was removed: - ----- Method: FullBlockClosure>>homeMethod (in category 'accessing') ----- - homeMethod - ^startpcOrMethod homeMethod! Item was removed: - ----- Method: FullBlockClosure>>isFullBlock (in category 'testing') ----- - isFullBlock - ^true! Item was removed: - ----- Method: FullBlockClosure>>method (in category 'accessing') ----- - method - ^startpcOrMethod! Item was removed: - ----- Method: FullBlockClosure>>numArgs: (in category 'accessing') ----- - numArgs: n - numArgs := n! Item was removed: - ----- Method: FullBlockClosure>>numTemps (in category 'accessing') ----- - numTemps - ^startpcOrMethod numTemps! Item was removed: - ----- Method: FullBlockClosure>>outerContext: (in category 'accessing') ----- - outerContext: ctxt - outerContext := ctxt! Item was removed: - ----- Method: FullBlockClosure>>outerContext:startpc:numArgs:copiedValues: (in category 'initialize-release') ----- - outerContext: aContext startpc: aStartpc numArgs: argCount copiedValues: anArrayOrNil - self shouldNotImplement! Item was removed: - ----- Method: FullBlockClosure>>printOn: (in category 'private') ----- - printOn: s - [ super printOn: s ] on: Error do: [ :ex | s << '!![' << ex messageText << ']!!' ]! Item was removed: - ----- Method: FullBlockClosure>>receiver (in category 'accessing') ----- - receiver - ^ receiver! Item was removed: - ----- Method: FullBlockClosure>>receiver: (in category 'accessing') ----- - receiver: anObject - receiver := anObject! Item was removed: - ----- Method: FullBlockClosure>>receiver:outerContext:method:copiedValues: (in category 'initialize-release') ----- - receiver: aReceiver outerContext: aContextOrNil method: aCompiledBlock copiedValues: anArrayOrNil - receiver := aReceiver. - outerContext := aContextOrNil. - startpcOrMethod := aCompiledBlock. - numArgs := aCompiledBlock numArgs. - 1 to: self numCopiedValues do: - [:i| - self at: i put: (anArrayOrNil at: i)]! Item was removed: - ----- Method: FullBlockClosure>>simulateValueWithArguments:caller: (in category 'simulation') ----- - simulateValueWithArguments: anArray caller: aContext - "Simulate the valueWithArguments: primitive. Fail if anArray is not an array of the right arity." - | newContext | - newContext := (Context newForMethod: startpcOrMethod) - setSender: aContext - receiver: receiver - method: startpcOrMethod - closure: self - startpc: startpcOrMethod initialPC. - ((newContext objectClass: anArray) ~~ Array - or: [numArgs ~= anArray size]) ifTrue: - [^Context primitiveFailTokenFor: nil]. - newContext stackp: startpcOrMethod numTemps. - 1 to: numArgs do: - [:i| newContext at: i put: (anArray at: i)]. - 1 to: self basicSize do: - [:i| newContext at: i + numArgs put: (self at: i)]. - ^newContext! Item was removed: - ----- Method: FullBlockClosure>>size (in category 'accessing') ----- - size - "Answer closure's bytecode size (number of bytes) by accessing - the closure's method." - ^startpcOrMethod endPC - startpcOrMethod initialPC + 1! Item was removed: - ----- Method: FullBlockClosure>>startpc (in category 'accessing') ----- - startpc - ^startpcOrMethod initialPC! Item was removed: - ----- Method: FullBlockClosure>>value (in category 'evaluating') ----- - value - "Activate the receiver, creating a closure activation (MethodContext) - whose closure is the receiver and whose caller is the sender of this - message. Supply the copied values to the activation as its copied - temps. Primitive. Essential." - <primitive: 207> - numArgs ~= 0 ifTrue: - [self numArgsError: 0]. - ^self primitiveFailed! Item was removed: - ----- Method: FullBlockClosure>>value: (in category 'evaluating') ----- - value: firstArg - "Activate the receiver, creating a closure activation (MethodContext) - whose closure is the receiver and whose caller is the sender of this - message. Supply the argument and copied values to the activation - as its argument and copied temps. Primitive. Essential." - <primitive: 207> - numArgs ~= 1 ifTrue: - [self numArgsError: 1]. - ^self primitiveFailed! Item was removed: - ----- Method: FullBlockClosure>>value:value: (in category 'evaluating') ----- - value: firstArg value: secondArg - "Activate the receiver, creating a closure activation (MethodContext) - whose closure is the receiver and whose caller is the sender of this - message. Supply the arguments and copied values to the activation - as its arguments and copied temps. Primitive. Essential." - <primitive: 207> - numArgs ~= 2 ifTrue: - [self numArgsError: 2]. - ^self primitiveFailed! Item was removed: - ----- Method: FullBlockClosure>>value:value:value: (in category 'evaluating') ----- - value: firstArg value: secondArg value: thirdArg - "Activate the receiver, creating a closure activation (MethodContext) - whose closure is the receiver and whose caller is the sender of this - message. Supply the arguments and copied values to the activation - as its arguments and copied temps. Primitive. Essential." - <primitive: 207> - numArgs ~= 3 ifTrue: - [self numArgsError: 3]. - ^self primitiveFailed! Item was removed: - ----- Method: FullBlockClosure>>value:value:value:value: (in category 'evaluating') ----- - value: firstArg value: secondArg value: thirdArg value: fourthArg - "Activate the receiver, creating a closure activation (MethodContext) - whose closure is the receiver and whose caller is the sender of this - message. Supply the arguments and copied values to the activation - as its arguments and copied temps. Primitive. Essential." - <primitive: 207> - numArgs ~= 4 ifTrue: - [self numArgsError: 4]. - ^self primitiveFailed! Item was removed: - ----- Method: FullBlockClosure>>value:value:value:value:value: (in category 'evaluating') ----- - value: firstArg value: secondArg value: thirdArg value: fourthArg value: fifthArg - "Activate the receiver, creating a closure activation (MethodContext) - whose closure is the receiver and whose caller is the sender of this - message. Supply the arguments and copied values to the activation - as its arguments and copied temps. Primitive. Essential." - <primitive: 207> - numArgs ~= 5 ifTrue: - [self numArgsError: 5]. - ^self primitiveFailed! Item was removed: - ----- Method: FullBlockClosure>>valueNoContextSwitch (in category 'evaluating') ----- - valueNoContextSwitch - "An exact copy of BlockClosure>>value except that this version will not preempt - the current process on block activation if a higher-priority process is runnable. - Primitive. Essential." - <primitive: 209> - numArgs ~= 0 ifTrue: - [self numArgsError: 0]. - self primitiveFailed! Item was removed: - ----- Method: FullBlockClosure>>valueNoContextSwitch: (in category 'evaluating') ----- - valueNoContextSwitch: anArg - "An exact copy of BlockClosure>>value: except that this version will not preempt - the current process on block activation if a higher-priority process is runnable. - Primitive. Essential." - <primitive: 209> - numArgs ~= 1 ifTrue: - [self numArgsError: 1]. - self primitiveFailed! Item was removed: - ----- Method: FullBlockClosure>>valueWithArguments: (in category 'evaluating') ----- - valueWithArguments: anArray - "Activate the receiver, creating a closure activation (MethodContext) - whose closure is the receiver and whose caller is the sender of this - message. Supply the arguments in an anArray and copied values to - the activation as its arguments and copied temps. Primitive. Essential." - <primitive: 208> - numArgs ~= anArray size ifTrue: - [self numArgsError: anArray size]. - ^self primitiveFailed! Item was removed: - ProtoObject subclass: #FutureMaker - instanceVariableNames: 'myTarget deltaMSecs' - classVariableNames: '' - poolDictionaries: '' - category: 'Kernel-Processes'! - - !FutureMaker commentStamp: 'jcg 12/17/2009 23:24' prior: 0! - Uses #doesNotUnderstand: to transform messages into future messages. In practice, this class is never used; for efficiency, the Compiler has been modified to use FutureNode to transform code at compile-time to directly send #futureSend:at:args:. However, this is simply an optimization... the semantics are unchanged.! Item was removed: - ----- Method: FutureMaker>>= (in category 'comparing') ----- - = anObject - ^self == anObject! Item was removed: - ----- Method: FutureMaker>>basicAt: (in category 'accessing') ----- - basicAt: index - "Primitive. Assumes receiver is indexable. Answer the value of an - indexable element in the receiver. Fail if the argument index is not an - Integer or is out of bounds. Essential. Do not override in a subclass. See - Object documentation whatIsAPrimitive." - - <primitive: 60> - index isInteger ifTrue: [self errorSubscriptBounds: index]. - index isNumber - ifTrue: [^self basicAt: index asInteger] - ifFalse: [self errorNonIntegerIndex]! Item was removed: - ----- Method: FutureMaker>>basicAt:put: (in category 'accessing') ----- - basicAt: index put: value - "Primitive. Assumes receiver is indexable. Store the second argument - value in the indexable element of the receiver indicated by index. Fail - if the index is not an Integer or is out of bounds. Or fail if the value is - not of the right type for this kind of collection. Answer the value that - was stored. Essential. Do not override in a subclass. See Object - documentation whatIsAPrimitive." - - <primitive: 61 error: ec> - index isInteger ifTrue: - [(index >= 1 and: [index <= self basicSize]) - ifTrue: - [ec == #'no modification' ifTrue: - [^thisContext modificationForbiddenFor: self at: index put: value]. - self errorImproperStore] - ifFalse: [self errorSubscriptBounds: index]]. - index isNumber ifTrue: - [^self basicAt: index asInteger put: value]. - self errorNonIntegerIndex! Item was removed: - ----- Method: FutureMaker>>basicSize (in category 'accessing') ----- - basicSize - "Primitive. Answer the number of indexable variables in the receiver. - This value is the same as the largest legal subscript. Essential. Do not - override in any subclass. See Object documentation whatIsAPrimitive." - - <primitive: 62> - "The number of indexable fields of fixed-length objects is 0" - ^0! Item was removed: - ----- Method: FutureMaker>>doesNotUnderstand: (in category 'accessing') ----- - doesNotUnderstand: aMessage - "Package up the message and send it" - ^myTarget futureSend: aMessage selector at: deltaMSecs args: aMessage arguments! Item was removed: - ----- Method: FutureMaker>>hash (in category 'comparing') ----- - hash - ^self scaledIdentityHash! Item was removed: - ----- Method: FutureMaker>>instVarAt: (in category 'accessing') ----- - 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! Item was removed: - ----- Method: FutureMaker>>instVarAt:put: (in category 'accessing') ----- - 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> - ec == #'no modification' ifTrue: - [^thisContext modificationForbiddenFor: self instVarAt: anInteger value: anObject]. - self primitiveFailed! Item was removed: - ----- Method: FutureMaker>>isKindOf: (in category 'accessing') ----- - isKindOf: aClass - "--- needed for debugging ---" - self class == aClass - ifTrue: [^true] - ifFalse: [^self class inheritsFrom: aClass]! Item was removed: - ----- Method: FutureMaker>>isMemberOf: (in category 'accessing') ----- - isMemberOf: aClass - "Answer whether the receiver is an instance of the class, aClass." - ^self class == aClass! Item was removed: - ----- Method: FutureMaker>>isText (in category 'testing') ----- - isText - ^false! Item was removed: - ----- Method: FutureMaker>>printOn: (in category 'printing') ----- - printOn: aStream - "Append to the argument, aStream, a sequence of characters that - identifies the receiver." - | title | - title := self class name. - aStream - nextPutAll: (title first isVowel ifTrue: ['an '] ifFalse: ['a ']); - nextPutAll: title! Item was removed: - ----- Method: FutureMaker>>printString (in category 'printing') ----- - printString - "Answer a String whose characters are a description of the receiver. - If you want to print without a character limit, use fullPrintString." - ^ self printStringLimitedTo: 50000! Item was removed: - ----- Method: FutureMaker>>printStringLimitedTo: (in category 'printing') ----- - printStringLimitedTo: limit - "Answer a String whose characters are a description of the receiver. - If you want to print without a character limit, use fullPrintString." - | limitedString | - limitedString := String streamContents: [:s | self printOn: s] limitedTo: limit. - limitedString size < limit ifTrue: [^ limitedString]. - ^ limitedString , '...etc...'! Item was removed: - ----- Method: FutureMaker>>setDeltaMSecs:target: (in category 'private') ----- - setDeltaMSecs: delta target: futureTarget - deltaMSecs := delta. - myTarget := futureTarget.! Item was removed: - ----- Method: FutureMaker>>setTarget: (in category 'private') ----- - setTarget: aTarget - myTarget := aTarget.! Item was removed: - Exception subclass: #Halt - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Kernel-Exceptions'! - - !Halt commentStamp: '<historical>' prior: 0! - Halt is provided to support Object>>halt.! Item was removed: - ----- Method: Halt>>defaultAction (in category 'priv handling') ----- - defaultAction - "No one has handled this error, but now give them a chance to decide how to debug it. If none handle this either then open debugger (see UnhandedError-defaultAction)" - - UnhandledError signalForException: self! Item was removed: - ----- Method: Halt>>isResumable (in category 'description') ----- - isResumable - - ^true! Item was removed: - Exception subclass: #IllegalResumeAttempt - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Kernel-Exceptions'! - - !IllegalResumeAttempt commentStamp: '<historical>' prior: 0! - This class is private to the EHS implementation. An instance of it is signaled whenever an attempt is made to resume from an exception which answers false to #isResumable.! Item was removed: - ----- Method: IllegalResumeAttempt>>defaultAction (in category 'handling') ----- - defaultAction - "No one has handled this error, but now give them a chance to decide how to debug it. If none handle this either then open debugger (see UnhandedError-defaultAction)" - - UnhandledError signalForException: self! Item was removed: - ----- Method: IllegalResumeAttempt>>isResumable (in category 'handling') ----- - isResumable - - ^ false! Item was removed: - ----- Method: IllegalResumeAttempt>>readMe (in category 'comment') ----- - readMe - - "Never handle this exception!!"! Item was removed: - InstructionClient subclass: #ImplicitLiteralFinder - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Kernel-Methods'! - - !ImplicitLiteralFinder commentStamp: 'eem 9/12/2021 14:44' prior: 0! - ImplicitLiteralFinder is a means to extract special literals from an instruction stream. Instances of InstructionClient answer self in response to all bytecode decode messages. Instances of this class answer the literal itself for implicit literal bytecode messages. - - Instance Variables - ! Item was removed: - ----- Method: ImplicitLiteralFinder>>pushSpecialConstant: (in category 'instruction decoding - implicit literals') ----- - pushSpecialConstant: value - ^value! Item was removed: - ----- Method: ImplicitLiteralFinder>>sendSpecial:numArgs: (in category 'instruction decoding - implicit literals') ----- - sendSpecial: selector numArgs: numArgs - ^selector! Item was removed: - Object subclass: #ImplicitLiteralInstructionClientHook - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Kernel-Methods'! - - !ImplicitLiteralInstructionClientHook commentStamp: 'eem 9/16/2021 19:35' prior: 0! - ImplicitLiteralInstructionClientHook is a hook to allow clients to intercept bytecodes referencing implicit literals, such as special selector sends which have an implicit selector in Smalltalk specialSelectors. It implements the messages sent by InstructionStream's interpretNextXXXInstructionFor: methods for bytecodes that reference implicit literals as sends of the relevant explciit literal methods. This allows clients that want to to intercept implicit literal messages while leaving existing clients unchanged. - - The class also supports CompiledCode>>abstractBytecodeMessagesFrom:to:do: et al which depend on MessageNotUnderstood to collect bytecode messages. Use of instances of this class hides the existence of pushSpecialConstant: and sendSpecial:numArgs: since these are understood, but their sends of pushConstant: and send:super:numArgs: are not. - - Instance Variables! Item was removed: - ----- Method: ImplicitLiteralInstructionClientHook>>pushSpecialConstant: (in category 'instruction decoding - implicit literals') ----- - pushSpecialConstant: value - "This is a hook to allow clients to intercept implicit literal bytecodes" - ^self pushConstant: value! Item was removed: - ----- Method: ImplicitLiteralInstructionClientHook>>sendSpecial:numArgs: (in category 'instruction decoding - implicit literals') ----- - sendSpecial: selector numArgs: numArgs - "This is a hook to allow clients to intercept special selector sends (which have an implicit selector)" - ^self send: selector super: false numArgs: numArgs! Item was removed: - Notification subclass: #InMidstOfFileinNotification - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Kernel-Exceptions'! Item was removed: - ----- Method: InMidstOfFileinNotification>>defaultAction (in category 'handling') ----- - defaultAction - - ^false! Item was removed: - InstructionClient subclass: #InstVarRefLocator - instanceVariableNames: 'bingo' - classVariableNames: '' - poolDictionaries: '' - category: 'Kernel-Methods'! - - !InstVarRefLocator commentStamp: 'eem 3/30/2017 17:43' prior: 0! - My job is to scan bytecodes for instance variable references. - - BlockClosure allInstances collect: [ :x | - {x. x method hasInstVarRef} - ]! Item was removed: - ----- Method: InstVarRefLocator>>interpretNextInstructionUsing: (in category 'initialize-release') ----- - interpretNextInstructionUsing: aScanner - - bingo := false. - aScanner interpretNextInstructionFor: self. - ^bingo! Item was removed: - ----- Method: InstVarRefLocator>>popIntoReceiverVariable: (in category 'instruction decoding') ----- - popIntoReceiverVariable: offset - - bingo := true! Item was removed: - ----- Method: InstVarRefLocator>>pushReceiverVariable: (in category 'instruction decoding') ----- - pushReceiverVariable: offset - - bingo := true! Item was removed: - ----- Method: InstVarRefLocator>>storeIntoReceiverVariable: (in category 'instruction decoding') ----- - storeIntoReceiverVariable: offset - - bingo := true! Item was removed: - ImplicitLiteralInstructionClientHook subclass: #InstructionClient - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Kernel-Methods'! - - !InstructionClient commentStamp: 'md 4/8/2003 12:50' prior: 0! - My job is to make it easier to implement clients for InstructionStream. See InstVarRefLocator - as an example. ! Item was removed: - ----- Method: InstructionClient>>blockReturnConstant: (in category 'instruction decoding') ----- - blockReturnConstant: value - "Return Constant From Block bytecode." - - ! Item was removed: - ----- Method: InstructionClient>>blockReturnTop (in category 'instruction decoding') ----- - blockReturnTop - "Return Top Of Stack bytecode." - - ! Item was removed: - ----- Method: InstructionClient>>callPrimitive: (in category 'instruction decoding') ----- - callPrimitive: pimIndex - "SqueakV3PlusClosures: 239 11101111 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 removed: - ----- Method: InstructionClient>>directedSuperSend:numArgs: (in category 'instruction decoding') ----- - directedSuperSend: selector numArgs: numArgs - "Send Message Above Specific Class With Selector, selector, bytecode. - Start the lookup above the class that is the value of the association on - top of stack. The arguments of the message are found in the top numArgs - stack locations beneath the association, and the receiver just below them."! Item was removed: - ----- Method: InstructionClient>>doDup (in category 'instruction decoding') ----- - doDup - "Duplicate Top Of Stack bytecode." - - ! Item was removed: - ----- Method: InstructionClient>>doPop (in category 'instruction decoding') ----- - doPop - "Remove Top Of Stack bytecode." - ! Item was removed: - ----- Method: InstructionClient>>jump: (in category 'instruction decoding') ----- - jump: offset - "Unconditional Jump bytecode." - - ! Item was removed: - ----- Method: InstructionClient>>jump:if: (in category 'instruction decoding') ----- - jump: offset if: condition - "Conditional Jump bytecode." - - ! Item was removed: - ----- Method: InstructionClient>>methodReturnConstant: (in category 'instruction decoding') ----- - methodReturnConstant: value - "Return Constant bytecode." - ! Item was removed: - ----- Method: InstructionClient>>methodReturnReceiver (in category 'instruction decoding') ----- - methodReturnReceiver - "Return Self bytecode." - ! Item was removed: - ----- Method: InstructionClient>>methodReturnTop (in category 'instruction decoding') ----- - methodReturnTop - "Return Top Of Stack bytecode." - ! Item was removed: - ----- Method: InstructionClient>>popIntoLiteralVariable: (in category 'instruction decoding') ----- - popIntoLiteralVariable: anAssociation - "Remove Top Of Stack And Store Into Literal Variable bytecode." - ! Item was removed: - ----- Method: InstructionClient>>popIntoReceiverVariable: (in category 'instruction decoding') ----- - popIntoReceiverVariable: offset - "Remove Top Of Stack And Store Into Instance Variable bytecode." - ! Item was removed: - ----- Method: InstructionClient>>popIntoRemoteTemp:inVectorAt: (in category 'instruction decoding') ----- - popIntoRemoteTemp: remoteTempIndex inVectorAt: tempVectorIndex - "Remove Top Of Stack And Store Into Offset of Temp Vector bytecode."! Item was removed: - ----- Method: InstructionClient>>popIntoTemporaryVariable: (in category 'instruction decoding') ----- - popIntoTemporaryVariable: offset - "Remove Top Of Stack And Store Into Temporary Variable bytecode." - ! Item was removed: - ----- Method: InstructionClient>>pushActiveContext (in category 'instruction decoding') ----- - pushActiveContext - "Push Active Context On Top Of Its Own Stack bytecode." - ! Item was removed: - ----- Method: InstructionClient>>pushClosureCopyNumCopiedValues:numArgs:blockSize: (in category 'instruction decoding') ----- - pushClosureCopyNumCopiedValues: numCopied numArgs: numArgs blockSize: blockSize - "Push Closure bytecode." - ! Item was removed: - ----- Method: InstructionClient>>pushConsArrayWithElements: (in category 'instruction decoding') ----- - pushConsArrayWithElements: numElements - "Push Cons Array of size numElements popping numElements items from the stack into the array bytecode." - ! Item was removed: - ----- Method: InstructionClient>>pushConstant: (in category 'instruction decoding') ----- - pushConstant: value - "Push Constant, value, on Top Of Stack bytecode." - ! Item was removed: - ----- Method: InstructionClient>>pushFullClosure:numCopied: (in category 'instruction decoding') ----- - pushFullClosure: aCompiledBlock numCopied: numCopied - "Push Full Closure bytecode."! Item was removed: - ----- Method: InstructionClient>>pushLiteralVariable: (in category 'instruction decoding') ----- - pushLiteralVariable: anAssociation - "Push Contents Of anAssociation On Top Of Stack bytecode." - ! Item was removed: - ----- Method: InstructionClient>>pushNewArrayOfSize: (in category 'instruction decoding') ----- - pushNewArrayOfSize: numElements - "Push New Array of size numElements bytecode." - ! Item was removed: - ----- Method: InstructionClient>>pushReceiver (in category 'instruction decoding') ----- - pushReceiver - "Push Active Context's Receiver on Top Of Stack bytecode." - ! Item was removed: - ----- Method: InstructionClient>>pushReceiverVariable: (in category 'instruction decoding') ----- - pushReceiverVariable: offset - "Push Contents Of the Receiver's Instance Variable Whose Index - is the argument, offset, On Top Of Stack bytecode." - ! Item was removed: - ----- Method: InstructionClient>>pushRemoteTemp:inVectorAt: (in category 'instruction decoding') ----- - pushRemoteTemp: remoteTempIndex inVectorAt: tempVectorIndex - "Push Contents at Offset in Temp Vector bytecode."! Item was removed: - ----- Method: InstructionClient>>pushTemporaryVariable: (in category 'instruction decoding') ----- - pushTemporaryVariable: offset - "Push Contents Of Temporary Variable Whose Index Is the - argument, offset, On Top Of Stack bytecode." - ! Item was removed: - ----- Method: InstructionClient>>send:super:numArgs: (in category 'instruction decoding') ----- - send: selector super: supered numArgs: numberArguments - "Send Message With Selector, selector, bytecode. The argument, - supered, indicates whether the receiver of the message is specified with - 'super' in the source method. The arguments of the message are found in - the top numArguments locations on the stack and the receiver just - below them." - ! Item was removed: - ----- Method: InstructionClient>>storeIntoLiteralVariable: (in category 'instruction decoding') ----- - storeIntoLiteralVariable: anAssociation - "Store Top Of Stack Into Literal Variable Of Method bytecode." - ! Item was removed: - ----- Method: InstructionClient>>storeIntoReceiverVariable: (in category 'instruction decoding') ----- - storeIntoReceiverVariable: offset - "Store Top Of Stack Into Instance Variable Of Method bytecode." - ! Item was removed: - ----- Method: InstructionClient>>storeIntoRemoteTemp:inVectorAt: (in category 'instruction decoding') ----- - storeIntoRemoteTemp: remoteTempIndex inVectorAt: tempVectorIndex - "Store Top Of Stack And Store Into Offset of Temp Vector bytecode."! Item was removed: - ----- Method: InstructionClient>>storeIntoTemporaryVariable: (in category 'instruction decoding') ----- - storeIntoTemporaryVariable: offset - "Store Top Of Stack Into Temporary Variable Of Method bytecode." - ! Item was removed: - ----- Method: InstructionClient>>trapIfNotInstanceOf: (in category 'instruction decoding') ----- - trapIfNotInstanceOf: behaviorOrArrayOfBehavior - "If the top of stack is not an instance of either the argument, or, if the argument is an Array, - any of the elements of the argument, send the class trap message to the current context."! Item was removed: - InstructionClient subclass: #InstructionPrinter - instanceVariableNames: 'method scanner stream oldPC innerIndents indent printPC indentSpanOfFollowingJump fullBlockRecursionSelector' - classVariableNames: '' - poolDictionaries: '' - category: 'Kernel-Methods'! - - !InstructionPrinter commentStamp: 'md 4/8/2003 12:47' prior: 0! - My instances can print the object code of a CompiledMethod in symbolic format. They print into an instance variable, stream, and uses oldPC to determine how many bytes to print in the listing. The variable method is used to hold the method being printed.! Item was removed: - ----- Method: InstructionPrinter class>>on: (in category 'printing') ----- - on: aMethod - ^self new method: aMethod. - ! Item was removed: - ----- Method: InstructionPrinter class>>printClass: (in category 'printing') ----- - printClass: class - "Create a file whose name is the argument followed by '.bytes'. Store on - the file the symbolic form of the compiled methods of the class." - | file | - file := FileStream newFileNamed: class name , '.bytes'. - class selectorsAndMethodsDo: - [:sel :m | - file cr; nextPutAll: sel; cr. - (self on: m) printInstructionsOn: file]. - file close - "InstructionPrinter printClass: Parser." - ! Item was removed: - ----- Method: InstructionPrinter>>blockReturnConstant: (in category 'instruction decoding') ----- - blockReturnConstant: value - "Print the Return Constant From Block bytecode." - - self print: 'blockReturn: ', value printString! Item was removed: - ----- Method: InstructionPrinter>>blockReturnTop (in category 'instruction decoding') ----- - blockReturnTop - "Print the Return Top Of Stack bytecode." - - self print: 'blockReturn'! Item was removed: - ----- Method: InstructionPrinter>>callPrimitive: (in category 'instruction decoding') ----- - callPrimitive: index - "Print the callPrimitive bytecode. This is the m = 0 case in SistaV1: ** 248, and V3/Spur 139 below. - - SistaV1: ** 248 (2) 11111000 iiiiiiii mssjjjjj Call Primitive #iiiiiiii + (jjjjj * 256) - m=1 means inlined primitive, no hard return after execution. - ss defines the unsafe operation set used to encode the operations. - (ss = 0 means sista unsafe operations, ss = 01 means lowcode operations, other numbers are as yet used) - V3/Spur: 139 10001011 i i i i i i i i jjjjjjjj Call Primitive #iiiiiiii + (jjjjjjjj * 256)" - - self print: 'callPrimitive: ' , index printString! Item was removed: - ----- Method: InstructionPrinter>>directedSuperSend:numArgs: (in category 'instruction decoding') ----- - directedSuperSend: selector "<Symbol>" numArgs: numArgs "<SmallInteger>" - self print: 'directedSuperSend: ' , (self stringForSelector: selector numArgs: numArgs)! Item was removed: - ----- Method: InstructionPrinter>>doDup (in category 'instruction decoding') ----- - doDup - "Print the Duplicate Top Of Stack bytecode." - - self print: 'dup'! Item was removed: - ----- Method: InstructionPrinter>>doPop (in category 'instruction decoding') ----- - doPop - "Print the Remove Top Of Stack bytecode." - - self print: 'pop'! Item was removed: - ----- Method: InstructionPrinter>>indent (in category 'accessing') ----- - indent - - ^ indent ifNil: [0]! Item was removed: - ----- Method: InstructionPrinter>>indent: (in category 'initialize-release') ----- - indent: numTabs - - indent := numTabs! Item was removed: - ----- Method: InstructionPrinter>>jump: (in category 'instruction decoding') ----- - jump: offset - "Print the Unconditional Jump bytecode." - - self print: 'jumpTo: ' , (scanner pc + offset) printString. - indentSpanOfFollowingJump ifTrue: - [indentSpanOfFollowingJump := false. - innerIndents atAll: (scanner pc to: scanner pc + offset - 1) put: (innerIndents at: scanner pc - 1) + 1]! Item was removed: - ----- Method: InstructionPrinter>>jump:if: (in category 'instruction decoding') ----- - jump: offset if: condition - "Print the Conditional Jump bytecode." - - self print: - (condition - ifTrue: ['jumpTrue: '] - ifFalse: ['jumpFalse: ']) - , (scanner pc + offset) printString! Item was removed: - ----- Method: InstructionPrinter>>method (in category 'accessing') ----- - method - ^method.! Item was removed: - ----- Method: InstructionPrinter>>method: (in category 'accessing') ----- - method: aMethod - method := aMethod. - printPC := true. - indentSpanOfFollowingJump := false! Item was removed: - ----- Method: InstructionPrinter>>methodReturnConstant: (in category 'instruction decoding') ----- - methodReturnConstant: value - "Print the Return Constant bytecode." - - self print: 'return: ' , value printString! Item was removed: - ----- Method: InstructionPrinter>>methodReturnReceiver (in category 'instruction decoding') ----- - methodReturnReceiver - "Print the Return Self bytecode." - - self print: 'returnSelf'! Item was removed: - ----- Method: InstructionPrinter>>methodReturnTop (in category 'instruction decoding') ----- - methodReturnTop - "Print the Return Top Of Stack bytecode." - - self print: 'returnTop'! Item was removed: - ----- Method: InstructionPrinter>>popIntoLiteralVariable: (in category 'instruction decoding') ----- - popIntoLiteralVariable: anAssociation - "Print the Remove Top Of Stack And Store Into Literal Variable bytecode." - - self print: 'popIntoLit: ' , anAssociation key! Item was removed: - ----- Method: InstructionPrinter>>popIntoReceiverVariable: (in category 'instruction decoding') ----- - popIntoReceiverVariable: offset - "Print the Remove Top Of Stack And Store Into Instance Variable - bytecode." - - self print: 'popIntoRcvr: ' , offset printString! Item was removed: - ----- Method: InstructionPrinter>>popIntoRemoteTemp:inVectorAt: (in category 'instruction decoding') ----- - popIntoRemoteTemp: remoteTempIndex inVectorAt: tempVectorIndex - self print: 'popIntoTemp: ', remoteTempIndex printString, ' inVectorAt: ', tempVectorIndex printString! Item was removed: - ----- Method: InstructionPrinter>>popIntoTemporaryVariable: (in category 'instruction decoding') ----- - popIntoTemporaryVariable: offset - "Print the Remove Top Of Stack And Store Into Temporary Variable - bytecode." - - self print: 'popIntoTemp: ' , offset printString! Item was removed: - ----- Method: InstructionPrinter>>print: (in category 'printing') ----- - print: instruction - "Append to the receiver a description of the bytecode, instruction." - - | code | - stream tab: self indent. - printPC ifTrue: [stream print: oldPC; space]. - stream tab: (innerIndents at: oldPC). - stream nextPut: $<. - oldPC to: scanner pc - 1 do: - [:i | - code := (method at: i) radix: 16. - stream nextPut: - (code size < 2 - ifTrue: [$0] - ifFalse: [code at: 1]). - stream nextPut: code last; space]. - stream skip: -1. - stream nextPut: $>. - stream space. - stream nextPutAll: instruction. - stream cr. - oldPC := scanner pc. - "(InstructionPrinter compiledMethodAt: #print:) symbolic." - ! Item was removed: - ----- Method: InstructionPrinter>>printInstructionsOn: (in category 'initialize-release') ----- - printInstructionsOn: aStream - "Append to the stream, aStream, a description of each bytecode in the - instruction stream." - - | end | - stream := aStream. - scanner := InstructionStream on: method. - end := method endPC. - oldPC := scanner pc. - innerIndents := Array new: end withAll: 0. - fullBlockRecursionSelector := #printInstructionsOn:. - [scanner pc <= end] whileTrue: - [scanner interpretNextInstructionFor: self]! Item was removed: - ----- Method: InstructionPrinter>>printInstructionsOn:do: (in category 'initialize-release') ----- - printInstructionsOn: aStream do: aBlock - "Append to the stream, aStream, a description of each bytecode in the - instruction stream. Evaluate aBlock with the receiver, the scanner and - the stream after each instruction." - - | end | - stream := aStream. - scanner := InstructionStream on: method. - end := method endPC. - oldPC := scanner pc. - innerIndents := Array new: end withAll: 0. - [scanner pc <= end] whileTrue: - [scanner interpretNextInstructionFor: self. - aBlock value: self value: scanner value: stream]! Item was removed: - ----- Method: InstructionPrinter>>printPC (in category 'accessing') ----- - printPC - ^printPC! Item was removed: - ----- Method: InstructionPrinter>>printPC: (in category 'accessing') ----- - printPC: aBoolean - printPC := aBoolean! Item was removed: - ----- Method: InstructionPrinter>>pushActiveContext (in category 'instruction decoding') ----- - pushActiveContext - "Print the Push Active Context On Top Of Its Own Stack bytecode." - - self print: 'pushThisContext: '! Item was removed: - ----- Method: InstructionPrinter>>pushClosureCopyNumCopiedValues:numArgs:blockSize: (in category 'instruction decoding') ----- - pushClosureCopyNumCopiedValues: numCopied numArgs: numArgs blockSize: blockSize - self print: 'closureNumCopied: ', numCopied printString - , ' numArgs: ', numArgs printString - , ' bytes ', scanner pc printString - , ' to ', (scanner pc + blockSize - 1) printString. - innerIndents - atAll: (scanner pc to: scanner pc + blockSize - 1) - put: (innerIndents at: scanner pc - 1) + 1! Item was removed: - ----- Method: InstructionPrinter>>pushConsArrayWithElements: (in category 'instruction decoding') ----- - pushConsArrayWithElements: numElements - self print: 'pop ', numElements printString, ' into (Array new: ', numElements printString, ')'! Item was removed: - ----- Method: InstructionPrinter>>pushConstant: (in category 'instruction decoding') ----- - pushConstant: obj - "Print the Push Constant, obj, on Top Of Stack bytecode." - - self print: (String streamContents: - [:s | - s nextPutAll: 'pushConstant: '. - obj isVariableBinding - ifTrue: - [obj key - ifNotNil: [s nextPutAll: '##'; nextPutAll: obj key] - ifNil: [s nextPutAll: '###'; nextPutAll: obj value soleInstance name]] - ifFalse: - [obj isClosure - ifTrue: [s nextPutAll: obj sourceString] - ifFalse: [obj printOn: s]]]). - - obj isCompiledMethod ifTrue: - [obj longPrintOn: stream indent: self indent + 2. - ^self]! Item was removed: - ----- Method: InstructionPrinter>>pushFullClosure:numCopied: (in category 'printing') ----- - pushFullClosure: aCompiledBlock numCopied: numCopied - | literalIndex | - literalIndex := method literals identityIndexOf: aCompiledBlock. - literalIndex = 0 - ifTrue: - [self print: 'closureNumCopied: ', numCopied printString - , ' numArgs: ', aCompiledBlock numArgs printString] - ifFalse: - [self print: 'pushFullClosure: (self literalAt: ', literalIndex printString, - ') numCopied: ', numCopied printString, - ' "numArgs: ', aCompiledBlock numArgs printString, '"']. - - fullBlockRecursionSelector ifNotNil: - [(self class on: aCompiledBlock) - indent: self indent + 1; - perform: fullBlockRecursionSelector with: stream]! Item was removed: - ----- Method: InstructionPrinter>>pushLiteralVariable: (in category 'instruction decoding') ----- - pushLiteralVariable: anAssociation - "Print the Push Value Of anAssociation On Top Of Stack bytecode." - - self print: 'pushLitVar: ' , (anAssociation printStringLimitedTo: 64)! Item was removed: - ----- Method: InstructionPrinter>>pushNewArrayOfSize: (in category 'instruction decoding') ----- - pushNewArrayOfSize: numElements - self print: 'push: (Array new: ', numElements printString, ')'! Item was removed: - ----- Method: InstructionPrinter>>pushReceiver (in category 'instruction decoding') ----- - pushReceiver - "Print the Push Active Context's Receiver on Top Of Stack bytecode." - - self print: 'self'! Item was removed: - ----- Method: InstructionPrinter>>pushReceiverVariable: (in category 'instruction decoding') ----- - pushReceiverVariable: offset - "Print the Push Contents Of the Receiver's Instance Variable Whose Index - is the argument, offset, On Top Of Stack bytecode." - - self print: 'pushRcvr: ' , offset printString! Item was removed: - ----- Method: InstructionPrinter>>pushRemoteTemp:inVectorAt: (in category 'instruction decoding') ----- - pushRemoteTemp: remoteTempIndex inVectorAt: tempVectorIndex - self print: 'pushTemp: ', remoteTempIndex printString, ' inVectorAt: ', tempVectorIndex printString! Item was removed: - ----- Method: InstructionPrinter>>pushTemporaryVariable: (in category 'instruction decoding') ----- - pushTemporaryVariable: offset - "Print the Push Contents Of Temporary Variable Whose Index Is the - argument, offset, On Top Of Stack bytecode." - - self print: 'pushTemp: ' , offset printString! Item was removed: - ----- Method: InstructionPrinter>>send:super:numArgs: (in category 'instruction decoding') ----- - send: selector super: supered numArgs: numArgs - "Print the Send Message With Selector, selector, bytecode. The argument, - supered, indicates whether the receiver of the message is specified with - 'super' in the source method. The arguments of the message are found in - the top numArguments locations on the stack and the receiver just - below them." - - self print: (supered - ifTrue: ['superSend: '] - ifFalse: ['send: ']) - , (self stringForSelector: selector numArgs: numArgs)! Item was removed: - ----- Method: InstructionPrinter>>storeIntoLiteralVariable: (in category 'instruction decoding') ----- - storeIntoLiteralVariable: anAssociation - "Print the Store Top Of Stack Into Literal Variable Of Method bytecode." - - self print: 'storeIntoLit: ' , anAssociation key! Item was removed: - ----- Method: InstructionPrinter>>storeIntoReceiverVariable: (in category 'instruction decoding') ----- - storeIntoReceiverVariable: offset - "Print the Store Top Of Stack Into Instance Variable Of Method bytecode." - - self print: 'storeIntoRcvr: ' , offset printString! Item was removed: - ----- Method: InstructionPrinter>>storeIntoRemoteTemp:inVectorAt: (in category 'instruction decoding') ----- - storeIntoRemoteTemp: remoteTempIndex inVectorAt: tempVectorIndex - self print: 'storeIntoTemp: ', remoteTempIndex printString, ' inVectorAt: ', tempVectorIndex printString! Item was removed: - ----- Method: InstructionPrinter>>storeIntoTemporaryVariable: (in category 'instruction decoding') ----- - storeIntoTemporaryVariable: offset - "Print the Store Top Of Stack Into Temporary Variable Of Method - bytecode." - - self print: 'storeIntoTemp: ' , offset printString! Item was removed: - ----- Method: InstructionPrinter>>stringForSelector:numArgs: (in category 'printing') ----- - stringForSelector: selector numArgs: numArgs - ^(selector isSymbol and: [selector numArgs = numArgs]) - ifTrue: [selector] - ifFalse: [selector printString - , (numArgs = 1 - ifTrue: [' (1 arg)'] - ifFalse: [' (', numArgs printString, ' args)'])]! Item was removed: - ----- Method: InstructionPrinter>>trapIfNotInstanceOf: (in category 'instruction decoding') ----- - trapIfNotInstanceOf: behaviorOrArrayOfBehavior - "If the top of stack is not an instance of either the argument, or, if the argument is an Array, - any of the elements of the argument, send the class trap message to the current context." - self print: 'trapIfNotInstanceOf: ', behaviorOrArrayOfBehavior printString! Item was removed: - Object subclass: #InstructionStream - instanceVariableNames: 'sender pc' - classVariableNames: 'SpecialConstants' - poolDictionaries: '' - category: 'Kernel-Methods'! - - !InstructionStream commentStamp: '<historical>' prior: 0! - My instances can interpret the byte-encoded Smalltalk instruction set. They maintain a program counter (pc) for streaming through CompiledMethods. My subclasses are Contexts, which inherit this capability. They store the return pointer in the instance variable sender, and the current position in their method in the instance variable pc. For other users, sender can hold a method to be similarly interpreted. The unclean re-use of sender to hold the method was to avoid a trivial subclass for the stand-alone scanning function.! Item was removed: - ----- Method: InstructionStream class>>initialize (in category 'class initialization') ----- - initialize - "Initialize an array of special constants returned by single-bytecode returns - in the SqueakV3 bytecode set." - - SpecialConstants := {true. false. nil. -1. 0. 1. 2} - "InstructionStream initialize." - ! Item was removed: - ----- Method: InstructionStream class>>instVarNamesAndOffsetsDo: (in category 'compiling') ----- - instVarNamesAndOffsetsDo: aBinaryBlock - "This is part of the interface between the compiler and a class's instance or field names. - We override here to arrange that the compiler will use MaybeContextInstanceVariableNodes - for instances variables of Context or any of its superclasses and subclasses. The - convention to make the compiler use the special nodes is to use negative indices" - - | superInstSize | - (self withAllSubclasses noneSatisfy: [:class|class isContextClass]) ifTrue: - [^super instVarNamesAndOffsetsDo: aBinaryBlock]. - (superInstSize := superclass notNil ifTrue: [superclass instSize] ifFalse: [0]) > 0 ifTrue: - [superclass instVarNamesAndOffsetsDo: aBinaryBlock]. - 1 to: self instSize - superInstSize do: - [:i| aBinaryBlock value: (instanceVariables at: i) value: (i + superInstSize) negated]! Item was removed: - ----- Method: InstructionStream class>>isContextClass (in category 'compiling') ----- - isContextClass - ^false! Item was removed: - ----- Method: InstructionStream class>>on: (in category 'instance creation') ----- - on: method - "Answer an instance of me on the argument, method." - - ^self new method: method pc: method initialPC! Item was removed: - ----- Method: InstructionStream>>addSelectorTo: (in category 'scanning') ----- - addSelectorTo: set - "If this instruction is a send, add its selector to set." - - | selectorOrSelf | - (selectorOrSelf := self selectorToSendOrSelf) == self ifFalse: - [set add: selectorOrSelf]! Item was removed: - ----- Method: InstructionStream>>atEnd (in category 'decoding') ----- - atEnd - - ^ pc > self method endPC! Item was removed: - ----- Method: InstructionStream>>blockMethodOrNil (in category 'scanning') ----- - blockMethodOrNil - "If this instruction is a full block creation, answer the block's method, otherwise nil." - - | method | - method := self method. - ^method encoderClass blockMethodOrNilFor: self in: method at: pc! Item was removed: - ----- Method: InstructionStream>>firstByte (in category 'scanning') ----- - firstByte - "Answer the first byte of the current bytecode." - - ^self method at: pc! Item was removed: - ----- Method: InstructionStream>>followingByte (in category 'scanning') ----- - followingByte - "Answer the next bytecode." - - ^self method at: pc + 1! Item was removed: - ----- Method: InstructionStream>>followingBytecode (in category 'scanning') ----- - followingBytecode - "Answer the bytecode of the following bytecode (different to nextByte)." - - ^self method at: self followingPc! Item was removed: - ----- Method: InstructionStream>>followingPc (in category 'scanning') ----- - followingPc - "Answer the pc of the following bytecode." - | method | - method := self method. - ^pc + (method encoderClass bytecodeSize: (method at: pc))! Item was removed: - ----- Method: InstructionStream>>fourthByte (in category 'scanning') ----- - fourthByte - "Answer the fourth byte of the current bytecode." - - ^self method at: pc + 3! Item was removed: - ----- Method: InstructionStream>>interpretJump (in category 'decoding') ----- - interpretJump - "If the instruction at pc is an unconditional jump, interpret it, advancing the pc, - and answering the jump distance. Otherwise answer nil." - ^self method encoderClass interpretJumpIn: self! Item was removed: - ----- Method: InstructionStream>>interpretJumpIfCond (in category 'decoding') ----- - interpretJumpIfCond - "If the instruction at pc is a conditional jump, interpret it, advancing the pc, - and answering the jump distance. Otherwise answer nil." - ^self method encoderClass interpretJumpIfCondIn: self! Item was removed: - ----- Method: InstructionStream>>interpretNext2ByteSistaV1Instruction:for:extA:extB:startPC: (in category 'decoding - private - sista v1') ----- - interpretNext2ByteSistaV1Instruction: bytecode for: client extA: extA extB: extB startPC: startPC - "Send to the argument, client, a message that specifies the next instruction. - This method handles the two-byte codes. - For a table of the bytecode set, see EncoderForV1's class comment." - - | byte method | - method := self method. - byte := self method at: pc. - pc := pc + 1. - "We do an inline quasi-binary search on bytecode" - bytecode < 234 ifTrue: "pushes" - [bytecode < 231 ifTrue: - [bytecode < 229 ifTrue: - [| literal | - bytecode = 226 ifTrue: - [^client pushReceiverVariable: (extA bitShift: 8) + byte]. - literal := method literalAt: (extA bitShift: 8) + byte + 1. - bytecode = 227 ifTrue: - [^client pushLiteralVariable: literal]. - ^client pushConstant: literal]. - bytecode = 229 ifTrue: - [^client pushTemporaryVariable: byte]. - ^self unusedBytecode: client at: startPC]. - bytecode = 231 ifTrue: - [^byte < 128 - ifTrue: [client pushNewArrayOfSize: byte] - ifFalse: [client pushConsArrayWithElements: byte - 128]]. - bytecode = 232 ifTrue: - [^client pushSpecialConstant: ((extB < 128 ifTrue: [extB] ifFalse: [extB - 256]) bitShift: 8) + byte]. - ^client pushSpecialConstant: (Character value: ((extB bitAnd: 16rFF) bitShift: 8) + byte)]. - bytecode < 240 ifTrue: "sends, trap and jump" - [bytecode < 236 ifTrue: "sends" - [(bytecode = 235 and: [extB >= 64]) ifTrue: - [^client - directedSuperSend: (method literalAt: (extA bitShift: 5) + (byte // 8) + 1) - numArgs: (extB - 64 bitShift: 3) + (byte \\ 8)]. - ^client - send: (method literalAt: (extA bitShift: 5) + (byte // 8) + 1) - super: bytecode = 235 - numArgs: (extB bitShift: 3) + (byte \\ 8)]. - bytecode = 236 ifTrue: - [^client callMappedInlinedPrimitive: byte]. - bytecode = 237 ifTrue: - [^client jump: (extB bitShift: 8) + byte]. - ^client jump: (extB bitShift: 8) + byte if: bytecode = 238]. - bytecode < 243 ifTrue: - [bytecode = 240 ifTrue: - [^client popIntoReceiverVariable: (extA bitShift: 8) + byte]. - bytecode = 241 ifTrue: - [^client popIntoLiteralVariable: (method literalAt: (extA bitShift: 8) + byte + 1)]. - ^client popIntoTemporaryVariable: byte]. - bytecode = 243 ifTrue: - [^client storeIntoReceiverVariable: (extA bitShift: 8) + byte]. - bytecode = 244 ifTrue: - [^client storeIntoLiteralVariable: (method literalAt: (extA bitShift: 8) + byte + 1)]. - bytecode = 245 ifTrue: - [^client storeIntoTemporaryVariable: byte]. - "246-247 1111011 i xxxxxxxx UNASSIGNED" - ^self unusedBytecode: client at: startPC! Item was removed: - ----- Method: InstructionStream>>interpretNext3ByteSistaV1Instruction:for:extA:extB:startPC: (in category 'decoding - private - sista v1') ----- - interpretNext3ByteSistaV1Instruction: bytecode for: client extA: extA extB: extB startPC: startPC - "Send to the argument, client, a message that specifies the next instruction. - This method handles the three-byte codes. - For a table of the bytecode set, see EncoderForSistaV1's class comment." - - | method byte2 byte3 literal | - method := self method. - byte2 := method at: pc. - byte3 := method at: pc + 1. - pc := pc + 2. - - "** 248 (2) 11111000 iiiiiiii mssjjjjj Call Primitive #iiiiiiii + (jjjjj * 256) - m=1 means inlined primitive, no hard return after execution. - ss defines the unsafe operation set used to encode the operations. - (ss = 0 means sista unsafe operations, ss = 01 means lowcode operations, other numbers are not used) - Lowcode inlined primitives may have extensions." - bytecode = 248 ifTrue: - [| primitiveSetSelector primitiveNumber | - byte3 < 128 ifTrue: - [ "Maybe this should be restricted to the 13 bit primitiveNumber too..." - ^client callPrimitive: byte2 + (byte3 bitShift: 8)]. - primitiveSetSelector := (byte3 bitShift: -5) bitAnd: 3. - primitiveNumber := byte2 + ((byte3 bitAnd: 31) bitShift: 8). - primitiveSetSelector = 0 ifTrue: "Sista inline primitives" - [^client callInlinePrimitive: byte2 + (byte3 - 128 bitShift: 8)]. - primitiveSetSelector = 1 ifTrue: "Lowcode inline primitives" - [^client callLowcodeInlinePrimitive: byte2 + (byte3 - 128 bitShift: 8) extA: extA extB: extB]. - "fall through to ^self unusedBytecode: client at: startPC below"]. - - "* 249 11111001 xxxxxxxx siyyyyyy push Closure Compiled block literal index xxxxxxxx (+ Extend A * 256) numCopied yyyyyy receiverOnStack: s = 1 ignoreOuterContext: i = 1" - bytecode = 249 ifTrue: - [literal := method literalAt: (extA bitShift: 8) + byte2 + 1. - (byte3 noMask: 16rC0) ifTrue: - [^client pushFullClosure: literal numCopied: byte3]. - ^client - pushFullClosure: literal - numCopied: (byte3 bitAnd: 16r3F) - receiverOnStack: (byte3 anyMask: 16r80) - ignoreOuterContext: (byte3 anyMask: 16r40)]. - bytecode = 250 ifTrue: - ["** 250 11111010 eeiiikkk jjjjjjjj Push Closure Num Copied iii (+ExtA//16*8) Num Args kkk (+ ExtA\\16*8) BlockSize jjjjjjjj (+ExtB*256). ee = num extensions" - ^client - pushClosureCopyNumCopiedValues: ((byte2 bitShift: -3) bitAnd: 7) + (extA // 16 bitShift: 3) - numArgs: (byte2 bitAnd: 7) + (extA \\ 16 bitShift: 3) - blockSize: byte3 + (extB bitShift: 8)]. - bytecode = 251 ifTrue: - [^client pushRemoteTemp: byte2 inVectorAt: byte3]. - bytecode = 252 ifTrue: - [^client storeIntoRemoteTemp: byte2 inVectorAt: byte3]. - bytecode = 253 ifTrue: - [^client popIntoRemoteTemp: byte2 inVectorAt: byte3]. - "** 254 11111110 kkkkkkkk jjjjjjjj branch If Not Instance Of Behavior/Array Of Behavior kkkkkkkk (+ Extend A * 256, where Extend A >= 0) distance jjjjjjjj (+ Extend B * 256, where Extend B >= 0)" - bytecode = 254 ifTrue: "The sign bit of extB inverts the operation. Would like to have extB < -128, but this is good enough for now." - [literal := method literalAt: (extA bitShift: 8) + byte2 + 1. - extB < 0 ifTrue: [^client branchIfInstanceOf: literal distance: (extB + 128 bitShift: 8) + byte3]. - ^client branchIfNotInstanceOf: literal distance: (extB bitShift: 8) + byte3]. - ^self unusedBytecode: client at: startPC! Item was removed: - ----- Method: InstructionStream>>interpretNextInstructionFor: (in category 'decoding') ----- - interpretNextInstructionFor: client - "Send to the argument, client, a message that specifies the type of the next instruction." - - ^self method encoderClass interpretNextInstructionFor: client in: self! Item was removed: - ----- Method: InstructionStream>>interpretNextSistaV1InstructionFor: (in category 'decoding - private - sista v1') ----- - interpretNextSistaV1InstructionFor: client - "Send to the argument, client, a message that specifies the next instruction." - - | byte div16 offset method extA extB savedPC | - method := self method. - "For a table of the bytecode set, see EncoderForSistaV1's class comment." - "consume and compute any extensions first." - extA := extB := 0. - savedPC := pc. - [byte := self method at: pc. - pc := pc + 1. - byte >= 16rE0 and: [byte <= 16rE1]] whileTrue: - [| extByte | - extByte := self method at: pc. - pc := pc + 1. - byte = 16rE0 - ifTrue: - [extA := (extA bitShift: 8) + extByte] - ifFalse: - [extB := (extB = 0 and: [extByte > 127]) - ifTrue: [extByte - 256] - ifFalse: [(extB bitShift: 8) + extByte]]]. - div16 := byte // 16. - offset := byte \\ 16. - "We do an inline quasi-binary search on each of the possible 16 values of div16" - div16 < 11 ifTrue: - [div16 < 6 ifTrue: - [div16 < 4 ifTrue: - [div16 < 2 ifTrue: - [div16 = 0 ifTrue: - [^client pushReceiverVariable: offset]. - ^client pushLiteralVariable: (method literalAt: offset + 1)]. "div16 = 1" - ^client pushConstant: (method literalAt: byte \\ 32 + 1)]. - div16 = 4 ifTrue: - [offset < 12 ifTrue: - [^client pushTemporaryVariable: offset]. - offset = 12 ifTrue: - [^client pushReceiver]. - offset = 13 ifTrue: - [^client pushSpecialConstant: true]. - offset = 14 ifTrue: - [^client pushSpecialConstant: false]. - offset = 15 ifTrue: - [^client pushSpecialConstant: nil]]. - "div16 = 5" - offset < 2 ifTrue: - [^client pushSpecialConstant: offset]. - offset = 2 ifTrue: - [^self interpretSistaV1ExtendedPush: extB for: client]. - offset = 3 ifTrue: - [^client doDup]. - offset = 8 ifTrue: - [^client methodReturnReceiver]. - offset = 9 ifTrue: - [^client methodReturnConstant: true]. - offset = 10 ifTrue: - [^client methodReturnConstant: false]. - offset = 11 ifTrue: - [^client methodReturnConstant: nil]. - offset = 12 ifTrue: - [^client methodReturnTop]. - offset = 13 ifTrue: - [^client blockReturnConstant: nil]. - offset = 14 ifTrue: - [^client blockReturnTop]. - offset = 15 ifTrue: - [^client doNop]. - ^self unusedBytecode: client at: savedPC]. - "short sends" - div16 = 6 ifTrue: - [^client - sendSpecial: (Smalltalk specialSelectorAt: offset + 1) - numArgs: (Smalltalk specialNargsAt: offset + 1)]. - div16 = 7 ifTrue: - [^client - sendSpecial: (Smalltalk specialSelectorAt: offset + 17) - numArgs: (Smalltalk specialNargsAt: offset + 17)]. - ^client - send: (method literalAt: offset + 1) - super: false - numArgs: div16 - 8]. - "div16 >= 11; bytecode >= 176" - div16 < 14 ifTrue: - [div16 = 11 ifTrue: - [offset < 8 ifTrue: - [^client jump: offset + 1]. - ^client jump: offset - 7 if: true]. - div16 = 12 ifTrue: - [offset < 8 ifTrue: - [^client jump: offset + 1 if: false]. - ^client popIntoReceiverVariable: offset - 8]. - "div16 = 13" - offset < 8 ifTrue: - [^client popIntoTemporaryVariable: offset]. - offset = 8 ifTrue: - [^client doPop]. - offset = 9 ifTrue: - [^client trap]. - ^self unusedBytecode: client at: savedPC]. - "2 byte and 3 byte codes" - byte < 248 ifTrue: - [^self interpretNext2ByteSistaV1Instruction: byte for: client extA: extA extB: extB startPC: savedPC]. - ^self interpretNext3ByteSistaV1Instruction: byte for: client extA: extA extB: extB startPC: savedPC! Item was removed: - ----- Method: InstructionStream>>interpretNextV3ClosuresInstructionFor: (in category 'decoding - private - v3 plus closures') ----- - interpretNextV3ClosuresInstructionFor: client - "Send to the argument, client, a message that specifies the type of the - next instruction." - - | byte type offset method | - method := self method. - byte := method at: pc. - type := byte // 16. - offset := byte \\ 16. - pc := pc+1. - "We do an inline binary search on each of the possible 16 values of type." - type < 8 ifTrue: - [type < 4 ifTrue: - [type < 2 ifTrue: - [type = 0 ifTrue: - [^ client pushReceiverVariable: offset]. - ^ client pushTemporaryVariable: offset]. "type = 1" - type = 2 ifTrue: - [^ client pushConstant: (method literalAt: offset + 1)]. - ^ client pushConstant: (method literalAt: offset + 17)]. "type = 3" - type < 6 ifTrue: - [type = 4 ifTrue: - [^ client pushLiteralVariable: (method literalAt: offset + 1)]. - ^ client pushLiteralVariable: (method literalAt: offset + 17)]."type = 5" - type = 6 ifTrue: - [offset < 8 ifTrue: - [^ client popIntoReceiverVariable: offset]. - ^ client popIntoTemporaryVariable: offset - 8]. - "type = 7" - offset = 0 ifTrue: [^ client pushReceiver]. - offset < 8 ifTrue: [^ client pushSpecialConstant: (SpecialConstants at: offset)]. - offset = 8 ifTrue: [^ client methodReturnReceiver]. - offset < 12 ifTrue: [^ client methodReturnConstant: (SpecialConstants at: offset - 8)]. - offset = 12 ifTrue: [^ client methodReturnTop]. - offset = 13 ifTrue: [^ client blockReturnTop]. - ^ self unusedBytecode: client at: pc - 1]. "offset = 14 & offset = 15, 126 & 127" - type < 12 ifTrue: - [type < 10 ifTrue: - [type = 8 ifTrue: - [^ self - interpretV3ClosuresExtension: offset - in: method - for: client]. - "type = 9 (short jumps)" - offset < 8 ifTrue: [^ client jump: offset + 1]. - ^ client jump: offset - 8 + 1 if: false]. - type = 10 ifTrue: "(long jumps)" - [byte := method at: pc. - pc := pc + 1. - offset < 8 ifTrue: [^ client jump: offset - 4 * 256 + byte]. - ^ client jump: (offset bitAnd: 3) * 256 + byte if: offset < 12]. - "type = 11; arithmetic special selector sends" - ^ client - sendSpecial: (Smalltalk specialSelectorAt: offset + 1) - numArgs: (Smalltalk specialNargsAt: offset + 1)]. - type = 12 ifTrue: "non-arithmetic special selector sends" - [^ client - sendSpecial: (Smalltalk specialSelectorAt: offset + 17) - numArgs: (Smalltalk specialNargsAt: offset + 17)]. - "type = 13, 14 or 15" - ^ client - send: (method literalAt: offset + 1) - super: false - numArgs: type - 13 "0, 1 & 2"! Item was removed: - ----- Method: InstructionStream>>interpretNextV3InstructionFor: (in category 'decoding - private - v3 plus closures') ----- - interpretNextV3InstructionFor: client - "Send to the argument, client, a message that specifies the type of the - next instruction." - - | byte type offset method | - method := self method. - byte := method at: pc. - type := byte // 16. - offset := byte \\ 16. - pc := pc+1. - "We do an inline binary search on each of the possible 16 values of type." - type < 8 ifTrue: - [type < 4 ifTrue: - [type < 2 ifTrue: - [type = 0 ifTrue: - [^ client pushReceiverVariable: offset]. - ^ client pushTemporaryVariable: offset]. "type = 1" - type = 2 ifTrue: - [^ client pushConstant: (method literalAt: offset + 1)]. - ^ client pushConstant: (method literalAt: offset + 17)]. "type = 3" - type < 6 ifTrue: - [type = 4 ifTrue: - [^ client pushLiteralVariable: (method literalAt: offset + 1)]. - ^ client pushLiteralVariable: (method literalAt: offset + 17)]."type = 5" - type = 6 ifTrue: - [offset < 8 ifTrue: - [^ client popIntoReceiverVariable: offset]. - ^ client popIntoTemporaryVariable: offset - 8]. - "type = 7" - offset = 0 ifTrue: [^ client pushReceiver]. - offset < 8 ifTrue: [^ client pushSpecialConstant: (SpecialConstants at: offset)]. - offset = 8 ifTrue: [^ client methodReturnReceiver]. - offset < 12 ifTrue: [^ client methodReturnConstant: (SpecialConstants at: offset - 8)]. - offset = 12 ifTrue: [^ client methodReturnTop]. - offset = 13 ifTrue: [^ client blockReturnTop]. - ^ self unusedBytecode: client at: pc - 1]. "offset = 14 & offset = 15, 126 & 127" - type < 12 ifTrue: - [type < 10 ifTrue: - [type = 8 ifTrue: - [^ self - interpretV3Extension: offset - in: method - for: client]. - "type = 9 (short jumps)" - offset < 8 ifTrue: [^ client jump: offset + 1]. - ^ client jump: offset - 8 + 1 if: false]. - type = 10 ifTrue: "(long jumps)" - [byte := method at: pc. - pc := pc + 1. - offset < 8 ifTrue: [^ client jump: offset - 4 * 256 + byte]. - ^ client jump: (offset bitAnd: 3) * 256 + byte if: offset < 12]. - "type = 11; arithmetic special selector sends" - ^ client - sendSpecial: (Smalltalk specialSelectorAt: offset + 1) - numArgs: (Smalltalk specialNargsAt: offset + 1)]. - type = 12 ifTrue: "non-arithmetic special selector sends" - [^ client - sendSpecial: (Smalltalk specialSelectorAt: offset + 17) - numArgs: (Smalltalk specialNargsAt: offset + 17)]. - "type = 13, 14 or 15" - ^ client - send: (method literalAt: offset + 1) - super: false - numArgs: type - 13 "0, 1 & 2"! Item was removed: - ----- Method: InstructionStream>>interpretSistaV1ExtendedPush:for: (in category 'decoding - private - sista v1') ----- - interpretSistaV1ExtendedPush: extB for: client - "Implement the extended push for non-zero extensions." - "* 82 01010010 Push thisContext, (then Extend B = 1 => push thisProcess)" - extB = 0 ifTrue: - [^client pushActiveContext]. - extB = 1 ifTrue: - [^client pushActiveProcess]. - self error: 'undefined extended push'! Item was removed: - ----- Method: InstructionStream>>interpretSistaV1Jump (in category 'decoding - private - sista v1') ----- - interpretSistaV1Jump - "If the instruction at pc is an unconditional jump, interpret it, advancing the pc, - and answering the jump distance. Otherwise answer nil." - - " 176-183 10110 iii Jump iii + 1 (i.e., 1 through 8) - * 225/16rE1 11100001 sbbbbbbb Extend B (Ext B = Ext B prev * 256 + Ext B) - * 237 11101101 iiiiiiii Jump #iiiiiiii (+ Extend B * 256, where bbbbbbbb = sddddddd, e.g. -32768 = i=0, a=0, s=1)" - | method byte nextpc extB | - method := self method. - "consume and compute any extension first." - extB := 0. - nextpc := pc. "must not advance pc unless this is a jump." - [byte := self method at: nextpc. - nextpc := nextpc + 1. - byte = 16rE1] whileTrue: - [| extByte | - extByte := self method at: nextpc. - nextpc := nextpc + 1. - extB := (extB = 0 and: [extByte > 127]) - ifTrue: [extByte - 256] - ifFalse: [(extB bitShift: 8) + extByte]]. - (byte between: 176 and: 183) ifTrue: - [pc := nextpc. - ^byte - 191]. - byte = 237 ifTrue: - [byte := method at: nextpc. - pc := nextpc + 1. - ^(extB bitShift: 8) + byte]. - ^nil! Item was removed: - ----- Method: InstructionStream>>interpretSistaV1JumpIfCond (in category 'decoding - private - sista v1') ----- - interpretSistaV1JumpIfCond - "If the instruction at pc is a conditional jump, interpret it, advancing the pc, - and answering the jump distance. Otherwise answer nil." - - " 184-191 10111 iii Pop and Jump 0n True iii +1 (i.e., 1 through 8) - 192-199 11000 iii Pop and Jump 0n False iii +1 (i.e., 1 through 8) - * 225/E1 11100001 sbbbbbbb Extend B (Ext B = Ext B prev * 256 + Ext B) - * 238 11101110 iiiiiiii Pop and Jump 0n True #iiiiiiii (+ Extend B * 256, where Extend B >= 0) - * 239 11101111 iiiiiiii Pop and Jump 0n False #iiiiiiii (+ Extend B * 256, where Extend B >= 0)" - | method byte nextpc extB | - method := self method. - "consume and compute any extension first." - extB := 0. - nextpc := pc. "must not advance pc unless this is a jump." - [byte := self method at: nextpc. - nextpc := nextpc + 1. - byte = 16rE1] whileTrue: - [| extByte | - extByte := self method at: nextpc. - nextpc := nextpc + 1. - extB := (extB = 0 and: [extByte > 127]) - ifTrue: [extByte - 256] - ifFalse: [(extB bitShift: 8) + extByte]]. - (byte between: 184 and: 199) ifTrue: - [pc := nextpc. - ^(byte bitAnd: 7) + 1]. - (byte between: 238 and: 239) ifTrue: - [byte := method at: nextpc. - pc := nextpc + 1. - ^(extB bitShift: 8) + byte]. - ^nil! Item was removed: - ----- 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]]. - 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 removed: - ----- Method: InstructionStream>>interpretV3Extension:in:for: (in category 'decoding - private - v3 plus closures') ----- - interpretV3Extension: offset in: method for: client - | type offset2 byte2 byte3 | - 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]. - ^self unusedBytecode: client at: pc! Item was removed: - ----- Method: InstructionStream>>interpretV3Jump (in category 'decoding - private - v3 plus closures') ----- - interpretV3Jump - "If the instruction at pc is an unconditional jump, interpret it, advancing the pc, - and answering the target pc. Otherwise answer nil." - - "144-151 10010iii Jump iii + 1 (i.e., 1 through 8) - 160-167 10100iii jjjjjjjj Jump(iii - 4) *256+jjjjjjjj" - | byte | - byte := self method at: pc. - (byte between: 144 and: 151) ifTrue: - [pc := pc + 1. - ^byte - 143]. - (byte between: 160 and: 167) ifTrue: - [pc := pc + 2. - ^(byte - 164) * 256 + (self method at: pc - 1)]. - ^nil! Item was removed: - ----- Method: InstructionStream>>interpretV3JumpIfCond (in category 'decoding - private - v3 plus closures') ----- - interpretV3JumpIfCond - "If the instruction at pc is a conditional jump, interpret it, advancing the pc, - and answering the jump distance. Otherwise answer nil." - - "152-159 10011iii Pop and Jump 0n False iii +1 (i.e., 1 through 8) - 168-171 101010ii jjjjjjjj Pop and Jump On True ii *256+jjjjjjjj - 172-175 101011ii jjjjjjjj Pop and Jump On False ii *256+jjjjjjjj" - | byte | - byte := self method at: pc. - (byte between: 152 and: 159) ifTrue: - [pc := pc + 1. - ^byte - 151]. - (byte between: 168 and: 175) ifTrue: - [pc := pc + 2. - ^(byte bitAnd: 3) * 256 + (self method at: pc - 1)]. - ^nil! Item was removed: - ----- Method: InstructionStream>>method (in category 'scanning') ----- - method - "Answer the compiled method that supplies the receiver's bytecodes." - - ^sender "method access when used alone (not as part of a context)"! Item was removed: - ----- Method: InstructionStream>>method:pc: (in category 'private') ----- - method: method pc: startpc - - sender := method. - "allows this class to stand alone as a method scanner" - pc := startpc! Item was removed: - ----- Method: InstructionStream>>nextByte (in category 'scanning') ----- - nextByte - "Answer the next bytecode." - - ^self method at: pc! Item was removed: - ----- Method: InstructionStream>>nextInstruction (in category 'scanning') ----- - nextInstruction - "Return the next bytecode instruction as a message that an InstructionClient would understand. This advances the pc by one instruction." - - ^ self interpretNextInstructionFor: MessageCatcher new! Item was removed: - ----- Method: InstructionStream>>nextPc: (in category 'private') ----- - nextPc: currentByte - "Answer the pc of the next bytecode following the current one, given the current bytecode.." - - ^pc + (self method encoderClass bytecodeSize: currentByte)! Item was removed: - ----- Method: InstructionStream>>pc (in category 'scanning') ----- - pc - "Answer the index of the next bytecode." - - ^pc! Item was removed: - ----- Method: InstructionStream>>pc: (in category 'private') ----- - pc: n - - pc := n! Item was removed: - ----- Method: InstructionStream>>peekInstruction (in category 'scanning') ----- - peekInstruction - "Return the next bytecode instruction as a message that an InstructionClient would understand. The pc remains unchanged." - - | currentPc instr | - currentPc := self pc. - instr := self nextInstruction. - self pc: currentPc. - ^ instr! Item was removed: - ----- Method: InstructionStream>>previousPc (in category 'scanning') ----- - previousPc - - ^self method pcPreviousTo: pc! Item was removed: - ----- Method: InstructionStream>>scanFor: (in category 'scanning') ----- - scanFor: scanBlock - "Check all bytecode instructions with scanBlock, answer true if scanBlock answers true. - This can be used to, e.g., check whether a method contains 'push closure' bytecodes like this: - aMethod scanFor: [ :b | b = 143 ]" - - | method encoderClass end byte | - method := self method. - end := method endPC. - encoderClass := method encoderClass. - [pc <= end] whileTrue: - [(scanBlock value: (byte := method at: pc)) ifTrue: - [^true]. - pc := pc + (encoderClass bytecodeSize: byte)]. - ^false! Item was removed: - ----- Method: InstructionStream>>scanForInstructionSequence: (in category 'scanning') ----- - scanForInstructionSequence: naryBlock - "naryBlock is a block taking one or more arguments. - Evaluate it for each sequence of instructions of length - n in the receiver until naryBlock evaluates to true. - Answer if naryBlock evaluated to true." - | instructions | - instructions := OrderedCollection withAll: ((1 to: naryBlock numArgs) collect: - [:ign| - self atEnd ifFalse: - [self nextInstruction]]). - instructions last ifNil: "not enough instructions, so no match in this method, but must check for blocks" - [instructions do: - [:instOrNil| - instOrNil ifNil: [^false]. - (instOrNil selector == #pushFullClosure:numCopied: - and: [(self class on: instOrNil argument) scanForInstructionSequence: naryBlock]) ifTrue: - [^true]]]. - [(naryBlock valueWithArguments: instructions asArray) ifTrue: - [^true]. - (instructions first selector == #pushFullClosure:numCopied: - and: [(self class on: instructions first argument) scanForInstructionSequence: naryBlock]) ifTrue: - [^true]. - self atEnd] whileFalse: - [instructions removeFirst; addLast: self nextInstruction]. - ^false! Item was removed: - ----- Method: InstructionStream>>secondByte (in category 'scanning') ----- - secondByte - "Answer the second byte of the current bytecode." - - ^self method at: pc + 1! Item was removed: - ----- Method: InstructionStream>>selectorJustSentOrSelf (in category 'scanning') ----- - selectorJustSentOrSelf - "If this instruction follows a send, answer the send's selector, otherwise answer self." - - | method | - method := self method. - ^method encoderClass selectorToSendOrItselfFor: self in: method at: (self previousPc ifNil: [^self])! Item was removed: - ----- Method: InstructionStream>>selectorToSendOrSelf (in category 'scanning') ----- - selectorToSendOrSelf - "If this instruction is a send, answer the selector, otherwise answer self." - - | method | - method := self method. - ^method encoderClass selectorToSendOrItselfFor: self in: method at: pc! Item was removed: - ----- Method: InstructionStream>>skipBackBeforeJump (in category 'scanning') ----- - skipBackBeforeJump - "Assuming that the receiver is positioned just after a jump, skip back one or two bytes, - depending on the size of the previous jump instruction." - | scanner client prevPc | - scanner := InstructionStream on: self method. - client := InstructionClient new. - [scanner pc < pc] whileTrue: - [prevPc := scanner pc. - scanner interpretNextInstructionFor: client]. - scanner pc: prevPc. - (scanner willJumpIfTrue or: [scanner willJumpIfFalse]) ifFalse: - [self error: 'Where''s the jump??']. - self jump: prevPc - pc! Item was removed: - ----- Method: InstructionStream>>skipCallPrimitive (in category 'decoding') ----- - skipCallPrimitive - "If the receiver's method starts with a callPrimitive: bytecode, skip it." - | method encoderClass callPrimitiveCode | - method := self method. - encoderClass := method encoderClass. - callPrimitiveCode := encoderClass callPrimitiveCode. - (method byteAt: pc) = callPrimitiveCode ifTrue: - [pc := pc + (encoderClass bytecodeSize: callPrimitiveCode)]! Item was removed: - ----- Method: InstructionStream>>thirdByte (in category 'scanning') ----- - thirdByte - "Answer the third byte of the current bytecode." - - ^self method at: pc + 2! Item was removed: - ----- Method: InstructionStream>>unusedBytecode:at: (in category 'private') ----- - unusedBytecode: client at: targetPC - [client unusedBytecode] - on: MessageNotUnderstood - do: [:ex| - (ex receiver == client - and: [ex message selector == #unusedBytecode]) - ifTrue: [self error: 'unusedBytecode'] - ifFalse: [ex pass]]! Item was removed: - ----- Method: InstructionStream>>willBlockReturn (in category 'testing') ----- - willBlockReturn - "Answer whether the next bytecode is a return." - | method | - method := self method. - ^method encoderClass isBlockReturnAt: pc in: method! Item was removed: - ----- Method: InstructionStream>>willJump (in category 'testing') ----- - willJump - "Answer whether the next bytecode is an uncoinditional jump." - | method | - method := self method. - ^method encoderClass isJumpAt: pc in: method! Item was removed: - ----- Method: InstructionStream>>willJumpIfFalse (in category 'testing') ----- - willJumpIfFalse - "Answer whether the next bytecode is a jump-if-false." - | method | - method := self method. - ^method encoderClass isBranchIfFalseAt: pc in: method! Item was removed: - ----- Method: InstructionStream>>willJumpIfTrue (in category 'testing') ----- - willJumpIfTrue - "Answer whether the next bytecode is a jump-if-true." - | method | - method := self method. - ^method encoderClass isBranchIfTrueAt: pc in: method! Item was removed: - ----- Method: InstructionStream>>willJustPop (in category 'testing') ----- - willJustPop - "Answer whether the bytecode at pc is a pop." - | method | - method := self method. - ^method encoderClass isJustPopAt: pc in: method! Item was removed: - ----- Method: InstructionStream>>willReallySend (in category 'testing') ----- - willReallySend - "Answer whether the next bytecode is a real message-send, not blockCopy:." - | method | - method := self method. - ^method encoderClass isRealSendAt: pc in: method! Item was removed: - ----- Method: InstructionStream>>willReallyStore (in category 'testing') ----- - willReallyStore - "Answer whether the bytecode at pc is a store or store-pop into an explicit variable. - This eliminates stores into indirect temp vectors, which implement mutable closed-over - variables in the the closure implementation, and hence stores into temp vectors are not real stores." - | method | - method := self method. - ^method encoderClass isNonSyntheticStoreAt: pc in: method for: self! Item was removed: - ----- Method: InstructionStream>>willReturn (in category 'testing') ----- - willReturn - "Answer whether the next bytecode is a return." - | method | - method := self method. - ^method encoderClass isReturnAt: pc in: method! Item was removed: - ----- Method: InstructionStream>>willReturnTopFromMethod (in category 'testing') ----- - willReturnTopFromMethod - "Answer whether the next bytecode is a return stack top from method." - | method | - method := self method. - ^method encoderClass isReturnTopFromMethodAt: pc in: method! Item was removed: - ----- Method: InstructionStream>>willSend (in category 'testing') ----- - willSend - "Answer whether the next bytecode is a message-send." - | method | - method := self method. - ^method encoderClass isSendAt: pc in: method! Item was removed: - ----- Method: InstructionStream>>willStore (in category 'testing') ----- - willStore - "Answer whether the bytecode at pc is a store or store-pop." - | method | - method := self method. - ^method encoderClass isStoreAt: pc in: method! Item was removed: - ----- Method: InstructionStream>>willStorePop (in category 'testing') ----- - willStorePop - "Answer whether the bytecode at pc is a store-pop." - | method | - method := self method. - ^method encoderClass isStorePopAt: pc in: method! Item was removed: - Number subclass: #Integer - instanceVariableNames: '' - classVariableNames: 'BitCountPerByteTable LowBitPerByteTable' - poolDictionaries: '' - category: 'Kernel-Numbers'! - - !Integer commentStamp: '<historical>' prior: 0! - I am a common abstract superclass for all Integer implementations. My implementation subclasses are SmallInteger, LargePositiveInteger, and LargeNegativeInteger. - - Integer division consists of: - / exact division, answers a fraction if result is not a whole integer - // answers an Integer, rounded towards negative infinity - \\ is modulo rounded towards negative infinity - quo: truncated division, rounded towards zero! Item was removed: - ----- Method: Integer class>>basicNew (in category 'instance creation') ----- - basicNew - - self == Integer ifTrue: [ - ^ self error: 'Integer is an abstract class. Make a concrete subclass.']. - ^ super basicNew! Item was removed: - ----- Method: Integer class>>byte1:byte2:byte3:byte4: (in category 'instance creation') ----- - byte1: byte1 byte2: byte2 byte3: byte3 byte4: byte4 - "Depending on the size of SmallInteger maxVal and the high-order byte, - either copy directly into a LargeInteger, or build up a SmallInteger by shifting" - | value | - ((SmallInteger maxVal > 1073741823) - or: [byte4 < 16r40]) ifTrue: - [^ (byte4 bitShift: 24) - + (byte3 bitShift: 16) - + (byte2 bitShift: 8) - + byte1]. - value := LargePositiveInteger new: 4. - value digitAt: 4 put: byte4. - value digitAt: 3 put: byte3. - value digitAt: 2 put: byte2. - value digitAt: 1 put: byte1. - ^value! Item was removed: - ----- Method: Integer class>>byte1:byte2:byte3:byte4:byte5:byte6:byte7:byte8: (in category 'instance creation') ----- - byte1: byte1 byte2: byte2 byte3: byte3 byte4: byte4 byte5: byte5 byte6: byte6 byte7: byte7 byte8: byte8 - "Depending on the size of SmallInteger maxVal and the high-order byte, - either copy directly into a LargeInteger, or build up a SmallInteger by shifting" - | value | - (SmallInteger maxVal > 1073741823 - ifTrue: [byte8 <= (SmallInteger maxVal digitAt: 8)] - ifFalse: [byte5 + byte6 + byte7 = 0 and: [byte4 < 16r40]]) ifTrue: - [^ (byte8 bitShift: 56) - + (byte7 bitShift: 48) - + (byte6 bitShift: 40) - + (byte5 bitShift: 32) - + (byte4 bitShift: 24) - + (byte3 bitShift: 16) - + (byte2 bitShift: 8) - + byte1]. - value := LargePositiveInteger new: 8. - value digitAt: 8 put: byte8. - value digitAt: 7 put: byte7. - value digitAt: 6 put: byte6. - value digitAt: 5 put: byte5. - value digitAt: 4 put: byte4. - value digitAt: 3 put: byte3. - value digitAt: 2 put: byte2. - value digitAt: 1 put: byte1. - ^value! Item was removed: - ----- Method: Integer class>>initialize (in category 'class initialization') ----- - initialize - "Integer initialize" - - self - initializeLowBitPerByteTable; - initializeBitCountPerByteTable! Item was removed: - ----- Method: Integer class>>initializeBitCountPerByteTable (in category 'class initialization') ----- - initializeBitCountPerByteTable - "Initialize BitCountPerByteTable which is a ByteArray that contains the number of set bits (1) of the integers between 0 and 255. It's defined as a class variable so that it can be used from the instance side and subclasses too." - "Evaluate this expression to form the byte array: - ((0 to: 255) - collect: [:i | - | bitCount n | - n := i. - bitCount := 0. - [n = 0] - whileFalse: - [bitCount := bitCount + 1. - n := n bitAnd: n - 1]. - bitCount] - as: ByteArray)" - - BitCountPerByteTable := #[0 1 1 2 1 2 2 3 1 2 2 3 2 3 3 4 1 2 2 3 2 3 3 4 2 3 3 4 3 4 4 5 1 2 2 3 2 3 3 4 2 3 3 4 3 4 4 5 2 3 3 4 3 4 4 5 3 4 4 5 4 5 5 6 1 2 2 3 2 3 3 4 2 3 3 4 3 4 4 5 2 3 3 4 3 4 4 5 3 4 4 5 4 5 5 6 2 3 3 4 3 4 4 5 3 4 4 5 4 5 5 6 3 4 4 5 4 5 5 6 4 5 5 6 5 6 6 7 1 2 2 3 2 3 3 4 2 3 3 4 3 4 4 5 2 3 3 4 3 4 4 5 3 4 4 5 4 5 5 6 2 3 3 4 3 4 4 5 3 4 4 5 4 5 5 6 3 4 4 5 4 5 5 6 4 5 5 6 5 6 6 7 2 3 3 4 3 4 4 5 3 4 4 5 4 5 5 6 3 4 4 5 4 5 5 6 4 5 5 6 5 6 6 7 3 4 4 5 4 5 5 6 4 5 5 6 5 6 6 7 4 5 5 6 5 6 6 7 5 6 6 7 6 7 7 8]! Item was removed: - ----- Method: Integer class>>initializeLowBitPerByteTable (in category 'class initialization') ----- - initializeLowBitPerByteTable - "Initialize LowBitPerByteTable which is a ByteArray that contains the index of the lowest set bit of the integers between 1 and 255. It's defined as a class variable because it's used from the instance side and subclasses." - "The low bits table can be obtained with: - ((1 to: 8) inject: #[1] into: [:lowBits :rank | (lowBits copy at: 1 put: lowBits first + 1; yourself) , lowBits]) allButFirst - or with it's symmetric pair: - ((1 to: 8) inject: #[1] into: [:lowBits :rank | lowBits, (lowBits copy atLast: 1 put: lowBits last + 1; yourself)]) allButLast." - - LowBitPerByteTable := #[1 2 1 3 1 2 1 4 1 2 1 3 1 2 1 5 1 2 1 3 1 2 1 4 1 2 1 3 1 2 1 6 1 2 1 3 1 2 1 4 1 2 1 3 1 2 1 5 1 2 1 3 1 2 1 4 1 2 1 3 1 2 1 7 1 2 1 3 1 2 1 4 1 2 1 3 1 2 1 5 1 2 1 3 1 2 1 4 1 2 1 3 1 2 1 6 1 2 1 3 1 2 1 4 1 2 1 3 1 2 1 5 1 2 1 3 1 2 1 4 1 2 1 3 1 2 1 8 1 2 1 3 1 2 1 4 1 2 1 3 1 2 1 5 1 2 1 3 1 2 1 4 1 2 1 3 1 2 1 6 1 2 1 3 1 2 1 4 1 2 1 3 1 2 1 5 1 2 1 3 1 2 1 4 1 2 1 3 1 2 1 7 1 2 1 3 1 2 1 4 1 2 1 3 1 2 1 5 1 2 1 3 1 2 1 4 1 2 1 3 1 2 1 6 1 2 1 3 1 2 1 4 1 2 1 3 1 2 1 5 1 2 1 3 1 2 1 4 1 2 1 3 1 2 1]! Item was removed: - ----- Method: Integer class>>initializedInstance (in category 'instance creation') ----- - initializedInstance - ^ 2468! Item was removed: - ----- Method: Integer class>>largePrimesUpTo: (in category 'prime numbers') ----- - largePrimesUpTo: maxValue - "Compute and return all the prime numbers up to maxValue" - ^Array streamContents:[:s| self largePrimesUpTo: maxValue do:[:prime| s nextPut: prime]]! Item was removed: - ----- Method: Integer class>>largePrimesUpTo:do: (in category 'prime numbers') ----- - largePrimesUpTo: max do: aBlock - "Evaluate aBlock with all primes up to maxValue. - The Algorithm is adapted from http://www.rsok.com/~jrm/printprimes.html - It encodes prime numbers much more compactly than #primesUpTo: - 38.5 integer per byte (2310 numbers per 60 byte) allow for some fun large primes. - (all primes up to SmallInteger maxVal can be computed within ~27MB of memory; - the regular #primesUpTo: would require one *GIGA*byte). - Note: The algorithm could be re-written to produce the first primes (which require - the longest time to sieve) faster but only at the cost of clarity." - - | n limit flags maskBitIndex bitIndex maskBit byteIndex index primesUpTo2310 indexLimit increments incrementIndex | - limit := max asInteger - 1. - indexLimit := max asInteger sqrtFloor + 1. - "Create the array of flags." - flags := ByteArray new: (limit + 2309) // 2310 * 60 + 60. - flags atAllPut: 16rFF. "set all to true" - - "Compute the primes up to 2310" - primesUpTo2310 := self primesUpTo: 2310. - - "Create a mapping from 2310 integers to 480 bits (60 byte)" - maskBitIndex := Array new: 2310. - bitIndex := -1. "for pre-increment" - maskBitIndex at: 1 put: (bitIndex := bitIndex + 1). - maskBitIndex at: 2 put: (bitIndex := bitIndex + 1). - - index := 1. - [ index <= 5 ] whileTrue: [ - aBlock value: (primesUpTo2310 at: index). - index := index + 1 ]. - - n := 2. - [ n <= 2309 ] whileTrue: [ - [(primesUpTo2310 at: index) < n] - whileTrue:[index := index + 1]. - n = (primesUpTo2310 at: index) ifTrue:[ - maskBitIndex at: n+1 put: (bitIndex := bitIndex + 1). - ] ifFalse:[ - "if modulo any of the prime factors of 2310, then could not be prime" - (n \\ 2 = 0 or:[n \\ 3 = 0 or:[n \\ 5 = 0 or:[n \\ 7 = 0 or:[n \\ 11 = 0]]]]) - ifTrue:[maskBitIndex at: n+1 put: 0] - ifFalse:[maskBitIndex at: n+1 put: (bitIndex := bitIndex + 1)]. - ]. - n := n + 1 ]. - - "Now the real work begins... - Start with 13 since multiples of 2,3,5,7,11 are handled by the storage method; - increment by iterating through increments, which enables us to only check about 20.77% of all numbers." - n := 13. - increments := #[4 2 4 6 2 6 4 2 4 6 6 2 6 4 2 6 4 6 8 4 2 4 2 4 14 4 6 2 10 2 6 6 4 2 4 6 2 10 2 4 2 12 10 2 4 2 4 6 2 6 4 6 6 6 2 6 4 2 6 4 6 8 4 2 4 6 8 6 10 2 4 6 2 6 6 4 2 4 6 2 6 4 2 6 10 2 10 2 4 2 4 6 8 4 2 4 12 2 6 4 2 6 4 6 12 2 4 2 4 8 6 4 6 2 4 6 2 6 10 2 4 6 2 6 4 2 4 2 10 2 10 2 4 6 6 2 6 6 4 6 6 2 6 4 2 6 4 6 8 4 2 6 4 8 6 4 6 2 4 6 8 6 4 2 10 2 6 4 2 4 2 10 2 10 2 4 2 4 8 6 4 2 4 6 6 2 6 4 8 4 6 8 4 2 4 2 4 8 6 4 6 6 6 2 6 6 4 2 4 6 2 6 4 2 4 2 10 2 10 2 6 4 6 2 6 4 2 4 6 6 8 4 2 6 10 8 4 2 4 2 4 8 10 6 2 4 8 6 6 4 2 4 6 2 6 4 6 2 10 2 10 2 4 2 4 6 2 6 4 2 4 6 6 2 6 6 6 4 6 8 4 2 4 2 4 8 6 4 8 4 6 2 6 6 4 2 4 6 8 4 2 4 2 10 2 10 2 4 2 4 6 2 10 2 4 6 8 6 4 2 6 4 6 8 4 6 2 4 8 6 4 6 2 4 6 2 6 6 4 6 6 2 6 6 4 2 10 2 10 2 4 2 4 6 2 6 4 2 10 6 2 6 4 2 6 4 6 8 4 2 4 2 12 6 4 6 2 4 6 2 12 4 2 4 8 6 4 2 4 2 10 2 10 6 2 4 6 2 6 4 2 4 6 6 2 6 4 2 10 6 8 6 4 2 4 8 6 4 6 2 4 6 2 6 6 6 4 6 2 6 4 2 4 2 10 12 2 4 2 10 2 6 4 2 4 6 6 2 10 2 6 4 14 4 2 4 2 4 8 6 4 6 2 4 6 2 6 6 4 2 4 6 2 6 4 2 4 12 2 12]. - incrementIndex := 1. - [ n <= limit ] whileTrue: [ - (maskBit := maskBitIndex at: (n \\ 2310 + 1)) = 0 ifFalse:["not a multiple of 2,3,5,7,11" - byteIndex := n // 2310 * 60 + (maskBit-1 bitShift: -3) + 1. - bitIndex := 1 bitShift: (maskBit bitAnd: 7). - ((flags at: byteIndex) bitAnd: bitIndex) = 0 ifFalse:["not marked -- n is prime" - aBlock value: n. - "Start with n*n since any integer < n has already been sieved - (e.g., any multiple of n with a number k < n has been cleared - when k was sieved); add 2 * n to avoid even numbers and - mark all multiples of this prime. Note: n < indexLimit below - limits running into LargeInts -- nothing more." - n < indexLimit ifTrue:[ - index := n * n. - [index <= limit] whileTrue:[ - (maskBit := maskBitIndex at: (index \\ 2310 + 1)) = 0 ifFalse:[ - byteIndex := (index // 2310 * 60) + (maskBit-1 bitShift: -3) + 1. - maskBit := 255 - (1 bitShift: (maskBit bitAnd: 7)). - flags at: byteIndex put: ((flags at: byteIndex) bitAnd: maskBit). - ]. - index := index + n + n ]. - ]. - ]. - ]. - n := n + (increments at: incrementIndex). - incrementIndex := incrementIndex + 1. - incrementIndex > increments size ifTrue: [ incrementIndex := 1 ] ]! Item was removed: - ----- Method: Integer class>>lowBitPerByteTable (in category 'class initialization') ----- - lowBitPerByteTable - - ^LowBitPerByteTable! Item was removed: - ----- Method: Integer class>>new (in category 'instance creation') ----- - new - - self == Integer ifTrue: [ - ^ self error: 'Integer is an abstract class. Make a concrete subclass.']. - ^ super new! Item was removed: - ----- Method: Integer class>>new:neg: (in category 'instance creation') ----- - new: length neg: neg - "Answer an instance of a large integer whose size is length. neg is a flag - determining whether the integer is negative or not." - - neg - ifTrue: [^LargeNegativeInteger new: length] - ifFalse: [^LargePositiveInteger new: length]! Item was removed: - ----- Method: Integer class>>primesUpTo: (in category 'prime numbers') ----- - primesUpTo: max - "Return a list of prime integers up to the given integer." - "Integer primesUpTo: 100" - ^Array streamContents:[:s| self primesUpTo: max do:[:prime| s nextPut: prime]]! Item was removed: - ----- Method: Integer class>>primesUpTo:do: (in category 'prime numbers') ----- - primesUpTo: max do: aBlock - "Compute aBlock with all prime integers up to the given integer." - "Integer primesUpTo: 100" - - | index sieve increment limit limitSqrtFloor | - limit := max asInteger. - "Fall back into #largePrimesUpTo:do: if we'd require more than 100k of memory; - the alternative will only requre 2/77th of the amount we need here and is almost as fast." - limit <= 100000 ifFalse: [ ^self largePrimesUpTo: limit do: aBlock ]. - limit := limit - 1. "upTo:" - limit <= 1 ifTrue: [ ^self ]. - aBlock value: 2. - limit <= 2 ifTrue: [ ^self ]. - aBlock value: 3. - sieve := ByteArray new: limit withAll: 1. "1 = prime, 0 = not prime" - sieve at: 1 put: 0. - "Filter multiples of 2." - index := 4. - [ index <= limit ] whileTrue: [ - sieve at: index put: 0. - index := index + 2 ]. - "Filter multiples of 3." - index := 9. - [ index <= limit ] whileTrue: [ - sieve at: index put: 0. - index := index + 3 ]. - "Filter the rest of the primes." - limitSqrtFloor := limit sqrtFloor. - index := 5. - increment := 2. - [ index <= limitSqrtFloor ] whileTrue: [ - (sieve at: index) = 1 ifTrue: [ - | originalIndex originalIncrement | - aBlock value: index. - originalIndex := index. - originalIncrement := increment. - increment := index + index. - index := index * index. - [ index <= limit ] whileTrue: [ - sieve at: index put: 0. - index := index + increment ]. - index := originalIndex. - increment := originalIncrement ]. - index := index + increment. - increment := 6 - increment ]. - "No more new primes here." - [ index <= limit ] whileTrue: [ - (sieve at: index) = 1 ifTrue: [ - aBlock value: index ]. - index := index + increment. - increment := 6 - increment ]! Item was removed: - ----- Method: Integer class>>readFrom: (in category 'instance creation') ----- - readFrom: aStringOrStream - "Answer a new Integer as described on the stream, aStream. - Embedded radix specifiers not allowed - use Number readFrom: for that." - ^self readFrom: aStringOrStream base: 10! Item was removed: - ----- Method: Integer class>>readFrom:base: (in category 'instance creation') ----- - readFrom: aStringOrStream base: base - "Answer an instance of one of the concrete subclasses if Integer. - Initial plus or minus sign accepted, and bases > 10 use letters A-Z. - Imbedded radix specifiers not allowed; use Number class readFrom: for that. - Raise an Error if there are no digits." - - ^(ExtendedNumberParser on: aStringOrStream) nextIntegerBase: base! Item was removed: - ----- Method: Integer class>>readFrom:base:ifFail: (in category 'instance creation') ----- - readFrom: aStringOrStream base: base ifFail: aBlock - "Answer an instance of one of the concrete subclasses if Integer. - Initial plus or minus sign accepted, and bases > 10 use letters A-Z. - Imbedded radix specifiers not allowed; use Number class readFrom: for that. - Execute aBlock if there are no digits." - - ^(ExtendedNumberParser on: aStringOrStream) nextIntegerBase: base ifFail: aBlock! Item was removed: - ----- Method: Integer class>>readFrom:ifFail: (in category 'instance creation') ----- - readFrom: aStringOrStream ifFail: aBlock - "Answer an instance of one of the concrete subclasses if Integer. - Initial plus or minus sign accepted. - Imbedded radix specifiers not allowed; use Number class readFrom: for that. - Execute aBlock if there are no digits." - - ^(ExtendedNumberParser on: aStringOrStream) nextIntegerBase: 10 ifFail: aBlock! Item was removed: - ----- Method: Integer class>>readFrom:radix: (in category 'compatibility') ----- - readFrom: aStream radix: radix - ^self readFrom: aStream base: radix! Item was removed: - ----- Method: Integer class>>verbosePrimesUpTo: (in category 'prime numbers') ----- - verbosePrimesUpTo: max - "Integer verbosePrimesUpTo: SmallInteger maxVal" "<- heh, heh" - "Compute primes up to max, but be verbose about it" - ^Array streamContents:[:s| self verbosePrimesUpTo: max do:[:prime| s nextPut: prime]].! Item was removed: - ----- Method: Integer class>>verbosePrimesUpTo:do: (in category 'prime numbers') ----- - verbosePrimesUpTo: max do: aBlock - "Integer verbosePrimesUpTo: SmallInteger maxVal" "<- heh, heh" - "Compute primes up to max, but be verbose about it" - | lastTime | - lastTime := Time millisecondClockValue. - UIManager default informUserDuring:[:bar| - bar value:'Computing primes...'. - self primesUpTo: max do:[:prime| | nowTime | - aBlock value: prime. - nowTime := Time millisecondClockValue. - (nowTime - lastTime > 1000) ifTrue:[ - lastTime := nowTime. - bar value:'Last prime found: ', prime printString]]].! Item was removed: - ----- Method: Integer>>* (in category 'arithmetic') ----- - * aNumber - "Refer to the comment in Number * " - aNumber isInteger ifTrue: - [^ self multiplyByInteger: aNumber]. - ^ aNumber adaptToInteger: self andSend: #*! Item was removed: - ----- Method: Integer>>+ (in category 'arithmetic') ----- - + aNumber - "Refer to the comment in Number + " - aNumber isInteger ifTrue: - [self negative == aNumber negative - ifTrue: [^ (self digitAdd: aNumber) normalize] - ifFalse: [^ self digitSubtract: aNumber]]. - aNumber isFraction ifTrue: - [^Fraction numerator: self * aNumber denominator + aNumber numerator denominator: aNumber denominator]. - ^ aNumber adaptToInteger: self andSend: #+! Item was removed: - ----- Method: Integer>>- (in category 'arithmetic') ----- - - aNumber - "Refer to the comment in Number - " - aNumber isInteger ifTrue: - [self negative == aNumber negative - ifTrue: [^ self digitSubtract: aNumber] - ifFalse: [^ (self digitAdd: aNumber) normalize]]. - aNumber isFraction ifTrue: - [^Fraction numerator: self * aNumber denominator - aNumber numerator denominator: aNumber denominator]. - ^ aNumber adaptToInteger: self andSend: #-! Item was removed: - ----- Method: Integer>>/ (in category 'arithmetic') ----- - / aNumber - "Refer to the comment in Number / " - aNumber isInteger ifTrue: - [aNumber isZero - ifTrue: [^(ZeroDivide dividend: self) signal]. - ^ (Fraction numerator: self denominator: aNumber) reduced]. - ^ aNumber adaptToInteger: self andSend: #/! Item was removed: - ----- Method: Integer>>// (in category 'arithmetic') ----- - // aNumber - | q | - #Numeric. - "Changed 200/01/19 For ANSI support." - aNumber = 0 ifTrue: [^ (ZeroDivide dividend: self) signal"<- Chg"]. - self = 0 ifTrue: [^ 0]. - q := self quo: aNumber. - "Refer to the comment in Number|//." - (q negative - ifTrue: [q * aNumber ~= self] - ifFalse: [q = 0 and: [self negative ~= aNumber negative]]) - ifTrue: [^ q - 1"Truncate towards minus infinity."] - ifFalse: [^ q]! Item was removed: - ----- Method: Integer>>< (in category 'comparing') ----- - < aNumber - aNumber isInteger ifTrue: - [self negative == aNumber negative - ifTrue: [self negative - ifTrue: [^ (self digitCompare: aNumber) > 0] - ifFalse: [^ (self digitCompare: aNumber) < 0]] - ifFalse: [^ self negative]]. - ^ aNumber adaptToInteger: self andCompare: #<! Item was removed: - ----- Method: Integer>><< (in category 'bit manipulation') ----- - << shiftAmount "left shift" - shiftAmount < 0 ifTrue: [self error: 'negative arg']. - ^ self bitShift: shiftAmount! Item was removed: - ----- Method: Integer>><= (in category 'comparing') ----- - <= aNumber - aNumber isInteger ifTrue: - [self negative == aNumber negative - ifTrue: [self negative - ifTrue: [^ (self digitCompare: aNumber) >= 0] - ifFalse: [^ (self digitCompare: aNumber) <= 0]] - ifFalse: [^ self negative]]. - ^ aNumber adaptToInteger: self andCompare: #<=! Item was removed: - ----- Method: Integer>>= (in category 'comparing') ----- - = aNumber - - aNumber class == self class ifTrue: [ ^(self digitCompare: aNumber) = 0 ]. - aNumber isInteger ifTrue: [ ^false ]. - aNumber isNumber ifFalse: [ ^false ]. - ^aNumber adaptToInteger: self andCompare: #=! Item was removed: - ----- Method: Integer>>> (in category 'comparing') ----- - > aNumber - aNumber isInteger ifTrue: - [self negative == aNumber negative - ifTrue: [self negative - ifTrue: [^(self digitCompare: aNumber) < 0] - ifFalse: [^(self digitCompare: aNumber) > 0]] - ifFalse: [^ aNumber negative]]. - ^ aNumber adaptToInteger: self andCompare: #>! Item was removed: - ----- Method: Integer>>>= (in category 'comparing') ----- - >= aNumber - aNumber isInteger ifTrue: - [self negative == aNumber negative - ifTrue: [self negative - ifTrue: [^(self digitCompare: aNumber) <= 0] - ifFalse: [^(self digitCompare: aNumber) >= 0]] - ifFalse: [^ aNumber negative]]. - ^ aNumber adaptToInteger: self andCompare: #>=! Item was removed: - ----- Method: Integer>>>> (in category 'bit manipulation') ----- - >> shiftAmount "right shift" - shiftAmount < 0 ifTrue: [self error: 'negative arg']. - ^ self bitShift: 0 - shiftAmount! Item was removed: - ----- Method: Integer>>\\\ (in category 'arithmetic') ----- - \\\ anInteger - "A modulo method former used in DSA." - - "Notes: this method used to be a faster than \\ for LargeIntegers, but this advantage is fainting: - - it always was slower for SmallInteger because of the indirection below - - a new LargeInteger primitive makes \\ faster up to 64 bits operands - - even above 64 bits, its advantage has become marginal thanks to revised \\ primitive fallback code - Moreover, \\\ behaviour is questionable for these reasons: - - for a negative receiver xor argument, it behaves like rem: for LargeInteger and \\ for SmallInteger - - it may answer a not normalized LargeInteger (with leading null digits) which breaks some invariants - For example, check (SmallInteger maxVal + 1 \\\ 8) isZero. - So beware if you ever think using this method." - - ^self \\ anInteger! Item was removed: - ----- Method: Integer>>adaptToScaledDecimal:andSend: (in category 'converting') ----- - adaptToScaledDecimal: receiverScaledDecimal andSend: arithmeticOpSelector - "Convert me to a ScaledDecimal and do the arithmetic. - receiverScaledDecimal arithmeticOpSelector self." - #Numeric. - "add 200/01/19 For ScaledDecimal support." - ^ receiverScaledDecimal perform: arithmeticOpSelector with: (self asScaledDecimal: 0)! Item was removed: - ----- Method: Integer>>alignedTo: (in category 'arithmetic') ----- - alignedTo: anInteger - "Answer the smallest number not less than receiver that is a multiple of anInteger." - - ^(self+anInteger-1//anInteger)*anInteger - - "5 alignedTo: 2" - "12 alignedTo: 3"! Item was removed: - ----- Method: Integer>>allMask: (in category 'bit manipulation') ----- - allMask: mask - "Treat the argument as a bit mask. Answer whether all of the bits that - are 1 in the argument are 1 in the receiver." - - ^mask = (self bitAnd: mask)! Item was removed: - ----- Method: Integer>>anyBitOfMagnitudeFrom:to: (in category 'bit manipulation') ----- - anyBitOfMagnitudeFrom: start to: stopArg - "Tests for any magnitude bits in the interval from start to stopArg." - "Primitive fixed in LargeIntegers v1.2. If you have an earlier version - comment out the primitive call (using this ST method then)." - | magnitude firstDigitIx lastDigitIx rightShift leftShift stop | - <primitive: 'primAnyBitFromTo' module:'LargeIntegers'> - start < 1 | (stopArg < 1) - ifTrue: [^ self error: 'out of range']. - magnitude := self abs. - stop := stopArg min: magnitude highBit. - start > stop - ifTrue: [^ false]. - firstDigitIx := start - 1 // 8 + 1. - lastDigitIx := stop - 1 // 8 + 1. - rightShift := (start - 1 \\ 8) negated. - leftShift := 7 - (stop - 1 \\ 8). - firstDigitIx = lastDigitIx - ifTrue: [| digit mask | - mask := (255 bitShift: rightShift negated) - bitAnd: (255 bitShift: leftShift negated). - digit := magnitude digitAt: firstDigitIx. - ^ (digit bitAnd: mask) - ~= 0]. - ((magnitude digitAt: firstDigitIx) - bitShift: rightShift) - ~= 0 - ifTrue: [^ true]. - firstDigitIx + 1 - to: lastDigitIx - 1 - do: [:ix | (magnitude digitAt: ix) - ~= 0 - ifTrue: [^ true]]. - (((magnitude digitAt: lastDigitIx) - bitShift: leftShift) - bitAnd: 255) - ~= 0 - ifTrue: [^ true]. - ^ false! Item was removed: - ----- Method: Integer>>anyMask: (in category 'bit manipulation') ----- - anyMask: mask - "Treat the argument as a bit mask. Answer whether any of the bits that - are 1 in the argument are 1 in the receiver." - - ^0 ~= (self bitAnd: mask)! Item was removed: - ----- Method: Integer>>asCharacter (in category 'converting') ----- - asCharacter - "Answer the Character whose value is the receiver." - ^Character value: self! Item was removed: - ----- Method: Integer>>asFloat (in category 'converting') ----- - asFloat - "Answer a Float that best approximates the value of the receiver." - - self subclassResponsibility! Item was removed: - ----- Method: Integer>>asFraction (in category 'converting') ----- - asFraction - "Answer a Fraction that represents the value of the receiver. - Since an Integer already behaves as a special kind of Fraction, no conversion is required, see #isFraction." - - ^self! Item was removed: - ----- Method: Integer>>asHexDigit (in category 'converting') ----- - asHexDigit - ^'0123456789ABCDEF' at: self+1! Item was removed: - ----- Method: Integer>>asInteger (in category 'converting') ----- - asInteger - "Answer with the receiver itself." - - ^self - - ! Item was removed: - ----- Method: Integer>>asLargerPowerOfTwo (in category 'truncation and round off') ----- - asLargerPowerOfTwo - "Convert the receiver into a power of two which is not less than the receiver" - self isPowerOfTwo - ifTrue:[^self] - ifFalse:[^1 bitShift: (self highBit)]! Item was removed: - ----- Method: Integer>>asPowerOfTwo (in category 'truncation and round off') ----- - asPowerOfTwo - "Convert the receiver into a power of two" - ^self asSmallerPowerOfTwo! Item was removed: - ----- Method: Integer>>asPrecedenceName (in category 'tiles') ----- - asPrecedenceName - - ^#('unary' 'binary' 'keyword') at: self - ! Item was removed: - ----- Method: Integer>>asScaledDecimal (in category 'converting') ----- - asScaledDecimal - "The number of significant digits of the answer is the same as the number of decimal digits in the receiver." - ^ ScaledDecimal newFromNumber: self scale: 0! Item was removed: - ----- Method: Integer>>asSmallerPowerOfTwo (in category 'truncation and round off') ----- - asSmallerPowerOfTwo - "Convert the receiver into a power of two which is not larger than the receiver" - self isPowerOfTwo - ifTrue:[^self] - ifFalse:[^1 bitShift: (self highBit - 1)]! Item was removed: - ----- Method: Integer>>asStringWithCommas (in category 'printing') ----- - asStringWithCommas - "123456789 asStringWithCommas" - "-123456789 asStringWithCommas" - ^ self asStringWithCommasSigned: false! Item was removed: - ----- Method: Integer>>asStringWithCommasSigned: (in category 'printing') ----- - asStringWithCommasSigned: aBoolean - "123456789 asStringWithCommasSigned: true" - "-123456789 asStringWithCommasSigned: false" - | digits | - digits := self abs printString. - ^ String streamContents: - [:strm | - self sign = -1 ifTrue: [strm nextPut: $-] ifFalse: [aBoolean ifTrue: [strm nextPut: $+]]. - 1 to: digits size do: - [:i | strm nextPut: (digits at: i). - (i < digits size and: [(i - digits size) \\ 3 = 0]) - ifTrue: [strm nextPut: $,]]]! Item was removed: - ----- Method: Integer>>asTwoCharacterString (in category 'printing') ----- - asTwoCharacterString - "Answer a two-character string representing the receiver, with leading zero if required. Intended for use with integers in the range 0 to 99, but plausible replies given for other values too" - - ^ (self >= 0 and: [self < 10]) - ifTrue: ['0', self printString] - ifFalse: [self printString copyFrom: 1 to: 2] - - - " - 2 asTwoCharacterString - 11 asTwoCharacterString - 1943 asTwoCharacterString - 0 asTwoCharacterString - -2 asTwoCharacterString - -234 asTwoCharacterString - "! Item was removed: - ----- Method: Integer>>asWords (in category 'printing') ----- - asWords - "SmallInteger maxVal asWords" - | mils minus three num answer milCount | - self = 0 ifTrue: [^'zero']. - mils := #('' ' thousand' ' million' ' billion' ' trillion' ' quadrillion' ' quintillion' ' sextillion' ' septillion' ' octillion' ' nonillion' ' decillion' ' undecillion' ' duodecillion' ' tredecillion' ' quattuordecillion' ' quindecillion' ' sexdecillion' ' septendecillion' ' octodecillion' ' novemdecillion' ' vigintillion'). - num := self. - minus := ''. - self < 0 ifTrue: [ - minus := 'negative '. - num := num negated. - ]. - answer := String new. - milCount := 1. - [num > 0] whileTrue: [ - three := (num \\ 1000) threeDigitName. - num := num // 1000. - three isEmpty ifFalse: [ - answer isEmpty ifFalse: [ - answer := ', ',answer - ]. - answer := three,(mils at: milCount),answer. - ]. - milCount := milCount + 1. - ]. - ^minus,answer! Item was removed: - ----- Method: Integer>>atRandom (in category 'truncation and round off') ----- - atRandom - "Answer a random integer from 1 to self. This implementation uses the process-local random number generator." - - self isZero ifTrue: [ ^0 ]. - self negative ifTrue: [ ^self negated atRandom negated ]. - ^self atRandom: ThreadSafeRandom value! Item was removed: - ----- Method: Integer>>atRandom: (in category 'truncation and round off') ----- - atRandom: aGenerator - "Answer a random integer from 1 to self picked from aGenerator." - - ^ aGenerator nextInt: self! Item was removed: - ----- Method: Integer>>benchFib (in category 'benchmarks') ----- - benchFib "Handy send-heavy benchmark" - "(result // seconds to run) = approx calls per second" - " | r t | - t := Time millisecondsToRun: [r := 26 benchFib]. - (r * 1000) // t" - "138000 on a Mac 8100/100" - ^ self < 2 - ifTrue: [1] - ifFalse: [(self-1) benchFib + (self-2) benchFib + 1] - ! Item was removed: - ----- Method: Integer>>benchmark (in category 'benchmarks') ----- - benchmark "Handy bytecode-heavy benchmark" - "(500000 // time to run) = approx bytecodes per second" - "5000000 // (Time millisecondsToRun: [10 benchmark]) * 1000" - "3059000 on a Mac 8100/100" - | size flags prime k count | - size := 8190. - 1 to: self do: - [:iter | - count := 0. - flags := (Array new: size) atAllPut: true. - 1 to: size do: - [:i | (flags at: i) ifTrue: - [prime := i+1. - k := i + prime. - [k <= size] whileTrue: - [flags at: k put: false. - k := k + prime]. - count := count + 1]]]. - ^ count! Item was removed: - ----- Method: Integer>>bitAnd: (in category 'bit manipulation') ----- - bitAnd: n - "Answer an Integer whose bits are the logical AND of the receiver's bits - and those of the argument, n." - | norm | - <primitive: 'primDigitBitAnd' module:'LargeIntegers'> - norm := n normalize. - ^ self - digitLogic: norm - op: #bitAnd: - length: (self digitLength max: norm digitLength)! Item was removed: - ----- Method: Integer>>bitAt: (in category 'bit manipulation') ----- - bitAt: anInteger - "Answer 1 if the bit at position anInteger is set to 1, 0 otherwise. - self is considered an infinite sequence of bits, so anInteger can be any strictly positive integer. - Bit at position 1 is the least significant bit. - Negative numbers are in two-complements. - - This is a naive implementation that can be refined in subclass for speed" - - ^(self bitShift: 1 - anInteger) bitAnd: 1! Item was removed: - ----- Method: Integer>>bitAt:put: (in category 'bit manipulation') ----- - bitAt: anInteger put: value - "Answer a new Integer that has the bit of rank anInteger set to value. - The bit value should be 0 or 1, otherwise raise an Error. - The bits are indexed starting at 1 for the least significant bit. - For negative integers, operate on 2-complement representation." - - | b | - b := self bitAt: anInteger. - b = value ifTrue: [^self]. - 0 = value ifTrue: [^self bitAnd: (1 bitShift: anInteger - 1) bitInvert]. - 1 = value ifTrue: [^self bitOr: (1 bitShift: anInteger - 1)]. - self error: 'bit value should be 0 or 1'! Item was removed: - ----- Method: Integer>>bitClear: (in category 'bit manipulation') ----- - bitClear: aMask - "Answer an Integer equal to the receiver, except with all bits cleared that are set in aMask." - - ^ (self bitOr: aMask) - aMask! Item was removed: - ----- Method: Integer>>bitCount (in category 'bit manipulation') ----- - bitCount - "Count the number of bits set to 1 in self" - - | bitCount | - self < 0 ifTrue: [self error: 'Cannot count bits of negative integers']. - bitCount := 0. - 1 to: self digitLength do: [:i | - bitCount := bitCount + (BitCountPerByteTable at: (self digitAt: i) + 1) ]. - ^bitCount! Item was removed: - ----- Method: Integer>>bitInvert (in category 'bit manipulation') ----- - bitInvert - "Answer an Integer whose bits are the logical negation of the receiver's bits. - Numbers are interpreted as having 2's-complement representation." - - ^ -1 - self! Item was removed: - ----- Method: Integer>>bitInvert32 (in category 'bit manipulation') ----- - bitInvert32 - "Answer the 32-bit complement of the receiver." - - ^ self bitXor: 16rFFFFFFFF! Item was removed: - ----- Method: Integer>>bitOr: (in category 'bit manipulation') ----- - bitOr: n - "Answer an Integer whose bits are the logical OR of the receiver's bits - and those of the argument, n." - | norm | - <primitive: 'primDigitBitOr' module:'LargeIntegers'> - norm := n normalize. - ^ self - digitLogic: norm - op: #bitOr: - length: (self digitLength max: norm digitLength)! Item was removed: - ----- Method: Integer>>bitReverse: (in category 'bit manipulation') ----- - bitReverse: highBit - "Reverse the bits of the receiver so that the lsb is the highBit'th bit of the answer. Translated from C code at: http://graphics.stanford.edu/~seander/bithacks.html#BitReverseObvious." - | v r s | - highBit < self highBit ifTrue: [ self error: 'Not enough bits.' ]. - v := self. - r := v bitAnd: 1. - s := highBit - 1. - [ v := v bitShift: -1. - v = 0 ] whileFalse: - [ r := r bitShift: 1. - r := r bitOr: (v bitAnd: 1). - s := s - 1 ]. - ^ r bitShift: s! Item was removed: - ----- Method: Integer>>bitShift: (in category 'bit manipulation') ----- - bitShift: shiftCount - "Answer an Integer whose value (in twos-complement representation) is - the receiver's value (in twos-complement representation) shifted left by - the number of bits indicated by the argument. Negative arguments - shift right. Zeros are shifted in from the right in left shifts." - | magnitudeShift | - magnitudeShift := self bitShiftMagnitude: shiftCount. - ^ ((self negative and: [shiftCount negative]) - and: [self anyBitOfMagnitudeFrom: 1 to: shiftCount negated]) - ifTrue: [magnitudeShift - 1] - ifFalse: [magnitudeShift]! Item was removed: - ----- Method: Integer>>bitShiftMagnitude: (in category 'bit manipulation') ----- - bitShiftMagnitude: shiftCount - "Answer an Integer whose value (in magnitude representation) is - the receiver's value (in magnitude representation) shifted left by - the number of bits indicated by the argument. Negative arguments - shift right. Zeros are shifted in from the right in left shifts." - | rShift | - <primitive: 'primDigitBitShiftMagnitude' module:'LargeIntegers'> - shiftCount >= 0 ifTrue: [^ self digitLshift: shiftCount]. - rShift := 0 - shiftCount. - ^ (self - digitRshift: (rShift bitAnd: 7) - bytes: (rShift bitShift: -3) - lookfirst: self digitLength) normalize! Item was removed: - ----- Method: Integer>>bitXor: (in category 'bit manipulation') ----- - bitXor: n - "Answer an Integer whose bits are the logical XOR of the receiver's bits - and those of the argument, n." - | norm | - <primitive: 'primDigitBitXor' module:'LargeIntegers'> - norm := n normalize. - ^ self - digitLogic: norm - op: #bitXor: - length: (self digitLength max: norm digitLength)! Item was removed: - ----- Method: Integer>>byteEncode:base: (in category 'printing-numerative') ----- - byteEncode: aStream base: base - ^self printOn: aStream base: base ! Item was removed: - ----- Method: Integer>>ceiling (in category 'truncation and round off') ----- - ceiling - "Refer to the comment in Number|ceiling."! Item was removed: - ----- Method: Integer>>copyto: (in category 'private') ----- - copyto: x - | stop | - stop := self digitLength min: x digitLength. - ^ x replaceFrom: 1 to: stop with: self startingAt: 1! Item was removed: - ----- Method: Integer>>crossSumBase: (in category 'arithmetic') ----- - crossSumBase: aBase - |aResult| - "Precondition" - self assert:[aBase isInteger and: [aBase >=2]]. - - self < 0 ifTrue: [^self negated crossSumBase: aBase]. - self < aBase ifTrue: [^ self]. - aResult := self \\ aBase + (self // aBase crossSumBase: aBase). - - "Postcondition - E.g. 18 crossSumBase: 10 -> 9 => 18\\(10-1) = 0" - self assert: [((aResult \\ (aBase - 1) = 0)) = ((self \\ (aBase - 1)) =0)]. - ^aResult! Item was removed: - ----- Method: Integer>>denominator (in category 'accessing') ----- - denominator - "Let an Integer be polymorphic to a Fraction. See #isFraction." - ^1! Item was removed: - ----- Method: Integer>>digitAdd: (in category 'private') ----- - digitAdd: arg - | len arglen accum sum | - <primitive: 'primDigitAdd' module:'LargeIntegers'> - accum := 0. - (len := self digitLength) < (arglen := arg digitLength) ifTrue: [len := arglen]. - "Open code max: for speed" - sum := Integer new: len neg: self negative. - 1 to: len do: - [:i | - accum := (accum bitShift: -8) - + (self digitAt: i) + (arg digitAt: i). - sum digitAt: i put: (accum bitAnd: 255)]. - accum > 255 - ifTrue: - [sum := sum growby: 1. - sum at: sum digitLength put: (accum bitShift: -8)]. - ^ sum! Item was removed: - ----- Method: Integer>>digitBuffer: (in category 'printing') ----- - digitBuffer:digitLength - ^Array new:digitLength*8.! Item was removed: - ----- Method: Integer>>digitCompare: (in category 'private') ----- - digitCompare: arg - "Compare the magnitude of self with that of arg. - Return a code of 1, 0, -1 for self >, = , < arg" - | len arglen argDigit selfDigit | - <primitive: 'primDigitCompare' module:'LargeIntegers'> - len := self digitLength. - (arglen := arg digitLength) ~= len - ifTrue: [arglen > len - ifTrue: [^ -1] - ifFalse: [^ 1]]. - [len > 0] - whileTrue: - [(argDigit := arg digitAt: len) ~= (selfDigit := self digitAt: len) - ifTrue: [argDigit < selfDigit - ifTrue: [^ 1] - ifFalse: [^ -1]]. - len := len - 1]. - ^ 0! Item was removed: - ----- Method: Integer>>digitDiv21: (in category 'private') ----- - digitDiv21: anInteger - - ^(self digitDiv: anInteger neg: false) collect: #normalize! Item was removed: - ----- Method: Integer>>digitDiv32: (in category 'private') ----- - digitDiv32: anInteger - - ^(self digitDiv: anInteger neg: false) collect: #normalize! Item was removed: - ----- Method: Integer>>digitDiv:neg: (in category 'private') ----- - digitDiv: arg neg: ng - "Answer with an array of (quotient, remainder)." - | quo rem ql d div dh dnh dl qhi qlo j l hi lo r3 a t divDigitLength remDigitLength | - <primitive: 'primDigitDivNegative' module:'LargeIntegers'> - arg = 0 ifTrue: [^ (ZeroDivide dividend: self) signal]. - "TFEI added this line" - l := self digitLength - arg digitLength + 1. - l <= 0 ifTrue: [^ Array with: 0 with: self]. - "shortcut against #highBit" - d := 8 - arg lastDigit highBitOfByte. - div := arg digitLshift: d. - divDigitLength := div digitLength + 1. - div := div growto: divDigitLength. - "shifts so high order word is >=128" - rem := self digitLshift: d. - rem digitLength = self digitLength ifTrue: [rem := rem growto: self digitLength + 1]. - remDigitLength := rem digitLength. - "makes a copy and shifts" - quo := Integer new: l neg: ng. - dl := divDigitLength - 1. - "Last actual byte of data" - ql := l. - dh := div digitAt: dl. - dnh := dl = 1 - ifTrue: [0] - ifFalse: [div digitAt: dl - 1]. - 1 to: ql do: - [:k | - "maintain quo*arg+rem=self" - "Estimate rem/div by dividing the leading to bytes of rem by dh." - "The estimate is q = qhi*16+qlo, where qhi and qlo are nibbles." - j := remDigitLength + 1 - k. - "r1 := rem digitAt: j." - (rem digitAt: j) - = dh - ifTrue: [qhi := qlo := 15 - "i.e. q=255"] - ifFalse: - ["Compute q = (r1,r2)//dh, t = (r1,r2)\\dh. - Note that r1,r2 are bytes, not nibbles. - Be careful not to generate intermediate results exceeding 13 - bits." - "r2 := (rem digitAt: j - 1)." - t := ((rem digitAt: j) - bitShift: 4) - + ((rem digitAt: j - 1) - bitShift: -4). - qhi := t // dh. - t := (t \\ dh bitShift: 4) - + ((rem digitAt: j - 1) - bitAnd: 15). - qlo := t // dh. - t := t \\ dh. - "Next compute (hi,lo) := q*dnh" - hi := qhi * dnh. - lo := qlo * dnh + ((hi bitAnd: 15) - bitShift: 4). - hi := (hi bitShift: -4) - + (lo bitShift: -8). - lo := lo bitAnd: 255. - "Correct overestimate of q. - Max of 2 iterations through loop -- see Knuth vol. 2" - r3 := j < 3 - ifTrue: [0] - ifFalse: [rem digitAt: j - 2]. - [(t < hi - or: [t = hi and: [r3 < lo]]) - and: - ["i.e. (t,r3) < (hi,lo)" - qlo := qlo - 1. - lo := lo - dnh. - lo < 0 - ifTrue: - [hi := hi - 1. - lo := lo + 256]. - hi >= dh]] - whileTrue: [hi := hi - dh]. - qlo < 0 - ifTrue: - [qhi := qhi - 1. - qlo := qlo + 16]]. - "Subtract q*div from rem" - l := j - dl. - a := 0. - 1 to: divDigitLength do: - [:i | - hi := (div digitAt: i) - * qhi. - lo := a + (rem digitAt: l) - ((hi bitAnd: 15) - bitShift: 4) - ((div digitAt: i) - * qlo). - rem digitAt: l put: lo - (lo // 256 * 256). - "sign-tolerant form of (lo bitAnd: 255)" - a := lo // 256 - (hi bitShift: -4). - l := l + 1]. - a < 0 - ifTrue: - ["Add div back into rem, decrease q by 1" - qlo := qlo - 1. - l := j - dl. - a := 0. - 1 to: divDigitLength do: - [:i | - a := (a bitShift: -8) - + (rem digitAt: l) + (div digitAt: i). - rem digitAt: l put: (a bitAnd: 255). - l := l + 1]]. - quo digitAt: ql + 1 - k put: (qhi bitShift: 4) - + qlo]. - rem := rem - digitRshift: d - bytes: 0 - lookfirst: dl. - ^ Array with: quo with: rem! Item was removed: - ----- Method: Integer>>digitLogic:op:length: (in category 'private') ----- - digitLogic: arg op: op length: len - | i result neg1 neg2 rneg z1 z2 rz b1 b2 b | - neg1 := self negative. - neg2 := arg negative. - rneg := ((neg1 - ifTrue: [-1] - ifFalse: [0]) - perform: op - with: (neg2 - ifTrue: [-1] - ifFalse: [0])) - < 0. - result := Integer new: len neg: rneg. - rz := z1 := z2 := true. - i := 0. - [(i := i + 1) <= len - or: ["mind a carry on result that might go past len digits" - rneg and: [rz - and: [result := result growby: 1. - true]]]] - whileTrue: [b1 := self digitAt: i. - neg1 - ifTrue: [b1 := z1 - ifTrue: [b1 = 0 - ifTrue: [0] - ifFalse: [z1 := false. - 256 - b1]] - ifFalse: [255 - b1]]. - b2 := arg digitAt: i. - neg2 - ifTrue: [b2 := z2 - ifTrue: [b2 = 0 - ifTrue: [0] - ifFalse: [z2 := false. - 256 - b2]] - ifFalse: [255 - b2]]. - b := b1 perform: op with: b2. - result - digitAt: i - put: (rneg - ifTrue: [rz - ifTrue: [b = 0 - ifTrue: [0] - ifFalse: [rz := false. - 256 - b]] - ifFalse: [255 - b]] - ifFalse: [b])]. - ^ result normalize! Item was removed: - ----- Method: Integer>>digitLshift: (in category 'private') ----- - digitLshift: shiftCount - | carry rShift mask len result digit byteShift bitShift highBit | - (highBit := self highBitOfMagnitude) = 0 ifTrue: [^ 0]. - len := highBit + shiftCount + 7 // 8. - result := Integer new: len neg: self negative. - byteShift := shiftCount // 8. - bitShift := shiftCount \\ 8. - bitShift = 0 ifTrue: ["Fast version for byte-aligned shifts" - ^ result - replaceFrom: byteShift + 1 - to: len - with: self - startingAt: 1]. - carry := 0. - rShift := bitShift - 8. - mask := 255 bitShift: 0 - bitShift. - 1 to: byteShift do: [:i | result digitAt: i put: 0]. - 1 to: len - byteShift do: - [:i | - digit := self digitAt: i. - result digitAt: i + byteShift put: (((digit bitAnd: mask) - bitShift: bitShift) - bitOr: carry). - carry := digit bitShift: rShift]. - ^ result! Item was removed: - ----- Method: Integer>>digitMultiply:neg: (in category 'private') ----- - digitMultiply: arg neg: ng - | selfLen argLen prod prodLen carry digit k ab | - <primitive: 'primDigitMultiplyNegative' module:'LargeIntegers'> - argLen := arg digitLength. - (argLen = 1 and: [(arg digitAt: 1) - = 0]) - ifTrue: [^ 0]. - selfLen := self digitLength. - (selfLen = 1 and: [(self digitAt: 1) - = 0]) - ifTrue: [^ 0]. - prodLen := selfLen + argLen. - prod := Integer new: prodLen neg: ng. - "prod starts out all zero" - 1 to: selfLen do: [:i | (digit := self digitAt: i) ~= 0 - ifTrue: - [k := i. - carry := 0. - "Loop invariant: 0<=carry<=0377, k=i+j-1" - 1 to: argLen do: - [:j | - ab := (arg digitAt: j) - * digit + carry + (prod digitAt: k). - carry := ab bitShift: -8. - prod digitAt: k put: (ab bitAnd: 255). - k := k + 1]. - prod digitAt: k put: carry]]. - ^ prod normalize! Item was removed: - ----- Method: Integer>>digitRshift:bytes:lookfirst: (in category 'private') ----- - digitRshift: anInteger bytes: b lookfirst: a - "Shift right 8*b+anInteger bits, 0<=n<8. - Discard all digits beyond a, and all zeroes at or below a." - | n x r f m digit count i | - n := 0 - anInteger. - x := 0. - f := n + 8. - i := a. - m := 255 bitShift: 0 - f. - digit := self digitAt: i. - [((digit bitShift: n) bitOr: x) = 0 and: [i ~= 1]] whileTrue: - [x := digit bitShift: f "Can't exceed 8 bits". - i := i - 1. - digit := self digitAt: i]. - i <= b ifTrue: [^Integer new: 0 neg: self negative]. "All bits lost" - r := Integer new: i - b neg: self negative. - count := i. - x := (self digitAt: b + 1) bitShift: n. - b + 1 to: count do: - [:j | digit := self digitAt: j + 1. - r digitAt: j - b put: (((digit bitAnd: m) bitShift: f) bitOr: x) - "Avoid values > 8 bits". - x := digit bitShift: n]. - ^r! Item was removed: - ----- Method: Integer>>digitSubtract: (in category 'private') ----- - digitSubtract: arg - | smaller larger z sum sl al ng | - <primitive: 'primDigitSubtract' module:'LargeIntegers'> - sl := self digitLength. - al := arg digitLength. - (sl = al - ifTrue: - [[(self digitAt: sl) - = (arg digitAt: sl) and: [sl > 1]] - whileTrue: [sl := sl - 1]. - al := sl. - (self digitAt: sl) - < (arg digitAt: sl)] - ifFalse: [sl < al]) - ifTrue: - [larger := arg. - smaller := self. - ng := self negative == false. - sl := al] - ifFalse: - [larger := self. - smaller := arg. - ng := self negative]. - sum := Integer new: sl neg: ng. - z := 0. - "Loop invariant is -1<=z<=1" - 1 to: sl do: - [:i | - z := z + (larger digitAt: i) - (smaller digitAt: i). - sum digitAt: i put: z - (z // 256 * 256). - "sign-tolerant form of (z bitAnd: 255)" - z := z // 256]. - ^ sum normalize! Item was removed: - ----- Method: Integer>>digitsAsFloat (in category 'private') ----- - digitsAsFloat - "private - naive conversion method. - This method should be used if and only if - Float precision + 8 >= self highBit. - This way, all floating point operations will be exact, but eventually the - last one, giving a guaranty that result will be the nearest Float." - | result n | - result := (self digitAt: (n := self digitLength)) asFloat. - [(n := n - 1) > 0] - whileTrue: [result := 256.0 * result + (self digitAt: n) asFloat]. - ^ result! Item was removed: - ----- Method: Integer>>divideByInteger: (in category 'private') ----- - divideByInteger: anInteger - "Answer an Array with quotient and remainder of division by anInteger. - the quotient is always truncated toward zero, and remainder has same sign as receiver. - Beware, the result might be un-normailzed (LargeInteger with leading zero digits)" - ^self digitDiv: anInteger - neg: self negative ~~ anInteger negative! Item was removed: - ----- Method: Integer>>even (in category 'testing') ----- - even - "Refer to the comment in Number|even." - - ^((self digitAt: 1) bitAnd: 1) = 0! Item was removed: - ----- Method: Integer>>factorial (in category 'mathematical functions') ----- - factorial - "Answer the factorial of the receiver." - - self = 0 ifTrue: [^ 1]. - self > 0 ifTrue: [^ self * (self - 1) factorial]. - self error: 'Not valid for negative integers'! Item was removed: - ----- Method: Integer>>floor (in category 'truncation and round off') ----- - floor - "Refer to the comment in Number|floor."! Item was removed: - ----- Method: Integer>>floorLog: (in category 'mathematical functions') ----- - floorLog: radix - "Unlike super, this version is exact when radix is integer" - - radix isInteger ifFalse: [^super floorLog: radix]. - self <= 0 ifTrue: [^DomainError signal: 'floorLog: is only defined for x > 0.0']. - ^(self numberOfDigitsInBase: radix) - 1! Item was removed: - ----- Method: Integer>>fractionPart (in category 'truncation and round off') ----- - fractionPart - "Added for ANSI compatibility" - ^0! Item was removed: - ----- Method: Integer>>gcd: (in category 'mathematical functions') ----- - gcd: anInteger - "See Knuth, Vol 2, 4.5.2, Algorithm L" - "Initialize" - | higher u v k uHat vHat a b c d vPrime vPrimePrime q t | - anInteger denominator = 1 ifFalse: [^anInteger gcd: self]. - higher := SmallInteger maxVal highBit. - u := self abs max: (v := anInteger abs). - v := self abs min: v. - [v class == SmallInteger] - whileFalse: - [(uHat := u bitShift: (k := higher - u highBit)) class == SmallInteger - ifFalse: - [k := k - 1. - uHat := uHat bitShift: -1]. - vHat := v bitShift: k. - a := 1. - b := 0. - c := 0. - d := 1. - "Test quotient" - [(vPrime := vHat + d) ~= 0 - and: [(vPrimePrime := vHat + c) ~= 0 and: [(q := uHat + a // vPrimePrime) = (uHat + b // vPrime)]]] - whileTrue: - ["Emulate Euclid" - c := a - (q * (a := c)). - d := b - (q * (b := d)). - vHat := uHat - (q * (uHat := vHat))]. - "Multiprecision step" - b = 0 - ifTrue: - [v := u rem: (u := v)] - ifFalse: - [t := u * a + (v * b). - v := u * c + (v * d). - u := t]]. - ^ v gcd: u! Item was removed: - ----- Method: Integer>>growby: (in category 'private') ----- - growby: n - - ^self growto: self digitLength + n! Item was removed: - ----- Method: Integer>>growto: (in category 'private') ----- - growto: n - - ^self copyto: (self species new: n)! Item was removed: - ----- Method: Integer>>hex (in category 'printing') ----- - hex - "Print the receiver as hex, prefixed with 16r. DO NOT CHANGE THIS!! The Cog VMMaker depends on this. - Consider using any of - printStringHex - printStringBase: 16 - printStringBase: 16 length: 8 padded: true - storeStringHex - storeStringBase: 16 - storeStringBase: 16 length: 11 padded: true" - ^self storeStringBase: 16! Item was removed: - ----- Method: Integer>>highBit (in category 'bit manipulation') ----- - highBit - "Answer the index of the high order bit of the receiver, or zero if the - receiver is zero. Raise an error if the receiver is negative, since - negative integers are defined to have an infinite number of leading 1's - in 2's-complement arithmetic. Use >>highBitOfMagnitude if you want to - get the highest bit of the magnitude." - - ^ self subclassResponsibility! Item was removed: - ----- Method: Integer>>highBitOfMagnitude (in category 'bit manipulation') ----- - highBitOfMagnitude - "Answer the index of the high order bit of the magnitude of the - receiver, or zero if the receiver is zero." - ^ self subclassResponsibility! Item was removed: - ----- Method: Integer>>initialGuessForNthRoot: (in category 'private') ----- - initialGuessForNthRoot: aPositiveInteger - "Use a simplistic scheme based solely on most significant bit" - ^1 bitShift: self highBitOfMagnitude + aPositiveInteger - 1 // aPositiveInteger! Item was removed: - ----- Method: Integer>>integerPart (in category 'truncation and round off') ----- - integerPart - "Added for ANSI compatibility" - ^self! Item was removed: - ----- Method: Integer>>isAnExactFloat (in category 'testing') ----- - isAnExactFloat - "Answer true if this Integer can be converted exactly to a Float" - | h | - (h := self highBitOfMagnitude) <= Float precision - ifTrue: [^ true]. - ^ h - 1 <= Float emax - and: [(self anyBitOfMagnitudeFrom: 1 to: h - Float precision) not]! Item was removed: - ----- Method: Integer>>isFraction (in category 'testing') ----- - isFraction - "Each Integer is considered as a special kind of Fraction with self as numerator and a unit denominator. - Rationale: A Fraction with a unit denominator will be automatically reduced to an Integer. - Hence Integer has to be polymorphic to Fraction." - ^true! Item was removed: - ----- Method: Integer>>isInteger (in category 'testing') ----- - isInteger - "True for all subclasses of Integer." - - ^ true! Item was removed: - ----- Method: Integer>>isLiteral (in category 'printing') ----- - isLiteral - - ^true! Item was removed: - ----- Method: Integer>>isPrime (in category 'testing') ----- - isPrime - "Answer true if the receiver is a prime number. See isProbablyPrime for a probabilistic - implementation that is much faster for large integers, and that is correct to an extremely - high statistical level of confidence (effectively deterministic)." - - | probe step limit | - self <= 3 ifTrue: [ ^self >= 2 ]. - self \\ 2 = 0 ifTrue: [ ^false ]. - self \\ 3 = 0 ifTrue: [ ^false ]. - self <= 1073741823 ifFalse: [ "1 << 30 - 1. For numbers larger than this (on 64-bit platforms) #isProbablyPrime is usually quicker." - ^self isProbablyPrime ]. - probe := 5. - step := 2. "Step will oscillate between 2 and 4 because at this point self \\ 6 is either 1 or 5." - limit := self sqrtFloor. "On 64-bit platforms this could be written as self asFloat sqrt truncated (+ 1), which is faster because it creates no intermediate objects. Knowing that self has at most 30 bits because of the check above, this value will never be larger than 32767." - [ probe <= limit ] whileTrue: [ - self \\ probe = 0 ifTrue: [ ^false ]. - probe := probe + step. - step := 6 - step ]. - ^true! Item was removed: - ----- Method: Integer>>isProbablyPrime (in category 'testing') ----- - isProbablyPrime - "See isProbablyPrimeWithK:andQ: for the algoritm description." - - | k q | - self <= 1 ifTrue: [ ^false ]. - self even ifTrue: [ ^self = 2 ]. - "Factor self into (2 raisedTo: k) * q + 1, where q odd" - q := self bitShift: -1. - k := q lowBit. - q := q bitShift: 1 - k. - "Repeat the probabilistic until false (the probability of false negative is null) or until probability is very low." - 25 timesRepeat: [ (self isProbablyPrimeWithK: k andQ: q) ifFalse: [ ^false ] ]. - "The probability of false positive after 25 iterations is less than (1/4 raisedTo: 25) < 1.0e-15" - ^true! Item was removed: - ----- Method: Integer>>isProbablyPrimeWithK:andQ: (in category 'private') ----- - isProbablyPrimeWithK: k andQ: q - "Algorithm P, probabilistic primality test, from - Knuth, Donald E. 'The Art of Computer Programming', Vol 2, - Third Edition, section 4.5.4, page 395, P1-P5 refer to Knuth description.. - Note that this is a Miller Rabin test which may answer false positives (known as pseudoprimes) for at most 1/4 of the possible bases x." - - | x j y minusOne | - "P1" - x := (self - 2) atRandom + 1. - "P2" - j := 0. - y := x raisedTo: q modulo: self. - minusOne := self - 1. - - ["P3" - y = 1 ifTrue: [^j = 0]. - y = minusOne ifTrue: [^true]. - "P4" - (j := j + 1) < k] - whileTrue: - [y := y squared \\ self]. - "P5" - ^false! Item was removed: - ----- Method: Integer>>lastDigit (in category 'system primitives') ----- - lastDigit - "Answer the last digit of the integer base 256. LargePositiveInteger uses bytes of base two number, and each is a 'digit'." - - ^self digitAt: self digitLength! Item was removed: - ----- Method: Integer>>lcm: (in category 'mathematical functions') ----- - lcm: n - "Answer the least common multiple of the receiver and n." - - ^self // (self gcd: n) * n! Item was removed: - ----- Method: Integer>>ln (in category 'mathematical functions') ----- - ln - self > 0 ifTrue: [^super ln]. - ^DomainError signal: 'ln is only defined for x > 0'! Item was removed: - ----- Method: Integer>>log (in category 'mathematical functions') ----- - log - self > 0 ifTrue: [^super log]. - ^DomainError signal: 'log is only defined for x > 0'! Item was removed: - ----- Method: Integer>>log2 (in category 'mathematical functions') ----- - log2 - self > 0 ifTrue: [^super log2]. - ^DomainError signal: 'log2 is only defined for x > 0'! Item was removed: - ----- Method: Integer>>lowBit (in category 'bit manipulation') ----- - lowBit - "Answer the index of the low order bit of this number." - - | index digit | - index := 0. - [ (digit := self digitAt: (index := index + 1)) = 0 ] whileTrue. - ^(LowBitPerByteTable at: digit) + (index - 1 * 8)! Item was removed: - ----- Method: Integer>>montgomeryDigitBase (in category 'private') ----- - montgomeryDigitBase - "Answer the base used by Montgomery algorithm." - ^1 << self montgomeryDigitLength! Item was removed: - ----- Method: Integer>>montgomeryDigitLength (in category 'private') ----- - montgomeryDigitLength - "Answer the number of bits composing a digit in Montgomery algorithm. - Primitive use either 8 or 32 bits digits" - <primitive: 'primMontgomeryDigitLength' module:'LargeIntegers'> - ^8 "Legacy plugin which did not have this primitive did use 8 bits digits"! Item was removed: - ----- Method: Integer>>montgomeryDigitMax (in category 'private') ----- - montgomeryDigitMax - "Answer the maximum value of a digit used in Montgomery algorithm." - - ^1 << self montgomeryDigitLength - 1! Item was removed: - ----- Method: Integer>>montgomeryNumberOfDigits (in category 'private') ----- - montgomeryNumberOfDigits - "Answer the number of montgomery digits required to represent the receiver." - ^self digitLength * 8 + (self montgomeryDigitLength - 1) // self montgomeryDigitLength! Item was removed: - ----- Method: Integer>>montgomeryRaisedTo:times:modulo:mInvModB: (in category 'private') ----- - montgomeryRaisedTo: n times: y modulo: m mInvModB: mInv - "Private - do a Montgomery exponentiation of self modulo m. - The operation is equivalent to (self/y raisedTo: n)*y \\ m, - with y is (b raisedTo: m montgomeryNumberOfDigits), - with (m bitAnd: b-1) * mInv \\ b = (b-1) - with b = self montgomeryDigitBase (either 1<<8 or 1<<32)" - - | pow j k w index oddPowersOfSelf square | - - "Precompute powers of self for odd bit patterns xxxx1 up to length w + 1. - The width w is chosen with respect to the total bit length of n, - such that each bit pattern will on average be encoutered P times in the whole bit sequence of n. - This costs (2 raisedTo: w) multiplications, but more will be saved later (see below)." - k := n highBit. - w := (k highBit - 1 >> 1 min: 16) max: 1. - oddPowersOfSelf := Array new: 1 << w. - oddPowersOfSelf at: 1 put: (pow := self). - square := self montgomeryTimes: self modulo: m mInvModB: mInv. - 2 to: oddPowersOfSelf size do: [:i | pow := oddPowersOfSelf at: i put: (pow montgomeryTimes: square modulo: m mInvModB: mInv)]. - - "Now exponentiate by searching precomputed bit patterns with a sliding window" - pow := y. - [k > 0] - whileTrue: - [pow := pow montgomeryTimes: pow modulo: m mInvModB: mInv. - "Skip bits set to zero (the sliding window)" - (n bitAt: k) = 0 - ifFalse: - ["Find longest odd bit pattern up to window length (w + 1)" - j := k - w max: 1. - [j < k and: [(n bitAt: j) = 0]] whileTrue: [j := j + 1]. - "We found a bit pattern of length k-j+1; - perform the square powers for each bit - (same cost as bitwise algorithm); - compute the index of this bit pattern in the precomputed powers." - index := 0. - [k > j] whileTrue: - [pow := pow montgomeryTimes: pow modulo: m mInvModB: mInv. - index := index << 1 + (n bitAt: k). - k := k - 1]. - "Perform a single multiplication for the whole bit pattern. - This saves up to (k-j) multiplications versus a naive algorithm operating bit by bit" - pow := pow montgomeryTimes: (oddPowersOfSelf at: index + 1) modulo: m mInvModB: mInv]. - k := k - 1]. - ^pow! Item was removed: - ----- Method: Integer>>montgomeryTimes:modulo:mInvModB: (in category 'private') ----- - montgomeryTimes: a modulo: m mInvModB: mInv - "Answer the result of a Montgomery multiplication - self * a * (b raisedTo: m montgomeryNumberOfDigits) inv \\ m - NOTE: it is assumed that: - self montgomeryNumberOfDigits <= m montgomeryNumberOfDigits - a montgomeryNumberOfDigits <= m montgomeryNumberOfDigits - mInv * m \\ b = (-1 \\ b) = (b-1) (this implies m odd) - where b = self montgomeryDigitBase - - Answer nil in case of absent plugin or other failure." - - <primitive: 'primMontgomeryTimesModulo' module:'LargeIntegers'> - ^nil! Item was removed: - ----- Method: Integer>>multiplyByInteger: (in category 'private') ----- - multiplyByInteger: anInteger - ^self digitMultiply: anInteger - neg: self negative ~~ anInteger negative! Item was removed: - ----- Method: Integer>>noMask: (in category 'bit manipulation') ----- - noMask: mask - "Treat the argument as a bit mask. Answer whether none of the bits that - are 1 in the argument are 1 in the receiver." - - ^0 = (self bitAnd: mask)! Item was removed: - ----- Method: Integer>>normalize (in category 'truncation and round off') ----- - normalize - "SmallInts OK; LgInts override" - ^ self! Item was removed: - ----- Method: Integer>>nthRoot: (in category 'mathematical functions') ----- - nthRoot: aPositiveInteger - "Answer the nth root of the receiver. - Answer an Integer if root is exactly this Integer, else answer the Float nearest the exact root." - - | guess excess scaled nBits | - guess := self nthRootRounded: aPositiveInteger. - excess := (guess raisedTo: aPositiveInteger) - self. - excess = 0 ifTrue: [ ^ guess ]. - - nBits := Float precision - guess highBitOfMagnitude. - nBits <= 0 ifTrue: [ ^(Fraction numerator: guess * 4 - excess sign denominator: 4) asFloat]. - - scaled := self << (nBits * aPositiveInteger). - guess := scaled nthRootRounded: aPositiveInteger. - excess := (guess raisedTo: aPositiveInteger) - scaled. - ^(Fraction numerator: guess * 4 - excess sign denominator: 1 << (nBits + 2)) asFloat! Item was removed: - ----- Method: Integer>>nthRootRounded: (in category 'mathematical functions') ----- - nthRootRounded: aPositiveInteger - "Answer the integer nearest the nth root of the receiver." - | guess | - self = 0 ifTrue: [^0]. - self negative - ifTrue: - [aPositiveInteger even ifTrue: [ ArithmeticError signal: 'Negative numbers don''t have even roots.' ]. - ^(self negated nthRootRounded: aPositiveInteger) negated]. - guess := self nthRootTruncated: aPositiveInteger. - ^(2 * guess + 1 raisedToInteger: aPositiveInteger) < (self bitShift: aPositiveInteger) - ifTrue: [guess + 1] - ifFalse: [guess]! Item was removed: - ----- Method: Integer>>nthRootTruncated: (in category 'mathematical functions') ----- - nthRootTruncated: n - "Answer the integer part of the nth root of the receiver." - | guess guessToTheNthMinusOne nextGuess | - self = 0 ifTrue: [^0]. - (n isInteger and: [n > 0]) ifFalse: [ ArithmeticError signal: 'nthRootTruncated: operand must be a strictly positive Integer' ]. - self negative - ifTrue: - [n even ifTrue: [ ArithmeticError signal: 'Negative numbers don''t have even roots.' ]. - ^(self negated nthRootTruncated: n) negated]. - guess := self initialGuessForNthRoot: n. - [ - guessToTheNthMinusOne := guess raisedToInteger: n - 1. - nextGuess := (n - 1 * guess * guessToTheNthMinusOne + self) // (guessToTheNthMinusOne * n). - nextGuess >= guess ] whileFalse: - [ guess := nextGuess ]. - ( guess raisedToInteger: n) > self ifTrue: - [ guess := guess - 1 ]. - ^guess! Item was removed: - ----- Method: Integer>>numberOfDigitsInBase: (in category 'printing') ----- - numberOfDigitsInBase: b - "Return how many digits are necessary to print this number in base b. - This does not count any place for minus sign, radix prefix or whatever. - Note that this algorithm may cost a few operations on LargeInteger." - - | nDigits q total | - self negative ifTrue: [^self negated numberOfDigitsInBase: b]. - self < b ifTrue: [^1]. - b isPowerOfTwo ifTrue: [^self highBit + b highBit - 2 quo: b highBit - 1]. - - "A conversion from base 2 to base b has to be performed. - This algorithm avoids Float computations like (self log: b) floor + 1, - 1) because they are inexact - 2) because LargeInteger might overflow - 3) because this algorithm might be cheaper than conversion" - - q := self. - total := 0. - ["Make an initial nDigits guess that is lower than or equal to required number of digits" - nDigits := b = 10 - ifTrue: [((q highBit - 1) * 1233 >> 12) + 1. "This is because (2 log)/(10 log)*4096 is slightly greater than 1233"] - ifFalse: [q highBit quo: b highBit]. - total := total + nDigits. - - "See how many digits remains above these first nDigits guess" - (q := q quo: (b raisedToInteger: nDigits)) < b] whileFalse. - ^q = 0 - ifTrue: [total] - ifFalse: [total + 1]! Item was removed: - ----- Method: Integer>>numerator (in category 'accessing') ----- - numerator - "Let an Integer be polymorphic to a Fraction. See #isFraction." - ^self! Item was removed: - ----- Method: Integer>>print:on:prefix:length:padded: (in category 'private') ----- - print: positiveNumberString on: aStream prefix: prefix length: minimum padded: zeroFlag - | padLength | - padLength := minimum - positiveNumberString size - prefix size. - padLength > 0 - ifTrue: [zeroFlag - ifTrue: [aStream nextPutAll: prefix; nextPutAll: (String new: padLength withAll: $0)] - ifFalse: [aStream nextPutAll: (String new: padLength withAll: Character space); nextPutAll: prefix]] - ifFalse: [aStream nextPutAll: prefix]. - aStream nextPutAll: positiveNumberString - ! Item was removed: - ----- Method: Integer>>printAsLiteralOn: (in category 'printing') ----- - printAsLiteralOn: aStream - ^self printOn: aStream base: 10! Item was removed: - ----- Method: Integer>>printOn: (in category 'printing') ----- - printOn: aStream - ^self printOn: aStream base: 10! Item was removed: - ----- Method: Integer>>printOn:asFixedPoint: (in category 'printing') ----- - printOn: aStream asFixedPoint: base - "assume I am a fixedpoint decimal scaled by base" - "String streamContents: [:s | 1234 printOn: s asFixedPoint: 1000]" - - | b n | - self < 0 ifTrue: [aStream nextPut: $-. - ^self negated printOn: aStream asFixedPoint: base]. - b := base. - n := self. - [aStream print: n // b. - (n := n \\ b) = 0] whileFalse: [ - b = base ifTrue: [aStream nextPut: $.]. - b := b // 10]. - ! Item was removed: - ----- Method: Integer>>printOn:base: (in category 'printing-numerative') ----- - printOn: aStream base: base - ^self subclassResponsibility! Item was removed: - ----- Method: Integer>>printOn:base:length:padded: (in category 'printing-numerative') ----- - printOn: aStream base: base length: minimum padded: zeroFlag - | prefix | - prefix := self negative ifTrue: ['-'] ifFalse: [String new]. - self print: (self abs printStringBase: base) on: aStream prefix: prefix length: minimum padded: zeroFlag - ! Item was removed: - ----- Method: Integer>>printOn:base:nDigits: (in category 'printing-numerative') ----- - printOn: aStream base: b nDigits: n - "Append a representation of this number in base b on aStream using nDigits. - self must be positive." - - self subclassResponsibility! Item was removed: - ----- Method: Integer>>printOn:base:showRadix: (in category 'printing') ----- - printOn: outputStream base: baseInteger showRadix: flagBoolean - "Write a sequence of characters that describes the receiver in radix - baseInteger with optional radix specifier. - The result is undefined if baseInteger less than 2 or greater than 36." - | tempString startPos | - #Numeric. - "2000/03/04 Harmon R. Added ANSI <integer> protocol" - - tempString := self printStringRadix: baseInteger. - flagBoolean ifTrue: [^ outputStream nextPutAll: tempString]. - startPos := (tempString indexOf: $r ifAbsent: [self error: 'radix indicator not found.']) - + 1. - self negative ifTrue: [outputStream nextPut: $-]. - outputStream nextPutAll: (tempString copyFrom: startPos to: tempString size)! Item was removed: - ----- Method: Integer>>printOn:maxDecimalPlaces: (in category 'printing') ----- - printOn: aStream maxDecimalPlaces: placesDesired - ^self printOn: aStream! Item was removed: - ----- Method: Integer>>printOn:showingDecimalPlaces: (in category 'printing') ----- - printOn: aStream showingDecimalPlaces: placesDesired - "Same as super, but provides a faster implementation because fraction part and rounding are trivial." - - self printOn: aStream base: 10. - placesDesired <= 0 - ifFalse: - [aStream nextPut: $.. - 0 printOn: aStream base: 10 length: placesDesired padded: true].! Item was removed: - ----- Method: Integer>>printPaddedWith:to: (in category 'printing') ----- - printPaddedWith: aCharacter to: anInteger - "Answer the string containing the ASCII representation of the receiver - padded on the left with aCharacter to be at least anInteger characters." - #Numeric. - "2000/03/04 Harmon R. Added Date and Time support" - ^ self - printPaddedWith: aCharacter - to: anInteger - base: 10! Item was removed: - ----- Method: Integer>>printPaddedWith:to:base: (in category 'printing') ----- - printPaddedWith: aCharacter to: anInteger base: aRadix - "Answer the string containing the ASCII representation of the receiver - padded on the left with aCharacter to be at least anInteger characters." - | aStream padding digits | - #Numeric. - "2000/03/04 Harmon R. Added Date and Time support" - aStream := WriteStream on: (String new: 10). - self - printOn: aStream - base: aRadix - showRadix: false. - digits := aStream contents. - padding := anInteger - digits size. - padding > 0 ifFalse: [^ digits]. - ^ ((String new: padding) atAllPut: aCharacter; - yourself) , digits! Item was removed: - ----- Method: Integer>>printString (in category 'printing') ----- - printString - "For Integer, prefer the stream version to the string version for efficiency" - - ^String streamContents: [:str | self printOn: str base: 10]! Item was removed: - ----- Method: Integer>>printStringBase:length:padded: (in category 'printing-numerative') ----- - printStringBase: base length: minimum padded: zeroFlag - ^String streamContents: [:s| self printOn: s base: base length: minimum padded: zeroFlag]! Item was removed: - ----- Method: Integer>>printStringHex (in category 'printing-numerative') ----- - printStringHex - ^self printStringBase: 16! Item was removed: - ----- Method: Integer>>printStringLength: (in category 'printing-numerative') ----- - printStringLength: minimal - ^self printStringLength: minimal padded: false - ! Item was removed: - ----- Method: Integer>>printStringLength:padded: (in category 'printing-numerative') ----- - printStringLength: minimal padded: zeroFlag - ^self printStringBase: 10 length: minimal padded: zeroFlag! Item was removed: - ----- Method: Integer>>printStringPadded: (in category 'printing-numerative') ----- - printStringPadded: minimal - ^self printStringLength: minimal padded: true - ! Item was removed: - ----- Method: Integer>>printStringRadix: (in category 'printing') ----- - printStringRadix: baseInteger - "Return a string containing a sequence of characters that represents the - numeric value of the receiver in the radix specified by the argument. - If the receiver is negative, a minus sign ('-') is prepended to the - sequence of characters. - The result is undefined if baseInteger less than 2 or greater than 36." - | tempString | - #Numeric. - "2000/03/04 Harmon R. Added ANSI <integer> protocol" - baseInteger = 10 - ifTrue: - [tempString := self storeStringBase: baseInteger. - self negative - ifTrue: [^ '-10r' , (tempString copyFrom: 2 to: tempString size)] - ifFalse: [^ '10r' , tempString]]. - ^ self storeStringBase: baseInteger! Item was removed: - ----- Method: Integer>>printStringRoman (in category 'printing-numerative') ----- - printStringRoman - ^String streamContents: [:stream | | integer | - integer := self negative ifTrue: [stream nextPut: $-. self negated] ifFalse: [self]. - integer // 1000 timesRepeat: [stream nextPut: $M]. - integer - romanDigits: 'MDC' for: 100 on: stream; - romanDigits: 'CLX' for: 10 on: stream; - romanDigits: 'XVI' for: 1 on: stream]! Item was removed: - ----- Method: Integer>>printTruncatedOn:showingDecimalPlaces: (in category 'printing') ----- - printTruncatedOn: aStream showingDecimalPlaces: placesDesired - "Print a representation of the receiver on aStream in decimal notation with prescribed number of places after decimal separator. - Print as if the receiver was truncated to requested precision." - - self printOn: aStream. - placesDesired > 0 - ifTrue: - [aStream nextPut: $.. - aStream next: placesDesired put: $0]! Item was removed: - ----- Method: Integer>>quo: (in category 'arithmetic') ----- - quo: aNumber - "Refer to the comment in Number quo: " - | quo | - aNumber isInteger ifTrue: - [quo := (self divideByInteger: aNumber) at: 1. - ^ quo normalize]. - ^ aNumber adaptToInteger: self andSend: #quo:! Item was removed: - ----- Method: Integer>>radix: (in category 'printing-numerative') ----- - radix: base - ^ self printStringBase: base! Item was removed: - ----- Method: Integer>>raisedTo:modulo: (in category 'mathematical functions') ----- - raisedTo: n modulo: m - "Answer the modular exponential. - Note: this implementation is optimized for case of large integers raised to large powers." - | a s mInv | - n = 0 ifTrue: [^1]. - (self >= m or: [self < 0]) ifTrue: [^self \\ m raisedTo: n modulo: m]. - n < 0 ifTrue: [^(self reciprocalModulo: m) raisedTo: n negated modulo: m]. - (n < 4096 or: [m even]) - ifTrue: - ["Overhead of Montgomery method might cost more than naive divisions, use naive" - ^self slidingLeftRightRaisedTo: n modulo: m]. - - mInv := self montgomeryDigitBase - ((m bitAnd: self montgomeryDigitMax) reciprocalModulo: self montgomeryDigitBase). - - "Initialize the result to R=self montgomeryDigitModulo raisedTo: m montgomeryNumberOfDigits" - a := (1 bitShift: m montgomeryNumberOfDigits * m montgomeryDigitLength) \\ m. - - "Montgomerize self (multiply by R)" - (s := self montgomeryTimes: (a*a \\ m) modulo: m mInvModB: mInv) - ifNil: - ["No Montgomery primitive available ? fallback to naive divisions" - ^self slidingLeftRightRaisedTo: n modulo: m]. - - "Exponentiate self*R" - a := s montgomeryRaisedTo: n times: a modulo: m mInvModB: mInv. - - "Demontgomerize the result (divide by R)" - ^a montgomeryTimes: 1 modulo: m mInvModB: mInv! Item was removed: - ----- Method: Integer>>raisedToFraction: (in category 'mathematical functions') ----- - raisedToFraction: aFraction - | root | - root := self nthRootTruncated: aFraction denominator. - (root raisedToInteger: aFraction denominator) = self ifTrue: [^root raisedToInteger: aFraction numerator]. - ^super raisedToFraction: aFraction! Item was removed: - ----- Method: Integer>>reciprocalModulo: (in category 'arithmetic') ----- - reciprocalModulo: n - "Answer an integer x such that (self * x) \\ n = 1, x > 0, x < n. - Raise an error if there is no such integer. - The algorithm is a non extended euclidean modular inversion called NINV. - It is described in this article: - 'Using an RSA Accelerator for Modular Inversion' - by Martin Seysen. See http://www.iacr.org/archive/ches2005/017.pdf" - - | u v f fPlusN b result result2 | - ((self <= 0) or: [n <= 0]) ifTrue: [self error: 'self and n must be greater than zero']. - self >= n ifTrue: [self error: 'self must be < n']. - - b := n highBit + 1. - f := 1 bitShift: b. - v := (self bitShift: b) + 1. - u := n bitShift: b. - fPlusN := f + n. - [v >= fPlusN] whileTrue: - [v := u \\ (u := v)]. - result := v - f. - (result2 := result + n) > 0 - ifFalse: [self error: 'no inverse']. - ^result positive - ifTrue: [result] - ifFalse: [result2]! Item was removed: - ----- Method: Integer>>replaceFrom:to:with:startingAt: (in category 'system primitives') ----- - replaceFrom: start to: stop with: replacement startingAt: repStart - | j | "Catches failure if LgInt replace primitive fails" - j := repStart. - start to: stop do: - [:i | - self digitAt: i put: (replacement digitAt: j). - j := j+1]! Item was removed: - ----- Method: Integer>>romanDigits:for:on: (in category 'private') ----- - romanDigits: digits for: base on: aStream - | n | - n := self \\ (base * 10) // base. - n = 9 ifTrue: [^ aStream nextPut: digits last; nextPut: digits first]. - n = 4 ifTrue: [^ aStream nextPut: digits last; nextPut: digits second]. - n > 4 ifTrue: [aStream nextPut: digits second]. - n \\ 5 timesRepeat: [aStream nextPut: digits last]! Item was removed: - ----- Method: Integer>>roundDownTo: (in category 'truncation and round off') ----- - roundDownTo: aNumber - "Overwritten to speed-up integer rounding via modulo instead of using intermediate fractions." - - aNumber isInteger ifFalse: [^ super roundDownTo: aNumber]. - ^ self - (self \\ aNumber)! Item was removed: - ----- Method: Integer>>roundTo: (in category 'truncation and round off') ----- - roundTo: aNumber - "Overwritten to speed-up integer rounding via modulo instead of using intermediate fractions." - - | rem quantum | - aNumber isInteger ifFalse: [^ super roundTo: aNumber]. - quantum := aNumber abs. - (rem := self \\ quantum) = 0 ifTrue: [^ self]. - ^ (self > 0 - ifTrue: [quantum + 1 // 2 <= rem] - ifFalse: [quantum // 2 < rem]) - ifTrue: [self + quantum - rem] - ifFalse: [self - rem] - ! Item was removed: - ----- Method: Integer>>roundUpTo: (in category 'truncation and round off') ----- - roundUpTo: aNumber - "Overwritten to speed-up integer rounding via modulo instead of using intermediate fractions." - - | rem | - aNumber isInteger ifFalse: [^ super roundUpTo: aNumber]. - ^ (rem := self \\ aNumber) ~= 0 - ifTrue: [self + aNumber - rem] - ifFalse: [self]! Item was removed: - ----- Method: Integer>>rounded (in category 'truncation and round off') ----- - rounded - "Refer to the comment in Number|rounded."! Item was removed: - ----- Method: Integer>>significantDigits: (in category 'truncation and round off') ----- - significantDigits: aNumber - "Round to preserve aNumber significant digits: - 987654321 significantDigits: 1 ==> 1000000000 - 987654321 significantDigits: 2 ==> 990000000" - | digits | - digits := self numberOfDigitsInBase: 10. - ^self roundTo: (10 raisedTo: digits - aNumber)! Item was removed: - ----- Method: Integer>>slidingLeftRightRaisedTo:modulo: (in category 'private') ----- - slidingLeftRightRaisedTo: n modulo: m - "Private - compute (self raisedTo: n) \\ m, - Note: this method has to be fast because it is generally used with large integers in cryptography. - It thus operate on exponent bits from left to right by packets with a sliding window rather than bit by bit (see below)." - - | pow j k w index oddPowersOfSelf square | - - "Precompute powers of self for odd bit patterns xxxx1 up to length w + 1. - The width w is chosen with respect to the total bit length of n, - such that each bit pattern will on average be encoutered P times in the whole bit sequence of n. - This costs (2 raisedTo: w) multiplications, but more will be saved later (see below)." - k := n highBit. - w := (k highBit - 1 >> 1 min: 16) max: 1. - oddPowersOfSelf := Array new: 1 << w. - oddPowersOfSelf at: 1 put: (pow := self). - square := self * self \\ m. - 2 to: oddPowersOfSelf size do: [:i | pow := oddPowersOfSelf at: i put: pow * square \\ m]. - - "Now exponentiate by searching precomputed bit patterns with a sliding window" - pow := 1. - [k > 0] - whileTrue: - [pow := pow * pow \\ m. - "Skip bits set to zero (the sliding window)" - (n bitAt: k) = 0 - ifFalse: - ["Find longest odd bit pattern up to window length (w + 1)" - j := k - w max: 1. - [j < k and: [(n bitAt: j) = 0]] whileTrue: [j := j + 1]. - "We found an odd bit pattern of length k-j+1; - perform the square powers for each bit - (same cost as bitwise algorithm); - compute the index of this bit pattern in the precomputed powers." - index := 0. - [k > j] whileTrue: - [pow := pow * pow \\ m. - index := index * 2 + (n bitAt: k). - k := k - 1]. - "Perform a single multiplication for the whole bit pattern. - This saves up to (k-j) multiplications versus a naive algorithm operating bit by bit" - pow := pow * (oddPowersOfSelf at: index + 1) \\ m]. - k := k - 1]. - ^pow! Item was removed: - ----- Method: Integer>>sqrtFloor (in category 'mathematical functions') ----- - sqrtFloor - "Return the integer part of the square root of self - Assume self >= 0 - The following post-conditions apply: - 1) self sqrtFloor squared <= self - 2) (self sqrtFloor + 1) squared > self" - - self subclassResponsibility! Item was removed: - ----- Method: Integer>>sqrtRem (in category 'mathematical functions') ----- - sqrtRem - "Return an array with floor sqrt and sqrt remainder. - Assume self >= 0. - The following invariants apply: - 1) self sqrtRem first squared <= self - 2) (self sqrtRem first + 1) squared > self - 3) self sqrtRem first squared + self sqrtRem last = self" - - self subclassResponsibility! Item was removed: - ----- Method: Integer>>storeOn:base: (in category 'printing-numerative') ----- - storeOn: aStream base: base - "Print a representation of the receiver on the stream - <aStream> in base <base> where - 2 <= <baseInteger> <= 16. If <base> is other than 10 - it is written first separated by $r followed by the number - like for example: 16rFCE2" - - | integer | - integer := self negative - ifTrue: [aStream nextPut: $-. self negated] - ifFalse: [self]. - base = 10 ifFalse: [aStream nextPutAll: base printString; nextPut: $r]. - aStream nextPutAll: (integer printStringBase: base). - ! Item was removed: - ----- Method: Integer>>storeOn:base:length:padded: (in category 'printing-numerative') ----- - storeOn: aStream base: base length: minimum padded: zeroFlag - | prefix | - prefix := self negative ifTrue: ['-'] ifFalse: [String new]. - base = 10 ifFalse: [prefix := prefix, base printString, 'r']. - self print: (self abs printStringBase: base) on: aStream prefix: prefix length: minimum padded: zeroFlag - ! Item was removed: - ----- Method: Integer>>storeStringBase:length:padded: (in category 'printing-numerative') ----- - storeStringBase: base length: minimum padded: zeroFlag - ^String streamContents: [:s| self storeOn: s base: base length: minimum padded: zeroFlag]! Item was removed: - ----- Method: Integer>>storeStringHex (in category 'printing-numerative') ----- - storeStringHex - ^self storeStringBase: 16! Item was removed: - ----- Method: Integer>>take: (in category 'mathematical functions') ----- - take: kk - "Return the number of combinations of (self) elements taken kk at a time. For 6 take 3, this is 6*5*4 / (1*2*3). Zero outside of Pascal's triangle. Use a trick to go faster." - " 6 take: 3 " - - | num denom | - kk < 0 ifTrue: [^ 0]. - kk > self ifTrue: [^ 0]. - num := 1. - self to: (kk max: self-kk) + 1 by: -1 do: [:factor | num := num * factor]. - denom := 1. - 1 to: (kk min: self-kk) do: [:factor | denom := denom * factor]. - ^ num // denom! Item was removed: - ----- Method: Integer>>timesRepeat: (in category 'enumerating') ----- - timesRepeat: aBlock - "Evaluate the argument, aBlock, the number of times represented by the - receiver." - - | remaining | - remaining := self. - [ (remaining := remaining - 1) >= 0 ] whileTrue: [ - aBlock value ]! Item was removed: - ----- Method: Integer>>tinyBenchmarks (in category 'benchmarks') ----- - tinyBenchmarks - "Report the results of running the two tiny Squeak benchmarks. - ar 9/10/1999: Adjusted to run at least 1 sec to get more stable results" - "0 tinyBenchmarks" - "On a 292 MHz G3 Mac: 23,000,000 bytecodes/sec; 980,000 sends/sec" - "On a 400 MHz PII/Win98: 18,000,000 bytecodes/sec; 1,100,000 sends/sec" - "On a 2800 MHz i7: 1,200,000,000 bytecodes/sec; 25,000,000 sends/sec" - "On a 2800 MHz i7 (CogVM): 1,700,000,000 bytecodes/sec; 260,000,000 sends/sec" - | t1 t2 r n1 n2 | - n1 := 1. - [t1 := Time millisecondsToRun: [n1 benchmark]. - t1 < 1000] whileTrue:[n1 := n1 * 2]. "Note: #benchmark's runtime is about O(n)" - - n2 := 28. - [t2 := Time millisecondsToRun: [r := n2 benchFib]. - t2 < 1000] whileTrue:[n2 := n2 + 1]. - "Note: #benchFib's runtime is about O(k^n), - where k is the golden number = (1 + 5 sqrt) / 2 = 1.618...." - - ^ ((n1 * 500000 * 1000) // t1 significantDigits: 2) asStringWithCommas, ' bytecodes/sec; ', - ((r * 1000) // t2 significantDigits: 2) asStringWithCommas, ' sends/sec' - ! Item was removed: - ----- Method: Integer>>truncated (in category 'truncation and round off') ----- - truncated - "Refer to the comment in Number|truncated."! Item was removed: - LargePositiveInteger variableByteSubclass: #LargeNegativeInteger - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Kernel-Numbers'! - - !LargeNegativeInteger commentStamp: '<historical>' prior: 0! - Just like LargePositiveInteger, but represents a negative number.! Item was removed: - ----- Method: LargeNegativeInteger class>>initializedInstance (in category 'as yet unclassified') ----- - initializedInstance - ^ -9876543210987654321 copy! Item was removed: - ----- Method: LargeNegativeInteger>>abs (in category 'arithmetic') ----- - abs - ^ self negated! Item was removed: - ----- Method: LargeNegativeInteger>>bitAt: (in category 'bit manipulation') ----- - bitAt: anInteger - "super would not work because we have to pretend we are in two-complement. - this has to be tricky..." - - | digitIndex bitIndex i | - digitIndex := anInteger - 1 // 8 + 1. - digitIndex > self digitLength ifTrue: [^1]. - bitIndex := (anInteger - 1 bitAnd: 2r111) + 1. - - i := 1. - [i = digitIndex - ifTrue: - ["evaluate two complement (bitInvert + 1) on the digit : - (if digitIndex > 1, we must still add 1 due to the carry). - but x bitInvert is -1-x, bitInvert+1 is just x negated..." - ^(self digitAt: digitIndex) negated bitAt: bitIndex]. - (self digitAt: i) = 0] - whileTrue: [ - "two complement (bitInvert + 1) raises a carry: - 0 bitInvert -> 2r11111111. 2r11111111 + 1 -> 0 with carry... - Thus we must inquire one digit forward" - i := i + 1]. - - "We escaped the while loop, because there is no more carry. - Do a simple bitInvert without a carry" - ^1 - ((self digitAt: digitIndex) bitAt: bitIndex)! Item was removed: - ----- Method: LargeNegativeInteger>>digitsAsFloat (in category 'private') ----- - digitsAsFloat - "super only deals with magnitude, not sign" - ^super digitsAsFloat negated! Item was removed: - ----- Method: LargeNegativeInteger>>highBit (in category 'bit manipulation') ----- - highBit - "Answer the index of the high order bit of the receiver, or zero if the - receiver is zero. Raise an error if the receiver is negative, since - negative integers are defined to have an infinite number of leading 1's - in 2's-complement arithmetic. Use >>highBitOfMagnitude if you want to - get the highest bit of the magnitude." - - ^ self shouldNotImplement! Item was removed: - ----- Method: LargeNegativeInteger>>isPowerOfTwo (in category 'testing') ----- - isPowerOfTwo - "Return true if the receiver is an integral power of two. Optimized version." - - ^false! Item was removed: - ----- Method: LargeNegativeInteger>>isPrime (in category 'testing') ----- - isPrime - - ^false! Item was removed: - ----- Method: LargeNegativeInteger>>isZero (in category 'testing') ----- - isZero - "Optimization. Answer false since receiver is less than 0." - - ^false - ! Item was removed: - ----- Method: LargeNegativeInteger>>ln (in category 'mathematical functions') ----- - ln - ^DomainError signal: 'ln is only defined for x > 0'! Item was removed: - ----- Method: LargeNegativeInteger>>log (in category 'mathematical functions') ----- - log - ^DomainError signal: 'log is only defined for x > 0'! Item was removed: - ----- Method: LargeNegativeInteger>>log2 (in category 'mathematical functions') ----- - log2 - ^DomainError signal: 'log2 is only defined for x > 0'! Item was removed: - ----- Method: LargeNegativeInteger>>negated (in category 'arithmetic') ----- - negated - ^ self copyto: (LargePositiveInteger new: self digitLength)! Item was removed: - ----- Method: LargeNegativeInteger>>negative (in category 'testing') ----- - negative - "Answer whether the receiver is mathematically negative." - - ^ true! Item was removed: - ----- Method: LargeNegativeInteger>>normalize (in category 'converting') ----- - normalize - "Check for leading zeroes and return shortened copy if so" - | sLen val len oldLen minVal | - <primitive: 'primNormalizeNegative' module: 'LargeIntegers'> - "First establish len = significant length" - len := oldLen := self digitLength. - [len = 0 ifTrue: [^0]. - (self digitAt: len) = 0] - whileTrue: [len := len - 1]. - - "Now check if in SmallInteger range. - Fast compute SmallInteger minVal digitLength" - sLen := SmallInteger minVal < -16r80000000 "we're definitely on 64bit if we are smaller than (-2 raisedTo: 31)" - ifTrue: [8] - ifFalse: [4]. - len <= sLen ifTrue: - [minVal := SmallInteger minVal. - (len < sLen - or: [(self digitAt: sLen) < minVal lastDigit]) - ifTrue: ["If high digit less, then can be small" - val := 0. - len to: 1 by: -1 do: - [:i | val := (val *256) - (self digitAt: i)]. - ^ val]. - 1 to: sLen do: "If all digits same, then = minVal" - [:i | (self digitAt: i) = (minVal digitAt: i) - ifFalse: ["Not so; return self shortened" - len < oldLen - ifTrue: [^ self growto: len] - ifFalse: [^ self]]]. - ^ minVal]. - - "Return self, or a shortened copy" - len < oldLen - ifTrue: [^ self growto: len] - ifFalse: [^ self]! Item was removed: - ----- Method: LargeNegativeInteger>>positive (in category 'testing') ----- - positive - "Answer whether the receiver is positive or equal to 0. (ST-80 protocol). - See also strictlyPositive" - - ^ false! Item was removed: - ----- Method: LargeNegativeInteger>>printOn:base: (in category 'printing') ----- - printOn: aStream base: b - "Append a representation of this number in base b on aStream." - - aStream nextPut: $-. - self abs printOn: aStream base: b! Item was removed: - ----- Method: LargeNegativeInteger>>sign (in category 'testing') ----- - sign - "Optimization. Answer -1 since receiver is less than 0." - - ^ -1 - ! Item was removed: - ----- Method: LargeNegativeInteger>>signBit (in category 'testing') ----- - signBit - "Optimization." - - ^1 - ! Item was removed: - ----- Method: LargeNegativeInteger>>sqrt (in category 'mathematical functions') ----- - sqrt - "Answer the square root of the receiver." - ^ DomainError signal: 'sqrt undefined for number less than zero.'! Item was removed: - ----- Method: LargeNegativeInteger>>strictlyPositive (in category 'testing') ----- - strictlyPositive - "Answer whether the receiver is mathematically positive." - - ^ false! Item was removed: - Integer variableByteSubclass: #LargePositiveInteger - instanceVariableNames: '' - classVariableNames: 'ThresholdForDiv21 ThresholdForMul22 ThresholdForMul33 ThresholdForSqrt ThresholdForSquaredByFourth ThresholdForSquaredByHalf' - poolDictionaries: '' - category: 'Kernel-Numbers'! - - !LargePositiveInteger commentStamp: '<historical>' prior: 0! - I represent positive integers of more than 30 bits (ie, >= 1073741824). These values are beyond the range of SmallInteger, and are encoded here as an array of 8-bit digits. Care must be taken, when new values are computed, that any result that COULD BE a SmallInteger IS a SmallInteger (see normalize). - - Note that the bit manipulation primitives, bitAnd:, bitShift:, etc., = and ~= run without failure (and therefore fast) if the value fits in 32 bits. This is a great help to the simulator.! Item was removed: - ----- Method: LargePositiveInteger class>>initializedInstance (in category 'testing') ----- - initializedInstance - ^ 12345678901234567 copy! Item was removed: - ----- Method: LargePositiveInteger class>>thresholdForDiv21 (in category 'accessing') ----- - thresholdForDiv21 - <preference: 'Threshold for division by Burnikel-Ziegler recursive split' - category: 'Arithmetic' - description: 'The number of byte-digit above which recursive division is more efficient than schoolbook division' - type: #Number> - ^ThresholdForDiv21 ifNil: [256]! Item was removed: - ----- Method: LargePositiveInteger class>>thresholdForDiv21: (in category 'accessing') ----- - thresholdForDiv21: anIntegerOrNil - "the number of byte-digit above which schoolbook division is more efficient than recursive division" - ThresholdForDiv21 := anIntegerOrNil ifNotNil: [:t | t max: Smalltalk wordSize]! Item was removed: - ----- Method: LargePositiveInteger class>>thresholdForMul22 (in category 'accessing') ----- - thresholdForMul22 - <preference: 'Threshold for multiplication by 2-way Karatsuba' - category: 'Arithmetic' - description: 'The number of byte-digit above which Karatsuba is more efficient than schoolbook' - type: #Number> - ^ThresholdForMul22 ifNil: [600]! Item was removed: - ----- Method: LargePositiveInteger class>>thresholdForMul22: (in category 'accessing') ----- - thresholdForMul22: anIntegerOrNil - "the number of byte-digit above which Karatsuba is more efficient than schoolbook" - ThresholdForMul22 := anIntegerOrNil ifNotNil: [:t | t max: Smalltalk wordSize + 1]! Item was removed: - ----- Method: LargePositiveInteger class>>thresholdForMul33 (in category 'accessing') ----- - thresholdForMul33 - <preference: 'Threshold for multiplication by 3-way Toom-Cook' - category: 'Arithmetic' - description: 'The number of byte-digit above which 3-way Toom-Cook is more efficient than Karatsuba' - type: #Number> - ^ThresholdForMul33 ifNil: [2000]! Item was removed: - ----- Method: LargePositiveInteger class>>thresholdForMul33: (in category 'accessing') ----- - thresholdForMul33: anIntegerOrNil - "the number of byte-digit above which 3-way Toom-Cook is more efficient than Karatsuba" - ThresholdForMul33 := anIntegerOrNil ifNotNil: [:t | t max: Smalltalk wordSize + 1]! Item was removed: - ----- Method: LargePositiveInteger class>>thresholdForSquaredByFourth (in category 'accessing') ----- - thresholdForSquaredByFourth - <preference: 'Threshold for squaring by 4-way Toom-Cook' - category: 'Arithmetic' - description: 'The number of byte-digit above which 4-way Toom-Cook squaring is more efficient than Karatsuba' - type: #Number> - ^ThresholdForSquaredByFourth ifNil: [800]! Item was removed: - ----- Method: LargePositiveInteger class>>thresholdForSquaredByFourth: (in category 'accessing') ----- - thresholdForSquaredByFourth: anIntegerOrNil - "the number of byte-digit above which 4-way Toom-Cook squaring is more efficient than Karatsuba" - ^ThresholdForSquaredByFourth := anIntegerOrNil ifNotNil: [:t | t max: Smalltalk wordSize]! Item was removed: - ----- Method: LargePositiveInteger class>>thresholdForSquaredByHalf (in category 'accessing') ----- - thresholdForSquaredByHalf - <preference: 'Threshold for squaring by 2-way Karatsuba' - category: 'Arithmetic' - description: 'The number of byte-digit above which Karatsuba squaring is more efficient than schoolbook multiplication' - type: #Number> - ^ThresholdForSquaredByHalf ifNil: [400]! Item was removed: - ----- Method: LargePositiveInteger class>>thresholdForSquaredByHalf: (in category 'accessing') ----- - thresholdForSquaredByHalf: anIntegerOrNil - "the number of byte-digit above which Karatsuba squaring is more efficient than schoolbook multiplication" - ^ThresholdForSquaredByHalf := anIntegerOrNil ifNotNil: [:t | t max: Smalltalk wordSize]! Item was removed: - ----- Method: LargePositiveInteger>>* (in category 'arithmetic') ----- - * anInteger - "Primitive. Multiply the receiver by the argument and answer with an - Integer result. Fail if either the argument or the result is not in 64 bit range. - Optional. See Object documentation whatIsAPrimitive." - - <primitive: 29> - ^super * anInteger! Item was removed: - ----- Method: LargePositiveInteger>>+ (in category 'arithmetic') ----- - + anInteger - "Primitive. Add the receiver to the argument and answer with an - Integer result. Fail if either the argument or the result is not in 64 bit range. - Optional. See Object documentation whatIsAPrimitive." - - <primitive: 21> - ^super + anInteger! Item was removed: - ----- Method: LargePositiveInteger>>- (in category 'arithmetic') ----- - - anInteger - "Primitive. Subtract the argument from the receiver and answer with an - Integer result. Fail if either the argument or the result is not in 64 bit range. - Optional. See Object documentation whatIsAPrimitive." - - <primitive: 22> - ^super - anInteger! Item was removed: - ----- Method: LargePositiveInteger>>/ (in category 'arithmetic') ----- - / anInteger - "Primitive. Divide the receiver by the argument and answer with the - result if the division is exact. Fail if the result is not a whole integer. - Fail if the argument is 0. Fail if either the argument or the result is not in 64 bit range. - Optional. See Object documentation whatIsAPrimitive." - - <primitive: 30> - ^super / anInteger! Item was removed: - ----- Method: LargePositiveInteger>>// (in category 'arithmetic') ----- - // anInteger - "Primitive. Divide the receiver by the argument and return the result. - Round the result down towards negative infinity to make it a whole - integer. Fail if the argument is 0. Fail if either the argument or the - result is not in 64 bit range. - Optional. See Object documentation whatIsAPrimitive." - - <primitive: 32> - ^super // anInteger! Item was removed: - ----- Method: LargePositiveInteger>>< (in category 'comparing') ----- - < anInteger - "Primitive. Compare the receiver with the argument and answer if the - receiver is less than the argument. Fail if either the argument or the - result is not in 64 bit range. - Optional. See Object documentation whatIsAPrimitive." - - <primitive: 23> - ^super < anInteger! Item was removed: - ----- Method: LargePositiveInteger>><= (in category 'comparing') ----- - <= anInteger - "Primitive. Compare the receiver with the argument and answer if the - receiver is less than or equal to the argument. Fail if the argument is - not a SmallInteger or a LargePositiveInteger in the 64 bit range. - Optional. See Object documentation whatIsAPrimitive." - - <primitive: 25> - ^super <= anInteger! Item was removed: - ----- Method: LargePositiveInteger>>> (in category 'comparing') ----- - > anInteger - "Primitive. Compare the receiver with the argument and answer if the - receiver is greater than the argument. Fail if the argument is - not a SmallInteger or a LargePositiveInteger in the 64 bit range. - Optional. See Object documentation whatIsAPrimitive." - - <primitive: 24> - ^super > anInteger! Item was removed: - ----- Method: LargePositiveInteger>>>= (in category 'comparing') ----- - >= anInteger - "Primitive. Compare the receiver with the argument and answer if the - receiver is greater than or equal to the argument. Fail if the argument - is not a SmallInteger or a LargePositiveInteger in the 64 bit range. - Optional. See Object documentation whatIsAPrimitive." - - <primitive: 26> - ^super >= anInteger! Item was removed: - ----- Method: LargePositiveInteger>>\\ (in category 'arithmetic') ----- - \\ aNumber - "Primitive. Take the receiver modulo the argument. The result is the - remainder rounded towards negative infinity, of the receiver divided - by the argument. Fail if the argument is 0. Fail if either the argument - or the result is not a SmallInteger or a LargePositiveInteger in the 64 bit range. - Optional. See Object documentation whatIsAPrimitive." - - <primitive: 31> - aNumber isInteger - ifTrue: - [| qr q r | - qr := self divideByInteger: aNumber. - q := qr first normalize. - r := qr last normalize. - ^(q negative - ifTrue: [r isZero not] - ifFalse: [q isZero and: [self negative ~~ aNumber negative]]) - ifTrue: [r + aNumber] - ifFalse: [r]]. - ^super \\ aNumber - ! Item was removed: - ----- Method: LargePositiveInteger>>\\\ (in category 'arithmetic') ----- - \\\ anInteger - "A modulo method former used in DSA. - This method is not much faster than \\ and rem: and it breaks some invariants (see super). - Usage is now deprecated and should be reserved to backward compatibility." - - ^(self digitDiv: anInteger neg: false) second! Item was removed: - ----- Method: LargePositiveInteger>>abs (in category 'arithmetic') ----- - abs! Item was removed: - ----- Method: LargePositiveInteger>>as31BitSmallInt (in category 'converting') ----- - as31BitSmallInt - "This is only for 31 bit numbers. Keep my 31 bits the same, but put them in a small int. The small int will be negative since my 31st bit is 1. We know my 31st bit is 1 because otherwise I would already be a positive small int." - - self highBit = 31 ifFalse: [self error: 'more than 31 bits can not fit in a SmallInteger']. - - ^ self - 16r80000000! Item was removed: - ----- Method: LargePositiveInteger>>asFloat (in category 'converting') ----- - asFloat - "Answer a Float that best approximates the value of the receiver. - This algorithm is optimized to process only the significant digits of a LargeInteger. - And it does honour IEEE 754 round to nearest even mode in case of excess precision (see details below)." - - "How numbers are rounded in IEEE 754 default rounding mode: - A shift is applied so that the highest 53 bits are placed before the floating point to form a significand. - The trailing bits form the fraction part placed after the floating point. - This fractional number must be rounded to the nearest integer. - If fraction part is 2r0.1, exactly between two consecutive integers, there is a tie. - The nearest even integer is chosen in this case. - Examples (First 52bits of significand are omitted for brevity): - 2r0.00001 is rounded downward to 2r0 - 2r1.00001 is rounded downward to 2r1 - 2r0.1 is a tie and rounded to 2r0 (nearest even) - 2r1.1 is a tie and rounded to 2r10 (nearest even) - 2r0.10001 is rounded upward to 2r1 - 2r1.10001 is rounded upward to 2r10 - Thus, if the next bit after floating point is 0, the significand is left unchanged. - If next bit after floating point is 1, an odd significand is always rounded upper. - An even significand is rounded upper only if the fraction part is not a tie." - - "Algorihm details: - The floating point hardware can perform the rounding correctly with several excess bits as long as there is a single inexact operation. - Note 1: the inexact flag in floating point hardware must not be trusted because in some cases the operations would be exact but would not take into account some bits that were truncated before the Floating point operations. - Note 2: the floating point hardware is presumed configured in default rounding mode." - - | significand shift excess | - - "Check how many bits excess the maximum precision of a Float significand." - excess := self highBitOfMagnitude - Float precision. - excess > 7 - ifFalse: - ["We can use naive digit by digit conversion because there will be a single inexact round off at last iteration. - But the nice thing is that Float precision + 7 excess bits = 60 which fit in a SmallInteger in Spur64. - So the best to do is to delegate this final operation" - ^self digitsAsFloat ]. - - "Remove the excess bits but seven." - significand := self bitShiftMagnitude: 7 - excess. - shift := excess - 7. - "An even significand with a single excess bit immediately following would be truncated. - But this would not be correct if above shift has truncated some extra bits. - Check this case, and move an extra bit to the last significand digit." - ((significand digitAt: 1) = 2r01000000 and: [self anyBitOfMagnitudeFrom: 1 to: shift]) - ifTrue: [significand := significand + self sign]. - - ^significand digitsAsFloat timesTwoPower: shift.! Item was removed: - ----- Method: LargePositiveInteger>>atRandom: (in category 'truncation and round off') ----- - atRandom: aRandom - "Answer a random integer from 1 to self picked from aRandom." - - ^aRandom nextLargeInt: self! Item was removed: - ----- Method: LargePositiveInteger>>bitAt: (in category 'bit manipulation') ----- - bitAt: anInteger - "Optimize super algorithm to avoid long bit operations. - Instead work on digits which are known to be SmallInteger and fast. - Note that this algorithm does not work for negative integers." - - | digitIndex bitIndex | - digitIndex := anInteger - 1 // 8 + 1. - digitIndex > self digitLength ifTrue: [^0]. - bitIndex := (anInteger - 1 bitAnd: 2r111) + 1. - ^(self digitAt: digitIndex) bitAt: bitIndex! Item was removed: - ----- Method: LargePositiveInteger>>bitReverse: (in category 'bit manipulation') ----- - bitReverse: highBit - "This implementation is faster than super" - - | digitSize reversed | - highBit < self highBit ifTrue: [ self error: 'Not enough bits.' ]. - digitSize := highBit + 7 // 8. - reversed := self class new: digitSize. - 1 to: self digitLength do: [:i | - reversed digitAt: digitSize + 1 - i put: (self digitAt: i) byteReversed]. - ^reversed normalize bitShift: highBit - (digitSize * 8)! Item was removed: - ----- Method: LargePositiveInteger>>butLowestNDigits: (in category 'private') ----- - butLowestNDigits: n - "make a new integer removing N least significant digits of self." - - ^self bitShiftMagnitude: -8 * n! Item was removed: - ----- Method: LargePositiveInteger>>copyDigitsFrom:to: (in category 'private') ----- - copyDigitsFrom: start to: stop - "Make a new integer keeping only some digits of self." - - | len slice | - start > 0 ifFalse: [^self error: 'start index should be at least 1']. - len := self digitLength. - (start > len or: [start > stop]) ifTrue: [^0]. - stop >= len - ifTrue: [start = 1 ifTrue: [^self]. - len := len - start + 1] - ifFalse: [len := stop - start + 1]. - slice := self class new: len. - slice replaceFrom: 1 to: len with: self startingAt: start. - ^slice normalize! Item was removed: - ----- Method: LargePositiveInteger>>digitAt: (in category 'system primitives') ----- - digitAt: index - "Primitive. Answer the value of an indexable field in the receiver. LargePositiveInteger uses bytes of base two number, and each is a 'digit' base 256. Fail if the argument (the index) is not an Integer or is out of bounds. Essential. See Object documentation whatIsAPrimitive." - - <primitive: 60> - self digitLength < index - ifTrue: [^0] - ifFalse: [^super at: index]! Item was removed: - ----- Method: LargePositiveInteger>>digitAt:put: (in category 'system primitives') ----- - digitAt: index put: value - "Primitive. Store the second argument (value) in the indexable field of - the receiver indicated by index. Fail if the value is negative or is larger - than 255. Fail if the index is not an Integer or is out of bounds. Answer - the value that was stored. Essential. See Object documentation - whatIsAPrimitive." - - <primitive: 61> - ^super at: index put: value! Item was removed: - ----- Method: LargePositiveInteger>>digitDiv21: (in category 'private') ----- - digitDiv21: anInteger - "This is part of the recursive division algorithm from Burnikel - Ziegler - Divide a two limbs receiver by 1 limb dividend - Each limb is decomposed in two halves of p bytes (8*p bits) - so as to continue the recursion" - - | p qr1 qr2 | - "split in two parts, rounded to upper multiple of 4" - p := (anInteger digitLength + 7 bitShift: -3) bitShift: 2. - p < self class thresholdForDiv21 ifTrue: [^(self digitDiv: anInteger neg: false) collect: #normalize]. - qr1 := (self butLowestNDigits: p) digitDiv32: anInteger. - qr2 := (self lowestNDigits: p) + (qr1 last bitShift: 8*p) digitDiv32: anInteger. - qr2 at: 1 put: (qr2 at: 1) + ((qr1 at: 1) bitShift: 8*p). - ^qr2! Item was removed: - ----- Method: LargePositiveInteger>>digitDiv32: (in category 'private') ----- - digitDiv32: anInteger - "This is part of the recursive division algorithm from Burnikel - Ziegler - Divide 3 limb (a2,a1,a0) by 2 limb (b1,b0). - Each limb is made of p bytes (8*p bits). - This step transforms the division problem into multiplication - It must use a fast multiplyByInteger: to be worth the overhead costs." - - | a2 b1 d p q qr r | - "split in two parts, rounded to upper multiple of 4" - p :=(anInteger digitLength + 7 bitShift: -3) bitShift: 2. - (a2 := self butLowestNDigits: 2*p) - < (b1 := anInteger butLowestNDigits: p) - ifTrue: - [qr := (self butLowestNDigits: p) digitDiv21: b1. - q := qr first. - r := qr last] - ifFalse: - [q := (1 bitShift: 8*p) - 1. - r := (self butLowestNDigits: p) - (b1 bitShift: 8*p) + b1]. - d := q * (anInteger lowestNDigits: p). - r := (self lowestNDigits: p) + (r bitShift: 8*p) - d. - [r < 0] - whileTrue: - [q := q - 1. - r := r + anInteger]. - ^Array with: q with: r - ! Item was removed: - ----- Method: LargePositiveInteger>>digitDivSplit: (in category 'private') ----- - digitDivSplit: anInteger - "This is the recursive division algorithm from Burnikel - Ziegler - See Fast Recursive Division - Christoph Burnikel, Joachim Ziegler - Research Report MPI-I-98-1-022, MPI Saarbrucken, Oct 1998 - https://pure.mpg.de/rest/items/item_1819444_4/component/file_2599480/content" - - | s m t a b z qr qDigits q i high low | - "round digits up to next power of 2" - s := anInteger digitLength. - m := 1 bitShift: (s - 1) highBit. - "shift so that leading bit of leading byte be 1, and digitLength power of two" - s := m * 8 - anInteger highBit. - a := self bitShift: s. - b := anInteger bitShift: s. - - "Decompose a into t limbs - each limb have m bytes - choose t such that leading bit of leading limb of a be 0" - t := (a highBit + 1 / (m * 8)) ceiling. - z := a butLowestNDigits: t - 2 * m. - i := t - 2. - qDigits := Array new: t - 1. - "and do a division of two limb by 1 limb b for each pair of limb of a" - [qr := z digitDiv21: b. - qDigits at: t - 1 - i put: qr first. - (i := i - 1) >= 0] whileTrue: - [z := (qr last bitShift: 8*m) + (a copyDigitsFrom: i * m + 1 to: i + 1 * m)]. - "recompose the quotient from digits" - t < 3 - ifTrue: - [q := 0. - qDigits do: [:qi | q := (q bitShift: 8 * m) + qi]] - ifFalse: - ["Use a O(n) reconstruction - note the interlace to avoid overlapping digits" - high := LargePositiveInteger new: t - 2 * m + qDigits first digitLength. - low := LargePositiveInteger new: t - 2 * m. - 1 to: t - 1 by: 2 do: [:k | high inplaceAddNonOverlapping: (qDigits at: k) digitShiftBy: t - 1 - k * m]. - 2 to: t - 1 by: 2 do: [:k | low inplaceAddNonOverlapping: (qDigits at: k) digitShiftBy: t - 1 - k * m]. - q := high + low]. - ^Array with: q with: (qr last bitShift: s negated)! Item was removed: - ----- Method: LargePositiveInteger>>digitLength (in category 'system primitives') ----- - digitLength - "Primitive. Answer the number of indexable fields in the receiver. This - value is the same as the largest legal subscript. Essential. See Object - documentation whatIsAPrimitive." - - <primitive: 62> - self primitiveFailed! Item was removed: - ----- Method: LargePositiveInteger>>digitMul22: (in category 'private') ----- - digitMul22: anInteger - "Multiply after decomposing each operand in two parts, using Karatsuba algorithm. - Karatsuba perform only 3 multiplications, leading to a cost O(n^3 log2) - asymptotically better than super O(n^2) for large number of digits n. - See https://en.wikipedia.org/wiki/Karatsuba_algorithm" - - | half xLow xHigh yLow yHigh low mid high | - "split each in two parts, rounded to upper multiple of 4" - half := (anInteger digitLength + 7 bitShift: -3) bitShift: 2. - xLow := self lowestNDigits: half. - xHigh := self butLowestNDigits: half. - yLow := anInteger lowestNDigits: half. - yHigh := anInteger butLowestNDigits: half. - - "Karatsuba trick: perform with 3 multiplications instead of 4" - low := xLow multiplyByInteger: yLow. - high := xHigh multiplyByInteger: yHigh. - mid := high + low + (xHigh - xLow multiplyByInteger: yLow - yHigh). - - "Sum the parts of decomposition" - ^(high isZero - ifTrue: [low] - ifFalse: [(high bitShift: 16*half) - inplaceAddNonOverlapping: low digitShiftBy: 0]) - + (mid bitShift: 8*half)! Item was removed: - ----- Method: LargePositiveInteger>>digitMul23: (in category 'private') ----- - digitMul23: anInteger - "Multiply after decomposing the receiver in 2 parts, and multiplicand in 3 parts. - Only invoke when anInteger digitLength between: 3/2 and 5/2 self digitLength. - This is a variant of Toom-Cook algorithm (see digitMul33:)" - - | half x1 x0 y2 y1 y0 y20 z3 z2 z1 z0 | - "divide self in 2 and operand in 3 parts, rounded to upper multiple of 4" - half := ( self digitLength + 7 bitShift: -3) bitShift: 2. - x1 := self butLowestNDigits: half. - x0 := self lowestNDigits: half. - y2 := anInteger butLowestNDigits: half * 2. - y1 := anInteger copyDigitsFrom: half + 1 to: half * 2. - y0 := anInteger lowestNDigits: half. - - "Toom trick: 4 multiplications instead of 6" - y20 := y2 + y0. - z3 := x1 multiplyByInteger: y2. - z2 := x0 - x1 multiplyByInteger: y20 - y1. - z1 := x0 + x1 multiplyByInteger: y20 + y1. - z0 := x0 multiplyByInteger: y0. - - "Sum the parts of decomposition" - ^z0 + ((z1 - z2 bitShift: -1) - z3 bitShift: 8*half) - + (((z1 + z2 bitShift: -1) - z0) + (z3 bitShift: 8*half) bitShift: 16 * half)! Item was removed: - ----- Method: LargePositiveInteger>>digitMul33: (in category 'private') ----- - digitMul33: anInteger - "Multiply after decomposing each operand in 3 parts, using a Toom-Cooke algorithm. - Toom-Cooke is a generalization of Karatsuba divide and conquer algorithm. - See https://en.wikipedia.org/wiki/Toom%E2%80%93Cook_multiplication - Use a Bodrato-Zanoni variant for the choice of interpolation points and matrix inversion - See What about Toom-Cook matrices optimality? - Marco Bodrato, Alberto Zanoni - Oct. 2006 - http://www.bodrato.it/papers/WhatAboutToomCookMatricesOptimality.pdf" - - | third x2 x1 x0 y2 y1 y0 y20 z4 z3 z2 z1 z0 x20 | - "divide both operands in 3 parts, rounded to upper multiple of 4" - third := anInteger digitLength + 11 // 12 bitShift: 2. - x2 := self butLowestNDigits: third * 2. - x1 := self copyDigitsFrom: third + 1 to: third * 2. - x0 := self lowestNDigits: third. - y2 := anInteger butLowestNDigits: third * 2. - y1 := anInteger copyDigitsFrom: third + 1 to: third * 2. - y0 := anInteger lowestNDigits: third. - - "Toom-3 trick: 5 multiplications instead of 9" - z0 := x0 multiplyByInteger: y0. - z4 := x2 multiplyByInteger: y2. - x20 := x2 + x0. - y20 := y2 + y0. - z1 := x20 + x1 multiplyByInteger: y20 + y1. - x20 := x20 - x1. - y20 := y20 - y1. - z2 := x20 multiplyByInteger: y20. - z3 := (x20 + x2 bitShift: 1) - x0 multiplyByInteger: (y20 + y2 bitShift: 1) - y0. - - "Sum the parts of decomposition" - z3 := z3 - z1 quo: 3. - z1 := z1 - z2 bitShift: -1. - z2 := z2 - z0. - - z3 := (z2 - z3 bitShift: -1) + (z4 bitShift: 1). - z2 := z2 + z1 - z4. - z1 := z1 - z3. - ^z0 + (z1 bitShift: 8*third) + (z2 bitShift: 16*third) + (z3 + (z4 bitShift: 8*third) bitShift: 24*third)! Item was removed: - ----- Method: LargePositiveInteger>>digitMulSplit: (in category 'private') ----- - digitMulSplit: anInteger - "multiply digits when self and anInteger have not well balanced digitlength. - in this case, it is better to split the largest (anInteger) in several parts and recompose" - - | xLen yLen split q r high mid low sizes | - yLen := anInteger digitLength. - xLen := self digitLength. - "divide in about 1.5 xLen, rounded to upper multiple of 4" - split := (xLen * 3 + 7 bitShift: -3) bitShift: 2. - - "Arrange to sum non overlapping parts" - q := yLen // split. - q < 3 ifTrue: [^(0 to: yLen - 1 by: split) detectSum: [:yShift | (self multiplyByInteger: (anInteger copyDigitsFrom: yShift + 1 to: yShift + split)) bitShift: 8 * yShift]]. - r := yLen \\ split. - "allocate enough bytes, but not too much, in order to minimise normalize cost; - we could allocate xLen + yLen for each one as well" - sizes := {q-1*split. q*split. q*split+r}. - low := Integer new: (sizes atWrap: 0 - (q\\3)) + xLen neg: self negative ~~ anInteger negative. - mid := Integer new: (sizes atWrap: 1 - (q\\3)) + xLen neg: self negative ~~ anInteger negative. - high := Integer new: (sizes atWrap: 2 - (q\\3)) + xLen neg: self negative ~~ anInteger negative. - 0 to: yLen - 1 by: 3 * split do: [:yShift | - low - inplaceAddNonOverlapping: (self multiplyByInteger: (anInteger copyDigitsFrom: yShift + 1 to: yShift + split)) - digitShiftBy: yShift]. - split to: yLen - 1 by: 3 * split do: [:yShift | - mid - inplaceAddNonOverlapping: (self multiplyByInteger: (anInteger copyDigitsFrom: yShift + 1 to: yShift + split)) - digitShiftBy: yShift]. - split * 2 to: yLen - 1 by: 3 * split do: [:yShift | - high - inplaceAddNonOverlapping: (self multiplyByInteger: (anInteger copyDigitsFrom: yShift + 1 to: yShift + split)) - digitShiftBy: yShift]. - ^high normalize + mid normalize + low normalize! Item was removed: - ----- Method: LargePositiveInteger>>divideByInteger: (in category 'private') ----- - divideByInteger: anInteger - "If length is worth, engage a recursive divide and conquer strategy, - more efficient than super" - | qr | - (anInteger digitLength < (self class thresholdForDiv21 * 2) - or: [self digitLength <= anInteger digitLength]) - ifTrue: [^ self digitDiv: anInteger neg: self negative ~~ anInteger negative]. - qr := self abs digitDivSplit: anInteger abs. - self negative ifTrue: [qr at: 2 put: qr second negated]. - self negative = anInteger negative ifFalse: [qr at: 1 put: qr first negated]. - ^qr! Item was removed: - ----- Method: LargePositiveInteger>>hash (in category 'comparing') ----- - hash - "Answer an integer value that is related to the value of the receiver. - Take care that the hash value is the same in both 32-bit and 64-bit versions. - Since the integers are by definition perfectly distributed a SmallInteger's hash is itself - (it is impossible to derive a hash function that is better distributed than the SmallIntegers - themselves). Therefore, for integers that could possibly fit in the SmallInteger range, answer - self. For values well outside of the SmallInteger range on 64-bits answer a hash that avoids - large integer arithmetic." - ^self digitLength <= 8 - ifTrue: [self] - ifFalse: - [ByteArray - hashBytes: self - startingWith: self species hash]! Item was removed: - ----- Method: LargePositiveInteger>>hashMultiply (in category 'bit manipulation') ----- - hashMultiply - "This is a multiplication by by 1664525 mod 2^28 written to avoid overflowing into large integers. - The primitive is able to perform the operation with modulo arihmetic." - <primitive: 159> - "Truncate to 28 bits and try again" - ^(self bitAnd: 16rFFFFFFF) hashMultiply! Item was removed: - ----- Method: LargePositiveInteger>>highBit (in category 'bit manipulation') ----- - highBit - "Answer the index of the high order bit of the receiver, or zero if the - receiver is zero. Raise an error if the receiver is negative, since - negative integers are defined to have an infinite number of leading 1's - in 2's-complement arithmetic. Use >>highBitOfMagnitude if you want to - get the highest bit of the magnitude." - ^ self highBitOfMagnitude! Item was removed: - ----- Method: LargePositiveInteger>>highBitOfMagnitude (in category 'bit manipulation') ----- - highBitOfMagnitude - "Answer the index of the high order bit of the magnitude of the - receiver, or zero if the receiver is zero. - This method is used for LargeNegativeIntegers as well, - since Squeak's LargeIntegers are sign/magnitude." - | realLength lastDigit | - realLength := self digitLength. - [(lastDigit := self digitAt: realLength) = 0] - whileTrue: [(realLength := realLength - 1) = 0 ifTrue: [^ 0]]. - ^ lastDigit highBitOfByte + (8 * (realLength - 1))! Item was removed: - ----- Method: LargePositiveInteger>>initialGuessForNthRoot: (in category 'private') ----- - initialGuessForNthRoot: n - "Try a divide and conquer approach for the initial guess of nth-root of receiver" - - | p high mid q s sn1 | - "Split self in high*b^n+mid*b+low" - p := ((self highBit bitShift: -1) // n) bitShift: -3. - p >= 4 ifFalse: [^super initialGuessForNthRoot: n]. - high := self butLowestNDigits: p * n. - mid := self copyDigitsFrom: p + 1 to: p * n. - - s := high nthRootTruncated: n. - sn1 := s raisedToInteger: n - 1. - q := (sn1 * s bitShift: n - 1 * 8 * p) + mid quo: (sn1 * n bitShift: n - 2 * 8 * p). - ^(s bitShift: 8 * p) + q - ! Item was removed: - ----- Method: LargePositiveInteger>>inplaceAddNonOverlapping:digitShiftBy: (in category 'private') ----- - inplaceAddNonOverlapping: anInteger digitShiftBy: p - "Beware: this will destructively replace some digits with that of anInteger. - - if self and anInteger are of same sign - (self negative = anInteger negative). - - if self and anInteger have no overlapping digits - (self anyBitOfMagnitudeFrom: 8 * p + 1 to: anInteger digitLength + p * 8) not. - - if anInteger does not overflow self digitLength - anInteger digitLength + p <= self digitLength. - then, and only then, this method can be used instead of more costly - self + (anInteger bitShift: 8 * p). - This operation is useful in divide and conquer reconstruction phase" - - self replaceFrom: p + 1 to: p + anInteger digitLength with: anInteger startingAt: 1! Item was removed: - ----- Method: LargePositiveInteger>>isLarge (in category 'testing') ----- - isLarge - ^true! Item was removed: - ----- Method: LargePositiveInteger>>isPowerOfTwo (in category 'testing') ----- - isPowerOfTwo - "Return true if the receiver is an integral power of two. Optimized version." - - | size | - 1 to: (size := self digitLength) do: [ :index | - | digit | - (digit := self digitAt: index) = 0 ifFalse: [ - ^size = index and: [ digit isPowerOfTwo ] ] ]. - ^false! Item was removed: - ----- Method: LargePositiveInteger>>isPrime (in category 'testing') ----- - isPrime - "Answer true if the receiver is a prime number. Use a probabilistic implementation that - is much faster for large integers, and that is correct to an extremely high statistical - level of confidence (effectively deterministic)." - - ^ self isProbablyPrime! Item was removed: - ----- Method: LargePositiveInteger>>isZero (in category 'testing') ----- - isZero - "Optimization. Answer false since receiver is greater than 0." - - ^false - ! Item was removed: - ----- Method: LargePositiveInteger>>ln (in category 'mathematical functions') ----- - ln - "This function is defined because super ln might overflow." - | res h | - res := super ln. - res isFinite ifTrue: [^res]. - h := self highBit. - ^2 ln * h + (self / (1 << h)) asFloat ln! Item was removed: - ----- Method: LargePositiveInteger>>log (in category 'mathematical functions') ----- - log - "This function is defined because super log might overflow." - | res h | - res := super log. - res isFinite ifTrue: [^res]. - h := self highBit. - ^2 log * h + (self / (1 << h)) asFloat log! Item was removed: - ----- Method: LargePositiveInteger>>log2 (in category 'mathematical functions') ----- - log2 - "This function is defined because super log2 might overflow." - | res h | - res := super log2. - res isFinite ifTrue: [^res]. - h := self highBit. - ^h + (self / (1 << h)) asFloat log2! Item was removed: - ----- Method: LargePositiveInteger>>lowestNDigits: (in category 'private') ----- - lowestNDigits: n - "Make a new integer keeping only n least significant digits of self" - - | low | - n >= self digitLength ifTrue: [^self]. - low := self class new: n. - low replaceFrom: 1 to: n with: self startingAt: 1. - ^low normalize! Item was removed: - ----- Method: LargePositiveInteger>>mightBeASquare (in category 'mathematical functions') ----- - mightBeASquare - "In base 16, a square number can end only with 0,1,4 or 9 and - - in case 0, only 0,1,4,9 can precede it, - - in case 4, only even numbers can precede it. - See http://en.wikipedia.org/wiki/Square_number - So, in hex, the last byte must be one of: - 00 - 10 - 40 - 90 - x1 - e4 - x9 - where x is any hex digit and e is any even digit - Also, the receiver must be an aven power of two." - | lsb | - lsb := self digitAt: 1. - ^(lsb = 0 and: [ self lowBit odd ]) "00 (and even power of 2)" - or: [ lsb = 16r40 "40" - or: [ (lsb bitAnd: 16r7) = 1 "any|1 or any|9" - or: [ (lsb bitAnd: 16r1F) = 4 "even|4" - or: [ (lsb bitAnd: 16r7F) = 16 ]]]] "10 or 90"! Item was removed: - ----- Method: LargePositiveInteger>>multiplyByInteger: (in category 'private') ----- - multiplyByInteger: anInteger - "Return the result of multiplying the receiver by the Integer argument. - This method dispatch to the fastest algorithm based on operands length." - - | xLen yLen | - "Revert to schoolbook multiplication if short" - (xLen := self digitLength) < self class thresholdForMul22 - ifTrue: [^ self digitMultiply: anInteger - neg: self negative ~~ anInteger negative]. - - "Arrange to have the receiver be the shorter and retry" - xLen > (yLen := anInteger digitLength) - ifTrue: [^ anInteger multiplyByInteger: self ]. - - "Seek for integers of about the same length, else split the long one" - yLen > (2 * xLen) ifTrue: [^self digitMulSplit: anInteger]. - - "Choose the fastest divide and conquer algorithm based on another heuristic" - xLen >= self class thresholdForMul33 ifTrue: [^self digitMul33: anInteger]. - yLen * 2 >= (3 * xLen) ifTrue: [^self digitMul23: anInteger]. - ^self digitMul22: anInteger! Item was removed: - ----- Method: LargePositiveInteger>>negated (in category 'arithmetic') ----- - negated - ^ (self copyto: (LargeNegativeInteger new: self digitLength)) - normalize "Need to normalize to catch SmallInteger minVal"! Item was removed: - ----- Method: LargePositiveInteger>>negative (in category 'testing') ----- - negative - "Answer whether the receiver is mathematically negative." - - ^ false! Item was removed: - ----- Method: LargePositiveInteger>>normalize (in category 'converting') ----- - normalize - "Check for leading zeroes and return shortened copy if so" - | sLen val len oldLen | - <primitive: 'primNormalizePositive' module:'LargeIntegers'> - "First establish len = significant length" - len := oldLen := self digitLength. - [len = 0 ifTrue: [^0]. - (self digitAt: len) = 0] - whileTrue: [len := len - 1]. - - "Now check if in SmallInteger range. Fast compute SmallInteger maxVal digitLength" - sLen := SmallInteger maxVal > 16r7FFFFFFF "we're definitely on 64bit if we are larger than (2 raisedTo: 31) - 1" - ifTrue: [8] - ifFalse: [4]. - (len <= sLen - and: [(self digitAt: sLen) <= (SmallInteger maxVal digitAt: sLen)]) - ifTrue: ["If so, return its SmallInt value" - val := 0. - len to: 1 by: -1 do: - [:i | val := (val *256) + (self digitAt: i)]. - ^ val]. - - "Return self, or a shortened copy" - len < oldLen - ifTrue: [^ self growto: len] - ifFalse: [^ self]! Item was removed: - ----- Method: LargePositiveInteger>>positive (in category 'testing') ----- - positive - "Answer whether the receiver is positive or equal to 0. (ST-80 protocol). - See also strictlyPositive" - - ^ true! Item was removed: - ----- Method: LargePositiveInteger>>printOn:base: (in category 'printing') ----- - printOn: aStream base: b - "Append a representation of this number in base b on aStream. - In order to reduce cost of LargePositiveInteger ops, split the number in approximately two equal parts in number of digits." - - | halfDigits halfPower head tail nDigitsUnderestimate qr | - "Don't engage any arithmetic if not normalized" - (self digitLength = 0 or: [(self digitAt: self digitLength) = 0]) ifTrue: [^self normalize printOn: aStream base: b]. - - nDigitsUnderestimate := b = 10 - ifTrue: [((self highBit - 1) * 1233 >> 12) + 1. "This is because (2 log)/(10 log)*4096 is slightly greater than 1233"] - ifFalse: [self highBit quo: b highBit]. - - "splitting digits with a whole power of two is more efficient" - halfDigits := 1 bitShift: nDigitsUnderestimate highBit - 2. - - halfDigits <= 1 - ifTrue: ["Hmmm, this could happen only in case of a huge base b... Let lower level fail" - ^self printOn: aStream base: b nDigits: (self numberOfDigitsInBase: b)]. - - "Separate in two halves, head and tail" - halfPower := b raisedToInteger: halfDigits. - qr := self divideByInteger: halfPower. - head := qr first normalize. - tail := qr last normalize. - - "print head" - head printOn: aStream base: b. - - "print tail without the overhead to count the digits" - tail printOn: aStream base: b nDigits: halfDigits! Item was removed: - ----- Method: LargePositiveInteger>>printOn:base:nDigits: (in category 'printing') ----- - printOn: aStream base: b nDigits: n - "Append a representation of this number in base b on aStream using n digits. - In order to reduce cost of LargePositiveInteger ops, split the number of digts approximatily in two - Should be invoked with: 0 <= self < (b raisedToInteger: n)" - - | halfPower half head tail qr | - n <= 1 ifTrue: [ - n <= 0 ifTrue: [self error: 'Number of digits n should be > 0']. - - "Note: this is to stop an infinite loop if one ever attempts to print with a huge base - This can happen because choice was to not hardcode any limit for base b - We let Character>>#digitValue: fail" - ^aStream nextPut: (Character digitValue: self) ]. - halfPower := n bitShift: -1. - half := b raisedToInteger: halfPower. - qr := self divideByInteger: half. - head := qr first normalize. - tail := qr last normalize. - head printOn: aStream base: b nDigits: n - halfPower. - tail printOn: aStream base: b nDigits: halfPower! Item was removed: - ----- Method: LargePositiveInteger>>printStringBase: (in category 'printing') ----- - printStringBase: base - "For LargeIntegers, it's faster to use the stream version. - This reproduces Number implementation to avoid speed down if one defines Integer>>#printStringBase: - This method should be removed if Integer>>#printStringBase: is removed. - Note: tests preallocating stream space with exact numberOfDigitsInBase: did not gain speed" - - ^String streamContents: [:str | self printOn: str base: base]! Item was removed: - ----- Method: LargePositiveInteger>>quo: (in category 'arithmetic') ----- - quo: anInteger - "Primitive. Divide the receiver by the argument and answer the result. - Round the result down towards zero to make it a whole integer. Fail if - the argument is 0. Fail if either the argument or the result is not a - SmallInteger or a LargePositiveInteger in the 64 bit range. - Optional. See Object documentation whatIsAPrimitive." - - <primitive: 33> - ^super quo: anInteger! Item was removed: - ----- Method: LargePositiveInteger>>readDataFrom:size: (in category 'objects from disk') ----- - readDataFrom: aDataStream size: varsOnDisk - ^(super readDataFrom: aDataStream size: varsOnDisk) normalize - ! Item was removed: - ----- Method: LargePositiveInteger>>rem: (in category 'arithmetic') ----- - rem: aNumber - "Remainder defined in terms of quo:. See super rem:. Fail if - the argument is 0. Fail if either the argument or the result is not a - SmallInteger or a LargePositiveInteger in the 64 bit range. - Optional. See Object documentation whatIsAPrimitive." - - <primitive: 20> - aNumber isInteger - ifTrue: - [| rem | - rem := (self divideByInteger: aNumber) at: 2. - ^ rem normalize]. - ^super rem: aNumber! Item was removed: - ----- Method: LargePositiveInteger>>replaceFrom:to:with:startingAt: (in category 'system primitives') ----- - replaceFrom: start to: stop with: replacement startingAt: repStart - "Primitive. This destructively replaces elements from start to stop in the receiver starting at index, repStart, in the collection, replacement. Answer the receiver. Range checks are performed in the primitive only. Optional. See Object documentation whatIsAPrimitive." - - | index replacementIndex | - <primitive: 105> - replacementIndex := repStart. - index := start. - replacement isInteger ifTrue: [ - "This branch is only here to accept SmallInteger replacements not handled by the primitive." - [ index <= stop ] whileTrue: [ - self digitAt: index put: (replacement digitAt: replacementIndex). - index := index + 1. - replacementIndex := replacementIndex + 1 ]. - ^self ]. - "Primitive compatible variant which doesn't support SmallInteger replacements." - [ index <= stop ] whileTrue: [ - self basicAt: index put: (replacement basicAt: replacementIndex). - index := index + 1. - replacementIndex := replacementIndex + 1 ]! Item was removed: - ----- Method: LargePositiveInteger>>sign (in category 'testing') ----- - sign - "Optimization. Answer 1 since receiver is greater than 0." - - ^ 1 - ! Item was removed: - ----- Method: LargePositiveInteger>>signBit (in category 'testing') ----- - signBit - "Optimization." - - ^0! Item was removed: - ----- Method: LargePositiveInteger>>sqrt (in category 'mathematical functions') ----- - sqrt - "Answer the square root of the receiver. - If the square root is exact, answer an Integer, else answer a Float approximation. - Make sure the result is correctly rounded (i.e. the nearest Float to the exact square root)" - - | floatResult integerResult guardBit highBit sr maybeExact | - maybeExact := self mightBeASquare. - self isAnExactFloat - ifTrue: - ["the sqrt of self asFloat is correctly rounded, so use it" - floatResult := self asFloat sqrt. - maybeExact ifFalse: [^floatResult]. - "Answer integerResult in case of perfect square" - integerResult := floatResult truncated. - integerResult squared = self ifTrue: [^integerResult]. - ^floatResult]. - - "Eventually use guard bits for handling correct rounding direction" - highBit := self highBit. - guardBit := highBit <= (Float precision + 1 * 2) - ifTrue: - ["Add guard bits for rounding correctly" - Float precision + 1 * 2 + 1 - highBit] - ifFalse: - [maybeExact - ifTrue: - ["Keep all the bits in case we were a perfect square" - 0] - ifFalse: - ["Remove superfluous bits that won't change the Float approximation" - Float precision + 1 - (highBit // 2)]]. - - "Get truncated sqrt and remainder for the same price" - sr := (self bitShift: guardBit * 2) sqrtRem. - - "Handle case of perfect square" - integerResult := sr first. - (maybeExact and: [sr last isZero]) ifTrue: [^integerResult bitShift: guardBit negated]. - - "Answer the best we have which is the sqrt correctly rounded at Float precision." - ^((integerResult bitShift: Float precision - integerResult highBit) - + (integerResult bitAt: integerResult highBit - Float precision)) asFloat - timesTwoPower: integerResult highBit - Float precision - guardBit! Item was removed: - ----- Method: LargePositiveInteger>>sqrtFloor (in category 'mathematical functions') ----- - sqrtFloor - "See super. Use a fast divide and conquer strategy." - - ^self sqrtRem first! Item was removed: - ----- Method: LargePositiveInteger>>sqrtRem (in category 'mathematical functions') ----- - sqrtRem - "See super. Use a divide and conquer method to perform this operation. - See Paul Zimmermann. Karatsuba Square Root. [Research Report] RR-3805, INRIA. 1999, pp.8. <inria-00072854> - https://hal.inria.fr/inria-00072854/PDF/RR-3805.pdf" - - | n qr q s r sr a3a2 a1 a0 | - "Split self in 4 digits a3,a2,a1,a0 in base b, - such that most significant digit a3 >= b/4 - It is not a problem to have a3 >= b, - so we can round b down to a whole number of bytes n" - n := (self highBit bitShift: -5) max: 1. "bitShift: -2 divide in 4 parts, bitShift: -3 round down in bytes" - a3a2 := self butLowestNDigits: n * 2. - a1 := self copyDigitsFrom: n + 1 to: n * 2. - a0 := self lowestNDigits: n. - - sr := a3a2 sqrtRem. - qr := (sr last bitShift: 8 * n) + a1 divideByInteger: (sr first bitShift: 1). - q := qr first normalize. - s := (sr first bitShift: 8 * n) + q. - r := (qr last normalize bitShift: 8 * n) + a0 - q squared. - r negative - ifTrue: - [r := (s bitShift: 1) + r - 1. - s := s - 1]. - sr at: 1 put: s; at: 2 put: r. - ^sr - ! Item was removed: - ----- Method: LargePositiveInteger>>squared (in category 'mathematical functions') ----- - squared - "Eventually use a divide and conquer algorithm to perform the multiplication" - - (self digitLength >= self class thresholdForSquaredByHalf) ifFalse: [^self * self]. - (self digitLength >= self class thresholdForSquaredByFourth) ifFalse: [^self squaredByHalf]. - ^self squaredByFourth! Item was removed: - ----- Method: LargePositiveInteger>>squaredByFourth (in category 'private') ----- - squaredByFourth - "Use a 4-way Toom-Cook divide and conquer algorithm to perform the multiplication. - See Asymmetric Squaring Formulae Jaewook Chung and M. Anwar Hasan - https://www.lirmm.fr/arith18/papers/Chung-Squaring.pdf" - - | p a0 a1 a2 a3 a02 a13 s0 s1 s2 s3 s4 s5 s6 t2 t3 | - "divide in 4 parts, rounded to upper multiple of 4" - p := (self digitLength + 15 bitShift: -4) bitShift: 2. - a3 := self butLowestNDigits: p * 3. - a2 := self copyDigitsFrom: p * 2 + 1 to: p * 3. - a1 := self copyDigitsFrom: p + 1 to: p * 2. - a0 := self lowestNDigits: p. - - "Toom-4 trick: 7 multiplications instead of 16" - a02 := a0 - a2. - a13 := a1 - a3. - s0 := a0 squared. - s1 := (a0 * a1) bitShift: 1. - s2 := (a02 + a13) * (a02 - a13). - s3 := ((a0 + a1) + (a2 + a3)) squared. - s4 := (a02 * a13) bitShift: 1. - s5 := (a3 * a2) bitShift: 1. - s6 := a3 squared. - - "Interpolation" - t2 := s1 + s5. - t3 := (s2 + s3 + s4 bitShift: -1) - t2. - s3 := t2 - s4. - s4 := t3 - s0. - s2 := t3 - s2 - s6. - - "Sum the parts of decomposition" - ^s0 + (s1 bitShift: 8*p) + (s2 + (s3 bitShift: 8*p) bitShift: 16*p) - +(s4 + (s5 bitShift: 8*p) + (s6 bitShift: 16*p) bitShift: 32*p)! Item was removed: - ----- Method: LargePositiveInteger>>squaredByHalf (in category 'private') ----- - squaredByHalf - "Use a divide and conquer algorithm to perform the multiplication. - Split in two parts like Karatsuba, but economize 2 additions by using asymetrical product." - - | half xHigh xLow low high mid | - - "Divide digits in two halves rounded tp upper multiple of 4" - half := (self digitLength + 1 bitShift: -3) bitShift: 2. - xLow := self lowestNDigits: half. - xHigh := self butLowestNDigits: half. - - "eventually use karatsuba" - low := xLow squared. - high := xHigh squared. - mid := xLow multiplyByInteger: xHigh. - - "Sum the parts of decomposition" - ^(high bitShift: 16*half) - inplaceAddNonOverlapping: low digitShiftBy: 0; - + (mid bitShift: 8*half+1)! Item was removed: - ----- Method: LargePositiveInteger>>squaredByThird (in category 'private') ----- - squaredByThird - "Use a 3-way Toom-Cook divide and conquer algorithm to perform the multiplication" - - | third x0 x1 x2 x20 z0 z1 z2 z3 z4 | - "divide in 3 parts, rounded to upper multiple of 4" - third := self digitLength + 11 // 3 bitShift: 2. - x2 := self butLowestNDigits: third * 2. - x1 := self copyDigitsFrom: third + 1 to: third * 2. - x0 := self lowestNDigits: third. - - "Toom-3 trick: 5 multiplications instead of 9" - z0 := x0 squared. - z4 := x2 squared. - x20 := x2 + x0. - z1 := (x20 + x1) squared. - x20 := x20 - x1. - z2 := x20 squared. - z3 := ((x20 + x2 bitShift: 1) - x0) squared. - - "Sum the parts of decomposition" - z3 := z3 - z1 quo: 3. - z1 := z1 - z2 bitShift: -1. - z2 := z2 - z0. - - z3 := (z2 - z3 bitShift: -1) + (z4 bitShift: 1). - z2 := z2 + z1 - z4. - z1 := z1 - z3. - ^z0 + (z1 bitShift: 8*third) + (z2 bitShift: 16*third) + (z3 + (z4 bitShift: 8*third) bitShift: 24*third)! Item was removed: - ----- Method: LargePositiveInteger>>strictlyPositive (in category 'testing') ----- - strictlyPositive - "Answer whether the receiver is mathematically positive." - - ^ true! Item was removed: - ----- Method: LargePositiveInteger>>withAtLeastNDigits: (in category 'converting') ----- - withAtLeastNDigits: desiredLength - - | new | - - self size >= desiredLength ifTrue: [^self]. - new := self class new: desiredLength. - new - replaceFrom: 1 - to: self size - with: self - startingAt: 1. - ^new! Item was removed: - ----- Method: LargePositiveInteger>>~= (in category 'comparing') ----- - ~= anInteger - "Primitive. Compare the receiver with the argument and answer if the - receiver is equal to the argument. Fail if the receiver or argument is not - an integer in the 64 bit range. - Optional. See Object documentation whatIsAPrimitive." - - <primitive: 28> - ^super ~= anInteger! Item was removed: - Object subclass: #Magnitude - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Kernel-Numbers'! - - !Magnitude commentStamp: 'sd 9/4/2005 10:14' prior: 0! - I'm the abstract class Magnitude that provides common protocol for objects that have - the ability to be compared along a linear dimension, such as dates or times. - Subclasses of Magnitude include Date, ArithmeticValue, and Time, as well as - Character and LookupKey. - - - My subclasses should implement - < aMagnitude - = aMagnitude - hash - - Here are some example of my protocol: - 3 > 4 - 5 = 6 - 100 max: 9 - 7 between: 5 and: 10 - ! Item was removed: - ----- Method: Magnitude>>< (in category 'comparing') ----- - < aMagnitude - "Answer whether the receiver is less than the argument." - - ^self subclassResponsibility! Item was removed: - ----- Method: Magnitude>><= (in category 'comparing') ----- - <= aMagnitude - "Answer whether the receiver is less than or equal to the argument." - - ^(self > aMagnitude) not! Item was removed: - ----- Method: Magnitude>><=> (in category 'sorting') ----- - <=> anotherObject - "Return a collation order of -1, 0, or 1, indicating whether I should be collated before the receiver, am equal, or after. - See also: http://en.wikipedia.org/wiki/Spaceship_operator" - - self = anotherObject ifTrue: [ ^0 ]. - self < anotherObject ifTrue: [ ^-1 ]. - ^1! Item was removed: - ----- Method: Magnitude>>= (in category 'comparing') ----- - = aMagnitude - "Compare the receiver with the argument and answer with true if the - receiver is equal to the argument. Otherwise answer false." - - ^self subclassResponsibility! Item was removed: - ----- Method: Magnitude>>> (in category 'comparing') ----- - > aMagnitude - "Answer whether the receiver is greater than the argument." - - ^aMagnitude < self! Item was removed: - ----- Method: Magnitude>>>= (in category 'comparing') ----- - >= aMagnitude - "Answer whether the receiver is greater than or equal to the argument." - - ^aMagnitude <= self! Item was removed: - ----- Method: Magnitude>>between:and: (in category 'comparing') ----- - between: min and: max - "Answer whether the receiver is less than or equal to the argument, max, - and greater than or equal to the argument, min." - - min <= self ifFalse: [ ^false ]. - ^self <= max! Item was removed: - ----- Method: Magnitude>>clampHigh: (in category 'testing') ----- - clampHigh: highMagnitude - "Answer my value, but keep it less than highMagnitude" - - ^ self min: highMagnitude! Item was removed: - ----- Method: Magnitude>>clampLow: (in category 'testing') ----- - clampLow: lowMagnitude - "Answer my value, but keep it greater than lowMagnitude" - - ^ self max: lowMagnitude! Item was removed: - ----- Method: Magnitude>>clampLow:high: (in category 'testing') ----- - clampLow: lowMagnitude high: highMagnitude - "Answer my value, but keep it between lowMagnitude and highMagnitude" - - ^ self min: highMagnitude max: lowMagnitude! Item was removed: - ----- Method: Magnitude>>hash (in category 'comparing') ----- - hash - "Hash must be redefined whenever = is redefined." - - ^self subclassResponsibility! Item was removed: - ----- Method: Magnitude>>inRangeOf:and: (in category 'comparing') ----- - inRangeOf: first and: second - "Answer whether the receiver is in the range between first and second, even if first is > second." - ^ first < second - ifTrue: - [ self - between: first - and: second ] - ifFalse: - [ self - between: second - and: first ]! Item was removed: - ----- Method: Magnitude>>max: (in category 'testing') ----- - max: aMagnitude - "Answer the receiver or the argument, whichever has the greater - magnitude." - - self > aMagnitude - ifTrue: [^self] - ifFalse: [^aMagnitude]! Item was removed: - ----- Method: Magnitude>>min: (in category 'testing') ----- - min: aMagnitude - "Answer the receiver or the argument, whichever has the lesser - magnitude." - - self < aMagnitude - ifTrue: [^self] - ifFalse: [^aMagnitude]! Item was removed: - ----- Method: Magnitude>>min:max: (in category 'testing') ----- - min: aMin max: aMax - - ^ (self min: aMin) max: aMax! Item was removed: - ----- Method: Magnitude>>putOn: (in category 'streaming') ----- - putOn: aStream - - (aStream isBinary ifTrue: [ self asByteArray ] ifFalse: [ self asString]) putOn: aStream - - ! Item was removed: - Object subclass: #Message - instanceVariableNames: 'selector args lookupClass' - classVariableNames: '' - poolDictionaries: '' - category: 'Kernel-Methods'! - - !Message commentStamp: '<historical>' prior: 0! - I represent a selector and its argument values. - - Generally, the system does not use instances of Message for efficiency reasons. However, when a message is not understood by its receiver, the interpreter will make up an instance of me in order to capture the information involved in an actual message transmission. This instance is sent it as an argument with the message doesNotUnderstand: to the receiver.! Item was removed: - ----- Method: Message class>>selector: (in category 'instance creation') ----- - selector: aSymbol - "Answer an instance of me with unary selector, aSymbol." - - ^self new setSelector: aSymbol arguments: (Array new: 0)! Item was removed: - ----- Method: Message class>>selector:argument: (in category 'instance creation') ----- - selector: aSymbol argument: anObject - "Answer an instance of me whose selector is aSymbol and single - argument is anObject." - - ^self new setSelector: aSymbol arguments: (Array with: anObject)! Item was removed: - ----- Method: Message class>>selector:arguments: (in category 'instance creation') ----- - selector: aSymbol arguments: anArray - "Answer an instance of me with selector, aSymbol, and arguments, - anArray." - - ^self new setSelector: aSymbol arguments: anArray! Item was removed: - ----- Method: Message>>= (in category 'comparing') ----- - = anObject - ^self class == anObject class - and: [selector == anObject selector "selector lookup is by identity" - and: [lookupClass == anObject lookupClass - and: [args literalEqual: anObject arguments]]]! Item was removed: - ----- Method: Message>>analogousCodeTo: (in category 'comparing') ----- - analogousCodeTo: anObject - "For MethodPropertires comparison." - ^self class == anObject class - and: [selector == anObject selector - and: [args = anObject arguments - and: [lookupClass == anObject lookupClass]]]! Item was removed: - ----- Method: Message>>argument (in category 'accessing') ----- - argument - "Answer the first (presumably sole) argument" - - ^args at: 1! Item was removed: - ----- Method: Message>>argument: (in category 'accessing') ----- - argument: newValue - "Change the first argument to newValue and answer self" - - args at: 1 put: newValue! Item was removed: - ----- Method: Message>>arguments (in category 'accessing') ----- - arguments - "Answer the arguments of the receiver." - - ^args! Item was removed: - ----- Method: Message>>hasIdenticalContentsAs: (in category 'comparing') ----- - hasIdenticalContentsAs: aMessage - "Answer if the argument's selector and arguments are identically equal to those of the receiver. - It is assumed that the argument aMessage is, in fact, a message." - selector ~~ aMessage selector ifTrue: - [^false]. - 1 to: args size do: - [:i| (args at: i) ~~ (aMessage arguments at: i) ifTrue: [^false]]. - ^true! Item was removed: - ----- Method: Message>>hash (in category 'comparing') ----- - hash - "#hash is implemented, because #= is implemented." - ^(selector hash bitXor: args hash) bitXor: lookupClass hash! Item was removed: - ----- Method: Message>>lookupClass (in category 'accessing') ----- - lookupClass - - ^ lookupClass! Item was removed: - ----- Method: Message>>lookupClass: (in category 'private') ----- - lookupClass: aClass - - lookupClass := aClass! Item was removed: - ----- Method: Message>>numArgs (in category 'accessing') ----- - numArgs - "Answer the number of arguments in this message" - - ^args size! Item was removed: - ----- Method: Message>>printOn: (in category 'printing') ----- - printOn: stream - - args isEmpty ifTrue: [^ stream nextPutAll: selector]. - args with: selector keywords do: [:arg :word | - stream nextPutAll: word. - stream space. - arg printOn: stream. - stream space. - ]. - stream skip: -1. - ! Item was removed: - ----- Method: Message>>selector (in category 'accessing') ----- - selector - "Answer the selector of the receiver." - - ^selector! Item was removed: - ----- Method: Message>>sendTo: (in category 'sending') ----- - sendTo: receiver - "answer the result of sending this message to receiver" - - ^ receiver perform: selector withArguments: args! Item was removed: - ----- Method: Message>>sends: (in category 'accessing') ----- - sends: aSelector - "answer whether this message's selector is aSelector" - - ^selector == aSelector! Item was removed: - ----- Method: Message>>sentTo: (in category 'sending') ----- - sentTo: receiver - "answer the result of sending this message to receiver" - - lookupClass == nil - ifTrue: [^ receiver perform: selector withArguments: args] - ifFalse: [^ receiver perform: selector withArguments: args inSuperclass: lookupClass]! Item was removed: - ----- Method: Message>>setSelector: (in category 'private') ----- - setSelector: aSymbol - - selector := aSymbol. - ! Item was removed: - ----- Method: Message>>setSelector:arguments: (in category 'private') ----- - setSelector: aSymbol arguments: anArray - - selector := aSymbol. - args := anArray! Item was removed: - ----- Method: Message>>storeOn: (in category 'printing') ----- - storeOn: aStream - "Refer to the comment in Object|storeOn:." - - aStream nextPut: $(; - nextPutAll: self class name; - nextPutAll: ' selector: '; - store: selector; - nextPutAll: ' arguments: '; - store: args; - nextPut: $)! Item was removed: - ProtoObject subclass: #MessageCatcher - instanceVariableNames: 'accumulator' - classVariableNames: '' - poolDictionaries: '' - category: 'Kernel-Methods'! - - !MessageCatcher commentStamp: '<historical>' prior: 0! - Any message sent to me is returned as a Message object. - - "Message catcher" creates an instance of me. - ! Item was removed: - ----- Method: MessageCatcher>>doesNotUnderstand: (in category 'as yet unclassified') ----- - doesNotUnderstand: aMessage - - accumulator ifNotNil: [accumulator add: aMessage]. - ^ aMessage! Item was removed: - ----- Method: MessageCatcher>>privAccumulator (in category 'as yet unclassified') ----- - privAccumulator - - ^ accumulator! Item was removed: - ----- Method: MessageCatcher>>privAccumulator: (in category 'as yet unclassified') ----- - privAccumulator: collection - - accumulator := collection! Item was removed: - NotImplemented subclass: #MessageNotUnderstood - instanceVariableNames: 'message receiver reachedDefaultHandler' - classVariableNames: '' - poolDictionaries: '' - category: 'Kernel-Exceptions'! - - !MessageNotUnderstood commentStamp: '<historical>' prior: 0! - This exception is provided to support Object>>doesNotUnderstand:.! Item was removed: - ----- Method: MessageNotUnderstood>>defaultAction (in category 'exceptionDescription') ----- - defaultAction - reachedDefaultHandler := true. - super defaultAction! Item was removed: - ----- Method: MessageNotUnderstood>>initialize (in category 'initialize-release') ----- - initialize - super initialize. - reachedDefaultHandler := false! Item was removed: - ----- Method: MessageNotUnderstood>>isResumable (in category 'exceptionDescription') ----- - isResumable - "Determine whether an exception is resumable." - - ^true! Item was removed: - ----- Method: MessageNotUnderstood>>message (in category 'exceptionDescription') ----- - message - "Answer the selector and arguments of the message that failed." - - ^message! Item was removed: - ----- Method: MessageNotUnderstood>>message: (in category 'exceptionBuilder') ----- - message: aMessage - - message := aMessage! Item was removed: - ----- Method: MessageNotUnderstood>>messageText (in category 'exceptionBuilder') ----- - messageText - "Return an exception's message text." - - ^messageText == nil - ifTrue: - [message == nil - ifTrue: [super messageText] - ifFalse: [message lookupClass printString, '>>', message selector asString]] - ifFalse: [messageText]! Item was removed: - ----- Method: MessageNotUnderstood>>reachedDefaultHandler (in category 'accessing') ----- - reachedDefaultHandler - ^reachedDefaultHandler! Item was removed: - ----- Method: MessageNotUnderstood>>receiver (in category 'exceptionDescription') ----- - receiver - "Answer the receiver that did not understand the message" - - ^ receiver! Item was removed: - ----- Method: MessageNotUnderstood>>receiver: (in category 'exceptionBuilder') ----- - receiver: obj - - receiver := obj! Item was removed: - Object subclass: #MessageSend - instanceVariableNames: 'receiver selector arguments' - classVariableNames: '' - poolDictionaries: '' - category: 'Kernel-Objects'! - - !MessageSend commentStamp: 'DF 5/25/2006 19:54' prior: 0! - Instances of MessageSend encapsulate message sends to objects. Arguments can be either predefined or supplied when the message send is performed. - - Use #value to perform a message send with its predefined arguments and #valueWithArguments: if additonal arguments have to supplied. - - Structure: - receiver Object -- object receiving the message send - selector Symbol -- message selector - arguments Array -- bound arguments! Item was removed: - ----- Method: MessageSend class>>receiver:selector: (in category 'instance creation') ----- - receiver: anObject selector: aSymbol - ^ self receiver: anObject selector: aSymbol arguments: #()! Item was removed: - ----- Method: MessageSend class>>receiver:selector:argument: (in category 'instance creation') ----- - receiver: anObject selector: aSymbol argument: aParameter - ^self receiver: anObject selector: aSymbol arguments: { aParameter }! Item was removed: - ----- Method: MessageSend class>>receiver:selector:arguments: (in category 'instance creation') ----- - receiver: anObject selector: aSymbol arguments: anArray - ^ self new - receiver: anObject; - selector: aSymbol; - arguments: anArray! Item was removed: - ----- Method: MessageSend>>= (in category 'comparing') ----- - = anObject - ^ anObject species == self species - and: [receiver == anObject receiver - and: [selector == anObject selector - and: [arguments = anObject arguments]]]! Item was removed: - ----- Method: MessageSend>>arguments (in category 'accessing') ----- - arguments - ^ arguments! Item was removed: - ----- Method: MessageSend>>arguments: (in category 'accessing') ----- - arguments: anArray - arguments := anArray! Item was removed: - ----- Method: MessageSend>>asMessage (in category 'converting') ----- - asMessage - ^ Message selector: selector arguments: arguments.! Item was removed: - ----- Method: MessageSend>>asMinimalRepresentation (in category 'converting') ----- - asMinimalRepresentation - ^self! Item was removed: - ----- Method: MessageSend>>collectArguments: (in category 'private') ----- - collectArguments: anArgArray - "Private" - - | staticArgs | - staticArgs := self arguments. - ^(anArgArray size = staticArgs size) - ifTrue: [anArgArray] - ifFalse: - [(staticArgs isEmpty - ifTrue: [ staticArgs := Array new: selector numArgs] - ifFalse: [staticArgs copy] ) - replaceFrom: 1 - to: (anArgArray size min: staticArgs size) - with: anArgArray - startingAt: 1]! Item was removed: - ----- Method: MessageSend>>cull: (in category 'evaluating') ----- - cull: firstArg - "Send the message with these optional arguments and answer the return value" - - selector numArgs >= 1 ifTrue: [ ^self value: firstArg ]. - ^self value! Item was removed: - ----- Method: MessageSend>>cull:cull: (in category 'evaluating') ----- - cull: firstArg cull: secondArg - "Send the message with these optional arguments and answer the return value" - - | numArgs | - (numArgs := selector numArgs) >= 2 ifTrue: [ ^self value: firstArg value: secondArg ]. - numArgs = 1 ifTrue: [ ^self value: firstArg ]. - ^self value! Item was removed: - ----- Method: MessageSend>>cull:cull:cull: (in category 'evaluating') ----- - cull: firstArg cull: secondArg cull: thirdArg - "Send the message with these optional arguments and answer the return value" - - | numArgs | - (numArgs := selector numArgs) >= 2 ifTrue: [ - numArgs >= 3 ifTrue: [ ^self value: firstArg value: secondArg value: thirdArg ]. - ^self value: firstArg value: secondArg ]. - numArgs = 1 ifTrue: [ ^self value: firstArg ]. - ^self value! Item was removed: - ----- Method: MessageSend>>cull:cull:cull:cull: (in category 'evaluating') ----- - cull: firstArg cull: secondArg cull: thirdArg cull: fourthArg - "Send the message with these optional arguments and answer the return value" - - | numArgs | - (numArgs := selector numArgs) >= 3 ifTrue: [ - numArgs >= 4 ifTrue: [ - ^self value: firstArg value: secondArg value: thirdArg value: fourthArg ]. - ^self value: firstArg value: secondArg value: thirdArg ]. - numArgs = 2 ifTrue: [ ^self value: firstArg value: secondArg ]. - numArgs = 1 ifTrue: [ ^self value: firstArg ]. - ^self value! Item was removed: - ----- Method: MessageSend>>cull:cull:cull:cull:cull: (in category 'evaluating') ----- - cull: firstArg cull: secondArg cull: thirdArg cull: fourthArg cull: fifthArg - "Send the message with these optional arguments and answer the return value" - - ^ selector numArgs caseOf: { - [5] -> [self value: firstArg value: secondArg value: thirdArg value: fourthArg value: fifthArg]. - [4] -> [self value: firstArg value: secondArg value: thirdArg value: fourthArg]. - [3] -> [self value: firstArg value: secondArg value: thirdArg]. - [2] -> [self value: firstArg value: secondArg]. - [1] -> [self value: firstArg]. - [0] -> [self value] }! Item was removed: - ----- Method: MessageSend>>hash (in category 'comparing') ----- - hash - ^ receiver hash bitXor: selector hash! Item was removed: - ----- Method: MessageSend>>isMessageSend (in category 'testing') ----- - isMessageSend - ^true - ! Item was removed: - ----- Method: MessageSend>>isReceiverOrAnyArgumentGarbage (in category 'private') ----- - isReceiverOrAnyArgumentGarbage - ^false! Item was removed: - ----- Method: MessageSend>>numArgs (in category 'accessing') ----- - numArgs - ^ selector numArgs! Item was removed: - ----- Method: MessageSend>>printOn: (in category 'printing') ----- - printOn: aStream - - aStream - nextPutAll: self class name; - nextPut: $(. - selector printOn: aStream. - aStream nextPutAll: ' -> '. - receiver printOn: aStream. - aStream nextPut: $)! Item was removed: - ----- Method: MessageSend>>receiver (in category 'accessing') ----- - receiver - ^ receiver! Item was removed: - ----- Method: MessageSend>>receiver: (in category 'accessing') ----- - receiver: anObject - receiver := anObject! Item was removed: - ----- Method: MessageSend>>selector (in category 'accessing') ----- - selector - ^ selector! Item was removed: - ----- Method: MessageSend>>selector: (in category 'accessing') ----- - selector: aSymbol - selector := aSymbol! Item was removed: - ----- Method: MessageSend>>value (in category 'evaluating') ----- - value - "Send the message and answer the return value" - - arguments ifNil: [^ receiver perform: selector]. - - ^ receiver - perform: selector - withArguments: (self collectArguments: arguments)! Item was removed: - ----- Method: MessageSend>>value: (in category 'evaluating') ----- - value: firstArg - "Send the message with these arguments and answer the return value" - - ^receiver perform: selector with: firstArg! Item was removed: - ----- Method: MessageSend>>value:value: (in category 'evaluating') ----- - value: firstArg value: secondArg - "Send the message with these arguments and answer the return value" - - ^receiver perform: selector with: firstArg with: secondArg! Item was removed: - ----- Method: MessageSend>>value:value:value: (in category 'evaluating') ----- - value: firstArg value: secondArg value: thirdArg - "Send the message with these arguments and answer the return value" - - ^receiver perform: selector with: firstArg with: secondArg with: thirdArg! Item was removed: - ----- Method: MessageSend>>value:value:value:value: (in category 'evaluating') ----- - value: firstArg value: secondArg value: thirdArg value: fourthArg - "Send the message with these arguments and answer the return value" - - ^receiver perform: selector with: firstArg with: secondArg with: thirdArg with: fourthArg! Item was removed: - ----- Method: MessageSend>>value:value:value:value:value: (in category 'evaluating') ----- - value: firstArg value: secondArg value: thirdArg value: fourthArg value: fifthArg - "Send the message with these arguments and answer the return value" - - ^receiver perform: selector with: firstArg with: secondArg with: thirdArg with: fourthArg with: fifthArg! Item was removed: - ----- Method: MessageSend>>valueOtherwise: (in category 'evaluating') ----- - valueOtherwise: aBlock - "Send the message and answer the return value" - - ^self value! Item was removed: - ----- Method: MessageSend>>valueWithArguments: (in category 'evaluating') ----- - valueWithArguments: anArray - - ^ receiver - perform: selector - withArguments: (self collectArguments: anArray)! Item was removed: - ----- Method: MessageSend>>valueWithArguments:otherwise: (in category 'evaluating') ----- - valueWithArguments: anArray otherwise: aBlock - - ^ self valueWithArguments: anArray! Item was removed: - ----- Method: MessageSend>>valueWithEnoughArguments: (in category 'evaluating') ----- - valueWithEnoughArguments: anArray - "call the selector with enough arguments from arguments and anArray" - | args | - args := Array new: selector numArgs. - args replaceFrom: 1 - to: (arguments size min: args size) - with: arguments - startingAt: 1. - args size > arguments size ifTrue: [ - args replaceFrom: arguments size + 1 - to: (arguments size + anArray size min: args size) - with: anArray - startingAt: 1. - ]. - ^ receiver perform: selector withArguments: args! Item was removed: - ----- Method: MessageSend>>valueWithPossibleArgs: (in category 'evaluating') ----- - valueWithPossibleArgs: anArray - "Send selector to the receiver with arguments in anArray. Only use enough arguments for the arity of the selector; supply nils for missing ones." - - ^receiver perform: selector withEnoughArguments: anArray! Item was removed: - ClassDescription subclass: #Metaclass - instanceVariableNames: 'thisClass' - classVariableNames: '' - poolDictionaries: '' - category: 'Kernel-Classes'! - - !Metaclass commentStamp: '<historical>' prior: 0! - My instances add instance-specific behavior to various class-describing objects in the system. This typically includes messages for initializing class variables and instance creation messages particular to a class. There is only one instance of a particular Metaclass, namely the class which is being described. A Metaclass shares the class variables of its instance. - - [Subtle] In general, the superclass hierarchy for metaclasses parallels that for classes. Thus, - Integer superclass == Number, and - Integer class superclass == Number class. - However there is a singularity at Object. Here the class hierarchy terminates, but the metaclass hierarchy must wrap around to Class, since ALL metaclasses are subclasses of Class. Thus, - Object superclass == nil, and - Object class superclass == Class. - - [Subtle detail] A class is know by name to an environment. Typically this is the SystemDictionary named Smalltalk. If we ever make lightweight classes that are not in Smalltalk, they must be in some environment. Specifically, the code that sets 'wasPresent' in name:inEnvironment:subclassOf:instanceVariableNames:variable:words:pointers:classVariableNames:poolDictionaries:category:comment:changed: must continue to work.! Item was removed: - ----- Method: Metaclass class>>isScarySelector: (in category 'anti-corruption') ----- - isScarySelector: newbieSelector - - "Return true if newbieSelector is already a part of Metaclass protocol." - (Metaclass includesSelector: newbieSelector) ifTrue: [^ true]. - (ClassDescription includesSelector: newbieSelector) ifTrue: [^ true]. - (Behavior includesSelector: newbieSelector) ifTrue: [^ true]. - ^ false - ! Item was removed: - ----- Method: Metaclass>>acceptsLoggingOfCompilation (in category 'compiling') ----- - acceptsLoggingOfCompilation - "Answer whether the receiver's method submisions and class defintions should be logged to the changes file and to the current change set. The metaclass follows the rule of the class itself. 6/18/96 sw" - - ^ thisClass acceptsLoggingOfCompilation! Item was removed: - ----- Method: Metaclass>>addInstVarName: (in category 'instance variables') ----- - addInstVarName: aString - "Add the argument, aString, as one of the receiver's instance variables." - - | fullString | - fullString := String streamContents: [:strm | - self instVarNames do: [:aString2 | strm nextPutAll: aString2; space]. - strm nextPutAll: aString]. - self instanceVariableNames: fullString! Item was removed: - ----- Method: Metaclass>>addObsoleteSubclass: (in category 'class hierarchy') ----- - addObsoleteSubclass: aClass - "Do nothing."! Item was removed: - ----- Method: Metaclass>>addSubclass: (in category 'class hierarchy') ----- - addSubclass: aClass - "Do nothing."! Item was removed: - ----- Method: Metaclass>>adoptInstance:from: (in category 'initialize-release') ----- - adoptInstance: oldInstance from: oldMetaClass - "Recreate any existing instances of the argument, oldClass, as instances of - the receiver, which is a newly changed class. Permute variables as - necessary." - thisClass class == self ifTrue:[^self error:'Metaclasses have only one instance']. - oldMetaClass isMeta ifFalse:[^self error:'Argument must be Metaclass']. - oldInstance class == oldMetaClass ifFalse:[^self error:'Not the class of argument']. - ^thisClass := self - newInstanceFrom: oldInstance - variable: self isVariable - size: self instSize - map: (self instVarMappingFrom: oldMetaClass)! Item was removed: - ----- Method: Metaclass>>allInstancesDo: (in category 'enumerating') ----- - allInstancesDo: aBlock - "There should be only one" - thisClass class == self ifTrue:[^aBlock value: thisClass]. - ^super allInstancesDo: aBlock! Item was removed: - ----- Method: Metaclass>>bindingOf: (in category 'compiling') ----- - bindingOf: varName - - ^thisClass classBindingOf: varName! Item was removed: - ----- Method: Metaclass>>bindingOf:environment: (in category 'compiling') ----- - bindingOf: varName environment: anEnvironment - ^ thisClass classBindingOf: varName environment: anEnvironment! Item was removed: - ----- Method: Metaclass>>canZapMethodDictionary (in category 'testing') ----- - canZapMethodDictionary - "Return true if it is safe to zap the method dictionary on #obsolete" - thisClass == nil - ifTrue:[^true] - ifFalse:[^thisClass canZapMethodDictionary]! Item was removed: - ----- Method: Metaclass>>category (in category 'organization') ----- - category - ^ thisClass category! Item was removed: - ----- Method: Metaclass>>classPool (in category 'pool variables') ----- - classPool - "Answer the dictionary of class variables." - - ^thisClass classPool! Item was removed: - ----- Method: Metaclass>>compilerClass (in category 'compiling') ----- - compilerClass - - ^ self theNonMetaClass metaCompilerClass! Item was removed: - ----- Method: Metaclass>>decompilerClass (in category 'compiling') ----- - decompilerClass - - ^ self theNonMetaClass metaDecompilerClass! Item was removed: - ----- Method: Metaclass>>definition (in category 'fileIn/Out') ----- - definition - "Refer to the comment in ClassDescription|definition." - - ^ String streamContents:[:strm | - strm print: self. - self traitComposition isEmpty ifFalse:[ - strm crtab; nextPutAll: 'uses: '; nextPutAll: self traitComposition asString. - ]. - strm - crtab; - nextPutAll: 'instanceVariableNames: '; - store: self instanceVariablesString]! Item was removed: - ----- Method: Metaclass>>environment (in category 'accessing') ----- - environment - ^thisClass environment! Item was removed: - ----- Method: Metaclass>>evaluatorClass (in category 'compiling') ----- - evaluatorClass - - ^ self theNonMetaClass metaEvaluatorClass! Item was removed: - ----- Method: Metaclass>>fileOutInitializerOn: (in category 'fileIn/Out') ----- - fileOutInitializerOn: aStream - (self methodDict includesKey: #initialize) ifTrue: - [aStream cr. - aStream nextChunkPut: thisClass name , ' initialize'].! Item was removed: - ----- Method: Metaclass>>fileOutOn:moveSource:toFile: (in category 'fileIn/Out') ----- - fileOutOn: aFileStream moveSource: moveSource toFile: fileIndex - ^self fileOutOn: aFileStream moveSource: moveSource toFile: fileIndex initializing: true! Item was removed: - ----- Method: Metaclass>>fileOutOn:moveSource:toFile:initializing: (in category 'fileIn/Out') ----- - fileOutOn: aFileStream moveSource: moveSource toFile: fileIndex initializing: aBool - super fileOutOn: aFileStream moveSource: moveSource toFile: fileIndex. - (aBool - and: [moveSource == false - and: [self methodDict includesKey: #initialize]]) ifTrue: - [aFileStream cr; cr; nextChunkPut: thisClass name , ' initialize'; cr]! Item was removed: - ----- Method: Metaclass>>formatterClass (in category 'printing') ----- - formatterClass - - ^ self theNonMetaClass metaFormatterClass! Item was removed: - ----- Method: Metaclass>>initializedInstance (in category 'instance creation') ----- - initializedInstance - thisClass class == self ifFalse: [^self new]. - ^thisClass! Item was removed: - ----- Method: Metaclass>>instanceVariableNames: (in category 'initialize-release') ----- - instanceVariableNames: instVarString - "Declare additional named variables for my instance." - ^(ClassBuilder new) - class: self - instanceVariableNames: instVarString! Item was removed: - ----- Method: Metaclass>>isMeta (in category 'testing') ----- - isMeta - ^ true! Item was removed: - ----- Method: Metaclass>>isObsolete (in category 'testing') ----- - isObsolete - "Return true if the receiver is obsolete" - ^thisClass == nil "Either no thisClass" - or:[thisClass class ~~ self "or I am not the class of thisClass" - or:[thisClass isObsolete]] "or my instance is obsolete"! Item was removed: - ----- Method: Metaclass>>isSystemDefined (in category 'accessing') ----- - isSystemDefined - "Answer false if I am a UniClass (an instance-specific lightweight class)" - - ^ true! Item was removed: - ----- Method: Metaclass>>name (in category 'accessing') ----- - name - "Answer a String that is the name of the receiver, either 'Metaclass' or - the name of the receiver's class followed by ' class'." - - thisClass == nil - ifTrue: [^'a Metaclass'] - ifFalse: [^thisClass name , ' class']! Item was removed: - ----- Method: Metaclass>>new (in category 'instance creation') ----- - new - "The receiver can only have one instance. Create it or complain that - one already exists." - - thisClass class ~~ self - ifTrue: [^thisClass := self basicNew] - ifFalse: [self error: 'A Metaclass should only have one instance!!']! Item was removed: - ----- Method: Metaclass>>nonTrivial (in category 'fileIn/Out') ----- - nonTrivial - "Answer whether the receiver has any methods or instance variables." - - ^ self instVarNames size > 0 or: [self methodDict size > 0 or: [self hasTraitComposition]]! Item was removed: - ----- Method: Metaclass>>objectForDataStream: (in category 'fileIn/Out') ----- - objectForDataStream: refStrm - | dp | - "I am about to be written on an object file. Write a reference to a class in Smalltalk instead." - - (refStrm insideASegment and: [self isSystemDefined not]) ifTrue: [ - ^ self]. "do trace me" - dp := DiskProxy global: self theNonMetaClass name selector: #class - args: (Array new). - refStrm replace: self with: dp. - ^ dp - ! Item was removed: - ----- Method: Metaclass>>obsoleteSubclasses (in category 'class hierarchy') ----- - obsoleteSubclasses - "Answer the receiver's subclasses." - thisClass == nil ifTrue:[^#()]. - ^thisClass obsoleteSubclasses - select:[:aSubclass| aSubclass isMeta not] - thenCollect:[:aSubclass| aSubclass class] - - "Metaclass allInstancesDo: - [:m | Compiler evaluate: 'subclasses:=nil' for: m logged: false]"! Item was removed: - ----- Method: Metaclass>>parserClass (in category 'compiling') ----- - parserClass - - ^ self theNonMetaClass metaParserClass! Item was removed: - ----- Method: Metaclass>>possibleVariablesFor:continuedFrom: (in category 'compiling') ----- - possibleVariablesFor: misspelled continuedFrom: oldResults - - ^ thisClass possibleVariablesFor: misspelled continuedFrom: oldResults - ! Item was removed: - ----- Method: Metaclass>>postCopy (in category 'copying') ----- - postCopy - "Don't share the reference to the sole instance." - - super postCopy. - thisClass := nil.! Item was removed: - ----- Method: Metaclass>>prettyPrinterClass (in category 'printing') ----- - prettyPrinterClass - - ^ self theNonMetaClass metaPrettyPrinterClass! Item was removed: - ----- Method: Metaclass>>removeInstVarName: (in category 'instance variables') ----- - removeInstVarName: aString - "Remove the argument, aString, as one of the receiver's instance variables." - - | newArray newString | - (self instVarNames includes: aString) - ifFalse: [self error: aString , ' is not one of my instance variables']. - newArray := self instVarNames copyWithout: aString. - newString := ''. - newArray do: [:aString2 | newString := aString2 , ' ' , newString]. - self instanceVariableNames: newString! Item was removed: - ----- Method: Metaclass>>removeObsoleteSubclass: (in category 'class hierarchy') ----- - removeObsoleteSubclass: aClass - "Do nothing."! Item was removed: - ----- Method: Metaclass>>removeSubclass: (in category 'class hierarchy') ----- - removeSubclass: aClass - "Do nothing."! Item was removed: - ----- Method: Metaclass>>replaceObsoleteInstanceWith: (in category 'private') ----- - replaceObsoleteInstanceWith: newInstance - thisClass class == self ifTrue:[^self error:'I am fine, thanks']. - newInstance class == self ifFalse:[^self error:'Not an instance of me']. - thisClass := newInstance.! Item was removed: - ----- Method: Metaclass>>soleInstance (in category 'accessing') ----- - soleInstance - "The receiver has only one instance. Answer it." - - ^thisClass! Item was removed: - ----- Method: Metaclass>>storeDataOn: (in category 'fileIn/Out') ----- - storeDataOn: aDataStream - "I don't get stored. Use a DiskProxy" - - (aDataStream insideASegment and: [self isSystemDefined not]) ifTrue: [ - ^ super storeDataOn: aDataStream]. "do trace me" - self error: 'use a DiskProxy to store a Class'! Item was removed: - ----- Method: Metaclass>>subclasses (in category 'class hierarchy') ----- - subclasses - "Answer the receiver's subclasses." - thisClass == nil ifTrue:[^#()]. - ^thisClass subclasses - select:[:aSubclass| aSubclass isMeta not] - thenCollect:[:aSubclass| aSubclass class] - - "Metaclass allInstancesDo: - [:m | Compiler evaluate: 'subclasses:=nil' for: m logged: false]"! Item was removed: - ----- Method: Metaclass>>subclassesDo: (in category 'class hierarchy') ----- - subclassesDo: aBlock - "Evaluate aBlock for each of the receiver's immediate subclasses." - thisClass subclassesDo:[:aSubclass| - "The following test is for Class class which has to exclude - the Metaclasses being subclasses of Class." - aSubclass isMeta ifFalse:[aBlock value: aSubclass class]].! Item was removed: - ----- Method: Metaclass>>subclassesDoGently: (in category 'class hierarchy') ----- - subclassesDoGently: aBlock - "Evaluate aBlock for each of the receiver's immediate subclasses." - thisClass subclassesDo: [:aSubclass | - "The following test is for Class class which has to exclude - the Metaclasses being subclasses of Class." - aSubclass isInMemory ifTrue: [ - aSubclass isMeta ifFalse: [aBlock value: aSubclass class]]].! Item was removed: - ----- Method: Metaclass>>theMetaClass (in category 'accessing parallel hierarchy') ----- - theMetaClass - "Sent to a class or metaclass, always return the metaclass" - - ^self! Item was removed: - ----- Method: Metaclass>>theNonMetaClass (in category 'accessing parallel hierarchy') ----- - theNonMetaClass - "Sent to a class or metaclass, always return the class" - - ^thisClass! Item was removed: - ----- Method: Metaclass>>uses:instanceVariableNames: (in category 'initialize-release') ----- - uses: aTraitCompositionOrArray instanceVariableNames: instVarString - | newComposition newMetaClass copyOfOldMetaClass | - - copyOfOldMetaClass := self copy. - newMetaClass := self instanceVariableNames: instVarString. - - newComposition := aTraitCompositionOrArray asTraitComposition. - newMetaClass setTraitComposition: newComposition. - - SystemChangeNotifier uniqueInstance - classDefinitionChangedFrom: copyOfOldMetaClass to: newMetaClass! Item was removed: - ----- Method: Metaclass>>wantsChangeSetLogging (in category 'compiling') ----- - wantsChangeSetLogging - "Answer whether code submitted for the receiver should be remembered by the changeSet mechanism.The metaclass follows the rule of the class itself. 7/12/96 sw" - - ^ thisClass wantsChangeSetLogging! Item was removed: - ----- Method: Metaclass>>wantsRecompilationProgressReported (in category 'compiling') ----- - wantsRecompilationProgressReported - "The metaclass follows the rule of the class itself." - - ^ thisClass wantsRecompilationProgressReported! Item was removed: - ----- Method: Metaclass>>whichSelectorsStoreInto: (in category 'testing') ----- - whichSelectorsStoreInto: varName - "Answer a collection of selectors whose methods access the argument, varName, as a named class variable. Or let super try with a named instance variable." - | ref | - ref := self classPool - associationAt: varName - ifAbsent: [ ^ super whichSelectorsStoreInto: varName ]. - ^self methodDict keys select: [:aSelector | (self methodDict at: aSelector) writesRef: ref ]! Item was removed: - Dictionary variableSubclass: #MethodDictionary - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Kernel-Methods'! - - !MethodDictionary commentStamp: 'nice 2/1/2011 02:47' prior: 0! - I am a special dictionary holding methods. I am just like a normal Dictionary, except that I am implemented differently. Each Class has an instance of MethodDictionary to hold the correspondence between selectors (names of methods) and methods themselves. - - In a normal Dictionary, the instance variable 'array' holds an array of Associations. Since there are thousands of methods in the system, these Associations waste space. - - Each MethodDictionary is a variable object, with the list of keys (selector Symbols) in the variable part of the instance. The variable 'array' holds the values, which are CompiledMethods. - - I also maintain the following invariant: (self basicAt: index) isNil = (array at: index) isNil.! Item was removed: - ----- Method: MethodDictionary class>>compactAllInstances (in category 'initialize-release') ----- - compactAllInstances - - | instancesToExchange newInstances | - instancesToExchange := Array streamContents: [ :oldStream | - newInstances := Array streamContents: [ :newStream | - self allInstances do: [ :each | - each isReadOnlyObject ifFalse: [ - | newInstance | - newInstance := each compactWithoutBecome. - newInstance capacity = each capacity - ifTrue: [ each copyFrom: newInstance ] - ifFalse: [ - oldStream nextPut: each. - newStream nextPut: newInstance ] ] ] ] ]. - instancesToExchange elementsForwardIdentityTo: newInstances! Item was removed: - ----- Method: MethodDictionary class>>new (in category 'instance creation') ----- - new - "Create a new instance with 32 slots, which can hold at most 24 methods before growing is necessary." - - ^self newForCapacity: 32! Item was removed: - ----- Method: MethodDictionary class>>new: (in category 'instance creation') ----- - new: numberOfElements - "Create an instance large enough to hold numberOfElements methods without growing." - - ^self newForCapacity: (self sizeFor: numberOfElements)! Item was removed: - ----- Method: MethodDictionary class>>newForCapacity: (in category 'private') ----- - newForCapacity: capacity - "Create an instance with the given capacity which must be a power of two." - - ^(self basicNew: capacity) initialize: capacity! Item was removed: - ----- Method: MethodDictionary class>>sizeFor: (in category 'sizing') ----- - sizeFor: numberOfElements - "Return the minimum capacity of a dictionary that can hold numberOfElements elements. At least 25% of the array must be empty and the return value must be a power of 2." - - ^(numberOfElements * 4 // 3 max: 1) asLargerPowerOfTwo! Item was removed: - ----- Method: MethodDictionary>>add: (in category 'adding') ----- - add: anAssociation - - self at: anAssociation key put: anAssociation value. - ^anAssociation! Item was removed: - ----- Method: MethodDictionary>>associationAt:ifAbsent: (in category 'accessing') ----- - associationAt: key ifAbsent: aBlock - "Answer the association with the given key. - If key is not found, return the result of evaluating aBlock." - - ^(array at: (self scanFor: key)) - ifNil: [ aBlock value ] - ifNotNil: [ :value | key -> value ]! Item was removed: - ----- Method: MethodDictionary>>associationsDo: (in category 'enumeration') ----- - associationsDo: aBlock - - tally = 0 ifTrue: [ ^self ]. - 1 to: self basicSize do: [ :i | - (self basicAt: i) ifNotNil: [ :key | - aBlock value: (Association key: key value: (array at: i)) ] ]! Item was removed: - ----- Method: MethodDictionary>>at:ifAbsent: (in category 'accessing') ----- - at: key ifAbsent: aBlock - - ^(array at: (self scanFor: key)) ifNil: [ aBlock value ]! Item was removed: - ----- Method: MethodDictionary>>at:ifPresent: (in category 'accessing') ----- - at: key ifPresent: aBlock - "Lookup the given key in the receiver. If it is present, answer the value of evaluating the given block with the value associated with the key. Otherwise, answer nil." - - ^(array at: (self scanFor: key)) ifNotNil: [ :value | aBlock value: value ]! Item was removed: - ----- Method: MethodDictionary>>at:ifPresent:ifAbsent: (in category 'accessing') ----- - at: key ifPresent: oneArgBlock ifAbsent: absentBlock - "Lookup the given key in the receiver. If it is present, answer the - value of evaluating the oneArgBlock with the value associated - with the key, otherwise answer the value of absentBlock." - ^(array at: (self scanFor: key)) - ifNil: [absentBlock value] - ifNotNil: [:method| oneArgBlock value: method]! Item was removed: - ----- Method: MethodDictionary>>at:ifPresent:ifAbsentPut: (in category 'accessing') ----- - at: key ifPresent: oneArgBlock ifAbsentPut: absentBlock - "Lookup the given key in the receiver. If it is present, answer the value of - evaluating oneArgBlock with the value associated with the key. Otherwise - add the value of absentBlock under the key, and answer that value." - - | index value | - index := self scanFor: key. - (array at: index) ifNotNil: [ :element | ^oneArgBlock value: element value]. - value := absentBlock value. - self - basicAt: index put: key; - atNewIndex: index put: value. - ^value! Item was removed: - ----- Method: MethodDictionary>>at:put: (in category 'accessing') ----- - at: key put: value - "Set the value at key to be value." - - | index | - index := self scanFor: key. - (self basicAt: index) - ifNil: [ - self - basicAt: index put: key; - atNewIndex: index put: value ] - ifNotNil: [ - (array at: index) flushCache. - array at: index put: value ]. - ^value! Item was removed: - ----- Method: MethodDictionary>>compact (in category 'private') ----- - compact - "Make sure that I have the highest possible load factor (between 37.5% and 75%)." - - | newInstance | - newInstance := self compactWithoutBecome. - newInstance capacity = self capacity - ifTrue: [ self copyFrom: newInstance ] - ifFalse: [ self becomeForward: newInstance ]! Item was removed: - ----- Method: MethodDictionary>>compactWithoutBecome (in category 'private') ----- - compactWithoutBecome - "Return a copy of self which has the highest possible load factor (between 37.5% and 75%)." - - | newInstance | - newInstance := self species new: self size. - 1 to: self basicSize do: [ :index | - (self basicAt: index) ifNotNil: [ :key | - newInstance at: key put: (array at: index) ] ]. - ^newInstance! Item was removed: - ----- Method: MethodDictionary>>fixCollisionsFrom: (in category 'private') ----- - fixCollisionsFrom: start - "The element at start has been removed and replaced by nil. - This method moves forward from there, relocating any entries - that had been placed below due to collisions with this one." - - | key index | - index := start. - [ (key := self basicAt: (index := index \\ array size + 1)) == nil ] whileFalse: [ - | newIndex | - (newIndex := self scanFor: key) = index ifFalse: [ - self swap: index with: newIndex ] ]! Item was removed: - ----- Method: MethodDictionary>>grow (in category 'private') ----- - grow - - | newSelf | - newSelf := self species newForCapacity: self basicSize * 2. - 1 to: self basicSize do: [ :i | - (self basicAt: i) ifNotNil: [ :key | - newSelf at: key put: (array at: i) ] ]. - self becomeForward: newSelf! Item was removed: - ----- Method: MethodDictionary>>keyAtIdentityValue:ifAbsent: (in category 'accessing') ----- - keyAtIdentityValue: value ifAbsent: exceptionBlock - "Answer the key whose value equals the argument, value. If there is - none, answer the result of evaluating exceptionBlock." - - value ifNotNil: [ - 1 to: self basicSize do: [ :index | - (array at: index) == value ifTrue: [ - ^self basicAt: index ] ] ]. - ^exceptionBlock value! Item was removed: - ----- Method: MethodDictionary>>keyAtValue:ifAbsent: (in category 'accessing') ----- - keyAtValue: value ifAbsent: exceptionBlock - "Answer the key whose value equals the argument, value. If there is - none, answer the result of evaluating exceptionBlock." - - value ifNotNil: [ - 1 to: self basicSize do: [ :index | - (array at: index) = value ifTrue: [ - ^self basicAt: index ] ] ]. - ^exceptionBlock value! Item was removed: - ----- Method: MethodDictionary>>keysAndValuesDo: (in category 'enumeration') ----- - keysAndValuesDo: aBlock - "Enumerate the receiver with all the keys and values passed to the block" - - tally = 0 ifTrue: [^ self]. - 1 to: self basicSize do: [ :i | - (self basicAt: i) ifNotNil: [ :key | - aBlock value: key value: (array at: i) ] ]! Item was removed: - ----- Method: MethodDictionary>>keysDo: (in category 'enumeration') ----- - keysDo: aBlock - - tally = 0 ifTrue: [ ^self ]. - 1 to: self basicSize do: [ :i | - (self basicAt: i) ifNotNil: [ :key | - aBlock value: key ] ]! Item was removed: - ----- Method: MethodDictionary>>postCopy (in category 'copying') ----- - postCopy - - array := array copy! Item was removed: - ----- Method: MethodDictionary>>rehash (in category 'private') ----- - rehash - - | newInstance | - newInstance := self species newForCapacity: self basicSize. - 1 to: self basicSize do: [ :index | - (self basicAt: index) ifNotNil: [ :key | - newInstance at: key put: (array at: index) ] ]. - self copyFrom: newInstance! Item was removed: - ----- Method: MethodDictionary>>removeAll (in category 'removing') ----- - removeAll - "Remove all elements from this collection. Preserve the capacity" - - | newSelf | - tally = 0 ifTrue: [^self]. - newSelf := self species newForCapacity: self basicSize. - self copyFrom: newSelf! Item was removed: - ----- Method: MethodDictionary>>removeDangerouslyKey:ifAbsent: (in category 'private') ----- - removeDangerouslyKey: key ifAbsent: aBlock - "This is not really dangerous. But if normal removal - were done WHILE a MethodDict were being used, the - system might crash. So instead we make a copy, then do - this operation (which is NOT dangerous in a copy that is - not being used), and then use the copy after the removal." - - | index element | - index := self scanFor: key. - (element := array at: index) ifNil: [ ^aBlock value ]. - tally := tally - 1. "Update tally first, so that read-only hashed collections raise an error before modifying array." - array at: index put: nil. - self basicAt: index put: nil. - self fixCollisionsFrom: index. - ^element! Item was removed: - ----- Method: MethodDictionary>>removeKey:ifAbsent: (in category 'removing') ----- - removeKey: key ifAbsent: errorBlock - "The interpreter might be using this MethodDict while - this method is running!! Therefore we perform the removal - in a copy, and then atomically copy that copy" - - | copy | - copy := self copy. - copy removeDangerouslyKey: key ifAbsent: [^ errorBlock value]. - self copyFrom: copy! Item was removed: - ----- Method: MethodDictionary>>replace: (in category 'enumeration') ----- - replace: aBlock - "Destructively replace the values in this Dictionary by applying aBlock, keeping the same keys." - - tally = 0 ifTrue: [ ^self]. - 1 to: array size do: [ :index | - (array at: index) ifNotNil: [ :element | - array at: index put: (aBlock value: element) ] ]! Item was removed: - ----- Method: MethodDictionary>>scanFor: (in category 'private') ----- - scanFor: anObject - "Scan the key array for the first slot containing either a nil (indicating an empty slot) or an element that matches anObject. Answer the index of that slot or raise an error if no slot is found. This method will be overridden in various subclasses that have different interpretations for matching elements." - - | index start size | - index := start := anObject identityHash \\ (size := array size) + 1. - [ - | element | - ((element := self basicAt: index) == nil or: [ element == anObject ]) - ifTrue: [ ^index ]. - (index := index \\ size + 1) = start ] whileFalse. - self errorNoFreeSpace! Item was removed: - ----- Method: MethodDictionary>>swap:with: (in category 'private') ----- - swap: oneIndex with: otherIndex - - | element | - element := self basicAt: oneIndex. - self basicAt: oneIndex put: (self basicAt: otherIndex). - self basicAt: otherIndex put: element. - array swap: oneIndex with: otherIndex - ! Item was removed: - ----- Method: MethodDictionary>>valuesDo: (in category 'enumeration') ----- - valuesDo: aBlock - - tally = 0 ifTrue: [ ^self ]. - 1 to: self basicSize do: [ :i | - (array at: i) ifNotNil: [ :value | - aBlock value: value ] ]! Item was removed: - Object subclass: #Model - instanceVariableNames: 'dependents' - classVariableNames: 'UseColorfulWindows WindowActiveOnFirstClick' - poolDictionaries: '' - category: 'Kernel-Models'! - - !Model commentStamp: '<historical>' prior: 0! - Provides a superclass for classes that function as models. The only behavior provided is fast dependents maintenance, which bypasses the generic DependentsFields mechanism. 1/23/96 sw! Item was removed: - ----- Method: Model class>>buildWith: (in category 'toolbuilder') ----- - buildWith: toolBuilder - ^self new buildWith: toolBuilder! Item was removed: - ----- Method: Model class>>themeProperties (in category 'preferences') ----- - themeProperties - - ^ { - { #uniformWindowColor. 'Colors'. 'The color to be used when all windows should have the same color' }. - { #customWindowColor. 'Colors'. 'The color to be used when all windows can have their own color' }. - }! Item was removed: - ----- Method: Model class>>useColorfulWindows (in category 'preferences') ----- - useColorfulWindows - <preference: 'Use colorful windows' - categoryList: #(Morphic windows Accessibility) - description: 'When true, windows have colors specific to their kind.' - type: #Boolean> - ^UseColorfulWindows ifNil:[true]! Item was removed: - ----- Method: Model class>>useColorfulWindows: (in category 'preferences') ----- - useColorfulWindows: aBoolean - - UseColorfulWindows = aBoolean ifTrue: [^ self]. - UseColorfulWindows := aBoolean. - - (Smalltalk classNamed: #SystemWindow) ifNotNil: [:c | c refreshAllWindows]. - (Smalltalk classNamed: #TheWorldMainDockingBar) ifNotNil: [:c | c updateInstances].! Item was removed: - ----- Method: Model class>>windowActiveOnFirstClick (in category 'preferences') ----- - windowActiveOnFirstClick - <preference: 'Windows'' Contents Are Always Active' - category: 'windows' - description: 'When enabled, the widgets of background windows are sensitive to mouse input. When disabled, clicking background window will only make it the active window, without changing, for example, selections in lists or text fields.' - type: #Boolean> - - ^ WindowActiveOnFirstClick ifNil: [ false ]! Item was removed: - ----- Method: Model class>>windowActiveOnFirstClick: (in category 'preferences') ----- - windowActiveOnFirstClick: aBoolean - - WindowActiveOnFirstClick := aBoolean. - (Smalltalk classNamed: #SystemWindow) ifNotNil: [:c | c reconfigureWindowsForFocus].! Item was removed: - ----- Method: Model>>aboutToStyle: (in category 'morphic ui') ----- - aboutToStyle: aStyler - "Default implementation for text styling. No changes in styler configuration but we are OK to style our contents." - - ^ true! Item was removed: - ----- Method: Model>>aboutToStyle:requestor: (in category 'morphic ui') ----- - aboutToStyle: aStyler requestor: anObject - "View-specific extension for styling. Overwrite this method to configure the styler with view-specific information." - - ^ self aboutToStyle: aStyler! Item was removed: - ----- Method: Model>>applyUserInterfaceTheme (in category 'morphic ui') ----- - applyUserInterfaceTheme - - self dependents do: [:ea | - ea isSystemWindow ifTrue: [ - ea refreshWindowColor]].! Item was removed: - ----- Method: Model>>buildWindow:with:specs: (in category 'toolbuilder') ----- - buildWindow: windowSpec with: builder specs: specs - - specs do:[:assoc| - | rect action widgetSpec | - rect := assoc key. - action := assoc value. - widgetSpec := action value. - widgetSpec ifNotNil:[ - widgetSpec frame: rect. - windowSpec children add: widgetSpec]]. - ^ windowSpec! Item was removed: - ----- Method: Model>>buildWindowWith: (in category 'toolbuilder') ----- - buildWindowWith: builder - | windowSpec | - windowSpec := builder pluggableWindowSpec new. - windowSpec model: self. - windowSpec label: #windowTitle. - windowSpec children: OrderedCollection new. - ^windowSpec! Item was removed: - ----- Method: Model>>buildWindowWith:specs: (in category 'toolbuilder') ----- - buildWindowWith: builder specs: specs - - ^ self - buildWindow: (self buildWindowWith: builder) - with: builder - specs: specs! Item was removed: - ----- Method: Model>>canApplyUserInterfaceTheme (in category 'morphic ui') ----- - canApplyUserInterfaceTheme - ^ self dependents notEmpty! Item was removed: - ----- Method: Model>>canDiscardEdits (in category 'dependents') ----- - canDiscardEdits - "Answer true if none of the views on this model has unaccepted edits that matter." - - dependents ifNil: [^ true]. - ^ super canDiscardEdits - ! Item was removed: - ----- Method: Model>>containingWindow (in category 'dependents') ----- - containingWindow - "Answer the window that holds the receiver. The dependents technique is odious and may not be airtight, if multiple windows have the same model." - - ^ self dependents detect: - [:d | d isWindowForModel: self] ifNone: [nil]! Item was removed: - ----- Method: Model>>hasUnacceptedEdits (in category 'dependents') ----- - hasUnacceptedEdits - "Answer true if any of the views on this model has unaccepted edits." - - dependents == nil ifTrue: [^ false]. - ^ super hasUnacceptedEdits - ! Item was removed: - ----- Method: Model>>labelString (in category 'toolbuilder') ----- - labelString - "We'd love to sunset this in favour of #windowTitle but there are so many places that would need changing that it really seems more trouble than could possibly be warranted" - ^self class name! Item was removed: - ----- Method: Model>>myDependents (in category 'dependents') ----- - myDependents - ^ dependents! Item was removed: - ----- Method: Model>>myDependents: (in category 'dependents') ----- - myDependents: aCollectionOrNil - dependents := aCollectionOrNil! Item was removed: - ----- Method: Model>>postAcceptBrowseFor: (in category 'morphic ui') ----- - postAcceptBrowseFor: anotherModel - "If I am taking over browsing for anotherModel, sucblasses may override to, for example, position me to the object to be focused on."! Item was removed: - ----- Method: Model>>postCopy (in category 'copying') ----- - postCopy - - super postCopy. - self breakDependents.! Item was removed: - ----- Method: Model>>representsSameBrowseeAs: (in category 'morphic ui') ----- - representsSameBrowseeAs: anotherModel - "Answer true if my browser can browse what anotherModel wants to browse." - ^ false! Item was removed: - ----- Method: Model>>topView (in category 'dependents') ----- - topView - "Find the first top view on me. Is there any danger of their being two with the same model? Any danger from ungarbage collected old views? Ask if schedulled?" - - dependents ifNil: [^nil]. - dependents do: [:d| (d isWindowForModel: self) ifTrue:[^d]]. - ^nil! Item was removed: - ----- Method: Model>>veryDeepFixupWith: (in category 'copying') ----- - veryDeepFixupWith: deepCopier - "See if the dependents are being copied also. If so, point at the new copies. (The dependent has self as its model.) - Dependents handled in class Object, when the model is not a Model, are fixed up in Object veryDeepCopy." - - | originalDependents refs | - super veryDeepFixupWith: deepCopier. - originalDependents := dependents. - originalDependents ifNil: [ - ^self. - ]. - dependents := nil. - refs := deepCopier references. - originalDependents - do: [:originalDependent | | newDependent | - newDependent := refs - at: originalDependent - ifAbsent: []. - newDependent - ifNotNil: [self addDependent: newDependent]]! Item was removed: - ----- Method: Model>>veryDeepInner: (in category 'copying') ----- - veryDeepInner: deepCopier - "Shallow copy dependents and fix them later" - ! Item was removed: - ----- Method: Model>>windowActiveOnFirstClick (in category 'user interface') ----- - windowActiveOnFirstClick - - ^ self class windowActiveOnFirstClick! Item was removed: - ----- Method: Model>>windowTitle (in category 'toolbuilder') ----- - windowTitle - "We'd rather use windowTitle but labelString is deeply embedded; see its comment" - ^self labelString! Item was removed: - Error subclass: #ModificationForbidden - instanceVariableNames: 'mirror object fieldIndex newValue retrySelector resumptionValue' - classVariableNames: '' - poolDictionaries: '' - category: 'Kernel-Exceptions'! - - !ModificationForbidden commentStamp: 'ct 4/9/2020 19:49' prior: 0! - This error is raised when attempting to mutate a read-only object. - - My instances describe the necessary state to be able to reproduce the modification via the #retryModification protocol. - - Instance Variables - mirror: <Context | Behavior | Array> - object: <Object> - fieldIndex: <SmallInteger | nil> - newValue: <Object> - resumptionValue: <Object> - retrySelector: <Symbol> - - mirror - - the object that will perform the modification on object if modificationRetried - - object - - read-only object that attempted to mutate - - fieldIndex - - index of the field in the object mutated, relevant for the corresponding selector - - newValue - - value that was attempted to be stored into the read-only object - - resumptionValue - - value that will be returned when the ModificationForbidden is resumed - - retrySelector - - selector that can be used to reproduce the mutation (#object:basicAt:put:, #object:instVarAt:put:, etc.)! Item was removed: - ----- Method: ModificationForbidden>>fieldIndex (in category 'accessing') ----- - fieldIndex - ^fieldIndex! Item was removed: - ----- Method: ModificationForbidden>>indexedMessageText (in category 'printing') ----- - indexedMessageText - - ^ 'Cannot modify field {2} of read-only object {1}' translated - format: { - self printObject: object. - fieldIndex }! Item was removed: - ----- Method: ModificationForbidden>>isResumable (in category 'priv handling') ----- - isResumable - - ^ true! Item was removed: - ----- Method: ModificationForbidden>>messageText (in category 'printing') ----- - messageText - "Overwritten to initialize the message text to a standard text if it has not yet been set" - - ^ messageText ifNil: [ messageText := self standardMessageText ]! Item was removed: - ----- Method: ModificationForbidden>>mirror (in category 'accessing') ----- - mirror - ^mirror! Item was removed: - ----- Method: ModificationForbidden>>mirror:object:index:newValue:resumptionValue:retrySelector: (in category 'accessing') ----- - mirror: aContext object: anObject index: index newValue: value resumptionValue: valueToResumeWith retrySelector: selector - - mirror := aContext. - object := anObject. - fieldIndex := index. - newValue := value. - retrySelector := selector. - resumptionValue := valueToResumeWith! Item was removed: - ----- Method: ModificationForbidden>>mirror:object:index:newValue:retrySelector: (in category 'accessing') ----- - mirror: aContext object: anObject index: index newValue: value retrySelector: selector - - mirror := aContext. - object := anObject. - fieldIndex := index. - newValue := value. - retrySelector := selector. - resumptionValue := value! Item was removed: - ----- Method: ModificationForbidden>>newValue (in category 'accessing') ----- - newValue - ^newValue! Item was removed: - ----- Method: ModificationForbidden>>nonIndexedMessageText (in category 'printing') ----- - nonIndexedMessageText - - ^ 'Cannot execute {2} on read-only object {1}' translated - format: { - self printObject: object. - retrySelector printString }! Item was removed: - ----- Method: ModificationForbidden>>object (in category 'accessing') ----- - object - ^object! Item was removed: - ----- Method: ModificationForbidden>>printObject: (in category 'private') ----- - printObject: obj - - ^ [obj printString] - ifError: ['<cannot print object>' translated]! Item was removed: - ----- Method: ModificationForbidden>>resume (in category 'controlling') ----- - resume - "Return from the message that signaled the receiver." - - ^ self resume: resumptionValue! Item was removed: - ----- Method: ModificationForbidden>>resumptionValue (in category 'accessing') ----- - resumptionValue - ^resumptionValue! Item was removed: - ----- Method: ModificationForbidden>>resumptionValue: (in category 'accessing') ----- - resumptionValue: anObject - resumptionValue := anObject! Item was removed: - ----- Method: ModificationForbidden>>retryModification (in category 'retrying') ----- - retryModification - fieldIndex - ifNotNil: [mirror perform: retrySelector with: object with: fieldIndex with: newValue] - ifNil: [mirror perform: retrySelector with: object with: newValue]. - self resume: resumptionValue! Item was removed: - ----- Method: ModificationForbidden>>retryModificationNoResume (in category 'retrying') ----- - retryModificationNoResume - fieldIndex - ifNotNil: [mirror perform: retrySelector with: object with: fieldIndex with: newValue] - ifNil: [mirror perform: retrySelector with: object with: newValue]! Item was removed: - ----- Method: ModificationForbidden>>retrySelector (in category 'accessing') ----- - retrySelector - ^retrySelector! Item was removed: - ----- Method: ModificationForbidden>>standardMessageText (in category 'printing') ----- - standardMessageText - ^fieldIndex - ifNil: [self nonIndexedMessageText] - ifNotNil: [self indexedMessageText]! Item was removed: - Mutex subclass: #Monitor - instanceVariableNames: 'defaultQueue queueDict queuesMutex nestingLevel' - classVariableNames: '' - poolDictionaries: '' - category: 'Kernel-Processes'! - - !Monitor commentStamp: 'eem 1/7/2016 11:38' prior: 0! - A monitor provides process synchronization that is more high level than the one provided by a Semaphore. Similar to the classical definition of a Monitor it has the following properties: - - 1) At any time, only one process can execute code inside a critical section of a monitor. - 2) A monitor is reentrant, which means that the active process in a monitor never gets blocked when it enters a (nested) critical section of the same monitor. For example a monitor will not block when trying the following: - | m | - m := Monitor new. - m critical: [m critical: [#yes]] - whereas a Semaphore will deadlock: - | s | - s := Semaphore forMutualExclusion. - s critical: [s critical: [#no]] - 3) Inside a critical section, a process can wait for an event that may be coupled to a certain condition. If the condition is not fulfilled, the process leaves the monitor temporarily (in order to let other processes enter) and waits until another process signals the event. Then, the original process checks the condition again (this is often necessary because the state of the monitor could have changed in the meantime) and continues if it is fulfilled. - 4) The monitor is fair, which means that the process that is waiting on a signaled condition the longest gets activated first. - 5) The monitor allows you to define timeouts after which a process gets activated automatically. - - - Basic usage: - - Monitor>>critical: aBlock - Critical section. - Executes aBlock as a critical section. At any time, only one process can execute code in a critical section. - NOTE: All the following synchronization operations are only valid inside the critical section of the monitor!! - - Monitor>>wait - Unconditional waiting for the default event. - The current process gets blocked and leaves the monitor, which means that the monitor allows another process to execute critical code. When the default event is signaled, the original process is resumed. - - Monitor>>waitWhile: aBlock - Conditional waiting for the default event. - The current process gets blocked and leaves the monitor only if the argument block evaluates to true. This means that another process can enter the monitor. When the default event is signaled, the original process is resumed, which means that the condition (argument block) is checked again. Only if it evaluates to false, does execution proceed. Otherwise, the process gets blocked and leaves the monitor again... - - Monitor>>waitUntil: aBlock - Conditional waiting for the default event. - See Monitor>>waitWhile: aBlock. - - Monitor>>signal - One process waiting for the default event is woken up. - - Monitor>>signalAll - All processes waiting for the default event are woken up. - - - Using non-default (specific) events: - - Monitor>>waitFor: aSymbol - Unconditional waiting for the non-default event represented by the argument symbol. - Same as Monitor>>wait, but the process gets only reactivated by the specific event and not the default event. - - Monitor>>waitWhile: aBlock for: aSymbol - Confitional waiting for the non-default event represented by the argument symbol. - Same as Monitor>>waitWhile:for:, but the process gets only reactivated by the specific event and not the default event. - - Monitor>>waitUntil: aBlock for: aSymbol - Confitional waiting for the non-default event represented by the argument symbol. - See Monitor>>waitWhile:for: aBlock. - - Monitor>>signal: aSymbol - One process waiting for the given event is woken up. If there is no process waiting for this specific event, a process waiting for the default event gets resumed. - - Monitor>>signalAll: aSymbol - All process waiting for the given event or the default event are woken up. - - Monitor>>signalReallyAll - All processes waiting for any events (default or specific) are woken up. - - - Using timeouts - - Monitor>>waitMaxMilliseconds: anInteger - Monitor>>waitFor: aSymbol maxMilliseconds: anInteger - Same as Monitor>>wait (resp. Monitor>>waitFor:), but the process gets automatically woken up when the specified time has passed. - - Monitor>>waitWhile: aBlock maxMilliseconds: anInteger - Monitor>>waitWhile: aBlock for: aSymbol maxMilliseconds: anInteger - Same as Monitor>>waitWhile: (resp. Monitor>>waitWhile:for:), but the process gets automatically woken up when the specified time has passed. - - Monitor>>waitUntil: aBlock maxMilliseconds: anInteger - Monitor>>waitUntil: aBlock for: aSymbol maxMilliseconds: anInteger - Same as Monitor>>waitUntil: (resp. Monitor>>waitUntil:for:), but the process gets automatically woken up when the specified time has passed.! Item was removed: - ----- Method: Monitor>>checkOwnerProcess (in category 'private') ----- - checkOwnerProcess - "If the receiver is not already the owner of the section raise an error." - - self primitiveTestAndSetOwnershipOfCriticalSection ifNotNil: [ :alreadyOwner | - alreadyOwner ifTrue: [ ^self ]. - self primitiveExitCriticalSection ]. - self error: 'Monitor access violation'! Item was removed: - ----- Method: Monitor>>cleanup (in category 'accessing') ----- - cleanup - self checkOwnerProcess. - self critical: [self privateCleanup].! Item was removed: - ----- Method: Monitor>>defaultQueue (in category 'private') ----- - defaultQueue - defaultQueue ifNil: [defaultQueue := OrderedCollection new]. - ^ defaultQueue! Item was removed: - ----- Method: Monitor>>exitAndWaitInQueue:maxMilliseconds: (in category 'private') ----- - exitAndWaitInQueue: anOrderedCollection maxMilliseconds: anIntegerOrNil - - [ | lock | - lock := queuesMutex critical: [ anOrderedCollection addLast: Semaphore new ]. - self primitiveExitCriticalSection. - anIntegerOrNil - ifNil: [ lock wait ] - ifNotNil: - [ | delay | - delay := MonitorDelay - signalLock: lock - afterMSecs: anIntegerOrNil - inMonitor: self - queue: anOrderedCollection. - [ lock wait ] ensure: [ delay unschedule ] ] ] - ensure: [ self primitiveEnterCriticalSection ]! Item was removed: - ----- Method: Monitor>>initialize (in category 'initialize-release') ----- - initialize - queuesMutex := Mutex new! Item was removed: - ----- Method: Monitor>>privateCleanup (in category 'private') ----- - privateCleanup - queuesMutex critical: [ - defaultQueue isEmpty ifTrue: [defaultQueue := nil]. - queueDict ifNotNil: [ - queueDict copy keysAndValuesDo: [:id :queue | - queue isEmpty ifTrue: [queueDict removeKey: id]]. - queueDict isEmpty ifTrue: [queueDict := nil]. - ]. - ].! Item was removed: - ----- Method: Monitor>>queueDict (in category 'private') ----- - queueDict - - ^queueDict ifNil: [ queueDict := IdentityDictionary new ]! Item was removed: - ----- Method: Monitor>>queueFor: (in category 'private') ----- - queueFor: aSymbol - aSymbol ifNil: [^ self defaultQueue]. - ^ self queueDict - at: aSymbol - ifAbsentPut: [OrderedCollection new].! Item was removed: - ----- Method: Monitor>>signal (in category 'signaling-default') ----- - signal - "One process waiting for the default event is woken up." - - ^ self signal: nil! Item was removed: - ----- Method: Monitor>>signal: (in category 'signaling-specific') ----- - signal: aSymbolOrNil - "One process waiting for the given event is woken up. If there is no process waiting - for this specific event, a process waiting for the default event gets resumed." - - | queue | - self checkOwnerProcess. - queue := self queueFor: aSymbolOrNil. - queue isEmpty ifTrue: [queue := self defaultQueue]. - self signalQueue: queue.! Item was removed: - ----- Method: Monitor>>signalAll (in category 'signaling-default') ----- - signalAll - "All processes waiting for the default event are woken up." - - ^ self signalAll: nil! Item was removed: - ----- Method: Monitor>>signalAll: (in category 'signaling-specific') ----- - signalAll: aSymbolOrNil - "All process waiting for the given event or the default event are woken up." - - | queue | - self checkOwnerProcess. - queue := self queueFor: aSymbolOrNil. - self signalAllInQueue: self defaultQueue. - queue ~~ self defaultQueue ifTrue: [self signalAllInQueue: queue].! Item was removed: - ----- Method: Monitor>>signalAllInQueue: (in category 'private') ----- - signalAllInQueue: anOrderedCollection - - queuesMutex critical: [ - anOrderedCollection removeAllSuchThat: [ :each | - each signal. - true ] ]! Item was removed: - ----- Method: Monitor>>signalLock:inQueue: (in category 'private') ----- - signalLock: aSemaphore inQueue: anOrderedCollection - queuesMutex critical: [ - aSemaphore signal. - anOrderedCollection remove: aSemaphore ifAbsent: []. - ].! Item was removed: - ----- Method: Monitor>>signalQueue: (in category 'private') ----- - signalQueue: anOrderedCollection - - queuesMutex critical: [ - anOrderedCollection isEmpty ifFalse: [ - anOrderedCollection removeFirst signal ] ]! Item was removed: - ----- Method: Monitor>>signalReallyAll (in category 'signaling-specific') ----- - signalReallyAll - "All processes waiting for any events (default or specific) are woken up." - - self checkOwnerProcess. - self signalAll. - self queueDict valuesDo: [:queue | - self signalAllInQueue: queue].! Item was removed: - ----- Method: Monitor>>wait (in category 'waiting-basic') ----- - wait - "Unconditional waiting for the default event. - The current process gets blocked and leaves the monitor, which means that the monitor - allows another process to execute critical code. When the default event is signaled, the - original process is resumed." - - ^ self waitMaxMilliseconds: nil! Item was removed: - ----- Method: Monitor>>waitFor: (in category 'waiting-specific') ----- - waitFor: aSymbolOrNil - "Unconditional waiting for the non-default event represented by the argument symbol. - Same as Monitor>>wait, but the process gets only reactivated by the specific event and - not the default event." - - ^ self waitFor: aSymbolOrNil maxMilliseconds: nil! Item was removed: - ----- Method: Monitor>>waitFor:maxMilliseconds: (in category 'waiting-timeout') ----- - waitFor: aSymbolOrNil maxMilliseconds: anIntegerOrNil - "Same as Monitor>>waitFor:, but the process gets automatically woken up when the - specified time has passed." - - self checkOwnerProcess. - self waitInQueue: (self queueFor: aSymbolOrNil) maxMilliseconds: anIntegerOrNil.! Item was removed: - ----- Method: Monitor>>waitFor:maxSeconds: (in category 'waiting-timeout') ----- - waitFor: aSymbolOrNil maxSeconds: aNumber - "Same as Monitor>>waitFor:, but the process gets automatically woken up when the - specified time has passed." - - ^ self waitFor: aSymbolOrNil maxMilliseconds: (aNumber * 1000) asInteger! Item was removed: - ----- Method: Monitor>>waitInQueue:maxMilliseconds: (in category 'private') ----- - waitInQueue: anOrderedCollection maxMilliseconds: anIntegerOrNil - self exitAndWaitInQueue: anOrderedCollection maxMilliseconds: anIntegerOrNil.! Item was removed: - ----- Method: Monitor>>waitMaxMilliseconds: (in category 'waiting-timeout') ----- - waitMaxMilliseconds: anIntegerOrNil - "Same as Monitor>>wait, but the process gets automatically woken up when the - specified time has passed." - - ^ self waitFor: nil maxMilliseconds: anIntegerOrNil! Item was removed: - ----- Method: Monitor>>waitMaxSeconds: (in category 'waiting-timeout') ----- - waitMaxSeconds: aNumber - "Same as Monitor>>wait, but the process gets automatically woken up when the - specified time has passed." - - ^ self waitMaxMilliseconds: (aNumber * 1000) asInteger! Item was removed: - ----- Method: Monitor>>waitUntil: (in category 'waiting-basic') ----- - waitUntil: aBlock - "Conditional waiting for the default event. - See Monitor>>waitWhile: aBlock." - - ^ self waitUntil: aBlock for: nil! Item was removed: - ----- Method: Monitor>>waitUntil:for: (in category 'waiting-specific') ----- - waitUntil: aBlock for: aSymbolOrNil - "Confitional waiting for the non-default event represented by the argument symbol. - See Monitor>>waitWhile:for: aBlock." - - ^ self waitUntil: aBlock for: aSymbolOrNil maxMilliseconds: nil! Item was removed: - ----- Method: Monitor>>waitUntil:for:maxMilliseconds: (in category 'waiting-timeout') ----- - waitUntil: aBlock for: aSymbolOrNil maxMilliseconds: anIntegerOrNil - "Same as Monitor>>waitUntil:for:, but the process gets automatically woken up when the - specified time has passed." - - ^ self waitWhile: [aBlock value not] for: aSymbolOrNil maxMilliseconds: anIntegerOrNil! Item was removed: - ----- Method: Monitor>>waitUntil:for:maxSeconds: (in category 'waiting-timeout') ----- - waitUntil: aBlock for: aSymbolOrNil maxSeconds: aNumber - "Same as Monitor>>waitUntil:for:, but the process gets automatically woken up when the - specified time has passed." - - ^ self waitUntil: aBlock for: aSymbolOrNil maxMilliseconds: (aNumber * 1000) asInteger! Item was removed: - ----- Method: Monitor>>waitUntil:maxMilliseconds: (in category 'waiting-timeout') ----- - waitUntil: aBlock maxMilliseconds: anIntegerOrNil - "Same as Monitor>>waitUntil:, but the process gets automatically woken up when the - specified time has passed." - - ^ self waitUntil: aBlock for: nil maxMilliseconds: anIntegerOrNil! Item was removed: - ----- Method: Monitor>>waitUntil:maxSeconds: (in category 'waiting-timeout') ----- - waitUntil: aBlock maxSeconds: aNumber - "Same as Monitor>>waitUntil:, but the process gets automatically woken up when the - specified time has passed." - - ^ self waitUntil: aBlock maxMilliseconds: (aNumber * 1000) asInteger! Item was removed: - ----- Method: Monitor>>waitWhile: (in category 'waiting-basic') ----- - waitWhile: aBlock - "Conditional waiting for the default event. - The current process gets blocked and leaves the monitor only if the argument block - evaluates to true. This means that another process can enter the monitor. When the - default event is signaled, the original process is resumed, which means that the condition - (argument block) is checked again. Only if it evaluates to false, does execution proceed. - Otherwise, the process gets blocked and leaves the monitor again..." - - ^ self waitWhile: aBlock for: nil! Item was removed: - ----- Method: Monitor>>waitWhile:for: (in category 'waiting-specific') ----- - waitWhile: aBlock for: aSymbolOrNil - "Confitional waiting for the non-default event represented by the argument symbol. - Same as Monitor>>waitWhile:for:, but the process gets only reactivated by the specific - event and not the default event." - - ^ self waitWhile: aBlock for: aSymbolOrNil maxMilliseconds: nil! Item was removed: - ----- Method: Monitor>>waitWhile:for:maxMilliseconds: (in category 'waiting-timeout') ----- - waitWhile: aBlock for: aSymbolOrNil maxMilliseconds: anIntegerOrNil - "Same as Monitor>>waitWhile:for:, but the process gets automatically woken up when the - specified time has passed." - - self checkOwnerProcess. - self waitWhile: aBlock inQueue: (self queueFor: aSymbolOrNil) maxMilliseconds: anIntegerOrNil.! Item was removed: - ----- Method: Monitor>>waitWhile:for:maxSeconds: (in category 'waiting-timeout') ----- - waitWhile: aBlock for: aSymbolOrNil maxSeconds: aNumber - "Same as Monitor>>waitWhile:for:, but the process gets automatically woken up when the - specified time has passed." - - ^ self waitWhile: aBlock for: aSymbolOrNil maxMilliseconds: (aNumber * 1000) asInteger! Item was removed: - ----- Method: Monitor>>waitWhile:inQueue:maxMilliseconds: (in category 'private') ----- - waitWhile: aBlock inQueue: anOrderedCollection maxMilliseconds: anIntegerOrNil - [aBlock value] whileTrue: [self exitAndWaitInQueue: anOrderedCollection maxMilliseconds: anIntegerOrNil].! Item was removed: - ----- Method: Monitor>>waitWhile:maxMilliseconds: (in category 'waiting-timeout') ----- - waitWhile: aBlock maxMilliseconds: anIntegerOrNil - "Same as Monitor>>waitWhile:, but the process gets automatically woken up when the - specified time has passed." - - ^ self waitWhile: aBlock for: nil maxMilliseconds: anIntegerOrNil! Item was removed: - ----- Method: Monitor>>waitWhile:maxSeconds: (in category 'waiting-timeout') ----- - waitWhile: aBlock maxSeconds: aNumber - "Same as Monitor>>waitWhile:, but the process gets automatically woken up when the - specified time has passed." - - ^ self waitWhile: aBlock maxMilliseconds: (aNumber * 1000) asInteger! Item was removed: - Delay subclass: #MonitorDelay - instanceVariableNames: 'monitor queue' - classVariableNames: '' - poolDictionaries: '' - category: 'Kernel-Processes'! - - !MonitorDelay commentStamp: 'NS 4/13/2004 16:51' prior: 0! - This is a specialization of the class Delay that is used for the implementation of the class Monitor.! Item was removed: - ----- Method: MonitorDelay class>>signalLock:afterMSecs:inMonitor:queue: (in category 'instance creation') ----- - signalLock: aSemaphore afterMSecs: anInteger inMonitor: aMonitor queue: anOrderedCollection - anInteger < 0 ifTrue: [self error: 'delay times cannot be negative']. - ^ (self new setDelay: anInteger forSemaphore: aSemaphore monitor: aMonitor queue: anOrderedCollection) schedule! Item was removed: - ----- Method: MonitorDelay>>setDelay:forSemaphore:monitor:queue: (in category 'private') ----- - setDelay: anInteger forSemaphore: aSemaphore monitor: aMonitor queue: anOrderedCollection - monitor := aMonitor. - queue := anOrderedCollection. - self setDelay: anInteger forSemaphore: aSemaphore.! Item was removed: - ----- Method: MonitorDelay>>signalWaitingProcess (in category 'private') ----- - signalWaitingProcess - "The delay time has elapsed; signal the waiting process." - - beingWaitedOn := false. - monitor signalLock: delaySemaphore inQueue: queue. - ! Item was removed: - LinkedList subclass: #Mutex - instanceVariableNames: 'owner' - classVariableNames: '' - poolDictionaries: '' - category: 'Kernel-Processes'! - - !Mutex commentStamp: 'eem 1/7/2016 11:36' prior: 0! - A Mutex is a light-weight MUTual EXclusion object being used when two or more processes need to access a shared resource concurrently. A Mutex grants ownership to a single process and will suspend any other process trying to aquire the mutex while in use. Waiting processes are granted access to the mutex in the order the access was requested. - - A Mutex allows the owning process to reenter as many times as desired. For example a Mutex will not block when trying the following: - | m | - m := Mutex new. - m critical: [m critical: [#yes]] - whereas a Semaphore will deadlock: - | s | - s := Semaphore forMutualExclusion. - s critical: [s critical: [#no]] - - Instance variables: - owner <Process|UndefinedObject> The process owning the mutex! Item was removed: - ----- Method: Mutex>>critical: (in category 'mutual exclusion') ----- - critical: aBlock - "Evaluate aBlock protected by the receiver." - <criticalSection> - ^self primitiveEnterCriticalSection - ifTrue: [aBlock value] - ifFalse: [aBlock ensure: [self primitiveExitCriticalSection]]! Item was removed: - ----- Method: Mutex>>critical:ifLocked: (in category 'mutual exclusion') ----- - critical: aBlock ifLocked: lockedBlock - "Answer the evaluation of aBlock protected by the receiver. If it is already in a critical - section on behalf of some other process answer the evaluation of lockedBlock." - <criticalSection> - ^self primitiveTestAndSetOwnershipOfCriticalSection - ifNil: [lockedBlock value] - ifNotNil: - [:alreadyOwner| - alreadyOwner - ifTrue: [aBlock value] - ifFalse: [aBlock ensure: [self primitiveExitCriticalSection]]]! Item was removed: - ----- Method: Mutex>>isOwned (in category 'testing') ----- - isOwned - "Answer if the receiver is owned. DO NOT USE THIS IN NORMAL CODE. - This exists for the MutexTests so they don't have to use e.g. instVarNamed:. - N.B. don't use notNil because that is a real send and preemptable." - ^nil ~~ owner! Item was removed: - ----- Method: Mutex>>primitiveEnterCriticalSection (in category 'private-primitives') ----- - primitiveEnterCriticalSection - "Primitive. The receiver must be unowned or owned by the current process to proceed. - Answer if the process is owned by the current process. - - Copyright (c) 2016 - 3D Immersive Collaboration Consulting, LLC." - <primitive: 186> - self primitiveFailed - "In the spirit of the following" - "[owner ifNil: - [owner := Processor activeProcess. - ^false]. - owner = Processor activeProcess ifTrue: - [^true]. - self addLast: Processor activeProcess. - Processor activeProcess suspend] valueUnpreemptively"! Item was removed: - ----- Method: Mutex>>primitiveEnterCriticalSectionOnBehalfOf: (in category 'system simulation') ----- - primitiveEnterCriticalSectionOnBehalfOf: effectiveProcess - "Primitive. Simulate primitiveEnterCriticalSection. The receiver - must be unowned or owned by the effectiveProcess to proceed. - Answer if the process is already owned by the current process." - <primitive: 186> - ^Context primitiveFailTokenFor: nil! Item was removed: - ----- Method: Mutex>>primitiveExitCriticalSection (in category 'private-primitives') ----- - primitiveExitCriticalSection - "Primitive. Set the receiver to unowned and if any processes are waiting on - the receiver then proceed the first one, indicating that the receiver is unowned. - - Copyright (c) 2016 - 3D Immersive Collaboration Consulting, LLC." - <primitive: 185> - self primitiveFailed - "In the spirit of the following" - "[owner := nil. - self isEmpty ifFalse: - [process := self removeFirst. - process resume]] valueUnpreemptively"! Item was removed: - ----- Method: Mutex>>primitiveTestAndSetOwnershipOfCriticalSection (in category 'private-primitives') ----- - primitiveTestAndSetOwnershipOfCriticalSection - "Primitive. Attempt to set the ownership of the receiver. - If the receiver is unowned set its owningProcess to the - activeProcess and answer false. If the receiver is owned - by the activeProcess answer true. If the receiver is owned - by some other process answer nil. - - Copyright (c) 2016 - 3D Immersive Collaboration Consulting, LLC." - <primitive: 187> - self primitiveFailed - "In the spirit of the following" - "[owner ifNil: - [owningProcess := Processor activeProcess. - ^false]. - owner = Processor activeProcess ifTrue: [^true]. - ^nil] valueUnpreemptively"! Item was removed: - ----- Method: Mutex>>primitiveTestAndSetOwnershipOfCriticalSectionOnBehalfOf: (in category 'system simulation') ----- - primitiveTestAndSetOwnershipOfCriticalSectionOnBehalfOf: effectiveProcess - "Primitive. Simulate primitiveEnterCriticalSection. Attempt to set the ownership - of the receiver. If the receiver is unowned set its owningProcess to the - effectiveProcess and answer false. If the receiver is owned by the effectiveProcess - answer true. If the receiver is owned by some other process answer nil." - <primitive: 187> - ^Context primitiveFailTokenFor: nil! Item was removed: - Object subclass: #MutexSet - instanceVariableNames: 'array' - classVariableNames: '' - poolDictionaries: '' - category: 'Kernel-Processes'! - - !MutexSet commentStamp: '<historical>' prior: 0! - A MutexSet helps with aquiring a set of mutexes.! Item was removed: - ----- Method: MutexSet class>>withAll: (in category 'instance creation') ----- - withAll: mutexList - ^self new withAll: mutexList! Item was removed: - ----- Method: MutexSet>>critical: (in category 'mutual exclusion') ----- - critical: aBlock - "Evaluate aBlock aquiring all mutexes" - ^self pvtCritical: aBlock startingAt: 1! Item was removed: - ----- Method: MutexSet>>pvtCritical:startingAt: (in category 'private') ----- - pvtCritical: aBlock startingAt: index - | mutex | - index > array size ifTrue:[^aBlock value]. - mutex := array at: index. - ^mutex critical:[self pvtCritical: aBlock startingAt: index+1].! Item was removed: - ----- Method: MutexSet>>withAll: (in category 'initialize') ----- - withAll: mutexList - array := mutexList.! Item was removed: - Error subclass: #NonBooleanReceiver - instanceVariableNames: 'object' - classVariableNames: '' - poolDictionaries: '' - category: 'Kernel-Exceptions'! Item was removed: - ----- Method: NonBooleanReceiver>>isResumable (in category 'signaledException') ----- - isResumable - - ^true! Item was removed: - ----- Method: NonBooleanReceiver>>object (in category 'accessing') ----- - object - ^object! Item was removed: - ----- Method: NonBooleanReceiver>>object: (in category 'accessing') ----- - object: anObject - object := anObject! Item was removed: - Error subclass: #NotImplemented - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Kernel-Exceptions'! Item was removed: - NotImplemented subclass: #NotYetImplemented - instanceVariableNames: 'receiverClass selector context' - classVariableNames: '' - poolDictionaries: '' - category: 'Kernel-Exceptions'! - - !NotYetImplemented commentStamp: 'jcg 10/21/2009 01:20' prior: 0! - Sent by #notYetImplemented. Better than the age-old behavior of opening a notifier window, because this can be caught and handled. - ! Item was removed: - ----- Method: NotYetImplemented class>>signal (in category 'signaling') ----- - signal - "Call only from #notYetImplemented. Find the context that sent #nYI... this is the method that needs to be implemented." - | ctxt ex | - ctxt := thisContext sender sender. - ex := self new. - ex receiverClass: ctxt receiver class selector: ctxt selector. - ex messageText: ctxt printString. - ex signal. - ! Item was removed: - ----- Method: NotYetImplemented>>receiverClass (in category 'accessing') ----- - receiverClass - ^receiverClass! Item was removed: - ----- Method: NotYetImplemented>>receiverClass:selector: (in category 'initialize') ----- - receiverClass: cls selector: sel - receiverClass := cls. - selector := sel.! Item was removed: - ----- Method: NotYetImplemented>>selector (in category 'accessing') ----- - selector - ^selector! Item was removed: - Exception subclass: #Notification - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Kernel-Exceptions-Kernel'! - - !Notification commentStamp: '<historical>' prior: 0! - A Notification is an indication that something interesting has occurred. If it is not handled, it will pass by without effect.! Item was removed: - ----- Method: Notification>>defaultAction (in category 'priv handling') ----- - defaultAction - "No action is taken. The value nil is returned as the value of the message that signaled the exception." - - ^nil! Item was removed: - ----- Method: Notification>>isResumable (in category 'priv handling') ----- - isResumable - "Answer true. Notification exceptions by default are specified to be resumable." - - ^true! Item was removed: - Magnitude subclass: #Number - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Kernel-Numbers'! - - !Number commentStamp: '<historical>' prior: 0! - Class Number holds the most general methods for dealing with numbers. Subclasses Float, Fraction, and Integer, and their subclasses, provide concrete representations of a numeric quantity. - - All of Number's subclasses participate in a simple type coercion mechanism that supports mixed-mode arithmetic and comparisons. It works as follows: If - self<typeA> op: arg<typeB> - fails because of incompatible types, then it is retried in the following guise: - (arg adaptTypeA: self) op: arg adaptToTypeA. - This gives the arg of typeB an opportunity to resolve the incompatibility, knowing exactly what two types are involved. If self is more general, then arg will be converted, and viceVersa. This mechanism is extensible to any new number classes that one might wish to add to Squeak. The only requirement is that every subclass of Number must support a pair of conversion methods specific to each of the other subclasses of Number.! Item was removed: - ----- Method: Number class>>one (in category 'constants') ----- - one - - ^1! Item was removed: - ----- Method: Number class>>readFrom: (in category 'instance creation') ----- - readFrom: stringOrStream - "Answer a number as described on aStream. The number may - be any accepted Smalltalk literal Number format. - It can include a leading radix specification, as in 16rFADE. - It can as well be NaN, Infinity or -Infinity for conveniency. - If stringOrStream does not start with a valid number description, fail." - - ^(ExtendedNumberParser on: stringOrStream) nextNumber! Item was removed: - ----- Method: Number class>>readFrom:base: (in category 'instance creation') ----- - readFrom: stringOrStream base: base - "Answer a number as described on aStream in the given number base." - - ^(SqNumberParser on: stringOrStream) nextNumberBase: base! Item was removed: - ----- Method: Number class>>readFrom:ifFail: (in category 'instance creation') ----- - readFrom: stringOrStream ifFail: aBlock - "Answer a number as described on aStream. The number may - be any accepted Smalltalk literal Number format. - It can include a leading radix specification, as in 16rFADE. - It can as well be NaN, Infinity or -Infinity for conveniency. - If input does not represent a valid number, then execute fail block - and leave the stream positioned before offending character" - - ^(ExtendedNumberParser on: stringOrStream) failBlock: aBlock; nextNumber! Item was removed: - ----- Method: Number class>>readSmalltalkSyntaxFrom: (in category 'instance creation') ----- - readSmalltalkSyntaxFrom: stringOrStream - "Answer a number as described on aStream. The number may - be any accepted Smalltalk literal Number format. - It can include a leading radix specification, as in 16rFADE. - It can as well be NaN, Infinity or -Infinity for conveniency. - If stringOrStream does not start with a valid number description, fail." - - ^(SqNumberParser on: stringOrStream) nextNumber! Item was removed: - ----- Method: Number class>>zero (in category 'constants') ----- - zero - ^ 0.! Item was removed: - ----- Method: Number>>* (in category 'arithmetic') ----- - * aNumber - "Answer the result of multiplying the receiver by aNumber." - - self subclassResponsibility! Item was removed: - ----- Method: Number>>** (in category 'mathematical functions') ----- - ** aNumber - - ^ self raisedTo: aNumber! Item was removed: - ----- Method: Number>>+ (in category 'arithmetic') ----- - + aNumber - "Answer the sum of the receiver and aNumber." - - self subclassResponsibility! Item was removed: - ----- Method: Number>>- (in category 'arithmetic') ----- - - aNumber - "Answer the difference between the receiver and aNumber." - - self subclassResponsibility! Item was removed: - ----- Method: Number>>/ (in category 'arithmetic') ----- - / aNumber - "Answer the result of dividing the receiver by aNumber." - - self subclassResponsibility! Item was removed: - ----- Method: Number>>// (in category 'arithmetic') ----- - // aNumber - "Integer quotient defined by division with truncation toward negative - infinity. 9//4 = 2, -9//4 = -3. -0.9//0.4 = -3. \\ answers the remainder - from this division." - - ^(self / aNumber) floor! Item was removed: - ----- Method: Number>>\\ (in category 'arithmetic') ----- - \\ aNumber - "modulo. Remainder defined in terms of //. Answer a Number with the - same sign as aNumber. e.g. 9\\4 = 1, -9\\4 = 3, 9\\-4 = -3, 0.9\\0.4 = 0.1." - - ^self - (self // aNumber * aNumber)! Item was removed: - ----- Method: Number>>abs (in category 'arithmetic') ----- - abs - "Answer a Number that is the absolute value (positive magnitude) of the - receiver." - - self < 0 - ifTrue: [^self negated] - ifFalse: [^self]! Item was removed: - ----- Method: Number>>adaptToCollection:andSend: (in category 'converting') ----- - adaptToCollection: rcvr andSend: selector - "If I am involved in arithmetic with a Collection, return a Collection of - the results of each element combined with me in that expression." - - ^ rcvr collect: [:element | element perform: selector with: self]! Item was removed: - ----- Method: Number>>adaptToComplex:andSend: (in category 'converting') ----- - adaptToComplex: rcvr andSend: selector - "If I am involved in arithmetic with a Complex number, convert me to a Complex number." - ^ rcvr perform: selector with: self asComplex! Item was removed: - ----- Method: Number>>adaptToFloat:andCompare: (in category 'converting') ----- - adaptToFloat: rcvr andCompare: selector - "If I am involved in comparison with a Float, convert rcvr to a - Fraction. This way, no bit is lost and comparison is exact." - - rcvr isFinite - ifFalse: [ - selector == #= ifTrue: [^false]. - selector == #~= ifTrue: [^true]. - rcvr isNaN ifTrue: [^ false]. - (selector = #< or: [selector = #'<=']) - ifTrue: [^ rcvr < 0.0]. - (selector = #> or: [selector = #'>=']) - ifTrue: [^ rcvr > 0.0]. - ^self error: 'unknow comparison selector']. - - "Try to avoid asTrueFraction because it can cost" - self isAnExactFloat ifTrue: [^rcvr perform: selector with: self asExactFloat]. - selector == #= ifTrue: [^false]. - selector == #~= ifTrue: [^true]. - ^ rcvr asTrueFraction perform: selector with: self! Item was removed: - ----- Method: Number>>adaptToFloat:andSend: (in category 'converting') ----- - adaptToFloat: rcvr andSend: selector - "If I am involved in arithmetic with a Float, convert me to a Float." - ^ rcvr perform: selector with: self asFloat! Item was removed: - ----- Method: Number>>adaptToFraction:andSend: (in category 'converting') ----- - adaptToFraction: rcvr andSend: selector - "If I am involved in arithmetic with a Fraction, convert us and evaluate exprBlock." - ^ self subclassResponsibility! Item was removed: - ----- Method: Number>>adaptToInteger:andSend: (in category 'converting') ----- - adaptToInteger: rcvr andSend: selector - "If I am involved in arithmetic with a Integer, convert us and evaluate exprBlock." - ^ self subclassResponsibility! Item was removed: - ----- Method: Number>>adaptToPoint:andSend: (in category 'converting') ----- - adaptToPoint: rcvr andSend: selector - "If I am involved in arithmetic with a Point, convert me to a Point." - ^ rcvr perform: selector with: self at self! Item was removed: - ----- Method: Number>>adaptToScaledDecimal:andSend: (in category 'converting') ----- - adaptToScaledDecimal: receiverScaledDecimal andSend: arithmeticOpSelector - "Do any required conversion and then the arithmetic. - receiverScaledDecimal arithmeticOpSelector self." - #Numeric. - "add 200/01/19 For ScaledDecimal support." - ^ self subclassResponsibility! Item was removed: - ----- Method: Number>>adaptToString:andSend: (in category 'converting') ----- - adaptToString: rcvr andSend: selector - "If I am involved in arithmetic with a String, convert it to a Number." - ^ rcvr asNumber perform: selector with: self! Item was removed: - ----- Method: Number>>arCosh (in category 'mathematical functions') ----- - arCosh - "Answer receiver's area hyperbolic cosine. - That is the inverse function of cosh." - - ^self asFloat arCosh! Item was removed: - ----- Method: Number>>arSinh (in category 'mathematical functions') ----- - arSinh - "Answer receiver's area hyperbolic sine. - That is the inverse function of sinh." - - ^self asFloat arSinh! Item was removed: - ----- Method: Number>>arTanh (in category 'mathematical functions') ----- - arTanh - "Answer receiver's area hyperbolic tangent. - That is the inverse function of tanh." - - ^self asFloat arTanh! Item was removed: - ----- Method: Number>>arcCos (in category 'mathematical functions') ----- - arcCos - "The receiver is the cosine of an angle. Answer the angle measured in - radians." - - ^self asFloat arcCos! Item was removed: - ----- Method: Number>>arcSin (in category 'mathematical functions') ----- - arcSin - "The receiver is the sine of an angle. Answer the angle measured in - radians." - - ^self asFloat arcSin! Item was removed: - ----- Method: Number>>arcTan (in category 'mathematical functions') ----- - arcTan - "The receiver is the tangent of an angle. Answer the angle measured in - radians." - - ^self asFloat arcTan! Item was removed: - ----- Method: Number>>arcTan: (in category 'mathematical functions') ----- - arcTan: denominator - "The receiver is the tangent of an angle. Answer the angle measured in - radians." - - ^(self asFloat) arcTan: denominator.! Item was removed: - ----- Method: Number>>arg (in category 'arithmetic') ----- - arg - "Answer the argument of the receiver (see Complex | arg)." - - self isZero ifTrue: [self error: 'Zero (0 + 0 i) does not have an argument.']. - 0 < self - ifTrue: [^ 0] - ifFalse: [^ Float pi]! Item was removed: - ----- Method: Number>>asB3DVector3 (in category 'converting') ----- - asB3DVector3 - ^self at self@self! Item was removed: - ----- Method: Number>>asComplex (in category 'converting') ----- - asComplex - "Answer a Complex number that represents value of the the receiver." - - ^ Complex real: self imaginary: 0! Item was removed: - ----- Method: Number>>asExactFloat (in category 'converting') ----- - asExactFloat - "Convert this number asFloat with a priori knowledge that it is an exact Float. - Some subclass might exploit this knowledge for a faster implementation. - Only send this if self isAnExactFloat." - ^self asFloat! Item was removed: - ----- Method: Number>>asFloatD (in category 'converting') ----- - asFloatD - "Answer a d precision floating-point number approximating the receiver." - #Numeric. - "add 200/01/19 For ANSI <number> protocol." - ^ self asFloat! Item was removed: - ----- Method: Number>>asFloatE (in category 'converting') ----- - asFloatE - "Answer a floating-point number approximating the receiver." - #Numeric. - "add 200/01/19 For ANSI <number> protocol." - ^ self asFloat! Item was removed: - ----- Method: Number>>asFloatQ (in category 'converting') ----- - asFloatQ - "Answer a floating-point number approximating the receiver." - #Numeric. - "add 200/01/19 For ANSI <number> protocol." - ^ self asFloat! Item was removed: - ----- Method: Number>>asInteger (in category 'converting') ----- - asInteger - "Answer an Integer nearest the receiver toward zero." - - ^self truncated! Item was removed: - ----- Method: Number>>asNonFraction (in category 'converting') ----- - asNonFraction - "Answer a number equivalent to the receiver that is not a fraction. See Fraction for active method." - - ^self ! Item was removed: - ----- Method: Number>>asNumber (in category 'converting') ----- - asNumber - ^ self! Item was removed: - ----- Method: Number>>asPoint (in category 'converting') ----- - asPoint - "Answer a Point with the receiver as both coordinates; often used to - supply the same value in two dimensions, as with symmetrical gridding - or scaling." - - ^self @ self! Item was removed: - ----- Method: Number>>asScaledDecimal (in category 'converting') ----- - asScaledDecimal - "Answer a scaled decimal number approximating the receiver." - #Numeric. - - ^ self asScaledDecimal: 8 - ! Item was removed: - ----- Method: Number>>asScaledDecimal: (in category 'converting') ----- - asScaledDecimal: scale - "Answer a scaled decimal number, with a fractional precision of scale, - approximating the receiver." - #Numeric. - "add 200/01/19 For number protocol." - ^ ScaledDecimal newFromNumber: self scale: scale! Item was removed: - ----- Method: Number>>asSmallAngleDegrees (in category 'converting') ----- - asSmallAngleDegrees - "Return the receiver normalized to lie within the range (-180, 180)" - - | pos | - pos := self \\ 360. - pos > 180 ifTrue: [pos := pos - 360]. - ^ pos - - "#(-500 -300 -150 -5 0 5 150 300 500 1200) collect: [:n | n asSmallAngleDegrees]"! Item was removed: - ----- Method: Number>>asSmallPositiveDegrees (in category 'converting') ----- - asSmallPositiveDegrees - "Return the receiver normalized to lie within the range (0, 360)" - - ^self \\ 360! Item was removed: - ----- Method: Number>>byteEncode: (in category 'filter streaming') ----- - byteEncode:aStream - ^aStream writeNumber:self. - ! Item was removed: - ----- Method: Number>>ceiling (in category 'truncation and round off') ----- - ceiling - "Answer the integer nearest the receiver toward infinity." - - | truncation | - truncation := self truncated. - self <= 0 ifTrue: [^truncation]. - self = truncation - ifTrue: [^truncation] - ifFalse: [^truncation + 1]! Item was removed: - ----- Method: Number>>closeTo: (in category 'comparing') ----- - closeTo: num - "are these two numbers close?" - - num isFloat ifTrue: [^ num closeTo: self asFloat]. - ^[self = num] ifError: [false]! Item was removed: - ----- Method: Number>>copySignTo: (in category 'mathematical functions') ----- - copySignTo: aNumber - "Return a number with same magnitude as aNumber and same sign as self." - - ^ self signBit = 0 - ifTrue: [aNumber abs] - ifFalse: [aNumber abs negated].! Item was removed: - ----- Method: Number>>cos (in category 'mathematical functions') ----- - cos - "The receiver represents an angle measured in radians. Answer its cosine." - - ^self asFloat cos! Item was removed: - ----- Method: Number>>cosh (in category 'mathematical functions') ----- - cosh - "Answer receivers hyperbolic cosine." - - ^self asFloat cosh! Item was removed: - ----- Method: Number>>defaultLabelForInspector (in category 'printing') ----- - defaultLabelForInspector - "Answer the default label to be used for an Inspector window on the receiver." - - ^ super defaultLabelForInspector, ': ', ([self printStringLimitedTo: 100] - ifError: ['<error cannot print this number>'])! Item was removed: - ----- Method: Number>>degreeCos (in category 'mathematical functions') ----- - degreeCos - "Answer the cosine of the receiver taken as an angle in degrees." - - ^ (90 - (180 + self \\ 360 - 180) abs) degreesToRadians sin! Item was removed: - ----- Method: Number>>degreeSin (in category 'mathematical functions') ----- - degreeSin - "Answer the sine of the receiver taken as an angle in degrees." - - ^(90 - self) degreeCos! Item was removed: - ----- Method: Number>>degreesToRadians (in category 'converting') ----- - degreesToRadians - "The receiver is assumed to represent degrees. Answer the conversion to - radians." - - ^self asFloat degreesToRadians! Item was removed: - ----- Method: Number>>detentBy:atMultiplesOf:snap: (in category 'truncation and round off') ----- - detentBy: detent atMultiplesOf: grid snap: snap - "Map all values that are within detent/2 of any multiple of grid to that multiple. Otherwise, if snap is true, return self, meaning that the values in the dead zone will never be returned. If snap is false, then expand the range between dead zones so that it covers the range between multiples of the grid, and scale the value by that factor." - | r1 r2 | - r1 := self roundTo: grid. "Nearest multiple of grid" - (self roundTo: detent) = r1 ifTrue: [^ r1]. "Snap to that multiple..." - snap ifTrue: [^ self]. "...or return self" - - r2 := self < r1 "Nearest end of dead zone" - ifTrue: [r1 - (detent asFloat/2)] - ifFalse: [r1 + (detent asFloat/2)]. - "Scale values between dead zones to fill range between multiples" - ^ r1 + ((self - r2) * grid asFloat / (grid - detent)) - " - (170 to: 190 by: 2) collect: [:a | a detentBy: 10 atMultiplesOf: 90 snap: true] (170 to: 190 by: 2) collect: [:a | a detentBy: 10 atMultiplesOf: 90 snap: false] - (3.9 to: 4.1 by: 0.02) collect: [:a | a detentBy: 0.1 atMultiplesOf: 1.0 snap: true] (-3.9 to: -4.1 by: -0.02) collect: [:a | a detentBy: 0.1 atMultiplesOf: 1.0 snap: false] - "! Item was removed: - ----- Method: Number>>even (in category 'testing') ----- - even - "Answer whether the receiver is an even number." - - ^self \\ 2 = 0! Item was removed: - ----- Method: Number>>exp (in category 'mathematical functions') ----- - exp - "Answer the exponential of the receiver as a floating point number." - - ^self asFloat exp! Item was removed: - ----- Method: Number>>floor (in category 'truncation and round off') ----- - floor - "Answer the integer nearest the receiver toward negative infinity." - - | truncation | - truncation := self truncated. - self >= 0 ifTrue: [^truncation]. - self = truncation - ifTrue: [^truncation] - ifFalse: [^truncation - 1]! Item was removed: - ----- Method: Number>>floorLog: (in category 'mathematical functions') ----- - floorLog: radix - "Answer the floor of the log base radix of the receiver." - - ^(self log: radix) floor! Item was removed: - ----- Method: Number>>fractionPart (in category 'truncation and round off') ----- - fractionPart - - "Added for ANSI compatibility" - - ^self - self integerPart! Item was removed: - ----- Method: Number>>hasLimitedPrecision (in category 'testing') ----- - hasLimitedPrecision - "indicate whether this number has limited precision. - Arithmetic involving numbers with limited precision is potentially inexact. - The default implementation is false. - Subclass subject to inexact arithmetic shall refine." - ^false! Item was removed: - ----- Method: Number>>i (in category 'converting') ----- - i - ^ Complex real: 0 imaginary: self! Item was removed: - ----- Method: Number>>integerPart (in category 'truncation and round off') ----- - integerPart - "Added for ANSI compatibility" - ^self truncated! Item was removed: - ----- Method: Number>>interpolateTo:at: (in category 'mathematical functions') ----- - interpolateTo: aNumber at: param - ^self + (aNumber - self * param)! Item was removed: - ----- Method: Number>>isAnExactFloat (in category 'testing') ----- - isAnExactFloat - "Answer true if this Number can be converted exactly to a Float" - ^self subclassResponsibility! Item was removed: - ----- Method: Number>>isDivisibleBy: (in category 'testing') ----- - isDivisibleBy: aNumber - aNumber = 0 ifTrue: [^ false]. - aNumber isInteger ifFalse: [^ false]. - ^ (self \\ aNumber) = 0! Item was removed: - ----- Method: Number>>isFinite (in category 'testing') ----- - isFinite - ^true! Item was removed: - ----- Method: Number>>isInfinite (in category 'testing') ----- - isInfinite - - ^ false! Item was removed: - ----- Method: Number>>isNaN (in category 'testing') ----- - isNaN - ^ false! Item was removed: - ----- Method: Number>>isNumber (in category 'testing') ----- - isNumber - ^ true! Item was removed: - ----- Method: Number>>isOrAreStringWith: (in category 'printing') ----- - isOrAreStringWith: aNoun - | result | - result := self = 1 - ifTrue: - [' is one '] - ifFalse: - [self = 0 - ifTrue: - [' are no '] - ifFalse: - [' are ', self printString, ' ']]. - result := result, aNoun. - self = 1 ifFalse: [result := result, 's']. - ^ result - - "#(0 1 2 98.6) do: - [:num | Transcript cr; show: 'There', (num isOrAreStringWith: 'way'), ' to skin a cat']"! Item was removed: - ----- Method: Number>>isPowerOfTwo (in category 'testing') ----- - isPowerOfTwo - "Return true if the receiver is an integral power of two." - - self subclassResponsibility! Item was removed: - ----- Method: Number>>isZero (in category 'testing') ----- - isZero - ^self = 0! Item was removed: - ----- Method: Number>>ln (in category 'mathematical functions') ----- - ln - "Answer the natural log of the receiver." - - ^self asFloat ln! Item was removed: - ----- Method: Number>>log (in category 'mathematical functions') ----- - log - "Answer the base-10 log of the receiver." - - ^self asFloat log! Item was removed: - ----- Method: Number>>log2 (in category 'mathematical functions') ----- - log2 - "Answer the base-2 log of the receiver." - - ^self asFloat log2! Item was removed: - ----- Method: Number>>log: (in category 'mathematical functions') ----- - log: aNumber - "Answer the log base aNumber of the receiver." - - aNumber = 2 ifTrue: [^self log2]. - aNumber isPowerOfTwo ifTrue: [^self log2 / aNumber log2]. - ^self ln / aNumber ln! Item was removed: - ----- Method: Number>>negated (in category 'arithmetic') ----- - negated - "Answer a Number that is the negation of the receiver." - - ^0 - self! Item was removed: - ----- Method: Number>>negative (in category 'testing') ----- - negative - "Answer whether the receiver is mathematically negative." - - ^ self < 0! Item was removed: - ----- Method: Number>>nthRoot: (in category 'mathematical functions') ----- - nthRoot: aPositiveInteger - "Answer the nth root of the receiver." - - self subclassResponsibility! Item was removed: - ----- Method: Number>>odd (in category 'testing') ----- - odd - "Answer whether the receiver is an odd number." - - ^self even == false! Item was removed: - ----- Method: Number>>positive (in category 'testing') ----- - positive - "Answer whether the receiver is positive or equal to 0. (ST-80 protocol). - See also strictlyPositive" - - ^ self >= 0! Item was removed: - ----- Method: Number>>printOn: (in category 'printing') ----- - printOn: aStream - self printOn: aStream base: 10! Item was removed: - ----- Method: Number>>printOn:base: (in category 'printing') ----- - printOn: aStream base: base - "This method should print a representation of the number for the given base, - excluding the base prefix (and the letter r for radix)" - - ^self subclassResponsibility! Item was removed: - ----- Method: Number>>printOn:maxDecimalPlaces: (in category 'printing') ----- - printOn: aStream maxDecimalPlaces: placesDesired - "Print a representation of the receiver on aStream in decimal notation with at most prescribed number of places after decimal separator." - - | rounder rounded roundedFractionPart placesRequired shorten | - placesDesired <= 0 ifTrue: [^ self rounded printOn: aStream]. - rounder := 10 raisedToInteger: placesDesired. - rounded := self roundTo: rounder reciprocal. - rounded negative ifTrue: [aStream nextPut: $-]. - rounded := rounded abs. - rounded integerPart truncated printOn: aStream. - roundedFractionPart := (rounded fractionPart * rounder) truncated. - placesRequired := placesDesired. - [roundedFractionPart = 0 ifTrue: [^self]. - (shorten := roundedFractionPart // 10) * 10 = roundedFractionPart] - whileTrue: - [placesRequired := placesRequired - 1. - roundedFractionPart := shorten]. - placesRequired > 0 - ifTrue: - [aStream nextPut: $.. - roundedFractionPart printOn: aStream base: 10 length: placesRequired padded: true]! Item was removed: - ----- Method: Number>>printOn:showingDecimalPlaces: (in category 'printing') ----- - printOn: aStream showingDecimalPlaces: placesDesired - "Print a representation of the receiver on aStream in decimal notation with prescribed number of places after decimal separator." - - | rounder rounded roundedFractionPart | - placesDesired <= 0 ifTrue: [^ self rounded printOn: aStream]. - rounder := 10 raisedToInteger: placesDesired. - rounded := self roundTo: rounder reciprocal. - rounded negative ifTrue: [aStream nextPut: $-]. - rounded := rounded abs. - rounded integerPart truncated printOn: aStream. - aStream nextPut: $.. - roundedFractionPart := (rounded fractionPart * rounder) truncated. - roundedFractionPart printOn: aStream base: 10 length: placesDesired padded: true! Item was removed: - ----- Method: Number>>printShowingDecimalPlaces: (in category 'printing') ----- - printShowingDecimalPlaces: placesDesired - "Print the receiver showing precisely the given number of places desired. If placesDesired is positive, a decimal point and that many digits after the decimal point will always be shown. If placesDesired is zero, a whole number will be shown, without a decimal point." - - ^String new: placesDesired + 10 streamContents: [:aStream | - self printOn: aStream showingDecimalPlaces: placesDesired] - " - 23 printShowingDecimalPlaces: 2 - 23.5698 printShowingDecimalPlaces: 2 - -234.567 printShowingDecimalPlaces: 5 - 23.4567 printShowingDecimalPlaces: 0 - 23.5567 printShowingDecimalPlaces: 0 - -23.4567 printShowingDecimalPlaces: 0 - -23.5567 printShowingDecimalPlaces: 0 - 100000000 printShowingDecimalPlaces: 1 - 0.98 printShowingDecimalPlaces: 5 - -0.98 printShowingDecimalPlaces: 2 - 2.567 printShowingDecimalPlaces: 2 - -2.567 printShowingDecimalPlaces: 2 - 0 printShowingDecimalPlaces: 2 - "! Item was removed: - ----- Method: Number>>printShowingMaxDecimalPlaces: (in category 'printing') ----- - printShowingMaxDecimalPlaces: placesDesired - "Print the receiver showing at most the given number of places desired after the decimal point. - Trailing zeros of decimal part are discarded, so the number of digits after the decimal point may vary. - When placesDesired is zero or negative, or when fraction part vanish, no decimal point is shown." - - ^String new: placesDesired + 10 streamContents: [:aStream | - self printOn: aStream maxDecimalPlaces: placesDesired]! Item was removed: - ----- Method: Number>>printString (in category 'printing') ----- - printString - ^self printStringBase: 10! Item was removed: - ----- Method: Number>>printStringBase: (in category 'printing') ----- - printStringBase: base - ^ String streamContents: - [:strm | self printOn: strm base: base]! Item was removed: - ----- Method: Number>>quo: (in category 'arithmetic') ----- - quo: aNumber - "Integer quotient defined by division with truncation toward zero. -9 quo: - 4 = -2, -0.9 quo: 0.4 = -2. rem: answers the remainder from this division." - - ^(self / aNumber) truncated! Item was removed: - ----- Method: Number>>radiansToDegrees (in category 'converting') ----- - radiansToDegrees - "The receiver is assumed to represent radians. Answer the conversion to - degrees." - - ^self asFloat radiansToDegrees! Item was removed: - ----- Method: Number>>raisedTo: (in category 'mathematical functions') ----- - raisedTo: aNumber - "Answer the receiver raised to aNumber." - - aNumber isInteger ifTrue: [ - "Do the special case of integer power" - ^ self raisedToInteger: aNumber]. - aNumber isFraction ifTrue: [ - "Special case for fraction power" - ^ self raisedToFraction: aNumber]. - self negative ifTrue: [ - ^ ArithmeticError signal: 'Negative numbers can''t be raised to float powers.' ]. - aNumber isZero ifTrue: [^ self class one]. "Special case of exponent=0" - 1 = aNumber ifTrue: [^ self]. "Special case of exponent=1" - self isZero ifTrue: [ "Special case of self = 0" - aNumber negative - ifTrue: [^ (ZeroDivide dividend: 1) signal] - ifFalse: [^ self]]. - ^ (aNumber * self ln) exp "Otherwise use logarithms"! Item was removed: - ----- Method: Number>>raisedToFraction: (in category 'mathematical functions') ----- - raisedToFraction: aFraction - self isZero - ifTrue: - [aFraction negative ifTrue: [^ (ZeroDivide dividend: 1) signal]. - ^self]. - self negative ifFalse: [^(self ln * aFraction) exp]. - aFraction denominator even - ifTrue: [^ ArithmeticError signal: 'nth root only defined for positive Integer n.']. - ^(self negated ln * aFraction) exp negated! Item was removed: - ----- Method: Number>>raisedToInteger: (in category 'mathematical functions') ----- - raisedToInteger: anInteger - "The 0 raisedToInteger: 0 is an special case. In some contexts must be 1 and in others must - be handled as an indeterminate form. - I take the first context because that's the way that was previously handled. - Maybe further discussion is required on this topic." - - | bitProbe result | - anInteger negative ifTrue: [^(self raisedToInteger: anInteger negated) reciprocal]. - bitProbe := 1 bitShift: anInteger highBit - 1. - result := self class one. - [ - (anInteger bitAnd: bitProbe) > 0 ifTrue: [ result := result * self ]. - (bitProbe := bitProbe bitShift: -1) > 0 ] - whileTrue: [ result := result squared ]. - ^result! Item was removed: - ----- Method: Number>>reciprocal (in category 'arithmetic') ----- - reciprocal - "Returns the reciprocal of self. - In case self is 0 the / signals ZeroDivide" - - ^1 / self! Item was removed: - ----- Method: Number>>reduce (in category 'truncation and round off') ----- - reduce - "If self is close to an integer, return that integer" - ^ self! Item was removed: - ----- Method: Number>>rem: (in category 'arithmetic') ----- - rem: aNumber - "Remainder defined in terms of quo:. Answer a Number with the same - sign as self. e.g. 9 rem: 4 = 1, -9 rem: 4 = -1. 0.9 rem: 0.4 = 0.1." - - ^self - ((self quo: aNumber) * aNumber)! Item was removed: - ----- Method: Number>>roundDownTo: (in category 'truncation and round off') ----- - roundDownTo: aNumber - "Answer the next multiple of aNumber toward negative infinity that is nearest the - receiver." - "Examples: - 3.1479 roundDownTo: 0.01 -> 3.14 - 3.1479 roundDownTo: 0.1 -> 3.1 - 1923 roundDownTo: 10 -> 1920 - 3.1479 roundDownTo: 0.005 -> 3.145 - -3.1479 roundDownTo: 0.01 -> -3.15" - - ^(self/aNumber) floor * aNumber! Item was removed: - ----- Method: Number>>roundTo: (in category 'truncation and round off') ----- - roundTo: quantum - "Answer the nearest number that is a multiple of quantum." - - ^(self / quantum) rounded * quantum! Item was removed: - ----- Method: Number>>roundUpTo: (in category 'truncation and round off') ----- - roundUpTo: aNumber - "Answer the next multiple of aNumber toward infinity that is nearest the - receiver." - "Examples: - 3.1479 roundUpTo: 0.01 -> 3.15 - 3.1479 roundUpTo: 0.1 -> 3.2 - 1923 roundUpTo: 10 -> 1930 - 3.1479 roundUpTo: 0.005 -> 3.15 - -3.1479 roundUpTo: 0.01 -> -3.14" - - ^(self/aNumber) ceiling * aNumber! Item was removed: - ----- Method: Number>>rounded (in category 'truncation and round off') ----- - rounded - "Answer the integer nearest the receiver." - - ^(self + (self sign / 2)) truncated! Item was removed: - ----- Method: Number>>sign (in category 'mathematical functions') ----- - sign - "Answer 1 if the receiver is greater than 0, -1 if less than 0, else 0." - - self > 0 ifTrue: [^1]. - self < 0 ifTrue: [^-1]. - ^0! Item was removed: - ----- Method: Number>>sign: (in category 'mathematical functions') ----- - sign: aNumber - "Return a Number with the same sign as aNumber and same magnitude as self." - - ^ aNumber copySignTo: self! Item was removed: - ----- Method: Number>>signBit (in category 'mathematical functions') ----- - signBit - "Answer 1 if the receiver is negative, zero otherwise." - - self < 0 ifTrue: [^1]. - ^0! Item was removed: - ----- Method: Number>>sin (in category 'mathematical functions') ----- - sin - "The receiver represents an angle measured in radians. Answer its sine." - - ^self asFloat sin! Item was removed: - ----- Method: Number>>sinh (in category 'mathematical functions') ----- - sinh - "Answer receivers hyperbolic sine" - - ^self asFloat sinh! Item was removed: - ----- Method: Number>>sqrt (in category 'mathematical functions') ----- - sqrt - "Answer the square root of the receiver." - - self subclassResponsibility! Item was removed: - ----- Method: Number>>squared (in category 'mathematical functions') ----- - squared - "Answer the receiver multipled by itself." - - ^self * self! Item was removed: - ----- Method: Number>>storeOn: (in category 'printing') ----- - storeOn: aStream - self printOn: aStream! Item was removed: - ----- Method: Number>>storeOn:base: (in category 'printing') ----- - storeOn: aStream base: base - "This method should print a representation of the number for the given base, - including the base prefix (with letter r for radix)" - - ^self subclassResponsibility! Item was removed: - ----- Method: Number>>storeStringBase: (in category 'printing') ----- - storeStringBase: base - ^ String streamContents: [:strm | self storeOn: strm base: base]! Item was removed: - ----- Method: Number>>strictlyPositive (in category 'testing') ----- - strictlyPositive - "Answer whether the receiver is mathematically positive." - - ^ self > 0! Item was removed: - ----- Method: Number>>stringForReadout (in category 'printing') ----- - stringForReadout - ^ self rounded printString! Item was removed: - ----- Method: Number>>tan (in category 'mathematical functions') ----- - tan - "The receiver represents an angle measured in radians. Answer its - tangent." - - ^self asFloat tan! Item was removed: - ----- Method: Number>>tanh (in category 'mathematical functions') ----- - tanh - "Answer receivers hyperbolic tangent" - - ^self asFloat tanh! Item was removed: - ----- Method: Number>>to: (in category 'intervals') ----- - to: stop - "Answer an Interval from the receiver up to the argument, stop, - incrementing by 1." - - ^Interval from: self to: stop by: 1! Item was removed: - ----- Method: Number>>to:by: (in category 'intervals') ----- - to: stop by: step - "Answer an Interval from the receiver up to the argument, stop, - incrementing by step." - - ^Interval from: self to: stop by: step! Item was removed: - ----- Method: Number>>to:by:do: (in category 'intervals') ----- - to: stop by: step do: aBlock - "Normally compiled in-line, and therefore not overridable. - Evaluate aBlock for each element of the interval (self to: stop by: - step)." - | nextValue | - nextValue := self. - step = 0 ifTrue: [self error: 'step must be non-zero']. - step < 0 - ifTrue: [[stop <= nextValue] - whileTrue: - [aBlock value: nextValue. - nextValue := nextValue + step]] - ifFalse: [[stop >= nextValue] - whileTrue: - [aBlock value: nextValue. - nextValue := nextValue + step]]! Item was removed: - ----- Method: Number>>to:do: (in category 'intervals') ----- - to: stop do: aBlock - "Normally compiled in-line, and therefore not overridable. - Evaluate aBlock for each element of the interval (self to: stop by: 1)." - | nextValue | - nextValue := self. - [nextValue <= stop] - whileTrue: - [aBlock value: nextValue. - nextValue := nextValue + 1]! Item was removed: - ----- Method: Number>>truncateTo: (in category 'truncation and round off') ----- - truncateTo: aNumber - "Answer the next multiple of aNumber toward zero that is nearest the - receiver." - "Examples: - 3.1479 truncateTo: 0.01 -> 3.14 - 3.1479 truncateTo: 0.1 -> 3.1 - 1923 truncateTo: 10 -> 1920 - 3.1479 truncateTo: 0.005 -> 3.145 - -3.1479 truncateTo: 0.01 -> -3.14" - - ^(self quo: aNumber) - * aNumber! Item was removed: - ----- Method: Number>>truncated (in category 'truncation and round off') ----- - truncated - "Answer an integer nearest the receiver toward zero." - - ^self quo: 1! Item was removed: - ----- Method: Number>>veryDeepCopy (in category 'private') ----- - veryDeepCopy - "Overridden for performance." - ^ self! Item was removed: - Object subclass: #NumberParser - instanceVariableNames: 'sourceStream base neg integerPart fractionPart exponent scale nDigits lastNonZero requestor failBlock defaultBase' - classVariableNames: '' - poolDictionaries: '' - category: 'Kernel-Numbers'! - - !NumberParser commentStamp: 'ct 10/27/2021 22:04' prior: 0! - NumberParser is an abstract class for parsing and building numbers from string/stream. - It offers a framework with utility methods and exception handling. - - Number syntax is not defined and should be subclassResponsibility. - - Instance variables: - sourceStream <Stream> the stream of characters from which the number is read - base <Integer> the radix in which to interpret digits - neg <Boolean> true in case of minus sign - integerPart <Integer> the integer part of the number - fractionPart <Integer> the fraction part of the number if any - exponent <Integer> the exponent used in scientific notation if any - scale <Integer> the scale used in case of ScaledDecimal number if any - nDigits <Integer> number of digits read to form an Integer - lasNonZero <Integer> position of last non zero digit, starting at 1 from left, 0 if all digits are zero - requestor <TextEditor | nil> can be used to insert an error message in the requestor - failBlock <BlockClosure> Block to execute whenever an error occurs. - The fail block can have 0, 1 or 2 arguments (errorString and source position) - defaultBase <Integer> the default radix in which to interpret digits, unless specified differently via radix notation! Item was removed: - ----- Method: NumberParser class>>on: (in category 'instance creation') ----- - on: aStringOrStream - ^self new on: aStringOrStream! Item was removed: - ----- Method: NumberParser class>>parse: (in category 'instance creation') ----- - parse: aStringOrStream - ^(self new) - on: aStringOrStream; - nextNumber! Item was removed: - ----- Method: NumberParser class>>parse:onError: (in category 'instance creation') ----- - parse: aStringOrStream onError: failBlock - ^(self new) - on: aStringOrStream; - failBlock: failBlock; - nextNumber! Item was removed: - ----- Method: NumberParser>>allowPlusSign (in category 'accessing') ----- - allowPlusSign - "return a boolean indicating if plus sign is allowed or not" - - ^self subclassResponsibility! Item was removed: - ----- Method: NumberParser>>allowPlusSignInExponent (in category 'accessing') ----- - allowPlusSignInExponent - "return a boolean indicating if plus sign is allowed or not in exponent" - - ^self allowPlusSign! Item was removed: - ----- Method: NumberParser>>defaultBase (in category 'accessing') ----- - defaultBase - - ^ defaultBase! Item was removed: - ----- Method: NumberParser>>defaultBase: (in category 'accessing') ----- - defaultBase: anInteger - - self assert: anInteger < 28 description: 'Default base must be lower than 28 to keep radix r distinguishable from digits. For higher bases, pass the base manually to #nextNumberBase: autc.'. - defaultBase := anInteger! Item was removed: - ----- Method: NumberParser>>defaultRadixBase (in category 'accessing') ----- - defaultRadixBase - - ^ 10! Item was removed: - ----- Method: NumberParser>>error: (in category 'error') ----- - error: aString - NumberParserError signal: aString! Item was removed: - ----- Method: NumberParser>>expected: (in category 'error') ----- - expected: aString - | errorString | - errorString := aString , ' expected'. - requestor isNil - ifFalse: [requestor - notify: errorString - at: sourceStream position + 1 - in: sourceStream]. - failBlock ifNotNil: [^failBlock cull: errorString cull: sourceStream position + 1]. - self error: 'Reading a number failed: ' , errorString! Item was removed: - ----- Method: NumberParser>>exponentLetters (in category 'accessing') ----- - exponentLetters - "answer the list of possible exponents for Numbers." - - ^self subclassResponsibility! Item was removed: - ----- Method: NumberParser>>failBlock: (in category 'accessing') ----- - failBlock: aBlockOrNil - failBlock := aBlockOrNil! Item was removed: - ----- Method: NumberParser>>initialize (in category 'initialize-release') ----- - initialize - - defaultBase := 10! Item was removed: - ----- Method: NumberParser>>isExponentLetter: (in category 'testing') ----- - isExponentLetter: aCharacter - - ^self exponentLetters includes: aCharacter! Item was removed: - ----- Method: NumberParser>>makeFloatFromMantissa:exponent:base: (in category 'parsing-private') ----- - makeFloatFromMantissa: m exponent: k base: aRadix - "Convert infinite precision arithmetic into limited precision Floating point. - This algorithm rely on correct IEEE rounding mode - being implemented in Integer>>asFloat and Fraction>>asFloat" - - k = 0 ifTrue: [ ^m asFloat ]. - k > 0 ifTrue: [ ^(m * (aRadix raisedToInteger: k)) asFloat ]. - ^(Fraction numerator: m denominator: (aRadix raisedToInteger: k negated)) asFloat! Item was removed: - ----- Method: NumberParser>>makeScaledDecimalWithNumberOfNonZeroFractionDigits:andNumberOfTrailingZeroInFractionPart: (in category 'parsing-private') ----- - makeScaledDecimalWithNumberOfNonZeroFractionDigits: numberOfNonZeroFractionDigits andNumberOfTrailingZeroInFractionPart: numberOfTrailingZeroInFractionPart - "at this point integerPart fractionPart and scale have been read out (in inst var). - Form a ScaledDecimal. - Care of eliminating trailing zeroes from the fractionPart" - - | decimalMultiplier decimalFraction | - decimalMultiplier := base raisedToInteger: numberOfNonZeroFractionDigits. - decimalFraction := integerPart * decimalMultiplier + (fractionPart // (base raisedTo: numberOfTrailingZeroInFractionPart)) / decimalMultiplier. - ^ ScaledDecimal - newFromNumber: (neg - ifTrue: [decimalFraction negated] - ifFalse: [decimalFraction]) - scale: scale! Item was removed: - ----- Method: NumberParser>>nextElementaryLargeIntegerBase: (in category 'parsing-large int') ----- - nextElementaryLargeIntegerBase: aRadix - "Form an unsigned integer with incoming digits from sourceStream. - Return this integer, or zero if no digits found. - Stop reading if end of digits or if a LargeInteger is formed. - Count the number of digits and the position of lastNonZero digit and store them in instVar." - - | value digit char | - value := 0. - nDigits := 0. - lastNonZero := 0. - [ - value isLarge ifTrue: [ ^value ]. - char := sourceStream next ifNil: [ ^value ]. - ((digit := char digitValue) < 0 or: [digit >= aRadix]) ifTrue: [ - sourceStream skip: -1. - ^value ]. - nDigits := nDigits + 1. - digit = 0 - ifFalse: [ - lastNonZero := nDigits. - value := value * aRadix + digit ] - ifTrue: [ value := value * aRadix ] ] repeat! Item was removed: - ----- Method: NumberParser>>nextInteger (in category 'parsing-public') ----- - nextInteger - "Read an Integer from sourceStream, asnwser that Integer. - This is a generic version dealing with an optional sign and a simple sequence of decimal digits. - Subclass might define extended syntax." - - base := self defaultBase. - ^self nextIntegerBase: base ifFail: [^self expected: ('a digit between 0 and ' copyWith: (Character digitValue: base - 1))]! Item was removed: - ----- Method: NumberParser>>nextIntegerBase: (in category 'parsing-public') ----- - nextIntegerBase: aRadix - "Form an integer with following digits. - Fail if no digit found" - - | isNeg value | - isNeg := self peekSignIsMinus. - value := self nextUnsignedIntegerBase: aRadix. - ^isNeg - ifTrue: [value negated] - ifFalse: [value]! Item was removed: - ----- Method: NumberParser>>nextIntegerBase:ifFail: (in category 'parsing-public') ----- - nextIntegerBase: aRadix ifFail: aBlock - "Form an integer with optional sign and following digits from sourceStream." - - | isNeg value | - isNeg := self peekSignIsMinus. - value := self nextUnsignedIntegerOrNilBase: aRadix. - value ifNil: [^aBlock value]. - ^isNeg - ifTrue: [value negated] - ifFalse: [value]! Item was removed: - ----- Method: NumberParser>>nextLargeIntegerBase:nPackets: (in category 'parsing-large int') ----- - nextLargeIntegerBase: aRadix nPackets: nPackets - "Form a Large integer with incoming digits from sourceStream. - Return this integer, or zero if no digits found. - Stop reading when no more digits or when nPackets elementary LargeInteger have been encountered. - Count the number of digits and the lastNonZero digit and store them in instVar" - - | high nDigitsHigh lastNonZeroHigh low nDigitsLow halfPackets | - halfPackets := nPackets bitShift: -1. - halfPackets = 0 ifTrue: [^self nextElementaryLargeIntegerBase: aRadix]. - high := self nextLargeIntegerBase: aRadix nPackets: halfPackets. - high isLarge ifFalse: [^high]. - nDigitsHigh := nDigits. - lastNonZeroHigh := lastNonZero. - low := self nextLargeIntegerBase: aRadix nPackets: halfPackets. - nDigitsLow := nDigits. - nDigits := nDigitsHigh + nDigitsLow. - lastNonZero := lastNonZero = 0 - ifTrue: [lastNonZeroHigh] - ifFalse: [lastNonZero + nDigitsHigh]. - ^high * (aRadix raisedToInteger: nDigitsLow) + low! Item was removed: - ----- Method: NumberParser>>nextNumber (in category 'parsing-public') ----- - nextNumber - "read next number from sourceStream contents" - - ^self subclassResponsibility! Item was removed: - ----- Method: NumberParser>>nextUnsignedInteger (in category 'parsing-public') ----- - nextUnsignedInteger - "Read an Integer from sourceStream, asnwser that Integer. - This is a generic version dealing with a simple sequence of decimal digits. - Subclass might define extended syntax." - - base := self defaultBase. - ^self nextUnsignedIntegerBase: base ifFail: [^self expected: ('a digit between 0 and ' copyWith: (Character digitValue: base - 1))]! Item was removed: - ----- Method: NumberParser>>nextUnsignedIntegerBase: (in category 'parsing-public') ----- - nextUnsignedIntegerBase: aRadix - "Form an unsigned integer with incoming digits from sourceStream. - Fail if no digit found. - Count the number of digits and the lastNonZero digit and store int in instVar " - - | value | - value := self nextUnsignedIntegerOrNilBase: aRadix. - value ifNil: [^self expected: ('a digit between 0 and ' copyWith: (Character digitValue: aRadix - 1))]. - ^value! Item was removed: - ----- Method: NumberParser>>nextUnsignedIntegerBase:ifFail: (in category 'parsing-public') ----- - nextUnsignedIntegerBase: aRadix ifFail: errorBlock - "Form an unsigned integer with incoming digits from sourceStream. - Answer this integer, or execute errorBlock if no digit found. - Count the number of digits and the position of lastNonZero digit and store them in instVar" - - | value | - value := self nextUnsignedIntegerOrNilBase: aRadix. - value ifNil: [^errorBlock value]. - ^value! Item was removed: - ----- Method: NumberParser>>nextUnsignedIntegerOrNilBase: (in category 'parsing-public') ----- - nextUnsignedIntegerOrNilBase: aRadix - "Form an unsigned integer with incoming digits from sourceStream. - Answer this integer, or nil if no digit found. - Count the number of digits and the position of lastNonZero digit and store them in instVar" - - | nPackets high nDigitsHigh lastNonZeroHigh low | - "read no more digits than one elementary LargeInteger" - high := self nextElementaryLargeIntegerBase: aRadix. - nDigits = 0 ifTrue: [^nil]. - - "Not enough digits to form a LargeInteger, stop iteration" - high isLarge ifFalse: [^high]. - - "We now have to engage arithmetic with LargeInteger - Decompose the integer in a high and low packets of growing size:" - nPackets := 1. - nDigitsHigh := nDigits. - lastNonZeroHigh := lastNonZero. - [ - low := self nextLargeIntegerBase: aRadix nPackets: nPackets . - high := high * (aRadix raisedToInteger: nDigits) + low. - lastNonZero = 0 ifFalse: [lastNonZeroHigh := lastNonZero + nDigitsHigh]. - nDigitsHigh := nDigitsHigh + nDigits. - low isLarge] - whileTrue: [nPackets := nPackets * 2]. - - nDigits := nDigitsHigh. - lastNonZero := lastNonZeroHigh. - ^high! Item was removed: - ----- Method: NumberParser>>on: (in category 'initialize-release') ----- - on: aStringOrStream - sourceStream := aStringOrStream isString - ifTrue: [ aStringOrStream readStream ] - ifFalse: [ aStringOrStream ]. - base := self defaultBase. - neg := false. - integerPart := fractionPart := exponent := scale := 0. - requestor := failBlock := nil! Item was removed: - ----- Method: NumberParser>>peekSignIsMinus (in category 'parsing-private') ----- - peekSignIsMinus - "Peek an optional sign from sourceStream. - Answer true if it is minus sign" - - | isMinus | - isMinus := sourceStream peekFor: $-. - isMinus ifFalse: [self allowPlusSign ifTrue: [sourceStream peekFor: $+]]. - ^isMinus! Item was removed: - ----- Method: NumberParser>>readExponent (in category 'parsing-private') ----- - readExponent - "read the exponent if any (stored in instVar). - Answer true if found, answer false if none. - If exponent letter is not followed by a digit, - this is not considered as an error. - Exponent are always read in base 10." - - | eneg epos | - exponent := 0. - (self isExponentLetter: sourceStream peek) ifFalse: [^ false]. - sourceStream next. - eneg := sourceStream peekFor: $-. - epos := eneg not and: [self allowPlusSignInExponent and: [sourceStream peekFor: $+]]. - exponent := self nextUnsignedIntegerOrNilBase: self defaultBase. - exponent ifNil: ["Oops, there was no digit after the exponent letter.Ungobble the letter" - exponent := 0. - sourceStream - skip: ((eneg or: [epos]) - ifTrue: [-2] - ifFalse: [-1]). - ^ false]. - eneg ifTrue: [exponent := exponent negated]. - ^true! Item was removed: - ----- Method: NumberParser>>requestor: (in category 'accessing') ----- - requestor: anObjectOrNil - requestor := anObjectOrNil! Item was removed: - Error subclass: #NumberParserError - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Kernel-Numbers-Exceptions'! Item was removed: - ProtoObject subclass: #Object - instanceVariableNames: '' - classVariableNames: 'DependentsFields' - poolDictionaries: '' - category: 'Kernel-Objects'! - - !Object commentStamp: '<historical>' prior: 0! - Object is the root class for almost all of the other classes in the class hierarchy. The exceptions are ProtoObject (the superclass of Object) and its subclasses. - - Class Object provides default behavior common to all normal objects, such as access, copying, comparison, error handling, message sending, and reflection. Also utility messages that all objects should respond to are defined here. - - Object has no instance variables, nor should any be added. This is due to several classes of objects that inherit from Object that have special implementations (SmallInteger and UndefinedObject for example) or the VM knows about and depends on the structure and layout of certain standard classes. - - Class Variables: - DependentsFields an IdentityDictionary - Provides a virtual 'dependents' field so that any object may have one - or more dependent views, synchronized by the changed:/update: protocol. - Note that class Model has a real slot for its dependents, and overrides - the associated protocol with more efficient implementations. - EventsFields an IdentityDictionary that maps each object to its dependents. - Registers a message send (consisting of a selector and a receiver object) - which should be performed when anEventSymbol is triggered by the receiver. - Part of a new event notification framework which could eventually replace - the existing changed/update mechanism. It is intended to be compatible - with Dolphin Smalltalk and VSE as much as possible. - - Because Object is the root of the inheritance tree, methods are often defined in Object to give all objects special behaviors needed by certain subsystems or applications, or to respond to certain general test messages such as isMorph.! Item was removed: - ----- Method: Object class>>basicReadFrom: (in category 'instance creation') ----- - basicReadFrom: textStringOrStream - "Create an object based on the contents of textStringOrStream." - - | object | - (Compiler couldEvaluate: textStringOrStream) - ifFalse: [^ self error: 'expected String, Stream, or Text' translated]. - object := self environment beCurrentDuring: [ - Compiler evaluate: textStringOrStream environment: self environment]. - (object isKindOf: self) ifFalse: [self error: ('{1} expected' translated format: {self name})]. - ^object! Item was removed: - ----- Method: Object class>>categoryForUniclasses (in category 'instance creation') ----- - categoryForUniclasses - "Answer the default system category into which to place unique-class instances" - - ^ 'UserObjects'! Item was removed: - ----- Method: Object class>>chooseUniqueClassName (in category 'instance creation') ----- - chooseUniqueClassName - | i className | - i := 1. - [className := (self name , i printString) asSymbol. - Smalltalk includesKey: className] - whileTrue: [i := i + 1]. - ^ className! Item was removed: - ----- Method: Object class>>createFrom:size:version: (in category 'objects from disk') ----- - createFrom: aSmartRefStream size: varsOnDisk version: instVarList - "Create an instance of me so objects on the disk can be read in. Tricky part is computing the size if variable. Inst vars will be filled in later. " - - ^ self isVariable - ifFalse: [self basicNew] - ifTrue: ["instVarList is names of old class's inst vars plus a version number" - self basicNew: (varsOnDisk - (instVarList size - 1))] - ! Item was removed: - ----- Method: Object class>>fileReaderServicesForDirectory: (in category 'file list services') ----- - fileReaderServicesForDirectory: aFileDirectory - "Backstop" - ^#()! Item was removed: - ----- Method: Object class>>fileReaderServicesForFile:suffix: (in category 'file list services') ----- - fileReaderServicesForFile: fullName suffix: suffix - "Backstop" - ^#()! Item was removed: - ----- Method: Object class>>flushDependents (in category 'class initialization') ----- - flushDependents - DependentsFields keysAndValuesDo:[:key :dep| - key ifNotNil:[key removeDependent: nil]. - ]. - DependentsFields finalizeValues.! Item was removed: - ----- Method: Object class>>howToModifyPrimitives (in category 'documentation') ----- - howToModifyPrimitives - "You are allowed to write methods which specify primitives, but please use - caution. If you make a subclass of a class which contains a primitive method, - the subclass inherits the primitive. The message which is implemented - primitively may be overridden in the subclass (E.g., see at:put: in String's - subclass Symbol). The primitive behavior can be invoked using super (see - Symbol string:). - - A class which attempts to mimic the behavior of another class without being - its subclass may or may not be able to use the primitives of the original class. - In general, if the instance variables read or written by a primitive have the - same meanings and are in the same fields in both classes, the primitive will - work. - - For certain frequently used 'special selectors', the compiler emits a - send-special-selector bytecode instead of a send-message bytecode. Special - selectors were created because they offer two advantages. First, code which - sends special selectors compiles into fewer bytes than normal. Second, for - some pairs of receiver classes and special selectors, the interpreter jumps - directly to a primitive routine without looking up the method in the class, - and the just-in-time (JIT) compiler (if in use) may emit code to directly execute - the primitive. At least in the interpreter this is much faster than a normal - message lookup. In both the interpreter and the JIT send-special-selector, - conditional branch pairs are short-circuited for the comparison selectors when - applied to SmallIntegers or Floats. - - A selector which is a special selector solely in order to save space has - normal behavior. Methods whose selectors are special in order to - gain speed contain the comment, 'No Lookup'. When the virtual machine - encounters a send-special-selector bytecode, it checks the class of the - receiver and the selector. If the class-selector pair is a no-lookup pair, - then the interpreter swiftly jumps to the routine which implements the - corresponding primitive. (A special selector whose receiver is not of the - right class to make a no-lookup pair, is looked up normally). The pairs are - listed below. No-lookup methods contain a primitive number specification, - <primitive: xx>, which is redundant. Since the method is not normally looked - up, deleting the primitive number specification cannot prevent this - primitive from running. If a no-lookup primitive fails, the method is looked - up normally, and the expressions in it are executed. - - No Lookup pairs of (class, selector) - - SmallInteger and Float with any of + - * / - SmallInteger with any of \\ bitOr: bitShift: bitAnd: // @ - SmallInteger and Float with any of = ~= > < >= <= - Any class with == ~~ class - Point with either of x y (interpreter only) - BlockClosure with either of value value: (interpreter only) - " - - self error: 'comment only'! Item was removed: - ----- Method: Object class>>initialInstance (in category 'instance creation') ----- - initialInstance - "Answer the first instance of the receiver, generate an error if there is one already" - "self instanceCount > 0 ifTrue: [self error: 'instance(s) already exist.']." - "Debugging test that is very slow" - ^ self new! Item was removed: - ----- Method: Object class>>initialize (in category 'class initialization') ----- - initialize - "Object initialize" - DependentsFields ifNil:[self initializeDependentsFields].! Item was removed: - ----- Method: Object class>>initializeDependentsFields (in category 'class initialization') ----- - initializeDependentsFields - "Object initialize" - DependentsFields := WeakIdentityKeyDictionary new. - ! Item was removed: - ----- Method: Object class>>initializedInstance (in category 'instance creation') ----- - initializedInstance - self isAbstract ifTrue: [^nil]. - ^ self new! Item was removed: - ----- Method: Object class>>instanceOfUniqueClass (in category 'instance creation') ----- - instanceOfUniqueClass - "Answer an instance of a unique subclass of the receiver" - - ^ self instanceOfUniqueClassWithInstVarString: '' andClassInstVarString: ''! Item was removed: - ----- Method: Object class>>instanceOfUniqueClassWithInstVarString:andClassInstVarString: (in category 'instance creation') ----- - instanceOfUniqueClassWithInstVarString: instVarString andClassInstVarString: classInstVarString - "Create a unique class for the receiver, and answer an instance of it" - - ^ (self newUniqueClassInstVars: instVarString - classInstVars: classInstVarString) initialInstance! Item was removed: - ----- Method: Object class>>isUniClass (in category 'instance creation') ----- - isUniClass - ^ false! Item was removed: - ----- Method: Object class>>newFrom: (in category 'instance creation') ----- - newFrom: aSimilarObject - "Create an object that has similar contents to aSimilarObject. - If the classes have any instance varaibles with the same names, copy them across. - If this is bad for a class, override this method." - - ^ (self isVariable - ifTrue: [self basicNew: aSimilarObject basicSize] - ifFalse: [self basicNew] - ) copySameFrom: aSimilarObject! Item was removed: - ----- Method: Object class>>newUniqueClassInstVars:classInstVars: (in category 'instance creation') ----- - newUniqueClassInstVars: instVarString classInstVars: classInstVarString - "Create a unique class for the receiver" - - | aName aClass | - self isSystemDefined ifFalse: - [^ superclass newUniqueClassInstVars: instVarString classInstVars: classInstVarString]. - aName := self chooseUniqueClassName. - aClass := self subclass: aName instanceVariableNames: instVarString - classVariableNames: '' poolDictionaries: '' category: self categoryForUniclasses. - classInstVarString size > 0 ifTrue: - [aClass class instanceVariableNames: classInstVarString]. - - self flag: #todo. self flag: #uniclasses. "Discuss if we really want to hide uniclasses again" - aClass environment: aClass newEnvironment. - aClass environment organization - classify: aClass name - under: (self environment organization categoryOfElement: aClass name). - self environment forgetClass: aClass logged: false. - self removeSubclass: aClass. - - ^ aClass! Item was removed: - ----- Method: Object class>>newUserInstance (in category 'instance creation') ----- - newUserInstance - "Answer an instance of an appropriate class to serve as a user object in the containment hierarchy" - - ^ self instanceOfUniqueClass! Item was removed: - ----- Method: Object class>>postRecompileAction (in category 'documentation') ----- - postRecompileAction - "This is a stub method to document the convention for reinitializing state at the end of Compiler recompileAll. - The issue is that after recompiling all methods, processes or blocks could remain that refer to old methods, - and that somehow those processes should be restarted and objects referring to blocks rebuilt. For example, - PluggableDictionary integerDictionary creates a PluggableDictionary with a hashBlock that refers to the - PluggableDictionary class>>#integerDictionary method. Users of PluggableDictionary integerDictionary can - rebuild structures containing it after recompile by implementing thsi method to do so. Compiler will then - invoke any and all such methods after recompileAll." - - ^self! Item was removed: - ----- Method: Object class>>reInitializeDependentsFields (in category 'class initialization') ----- - reInitializeDependentsFields - "Object reInitializeDependentsFields" - | oldFields | - oldFields := DependentsFields. - DependentsFields := WeakIdentityKeyDictionary new. - oldFields keysAndValuesDo:[:obj :deps| - deps do:[:d| obj addDependent: d]]. - ! Item was removed: - ----- Method: Object class>>readCarefullyFrom: (in category 'instance creation') ----- - readCarefullyFrom: textStringOrStream - "Create an object based on the contents of textStringOrStream. Return an error instead of putting up a SyntaxError window." - - ^ [self basicReadFrom: textStringOrStream] - on: SyntaxErrorNotification - do: [:ex | self error: ex messageText]! Item was removed: - ----- Method: Object class>>readFrom: (in category 'instance creation') ----- - readFrom: textStringOrStream - "Create an object based on the contents of textStringOrStream." - - ^ self basicReadFrom: textStringOrStream! Item was removed: - ----- Method: Object class>>releaseExternalSettings (in category 'private') ----- - releaseExternalSettings - "Do nothing as a default"! Item was removed: - ----- Method: Object class>>releaseNotes (in category 'documentation') ----- - releaseNotes - "This is a scratch pad of release notes for the 6.0 release this version is building towards. - Feel free to add to this comment mention of things that should appear in the release notes. - - <tbd>" - - self error: 'comment only'! Item was removed: - ----- Method: Object class>>services (in category 'file list services') ----- - services - "Backstop" - ^#()! Item was removed: - ----- Method: Object class>>whatIsAPrimitive (in category 'documentation') ----- - whatIsAPrimitive - "Some messages in the system are responded to primitively. A primitive - response is performed directly by the virtual machine rather than by - evaluating expressions in a method. The methods for these messages - indicate the presence of a primitive response by including one of - <primitive: N> - <primitive: N error: errorCode> - <primitive: 'primitiveName' module: 'module name'> - <primitive: 'primitiveName' module: 'module name' error: errorCode> - before the first expression in the method. - - Primitives exist for several reasons. Certain basic or 'primitive' operations - cannot be performed in any other way. Smalltalk without primitives can - move values from one variable to another, but cannot add two SmallIntegers - together. Many methods for arithmetic and comparison between numbers - are primitives. Some primitives allow Smalltalk to communicate with I/O - devices such as the disk, the display, and the keyboard. Some primitives - exist only to make the system run faster; each does the same thing as a - certain Smalltalk method, and its implementation as a primitive is optional. - - When the Smalltalk virtual machine begins to execute a method which - specifies a primitive response, it tries to perform the primitive action and to - return a result. If the routine in the virtual machine for this primitive is - successful, it will return a value and the expressions in the method will not - be evaluated. If the primitive routine is not successful, the primitive 'fails', - and the Smalltalk expressions in the method are executed instead. These - expressions are evaluated as though the primitive routine had not been called. - - The Smalltalk code that is evaluated when a primitive fails usually anticipates - why that primitive might fail. If the primitive is optional, the expressions in the - method do exactly what the primitive would have done (See Number @). If the - primitive only works on certain classes of arguments, the Smalltalk code tries - to coerce the argument or appeals to a superclass to find a more general way - of doing the operation (see SmallInteger +). If the primitive is never supposed - to fail, the expressions signal an error (see e.g. SmallInteger asFloat). - - Each method that specifies a primitive has a comment in it. If the primitive is - optional, the comment will say 'Optional'. An optional primitive that is not - implemented always fails, and the Smalltalk expressions do the work instead. - - If a primitive is not optional, the comment will say, 'Essential'. If the primitive is - so required, the comment will say 'Do not override in a subclass'. Some methods - will have the comment, 'No Lookup'. See Object howToModifyPrimitives for an - explanation of special selectors which are not looked up. - - The comments in the SmallInteger primitives say 'Fails if result is not a SmallInteger', - even though the implementor has the option to construct a LargePositiveInteger. - For further information on primitives, see the 'Primitive Methods' part of the - chapter on the formal specification of the virtual machine in - Smalltalk-80: The Language and its Implementation." - - self error: 'comment only'! Item was removed: - ----- Method: Object>>-> (in category 'associating') ----- - -> anObject - "Answer an Association between self and anObject" - - ^Association basicNew key: self value: anObject! Item was removed: - ----- Method: Object>>= (in category 'comparing') ----- - = anObject - "Answer whether the receiver and the argument represent the same - object. If = is redefined in any subclass, consider also redefining the - message hash." - - ^self == anObject! Item was removed: - ----- Method: Object>>acceptDroppingMorph:event:inMorph: (in category 'drag and drop') ----- - acceptDroppingMorph: transferMorph event: evt inMorph: dstListMorph - - ^false.! Item was removed: - ----- Method: Object>>adaptToFloat:andCompare: (in category 'converting') ----- - adaptToFloat: rcvr andCompare: selector - "If I am involved in comparison with a Float. - Default behaviour is to process comparison as any other selectors." - ^ self adaptToFloat: rcvr andSend: selector! Item was removed: - ----- Method: Object>>adaptToFloat:andSend: (in category 'converting') ----- - adaptToFloat: rcvr andSend: selector - "If no method has been provided for adapting an object to a Float, - then it may be adequate to simply adapt it to a number." - ^ self adaptToNumber: rcvr andSend: selector! Item was removed: - ----- Method: Object>>adaptToFraction:andCompare: (in category 'converting') ----- - adaptToFraction: rcvr andCompare: selector - "If I am involved in comparison with a Fraction. - Default behaviour is to process comparison as any other selectors." - ^ self adaptToFraction: rcvr andSend: selector! Item was removed: - ----- Method: Object>>adaptToFraction:andSend: (in category 'converting') ----- - adaptToFraction: rcvr andSend: selector - "If no method has been provided for adapting an object to a Fraction, - then it may be adequate to simply adapt it to a number." - ^ self adaptToNumber: rcvr andSend: selector! Item was removed: - ----- Method: Object>>adaptToInteger:andCompare: (in category 'converting') ----- - adaptToInteger: rcvr andCompare: selector - "If I am involved in comparison with an Integer. - Default behaviour is to process comparison as any other selectors." - ^ self adaptToInteger: rcvr andSend: selector! Item was removed: - ----- Method: Object>>adaptToInteger:andSend: (in category 'converting') ----- - adaptToInteger: rcvr andSend: selector - "If no method has been provided for adapting an object to a Integer, - then it may be adequate to simply adapt it to a number." - ^ self adaptToNumber: rcvr andSend: selector! Item was removed: - ----- Method: Object>>adaptToScaledDecimal:andCompare: (in category 'converting') ----- - adaptToScaledDecimal: rcvr andCompare: selector - "If I am involved in comparison with a ScaledDecimal. - Default behaviour is to process comparison as any other selectors." - ^ self adaptToScaledDecimal: rcvr andSend: selector! Item was removed: - ----- Method: Object>>adaptToScaledDecimal:andSend: (in category 'converting') ----- - adaptToScaledDecimal: rcvr andSend: selector - "If no method has been provided for adapting an object to a ScaledDecimal, - then it may be adequate to simply adapt it to a number." - ^ self adaptToNumber: rcvr andSend: selector! Item was removed: - ----- Method: Object>>adaptedToWorld: (in category 'scripting') ----- - adaptedToWorld: aWorld - "If I refer to a world or a hand, return the corresponding items in the new world." - ^self! Item was removed: - ----- Method: Object>>addDependent: (in category 'dependents access') ----- - addDependent: anObject - "Make the given object one of the receiver's dependents." - - | dependents | - dependents := self dependents. - (dependents includes: anObject) ifFalse: - [self myDependents: (dependents copyWithDependent: anObject)]. - ^ anObject! Item was removed: - ----- Method: Object>>addModelItemsToWindowMenu: (in category 'user interface') ----- - addModelItemsToWindowMenu: aMenu - "aMenu is being constructed to be presented to the user in response to the user's pressing on the menu widget in the title bar of a morphic window. Here, the model is given the opportunity to add any model-specific items to the menu, whose default target is the SystemWindow itself."! Item was removed: - ----- Method: Object>>addModelMenuItemsTo:forMorph:hand: (in category 'user interface') ----- - addModelMenuItemsTo: aCustomMenu forMorph: aMorph hand: aHandMorph - "The receiver serves as the model for aMorph; a menu is being constructed for the morph, and here the receiver is able to add its own items" - ! Item was removed: - ----- Method: Object>>addModelYellowButtonMenuItemsTo:forMorph:hand: (in category 'graph model') ----- - addModelYellowButtonMenuItemsTo: aCustomMenu forMorph: aMorph hand: aHandMorph - "The receiver serves as the model for aMorph; a menu is being constructed for the morph, and here the receiver is able to add its own items" - - aCustomMenu add: 'inspect model' translated target: self action: #inspect. - ^aCustomMenu - ! Item was removed: - ----- Method: Object>>allLiteralsDo: (in category 'literals') ----- - allLiteralsDo: aBlock - - self flag: #discuss. "mt: Better implement this only on Symbol, Array, Number, Binding, etc. instead of Object?" - aBlock value: self.! Item was removed: - ----- Method: Object>>as: (in category 'converting') ----- - as: aSimilarClass - "Create an object of class aSimilarClass that has similar contents to the receiver." - - ^ aSimilarClass newFrom: self! Item was removed: - ----- Method: Object>>asExplorerString (in category 'user interface') ----- - asExplorerString - "The ObjectExplorer only shows a single line of text. Most of it is clipped anyway. So speed up the data collection by reducing the number of characters drastically." - - ^ self printStringLimitedTo: 300! Item was removed: - ----- Method: Object>>asOop (in category 'system primitives') ----- - asOop - "This method is for compatibility only. - In Smalltalk, this used to return an integer unique to each object. - In Squeak, OOPs are internal to the VM. Accessing an OOP would be useless anyway since it changes when the object is moved during garbage collection." - - ^self identityHash! Item was removed: - ----- Method: Object>>asOrderedCollection (in category 'converting') ----- - asOrderedCollection - "Answer an OrderedCollection with the receiver as its only element." - - ^ OrderedCollection with: self! Item was removed: - ----- Method: Object>>asSetElement (in category 'converting') ----- - asSetElement - "Answer an object, which can be put into a Set as element , wrapped - by one of SetElement instance, if necessary. - Default implementation is to answer self" - ! Item was removed: - ----- Method: Object>>asString (in category 'converting') ----- - asString - "Answer a string that represents the receiver." - - ^ self printString ! Item was removed: - ----- Method: Object>>asStringOrText (in category 'converting') ----- - asStringOrText - "Answer a string that represents the receiver." - ^ self asString! Item was removed: - ----- Method: Object>>assert: (in category 'error handling') ----- - assert: aBlock - "Throw an assertion error if aBlock does not evaluates to true." - - aBlock value ifFalse: [AssertionFailure signal: 'Assertion failed']! Item was removed: - ----- Method: Object>>assert:description: (in category 'error handling') ----- - assert: aBlock description: aStringOrBlock - "Throw an assertion error if aBlock does not evaluates to true." - - aBlock value ifFalse: [ AssertionFailure signal: aStringOrBlock value ]! Item was removed: - ----- Method: Object>>assert:descriptionBlock: (in category 'error handling') ----- - assert: aBlock descriptionBlock: descriptionBlock - "Throw an assertion error if aBlock does not evaluate to true." - - aBlock value ifFalse: [AssertionFailure signal: descriptionBlock value asString ]! Item was removed: - ----- Method: Object>>at: (in category 'accessing') ----- - at: index - "Primitive. Assumes receiver is indexable. Answer the value of an - indexable element in the receiver. Fail if the argument index is not an - Integer or is out of bounds. Essential. See Object documentation - whatIsAPrimitive." - - <primitive: 60> - index isInteger ifTrue: - [self class isVariable - ifTrue: [self errorSubscriptBounds: index] - ifFalse: [self errorNotIndexable]]. - index isNumber - ifTrue: [^self at: index asInteger] - ifFalse: [self errorNonIntegerIndex]! Item was removed: - ----- Method: Object>>at:modify: (in category 'accessing') ----- - at: index modify: aBlock - "Replace the element of the collection with itself transformed by the block" - ^ self at: index put: (aBlock value: (self at: index))! Item was removed: - ----- Method: Object>>at:put: (in category 'accessing') ----- - at: index put: anObject - "Primitive. Assumes receiver is indexable. Store the argument anObject in - the indexable element of the receiver indicated by index. Fail if the index - is not an Integer or is out of bounds, or if the receiver is read-only, or if - anObject is not of the right type for this kind of collection. Answer the - value (anObject) that was stored. Essential. See Object documentation - whatIsAPrimitive." - - <primitive: 61 error: ec> - index isInteger ifTrue: - [self class isVariable - ifTrue: - [(index >= 1 and: [index <= self size]) - ifTrue: - [ec == #'no modification' ifTrue: - [^thisContext modificationForbiddenFor: self at: index put: anObject]. - self errorImproperStore] - ifFalse: [self errorSubscriptBounds: index]] - ifFalse: [self errorNotIndexable]]. - index isNumber ifTrue: - [^self at: index asInteger put: anObject]. - self errorNonIntegerIndex! Item was removed: - ----- Method: Object>>attemptToAssign:withIndex: (in category 'write barrier') ----- - attemptToAssign: value withIndex: index - "Called by the VM when attempting to assign an instance variable of an read-only object. - Upon return, executing will resume *after* the inst var assignment. If the inst var - mutation has to be performed, do it manually here in the call back with instVarAt:put:. - This method has to return *no* value by jumping to the context's sender" - - thisContext modificationForbiddenFor: self instVarAt: index put: value. - - thisContext sender jump - "CAN'T REACH"! Item was removed: - ----- Method: Object>>backwardCompatibilityOnly: (in category 'error handling') ----- - backwardCompatibilityOnly: explanationString - "Warn that the sending method has been deprecated. Methods that are tagt with #backwardCompatibility: - are kept for compatibility." - - Deprecation - signalForContext: thisContext sender - message: ' (but will be kept for compatibility)' - explanation: explanationString! Item was removed: - ----- Method: Object>>basicAt: (in category 'accessing') ----- - basicAt: index - "Primitive. Assumes receiver is indexable. Answer the value of an - indexable element in the receiver. Fail if the argument index is not an - Integer or is out of bounds. Essential. Do not override in a subclass. See - Object documentation whatIsAPrimitive." - - <primitive: 60> - index isInteger ifTrue: [self errorSubscriptBounds: index]. - index isNumber - ifTrue: [^self basicAt: index asInteger] - ifFalse: [self errorNonIntegerIndex]! Item was removed: - ----- Method: Object>>basicAt:put: (in category 'accessing') ----- - basicAt: index put: anObject - "Primitive. Assumes receiver is indexable. Store the argument anObject in - the indexable element of the receiver indicated by index. Fail if the index - is not an Integer or is out of bounds, or if the receiver is read-only, or if - anObject is not of the right type for this kind of collection. Answer the - value (anObject) that was stored. Essential. Do not override in a subclass. - See Object documentation whatIsAPrimitive." - - <primitive: 61 error: ec> - index isInteger ifTrue: - [self class isVariable - ifTrue: - [(index >= 1 and: [index <= self basicSize]) - ifTrue: - [ec == #'no modification' ifTrue: - [^thisContext modificationForbiddenFor: self at: index put: anObject]. - self errorImproperStore] - ifFalse: [self errorSubscriptBounds: index]] - ifFalse: [self errorNotIndexable]]. - index isNumber ifTrue: - [^self basicAt: index asInteger put: anObject]. - self errorNonIntegerIndex! Item was removed: - ----- Method: Object>>basicSize (in category 'accessing') ----- - basicSize - "Primitive. Answer the number of indexable variables in the receiver. - This value is the same as the largest legal subscript. Essential. Do not - override in any subclass. See Object documentation whatIsAPrimitive." - - <primitive: 62> - "The number of indexable fields of fixed-length objects is 0" - ^0 ! Item was removed: - ----- Method: Object>>beReadOnlyObject (in category 'write barrier') ----- - beReadOnlyObject - "If the VM supports read-only objects it will not write to read-only objects. - An attempt to write to an instance variable of a read-only object will - cause the VM to send attemptToAssign:withIndex: to the read-only object. - An attempt to modify a read-only object in a primitive will cause the - primitive to fail with a #'no modification' error code. - Set the read-only flag of the receiver to true and answer the previous vaue of the flag." - ^self setIsReadOnlyObject: true! Item was removed: - ----- Method: Object>>beViewed (in category 'testing') ----- - beViewed - "Open up a viewer on the receiver. The Presenter is invited to decide just how to present this viewer" - - self uniqueNameForReference. "So the viewer will have something nice to refer to" - self presenter viewObject: self! Item was removed: - ----- Method: Object>>beWritableObject (in category 'write barrier') ----- - beWritableObject - "If the VM supports read-only objects it will not write to read-only objects. - An attempt to write to an instance variable of a read-only object will - cause the VM to send attemptToAssign:withIndex: to the read-only object. - An attempt to modify a read-only object in a primitive will cause the - primitive to fail with a #'no modification' error code. - Set the read-only flag of the receiver to false and answer the previous vaue of the flag." - ^self setIsReadOnlyObject: false! Item was removed: - ----- Method: Object>>become: (in category 'system primitives') ----- - become: otherObject - "Primitive. Swap the object pointers of the receiver and the argument. - All variables in the entire system that used to point to the receiver now - point to the argument, and vice-versa. Fails if either object is read-only - or is an immediate such as a SmallInteger." - - {self} elementsExchangeIdentityWith: {otherObject}! Item was removed: - ----- Method: Object>>becomeForward: (in category 'system primitives') ----- - becomeForward: otherObject - "Primitive. All variables in the entire system that used to point to the receiver now point to the argument. Fails if either argument is an immediate such as a SmallInteger, or if the receiver is read-only. - NOTE THAT the #identityHash of the receiver IS NOT copied to the argument so that hashed structures that contain the argument are still properly indexed BUT the ones with the receiver MUST BE rehashed. See implementors of #rehash and #becomeForward:copyHash:. - NOTE THAT before 4/15/2020, the hash of the receiver was indeed copied over to the argument." - - {self} elementsForwardIdentityTo: {otherObject}! Item was removed: - ----- Method: Object>>becomeForward:copyHash: (in category 'system primitives') ----- - becomeForward: otherObject copyHash: copyHash - "Primitive. All variables in the entire system that used to point to - the receiver now point to the argument. If copyHash is true, the - argument's identity hash bits will be set to those of the receiver. - Fails if - - either argument is an immediate such as a SmallInteger, - - if the receiver is read-only - - otherObject is read-only and copyHash is true." - - {self} - elementsForwardIdentityTo: {otherObject} - copyHash: copyHash! Item was removed: - ----- Method: Object>>belongsToUniClass (in category 'testing') ----- - belongsToUniClass - "Answer whether the receiver belongs to a uniclass. For the moment (this is not entirely satisfactory) this is precisely equated with the classname ending in a digit" - - ^ self class isUniClass! Item was removed: - ----- Method: Object>>bindWithTemp: (in category 'accessing') ----- - bindWithTemp: aBlock - ^ aBlock value: self value: nil! Item was removed: - ----- Method: Object>>bindingOf: (in category 'binding') ----- - bindingOf: aString - ^nil! Item was removed: - ----- Method: Object>>breakDependents (in category 'dependents access') ----- - breakDependents - "Remove all of the receiver's dependents." - - self myDependents: nil! Item was removed: - ----- Method: Object>>byteEncode: (in category 'filter streaming') ----- - byteEncode:aStream - self flattenOnStream:aStream. - ! Item was removed: - ----- Method: Object>>canDiscardEdits (in category 'dependents access') ----- - canDiscardEdits - "Answer true if none of the views on this model has unaccepted edits that matter." - - self dependents - do: [:each | each canDiscardEdits ifFalse: [^ false]] - without: self. - ^ true! Item was removed: - ----- Method: Object>>caseError (in category 'error handling') ----- - caseError - "Report an error from an in-line or explicit case statement." - - self error: ('Case not found ({1}), and no otherwise clause' format: {self printString})! Item was removed: - ----- Method: Object>>caseOf: (in category 'casing') ----- - caseOf: aBlockAssociationCollection - "The elements of aBlockAssociationCollection are associations between blocks. - Answer the evaluated value of the first association in aBlockAssociationCollection - whose evaluated key equals the receiver. If no match is found, report an error." - - ^ self caseOf: aBlockAssociationCollection otherwise: [self caseError] - - "| z | z := {[#a]->[1+1]. ['b' asSymbol]->[2+2]. [#c]->[3+3]}. #b caseOf: z" - "| z | z := {[#a]->[1+1]. ['d' asSymbol]->[2+2]. [#c]->[3+3]}. #b caseOf: z" - "The following are compiled in-line:" - "#b caseOf: {[#a]->[1+1]. ['b' asSymbol]->[2+2]. [#c]->[3+3]}" - "#b caseOf: {[#a]->[1+1]. ['d' asSymbol]->[2+2]. [#c]->[3+3]}"! Item was removed: - ----- Method: Object>>caseOf:otherwise: (in category 'casing') ----- - caseOf: aBlockAssociationCollection otherwise: aBlock - "The elements of aBlockAssociationCollection are associations between blocks. Answer the evaluated value of the first association in aBlockAssociationCollection whose evaluated key equals the receiver. If no match is found, answer the result of evaluating aBlock." - - aBlockAssociationCollection associationsDo: - [:assoc | (assoc key value = self) ifTrue: [^assoc value value]]. - ^ aBlock cull: self - - "| z | z := {[#a]->[1+1]. ['b' asSymbol]->[2+2]. [#c]->[3+3]}. #b caseOf: z otherwise: [0]" - "| z | z := {[#a]->[1+1]. ['d' asSymbol]->[2+2]. [#c]->[3+3]}. #b caseOf: z otherwise: [0]" - "The following are compiled in-line:" - "#b caseOf: {[#a]->[1+1]. ['b' asSymbol]->[2+2]. [#c]->[3+3]} otherwise: [0]" - "#b caseOf: {[#a]->[1+1]. ['d' asSymbol]->[2+2]. [#c]->[3+3]} otherwise: [0]" - "#b caseOf: {[#a]->[1+1]. ['d' asSymbol]->[2+2]. [#c]->[3+3]} otherwise: [:x | x halt]"! Item was removed: - ----- Method: Object>>changeClassTo: (in category 'converting') ----- - changeClassTo: aBehavior - "Change the class of the receiver to the argument, provided - that the format of the argument matches the format of the receiver's class." - aBehavior adoptInstance: self. - ^self! Item was removed: - ----- Method: Object>>changed (in category 'updating') ----- - changed - "Receiver changed in a general way; inform all the dependents by - sending each dependent an update: message." - - self changed: self! Item was removed: - ----- Method: Object>>changed: (in category 'updating') ----- - changed: aParameter - "Receiver changed. The change is denoted by the argument aParameter. - Usually the argument is a Symbol that is part of the dependent's change - protocol. Inform all of the dependents." - - self dependents do: [:aDependent | aDependent update: aParameter]! Item was removed: - ----- Method: Object>>changed:with: (in category 'updating') ----- - changed: anAspect with: anObject - "Receiver changed. The change is denoted by the argument anAspect. - Usually the argument is a Symbol that is part of the dependent's change - protocol. Inform all of the dependents. Also pass anObject for additional information." - - self dependents do: [:aDependent | aDependent update: anAspect with: anObject]! Item was removed: - ----- Method: Object>>checkHaltCountExpired (in category 'debugging-haltOnce') ----- - checkHaltCountExpired - | counter | - counter := Smalltalk at: #HaltCount ifAbsent: [0]. - ^counter = 0! Item was removed: - ----- Method: Object>>class (in category 'class membership') ----- - class - "Primitive. Answer the object which is the receiver's class. Essential. See - Object documentation whatIsAPrimitive." - - <primitive: 111> - self primitiveFailed! Item was removed: - ----- Method: Object>>className (in category 'system primitives') ----- - className - "Answer a string characterizing the receiver's class, for use in list views for example" - - ^ self class name asString! Item was removed: - ----- Method: Object>>clearHaltOnce (in category 'debugging-haltOnce') ----- - clearHaltOnce - "Turn on the halt once flag." - Smalltalk at: #HaltOnce put: false! Item was removed: - ----- Method: Object>>closeTo: (in category 'comparing') ----- - closeTo: anObject - "Answer whether the receiver and the argument represent the same - object. If = is redefined in any subclass, consider also redefining the - message hash." - - ^[self = anObject] ifError: [false]! Item was removed: - ----- Method: Object>>codeStrippedOut: (in category 'macpal') ----- - codeStrippedOut: messageString - "When a method is stripped out for external release, it is replaced by a method that calls this" - - self halt: 'Code stripped out -- ', messageString, '-- do not proceed.'! Item was removed: - ----- Method: Object>>comeFullyUpOnReload: (in category 'objects from disk') ----- - comeFullyUpOnReload: smartRefStream - "Normally this read-in object is exactly what we want to store. 7/26/96 tk" - - ^ self! Item was removed: - ----- Method: Object>>complexContents (in category 'converting') ----- - complexContents - - ^self! Item was removed: - ----- Method: Object>>contentsChanged (in category 'macpal') ----- - contentsChanged - self changed: #contents! Item was removed: - ----- Method: Object>>convertToCurrentVersion:refStream: (in category 'objects from disk') ----- - convertToCurrentVersion: varDict refStream: smartRefStrm - - "subclasses should implement if they wish to convert old instances to modern ones"! Item was removed: - ----- Method: Object>>copy (in category 'copying') ----- - copy - "Answer another instance just like the receiver. Subclasses typically override postCopy; they typically do not override shallowCopy." - - ^self shallowCopy postCopy! Item was removed: - ----- Method: Object>>copyAddedStateFrom: (in category 'copying') ----- - copyAddedStateFrom: anotherObject - "Copy over the values of instance variables added by the receiver's class from anotherObject to the receiver. These will be remapped in mapUniClasses, if needed." - - self class superclass instSize + 1 to: self class instSize do: - [:index | self instVarAt: index put: (anotherObject instVarAt: index)]! Item was removed: - ----- Method: Object>>copyFrom: (in category 'copying') ----- - copyFrom: anotherObject - "Copy to myself all instance variables I have in common with anotherObject. This is dangerous because it ignores an object's control over its own inst vars. " - - | mine his | - <primitive: 168> - mine := self class allInstVarNames. - his := anotherObject class allInstVarNames. - 1 to: (mine size min: his size) do: [:ind | - (mine at: ind) = (his at: ind) ifTrue: [ - self instVarAt: ind put: (anotherObject instVarAt: ind)]]. - self class isVariable & anotherObject class isVariable ifTrue: [ - 1 to: (self basicSize min: anotherObject basicSize) do: [:ind | - self basicAt: ind put: (anotherObject basicAt: ind)]].! Item was removed: - ----- Method: Object>>copySameFrom: (in category 'copying') ----- - copySameFrom: otherObject - "Copy to myself all instance variables named the same in otherObject. - This ignores otherObject's control over its own inst vars." - - | myInstVars otherInstVars | - myInstVars := self class allInstVarNames. - otherInstVars := otherObject class allInstVarNames. - myInstVars withIndexDo: [:each :index | - | match | - (match := otherInstVars indexOf: each) > 0 ifTrue: - [self instVarAt: index put: (otherObject instVarAt: match)]]. - 1 to: (self basicSize min: otherObject basicSize) do: [:i | - self basicAt: i put: (otherObject basicAt: i)]. - ! Item was removed: - ----- Method: Object>>copyTwoLevel (in category 'copying') ----- - copyTwoLevel - "one more level than a shallowCopy" - - | newObject class index | - class := self class. - newObject := self shallowCopy. - newObject == self ifTrue: [^ self]. - class isVariable - ifTrue: - [index := self basicSize. - [index > 0] - whileTrue: - [newObject basicAt: index put: (self basicAt: index) shallowCopy. - index := index - 1]]. - index := class instSize. - [index > 0] - whileTrue: - [newObject instVarAt: index put: (self instVarAt: index) shallowCopy. - index := index - 1]. - ^newObject! Item was removed: - ----- Method: Object>>costumes (in category 'testing') ----- - costumes - "Answer a list of costumes associated with the receiver. The appearance of this method in class Object serves only as a backstop, probably only transitionally" - - ^ nil! Item was removed: - ----- Method: Object>>creationStamp (in category 'system primitives') ----- - creationStamp - "Answer a string which reports the creation particulars of the receiver. Intended perhaps for list views, but this is presently a feature not easily accessible" - - ^ '<no creation stamp>'! Item was removed: - ----- Method: Object>>decrementAndCheckHaltCount (in category 'debugging-haltOnce') ----- - decrementAndCheckHaltCount - self decrementHaltCount. - ^self checkHaltCountExpired! Item was removed: - ----- Method: Object>>decrementHaltCount (in category 'debugging-haltOnce') ----- - decrementHaltCount - | counter | - counter := Smalltalk - at: #HaltCount - ifAbsent: [0]. - counter > 0 ifTrue: [ - counter := counter - 1. - self setHaltCountTo: counter]! Item was removed: - ----- Method: Object>>deepCopy (in category 'copying') ----- - deepCopy - "Answer a copy of the receiver with its own copy of each instance variable. - WARNING: deepCopy does not preserve object identities in cycles in the object graph. Consider using #veryDeepCopy instead." - - | newObject class index | - class := self class. - (class == Object) ifTrue: [^self]. - class isVariable - ifTrue: - [index := self basicSize. - newObject := class basicNew: index. - [index > 0] - whileTrue: - [newObject basicAt: index put: (self basicAt: index) deepCopy. - index := index - 1]] - ifFalse: [newObject := class basicNew]. - index := class instSize. - [index > 0] - whileTrue: - [newObject instVarAt: index put: (self instVarAt: index) deepCopy. - index := index - 1]. - ^newObject! Item was removed: - ----- Method: Object>>defaultFloatPrecisionFor: (in category 'scripting') ----- - defaultFloatPrecisionFor: aGetSelector - "Answer a number indicating the default float precision to be used in a numeric readout for which the receiver is the model." - - ^ 1! Item was removed: - ----- Method: Object>>defaultLabelForInspector (in category 'user interface') ----- - defaultLabelForInspector - "Answer the default label to be used for an Inspector window on the receiver." - - ^ self class name! Item was removed: - ----- Method: Object>>dependents (in category 'dependents access') ----- - dependents - "Answer a collection of objects that are 'dependent' on the receiver; - that is, all objects that should be notified if the receiver changes." - - ^ self myDependents ifNil: [#()]! Item was removed: - ----- Method: Object>>deprecated (in category 'error handling') ----- - deprecated - "Warn that the sending method has been deprecated." - - Deprecation - signalForContext: thisContext sender - message: '' - explanation: ''! Item was removed: - ----- Method: Object>>deprecated: (in category 'error handling') ----- - deprecated: explanationString - "Warn that the sending method has been deprecated." - - Deprecation - signalForContext: thisContext sender - message: '' - explanation: explanationString! Item was removed: - ----- Method: Object>>deprecated:block: (in category 'error handling') ----- - deprecated: explanationString block: aBlock - "Warn that the sender has been deprecated. Answer the value of aBlock on resumption. (Note that #deprecated: is usually the preferred method.)" - - Deprecation - signalForContext: thisContext sender - message: '' - explanation: explanationString. - ^ aBlock value - ! Item was removed: - ----- Method: Object>>doExpiredHaltCount (in category 'debugging-haltOnce') ----- - doExpiredHaltCount - self clearHaltOnce. - self removeHaltCount. - self halt! Item was removed: - ----- Method: Object>>doExpiredHaltCount: (in category 'debugging-haltOnce') ----- - doExpiredHaltCount: aString - self clearHaltOnce. - self removeHaltCount. - self halt: aString! Item was removed: - ----- Method: Object>>doExpiredInspectCount (in category 'debugging-haltOnce') ----- - doExpiredInspectCount - self clearHaltOnce. - self removeHaltCount. - self inspect! Item was removed: - ----- Method: Object>>doesNotUnderstand: (in category 'error handling') ----- - doesNotUnderstand: aMessage - "Handle the fact that there was an attempt to send the given - message to the receiver but the receiver does not understand - this message (typically sent from the machine when a message - is sent to the receiver and no method is defined for that selector). - - Raise the MessageNotUnderstood signal. If it is caught, answer - the result supplied by the exception handler. If it is not caught, - answer the result of resending the message within a guard for - infinite recursion. This allows, for example, the programmer to - implement the method and continue." - - "Testing: (3 activeProcess)" - - | exception resumeValue | - (exception := MessageNotUnderstood new) - message: aMessage; - receiver: self. - resumeValue := exception signal. - ^exception reachedDefaultHandler "i.e. exception was not caught..." - ifTrue: - [[aMessage sentTo: self] - on: MessageNotUnderstood - do: [:ex| - (self == ex receiver - and: [aMessage hasIdenticalContentsAs: ex message]) ifFalse: - [ex pass]. - self error: 'infinite recursion in doesNotUnderstand:']] - ifFalse: [resumeValue]! Item was removed: - ----- Method: Object>>dpsTrace: (in category 'error handling') ----- - dpsTrace: reportObject - Transcript myDependents isNil ifTrue: [^self]. - self dpsTrace: reportObject levels: 1 withContext: thisContext - - " nil dpsTrace: 'sludder'. "! Item was removed: - ----- Method: Object>>dpsTrace:levels: (in category 'error handling') ----- - dpsTrace: reportObject levels: anInt - self dpsTrace: reportObject levels: anInt withContext: thisContext - - "(1 to: 3) do: [:int | nil dpsTrace: int levels: 5.]"! Item was removed: - ----- Method: Object>>dpsTrace:levels:withContext: (in category 'error handling') ----- - dpsTrace: reportObject levels: anInt withContext: currentContext - | reportString context displayCount | - reportString := (reportObject respondsTo: #asString) - ifTrue: [reportObject asString] ifFalse: [reportObject printString]. - (Smalltalk at: #Decompiler ifAbsent: [nil]) - ifNil: - [Transcript cr; show: reportString] - ifNotNil: - [context := currentContext. - displayCount := anInt > 1. - 1 to: anInt do: - [:count | - Transcript cr. - displayCount - ifTrue: [Transcript show: count printString, ': ']. - - reportString notNil - ifTrue: - [Transcript show: context home class name - , '/' , context sender selector, ' (' , reportString , ')'. - context := context sender. - reportString := nil] - ifFalse: - [(context notNil and: [(context := context sender) notNil]) - ifTrue: [Transcript show: context receiver class name , '/' , context selector]]]. - "Transcript cr"].! Item was removed: - ----- Method: Object>>dragPassengerFor:inMorph: (in category 'drag and drop') ----- - dragPassengerFor: item inMorph: dragSource - ^item! Item was removed: - ----- Method: Object>>dragStartedFor:transferMorph: (in category 'drag and drop') ----- - dragStartedFor: anItemMorph transferMorph: aTransferMorph - "Give the model a chance to respond to a started drag operation. Could be used to give a notification or play an animation. Do nothing by default."! Item was removed: - ----- Method: Object>>dragTransferTypeForMorph: (in category 'drag and drop') ----- - dragTransferTypeForMorph: dragSource - ^nil! Item was removed: - ----- Method: Object>>drawOnCanvas: (in category 'filter streaming') ----- - drawOnCanvas:aStream - self flattenOnStream:aStream. - ! Item was removed: - ----- Method: Object>>elementSeparator (in category 'filter streaming') ----- - elementSeparator - ^nil.! Item was removed: - ----- Method: Object>>enclosedSetElement (in category 'accessing') ----- - enclosedSetElement - "The receiver is included into a set as an element. - Since some objects require wrappers (see SetElement) to be able to be included into a Set, - a set sends this message to its element to make sure it getting real object, - instead of its wrapper. - Only SetElement instance or its subclasses allowed to answer something different than receiver itself" - - ! Item was removed: - ----- Method: Object>>encodePostscriptOn: (in category 'filter streaming') ----- - encodePostscriptOn:aStream - self byteEncode:aStream. - ! Item was removed: - ----- Method: Object>>error (in category 'error handling') ----- - error - "Throw a generic Error exception." - - ^self error: 'Error!!'.! Item was removed: - ----- Method: Object>>error: (in category 'error handling') ----- - error: aString - "Throw a generic Error exception." - - ^Error new signal: aString! Item was removed: - ----- Method: Object>>errorImproperStore (in category 'private') ----- - errorImproperStore - "Create an error notification that an improper store was attempted." - - self error: 'Improper store into indexable object'! Item was removed: - ----- Method: Object>>errorNonIntegerIndex (in category 'private') ----- - errorNonIntegerIndex - "Create an error notification that an improper object was used as an index." - - self error: 'only integers should be used as indices'! Item was removed: - ----- Method: Object>>errorNotIndexable (in category 'private') ----- - errorNotIndexable - "Create an error notification that the receiver is not indexable." - - self error: ('Instances of {1} are not indexable' translated format: {self class name})! Item was removed: - ----- Method: Object>>errorSubscriptBounds: (in category 'private') ----- - errorSubscriptBounds: index - "Create an error notification that an improper integer was used as an index." - - self error: 'subscript is out of bounds: ' , index printString! Item was removed: - ----- Method: Object>>evaluate:wheneverChangeIn: (in category 'debugging') ----- - evaluate: actionBlock wheneverChangeIn: aspectBlock - | viewerThenObject objectThenViewer | - objectThenViewer := self. - viewerThenObject := ObjectViewer on: objectThenViewer. - objectThenViewer become: viewerThenObject. - "--- Then ---" - objectThenViewer xxxViewedObject: viewerThenObject - evaluate: actionBlock - wheneverChangeIn: aspectBlock! Item was removed: - ----- Method: Object>>evaluateUnloggedForSelf: (in category 'scripting') ----- - evaluateUnloggedForSelf: aCodeString - - ^Compiler evaluate: - aCodeString - for: self! Item was removed: - ----- Method: Object>>executeMethod: (in category 'message handling') ----- - executeMethod: compiledMethod - "Execute compiledMethod against the receiver with no args" - - <primitive: 189> - ^ self withArgs: #() executeMethod: compiledMethod! Item was removed: - ----- Method: Object>>fixUponLoad:seg: (in category 'objects from disk') ----- - fixUponLoad: aProject seg: anImageSegment - "change the object due to conventions that have changed on - the project level. (sent to all objects in the incoming project). - Specific classes should reimplement this."! Item was removed: - ----- Method: Object>>flash (in category 'macpal') ----- - flash - "Do nothing." - ! Item was removed: - ----- Method: Object>>flattenOnStream: (in category 'filter streaming') ----- - flattenOnStream:aStream - self writeOnFilterStream:aStream. - ! Item was removed: - ----- Method: Object>>fullDrawPostscriptOn: (in category 'filter streaming') ----- - fullDrawPostscriptOn:aStream - ^aStream fullDraw:self. - ! Item was removed: - ----- Method: Object>>fullPrintString (in category 'printing') ----- - fullPrintString - "Answer a String whose characters are a description of the receiver." - - ^ String streamContents: [:s | self printOn: s]! Item was removed: - ----- Method: Object>>future (in category 'futures') ----- - future - "See FutureMaker class comment. In practice, this code is optimized away by the Compiler (see FutureNode)." - ^(FutureMaker new) - setDeltaMSecs: 0.0 target: self! Item was removed: - ----- Method: Object>>future: (in category 'futures') ----- - future: deltaMSecs - "See FutureMaker class comment. In practice, this code is optimized away by the Compiler (see FutureNode)." - ^(FutureMaker new) - setDeltaMSecs: deltaMSecs target: self! Item was removed: - ----- Method: Object>>futureDo:at:args: (in category 'futures') ----- - futureDo: aSelector at: deltaMSecs args: args - "Send a message deltaMSecs into the future (some implementations may requires 'deltaMSecs' to be zero). No response is expected. See comment in class FutureNode." - Project current future: self do: aSelector at: deltaMSecs args: args. - ^nil! Item was removed: - ----- Method: Object>>futureSend:at:args: (in category 'futures') ----- - futureSend: aSelector at: deltaMSecs args: args - "Send a message deltaSeconds into the future (some implementations may requires 'deltaMSecs' to be zero). Answers a Promise that will be resolved at some time in the future. See comment in class FutureNode." - ^Project current future: self send: aSelector at: deltaMSecs args: args.! Item was removed: - ----- Method: Object>>halt (in category 'error handling') ----- - halt - "This is the typical message to use for inserting breakpoints during - debugging. It behaves like halt:, but does not call on halt: in order to - avoid putting this message on the stack. Halt is especially useful when - the breakpoint message is an arbitrary one." - - Halt signal! Item was removed: - ----- Method: Object>>halt: (in category 'error handling') ----- - halt: aString - "This is the typical message to use for inserting breakpoints during - debugging. It creates and schedules a Notifier with the argument, - aString, as the label." - - Halt new signal: aString! Item was removed: - ----- Method: Object>>halt:onCount: (in category 'debugging-haltOnce') ----- - halt: aString onCount: int - self haltOnceEnabled - ifTrue: [self hasHaltCount - ifTrue: [self decrementAndCheckHaltCount - ifTrue: [self doExpiredHaltCount: aString]] - ifFalse: [int = 1 - ifTrue: [self doExpiredHaltCount: aString] - ifFalse: [self setHaltCountTo: int - 1]]]! Item was removed: - ----- Method: Object>>haltIf: (in category 'debugging') ----- - haltIf: condition - "This is the typical message to use for inserting breakpoints during - debugging. Param can be a block or expression, halt if true. - If the Block has one arg, the receiver is bound to that. - If the condition is a selector, we look up in the callchain. Halt if - any method's selector equals selector." - | cntxt | - - condition isSymbol ifTrue:[ - "only halt if a method with selector symbol is in callchain" - cntxt := thisContext. - [cntxt sender isNil] whileFalse: [ - cntxt := cntxt sender. - (cntxt selector = condition) ifTrue: [Halt signal]. - ]. - ^self. - ]. - (condition isBlock - ifTrue: [condition cull: self] - ifFalse: [condition] - ) ifTrue: [ - Halt signal - ].! Item was removed: - ----- Method: Object>>haltIfNil (in category 'testing') ----- - haltIfNil! Item was removed: - ----- Method: Object>>haltOnCount: (in category 'debugging-haltOnce') ----- - haltOnCount: int - self haltOnceEnabled - ifTrue: [self hasHaltCount - ifTrue: [self decrementAndCheckHaltCount - ifTrue: [self doExpiredHaltCount]] - ifFalse: [int = 1 - ifTrue: [self doExpiredHaltCount] - ifFalse: [self setHaltCountTo: int - 1]]]! Item was removed: - ----- Method: Object>>haltOnce (in category 'debugging-haltOnce') ----- - haltOnce - "Halt unless we have already done it once." - self haltOnceEnabled - ifTrue: [self clearHaltOnce. - ^ self halt]! Item was removed: - ----- Method: Object>>haltOnce: (in category 'debugging-haltOnce') ----- - haltOnce: aString - "Halt unless we have already done it once." - self haltOnceEnabled - ifTrue: [self clearHaltOnce. - ^ self halt: aString]! Item was removed: - ----- Method: Object>>haltOnceEnabled (in category 'debugging-haltOnce') ----- - haltOnceEnabled - ^ Smalltalk - at: #HaltOnce - ifAbsent: [false]! Item was removed: - ----- Method: Object>>handledListVerification (in category 'updating') ----- - handledListVerification - "When a self-updating PluggableListMorph lazily checks to see the state of affairs, it first gives its model an opportunity to handle the list verification itself (this is appropriate for some models, such as VersionsBrowser); if a list's model has indeed handled things itself, it returns true here" - - ^ false! Item was removed: - ----- Method: Object>>handles: (in category 'error handling') ----- - handles: exception - "This method exists in case a non exception class is the first arg in an on:do: (for instance using a exception class that is not loaded). We prefer this to raising an error during error handling itself. Also, semantically it makes sense that the exception handler is not active if its exception class is not loaded" - - ^ false! Item was removed: - ----- Method: Object>>hasHaltCount (in category 'debugging-haltOnce') ----- - hasHaltCount - ^self class environment - includesKey: #HaltCount! Item was removed: - ----- Method: Object>>hasLiteral: (in category 'literals') ----- - hasLiteral: literal - - ^ self hasLiteralSuchThat: [:lit | lit literalEqual: literal]! Item was removed: - ----- Method: Object>>hasLiteralSuchThat: (in category 'literals') ----- - hasLiteralSuchThat: testBlock - - self allLiteralsDo: [:literal | - (testBlock value: literal) ifTrue: [^ true]]. - - ^ false! Item was removed: - ----- Method: Object>>hasModelYellowButtonMenuItems (in category 'graph model') ----- - hasModelYellowButtonMenuItems - ^ true! Item was removed: - ----- Method: Object>>hasUnacceptedEdits (in category 'dependents access') ----- - hasUnacceptedEdits - "Answer true if any of the views on this object has unaccepted edits." - - self dependents - do: [:each | each hasUnacceptedEdits ifTrue: [^ true]] - without: self. - ^ false! Item was removed: - ----- Method: Object>>hash (in category 'comparing') ----- - hash - "Answer a SmallInteger whose value is related to the receiver's identity. - May be overridden, and should be overridden in any classes that define = " - - ^self scaledIdentityHash! Item was removed: - ----- Method: Object>>iconOrThumbnailOfSize: (in category 'thumbnail') ----- - iconOrThumbnailOfSize: aNumberOrPoint - "Answer an appropiate form to represent the receiver" - ^ nil! Item was removed: - ----- Method: Object>>identityHashPrintString (in category 'comparing') ----- - identityHashPrintString - "'fred' identityHashPrintString" - - ^ '(', self identityHash printString, ')'! Item was removed: - ----- Method: Object>>in: (in category 'accessing') ----- - in: aBlock - "Evaluate the given block with the receiver as its argument." - - ^ aBlock value: self - ! Item was removed: - ----- Method: Object>>inboundPointers (in category 'tracing') ----- - inboundPointers - "Answers a collection of all objects in the system that point to myself" - - ^ self inboundPointersExcluding: #()! Item was removed: - ----- Method: Object>>inboundPointersExcluding: (in category 'tracing') ----- - inboundPointersExcluding: objectsToExclude - "Answer a list of all objects in the system that hold a reference to me, excluding those in the collection of objectsToExclude." - - | pointers object objectsToAlwaysExclude | - Smalltalk garbageCollect. - pointers := OrderedCollection new. - self systemNavigation allObjectsOrNil ifNotNil: [ :allObjects | - objectsToAlwaysExclude := { - allObjects. - thisContext. - thisContext sender. - thisContext sender sender. - objectsToExclude. - }. - 1 to: allObjects size do: [ :index | - object := allObjects at: index. - (object pointsTo: self) ifTrue: [ - ((objectsToAlwaysExclude identityIncludes: object) - or: [ objectsToExclude identityIncludes: object ]) - ifFalse: [ pointers add: object ] ] ]. - ^pointers ]. - "SystemNavigation >> #allObjectsDo: is inlined here with a slight modification: the marker object is pointers. This gives better results, because the value of pointers, it's inner objects and transient method contexts will not be iterated over." - object := self someObject. - [ object == pointers ] whileFalse: [ - (object isInMemory and: [ object pointsTo: self ]) ifTrue: [ - pointers add: object ]. - object := object nextObject ]. - objectsToAlwaysExclude := { - thisContext. - thisContext sender. - thisContext sender sender. - objectsToExclude. - }. - ^pointers removeAllSuchThat: [ :ea | - (objectsToAlwaysExclude identityIncludes: ea) - or: [ objectsToExclude identityIncludes: ea ] ]! Item was removed: - ----- Method: Object>>inheritsFromAnyIn: (in category 'class membership') ----- - inheritsFromAnyIn: aList - "Answer whether the receiver inherits from any class represented by any element in the list. The elements of the list can be classes, class name symbols, or strings representing possible class names. This allows speculative membership tests to be made even when some of the classes may not be known to the current image, and even when their names are not interned symbols." - - ^aList anySatisfy: [ :element | - (Smalltalk classNamed: element asString) - ifNil: [ false ] - ifNotNil: [ :class | - (class isKindOf: Class) - and: [ self isKindOf: class ] ] ] - - " - {3. true. 'olive'} do: - [:token | - {{#Number. #Boolean}. {Number. Boolean }. {'Number'. 'Boolean'}} do: - [:list | - Transcript cr; show: token asString, ' list element provided as a ', list first class name, ' - ', (token inheritsFromAnyIn: list) asString]] - "! Item was removed: - ----- Method: Object>>initialDeepCopierSize (in category 'copying') ----- - initialDeepCopierSize - "default value is 4096; other classes may override this, esp. for smaller (=faster) sizes" - - ^4096! Item was removed: - ----- Method: Object>>inspectOnCount: (in category 'debugging-haltOnce') ----- - inspectOnCount: int - self haltOnceEnabled - ifTrue: [self hasHaltCount - ifTrue: [self decrementAndCheckHaltCount - ifTrue: [self doExpiredInspectCount]] - ifFalse: [int = 1 - ifTrue: [self doExpiredInspectCount] - ifFalse: [self setHaltCountTo: int - 1]]]! Item was removed: - ----- Method: Object>>inspectOnce (in category 'debugging-haltOnce') ----- - inspectOnce - "Inspect unless we have already done it once." - self haltOnceEnabled - ifTrue: [self clearHaltOnce. - ^ self inspect]! Item was removed: - ----- Method: Object>>inspectUntilCount: (in category 'debugging-haltOnce') ----- - inspectUntilCount: int - self haltOnceEnabled - ifTrue: [self hasHaltCount - ifTrue: [self decrementAndCheckHaltCount - ifTrue: [self doExpiredInspectCount] - ifFalse: [self inspect]] - ifFalse: [int = 1 - ifTrue: [self doExpiredInspectCount] - ifFalse: [self setHaltCountTo: int - 1]]]! Item was removed: - ----- 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 or - indexed variable. Essential. See Object documentation whatIsAPrimitive." - - <primitive: 173 error: ec> - self primitiveFailed! Item was removed: - ----- 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 - or indexed variable, or if the receiver is read-only. - Essential. See Object documentation whatIsAPrimitive." - - <primitive: 174 error: ec> - ec == #'no modification' ifTrue: - [^thisContext modificationForbiddenFor: self instVarAt: index put: anObject]. - self primitiveFailed! Item was removed: - ----- Method: Object>>instVarNamed: (in category 'system primitives') ----- - instVarNamed: aString - "Return the value of the instance variable in me with that name. Slow and unclean, but very useful. " - - ^ self instVarAt: (self class - instVarIndexFor: aString asString - ifAbsent: [self error: 'no such inst var']) - - - ! Item was removed: - ----- Method: Object>>instVarNamed:put: (in category 'system primitives') ----- - instVarNamed: aString put: aValue - "Store into the value of the instance variable in me of that name. Slow and unclean, but very useful. " - - ^self - instVarAt: (self class - instVarIndexFor: aString asString - ifAbsent: [self error: 'no such inst var']) - put: aValue - ! Item was removed: - ----- Method: Object>>instanceVariableValues (in category 'macpal') ----- - instanceVariableValues - "Answer a collection whose elements are the values of those instance variables of the receiver which were added by the receiver's class" - | c | - c := OrderedCollection new. - self class superclass instSize + 1 to: self class instSize do: - [:i | c add: (self instVarAt: i)]. - ^ c! Item was removed: - ----- Method: Object>>isArray (in category 'testing') ----- - isArray - ^false! Item was removed: - ----- Method: Object>>isBehavior (in category 'testing') ----- - isBehavior - "Return true if the receiver is a behavior. - Note: Do not override in any class except behavior." - ^false! Item was removed: - ----- Method: Object>>isBlock (in category 'testing') ----- - isBlock - - ^ false! Item was removed: - ----- Method: Object>>isBoolean (in category 'testing') ----- - isBoolean - ^ false! Item was removed: - ----- Method: Object>>isCharacter (in category 'testing') ----- - isCharacter - - ^ false. - ! Item was removed: - ----- Method: Object>>isClassReference (in category 'testing') ----- - isClassReference - - ^ false! Item was removed: - ----- Method: Object>>isClosure (in category 'testing') ----- - isClosure - ^false! Item was removed: - ----- Method: Object>>isCodeReference (in category 'testing') ----- - isCodeReference - - ^ self isClassReference or: [self isMethodReference]! Item was removed: - ----- Method: Object>>isCollection (in category 'testing') ----- - isCollection - "Return true if the receiver is some sort of Collection and responds to basic collection messages such as #size and #do:" - ^false! Item was removed: - ----- Method: Object>>isColor (in category 'testing') ----- - isColor - "Answer true if receiver is a Color. False by default." - - ^ false - ! Item was removed: - ----- Method: Object>>isColorForm (in category 'testing') ----- - isColorForm - ^false! Item was removed: - ----- Method: Object>>isCompiledCode (in category 'testing') ----- - isCompiledCode - ^false! Item was removed: - ----- Method: Object>>isCompiledCodeClass (in category 'testing') ----- - isCompiledCodeClass - ^false! Item was removed: - ----- Method: Object>>isCompiledMethod (in category 'testing') ----- - isCompiledMethod - - ^ false! Item was removed: - ----- Method: Object>>isComplex (in category 'testing') ----- - isComplex - "Answer true if receiver is a Complex number. False by default." - - ^ false - ! Item was removed: - ----- Method: Object>>isContext (in category 'testing') ----- - isContext - ^false! Item was removed: - ----- Method: Object>>isDictionary (in category 'testing') ----- - isDictionary - ^false! Item was removed: - ----- Method: Object>>isFloat (in category 'testing') ----- - isFloat - "Overridden to return true in Float, natch" - ^ false! Item was removed: - ----- Method: Object>>isForm (in category 'testing') ----- - isForm - ^false! Item was removed: - ----- Method: Object>>isFraction (in category 'testing') ----- - isFraction - "Answer true if the receiver is a Fraction." - - ^ false! Item was removed: - ----- Method: Object>>isHeap (in category 'testing') ----- - isHeap - - ^ false! Item was removed: - ----- Method: Object>>isInteger (in category 'testing') ----- - isInteger - "Overridden to return true in Integer." - - ^ false! Item was removed: - ----- Method: Object>>isInterval (in category 'testing') ----- - isInterval - - ^ false! Item was removed: - ----- Method: Object>>isKindOf: (in category 'class membership') ----- - isKindOf: aClass - "Answer whether the class, aClass, is a superclass or class of the receiver." - ^ self class == aClass or: [ self class inheritsFrom: aClass ]! Item was removed: - ----- Method: Object>>isKindOf:orOf: (in category 'class membership') ----- - isKindOf: aClass orOf: anotherClass - "Answer whether either of the classes, aClass or anotherClass,, is a superclass or class of the receiver. A convenience; could be somewhat optimized" - ^ (self isKindOf: aClass) or: [self isKindOf: anotherClass]! Item was removed: - ----- Method: Object>>isLiteral (in category 'printing') ----- - isLiteral - "Answer whether the receiver has a literal text form recognized by the - compiler." - - ^false! Item was removed: - ----- Method: Object>>isMemberOf: (in category 'class membership') ----- - isMemberOf: aClass - "Answer whether the receiver is an instance of the class, aClass." - - ^self class == aClass! Item was removed: - ----- Method: Object>>isMessageSend (in category 'testing') ----- - isMessageSend - ^false - ! Item was removed: - ----- Method: Object>>isMethodContext (in category 'testing') ----- - isMethodContext - ^ false! Item was removed: - ----- Method: Object>>isMethodProperties (in category 'testing') ----- - isMethodProperties - ^false! Item was removed: - ----- Method: Object>>isMethodReference (in category 'testing') ----- - isMethodReference - ^false! Item was removed: - ----- Method: Object>>isMorph (in category 'testing') ----- - isMorph - - ^ false! Item was removed: - ----- Method: Object>>isMorphicEvent (in category 'testing') ----- - isMorphicEvent - ^false! Item was removed: - ----- Method: Object>>isMorphicModel (in category 'testing') ----- - isMorphicModel - "Return true if the receiver is a morphic model" - ^false - ! Item was removed: - ----- Method: Object>>isNumber (in category 'testing') ----- - isNumber - "Overridden to return true in Number, natch" - ^ false! Item was removed: - ----- Method: Object>>isPinned (in category 'pinning') ----- - 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 removed: - ----- Method: Object>>isPlayer (in category 'testing') ----- - isPlayer - ^false! Item was removed: - ----- Method: Object>>isPoint (in category 'testing') ----- - isPoint - "Overridden to return true in Point." - - ^ false! Item was removed: - ----- Method: Object>>isPrimitiveCostume (in category 'testing') ----- - isPrimitiveCostume - "True for primitive costumes in Tweak. Added here because a Tweak override in DisplayScanner was merged into trunk for maintainability" - ^false! Item was removed: - ----- Method: Object>>isPromise (in category 'testing') ----- - isPromise - ^false! Item was removed: - ----- Method: Object>>isReadOnlyObject (in category 'write barrier') ----- - isReadOnlyObject - "Answer if the receiver is read-only. - If the VM supports read-only objects it will not write to read-only objects. - An attempt to write to an instance variable of a read-only object will - cause the VM to send attemptToAssign:withIndex: to the read-only object. - An attempt to modify a read-only object in a primitive will cause the - primitive to fail with a #'no modification' error code." - <primitive: 163 error: ec> - ^self class isImmediateClass! Item was removed: - ----- Method: Object>>isRectangle (in category 'testing') ----- - isRectangle - ^false! Item was removed: - ----- Method: Object>>isScaledDecimal (in category 'testing') ----- - isScaledDecimal - ^false! Item was removed: - ----- Method: Object>>isScriptEditorMorph (in category 'testing') ----- - isScriptEditorMorph - ^false! Item was removed: - ----- Method: Object>>isSketchMorph (in category 'testing') ----- - isSketchMorph - ^false! Item was removed: - ----- Method: Object>>isStream (in category 'testing') ----- - isStream - "Return true if the receiver responds to the stream protocol" - ^false - ! Item was removed: - ----- Method: Object>>isString (in category 'testing') ----- - isString - "Overridden to return true in String, natch" - ^ false! Item was removed: - ----- Method: Object>>isSymbol (in category 'testing') ----- - isSymbol - ^ false ! Item was removed: - ----- Method: Object>>isSystemWindow (in category 'testing') ----- - isSystemWindow - "answer whatever the receiver is a SystemWindow" - ^ false! Item was removed: - ----- Method: Object>>isText (in category 'testing') ----- - isText - ^ false! Item was removed: - ----- Method: Object>>isTextView (in category 'testing') ----- - isTextView - "True if the reciever is a view on a text model, such as a view on a TranscriptStream" - ^false! Item was removed: - ----- Method: Object>>isThisEverCalled (in category 'flagging') ----- - isThisEverCalled - ^ self isThisEverCalled: thisContext sender printString! Item was removed: - ----- Method: Object>>isThisEverCalled: (in category 'flagging') ----- - isThisEverCalled: msg - "Send this message, with some useful printable argument, from methods or branches of methods which you believe are never reached. 2/5/96 sw" - - self halt: 'This is indeed called: ', msg printString! Item was removed: - ----- Method: Object>>isTrait (in category 'testing') ----- - isTrait - "Return true if the receiver is a trait. - Note: Do not override in any class except TraitBehavior." - ^false! Item was removed: - ----- Method: Object>>isTransparent (in category 'testing') ----- - isTransparent - ^ false! Item was removed: - ----- Method: Object>>isUniversalTiles (in category 'macpal') ----- - isUniversalTiles - "Return true if I (my world) uses universal tiles. This message can be called in places where the current World is not known, such as when writing out a project. For more information about the project-writing subtlety addressed by this protocol, kindly contact Ted Kaehler." - - ^ Preferences universalTiles! Item was removed: - ----- Method: Object>>isVariableBinding (in category 'testing') ----- - isVariableBinding - "Return true if I represent a literal variable binding" - ^false - ! Item was removed: - ----- Method: Object>>isWebBrowser (in category 'testing') ----- - isWebBrowser - "whether this object is a web browser. See class: Scamper" - ^false! Item was removed: - ----- Method: Object>>isWindowForModel: (in category 'testing') ----- - isWindowForModel: aModel - "Return true if the receiver acts as the window for the given model" - ^false! Item was removed: - ----- Method: Object>>knownName (in category 'testing') ----- - knownName - "If a formal name has been handed out for this object, answer it, else nil" - - ^ Preferences capitalizedReferences - ifTrue: - [References keyAtValue: self ifAbsent: [nil]] - ifFalse: - [nil]! Item was removed: - ----- Method: Object>>launchPartVia: (in category 'user interface') ----- - launchPartVia: aSelector - "Obtain a morph by sending aSelector to self, and attach it to the morphic hand. This provides a general protocol for parts bins" - - | aMorph | - aMorph := self perform: aSelector. - aMorph setProperty: #beFullyVisibleAfterDrop toValue: true. - aMorph openInHand! Item was removed: - ----- Method: Object>>launchPartVia:label: (in category 'user interface') ----- - launchPartVia: aSelector label: aString - "Obtain a morph by sending aSelector to self, and attach it to the morphic hand. This provides a general protocol for parts bins" - - | aMorph | - aMorph := self perform: aSelector. - aMorph setNameTo: (Project current world unusedMorphNameLike: aString). - aMorph setProperty: #beFullyVisibleAfterDrop toValue: true. - aMorph openInHand.! Item was removed: - ----- Method: Object>>launchTileToRefer (in category 'user interface') ----- - launchTileToRefer - "Create a tile to reference the receiver, and attach it to the hand" - - self currentHand attachMorph: self tileToRefer! Item was removed: - ----- Method: Object>>literalEqual: (in category 'comparing') ----- - literalEqual: other - - ^ self class == other class and: [self = other]! Item was removed: - ----- Method: Object>>logEntry (in category 'flagging') ----- - logEntry - - Transcript show: 'Entered ', thisContext sender printString; cr. - ! Item was removed: - ----- Method: Object>>logExecution (in category 'flagging') ----- - logExecution - - Transcript show: 'Executing ', thisContext sender printString; cr. - ! Item was removed: - ----- Method: Object>>logExit (in category 'flagging') ----- - logExit - - Transcript show: 'Exited ', thisContext sender printString; cr. - ! Item was removed: - ----- Method: Object>>longPrintOn: (in category 'printing') ----- - longPrintOn: aStream - "Append to the argument, aStream, the names and values of all - of the receiver's instance variables." - - self class allInstVarNames withIndexDo: - [:title :index | - aStream nextPutAll: title; - nextPut: $:; - space; - tab; - print: (self instVarAt: index); - cr]! Item was removed: - ----- Method: Object>>longPrintOn:limitedTo:indent: (in category 'printing') ----- - longPrintOn: aStream limitedTo: sizeLimit indent: indent - "Append to the argument, aStream, the names and values of all of the receiver's instance variables. Limit is the length limit for each inst var." - - self class allInstVarNames withIndexDo: - [:title :index | - indent timesRepeat: [aStream tab]. - aStream nextPutAll: title; - nextPut: $:; - space; - tab; - nextPutAll: - ((self instVarAt: index) printStringLimitedTo: (sizeLimit -3 -title size max: 1)); - cr]! Item was removed: - ----- Method: Object>>longPrintString (in category 'printing') ----- - longPrintString - "Answer a String whose characters are a description of the receiver." - - | str | - str := String streamContents: [:aStream | self longPrintOn: aStream]. - "Objects without inst vars should return something" - ^ str isEmpty ifTrue: [self printString, String cr] ifFalse: [str]! Item was removed: - ----- Method: Object>>longPrintStringLimitedTo: (in category 'printing') ----- - longPrintStringLimitedTo: aLimitValue - "Answer a String whose characters are a description of the receiver." - - | str | - str := String streamContents: [:aStream | self longPrintOn: aStream limitedTo: aLimitValue indent: 0]. - "Objects without inst vars should return something" - ^ str isEmpty ifTrue: [self printString, String cr] ifFalse: [str]! Item was removed: - ----- Method: Object>>methodInterfacesForCategory:inVocabulary:limitClass: (in category 'scripting') ----- - methodInterfacesForCategory: aCategorySymbol inVocabulary: aVocabulary limitClass: aLimitClass - "Return a list of methodInterfaces for the receiver in the given category, given a vocabulary. aCategorySymbol is the inherent category symbol, not necessarily the wording as expressed in the vocabulary." - - | categorySymbol | - categorySymbol := aCategorySymbol asSymbol. - - (categorySymbol == ScriptingSystem nameForInstanceVariablesCategory) ifTrue: [ - "user-defined instance variables" - ^ self methodInterfacesForInstanceVariablesCategoryIn: aVocabulary]. - (categorySymbol == ScriptingSystem nameForScriptsCategory) ifTrue: [ - "user-defined scripts" - ^ self methodInterfacesForScriptsCategoryIn: aVocabulary]. - "all others" - ^ self usableMethodInterfacesIn: (aVocabulary methodInterfacesInCategory: categorySymbol - forInstance: self - ofClass: self class - limitClass: aLimitClass) - ! Item was removed: - ----- Method: Object>>methodInterfacesForInstanceVariablesCategoryIn: (in category 'scripting') ----- - methodInterfacesForInstanceVariablesCategoryIn: aVocabulary - "Return a collection of methodInterfaces for the instance-variables category. The vocabulary parameter, at present anyway, is not used. And for non-players, the method is at present vacuous in any case" - - ^ OrderedCollection new! Item was removed: - ----- Method: Object>>methodInterfacesForScriptsCategoryIn: (in category 'scripting') ----- - methodInterfacesForScriptsCategoryIn: aVocabulary - "Answer a list of method interfaces for the category #scripts, as seen in a viewer or other tool. The vocabulary argument is not presently used. Also, at present, only Players really do anyting interesting here." - - ^ OrderedCollection new! Item was removed: - ----- Method: Object>>modelSleep (in category 'user interface') ----- - modelSleep - "A window with me as model is being exited or collapsed or closed. - Default response is no-op" ! Item was removed: - ----- Method: Object>>modelWakeUp (in category 'user interface') ----- - modelWakeUp - "A window with me as model is being entered or expanded. Default response is no-op" ! Item was removed: - ----- Method: Object>>modelWakeUpIn: (in category 'user interface') ----- - modelWakeUpIn: aWindow - "A window with me as model is being entered or expanded. Default response is no-op" - self modelWakeUp! Item was removed: - ----- Method: Object>>mouseUpBalk: (in category 'user interface') ----- - mouseUpBalk: evt - "A button I own got a mouseDown, but the user moved out before letting up. Certain kinds of objects (so-called 'radio buttons', for example, and other structures that must always have some selection, e.g. PaintBoxMorph) wish to take special action in this case; this default does nothing." - ! Item was removed: - ----- Method: Object>>mustBeBoolean (in category 'converting') ----- - mustBeBoolean - "Catches attempts to test truth of non-Booleans. This message is sent from the VM. The sending context is rewound to just before the jump causing this exception." - - ^ self mustBeBooleanIn: thisContext sender! Item was removed: - ----- Method: Object>>mustBeBooleanIn: (in category 'converting') ----- - mustBeBooleanIn: context - "context is the where the non-boolean error occurred. Rewind context to before jump then raise error." - - | proceedValue | - context skipBackBeforeJump. - proceedValue := NonBooleanReceiver new - object: self; - signal: 'proceed for truth.'. - ^ proceedValue ~~ false! Item was removed: - ----- Method: Object>>myDependents (in category 'dependents access') ----- - myDependents - "Private. Answer a list of all the receiver's dependents." - - ^ DependentsFields at: self ifAbsent: []! Item was removed: - ----- Method: Object>>myDependents: (in category 'dependents access') ----- - myDependents: aCollectionOrNil - "Private. Set (or remove) the receiver's dependents list." - - aCollectionOrNil - ifNil: [DependentsFields removeKey: self ifAbsent: []] - ifNotNil: [DependentsFields at: self put: aCollectionOrNil]! Item was removed: - ----- Method: Object>>name (in category 'testing') ----- - name - "Answer a name for the receiver. This is used generically in the title of certain inspectors, such as the referred-to inspector, and specificially by various subsystems. By default, we let the object just print itself out.. " - - ^ self printString! Item was removed: - ----- Method: Object>>nameForViewer (in category 'testing') ----- - nameForViewer - "Answer a name to be shown in a Viewer that is viewing the receiver" - - | aName | - (aName := self uniqueNameForReferenceOrNil) ifNotNil: [^ aName]. - (aName := self knownName) ifNotNil: [^ aName]. - - ^ [(self asString copyWithout: Character cr) truncateTo: 27] ifError: - [:msg :rcvr | self class name printString]! Item was removed: - ----- Method: Object>>needsWork (in category 'debugging') ----- - needsWork! Item was removed: - ----- Method: Object>>nominallyUnsent: (in category 'printing') ----- - nominallyUnsent: aSelectorSymbol - "From within the body of a method which is not formally sent within the system, but which you intend to have remain in the system (for potential manual invocation, or for documentation, or perhaps because it's sent by commented-out-code that you anticipate uncommenting out someday, send this message, with the selector itself as the argument. - - This will serve two purposes: - - (1) The method will not be returned by searches for unsent selectors (because it, in a manner of speaking, sends itself). - (2) You can locate all such methods by browsing senders of #nominallyUnsent:" - - false ifTrue: [self flag: #nominallyUnsent:] "So that this method itself will appear to be sent" - ! Item was removed: - ----- Method: Object>>notYetImplemented (in category 'user interface') ----- - notYetImplemented - NotYetImplemented signal - ! Item was removed: - ----- Method: Object>>noteSelectionIndex:for: (in category 'updating') ----- - noteSelectionIndex: anInteger for: aSymbol - "backstop"! Item was removed: - ----- Method: Object>>notify: (in category 'error handling') ----- - notify: aString - "Create and schedule a Notifier with the argument as the message in - order to request confirmation before a process can proceed." - - Warning signal: aString - - "nil notify: 'confirmation message'"! Item was removed: - ----- Method: Object>>notify:at: (in category 'error handling') ----- - notify: aString at: location - "Create and schedule a Notifier with the argument as the message in - order to request confirmation before a process can proceed. Subclasses can - override this and insert an error message at location within aString." - - self notify: aString - - "nil notify: 'confirmation message' at: 12"! Item was removed: - ----- Method: Object>>objectForDataStream: (in category 'objects from disk') ----- - objectForDataStream: refStrm - "Return an object to store on an external data stream." - - ^ self! Item was removed: - ----- Method: Object>>objectRepresented (in category 'macpal') ----- - objectRepresented - "most objects represent themselves; this provides a hook for aliases to grab on to" - - ^ self! Item was removed: - ----- Method: Object>>okToChange (in category 'updating') ----- - okToChange - "Allows a controller to ask this of any model" - ^ true! Item was removed: - ----- Method: Object>>okToClose (in category 'updating') ----- - okToClose - "Allows a controller to ask this of any model" - ^self okToChange! Item was removed: - ----- Method: Object>>oopString (in category 'system primitives') ----- - oopString - "Answer a string that represents the oop of the receiver. - This method is for compatibility only, see comment for #asOop." - - ^ self asOop printString! Item was removed: - ----- Method: Object>>outboundPointers (in category 'tracing') ----- - outboundPointers - "Answers a list of all objects I am causing not to be garbage-collected" - - | collection | - collection := OrderedCollection new. - self outboundPointersDo: [:ea | collection add: ea]. - ^ collection! Item was removed: - ----- Method: Object>>outboundPointersDo: (in category 'tracing') ----- - outboundPointersDo: aBlock - "do aBlock for every object I point to, exactly how the garbage collector would. Adapted from PointerFinder >> #followObject:" - - aBlock value: self class. - 1 to: self class instSize do: [:i | aBlock value: (self instVarAt: i)]. - 1 to: self basicSize do: [:i | aBlock value: (self basicAt: i)].! Item was removed: - ----- Method: Object>>perform: (in category 'message handling') ----- - perform: aSymbol - "Send the unary selector, aSymbol, to the receiver. - Fail if the number of arguments expected by the selector is not zero. - Primitive. Optional. See Object documentation whatIsAPrimitive." - - <primitive: 83> - ^ self perform: aSymbol withArguments: {}! Item was removed: - ----- Method: Object>>perform:orSendTo: (in category 'message handling') ----- - perform: selector orSendTo: otherTarget - "Generic callback for an object composition. If the receiver can respond, then perform the message send on itself. If not, delegate it to otherTarget. This can be useful for callbacks in model-view compositions where the model might be the receiver and the view be the otherTarget. Override this to provoke a message-not-understood exception or otherwise tweak the send." - - ^ (self respondsTo: selector) - ifTrue: [self perform: selector] - ifFalse: [otherTarget perform: selector]! Item was removed: - ----- Method: Object>>perform:with: (in category 'message handling') ----- - perform: aSymbol with: anObject - "Send the selector, aSymbol, to the receiver with anObject as its argument. - Fail if the number of arguments expected by the selector is not one. - Primitive. Optional. See Object documentation whatIsAPrimitive." - - <primitive: 83> - ^ self perform: aSymbol withArguments: { anObject }! Item was removed: - ----- Method: Object>>perform:with:with: (in category 'message handling') ----- - perform: aSymbol with: firstObject with: secondObject - "Send the selector, aSymbol, to the receiver with the given arguments. - Fail if the number of arguments expected by the selector is not two. - Primitive. Optional. See Object documentation whatIsAPrimitive." - - <primitive: 83> - ^ self perform: aSymbol withArguments: { firstObject. secondObject }! Item was removed: - ----- Method: Object>>perform:with:with:with: (in category 'message handling') ----- - perform: aSymbol with: firstObject with: secondObject with: thirdObject - "Send the selector, aSymbol, to the receiver with the given arguments. - Fail if the number of arguments expected by the selector is not three. - Primitive. Optional. See Object documentation whatIsAPrimitive." - - <primitive: 83> - ^ self perform: aSymbol withArguments: { firstObject. secondObject. thirdObject }! Item was removed: - ----- Method: Object>>perform:with:with:with:with: (in category 'message handling') ----- - perform: aSymbol with: firstObject with: secondObject with: thirdObject with: fourthObject - "Send the selector, aSymbol, to the receiver with the given arguments. - Fail if the number of arguments expected by the selector is not four. - Primitive. Optional. See Object documentation whatIsAPrimitive." - - <primitive: 83> - ^ self perform: aSymbol withArguments: { firstObject. secondObject. thirdObject. fourthObject }! Item was removed: - ----- Method: Object>>perform:with:with:with:with:with: (in category 'message handling') ----- - perform: aSymbol with: firstObject with: secondObject with: thirdObject with: fourthObject with: fifthObject - "Send the selector, aSymbol, to the receiver with the given arguments. - Fail if the number of arguments expected by the selector is not five. - Primitive. Optional. See Object documentation whatIsAPrimitive." - - <primitive: 83> - ^ self perform: aSymbol withArguments: { firstObject. secondObject. thirdObject. fourthObject. fifthObject }! Item was removed: - ----- Method: Object>>perform:withArguments: (in category 'message handling') ----- - perform: selector withArguments: argArray - "Send the selector, aSymbol, to the receiver with arguments in argArray. - Fail if the number of arguments expected by the selector - does not match the size of argArray. - Primitive. Optional. See Object documentation whatIsAPrimitive." - - <primitive: 84> - ^ self perform: selector withArguments: argArray inSuperclass: self class! Item was removed: - ----- Method: Object>>perform:withArguments:inSuperclass: (in category 'message handling') ----- - perform: selector withArguments: argArray inSuperclass: lookupClass - "NOTE: This is just like perform:withArguments:, except that - the message lookup process begins, not with the receivers's class, - but with the supplied superclass instead. It will fail if lookupClass - cannot be found among the receiver's superclasses. - Primitive. Essential. See Object documentation whatIsAPrimitive." - - <primitive: 100> - (selector isSymbol) - ifFalse: [^ self error: 'selector argument must be a Symbol']. - (selector numArgs = argArray size) - ifFalse: [^ self error: 'incorrect number of arguments']. - (self class == lookupClass or: [self class inheritsFrom: lookupClass]) - ifFalse: [^ self error: 'lookupClass is not in my inheritance chain']. - self primitiveFailed! Item was removed: - ----- Method: Object>>perform:withEnoughArguments: (in category 'message handling') ----- - perform: selector withEnoughArguments: anArray - "Send selector to the receiver with arguments in anArray. Only use enough arguments for the arity of the selector; supply nils for missing ones." - - | numArgs args | - (numArgs := selector numArgs) = anArray size - ifTrue: [ args := anArray asArray ] - ifFalse: [ - args := Array new: numArgs. - args - replaceFrom: 1 - to: (anArray size min: args size) - with: anArray - startingAt: 1 ]. - ^self perform: selector withArguments: args! Item was removed: - ----- Method: Object>>pin (in category 'pinning') ----- - 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 removed: - ----- Method: Object>>postCopy (in category 'copying') ----- - postCopy - "self is a shallow copy, subclasses should copy fields as necessary to complete the full copy" - - ^ self! Item was removed: - ----- Method: Object>>presenter (in category 'accessing') ----- - presenter - "Answer the presenter object associated with the receiver. For morphs, there is in effect a clear containment hierarchy of presenters (accessed via their association with PasteUpMorphs); for arbitrary objects the hook is simply via the current world, at least at present." - - ^ self currentWorld presenter! Item was removed: - ----- Method: Object>>primitiveChangeClassTo: (in category 'system primitives') ----- - primitiveChangeClassTo: anObject - "Primitive. Change the class of the receiver into the class of the argument - given that the format of the receiver matches the format of the argument's - class. Fail if receiver or argument are immediates (SmallIntegers, Characters - or SmallFloat64s), or when the format of the receiver is different from the - format of the argument's class, or when the arguments class is fixed and - the receiver's size differs from the size that an instance of the argument's - class should have. - - Note: The primitive will fail in cases that you think might work. This is mostly - because of because of differences in the format. As an example, - '(Array new: 3) primitiveChangeClassTo: Morph basicNew' - would fail because Morph is a fixed-field-only object with about 6 instance - variables, and the array is too short (failure #3). - - The facility is really provided for certain, very specific applications (mostly related to classes changing shape) and not for casual use." - - <primitive: 115 error: ec> - ec == #'no modification' ifTrue: - [^anObject class modificationForbiddenAdopting: self]. - self primitiveFailed! Item was removed: - ----- Method: Object>>primitiveFailed (in category 'error handling') ----- - primitiveFailed - "Announce that a primitive has failed and there is no appropriate - Smalltalk code to run." - - self primitiveFailed: thisContext sender selector! Item was removed: - ----- Method: Object>>primitiveFailed: (in category 'error handling') ----- - primitiveFailed: selector - "Announce that a primitive has failed and there is no appropriate - Smalltalk code to run." - - self error: selector asString, ' failed'! Item was removed: - ----- Method: Object>>printDirectlyToDisplay (in category 'converting') ----- - printDirectlyToDisplay - "For debugging: write the receiver's printString directly to the display at (0, 100); senders of this are detected by the check-for-slips mechanism." - - self asString displayAt: 0 at 100 - - "StringMorph someInstance printDirectlyToDisplay"! Item was removed: - ----- Method: Object>>printOn: (in category 'printing') ----- - printOn: aStream - "Append to the argument, aStream, a sequence of characters that - identifies the receiver." - - | title | - title := self class name. - aStream - nextPutAll: (title first isVowel ifTrue: ['an '] ifFalse: ['a ']); - nextPutAll: title! Item was removed: - ----- Method: Object>>printString (in category 'printing') ----- - printString - "Answer a String whose characters are a description of the receiver. - If you want to print without a character limit, use fullPrintString." - - ^ self printStringLimitedTo: 50000! Item was removed: - ----- Method: Object>>printStringLimitedTo: (in category 'printing') ----- - printStringLimitedTo: limit - "Answer a String whose characters are a description of the receiver. - If you want to print without a character limit, use fullPrintString." - | limitedString | - limitedString := String streamContents: [:s | self printOn: s] limitedTo: limit. - limitedString size < limit ifTrue: [^ limitedString]. - ^ limitedString , '...etc...'! Item was removed: - ----- Method: Object>>printWithClosureAnalysisOn: (in category 'printing') ----- - printWithClosureAnalysisOn: aStream - "Append to the argument, aStream, a sequence of characters that - identifies the receiver." - - | title | - title := self class name. - aStream - nextPutAll: (title first isVowel ifTrue: ['an '] ifFalse: ['a ']); - nextPutAll: title! Item was removed: - ----- Method: Object>>putOn: (in category 'filter streaming') ----- - putOn:aStream - ^aStream nextPut:self. - ! Item was removed: - ----- Method: Object>>readDataFrom:size: (in category 'objects from disk') ----- - readDataFrom: aDataStream size: varsOnDisk - "Fill in the fields of self based on the contents of aDataStream. Return self. - Read in the instance-variables written by Object>>storeDataOn:. - NOTE: This method must send beginReference: before reading any objects from aDataStream that might reference it. - Allow aDataStream to have fewer inst vars. See SmartRefStream." - | cntInstVars cntIndexedVars | - - cntInstVars := self class instSize. - self class isVariable - ifTrue: [cntIndexedVars := varsOnDisk - cntInstVars. - cntIndexedVars < 0 ifTrue: [ - self error: 'Class has changed too much. Define a convertxxx method']] - ifFalse: [cntIndexedVars := 0. - cntInstVars := varsOnDisk]. "OK if fewer than now" - - aDataStream beginReference: self. - 1 to: cntInstVars do: - [:i | self instVarAt: i put: aDataStream next]. - 1 to: cntIndexedVars do: - [:i | self basicAt: i put: aDataStream next]. - "Total number read MUST be equal to varsOnDisk!!" - ^ self "If we ever return something other than self, fix calls - on (super readDataFrom: aDataStream size: anInteger)"! Item was removed: - ----- Method: Object>>readFromString: (in category 'accessing') ----- - readFromString: aString - "Create an object based on the contents of aString." - - ^self readFrom: (ReadStream on: aString)! Item was removed: - ----- Method: Object>>refusesToAcceptCode (in category 'macpal') ----- - refusesToAcceptCode - "Answer whether the receiver is a code-bearing instrument which at the moment refuses to allow its contents to be submitted" - - ^ false - ! Item was removed: - ----- Method: Object>>release (in category 'dependents access') ----- - release - "Remove references to objects that may refer to the receiver. This message - should be overridden by subclasses with any cycles, in which case the - subclass should also include the expression super release." - - self breakDependents. - (self respondsTo: #releaseActionMap) ifTrue: [self releaseActionMap].! Item was removed: - ----- Method: Object>>removeDependent: (in category 'dependents access') ----- - removeDependent: anObject - "Remove the given object as one of the receiver's dependents." - - | dependents | - dependents := self dependents reject: [:each | each == anObject]. - self myDependents: (dependents isEmpty ifFalse: [dependents]). - ^ anObject! Item was removed: - ----- Method: Object>>removeHaltCount (in category 'debugging-haltOnce') ----- - removeHaltCount - (self class environment includesKey: #HaltCount) ifTrue: [ - self class environment removeKey: #HaltCount]! Item was removed: - ----- Method: Object>>renameInternal: (in category 'testing') ----- - renameInternal: newName - "Change the internal name (because of a conflict) but leave the external name unchanged. Change Player class name, but do not change the names that appear in tiles. Any object that might be pointed to in the References dictionary might get this message sent to it upon reload" - - ^ nil "caller will renameTo:. new name may be different"! Item was removed: - ----- Method: Object>>renameTo: (in category 'testing') ----- - renameTo: newName - "If the receiver has an inherent idea about its own name, it should take action here. Any object that might be pointed to in the References dictionary might get this message sent to it upon reload"! Item was removed: - ----- Method: Object>>reportableSize (in category 'printing') ----- - reportableSize - "Answer a string that reports the size of the receiver -- useful for showing in a list view, for example" - - ^ (self basicSize + self class instSize) printString! Item was removed: - ----- Method: Object>>respondsTo: (in category 'class membership') ----- - respondsTo: aSymbol - "Answer whether the method dictionary of the receiver's class contains - aSymbol as a message selector." - - ^self class canUnderstand: aSymbol! Item was removed: - ----- Method: Object>>rootStubInImageSegment: (in category 'system primitives') ----- - rootStubInImageSegment: imageSegment - - ^ ImageSegmentRootStub new - xxSuperclass: nil - format: nil - segment: imageSegment! Item was removed: - ----- Method: Object>>saveOnFile (in category 'objects from disk') ----- - saveOnFile - "Ask the user for a filename and save myself on a SmartReferenceStream file. Writes out the version and class structure. The file is fileIn-able. Does not file out the class of the object." - - | aFileName | - aFileName := self class name asFileName. "do better?" - aFileName := UIManager default - saveFilenameRequest: 'File name?' translated initialAnswer: aFileName. - aFileName ifNil: [^ Beeper beep]. - - self saveOnFileNamed: aFileName! Item was removed: - ----- Method: Object>>saveOnFileNamed: (in category 'objects from disk') ----- - saveOnFileNamed: filenameString - "Save myself on a SmartReferenceStream file. Writes out the version and class structure. The file is fileIn-able. UniClasses will be filed out." - | fileStream | - fileStream := FileStream newFileNamed: filenameString. - fileStream fileOutClass: nil andObject: self. "Puts UniClass definitions out anyway, and closes the stream."! Item was removed: - ----- Method: Object>>scriptPerformer (in category 'macpal') ----- - scriptPerformer - - ^ self - ! Item was removed: - ----- Method: Object>>selfWrittenAsIll (in category 'scripting') ----- - selfWrittenAsIll - - ^self! Item was removed: - ----- Method: Object>>selfWrittenAsIm (in category 'scripting') ----- - selfWrittenAsIm - - ^self! Item was removed: - ----- Method: Object>>selfWrittenAsMe (in category 'scripting') ----- - selfWrittenAsMe - - ^self! Item was removed: - ----- Method: Object>>selfWrittenAsMy (in category 'scripting') ----- - selfWrittenAsMy - - ^self! Item was removed: - ----- Method: Object>>selfWrittenAsThis (in category 'scripting') ----- - selfWrittenAsThis - - ^self! Item was removed: - ----- Method: Object>>setHaltCountTo: (in category 'debugging-haltOnce') ----- - setHaltCountTo: int - Smalltalk at: #HaltCount put: int! Item was removed: - ----- Method: Object>>setHaltOnce (in category 'debugging-haltOnce') ----- - setHaltOnce - "Turn on the halt once flag." - Smalltalk at: #HaltOnce put: true! Item was removed: - ----- Method: Object>>setIsReadOnlyObject: (in category 'write barrier') ----- - setIsReadOnlyObject: aBoolean - "If the VM supports read-only objects it will not write to read-only objects. - An attempt to write to an instance variable of a read-only object will - cause the VM to send attemptToAssign:withIndex: to the read-only object. - An attempt to modify a read-only object in a primitive will cause the - primitive to fail with a #'no modification' error code. - This primitive sets the read-only flag of the receiver to the given - value and answers the previous vaue of the flag. - Note: Some objects can't be read-only, currently contexts and objects related - to process scheduling (Processor, Process instances, Semaphore instances, ...)" - <primitive: 164 error: ec> - ^self primitiveFailed! Item was removed: - ----- Method: Object>>setPinned: (in category 'private') ----- - 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 removed: - ----- Method: Object>>shallowCopy (in category 'copying') ----- - shallowCopy - "Answer a copy of the receiver which shares the receiver's instance variables." - - <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! Item was removed: - ----- Method: Object>>shouldBeImplemented (in category 'error handling') ----- - shouldBeImplemented - "Announce that this message should be implemented" - - ^ NotImplemented signal: ('{1} or a superclass should implement {2}' format: {self className. thisContext sender selector})! Item was removed: - ----- Method: Object>>shouldBePrintedAsLiteral (in category 'testing') ----- - shouldBePrintedAsLiteral - - ^self isLiteral! Item was removed: - ----- Method: Object>>shouldBePrintedAsLiteralVisiting: (in category 'testing') ----- - shouldBePrintedAsLiteralVisiting: aSet - - ^self isLiteral! Item was removed: - ----- Method: Object>>shouldNotImplement (in category 'error handling') ----- - shouldNotImplement - "Announce that, although the receiver inherits this message, it should - not implement it." - - NotImplemented signal: ('{1} is not a message appropriate for a {2}' format: {thisContext sender selector. self className}).! Item was removed: - ----- Method: Object>>showDiffs (in category 'testing') ----- - showDiffs - "Answer whether the receiver, serving as the model of a text-bearing entity, is 'showing differences' -- if it is, the editor may wish to show special feedback" - - ^ false! Item was removed: - ----- Method: Object>>size (in category 'accessing') ----- - size - "Primitive. Answer the number of indexable variables in the receiver. - This value is the same as the largest legal subscript. Essential. See Object - documentation whatIsAPrimitive." - - <primitive: 62> - self class isVariable ifFalse: [self errorNotIndexable]. - ^ 0! Item was removed: - ----- Method: Object>>slotInfo (in category 'macpal') ----- - slotInfo - "Answer a list of slot-information objects. Initally only provides useful info for players" - - ^ Dictionary new! Item was removed: - ----- Method: Object>>someObject (in category 'system primitives') ----- - someObject - "Primitive. Answer the first object in the enumeration of all - objects." - - <primitive: 138> - self primitiveFailed.! Item was removed: - ----- Method: Object>>species (in category 'private') ----- - species - "Answer the preferred class for reconstructing the receiver. For example, - collections create new collections whenever enumeration messages such as - collect: or select: are invoked. The new kind of collection is determined by - the species of the original collection. Species and class are not always the - same. For example, the species of Interval is Array." - <primitive: 111> - ^self class! Item was removed: - ----- Method: Object>>stepAt:in: (in category 'testing') ----- - stepAt: millisecondClockValue in: aWindow - - ^ self stepIn: aWindow! Item was removed: - ----- Method: Object>>stepIn: (in category 'testing') ----- - stepIn: aWindow - - ^ self step! Item was removed: - ----- Method: Object>>stepTime (in category 'testing') ----- - stepTime - - ^ 1000 "milliseconds -- default backstop for objects serving as models of system windows"! Item was removed: - ----- Method: Object>>stepTimeIn: (in category 'testing') ----- - stepTimeIn: aSystemWindow - - ^ 1000 "milliseconds -- default backstop for objects serving as models of system windows"! Item was removed: - ----- Method: Object>>storeAt:inTempFrame: (in category 'private') ----- - storeAt: offset inTempFrame: aContext - "This message had to get sent to an expression already on the stack - as a Block argument being accessed by the debugger. - Just re-route it to the temp frame." - ^ aContext tempAt: offset put: self! Item was removed: - ----- Method: Object>>storeDataOn: (in category 'objects from disk') ----- - storeDataOn: aDataStream - "Store myself on a DataStream. Answer self. This is a low-level DataStream/ReferenceStream method. See also objectToStoreOnDataStream. NOTE: This method must send 'aDataStream beginInstance:size:' and then (nextPut:/nextPutWeak:) its subobjects. readDataFrom:size: reads back what we write here." - | cntInstVars cntIndexedVars | - - cntInstVars := self class instSize. - cntIndexedVars := self basicSize. - aDataStream - beginInstance: self xxxClass - size: cntInstVars + cntIndexedVars. - 1 to: cntInstVars do: - [:i | aDataStream nextPut: (self instVarAt: i)]. - - "Write fields of a variable length object. When writing to a dummy - stream, don't bother to write the bytes" - ((aDataStream byteStream class == DummyStream) and: [self class isBits]) ifFalse: [ - 1 to: cntIndexedVars do: - [:i | aDataStream nextPut: (self basicAt: i)]]. - ! Item was removed: - ----- Method: Object>>storeOn: (in category 'printing') ----- - storeOn: aStream - "Append to the argument aStream a sequence of characters that is an - expression whose evaluation creates an object similar to the receiver." - - aStream nextPut: $(. - self class isVariable - ifTrue: [aStream nextPutAll: '(', self class name, ' basicNew: '; - store: self basicSize; - nextPutAll: ') '] - ifFalse: [aStream nextPutAll: self class name, ' basicNew']. - 1 to: self class instSize do: - [:i | - aStream nextPutAll: ' instVarAt: '; - store: i; - nextPutAll: ' put: '; - store: (self instVarAt: i); - nextPut: $;]. - 1 to: self basicSize do: - [:i | - aStream nextPutAll: ' basicAt: '; - store: i; - nextPutAll: ' put: '; - store: (self basicAt: i); - nextPut: $;]. - aStream nextPutAll: ' yourself)' - ! Item was removed: - ----- Method: Object>>storeString (in category 'printing') ----- - storeString - "Answer a String representation of the receiver from which the receiver - can be reconstructed." - - ^ String streamContents: [:s | self storeOn: s]! Item was removed: - ----- Method: Object>>stringForReadout (in category 'printing') ----- - stringForReadout - ^ self stringRepresentation! Item was removed: - ----- Method: Object>>stringRepresentation (in category 'printing') ----- - stringRepresentation - "Answer a string that represents the receiver. For most objects this is simply its printString, but for strings themselves, it's themselves. 6/12/96 sw" - - ^ self printString ! Item was removed: - ----- Method: Object>>subclassResponsibility (in category 'error handling') ----- - subclassResponsibility - "This message sets up a framework for the behavior of the class' subclasses. - Announce that the subclass should have implemented this message." - ^ SubclassResponsibility - signal: ('My {1} subclass should have overridden {2}' - format: {self className. thisContext sender selector}).! Item was removed: - ----- Method: Object>>toggleHaltOnce (in category 'debugging-haltOnce') ----- - toggleHaltOnce - self haltOnceEnabled - ifTrue: [self clearHaltOnce] - ifFalse: [self setHaltOnce]! Item was removed: - ----- Method: Object>>traitConflict (in category 'error handling') ----- - traitConflict - self error: 'A class or trait does not properly resolve a conflict between multiple traits it uses.'! Item was removed: - ----- Method: Object>>unpin (in category 'pinning') ----- - 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 removed: - ----- Method: Object>>update: (in category 'updating') ----- - update: aParameter - "Receive a change notice from an object of whom the receiver is a - dependent. The default behavior is to do nothing; a subclass might want - to change itself in some way." - - ^ self! Item was removed: - ----- Method: Object>>update:with: (in category 'updating') ----- - update: anAspect with: anObject - "Receive a change notice from an object of whom the receiver is a - dependent. The default behavior is to call update:, - which by default does nothing; a subclass might want - to change itself in some way." - - ^ self update: anAspect! Item was removed: - ----- Method: Object>>updateListsAndCodeIn: (in category 'updating') ----- - updateListsAndCodeIn: aWindow - self canDiscardEdits ifFalse: [^ self]. - aWindow updatablePanes do: [:aPane | aPane verifyContents]! Item was removed: - ----- Method: Object>>value (in category 'evaluating') ----- - value - - ^self! Item was removed: - ----- Method: Object>>valueWithArguments: (in category 'evaluating') ----- - valueWithArguments: aSequenceOfArguments - - ^self! Item was removed: - ----- Method: Object>>veryDeepCopy (in category 'copying') ----- - veryDeepCopy - "Do a complete tree copy using a dictionary. An object in the tree twice is only copied once. All references to the object in the copy of the tree will point to the new copy." - - | copier new | - copier := DeepCopier new: self initialDeepCopierSize. - new := self veryDeepCopyWith: copier. - copier mapUniClasses. - copier references associationsDo: [:assoc | - assoc value veryDeepFixupWith: copier]. - copier fixDependents. - ^ new! Item was removed: - ----- Method: Object>>veryDeepCopySibling (in category 'copying') ----- - veryDeepCopySibling - "Do a complete tree copy using a dictionary. Substitute a clone of oldPlayer for the root. Normally, a Player or non systemDefined object would have a new class. We do not want one this time. An object in the tree twice, is only copied once. All references to the object in the copy of the tree will point to the new copy." - - | copier new | - copier := DeepCopier new: self initialDeepCopierSize. - copier newUniClasses: false. - new := self veryDeepCopyWith: copier. - copier mapUniClasses. - copier references associationsDo: [:assoc | - assoc value veryDeepFixupWith: copier]. - copier fixDependents. - ^ new! Item was removed: - ----- Method: Object>>veryDeepCopyUsing: (in category 'copying') ----- - veryDeepCopyUsing: copier - "Do a complete tree copy using a dictionary. An object in the tree twice is only copied once. All references to the object in the copy of the tree will point to the new copy. - Same as veryDeepCopy except copier (with dictionary) is supplied. - ** do not delete this method, even if it has no callers **" - - | new refs | - new := self veryDeepCopyWith: copier. - copier mapUniClasses. - copier references associationsDo: [:assoc | - assoc value veryDeepFixupWith: copier]. - "Fix dependents" - refs := copier references. - DependentsFields associationsDo: [:pair | - pair value do: [:dep | - | newDep newModel | - (newDep := refs at: dep ifAbsent: [nil]) ifNotNil: [ - newModel := refs at: pair key ifAbsent: [pair key]. - newModel addDependent: newDep]]]. - ^ new! Item was removed: - ----- Method: Object>>veryDeepCopyWith: (in category 'copying') ----- - veryDeepCopyWith: deepCopier - "Copy me and the entire tree of objects I point to. An object in the tree twice is copied once, and both references point to him. deepCopier holds a dictionary of objects we have seen. Some classes refuse to be copied. Some classes are picky about which fields get deep copied." - | class index sub subAss new uc sup has mine | - deepCopier references at: self ifPresent: [:newer | ^ newer]. "already did him" - class := self class. - class isMeta ifTrue: [^ self]. "a class" - new := self shallowCopy. - (class isSystemDefined not and: [deepCopier newUniClasses "allowed"]) ifTrue: [ - uc := deepCopier uniClasses at: class ifAbsent: [nil]. - uc ifNil: [ - deepCopier uniClasses at: class put: (uc := self copyUniClassWith: deepCopier). - deepCopier references at: class put: uc]. "remember" - new := uc new. - new copyFrom: self]. "copy inst vars in case any are weak" - deepCopier references at: self put: new. "remember" - (class isVariable and: [class isPointers]) ifTrue: - [index := self basicSize. - [index > 0] whileTrue: - [sub := self basicAt: index. - (subAss := deepCopier references associationAt: sub ifAbsent: [nil]) - ifNil: [new basicAt: index put: (sub veryDeepCopyWith: deepCopier)] - ifNotNil: [new basicAt: index put: subAss value]. - index := index - 1]]. - "Ask each superclass if it wants to share (weak copy) any inst vars" - new veryDeepInner: deepCopier. "does super a lot" - - "other superclasses want all inst vars deep copied" - sup := class. index := class instSize. - [has := sup compiledMethodAt: #veryDeepInner: ifAbsent: [nil]. - has := has ifNil: [class isSystemDefined not "is a uniClass"] ifNotNil: [true]. - mine := sup instVarNames. - has ifTrue: [index := index - mine size] "skip inst vars" - ifFalse: [1 to: mine size do: [:xx | - sub := self instVarAt: index. - (subAss := deepCopier references associationAt: sub ifAbsent: [nil]) - "use association, not value, so nil is an exceptional value" - ifNil: [new instVarAt: index put: - (sub veryDeepCopyWith: deepCopier)] - ifNotNil: [new instVarAt: index put: subAss value]. - index := index - 1]]. - (sup := sup superclass) == nil] whileFalse. - new rehash. "force Sets and Dictionaries to rehash" - ^ new - ! Item was removed: - ----- Method: Object>>veryDeepFixupWith: (in category 'copying') ----- - veryDeepFixupWith: deepCopier - "I have no fields and no superclass. Catch the super call." - ! Item was removed: - ----- Method: Object>>veryDeepInner: (in category 'copying') ----- - veryDeepInner: deepCopier - "No special treatment for inst vars of my superclasses. Override when some need to be weakly copied. Object>>veryDeepCopyWith: will veryDeepCopy any inst var whose class does not actually define veryDeepInner:" - ! Item was removed: - ----- Method: Object>>vocabularyDemanded (in category 'testing') ----- - vocabularyDemanded - "Answer a vocabulary that the receiver insists be used when it is looked at in a Viewer. This allows specific classes to insist on specific custom vocabularies" - - ^ nil! Item was removed: - ----- Method: Object>>wantsDiffFeedback (in category 'testing') ----- - wantsDiffFeedback - "Answer whether the receiver, serving as the model of a text-bearing entity, would like for 'diffs' green pane-border feedback to be shown" - - ^ false! Item was removed: - ----- Method: Object>>wantsDroppedMorph:event:inMorph: (in category 'drag and drop') ----- - wantsDroppedMorph: aMorph event: anEvent inMorph: destinationLM - ^false! Item was removed: - ----- Method: Object>>wantsSteps (in category 'testing') ----- - wantsSteps - "Overridden by morphic classes whose instances want to be stepped, - or by model classes who want their morphic views to be stepped." - - ^ false! Item was removed: - ----- Method: Object>>wantsStepsIn: (in category 'testing') ----- - wantsStepsIn: aSystemWindow - - ^ self wantsSteps! Item was removed: - ----- Method: Object>>windowActiveOnFirstClick (in category 'user interface') ----- - windowActiveOnFirstClick - "Return true if my window should be active on first click." - - ^ false! Item was removed: - ----- Method: Object>>windowIsClosing (in category 'updating') ----- - windowIsClosing - "This message is used to inform a models that its window is closing. Most models do nothing, but some, such as the Debugger, must do some cleanup. Note that this mechanism must be used with care by models that support multiple views, since one view may be closed while others left open." - ! Item was removed: - ----- Method: Object>>windowReqNewLabel: (in category 'user interface') ----- - windowReqNewLabel: labelString - "My window's title has been edited. - Return true if this is OK, and override for further behavior." - - ^ true! Item was removed: - ----- Method: Object>>with:executeMethod: (in category 'message handling') ----- - with: arg1 executeMethod: compiledMethod - "Execute compiledMethod against the receiver and arg1" - - <primitive: 189> - ^ self withArgs: {arg1} executeMethod: compiledMethod! Item was removed: - ----- Method: Object>>with:with:executeMethod: (in category 'message handling') ----- - with: arg1 with: arg2 executeMethod: compiledMethod - "Execute compiledMethod against the receiver and arg1 & arg2" - - <primitive: 189> - ^ self withArgs: {arg1. arg2} executeMethod: compiledMethod! Item was removed: - ----- Method: Object>>with:with:with:executeMethod: (in category 'message handling') ----- - with: arg1 with: arg2 with: arg3 executeMethod: compiledMethod - "Execute compiledMethod against the receiver and arg1, arg2, & arg3" - - <primitive: 189> - ^ self withArgs: {arg1. arg2. arg3} executeMethod: compiledMethod! Item was removed: - ----- Method: Object>>with:with:with:with:executeMethod: (in category 'message handling') ----- - with: arg1 with: arg2 with: arg3 with: arg4 executeMethod: compiledMethod - "Execute compiledMethod against the receiver and arg1, arg2, arg3, & arg4" - - <primitive: 189> - ^ self withArgs: {arg1. arg2. arg3. arg4} executeMethod: compiledMethod! Item was removed: - ----- Method: Object>>withArgs:executeMethod: (in category 'message handling') ----- - withArgs: argArray executeMethod: compiledMethod - "Execute compiledMethod against the receiver and args in argArray" - - | selector | - <primitive: 188> - selector := Symbol new. - self class addSelectorSilently: selector withMethod: compiledMethod. - ^ [self perform: selector withArguments: argArray] - ensure: [self class basicRemoveSelector: selector]! Item was removed: - ----- Method: Object>>withoutListWrapper (in category 'converting') ----- - withoutListWrapper - - ^self! Item was removed: - ----- Method: Object>>writeOnFilterStream: (in category 'filter streaming') ----- - writeOnFilterStream:aStream - aStream writeObject:self. - ! Item was removed: - ----- Method: Object>>xxxClass (in category 'class membership') ----- - xxxClass - "For subclasses of nil, such as ObjectOut" - ^ self class! Item was removed: - ----- Method: Object>>yourself (in category 'accessing') ----- - yourself - "Answer self." - ^self! Item was removed: - ----- Method: Object>>~= (in category 'comparing') ----- - ~= anObject - "Answer whether the receiver and the argument do not represent the - same object." - - ^self = anObject == false! Item was removed: - ProtoObject subclass: #ObjectTracer - instanceVariableNames: 'tracedObject recursionFlag' - classVariableNames: '' - poolDictionaries: '' - category: 'Kernel-Objects'! - - !ObjectTracer commentStamp: '<historical>' prior: 0! - An ObjectTracer can be wrapped around another object, and then give you a chance to inspect it whenever it receives messages from the outside. For instance... - (ObjectTracer on: Display) flash: (50 at 50 extent: 50 at 50) - will give control to a debugger just before the message flash is sent. - Obviously this facility can be embellished in many useful ways. - See also the even more perverse subclass, ObjectViewer, and its example. - ! Item was removed: - ----- Method: ObjectTracer class>>on: (in category 'instance creation') ----- - on: anObject - ^ self new xxxViewedObject: anObject! Item was removed: - ----- Method: ObjectTracer>>doesNotUnderstand: (in category 'very few messages') ----- - doesNotUnderstand: aMessage - "Present a debugger before proceeding to re-send the message. All external messages (those not caused by the re-send) get trapped here." - - self flag: #workaround. "ct: After the selection of buttons in the debugger has been refactored, return to a simple Warning here. See: http://forum.world.st/The-Trunk-Kernel-mt-1303-mcz-tp5112200p5112211.html" - Processor - debugWithTitle: ('Object Tracer ({1})' translated format: {self identityHash}) - full: false - contents: ('On an instance of\ {1} ({2})\\About to perform\ {3}\\Using the following arguments\ {4}' translated withCRs - format: { - thisContext objectClass: tracedObject. - tracedObject identityHash. - aMessage selector storeString. - aMessage arguments printString}). - - ^ aMessage sendTo: tracedObject! Item was removed: - ----- Method: ObjectTracer>>xxxUnTrace (in category 'very few messages') ----- - xxxUnTrace - - tracedObject become: self! Item was removed: - ----- Method: ObjectTracer>>xxxViewedObject (in category 'very few messages') ----- - xxxViewedObject - "This message name must not clash with any other (natch)." - ^ tracedObject! Item was removed: - ----- Method: ObjectTracer>>xxxViewedObject: (in category 'very few messages') ----- - xxxViewedObject: anObject - "This message name must not clash with any other (natch)." - tracedObject := anObject! Item was removed: - ObjectTracer subclass: #ObjectViewer - instanceVariableNames: 'valueBlock lastValue changeBlock' - classVariableNames: '' - poolDictionaries: '' - category: 'Kernel-Objects'! - - !ObjectViewer commentStamp: 'dtl 1/30/2016 14:50' prior: 0! - ObjectViewers offers the same kind of interception of messages (via doesnotUnderstand:) as ObjectTracers, but instead of just being wrappers, they actually replace the object being viewed. This makes them a lot more dangerous to use, but one can do amazing things. For instance, the example below actually intercepts the EventSensor object, and prints the mouse coordinates asynchronously, every time they change: - Sensor evaluate: [Sensor cursorPoint printString displayAt: 0 at 0] - wheneverChangeIn: [Sensor cursorPoint]. - To exit from this example, execute: - Sensor xxxUnTrace - ! Item was removed: - ----- Method: ObjectViewer>>doesNotUnderstand: (in category 'very few messages') ----- - doesNotUnderstand: aMessage - "Check for change after sending aMessage" - | returnValue newValue | - recursionFlag ifTrue: [^ aMessage sendTo: tracedObject]. - recursionFlag := true. - returnValue := aMessage sendTo: tracedObject. - returnValue == tracedObject ifTrue: [ - "Keep the ObjectViewer in place as long as possible" - returnValue := self]. - newValue := valueBlock cull: aMessage. - newValue = lastValue ifFalse: - [changeBlock cull: aMessage. - lastValue := newValue]. - recursionFlag := false. - ^ returnValue! Item was removed: - ----- Method: ObjectViewer>>xxxViewedObject:evaluate:wheneverChangeIn: (in category 'very few messages') ----- - xxxViewedObject: viewedObject evaluate: block1 wheneverChangeIn: block2 - "This message name must not clash with any other (natch)." - tracedObject := viewedObject. - valueBlock := block2. - changeBlock := block1. - recursionFlag := false! Item was removed: - Error subclass: #OutOfMemory - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Kernel-Exceptions'! - - !OutOfMemory commentStamp: '<historical>' prior: 0! - OutOfMemory is signaled when an allocation fails due to not having enough memory. Its default action signals the low-space semaphore.! Item was removed: - ----- Method: OutOfMemory>>isResumable (in category 'private') ----- - isResumable - ^true! Item was removed: - Object subclass: #Pragma - instanceVariableNames: 'method keyword arguments' - classVariableNames: '' - poolDictionaries: '' - category: 'Kernel-Methods'! - - !Pragma commentStamp: 'fbs 5/8/2011 18:21' prior: 0! - I represent an occurrence of a pragma in a compiled method. A pragma is a literal message pattern that occurs between angle brackets at the start of a method after any temporaries. A common example is the primitive pragma: - <primitive: 123 errorCode: 'errorCode'> - but one can add one's own and use them as metadata attached to a method. Because pragmas are messages one can browse senders and implementors and perform them. One can query a method for its pragmas by sending it the pragmas message, which answers an Array of instances of me, one for each pragma in the method. - - I can provide information about the defining class, method, its selector, as well as the information about the pragma keyword and its arguments. See the two 'accessing' protocols for details. 'accessing-method' provides information about the method the pragma is found in, while 'accessing-pragma' is about the pragma itself. - - Instances are retrieved using one of the pragma search methods of the 'finding' protocol on the class side. - - To browse all methods with pragmas in the system evaluate - SystemNavigation default browseAllSelect: [:m| m pragmas notEmpty] - and to browse all nonprimitive methods with pragmas evaluate - SystemNavigation default browseAllSelect: [:m| m primitive isZero and: [m pragmas notEmpty]]! Item was removed: - ----- Method: Pragma class>>allNamed:from:to: (in category 'finding') ----- - allNamed: aSymbol from: aSubClass to: aSuperClass - "Answer a collection of all pragmas found in methods of all classes between aSubClass and aSuperClass (inclusive) whose keyword is aSymbol." - - ^ Array streamContents: [ :stream | - aSubClass withAllSuperclassesDo: [ :class | - self withPragmasIn: class do: [ :pragma | - pragma keyword = aSymbol - ifTrue: [ stream nextPut: pragma ] ]. - aSuperClass = class - ifTrue: [ ^ stream contents ] ] ].! Item was removed: - ----- Method: Pragma class>>allNamed:from:to:sortedByArgument: (in category 'finding') ----- - allNamed: aSymbol from: aSubClass to: aSuperClass sortedByArgument: anInteger - "Answer a collection of all pragmas found in methods of all classes between aSubClass and aSuperClass (inclusive) whose keyword is aSymbol, sorted according to argument anInteger." - - ^ self allNamed: aSymbol from: aSubClass to: aSuperClass sortedUsing: [ :a :b | (a argumentAt: anInteger) < (b argumentAt: anInteger) ].! Item was removed: - ----- Method: Pragma class>>allNamed:from:to:sortedUsing: (in category 'finding') ----- - allNamed: aSymbol from: aSubClass to: aSuperClass sortedUsing: aSortBlock - "Answer a collection of all pragmas found in methods of all classes between aSubClass and aSuperClass (inclusive) whose keyword is aSymbol, sorted according to aSortBlock." - - ^ (self allNamed: aSymbol from: aSubClass to: aSuperClass) sort: aSortBlock.! Item was removed: - ----- Method: Pragma class>>allNamed:in: (in category 'finding') ----- - allNamed: aSymbol in: aClass - "Answer a collection of all pragmas found in methods of aClass whose keyword is aSymbol." - - ^ Array streamContents: [ :stream | - self withPragmasIn: aClass do: [ :pragma | - pragma keyword = aSymbol - ifTrue: [ stream nextPut: pragma ] ] ].! Item was removed: - ----- Method: Pragma class>>allNamed:in:sortedByArgument: (in category 'finding') ----- - allNamed: aSymbol in: aClass sortedByArgument: anInteger - "Answer a collection of all pragmas found in methods of aClass whose keyword is aSymbol, sorted according to argument anInteger." - - ^ self allNamed: aSymbol in: aClass sortedUsing: [ :a :b | (a argumentAt: anInteger) < (b argumentAt: anInteger) ].! Item was removed: - ----- Method: Pragma class>>allNamed:in:sortedUsing: (in category 'finding') ----- - allNamed: aSymbol in: aClass sortedUsing: aSortBlock - "Answer a collection of all pragmas found in methods of aClass whose keyword is aSymbol, sorted according to aSortBlock." - - ^ (self allNamed: aSymbol in: aClass) sort: aSortBlock.! Item was removed: - ----- Method: Pragma class>>for:selector:arguments: (in category 'instance creation') ----- - for: aMethod selector: aSelector arguments: anArray - ^self new - setMethod: aMethod; - setKeyword: aSelector; - setArguments: anArray; - yourself! Item was removed: - ----- Method: Pragma class>>keyword:arguments: (in category 'private') ----- - keyword: aSymbol arguments: anArray - ^ self new - setKeyword: aSymbol; - setArguments: anArray; - yourself.! Item was removed: - ----- Method: Pragma class>>withPragmasIn:do: (in category 'private') ----- - withPragmasIn: aClass do: aBlock - aClass selectorsAndMethodsDo: [ :selector :method | method pragmas do: aBlock ].! Item was removed: - ----- Method: Pragma>>= (in category 'comparing') ----- - = anObject - ^self class == anObject class - and: [keyword == anObject keyword - and: [arguments = anObject arguments]]! Item was removed: - ----- Method: Pragma>>allLiteralsDo: (in category 'literals') ----- - allLiteralsDo: aBlock - - keyword allLiteralsDo: aBlock. - arguments allLiteralsDo: aBlock.! Item was removed: - ----- Method: Pragma>>analogousCodeTo: (in category 'comparing') ----- - analogousCodeTo: anObject - ^self class == anObject class - and: [keyword == anObject keyword - and: [arguments = anObject arguments]]! Item was removed: - ----- Method: Pragma>>argumentAt: (in category 'accessing-pragma') ----- - argumentAt: anInteger - "Answer one of the arguments of the pragma." - - ^ self arguments at: anInteger.! Item was removed: - ----- Method: Pragma>>arguments (in category 'accessing-pragma') ----- - arguments - "Answer the arguments of the receiving pragma. For a pragma defined as <key1: val1 key2: val2> this will answer #(val1 val2)." - - ^ arguments! Item was removed: - ----- Method: Pragma>>hasLiteral: (in category 'literals') ----- - hasLiteral: aLiteral - "Extra support for #hasLiteralTest:." - - ^ (super hasLiteral: aLiteral) - or: [keyword == #hasLiteralTest: and: [ - self methodClass theNonMetaClass perform: arguments first with: aLiteral]]! Item was removed: - ----- Method: Pragma>>hash (in category 'comparing') ----- - hash - ^keyword hash + arguments hash! Item was removed: - ----- Method: Pragma>>key (in category 'accessing-pragma') ----- - key - "Answer the keyword of the pragma (the selector of its message pattern). - This accessor provides polymorphism with Associations used for properties." - ^keyword! Item was removed: - ----- Method: Pragma>>keyword (in category 'accessing-pragma') ----- - keyword - "Answer the keyword of the pragma (the selector of its message pattern). - For a pragma defined as <key1: val1 key2: val2> this will answer #key1:key2:." - - ^ keyword! Item was removed: - ----- Method: Pragma>>message (in category 'accessing-pragma') ----- - message - "Answer the message of the receiving pragma." - - ^ Message selector: self keyword arguments: self arguments. ! Item was removed: - ----- Method: Pragma>>method (in category 'accessing-method') ----- - method - "Answer the compiled-method containing the pragma." - - ^ method! Item was removed: - ----- Method: Pragma>>methodClass (in category 'accessing-method') ----- - methodClass - "Answer the class of the method containing the pragma." - - ^ method methodClass! Item was removed: - ----- Method: Pragma>>numArgs (in category 'accessing-pragma') ----- - numArgs - "Answer the number of arguments in the pragma." - - ^ self arguments size.! Item was removed: - ----- Method: Pragma>>printOn: (in category 'printing') ----- - printOn: aStream - aStream - nextPut: $<; - print: self message; - nextPut: $>. - method ifNotNil: - [:m| - aStream nextPutAll: ' "in '. - m printReferenceOn: aStream. - aStream nextPut: $"]! Item was removed: - ----- Method: Pragma>>selector (in category 'accessing-method') ----- - selector - "Answer the selector of the method containing the pragma. - Do not confuse this with the selector of the pragma's message pattern." - - ^method selector! Item was removed: - ----- Method: Pragma>>setArguments: (in category 'initialization') ----- - setArguments: anArray - arguments := anArray! Item was removed: - ----- Method: Pragma>>setKeyword: (in category 'initialization') ----- - setKeyword: aSymbol - keyword := aSymbol! Item was removed: - ----- Method: Pragma>>setMethod: (in category 'initialization') ----- - setMethod: aCompiledMethod - method := aCompiledMethod! Item was removed: - Link subclass: #Process - instanceVariableNames: 'suspendedContext priority myList threadId effectiveProcess name island env' - classVariableNames: '' - poolDictionaries: '' - category: 'Kernel-Processes'! - - !Process commentStamp: 'eem 10/9/2021 15:34' prior: 0! - I represent an independent path of control in the system. This path of control may be stopped (by sending the message suspend) in such a way that it can later be restarted (by sending the message resume). When any one of several paths of control can be advanced, the single instance of ProcessorScheduler named Processor determines which one will actually be advanced, partly using the value of priority. - - Instance Variables: N.B. The first four are used by the virtual machine. They must be defined, and defined in this order, - suspendedContext: <Context|nil> - priority: <Integer> - myList: <LinkedList|nil> - threadId: <Integer|nil> - effectiveProcess: <Process|nil> - name: <String|nil> - island: <Island|nil> - env: <Dictionary|nil> - - effectiveProcess - - if not nil effectiveProcess is a process I am running on behalf of. Used by the execution simulation machinery (used by the debugger) to ensure that Processor activeProcess et al answer the expected result when simulating execution (e.g. when debugging). See evaluate:onBehalfOf: and senders. - - env - - if not nil this is a Dictionary providing process-specific variables. See e.g. environmentAt:*, DynamicVariable and ProcessSpecificVariable. - - island - - used by Tweak and Croquet to partition the image into multiple address spaces - - myList - - if nil, I am either suspended or the active process. If not nil it is either some condition variable (Semaphore, Mutex) that I am blocked waiting on, or it is the LinkedList in ProcessorScheduler quiescentProcesses that holds the processes for my priority that are not the current active process but still runnable. - - name - - if not nil this is my name, used for information, see e.g. the names of processes displayed in the ProcessBrowser - - priority - - my scheduling priority, which corresponds to the index in ProcessorScheduler quiescentProcesses that holds the LinkedList of processes at this priority. If I am running but quiescent, changing priority involves changing priority and myList. - - suspendedContext - - if nil, then I am either the active process or I have been terminated. If not nil it is the Context at the hot end of my stack - - threadId - - if not nil then it is an integer value set by the VM that controls how I interact with underlying native threads. If positive, the threadId is that of some native thread known to the VM, and the VM will ensure that when I am running, I will be running on that native thread. If negative, the absolute value of threadId is that of some thread known to the VM, and the VM will ensure that when I am running, I will *not* be running on that native thread. Set by the VM. Not to be set manually. Meaningful only on threaded VMs (which do not mean VMs with a threaded heartbeat). It is required to be my fourth instance variable. See SmalltalkImage >> #processHasThreadIdInstVar: for further information.! Item was removed: - ----- Method: Process class>>forContext:priority: (in category 'instance creation') ----- - forContext: aContext priority: anInteger - "Answer an instance of me that has suspended aContext at priority anInteger. - It's important to set the priority before setting the suspendedContext; otherwise - an endless stream of error windows will start poping up when debugging e.g. - [] newProcess - when Process Browser is open with auto-update on." - - | newProcess | - newProcess := self new. - newProcess priority: anInteger. - newProcess suspendedContext: aContext asContext. - ^newProcess! Item was removed: - ----- Method: Process>>activateReturn:value: (in category 'changing suspended state') ----- - activateReturn: aContext value: value - "Activate 'aContext return: value', so execution will return to aContext's sender" - - ^Processor activeProcess - evaluate: [suspendedContext := suspendedContext activateReturn: aContext value: value] - onBehalfOf: self! Item was removed: - ----- Method: Process>>browserPrintString (in category 'printing') ----- - browserPrintString - ^self browserPrintStringWith: suspendedContext! Item was removed: - ----- Method: Process>>browserPrintStringWith: (in category 'printing') ----- - browserPrintStringWith: anObject - | stream | - stream := WriteStream - on: (String new: 100). - stream nextPut: $(. - priority printOn: stream. - self isSuspended - ifTrue: [stream nextPut: $s]. - stream nextPutAll: ') '. - stream nextPutAll: self name. - stream nextPut: $:. - stream space. - stream nextPutAll: anObject asString. - ^ stream contents! Item was removed: - ----- Method: Process>>calleeOf: (in category 'accessing') ----- - calleeOf: aContext - "Return the context whose sender is aContext. Return nil if aContext is on top. Raise error if aContext is not in process chain." - - suspendedContext == aContext ifTrue: [^ nil]. - ^ (suspendedContext findContextSuchThat: [:c | c sender == aContext]) - ifNil: [self error: 'aContext not in process chain']! Item was removed: - ----- Method: Process>>complete: (in category 'changing suspended state') ----- - complete: aContext - - ^ self complete: aContext ifError: [:error | - Notification new - tag: {aContext. error}; - signal. - ^error signalerContext]! Item was removed: - ----- Method: Process>>complete:ifError: (in category 'changing suspended state') ----- - complete: aContext ifError: errorBlock - "Run the receiver until aContext is popped or an unhandled error is raised. If aContext was popped regularly, return self's new top context; otherwise, evaluate errorBlock with the error and return the signaler context (rather than opening a debugger)." - - | ctxt error pair | - ctxt := suspendedContext. - suspendedContext := nil. "disable this process while running its stack in active process below" - pair := Processor activeProcess - evaluate: [ctxt runUntilErrorOrReturnFrom: aContext] - onBehalfOf: self. - suspendedContext := pair first. - error := pair second. - error ifNotNil: [errorBlock value: error]. - ^ suspendedContext! Item was removed: - ----- Method: Process>>completeStep: (in category 'changing suspended state') ----- - completeStep: aContext - "Resume self until aContext is on top, or if already on top, complete next step" - - | callee | - self isTerminated ifTrue: - [^ nil]. - self suspendedContext == aContext ifFalse: - [^ self complete: (self calleeOf: aContext)]. - callee := self step. - callee == aContext ifTrue: [^ callee]. - aContext isDead ifTrue: [^ self suspendedContext]. "returned" - ^ self complete: callee "finish send"! Item was removed: - ----- Method: Process>>completeTo: (in category 'changing suspended state') ----- - completeTo: aContext - "Resume self until aContext is on top" - - self suspendedContext == aContext ifTrue: [^ aContext]. - ^ self complete: (self calleeOf: aContext)! Item was removed: - ----- Method: Process>>copyStack (in category 'accessing') ----- - copyStack - - ^ self copy install: suspendedContext copyStack! Item was removed: - ----- Method: Process>>destroy (in category 'changing process state') ----- - destroy - "Destroy the receiver immediately without attempting to run any of its unwind blocks. Kind of private!! Unless you have a very good reason (such as recursive stack errors), you should send #terminate or #terminateAggressively instead which will allow for cleaning up any open resources properly." - - suspendedContext := nil. - self terminateAggressively.! Item was removed: - ----- Method: Process>>effectiveProcess (in category 'accessing') ----- - effectiveProcess - "effectiveProcess is a mechanism to allow process-faithful debugging. The debugger executes code - on behalf of processes, so unless some effort is made the identity of Processor activeProcess is not - correctly maintained when debugging code. The debugger uses evaluate:onBehalfOf: to assign the - debugged process as the effectiveProcess of the process executing the code, preserving process - identity." - ^effectiveProcess ifNil: [self]! Item was removed: - ----- Method: Process>>environmentAt: (in category 'process specific') ----- - environmentAt: key - ^ self environmentAt: key ifAbsent: [self environmentKeyNotFound]! Item was removed: - ----- Method: Process>>environmentAt:ifAbsent: (in category 'process specific') ----- - environmentAt: key ifAbsent: aBlock - - ^(env ifNil: [ ^aBlock value ]) at: key ifAbsent: aBlock.! Item was removed: - ----- Method: Process>>environmentAt:ifAbsentPut: (in category 'process specific') ----- - environmentAt: key ifAbsentPut: aBlock - - ^(env ifNil: [ env := Dictionary new ]) at: key ifAbsentPut: aBlock.! Item was removed: - ----- Method: Process>>environmentAt:put: (in category 'process specific') ----- - environmentAt: key put: value - - ^(env ifNil: [ env := Dictionary new ]) at: key put: value.! Item was removed: - ----- Method: Process>>environmentKeyNotFound (in category 'process specific') ----- - environmentKeyNotFound - self error: 'Environment key not found'! Item was removed: - ----- Method: Process>>environmentRemoveKey: (in category 'process specific') ----- - environmentRemoveKey: key - ^ self environmentRemoveKey: key ifAbsent: [self environmentKeyNotFound]! Item was removed: - ----- Method: Process>>environmentRemoveKey:ifAbsent: (in category 'process specific') ----- - environmentRemoveKey: key ifAbsent: errorBlock - - ^(env ifNil: [ ^errorBlock value ]) removeKey: key ifAbsent: errorBlock! Item was removed: - ----- Method: Process>>evaluate:onBehalfOf: (in category 'private') ----- - evaluate: aBlock onBehalfOf: aProcess - "Evaluate aBlock setting effectiveProcess to aProcess. Used in the execution simulation machinery to ensure that Processor activeProcess evaluates correctly when debugging, which is also known as process-faithful debugging." - - | oldEffectiveProcess | - aProcess == self ifTrue: [^ aBlock value]. "Optimization" - - oldEffectiveProcess := effectiveProcess. - effectiveProcess := aProcess. - ^ aBlock ensure: [effectiveProcess := oldEffectiveProcess]! Item was removed: - ----- Method: Process>>install: (in category 'changing suspended state') ----- - install: aContext - "Replace the suspendedContext with aContext." - - self == Processor activeProcess - ifTrue: [^self error: 'The active process cannot install contexts']. - suspendedContext := aContext! Item was removed: - ----- Method: Process>>isActiveProcess (in category 'testing') ----- - isActiveProcess - - ^ self == Processor activeProcess! Item was removed: - ----- Method: Process>>isBlocked (in category 'testing') ----- - isBlocked - "A process is blocked if it is waiting on some list (i.e. a Semaphore), other than the runnable process lists." - | myPriority | - "Grab my prioirty now. Even though evaluation is strictly right-to-left, accessing Processor could involve a send." - myPriority := priority. - ^myList - ifNil: [false] - ifNotNil: [:list| list ~~ (Processor waitingProcessesAt: myPriority)]! Item was removed: - ----- Method: Process>>isRunnable (in category 'testing') ----- - isRunnable - "A process is runnable if it is the active process or is on one of the runnable process lists." - | myPriority | - "Grab my prioirty now. Even though evaluation is strictly right-to-left, accessing Processor could involve a send." - myPriority := priority. - ^myList - ifNil: [^self == Processor activeProcess] - ifNotNil: [:list| list == (Processor waitingProcessesAt: myPriority)]! Item was removed: - ----- Method: Process>>isSuspended (in category 'testing') ----- - isSuspended - "A process is suspended if it is not active, not terminated and - not waiting in a scheduler or a semaphore queue." - - self isActiveProcess ifTrue: [^ false]. - ^myList isNil and: [self isTerminated not]! Item was removed: - ----- Method: Process>>isTerminated (in category 'testing') ----- - isTerminated - "Answer if the receiver is terminated. A process is considered terminated - if the suspendedContext is the bottomContext and the pc is at the endPC" - - self isActiveProcess ifTrue: [^ false]. - ^suspendedContext isNil or: [ - suspendedContext isBottomContext and: [ - suspendedContext isDead or: [suspendedContext atEnd]]]! Item was removed: - ----- Method: Process>>longPrintOn: (in category 'printing') ----- - longPrintOn: stream - - | ctxt | - super printOn: stream. - stream - nextPut: $(; - nextPutAll: self name; - nextPut: $). - stream cr. - ctxt := self suspendedContext. - [ctxt == nil] whileFalse: [ - stream space. - ctxt printOn: stream. - stream cr. - ctxt := ctxt sender. - ]. - ! Item was removed: - ----- Method: Process>>name (in category 'accessing') ----- - name - - ^name ifNil: [ self hash asString forceTo: 5 paddingStartWith: $ ]! Item was removed: - ----- Method: Process>>name: (in category 'accessing') ----- - name: aString - - name := aString! Item was removed: - ----- Method: Process>>objectForDataStream: (in category 'objects from disk') ----- - objectForDataStream: refStrm - "I am not allowed to be written on an object file." - - refStrm replace: self with: nil. - ^ nil! Item was removed: - ----- Method: Process>>offList (in category 'accessing') ----- - offList - "OBSOLETE. Process>>suspend will atomically reset myList if the process is suspended. - There should never be a need to send #offList but some older users may not be aware - of the changed semantics to suspend and may try the old hickadidoo seen here: - - (suspendingList := process suspendingList) == nil - ifTrue: [process == Processor activeProcess ifTrue: [process suspend]] - ifFalse: [suspendingList remove: process ifAbsent:[]. - process offList]. - - Usages like the above should be replaced by a simple 'process suspend' " - myList := nil! Item was removed: - ----- Method: Process>>popTo: (in category 'changing suspended state') ----- - popTo: aContext - "Pop self down to aContext by remote returning from aContext's callee. Unwind blocks will be executed on the way. - This is done by pushing a new context on top which executes 'aContext callee return' then resuming self until aContext is reached. This way any errors raised in an unwind block will get handled by senders in self and not by senders in the activeProcess. - If an unwind block raises an error that is not handled then the popping stops at the error and the signalling context is returned, othewise aContext is returned." - - self == Processor activeProcess ifTrue: - [^self error: 'The active process cannot pop contexts']. - ^(self calleeOf: aContext) - ifNil: [aContext] "aContext is on top" - ifNotNil: - [:callee| - Processor activeProcess - evaluate: [self return: callee value: callee receiver] - onBehalfOf: self]! Item was removed: - ----- Method: Process>>popTo:value: (in category 'changing suspended state') ----- - popTo: aContext value: aValue - "Replace the suspendedContext with aContext, releasing all contexts - between the currently suspendedContext and it." - - self == Processor activeProcess ifTrue: - [^self error: 'The active process cannot pop contexts']. - ^(self calleeOf: aContext) - ifNil: [aContext] "aContext is on top" - ifNotNil: - [:callee| - Processor activeProcess - evaluate: [self return: callee value: aValue] - onBehalfOf: self]! Item was removed: - ----- Method: Process>>printOn: (in category 'printing') ----- - printOn: aStream - - super printOn: aStream. - aStream - nextPut: $(; - nextPutAll: self name; - nextPut: $). - aStream nextPutAll: ' in '. - suspendedContext printOn: aStream! Item was removed: - ----- Method: Process>>priority (in category 'accessing') ----- - priority - "Answer the priority of the receiver." - - ^priority! Item was removed: - ----- Method: Process>>priority: (in category 'accessing') ----- - priority: anInteger - "Set the receiver's priority to anInteger." - (anInteger >= Processor lowestPriority and:[anInteger <= Processor highestPriority]) - ifTrue: [priority := anInteger] - ifFalse: [self error: 'Invalid priority: ', anInteger printString]! Item was removed: - ----- Method: Process>>pvtSignal:list: (in category 'signaling') ----- - pvtSignal: anException list: aList - "Private. This method is used to signal an exception from another - process...the receiver must be the active process. If the receiver - was previously waiting on a Semaphore, then return the process - to the waiting state after signaling the exception and if the Semaphore - has not been signaled in the interim" - - "Since this method is not called in a normal way, we need to take care - that it doesn't directly return to the caller (because I believe that could - have the potential to push an unwanted object on the caller's stack)." - - | blocker | - self isActiveProcess ifFalse: [^self]. - anException signal. - blocker := Semaphore new. - [self suspend. - suspendedContext := suspendedContext swapSender: nil. - aList class == Semaphore - ifTrue: - [aList isSignaled - ifTrue: - [aList wait. "Consume the signal that would have restarted the receiver" - self resume] - ifFalse: - ["Add us back to the Semaphore's list (and remain blocked)" - myList := aList. - aList add: self]] - ifFalse: [self resume]] fork. - blocker wait. - - - ! Item was removed: - ----- Method: Process>>releaseCriticalSection: (in category 'private') ----- - releaseCriticalSection: runnable - "Figure out if we are terminating a process that is in the ensure: block of a critical section. - In this case, if the block has made progress, pop the suspendedContext so that we leave the - ensure: block inside the critical: without signaling the semaphore/exiting the primitive section, - since presumably this has already happened. But if it hasn't made progress but is beyond the - wait (which we can tell by the oldList being one of the runnable lists, i.e. a LinkedList, not a - Semaphore or Mutex, et al), then the ensure: block needs to be run." - | selectorJustSent | - (suspendedContext method pragmaAt: #criticalSection) ifNil: [^self]. - selectorJustSent := suspendedContext selectorJustSentOrSelf. - - "Receiver and/or argument blocks of ensure: in Semaphore>>critical: or Mutex>>#critical:" - suspendedContext isClosureContext ifTrue: - [suspendedContext sender isUnwindContext ifTrue: - [| notWaitingButMadeNoProgress | - "Avoid running the ensure: block twice, popping it if it has already been run. If runnable - but at the wait, leave it in place. N.B. No need to check if the block receiver of ensure: has - not started to run (via suspendedContext pc = suspendedContext startpc) because ensure: - uses valueNoContextSwitch, and so there is no suspension point before the wait." - notWaitingButMadeNoProgress := - runnable - and: [selectorJustSent == #wait - and: [suspendedContext sender selectorJustSentOrSelf == #valueNoContextSwitch]]. - notWaitingButMadeNoProgress ifFalse: - [suspendedContext := suspendedContext home]]. - ^self]. - - "Either Semaphore>>critical: or Mutex>>#critical:. Is the process still blocked? If so, nothing further to do." - runnable ifFalse: [^self]. - - "If still at the wait the ensure: block has not been activated, so signal to restore." - selectorJustSent == #wait ifTrue: - [suspendedContext receiver signal]. - - "If still at the lock primitive and the lock primitive just acquired ownership (indicated by it answering false) - then the ensure block has not been activated, so explicitly primitiveExitCriticalSection to unlock." - (selectorJustSent == #primitiveEnterCriticalSection - or: [selectorJustSent == #primitiveTestAndSetOwnershipOfCriticalSection]) ifTrue: - [(suspendedContext stackPtr > 0 - and: [suspendedContext top == false]) ifTrue: - [suspendedContext receiver primitiveExitCriticalSection]]! Item was removed: - ----- Method: Process>>restartTop (in category 'changing suspended state') ----- - restartTop - "Rollback top context and replace with new method. Assumes self is suspended" - - suspendedContext privRefresh! Item was removed: - ----- Method: Process>>restartTopWith: (in category 'changing suspended state') ----- - restartTopWith: method - "Rollback top context and replace with new method. Assumes self is suspended" - - method isQuick - ifTrue: [self popTo: suspendedContext sender] - ifFalse: - [suspendedContext method frameSize >= method frameSize - ifTrue: [suspendedContext privRefreshWith: method] - ifFalse: - [self assert: suspendedContext isExecutingBlock not. - suspendedContext := Context - sender: suspendedContext sender - receiver: suspendedContext receiver - method: method - arguments: ((1 to: method numArgs) collect: - [:i| suspendedContext tempAt: i])]]. - ! Item was removed: - ----- Method: Process>>resume (in category 'changing process state') ----- - resume - "Primitive. Allow the process that the receiver represents to continue. Put - the receiver in line to become the activeProcess. Fail if the receiver is - already waiting in a queue (in a Semaphore or ProcessScheduler). Fail if - the receiver's suspendedContext is not a context. - Essential. See Object documentation whatIsAPrimitive." - - <primitive: 87 error: ec> - self primitiveFailed! Item was removed: - ----- Method: Process>>return:value: (in category 'changing suspended state') ----- - return: aContext value: value - "Pop thread down to aContext's sender. Execute any unwind blocks on the way. See #popTo: comment and #runUntilErrorOrReturnFrom: for more details." - - suspendedContext == aContext ifTrue: - [^Processor activeProcess - evaluate: [suspendedContext := aContext return: value from: aContext] - onBehalfOf: self]. - self activateReturn: aContext value: value. - ^self complete: aContext! Item was removed: - ----- Method: Process>>run (in category 'changing process state') ----- - run - "Suspend current process and execute self instead" - - | proc | - proc := Processor activeProcess. - [ proc suspend. - self resume. - ] forkAt: Processor highestPriority! Item was removed: - ----- Method: Process>>signalException: (in category 'signaling') ----- - signalException: anException - "Signal an exception in the receiver process...if the receiver is currently - suspended, the exception will get signaled when the receiver is resumed. If - the receiver is blocked on a Semaphore, it will be immediately re-awakened - and the exception will be signaled; if the exception is resumed, then the receiver - will return to a blocked state unless the blocking Semaphore has excess signals" - - "If we are the active process, go ahead and signal the exception" - self isActiveProcess ifTrue: [^anException signal]. - - "One could raise an error here but that would force clients to employ a guard. - Since a terminated process can have no response to a signal (there is no - where for a handler to exist) it is legitimate to simply discard the signal." - suspendedContext ifNil: [^self]. - - "Suspend myself first to ensure that I won't run away - in the midst of the following modifications." - self isSuspended ifFalse: - [self suspend]. - - "Add a new block context to the stack that will signal the exception (jar 6/27/2022)" - suspendedContext := - [anException signal. thisContext sender jump] asContextWithSender: suspendedContext. - "Since this block is not called in a normal way, we need to take care - that it doesn't directly return to the caller (because that could have - the potential to push an unwanted object on the caller's stack). - Workspace example: - p := [Semaphore new wait] fork. - Processor yield. - p signalException: Notification - " - ^self resume! Item was removed: - ----- Method: Process>>step (in category 'changing suspended state') ----- - step - - ^Processor activeProcess - evaluate: [suspendedContext := suspendedContext step] - onBehalfOf: self! Item was removed: - ----- Method: Process>>step: (in category 'changing suspended state') ----- - step: aContext - "Resume self until aContext is on top, or if already on top, do next step" - - ^Processor activeProcess - evaluate: - [self suspendedContext == aContext - ifTrue: [suspendedContext := suspendedContext step] - ifFalse: [self complete: (self calleeOf: aContext)]] - onBehalfOf: self! Item was removed: - ----- Method: Process>>stepToCallee (in category 'changing suspended state') ----- - stepToCallee - "Step until top context changes" - - Processor activeProcess - evaluate: - [| ctxt | - ctxt := suspendedContext. - [ctxt == suspendedContext] whileTrue: [ - suspendedContext := suspendedContext step]] - onBehalfOf: self. - ^suspendedContext! Item was removed: - ----- Method: Process>>stepToHome: (in category 'changing suspended state') ----- - stepToHome: aContext - "Resume self until the home of top context is aContext. Top context may be a block context. - Catch any UnhandledErrors that are created while stepping, answering the relevant signalerContext - if so. Note that this will cause weird effects if using through to step through UnhandledError - code, but as the doctor ordered, don't do that; use over or into instead." - - ^Processor activeProcess - evaluate: - [| home anError | - home := aContext home. - [suspendedContext := suspendedContext step. - home == suspendedContext home or: [home isDead]] whileFalse: - [(suspendedContext selector == #signalForException: - and: [(suspendedContext receiver isBehavior and: [ - suspendedContext receiver includesBehavior: UnhandledError]) - and: [anError := suspendedContext tempAt: 1. - ((suspendedContext objectClass: anError) includesBehavior: Exception) - and: [anError canSearchForSignalerContext]]]) ifTrue: - [anError signalerContext ifNotNil: - [:unhandledErrorSignalerContext| - [unhandledErrorSignalerContext == suspendedContext] whileFalse: - [self completeStep: suspendedContext]. - "Give a debugger a chance to update its title to reflect the new exception" - Notification new - tag: {unhandledErrorSignalerContext. anError}; - signal. - ^unhandledErrorSignalerContext]]]. - suspendedContext] - onBehalfOf: self! Item was removed: - ----- Method: Process>>stepToSendOrReturn (in category 'changing suspended state') ----- - stepToSendOrReturn - - ^Processor activeProcess - evaluate: [suspendedContext := suspendedContext stepToSendOrReturn] - onBehalfOf: self! Item was removed: - ----- Method: Process>>suspend (in category 'changing process state') ----- - suspend - "eem 1/3/2022 10:38: - Primitive. Suspend the receiver, aProcess, such that it can be executed again - by sending #resume. If the given process is not the active process, take it off - its corresponding list. If the list was not its run queue assume it was on some - condition variable (Semaphore, Mutex) and back up its pc to the send that - invoked the wait state the process entered. Hence when the process resumes - it will reenter the wait state. Answer the list the receiver was previously on iff - it was not active and not blocked, otherwise answer nil." - - <primitive: 578 error: ec> - "This is fallback code for VMs which only support the old primitiveSuspend 88. - Note: in this case some tests may fail and some methods assuming the revised - suspend semantics described above may not work entirely as expected (e.g. - Context >> #releaseCriticalSection or Process >> #signalException)." - ^self suspendAndUnblock! Item was removed: - ----- Method: Process>>suspendAndReleaseCriticalSection (in category 'private') ----- - suspendAndReleaseCriticalSection - "Figure out if we are terminating a process that is in the ensure: block of a critical section. - If it hasn't made progress but is beyond the wait (which we can tell by the oldList being - one of the runnable lists, i.e. a LinkedList, not a Semaphore or Mutex, et al), then the ensure: - block needs to be run." - - | oldList selectorJustSent | - "Suspend and unblock the receiver from a condition variable using suspend primitive #88. - It answers the list the receiver was on before the suspension." - oldList := self suspendAndUnblock. - (oldList isNil or: [oldList class == LinkedList]) ifFalse: [^self]. - - ((suspendedContext ifNil: [^self]) method pragmaAt: #criticalSection) ifNil: [^self]. - selectorJustSent := suspendedContext selectorJustSentOrSelf. - - "If still at the wait the ensure: block has not been activated, so signal to restore." - selectorJustSent == #wait ifTrue: - [suspendedContext receiver signal]. - - "If still at the lock primitive and the lock primitive just acquired ownership (indicated by it answering false) - then the ensure block has not been activated, so explicitly primitiveExitCriticalSection to unlock." - (selectorJustSent == #primitiveEnterCriticalSection - or: [selectorJustSent == #primitiveTestAndSetOwnershipOfCriticalSection]) ifTrue: - [(suspendedContext stackPtr > 0 - and: [suspendedContext top == false]) ifTrue: - [suspendedContext receiver primitiveExitCriticalSection]]! Item was removed: - ----- Method: Process>>suspendAndUnblock (in category 'changing process state') ----- - suspendAndUnblock - "ar 12/7/2007 17:10: - Primitive. Stop the process that the receiver represents in such a way - that it can be restarted at a later time (by sending the receiver the - message resume). If the receiver represents the activeProcess, suspend it. - Otherwise remove the receiver from the list of waiting processes. - The return value of this method is the list the receiver was previously on (if any)." - - <primitive: 88 error: ec> - "ar 12/7/2007 17:10: - This is fallback code for VMs which only support the old primitiveSuspend which - would not accept processes that are waiting to be run." - ^myList ifNotNil: "this allows us to use suspend multiple times" - [:oldList| - myList := nil. - oldList remove: self ifAbsent: []. - oldList]! Item was removed: - ----- Method: Process>>suspendedContext (in category 'accessing') ----- - suspendedContext - "Answer the context the receiver has suspended." - - ^suspendedContext! Item was removed: - ----- Method: Process>>suspendedContext: (in category 'private') ----- - suspendedContext: aContextOrNil - "Set suspendedContext; proceed with caution when assigning nil or when process priority is undefined." - - "Note: Assigning nil to a runnable but not active process would freeze the image when self is scheduled to run. - - Workspace example: - These two lines (executed at once, not line by line) - p := [] newProcess resume. - p suspendedContext: nil - will freeze the image; the first line puts p in the run queue, the second line niles p's suspendedContext and - when the UI cycles, p tries to run with niled suspendedContext and the image freezes as a result. - - Assigning 'suspendedContext' before 'priority' is defined may cause a disaster when Process Browser is open - with auto-update on; once the 'suspendedContext' is set, the new process is no longer considered terminated - and Process Browser will try to place it in its list of processes but encounters a nil error when reading its priority - because it has not been set yet. - - Workspace example: - If you run the following line with Process Browser open and auto-update on, you'll ruin your image: - p := Process new suspendedContext: [self] asContext - Every second a new debugger window pops up and the only way out is to kill the image in the OS. - - As a precautionary measure set 'priority' if undefined to the active process priority before setting - 'suspendedContext'." - - priority ifNil: [priority := Processor activePriority]. - suspendedContext := aContextOrNil ifNil: [self suspend. nil]! Item was removed: - ----- Method: Process>>suspendingList (in category 'accessing') ----- - suspendingList - "Answer the list on which the receiver has been suspended." - - ^myList! Item was removed: - ----- Method: Process>>terminate (in category 'changing process state') ----- - terminate - "Stop the process that the receiver represents forever. - Unwind to execute pending #ensure:/#ifCurtailed: blocks before terminating; - allow all unwind blocks to run; if they are currently in progress, let them finish." - - "This is the kind of behavior we expect when terminating a healthy process. - See further comments in #terminateAggressively and #destroy methods dealing - with process termination when closing the debugger or after a catastrophic failure. - - If terminating the active process, create a new stack and run unwinds from there. - - If terminating a suspended process (including runnable and blocked), always - suspend the terminating process first so it doesn't accidentally get woken up. - Equally important is the side effect of the suspension: In 2022 a new suspend - semantics has been introduced: the revised #suspend backs up a process waiting - on a conditional variable to the send that invoked the wait state, while the previous - #suspend simply removed the process from the conditional variable's list it was - previously waiting on; see #suspend and #suspendAndUnblock comments. - - If the process is in the middle of a #critical: critical section, release it properly. - - To allow a suspended process to unwind itself, create a new stack for the process - being terminated and resume the suspended process to complete its termination - from the new parallel stack. Use a semaphore to make the process that invoked - the termination wait for self's completion. Execute the termination in the ensure - argument block to ensure it completes even if the terminator process itself gets - terminated before it's finished; see testTerminateInTerminate and others." - - | context | - self isActiveProcess ifTrue: [ - context := thisContext. - ^[[] ensure: [context unwindTo: nil]. self suspend] asContext jump]. - - [] ensure: [ | terminator | - self suspendAndReleaseCriticalSection. - context := suspendedContext ifNil: [^self]. - terminator := Semaphore new. - context bottomContext insertSender: (Context contextEnsure: [terminator signal]). - self suspendedContext: [[] ensure: [context unwindTo: nil]. self suspend] asContext; - priority: Processor activePriority; - resume. - terminator wait]! Item was removed: - ----- Method: Process>>terminateAggressively (in category 'changing process state') ----- - terminateAggressively - "Stop the receiver forever. - Run all unwind contexts (#ensure:/#ifCurtailed: blocks) on the stack that have not yet been started. If the process is in the middle of an unwind block, then that unwind block will not be completed, but subsequent unwind blocks will be run. If even those unwind contexts should be continued, send #terminate instead. - Note that ill unwind contexts are theoretically able to stall the termination (for instance, by placing a non-local return in an unwind block); however, this is a disrecommended practice. - If the process is in the middle of a critical: critical section, release it properly." - - | oldList bottom tombstone | - self isActiveProcess ifTrue: [ - "If terminating the active process, suspend it first and terminate it as a suspended process." - [self terminate] fork. - ^self suspend]. - - "Always suspend the process first so it doesn't accidentally get woken up. - N.B.: If oldList is a LinkedList then the process is runnable. If it is a Semaphore/Mutex et al., then the process is blocked." - oldList := self suspend. - suspendedContext ifNil: [^ self "Process is already terminated"]. - - "Release any method marked with the <criticalSection> pragma. The argument is whether the process is runnable." - self releaseCriticalSection: (oldList isNil or: [oldList class == LinkedList]). - - bottom := suspendedContext bottomContext. - tombstone := bottom insertSender: [self suspend "terminated"] asContext. - suspendedContext := self - activateReturn: bottom - value: nil. - self complete: tombstone ifError: [:ex | - suspendedContext privRefresh. "Restart the handler context of UnhandledError so that when the receiver is resumed, its #defaultAction will be reached. See implementation details in #runUntilErrorOrReturnFrom:." - "We're not yet done, resume the receiver to spawn a new debugger on the error." - self resume].! Item was removed: - ProcessSpecificVariable subclass: #ProcessLocalVariable - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Kernel-Processes-Variables'! - - !ProcessLocalVariable commentStamp: 'mvl 3/13/2007 12:28' prior: 0! - My subclasses have values specific to the active process. They can be read with #value and set with #value:! Item was removed: - ----- Method: ProcessLocalVariable class>>value: (in category 'accessing') ----- - value: anObject - - ^Processor activeProcess environmentAt: self put: anObject! Item was removed: - Object subclass: #ProcessSpecificVariable - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Kernel-Processes-Variables'! - ProcessSpecificVariable class - instanceVariableNames: 'hash'! - - !ProcessSpecificVariable commentStamp: 'mvl 3/13/2007 13:53' prior: 0! - My subclasses (not instances of them) keep state specific to the current process. - - There are two kinds of process-specific variables: process-local (state available - for read and write in all methods inside the process), and dynamic variables - (implementing dynamic scope).! - ProcessSpecificVariable class - instanceVariableNames: 'hash'! Item was removed: - ----- Method: ProcessSpecificVariable class>>default (in category 'accessing') ----- - default - "Answer the default value for the variable. The default for the default value is nil." - ^nil! Item was removed: - ----- Method: ProcessSpecificVariable class>>hash (in category 'accessing') ----- - hash - - ^hash ifNil: [ hash := super hash ]! Item was removed: - ----- Method: ProcessSpecificVariable class>>value (in category 'accessing') ----- - value - "Answer the current value for this variable in the current context." - ^Processor activeProcess environmentAt: self ifAbsent: [self default].! Item was removed: - Object subclass: #ProcessorScheduler - instanceVariableNames: 'quiescentProcessLists genuineProcess' - classVariableNames: 'BackgroundProcess HighIOPriority LowIOPriority SystemBackgroundPriority SystemRockBottomPriority TimingPriority UserBackgroundPriority UserInterruptPriority UserSchedulingPriority' - poolDictionaries: '' - category: 'Kernel-Processes'! - - !ProcessorScheduler commentStamp: '<historical>' prior: 0! - My single instance, named Processor, coordinates the use of the physical processor by all Processes requiring service.! Item was removed: - ----- Method: ProcessorScheduler class>>idleProcess (in category 'background process') ----- - idleProcess - "A default background process which is invisible." - - [self relinquishProcessorForMicroseconds: 1000] repeat! Item was removed: - ----- Method: ProcessorScheduler class>>initialize (in category 'class initialization') ----- - initialize - - SystemRockBottomPriority := 10. - SystemBackgroundPriority := 20. - UserBackgroundPriority := 30. - UserSchedulingPriority := 40. - UserInterruptPriority := 50. - LowIOPriority := 60. - HighIOPriority := 70. - TimingPriority := 80. - - "ProcessorScheduler initialize."! Item was removed: - ----- Method: ProcessorScheduler class>>installIdleProcess (in category 'background process') ----- - installIdleProcess - "Install a background process of the lowest possible priority that is always runnable." - "Details: The virtual machine requires that there is aways some runnable process that - can be scheduled; this background process ensures that this is the case." - - BackgroundProcess ifNotNil: [BackgroundProcess terminate]. - BackgroundProcess := [self idleProcess] newProcess. - BackgroundProcess priority: SystemRockBottomPriority. - BackgroundProcess resume.! Item was removed: - ----- Method: ProcessorScheduler class>>new (in category 'instance creation') ----- - new - "New instances of ProcessorScheduler should not be created." - - self error: - 'New ProcessSchedulers should not be created since - the integrity of the system depends on a unique scheduler'! Item was removed: - ----- Method: ProcessorScheduler class>>relinquishProcessorForMicroseconds: (in category 'background process') ----- - relinquishProcessorForMicroseconds: anInteger - "Platform specific. This primitive is used to return processor cycles to the host operating system when Squeak's idle process is running (i.e., when no other Squeak process is runnable). On some platforms, this primitive causes the entire Squeak application to sleep for approximately the given number of microseconds. No Squeak process can run while the Squeak application is sleeping, even if some external event makes it runnable. On the Macintosh, this primitive simply calls GetNextEvent() to give other applications a chance to run. On platforms without a host operating system, it does nothing. This primitive should not be used to add pauses to a Squeak process; use a Delay instead." - - <primitive: 230> - "don't fail if primitive is not implemented, just do nothing" - ! Item was removed: - ----- Method: ProcessorScheduler class>>startUp: (in category 'background process') ----- - startUp: resuming - - Smalltalk processPreemptionYields ifTrue: [ - Smalltalk processPreemptionYields: false]. - - resuming ifTrue: [ - Smalltalk installLowSpaceWatcher. - self installIdleProcess].! Item was removed: - ----- Method: ProcessorScheduler>>activePriority (in category 'accessing') ----- - activePriority - "Answer the priority level of the currently running Process." - - ^ self activeProcess priority! Item was removed: - ----- Method: ProcessorScheduler>>activeProcess (in category 'accessing') ----- - activeProcess - "Answer the active process (from the user's perspective), which can be simulated by the genuinely running process (from the system's perspective). See Process >> #evaluate:onBehalfOf:." - - ^genuineProcess effectiveProcess! Item was removed: - ----- Method: ProcessorScheduler>>anyProcessesAbove: (in category 'private') ----- - anyProcessesAbove: highestPriority - "Do any (sub) instances of Process exist with higher priorities?" - - ^(Process allSubInstances anySatisfy: [:aProcess | - aProcess priority > highestPriority])! Item was removed: - ----- Method: ProcessorScheduler>>backgroundProcess (in category 'accessing') ----- - backgroundProcess - "Answer the background process" - ^ BackgroundProcess! Item was removed: - ----- Method: ProcessorScheduler>>highIOPriority (in category 'priority names') ----- - highIOPriority - "Answer the priority at which the most time critical input/output - processes should run. An example is the process handling input from a - network." - - ^HighIOPriority! Item was removed: - ----- Method: ProcessorScheduler>>highestPriority (in category 'accessing') ----- - highestPriority - "Answer the number of priority levels currently available for use." - - ^quiescentProcessLists size! Item was removed: - ----- Method: ProcessorScheduler>>highestPriority: (in category 'accessing') ----- - highestPriority: newHighestPriority - "Change the number of priority levels currently available for use." - - | newProcessLists | - (quiescentProcessLists size > newHighestPriority - and: [self anyProcessesAbove: newHighestPriority]) - ifTrue: [self error: 'There are processes with priority higher than ' - ,newHighestPriority printString]. - newProcessLists := Array new: newHighestPriority. - 1 to: (quiescentProcessLists size min: newProcessLists size) do: - [:priority | newProcessLists at: priority put: (quiescentProcessLists at: priority)]. - quiescentProcessLists size + 1 to: newProcessLists size do: - [:priority | newProcessLists at: priority put: LinkedList new]. - quiescentProcessLists := newProcessLists! Item was removed: - ----- Method: ProcessorScheduler>>lowIOPriority (in category 'priority names') ----- - lowIOPriority - "Answer the priority at which most input/output processes should run. - Examples are the process handling input from the user (keyboard, - pointing device, etc.) and the process distributing input from a network." - - ^LowIOPriority! Item was removed: - ----- Method: ProcessorScheduler>>lowestPriority (in category 'priority names') ----- - lowestPriority - "Return the lowest priority that is allowed with the scheduler" - ^SystemRockBottomPriority! Item was removed: - ----- Method: ProcessorScheduler>>nextReadyProcess (in category 'CPU usage tally') ----- - nextReadyProcess - quiescentProcessLists reverseDo: [ :list | - list isEmpty ifFalse: [ | proc | - proc := list first. - proc suspendedContext ifNotNil: [ ^proc ]]]. - ^nil! Item was removed: - ----- Method: ProcessorScheduler>>objectForDataStream: (in category 'objects from disk') ----- - objectForDataStream: refStrm - | dp | - "I am about to be written on an object file. Write a path to me in the other system instead." - - dp := DiskProxy global: #Processor selector: #yourself args: #(). - refStrm replace: self with: dp. - ^ dp - ! Item was removed: - ----- Method: ProcessorScheduler>>preemptedProcess (in category 'accessing') ----- - preemptedProcess - "Return the process that the currently active process just preempted." - - self activeProcess priority to: 1 by: -1 do: [:priority | - (quiescentProcessLists at: priority) ifNotEmpty: [:list | - ^ Smalltalk processPreemptionYields - ifTrue: [list last] - ifFalse: [list first]]]. - ^ nil - - "Processor preemptedProcess"! Item was removed: - ----- Method: ProcessorScheduler>>remove:ifAbsent: (in category 'removing') ----- - remove: aProcess ifAbsent: aBlock - "Remove aProcess from the list on which it is waiting for the processor - and answer aProcess. If it is not waiting, evaluate aBlock." - - (quiescentProcessLists at: aProcess priority) - remove: aProcess ifAbsent: aBlock. - ^aProcess! Item was removed: - ----- Method: ProcessorScheduler>>suspendFirstAt: (in category 'process state change') ----- - suspendFirstAt: aPriority - "Suspend the first Process that is waiting to run with priority aPriority." - - ^self suspendFirstAt: aPriority - ifNone: [self error: 'No Process to suspend']! Item was removed: - ----- Method: ProcessorScheduler>>suspendFirstAt:ifNone: (in category 'process state change') ----- - suspendFirstAt: aPriority ifNone: noneBlock - "Suspend the first Process that is waiting to run with priority aPriority. If - no Process is waiting, evaluate the argument, noneBlock." - - | aList | - aList := quiescentProcessLists at: aPriority. - aList isEmpty - ifTrue: [^noneBlock value] - ifFalse: [^aList first suspend]! Item was removed: - ----- Method: ProcessorScheduler>>systemBackgroundPriority (in category 'priority names') ----- - systemBackgroundPriority - "Answer the priority at which system background processes should run. - Examples are an incremental garbage collector or status checker." - - ^SystemBackgroundPriority! Item was removed: - ----- Method: ProcessorScheduler>>tallyCPUUsageFor: (in category 'CPU usage tally') ----- - tallyCPUUsageFor: seconds - "Start a high-priority process that will tally the next ready process for the given - number of seconds. Answer a Block that will return the tally (a Bag) after the task - is complete" - ^self tallyCPUUsageFor: seconds every: 10 - ! Item was removed: - ----- Method: ProcessorScheduler>>tallyCPUUsageFor:every: (in category 'CPU usage tally') ----- - tallyCPUUsageFor: seconds every: msec - "Start a high-priority process that will tally the next ready process for the given - number of seconds. Answer a Block that will return the tally (a Bag) after the task - is complete" - | tally sem delay endDelay | - tally := IdentityBag new: 200. - delay := Delay forMilliseconds: msec truncated. - endDelay := Delay forSeconds: seconds. - endDelay schedule. - sem := Semaphore new. - [ - [ endDelay isExpired ] whileFalse: [ - delay wait. - tally add: Processor nextReadyProcess - ]. - sem signal. - ] forkAt: self highestPriority. - - ^[ sem wait. tally ]! Item was removed: - ----- Method: ProcessorScheduler>>terminateActive (in category 'process state change') ----- - terminateActive - "Terminate the process that is currently running." - - self activeProcess terminate.! Item was removed: - ----- Method: ProcessorScheduler>>timingPriority (in category 'priority names') ----- - timingPriority - "Answer the priority at which the system processes keeping track of real - time should run." - - ^TimingPriority! Item was removed: - ----- Method: ProcessorScheduler>>userBackgroundPriority (in category 'priority names') ----- - userBackgroundPriority - "Answer the priority at which user background processes should run." - - ^UserBackgroundPriority! Item was removed: - ----- Method: ProcessorScheduler>>userInterruptPriority (in category 'priority names') ----- - userInterruptPriority - "Answer the priority at which user processes desiring immediate service - should run. Processes run at this level will preempt the window - scheduler and should, therefore, not consume the processor forever." - - ^UserInterruptPriority! Item was removed: - ----- Method: ProcessorScheduler>>userSchedulingPriority (in category 'priority names') ----- - userSchedulingPriority - "Answer the priority at which the window scheduler should run." - - ^UserSchedulingPriority! Item was removed: - ----- Method: ProcessorScheduler>>waitingProcessesAt: (in category 'accessing') ----- - waitingProcessesAt: aPriority - "Return the list of processes at the given priority level." - ^quiescentProcessLists at: aPriority! Item was removed: - ----- Method: ProcessorScheduler>>yield (in category 'process state change') ----- - yield - "Give other Processes at the current priority a chance to run." - - | semaphore | - - <primitive: 167> - semaphore := Semaphore new. - [semaphore signal] fork. - semaphore wait! Item was removed: - Object subclass: #Promise - instanceVariableNames: 'value resolvers mutex state error rejecters' - classVariableNames: '' - poolDictionaries: '' - category: 'Kernel-Processes'! - - !Promise commentStamp: 'tonyg 1/31/2018 23:34' prior: 0! - I represent the result of an asynchronous message. Once the message is processed, I will be resolved to a value. I am typically instantiated by invocations of #futureSend:at:args: (and not by #futureDo:atArgs:). - - See class-comment of FutureNode. - - I also implement the Promises/A+ Javascript specification. This allows you to chain my instances to perform arbitrarily complex asynchronous tasks with error handling baked in. - - A Promise may be in one of three possible states: #pending, #fulfilled or #rejected. A Promise may move from #pending -> #fulfilled (by way of the resolveWith: message), or from #pending -> #rejected (by way of rejectWith:). No other state changes may occur. - - Once #fulfilled or #rejected, a Promise's value must not change. In keeping with the major Javascript Promise implementations' interpretations of this, calls to resolveWith: or rejectWith: when a Promise is in #fulfilled or #rejected state are simply ignored - an error is not signalled. (See test cases PromiseTest testFirstResolutionWins, testCannotRejectFulfilledPromise and testCannotResolveaRejectedPromise.)! Item was removed: - ----- Method: Promise class>>ifRejected: (in category 'instance creation') ----- - ifRejected: aBlock - ^ self basicNew initializeWithIfRejected: aBlock.! Item was removed: - ----- Method: Promise class>>unit: (in category 'instance creation') ----- - unit: anObject - "Return a resolved Promise. #new is the other half of Promise's unit function; #new returns an unresolved Promise." - ^ self basicNew initializeWithResolvedValue: anObject.! Item was removed: - ----- Method: Promise>>>> (in category 'monad') ----- - >> resolvedBlock - "Like >>=, but discards the result of the promise." - ^ self then: [:v | resolvedBlock value]! Item was removed: - ----- Method: Promise>>>>= (in category 'monad') ----- - >>= resolvedBlock - "Alias for `then:` allowing convenient chaining." - ^ self then: resolvedBlock! Item was removed: - ----- Method: Promise>>error (in category 'accessing') ----- - error - ^ error.! Item was removed: - ----- Method: Promise>>evaluateRejecter: (in category 'private') ----- - evaluateRejecter: rejecterBlock - ^ rejecterBlock cull: error.! Item was removed: - ----- Method: Promise>>evaluateResolver: (in category 'private') ----- - evaluateResolver: resolverBlock - ^ resolverBlock cull: value.! Item was removed: - ----- Method: Promise>>fulfillWith: (in category 'resolving') ----- - fulfillWith: aBlock - self fulfillWith: aBlock passErrors: rejecters isEmpty! Item was removed: - ----- Method: Promise>>fulfillWith:passErrors: (in category 'resolving') ----- - fulfillWith: aBlock passErrors: aBoolean - "Evaluate aBlock. If it signals an exception, reject this promise with the exception - as the argument; if it returns a value [or another Promise], resolve this promise - with the result. - - If aBoolean is true, and an exception is signaled, it is passed out to the caller. - If aBoolean is false, signaled exceptions are considered handled after the promise - has been rejected." - [ self resolveWith: aBlock value ] - on: Exception - do: [ :ex | - (ex isKindOf: Halt) - ifTrue: [ex pass] - ifFalse: [ - self rejectWith: ex. - aBoolean ifTrue: [ ex pass ] ]]! Item was removed: - ----- Method: Promise>>ifRejected: (in category 'monad') ----- - ifRejected: errBlock - ^ self then: nil ifRejected: errBlock! Item was removed: - ----- Method: Promise>>initialize (in category 'initialize') ----- - initialize - state := #pending. - resolvers := #(). - rejecters := #(). - mutex := Mutex new.! Item was removed: - ----- Method: Promise>>initializeWithIfRejected: (in category 'initialize') ----- - initializeWithIfRejected: aBlock - self initialize. - rejecters := {aBlock}.! Item was removed: - ----- Method: Promise>>initializeWithResolvedValue: (in category 'initialize') ----- - initializeWithResolvedValue: anObject - self initialize. - self resolveWith: anObject.! Item was removed: - ----- Method: Promise>>isPromise (in category 'testing') ----- - isPromise - ^ true! Item was removed: - ----- Method: Promise>>isRejected (in category 'testing') ----- - isRejected - ^ state == #rejected.! Item was removed: - ----- Method: Promise>>isResolved (in category 'testing') ----- - isResolved - ^ state == #fulfilled.! Item was removed: - ----- Method: Promise>>printOn: (in category 'printing') ----- - printOn: aStream - aStream nextPutAll: 'a Promise'. - self isResolved ifTrue: [ - aStream - nextPutAll: '(resolved: '; - nextPutAll: value printString; - nextPutAll: ')']. - self isRejected ifTrue: [ - aStream - nextPutAll: '(rejected: '; - nextPutAll: error printString; - nextPutAll: ')'].! Item was removed: - ----- Method: Promise>>reject (in category 'resolving') ----- - reject - - self rejectWith: nil! Item was removed: - ----- Method: Promise>>rejectWith: (in category 'resolving') ----- - rejectWith: anObject - "Reject this promise." - mutex critical: [ - (state == #pending) ifTrue: [ | worklist | - error := anObject. - state := #rejected. - worklist := rejecters. - resolvers := #(). - rejecters := #(). - worklist do: [:r | self evaluateRejecter: r]]]! Item was removed: - ----- Method: Promise>>resolve (in category 'resolving') ----- - resolve - - self resolveWith: nil! Item was removed: - ----- Method: Promise>>resolveWith: (in category 'resolving') ----- - resolveWith: arg - "Resolve this promise. If arg is itself a Promise, make this promise depend upon it, - as detailed in the Promises/A+ spec: - https://promisesaplus.com/#the-promise-resolution-procedure" - - arg isPromise - ifTrue: [ - arg whenResolved: [:v | self resolveWith: v]. - arg whenRejected: [:e | self rejectWith: e]] - ifFalse: [ - mutex critical: [ - (state == #pending) ifTrue: [ | worklist | - value := arg. - state := #fulfilled. - worklist := resolvers. - resolvers := #(). - rejecters := #(). - worklist do: [:r | self evaluateResolver: r]]]]! Item was removed: - ----- Method: Promise>>then: (in category 'monad') ----- - then: resolvedBlock - ^ self then: resolvedBlock ifRejected: nil! Item was removed: - ----- Method: Promise>>then:ifRejected: (in category 'monad') ----- - then: resolvedBlock ifRejected: errBlock - "Return a Promise that, if it resolves, runs the resolvedBlock. If resolution throws an Exception, it runs the errBlock." - | p | - p := self species new. - resolvedBlock - ifNil: [self whenResolved: [:v | p resolveWith: v]] - ifNotNil: [ - self whenResolved: [:v | - [p resolveWith: (resolvedBlock value: v)] - on: Error do: [:e | p rejectWith: e]]]. - errBlock - ifNil: [self whenRejected: [:e | p rejectWith: e]] - ifNotNil: [ - self whenRejected: [:e | - [p resolveWith: (errBlock value: e)] - on: Error do: [:e2 | p rejectWith: e2]]]. - ^ p.! Item was removed: - ----- Method: Promise>>value (in category 'accessing') ----- - value - ^value! Item was removed: - ----- Method: Promise>>wait (in category 'waiting') ----- - wait - "Wait unconditionally for this promise to become fulfilled or rejected." - | sema | - sema := Semaphore new. - self whenResolved:[sema signal]. - self whenRejected:[sema signal]. - sema wait. - ^ self isResolved - ifTrue: [ value ] - ifFalse: [ BrokenPromise new promise: self; signal ]! Item was removed: - ----- Method: Promise>>waitTimeoutMSecs: (in category 'waiting') ----- - waitTimeoutMSecs: msecs - "Wait for at most the given number of milliseconds for this promise to settle. - Answer true if it is resolved, false otherwise. False can therefore mean EITHER 'timeout' OR 'rejected'." - | sema delay | - sema := Semaphore new. - self whenResolved: [sema signal]. - self whenRejected: [sema signal]. - delay := Delay timeoutSemaphore: sema afterMSecs: msecs. - [sema wait] ensure: [delay unschedule]. - ^ self isResolved.! Item was removed: - ----- Method: Promise>>waitTimeoutSeconds: (in category 'waiting') ----- - waitTimeoutSeconds: seconds - "Wait for at most the given number of seconds for this promise to resolve. Answer true if it is resolved, false otherwise." - ^self waitTimeoutMSecs: seconds*1000! Item was removed: - ----- Method: Promise>>whenRejected: (in category 'resolving') ----- - whenRejected: aBlock - "Evaluate aBlock when I am rejected" - aBlock numArgs <= 1 ifFalse: [self error: 'Must be 0- or 1-argument block']. - mutex critical: [ - (state == #pending) - ifTrue: [rejecters := rejecters copyWith: aBlock] - ifFalse: [self isRejected ifTrue: [self evaluateRejecter: aBlock]]]. - ^ nil! Item was removed: - ----- Method: Promise>>whenResolved: (in category 'resolving') ----- - whenResolved: aBlock - "Evaluate aBlock when I am resolved" - aBlock numArgs <= 1 ifFalse:[self error: 'Must be 0- or 1-argument block']. - mutex critical: [ - (state == #pending) - ifTrue: [resolvers := resolvers copyWith: aBlock] - ifFalse: [self isResolved ifTrue: [self evaluateResolver: aBlock]]]. - ^ nil! Item was removed: - nil subclass: #ProtoObject - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Kernel-Objects'! - - !ProtoObject commentStamp: '<historical>' prior: 0! - ProtoObject establishes minimal behavior required of any object in Squeak, even objects that should balk at normal object behavior. Generally these are proxy objects designed to read themselves in from the disk, or to perform some wrapper behavior, before responding to a message. Current examples are ObjectOut and ImageSegmentRootStub, and one could argue that ObjectTracer should also inherit from this class. - - ProtoObject has no instance variables, nor should any be added.! Item was removed: - ----- Method: ProtoObject class>>initializedInstance (in category 'as yet unclassified') ----- - initializedInstance - ^ nil! Item was removed: - ----- Method: ProtoObject>>== (in category 'comparing') ----- - == anObject - "Primitive. Answer whether the receiver and the argument are the same - object (have the same object pointer). Do not redefine the message == in - any other class!! Essential. No Lookup. Do not override in any subclass. - See Object documentation whatIsAPrimitive." - - <primitive: 110> - self primitiveFailed! Item was removed: - ----- Method: ProtoObject>>cannotInterpret: (in category 'system primitives') ----- - cannotInterpret: aMessage - "Handle the fact that there was an attempt to send the given message to the receiver but a null methodDictionary was encountered while looking up the message selector. Hopefully this is the result of encountering a stub for a swapped out class which induces this exception on purpose." - - "If this is the result of encountering a swap-out stub, then simulating the lookup in Smalltalk should suffice to install the class properly, and the message may be resent." - - (self class lookupSelector: aMessage selector) == nil ifFalse: - ["Simulated lookup succeeded -- resend the message." - ^ aMessage sentTo: self]. - - "Could not recover by simulated lookup -- it's an error" - Error signal: 'MethodDictionary fault'. - - "Try again in case an error handler fixed things" - ^ aMessage sentTo: self! Item was removed: - ----- Method: ProtoObject>>doOnlyOnce: (in category 'debugging') ----- - doOnlyOnce: aBlock - "If the 'one-shot' mechanism is armed, evaluate aBlock once and disarm the one-shot mechanism. To rearm the mechanism, evaluate 'self rearmOneShot' manually." - - (Smalltalk at: #OneShotArmed ifAbsent: [true]) - ifTrue: - [Smalltalk at: #OneShotArmed put: false. - aBlock value]! Item was removed: - ----- Method: ProtoObject>>doesNotUnderstand: (in category 'system primitives') ----- - doesNotUnderstand: aMessage - - ^ MessageNotUnderstood new - message: aMessage; - receiver: self; - signal! Item was removed: - ----- Method: ProtoObject>>flag: (in category 'debugging') ----- - flag: aSymbol - "Send this message, with a relevant symbol as argument, to flag a message for subsequent retrieval. For example, you might put the following line in a number of messages: - self flag: #returnHereUrgently - Then, to retrieve all such messages, browse all senders of #returnHereUrgently."! Item was removed: - ----- Method: ProtoObject>>identityHash (in category 'comparing') ----- - identityHash - "Answer a SmallInteger whose value is related to the receiver's identity. - This method must not be overridden, except by immediate values. - Primitive. Fails if the receiver is immediate. Essential. - See Object documentation whatIsAPrimitive. - - Do not override." - - <primitive: 75> - self primitiveFailed! Item was removed: - ----- Method: ProtoObject>>ifNil: (in category 'testing') ----- - ifNil: nilBlock - "Return self, or evaluate the block if I'm == nil (q.v.)" - - ^ self! Item was removed: - ----- Method: ProtoObject>>ifNil:ifNotNil: (in category 'testing') ----- - ifNil: nilBlock ifNotNil: ifNotNilBlock - "Evaluate the block, unless I'm == nil (q.v.)" - - ^ ifNotNilBlock cull: self! Item was removed: - ----- Method: ProtoObject>>ifNotNil: (in category 'testing') ----- - ifNotNil: ifNotNilBlock - "Evaluate the block, unless I'm == nil (q.v.)" - - ^ ifNotNilBlock cull: self! Item was removed: - ----- Method: ProtoObject>>ifNotNil:ifNil: (in category 'testing') ----- - ifNotNil: ifNotNilBlock ifNil: nilBlock - "If I got here, I am not nil, so evaluate the block ifNotNilBlock" - - ^ ifNotNilBlock cull: self! Item was removed: - ----- Method: ProtoObject>>initialize (in category 'initialize-release') ----- - initialize - "Subclasses should redefine this method to perform initializations on instance creation"! Item was removed: - ----- Method: ProtoObject>>instVarsInclude: (in category 'system primitives') ----- - instVarsInclude: anObject - "Answers true if anObject is among my named or indexed instance variables, and false otherwise" - - <primitive: 132> - 1 to: self class instSize do: - [:i | (self instVarAt: i) == anObject ifTrue: [^ true]]. - 1 to: self basicSize do: - [:i | (self basicAt: i) == anObject ifTrue: [^ true]]. - ^ false! Item was removed: - ----- Method: ProtoObject>>isInMemory (in category 'testing') ----- - isInMemory - "All normal objects are." - ^ true! Item was removed: - ----- Method: ProtoObject>>isNil (in category 'testing') ----- - isNil - "Coerces nil to true and everything else to false." - - ^false! Item was removed: - ----- Method: ProtoObject>>nextInstance (in category 'system primitives') ----- - nextInstance - "Primitive. Answer the next instance after the receiver in the - enumeration of all instances of this class. Fails if all instances have been - enumerated. Essential. See Object documentation whatIsAPrimitive." - - <primitive: 78> - ^nil! Item was removed: - ----- Method: ProtoObject>>nextObject (in category 'system primitives') ----- - nextObject - "Primitive. Answer the next object after the receiver in the - enumeration of all objects. Return 0 when all objects have been - enumerated." - - <primitive: 139> - self primitiveFailed.! Item was removed: - ----- Method: ProtoObject>>notNil (in category 'testing') ----- - notNil - "Coerces nil to false and everything else to true." - - ^true! Item was removed: - ----- Method: ProtoObject>>pointsOnlyWeaklyTo: (in category 'tracing') ----- - pointsOnlyWeaklyTo: anObject - "Assume, we already know that receiver points to an object, answer true if receiver points only weakly to it." - - self class isWeak ifFalse: [ ^false ]. - 1 to: self class instSize do: [ :i | - (self instVarAt: i) == anObject ifTrue: [ ^false ] ]. - ^true! Item was removed: - ----- Method: ProtoObject>>pointsTo: (in category 'tracing') ----- - pointsTo: anObject - "Answers true if I hold a reference to anObject, or false otherwise. Or stated another way: - - Answers true if the garbage collector would fail to collect anObject because I hold a reference to it, or false otherwise" - - ^ (self instVarsInclude: anObject) - or: [self class == anObject]! Item was removed: - ----- Method: ProtoObject>>rearmOneShot (in category 'debugging') ----- - rearmOneShot - "Call this manually to arm the one-shot mechanism; use the mechanism in code by calling - self doOnlyOnce: <a block>" - - Smalltalk at: #OneShotArmed put: true - - "self rearmOneShot" - ! Item was removed: - ----- Method: ProtoObject>>rehash (in category 'objects from disk') ----- - rehash - "Do nothing. Here so sending this to a Set does not have to do a time consuming respondsTo:"! Item was removed: - ----- 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" - - ^self identityHash * 256 "bitShift: 8"! Item was removed: - ----- Method: ProtoObject>>tryPrimitive:withArgs: (in category 'apply primitives') ----- - tryPrimitive: primIndex withArgs: argumentArray - "Invoke the primitive with number primIndex, answering its result, - or, if the primiitve fails, the error code." - - <primitive: 118 error: errorCode> - ^Context primitiveFailTokenFor: errorCode! Item was removed: - ----- Method: ProtoObject>>withArgs:executeMethod: (in category 'debugging') ----- - withArgs: argArray executeMethod: compiledMethod - "Execute compiledMethod against the receiver and args in argArray" - - <primitive: 188> - self primitiveFailed! Item was removed: - ----- Method: ProtoObject>>~~ (in category 'comparing') ----- - ~~ anObject - "Answer whether the receiver and the argument are not the same object - (do not have the same object pointer). Primitive. Optional." - <primitive: 169> - self == anObject ifTrue: [^false]. - ^true! Item was removed: - Notification subclass: #ProvideAnswerNotification - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Kernel-Exceptions'! Item was removed: - Object subclass: #Random - instanceVariableNames: 'states index' - classVariableNames: 'MTa MTbShifted MTcShifted MTl MTlowerMask MTm MTn MTs MTt MTu MTupperMask MTw MTwFloatMultiplier MTwordMask' - poolDictionaries: '' - category: 'Kernel-Numbers'! - - !Random commentStamp: 'ul 2/20/2015 09:44' prior: 0! - I implement the 32-bit version of the Mersenne Twister PRNG, using 30-bit arithmetic, based on http://www.math.sci.hiroshima-u.ac.jp/~m-mat/MT/ARTICLES/mt.pdf . The parameters of the generator are stored in class variables prefixed with MT. - - Instance Variables - states: <Array> - index: <Integer> - - index - - the index of the state, which should be used to generate the next random integer value - - states - - an Array holding the internal state of the generator - - --- - - If you just want a quick random integer, use: - 10 atRandom - Every integer interval can give a random number: - (6 to: 12) atRandom - SequenceableCollections can give randomly selected elements: - 'pick one of these letters randomly' atRandom - SequenceableCollections also respond to shuffled, as in: - ($A to: $Z) shuffled - - The correct way to use class Random is to store one in an instance or class variable: - myGenerator := Random new. - Then use it every time you need another number between 0.0 and 1.0 (excluding) - myGenerator next - You can also generate a positive integer - myGenerator nextInt: 10! Item was removed: - ----- Method: Random class>>bucketTest: (in category 'testing') ----- - bucketTest: randy - "Execute this: Random bucketTest: Random new" - " A quick-and-dirty bucket test. Prints nbuckets values on the - Transcript. - Each should be 'near' the value of ntries. Any run with any value - 'far' from ntries - indicates something is very wrong. Each run generates different - values. - For a slightly better test, try values of nbuckets of 200-1000 or - more; go get coffee. - This is a poor test; see Knuth. Some 'OK' runs: - 1000 1023 998 969 997 1018 1030 1019 1054 985 1003 - 1011 987 982 980 982 974 968 1044 976 - 1029 1011 1025 1016 997 1019 991 954 968 999 991 - 978 1035 995 988 1038 1009 988 993 976 - " - | nbuckets buckets ntrys | - nbuckets := 200. - buckets := Array new: nbuckets. - buckets atAllPut: 0. - ntrys := 10000. - ntrys*nbuckets timesRepeat: [ | slot | - slot := randy nextInt: nbuckets. - buckets at: slot put: (buckets at: slot) + 1 ]. - Transcript cr. - 1 to: nbuckets do: [ :nb | - Transcript print: (buckets at: nb); space ]. - Transcript flush! Item was removed: - ----- Method: Random class>>gatherEntropyInto: (in category 'entropy source') ----- - gatherEntropyInto: aByteArray - "Gather good random entropy from a system source and fill up aByteArray with it. Return true upon success, else false." - - <primitive: 'primitiveGatherEntropy' module: 'CroquetPlugin'> - ^false! Item was removed: - ----- Method: Random class>>initialize (in category 'class initialization') ----- - initialize - "30-bit MT521 parameters. generated with a modified version of dcmt with ID=1. http://www.math.sci.hiroshima-u.ac.jp/~m-mat/MT/DC/dc.html" - - "Base parameters" - "MTp := 521. Not used directly." - MTw := 30. - MTm := 9. - MTa := 16r3235DEE2. - "MTb := 16r39BB2B00. Not used directly." - "MTc := 16r3EFD0000. Not used directly." - MTl := -18. - MTu := -12. - MTs := 7. - MTt := 15. - "Calculated parameters" - MTn := 18. - "MTr := 19. Not used directly." - MTupperMask := 16r3FF80000. - MTlowerMask := 16r7FFFF. - MTwordMask := 16r3FFFFFFF. - MTbShifted := 7566934. - MTcShifted := 32250. - MTwFloatMultiplier := 8388608! Item was removed: - ----- Method: Random class>>seed: (in category 'instance creation') ----- - seed: anInteger - - ^self basicNew seed: anInteger! Item was removed: - ----- Method: Random>>check: (in category 'die rolling') ----- - check: nDice - "Roll some dice, WoD-style." - - ^ self check: nDice difficulty: 6! Item was removed: - ----- Method: Random>>check:against: (in category 'die rolling') ----- - check: nAttack against: nDefend - "Roll some dice, WoD-style." - - ^ self check: nAttack against: nDefend difficulty: 6! Item was removed: - ----- Method: Random>>check:against:difficulty: (in category 'die rolling') ----- - check: nAttack against: nDefend difficulty: diff - "Roll some dice, WoD-style." - - | attacks defends | - attacks := self check: nAttack difficulty: diff. - attacks < 0 ifTrue: [^ attacks]. - defends := self check: nDefend difficulty: diff. - ^ attacks - defends min: 0! Item was removed: - ----- Method: Random>>check:difficulty: (in category 'die rolling') ----- - check: nDice difficulty: diff - "Roll some dice, WoD-style." - - | result | - result := 0. - nDice timesRepeat: - [ | die | - (die := self nextInt: 10) = 1 - ifTrue: [result := result - 1] - ifFalse: [die >= diff ifTrue: [result := result + 1]]]. - ^ result! Item was removed: - ----- Method: Random>>diceToken: (in category 'die rolling') ----- - diceToken: stream - "Private. Mini scanner, see #roll:" - - stream atEnd ifTrue: [^ nil]. - stream peek isDigit ifTrue: [^ Integer readFrom: stream]. - ^ stream next asLowercase! Item was removed: - ----- Method: Random>>generateStates (in category 'private') ----- - generateStates - "Generate untempered numbers into the states variable. Split up the operation into three parts to avoid the use of #atWrap: for accessing the states array. Optimized for SmallInteger operations." - - | i limit y offset | - "Part 1" - i := 0. - offset := MTm. - limit := MTn - offset. - [ (i := i + 1) <= limit ] whileTrue: [ - y := (MTupperMask bitAnd: (states at: i)) bitOr: (MTlowerMask bitAnd: (states at: i + 1)). - states - at: i - put: ((y bitAnd: 1) * MTa bitXor: ((states at: i + offset) bitXor: (y bitShift: -1))) ]. - "Part 2" - limit := MTn - 1. - offset := MTm - MTn. - i := i - 1. - [ (i := i + 1) <= limit ] whileTrue: [ - y := (MTupperMask bitAnd: (states at: i)) bitOr: (MTlowerMask bitAnd: (states at: i + 1)). - states - at: i - put: ((y bitAnd: 1) * MTa bitXor: ((states at: i + offset) bitXor: (y bitShift: -1))) ]. - "Part 3" - y := (MTupperMask bitAnd: (states at: MTn)) bitOr: (MTlowerMask bitAnd: (states at: 1)). - states - at: MTn - put: ((y bitAnd: 1) * MTa bitXor: ((states at: MTm) bitXor: (y bitShift: -1))). - index := 1 - ! Item was removed: - ----- Method: Random>>hashSeed: (in category 'private') ----- - hashSeed: anInteger - "Use the 32-bit version of the FNV-1a algorithm to hash the seed, and return a 32-bit unsigned integer." - - | fnvPrime hash | - fnvPrime := 16777619 " 32-bit FVN prime ". - hash := anInteger negative - ifTrue: [ 3490449840 " mix in the sign as (2166136261 bitXor: 2r1010101) * 16777619 bitAnd: 16rFFFFFFFF "] - ifFalse: [ 2166136261 " 32-bit FVN offset basis "]. - 1 to: anInteger digitLength do: [ :index | - hash := 16rFFFFFFFF bitAnd: (hash bitXor: (anInteger digitAt: index)) * fnvPrime ]. - ^hash! Item was removed: - ----- Method: Random>>initialize (in category 'initialization') ----- - initialize - - self seed: nil! Item was removed: - ----- Method: Random>>initializeStatesWith: (in category 'private') ----- - initializeStatesWith: anInteger - "Initialize the states array with the seed." - - | seed | - states := Array new: MTn. - seed := anInteger. - 1 to: MTn do: [ :i | - states at: i put: (MTwordMask bitAnd: seed). - seed := 16rFFFFFFFF bitAnd: (16r6C078965 * (seed bitXor: seed // 16r40000000 "bitShift: -30") + i) ]! Item was removed: - ----- Method: Random>>next (in category 'accessing') ----- - next - "Answer a random 53-bit Float from the [0, 1) interval. The implementation assumes that the MTw parameter is between 27 and 53." - - ^self nextValue asFloat * MTwFloatMultiplier + (self nextValue bitAnd: MTwFloatMultiplier - 1) / 9.007199254740992e15 "(1 << 53) asFloat"! Item was removed: - ----- Method: Random>>next: (in category 'accessing') ----- - next: anInteger - ^ self next: anInteger into: (Array new: anInteger)! Item was removed: - ----- Method: Random>>next:into: (in category 'accessing') ----- - next: anInteger into: anArray - 1 to: anInteger do: [:index | anArray at: index put: self next]. - ^ anArray! Item was removed: - ----- Method: Random>>nextBytes:into:startingAt: (in category 'accessing') ----- - nextBytes: anInteger into: aBytesObject startingAt: startIndex - "Fill aBytesObject, an object with indexable byte fields, with anInteger number of random bytes starting from startIndex. Assume that MTw is at least 8." - - | randomValue remainingBits index endIndex | - randomValue := remainingBits := 0. - index := startIndex. - endIndex := startIndex + anInteger - 1. - [ index <= endIndex ] whileTrue: [ - remainingBits >= 8 - ifTrue: [ - aBytesObject basicAt: index put: (randomValue bitAnd: 16rFF). - randomValue := randomValue bitShift: -8. - remainingBits := remainingBits - 8. - index := index + 1 ] - ifFalse: [ - remainingBits = 0 - ifTrue: [ randomValue := self nextValue ] - ifFalse: [ - | newRandomValue | - newRandomValue := self nextValue. - aBytesObject basicAt: index put: (randomValue bitShift: 8 - remainingBits) + - (newRandomValue bitAnd: (1 bitShift: 8 - remainingBits) - 1). - randomValue := newRandomValue bitShift: 0 - remainingBits. - index := index + 1 ]. - remainingBits := MTw - remainingBits ] ]! Item was removed: - ----- Method: Random>>nextInt: (in category 'accessing') ----- - nextInt: anInteger - "Answer a random integer value from the interval [1, anInteger]" - - | bucketSize retriesLeft | - anInteger strictlyPositive ifFalse: [ self error: 'Range must be positive' ]. - (anInteger isLarge - or: [ anInteger > MTwordMask "In case SmallIntegers have more than MTw-bits, but the generator hasn't been updated accordingly." ]) - ifTrue: [ ^self nextLargeInt: anInteger ]. - "Split the MTw-bit(currently 30-bit) integer range up to the equal sized buckets. Generate an MTw-bit random number, and see which bucket it's in. If it doesn't fit in any bucket, then try again." - bucketSize := MTwordMask // anInteger. "The optimal bucket size would be MTwordMask + 1 // anInteger, but calculating it would involve LargeInteger arithmetic. The MTwordMask // anInteger expression is suboptimal only when anInteger is a power of two. These cases are rare, and the effect is negligible for small values. We could handle these cases separately, but testing if anInteger is a power of two costs more in general." - retriesLeft := 10. "Based on measurements with various seeds, 10 retries is about optimal for the worst case, when anInteger = MTwordMask // 2 + 1." - [ (retriesLeft := retriesLeft - 1) >= 0 ] whileTrue: [ - | bucket | - bucket := self nextValue // bucketSize. - bucket < anInteger ifTrue: [ ^bucket + 1 ] ]. - "Fall back to the floating point method, which is slower, but when we get here, then we've already spent enough resources on trying to generate the number. Using this fallback also ensures that the method doesn't run for indefinitely long." - ^(self next * anInteger) truncated + 1! Item was removed: - ----- Method: Random>>nextLargeInt: (in category 'accessing') ----- - nextLargeInt: anInteger - "Answer a random integer value from the interval [1, anInteger]. This method works for arbitrarily large integers." - - | byteCount bigRandom result firstDigit | - byteCount := anInteger digitLength + 4. "Extend the space with at least 32 bits for a fairer distribution." - bigRandom := LargePositiveInteger new: byteCount. - self nextBytes: byteCount into: bigRandom startingAt: 1. - bigRandom := bigRandom normalize. "Make sure that there are no leading zero bytes." - result := anInteger * bigRandom bitShift: -8 * byteCount. - "Avoid using LargeInteger arithmetic for +1 in most cases." - result isLarge ifFalse: [ ^result + 1 ]. - (firstDigit := result digitAt: 1) = 255 ifTrue: [ ^result + 1 ]. - result digitAt: 1 put: firstDigit + 1. - ^result - ! Item was removed: - ----- Method: Random>>nextValue (in category 'private') ----- - nextValue - "Answer an MTw-bit random integer between 0 and wordMask, and increment the index." - - | y | - y := states at: index. - (index := index + 1) > MTn ifTrue: [ self generateStates ]. - y := y bitXor: (y bitShift: MTu). - y := ((y bitAnd: MTbShifted) bitShift: MTs) bitXor: y. - y := ((y bitAnd: MTcShifted) bitShift: MTt) bitXor: y. - y := (y bitShift: MTl) bitXor: y. - ^y! Item was removed: - ----- Method: Random>>roll: (in category 'die rolling') ----- - roll: diceString - "Roll some dice, DnD-style, according to this mini-grammar: - dice := epxr {pm dice} - pm := '+' | '-' - expr := num | num dD | dD numP | num dD numP - dD := 'd' | 'D' - num := digit+ - numP := num | '%'" - - | stream op result | - stream := diceString readStream. - result := 0. - op := #+. - [ | res range dice token | - token := self diceToken: stream. - token isNumber - ifTrue: [dice := token. - res := token. - token := self diceToken: stream] - ifFalse: [token == $d - ifTrue: [dice := 1] - ifFalse: [self error: 'unknown token' , token]]. - token == $d - ifTrue: [token := self diceToken: stream. - token isNumber - ifTrue: [range := token. - token := self diceToken: stream] - ifFalse: [token == $% - ifTrue: [range := 100. - token := self diceToken: stream] - ifFalse: [range := 6]]. - res := 0. - dice timesRepeat: [res := res + (self nextInt: range)]]. - result := result perform: op with: res. - token ifNil: [^ result]. - (token == $+ or: [token == $-]) - ifFalse: [self error: 'unknown token ' , token]. - op := token asSymbol] repeat! Item was removed: - ----- Method: Random>>seed: (in category 'initialization') ----- - seed: anIntegerOrNil - "Use the given integer as the seed, or generate one if it's nil." - - (anIntegerOrNil isNil and: [ self seedWithRandomBytes ]) ifFalse: [ - | newSeed | - newSeed := anIntegerOrNil ifNil: [ - (Time utcMicrosecondClock bitShift: 28) bitXor: self hash hashMultiply ]. - (newSeed between: 0 and: 16rFFFFFFFF) ifFalse: [ - newSeed := self hashSeed: newSeed ]. - self initializeStatesWith: newSeed ]. - self generateStates! Item was removed: - ----- Method: Random>>seedWithRandomBytes (in category 'private') ----- - seedWithRandomBytes - "Initialize the states array with random bytes from the VM. Return true on success, false on failure." - - | randomBytes | - randomBytes := ByteArray new: MTn * 4. - (self class gatherEntropyInto: randomBytes) ifFalse: [ - "Primitive not available" - ^false ]. - states := Array new: MTn. - 1 to: MTn do: [ :i | - states at: i put: ( - "The below code assumes that MTwordMask is 1 << 30 - 1. It avoids LargeInteger operations on 32-bit platforms. It's equivalent to: - (randomBytes unsignedLongAt: 1 bigEndian: true) bitAnd: MTwordMask" - ((randomBytes at: i * 4 - 3) bitAnd: 16r3F) * 256 + - (randomBytes at: i * 4 - 2) * 256 + - (randomBytes at: i * 4 - 1) * 256 + - (randomBytes at: i * 4)) ]. - ^true! Item was removed: - InstructionPrinter subclass: #RelativeInstructionPrinter - instanceVariableNames: 'printCode labels labelling' - classVariableNames: '' - poolDictionaries: '' - category: 'Kernel-Methods'! Item was removed: - ----- Method: RelativeInstructionPrinter>>jump: (in category 'instruction decoding') ----- - jump: offset - "Print the Unconditional Jump bytecode." - - labelling - ifTrue: - [labels at: scanner pc + offset + 1 put: true. - self print: 'jumpBy: ', offset printString, - ' to: ', (scanner pc + offset - method initialPC) printString] - ifFalse: - [self print: 'jumpTo: ', (labels at: scanner pc + offset + 1)]! Item was removed: - ----- Method: RelativeInstructionPrinter>>jump:if: (in category 'instruction decoding') ----- - jump: offset if: condition - "Print the Conditional Jump bytecode." - - labelling - ifTrue: - [labels at: scanner pc + offset + 1 put: true. - self print: - (condition ifTrue: ['jumpTrueBy: '] ifFalse: ['jumpFalseBy: ']), offset printString, - ' to: ', (labelling - ifTrue: [(scanner pc + offset - method initialPC) printString] - ifFalse: [labels at: scanner pc + offset])] - ifFalse: - [self print: - (condition ifTrue: ['jumpTrueTo: '] ifFalse: ['jumpFalseTo: ']), (labels at: scanner pc + offset + 1)]! Item was removed: - ----- Method: RelativeInstructionPrinter>>print: (in category 'printing') ----- - print: instruction - "Append to the receiver a description of the bytecode, instruction." - - stream tab: self indent. - labelling - ifTrue: [stream print: oldPC - method initialPC; space] - ifFalse: [stream tab]. - stream tab: (innerIndents at: oldPC). - self printCode ifTrue: - [stream nextPut: $<. - oldPC to: scanner pc - 1 do: - [:i | | code | - code := (method at: i) radix: 16. - stream - nextPut: (code size < 2 ifTrue: [$0] ifFalse: [code at: 1]); - nextPut: code last; - space]. - stream skip: -1; nextPut: $>; space]. - stream nextPutAll: instruction. - stream cr. - labelling ifFalse: - [(labels at: scanner pc + 1) ~~ false ifTrue: - [stream nextPutAll: (labels at: scanner pc + 1); nextPut: $:; cr]]. - oldPC := scanner pc! Item was removed: - ----- Method: RelativeInstructionPrinter>>printCode (in category 'printing') ----- - printCode - ^printCode ~~ false! Item was removed: - ----- Method: RelativeInstructionPrinter>>printCode: (in category 'initialize-release') ----- - printCode: aBoolean - printCode := aBoolean! Item was removed: - ----- Method: RelativeInstructionPrinter>>printInstructionsOn: (in category 'printing') ----- - printInstructionsOn: aStream - "Append to the stream, aStream, a description of each bytecode in the instruction stream." - - | label | - labelling := true. - labels := Array new: method size + 1 withAll: false. - super printInstructionsOn: (String new: 1024) writeStream. - label := 0. - labels withIndexDo: - [:bool :index| - bool ifTrue: [labels at: index put: 'L', (label := label + 1) printString]]. - labelling := false. - super printInstructionsOn: aStream! Item was removed: - ----- Method: RelativeInstructionPrinter>>printInstructionsOn:do: (in category 'printing') ----- - printInstructionsOn: aStream do: aBlock - "Append to the stream, aStream, a description of each bytecode in the instruction stream. - Evaluate aBlock with the receiver, the scanner and the stream after each instruction." - - | label | - labelling := true. - labels := Array new: method size withAll: false. - super printInstructionsOn: (String new: 1024) writeStream do: [:ig :no :re|]. - label := 0. - labels withIndexDo: - [:bool :index| - bool ifTrue: [labels at: index put: 'L', (label := label + 1) printString]]. - labelling := false. - super printInstructionsOn: aStream do: aBlock! Item was removed: - Notification subclass: #RemarkNotification - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Kernel-Exceptions'! Item was removed: - ----- Method: RemarkNotification>>defaultAction (in category 'priv handling') ----- - defaultAction - - Transcript showln: self messageText.! Item was removed: - Number subclass: #ScaledDecimal - instanceVariableNames: 'fraction scale' - classVariableNames: '' - poolDictionaries: '' - category: 'Kernel-Numbers'! - - !ScaledDecimal commentStamp: 'nice 9/7/2011 19:09' prior: 0! - ScaledDecimal provides a numeric representation of fixed point decimal numbers able to accurately represent decimal fractions. It supports unbounded precision, with no limit to the number of digits before and after the decimal point. - ScaledDecimal complies with the ANSI protocols: - - Object - number - ScaledDecimal - ???? - #todo. "finish protocol list." - - Implementation Notes: - - In order to fullfil exact arithmetic requirements, ScaledDecimal is implemented using a Fraction (or an Integer if fraction part is zero) in the fraction instance variable, and a positive Integer number of digits after the decimal point in the scale instance variable. - - A scaled decimal will perform arithmetic by coercing the arguments to fractions, and perform the operations with exact arithmetic. - - Note that the denominator needs not being a power of two. If denominator has other prime factors than 2 and 5, then it cannot be printed in decimal form with a finite number of digits. Instead, the printed representation will be truncated to the number of digits prescribed in scale. But beware, the number still has hidden precision. - - Example: - | x | - x := 1 / 3.0s2. - ^{ x printString -> 'truncated print'. - 3 * x -> 'but full precision'} - ! Item was removed: - ----- Method: ScaledDecimal class>>newFromNumber:scale: (in category 'instance creation') ----- - newFromNumber: aNumber scale: scaleIn - "Answer a new instance of me." - | temp | - temp := self basicNew. - temp setFraction: aNumber asFraction scale: scaleIn. - ^ temp! Item was removed: - ----- Method: ScaledDecimal class>>readFrom: (in category 'instance creation') ----- - readFrom: stringOrStream - "Answer a decimal number as described on stringOrStream. - The number may not include a leading radix specification, as in 16rFADE, - nor an exponent like 1.0e-3 - It might have a scale specification at end or not like 10.3s2 - If not, number of digits after decimal point will be used as scale" - - ^(SqNumberParser on: stringOrStream) nextScaledDecimal! Item was removed: - ----- Method: ScaledDecimal class>>zero (in category 'constants') ----- - zero - "Answer the receiver's representation of zero." - ^ self newFromNumber: 0 scale: 0! Item was removed: - ----- Method: ScaledDecimal>>* (in category 'arithmetic') ----- - * operand - "Implementation of Number 'arithmetic' method." - (operand isKindOf: ScaledDecimal) ifTrue: [^ ScaledDecimal newFromNumber: fraction * operand asFraction scale: (scale max: operand scale)]. - ^ operand adaptToScaledDecimal: self andSend: #*! Item was removed: - ----- Method: ScaledDecimal>>+ (in category 'arithmetic') ----- - + operand - "Implementation of Number 'arithmetic' method." - (operand isKindOf: ScaledDecimal) ifTrue: [^ ScaledDecimal newFromNumber: fraction + operand asFraction scale: (scale max: operand scale)]. - ^ operand adaptToScaledDecimal: self andSend: #+! Item was removed: - ----- Method: ScaledDecimal>>- (in category 'arithmetic') ----- - - operand - "Implementation of Number 'arithmetic' method." - (operand isKindOf: ScaledDecimal) ifTrue: [^ ScaledDecimal newFromNumber: fraction - operand asFraction scale: (scale max: operand scale)]. - ^ operand adaptToScaledDecimal: self andSend: #-! Item was removed: - ----- Method: ScaledDecimal>>/ (in category 'arithmetic') ----- - / operand - "Implementation of Number 'arithmetic' method." - #ScalDec. - "Protocol: ANSI <number>." - operand = 0 ifTrue: [^ (ZeroDivide dividend: self) signal]. - (operand isKindOf: ScaledDecimal) ifTrue: [^ ScaledDecimal newFromNumber: fraction / operand asFraction scale: (scale max: operand scale)]. - ^ operand adaptToScaledDecimal: self andSend: #/! Item was removed: - ----- Method: ScaledDecimal>>< (in category 'comparing') ----- - < operand - "Implementation of Number 'comparing' method." - (operand isKindOf: ScaledDecimal) ifTrue: [^ fraction < operand asFraction]. - ^ operand adaptToScaledDecimal: self andCompare: #<! Item was removed: - ----- Method: ScaledDecimal>><= (in category 'comparing') ----- - <= operand - "Implementation of Number 'comparing' method." - (operand isKindOf: ScaledDecimal) ifTrue: [^ fraction <= operand asFraction]. - ^ operand adaptToScaledDecimal: self andCompare: #<=! Item was removed: - ----- Method: ScaledDecimal>>= (in category 'comparing') ----- - = comparand - "Implementation of Number 'comparing' method." - comparand isNumber ifFalse: [^ false]. - (comparand isKindOf: ScaledDecimal) ifTrue: [^ fraction = comparand asFraction]. - ^ comparand adaptToScaledDecimal: self andCompare: #=! Item was removed: - ----- Method: ScaledDecimal>>> (in category 'comparing') ----- - > operand - "Implementation of Number 'comparing' method." - (operand isKindOf: ScaledDecimal) ifTrue: [^ fraction > operand asFraction]. - ^ operand adaptToScaledDecimal: self andCompare: #>! Item was removed: - ----- Method: ScaledDecimal>>>= (in category 'comparing') ----- - >= operand - "Implementation of Number 'comparing' method." - (operand isKindOf: ScaledDecimal) ifTrue: [^ fraction >= operand asFraction]. - ^ operand adaptToScaledDecimal: self andCompare: #>=! Item was removed: - ----- Method: ScaledDecimal>>adaptToFraction:andSend: (in category 'converting') ----- - adaptToFraction: receiver andSend: arithmeticOpSelector - "Convert a Fraction to aScaledDecimal and do the arithmetic. - receiver arithmeticOpSelector self." - ^(receiver asScaledDecimal: scale) perform: arithmeticOpSelector with: self! Item was removed: - ----- Method: ScaledDecimal>>adaptToInteger:andSend: (in category 'converting') ----- - adaptToInteger: receiver andSend: arithmeticOpSelector - "Convert receiver to a ScaledDecimal and do the arithmetic. - receiver arithmeticOpSelector self." - ^ (receiver asScaledDecimal: 0) - perform: arithmeticOpSelector with: self! Item was removed: - ----- Method: ScaledDecimal>>asExactFloat (in category 'converting') ----- - asExactFloat - ^fraction asExactFloat! Item was removed: - ----- Method: ScaledDecimal>>asFloat (in category 'converting') ----- - asFloat - "Reimplementation - Number 'converting' method." - ^ fraction asFloat! Item was removed: - ----- Method: ScaledDecimal>>asFraction (in category 'converting') ----- - asFraction - "Implementation - Number 'converting' method." - ^ fraction! Item was removed: - ----- Method: ScaledDecimal>>asScaledDecimal: (in category 'converting') ----- - asScaledDecimal: scaleIn - "Reimplementation - Number 'converting' method." - ^ ScaledDecimal newFromNumber: fraction scale: scaleIn! Item was removed: - ----- Method: ScaledDecimal>>asSpecies: (in category 'converting') ----- - asSpecies: number - "Convert number to a ScaledDecimal." - #Numeric. - "add 200/01/19 For ANSI <number>support." - ^ ScaledDecimal newFromNumber: number scale: scale! Item was removed: - ----- Method: ScaledDecimal>>denominator (in category 'private') ----- - denominator - "Private - Answer an Integer, the denominator part of the receiver." - ^ fraction denominator! Item was removed: - ----- Method: ScaledDecimal>>floorLog: (in category 'mathematical functions') ----- - floorLog: radix - "Unlike super, this version is exact when radix is integer" - - ^self asFraction floorLog: radix! Item was removed: - ----- Method: ScaledDecimal>>fractionPart (in category 'truncation and round off') ----- - fractionPart - "Answer the fractional part of the receiver." - ^ ScaledDecimal newFromNumber: fraction fractionPart scale: scale! Item was removed: - ----- Method: ScaledDecimal>>hash (in category 'comparing') ----- - hash - "Reimplementation of Object 'comparing' method." - ^ fraction hash! Item was removed: - ----- Method: ScaledDecimal>>integerPart (in category 'truncation and round off') ----- - integerPart - "Answer the integer part of the receiver." - ^ ScaledDecimal newFromNumber: fraction integerPart scale: scale! Item was removed: - ----- Method: ScaledDecimal>>isAnExactFloat (in category 'testing') ----- - isAnExactFloat - ^fraction isAnExactFloat! Item was removed: - ----- Method: ScaledDecimal>>isLiteral (in category 'testing') ----- - isLiteral - "Answer if this number could be a well behaved literal. - Well, it would only if evaluating back to self. - This is not the case of all ScaledDecimals. - Some has an infinite precision and would need an infinite number of digits to print literally. - Try for example (3.00s2 reciprocal)." - - ^fraction denominator = 1 "first test trivial case before engaging arithmetic" - - or: ["Exactly we should test: - (fraction numerator * (10 raisedTo; scale)) \\ fraction denominator = 0. - But since we can assume fraction is reduced already this will be simply:" - - (10 raisedTo: scale) \\ fraction denominator = 0] - - ! Item was removed: - ----- Method: ScaledDecimal>>isPowerOfTwo (in category 'testing') ----- - isPowerOfTwo - "Return true if the receiver is an integral power of two." - - ^fraction isPowerOfTwo! Item was removed: - ----- Method: ScaledDecimal>>isScaledDecimal (in category 'testing') ----- - isScaledDecimal - "Reimplementation - Number 'testing' method." - ^ true! Item was removed: - ----- Method: ScaledDecimal>>isZero (in category 'comparing') ----- - isZero - "Answer whether the receiver is equal to its class' zero" - ^ fraction numerator = 0! Item was removed: - ----- Method: ScaledDecimal>>literalEqual: (in category 'comparing') ----- - literalEqual: other - "Testing equality is not enough. - It is also necessary to test number of decimal places (scale). - Otherwise we cannot compile both literals 0.5s1 and 0.50s2 in the same method" - - ^(super literalEqual: other) and: [self scale = other scale]! Item was removed: - ----- Method: ScaledDecimal>>ln (in category 'mathematical functions') ----- - ln - "Unlike super, avoid FLoat overflow/underflow" - - ^self asFraction ln! Item was removed: - ----- Method: ScaledDecimal>>log (in category 'mathematical functions') ----- - log - "Unlike super, avoid FLoat overflow/underflow" - - ^self asFraction log! Item was removed: - ----- Method: ScaledDecimal>>log2 (in category 'mathematical functions') ----- - log2 - "Unlike super, avoid Float overflow/underflow" - - ^self asFraction log2! Item was removed: - ----- Method: ScaledDecimal>>negated (in category 'arithmetic') ----- - negated - "Reimplementation of Number 'arithmetic' method." - ^ ScaledDecimal newFromNumber: fraction negated scale: scale! Item was removed: - ----- Method: ScaledDecimal>>negative (in category 'testing') ----- - negative - - ^fraction negative! Item was removed: - ----- Method: ScaledDecimal>>nthRoot: (in category 'mathematical functions') ----- - nthRoot: anInteger - "Answer the nth root of the receiver. - Preserve receiver class and scale if answer is exact. - Otherwise, answer a Float to denote inexactness." - | nthRoot | - nthRoot := self asFraction nthRoot: anInteger. - ^nthRoot isFloat - ifTrue: [nthRoot] - ifFalse: [nthRoot asScaledDecimal: scale]! Item was removed: - ----- Method: ScaledDecimal>>numerator (in category 'private') ----- - numerator - "Private - Answer an Integer, the numerator part of the receiver." - ^ fraction numerator! Item was removed: - ----- Method: ScaledDecimal>>printAsLiteralOn: (in category 'printing') ----- - printAsLiteralOn: aStream - ^self printOn: aStream! Item was removed: - ----- Method: ScaledDecimal>>printFractionAsDecimalOn: (in category 'printing') ----- - printFractionAsDecimalOn: stream - "Please note: this is different from printOn:showingDecimalPlaces: because it prints truncated." - - fraction printTruncatedOn: stream showingDecimalPlaces: scale! Item was removed: - ----- Method: ScaledDecimal>>printOn: (in category 'printing') ----- - printOn: stream - - self - printFractionAsDecimalOn: stream; - printScaleOn: stream! Item was removed: - ----- Method: ScaledDecimal>>printOn:showingDecimalPlaces: (in category 'printing') ----- - printOn: aStream showingDecimalPlaces: placesDesired - "Same as super, except the fraction knows better how to do it." - - fraction printOn: aStream showingDecimalPlaces: placesDesired! Item was removed: - ----- Method: ScaledDecimal>>printScaleOn: (in category 'printing') ----- - printScaleOn: stream - - stream nextPut: $s. - scale printOn: stream! Item was removed: - ----- Method: ScaledDecimal>>printString (in category 'printing') ----- - printString - "Reimplementation - Number 'printing' method." - | tempStream | - tempStream := WriteStream on: (String new: 10). - self printOn: tempStream. - ^ tempStream contents! Item was removed: - ----- Method: ScaledDecimal>>raisedToFraction: (in category 'mathematical functions') ----- - raisedToFraction: aFraction - | result | - result := self asFraction raisedToFraction: aFraction. - ^result isFloat - ifTrue: [result] - ifFalse: [result asScaledDecimal: scale]! Item was removed: - ----- Method: ScaledDecimal>>raisedToInteger: (in category 'mathematical functions') ----- - raisedToInteger: aNumber - ^self class newFromNumber: (fraction raisedToInteger: aNumber) scale: scale! Item was removed: - ----- Method: ScaledDecimal>>reciprocal (in category 'arithmetic') ----- - reciprocal - "Reimplementation of Number 'arithmetic' method." - self = 0 ifTrue: [^ (ZeroDivide dividend: 1) signal]. - ^ ScaledDecimal newFromNumber: fraction reciprocal scale: scale! Item was removed: - ----- Method: ScaledDecimal>>scale (in category 'private') ----- - scale - "Private - Answer a integer which represents the total number of digits - used to represent the fraction part of the receiver, including trailing - zeroes. " - ^ scale! Item was removed: - ----- Method: ScaledDecimal>>setFraction:scale: (in category 'private') ----- - setFraction: fractionIn scale: scaleIn - "Private - Set the fraction to fractionIn and the total number of digits - used to represent the fraction part of the receiver, including trailing - zeroes, to the Integer scaleIn." - fraction := fractionIn. - scale := scaleIn! Item was removed: - ----- Method: ScaledDecimal>>sqrt (in category 'mathematical functions') ----- - sqrt - "Answer the square root of the receiver. - Preserve receiver class and scale if answer is exact. - Otherwise, answer a Float to denote inexactness." - | squareRoot | - squareRoot := self asFraction sqrt. - ^squareRoot isFloat - ifTrue: [squareRoot] - ifFalse: [squareRoot asScaledDecimal: scale]! Item was removed: - ----- Method: ScaledDecimal>>squared (in category 'mathematical functions') ----- - squared - "Reimplementation - Number 'mathematical functions' method." - "not used ->" - ^ ScaledDecimal newFromNumber: fraction squared scale: scale! Item was removed: - ----- Method: ScaledDecimal>>storeOn: (in category 'printing') ----- - storeOn: aStream - "SxaledDecimal sometimes have more digits than they print (potentially an infinity). - In this case, do not use printOn: because it would loose some extra digits" - - self shouldBePrintedAsLiteral - ifTrue: [self printOn: aStream] - ifFalse: [aStream - nextPut: $(; - store: fraction numerator; - nextPut: $/; - store: fraction denominator; - nextPut: $s; - store: scale; - nextPut: $)]! Item was removed: - ----- Method: ScaledDecimal>>truncated (in category 'truncation and round off') ----- - truncated - "Reimplementation of Number 'truncation and round off' method." - ^ fraction truncated! Item was removed: - LinkedList subclass: #Semaphore - instanceVariableNames: 'excessSignals' - classVariableNames: '' - poolDictionaries: '' - category: 'Kernel-Processes'! - - !Semaphore commentStamp: '<historical>' prior: 0! - I provide synchronized communication of a single bit of information (a "signal") between Processes. A signal is sent by sending the message signal and received by sending the message wait. If no signal has been sent when a wait message is sent, the sending Process will be suspended until a signal is sent.! Item was removed: - ----- Method: Semaphore class>>forMutualExclusion (in category 'instance creation') ----- - forMutualExclusion - "Answer an instance of me that contains a single signal. This new - instance can now be used for mutual exclusion (see the critical: message - to Semaphore)." - - ^self new signal! Item was removed: - ----- Method: Semaphore class>>new (in category 'instance creation') ----- - new - "Answer a new instance of Semaphore that contains no signals." - - ^self basicNew initSignals! Item was removed: - ----- Method: Semaphore>>= (in category 'comparing') ----- - = anObject - ^ self == anObject! Item was removed: - ----- Method: Semaphore>>critical: (in category 'mutual exclusion') ----- - critical: mutuallyExcludedBlock - "Evaluate mutuallyExcludedBlock only if the receiver is not currently in - the process of running the critical: message. If the receiver is, evaluate - mutuallyExcludedBlock after the other critical: message is finished." - <criticalSection> - self wait. - ^mutuallyExcludedBlock ensure: [self signal] - ! Item was removed: - ----- Method: Semaphore>>critical:ifCurtailed: (in category 'mutual exclusion') ----- - critical: mutuallyExcludedBlock ifCurtailed: terminationBlock - "Evaluate mutuallyExcludedBlock only if the receiver is not currently in - the process of running the critical: message. If the receiver is, evaluate - mutuallyExcludedBlock after the other critical: message is finished." - ^self critical: [ mutuallyExcludedBlock ifCurtailed: terminationBlock ] - ! Item was removed: - ----- Method: Semaphore>>critical:ifError: (in category 'mutual exclusion') ----- - critical: mutuallyExcludedBlock ifError: errorBlock - "Evaluate mutuallyExcludedBlock only if the receiver is not currently in - the process of running the critical: message. If the receiver is, evaluate - mutuallyExcludedBlock after the other critical: message is finished." - | blockValue hasError errMsg errRcvr | - hasError := false. - blockValue := self critical:[ - mutuallyExcludedBlock ifError: [ :msg :rcvr | - hasError := true. - errMsg := msg. - errRcvr := rcvr - ]. - ]. - hasError ifTrue:[ ^errorBlock value: errMsg value: errRcvr]. - ^blockValue! Item was removed: - ----- Method: Semaphore>>critical:ifLocked: (in category 'mutual exclusion') ----- - critical: mutuallyExcludedBlock ifLocked: alternativeBlock - "Evaluate mutuallyExcludedBlock only if the receiver is not currently in - the process of running the critical: message. If the receiver is, then evaluate - alternativeBlock and return." - "See the comment of #critical: for the explanation how this pattern works - before changing the code." - - 0 == excessSignals ifTrue: [ ^alternativeBlock value ]. - excessSignals := excessSignals - 1. - ^mutuallyExcludedBlock ensure: [ self signal ]! Item was removed: - ----- Method: Semaphore>>excessSignals (in category 'accessing') ----- - excessSignals - - ^excessSignals! Item was removed: - ----- Method: Semaphore>>hash (in category 'comparing') ----- - hash - ^ self identityHash! Item was removed: - ----- Method: Semaphore>>initSignals (in category 'initialize-release') ----- - initSignals - "Consume any excess signals the receiver may have accumulated." - - excessSignals := 0.! Item was removed: - ----- Method: Semaphore>>isSignaled (in category 'testing') ----- - isSignaled - "Return true if this semaphore is currently signaled" - ^excessSignals > 0! Item was removed: - ----- Method: Semaphore>>resumeProcess: (in category 'initialize-release') ----- - resumeProcess: aProcess - "Remove the given process from the list of waiting processes (if it's there) and resume it. This is used when a process asked for its wait to be timed out." - - | process | - process := self remove: aProcess ifAbsent: [nil]. - process ifNotNil: [process resume].! Item was removed: - ----- Method: Semaphore>>signal (in category 'communication') ----- - signal - "Primitive. Send a signal through the receiver. If one or more processes - have been suspended trying to receive a signal, allow the first one to - proceed. If no process is waiting, remember the excess signal. Essential. - See Object documentation whatIsAPrimitive." - - <primitive: 85> - self primitiveFailed - - "self isEmpty - ifTrue: [excessSignals := excessSignals+1] - ifFalse: [Processor resume: self removeFirstLink]" - - ! Item was removed: - ----- Method: Semaphore>>terminateProcess (in category 'initialize-release') ----- - terminateProcess - "Terminate the process waiting on this semaphore, if any." - - self isEmpty ifFalse: [ self removeFirst terminate ].! Item was removed: - ----- Method: Semaphore>>wait (in category 'communication') ----- - wait - "Primitive. The active Process must receive a signal through the receiver - before proceeding. If no signal has been sent, the active Process will be - suspended until one is sent. Essential. See Object documentation - whatIsAPrimitive." - - <primitive: 86> - self primitiveFailed - - "excessSignals>0 - ifTrue: [excessSignals := excessSignals-1] - ifFalse: [self addLastLink: Processor activeProcess suspend]" - ! Item was removed: - ----- Method: Semaphore>>waitIfLocked: (in category 'communication') ----- - waitIfLocked: aBlock - "Use a signal if available, otherwise evaluate aBlock" - - excessSignals == 0 ifTrue: [ ^aBlock value ]. - excessSignals := excessSignals - 1! Item was removed: - ----- Method: Semaphore>>waitTimeoutMSecs: (in category 'communication') ----- - waitTimeoutMSecs: anInteger - "Wait on this semaphore for up to the given number of milliseconds, then timeout. - Return true if the deadline expired, false otherwise." - | d | - d := DelayWaitTimeout new setDelay: (anInteger max: 0) forSemaphore: self. - ^d wait! Item was removed: - ----- Method: Semaphore>>waitTimeoutSeconds: (in category 'communication') ----- - waitTimeoutSeconds: anInteger - "Wait on this semaphore for up to the given number of seconds, then timeout. - Return true if the deadline expired, false otherwise." - ^self waitTimeoutMSecs: anInteger * 1000. - ! Item was removed: - Object subclass: #SharedPool - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Kernel-Pools'! - - !SharedPool commentStamp: '<historical>' prior: 0! - A shared pool represents a set of bindings which are accessible to all classes which import the pool in its 'pool dictionaries'. SharedPool is NOT a dictionary but rather a name space. Bindings are represented by 'class variables' - as long as we have no better way to represent them at least.! Item was removed: - ----- Method: SharedPool class>>bindingOf: (in category 'name lookup') ----- - bindingOf: varName - "Answer the binding of some variable resolved in the scope of the receiver" - | aSymbol binding | - aSymbol := varName asSymbol. - - "First look in classVar dictionary." - binding := self classPool bindingOf: aSymbol. - binding ifNotNil:[^binding]. - - "Next look in shared pools." - self sharedPools do:[:pool | - | poolBinding | - poolBinding := pool bindingOf: aSymbol. - poolBinding ifNotNil:[^poolBinding]. - ]. - - "subclassing and environment are not preserved" - ^nil! Item was removed: - ----- Method: SharedPool class>>bindingsDo: (in category 'name lookup') ----- - bindingsDo: aBlock - ^self classPool bindingsDo: aBlock! Item was removed: - ----- Method: SharedPool class>>classBindingOf: (in category 'name lookup') ----- - classBindingOf: varName - "For initialization messages grant the regular scope" - ^super bindingOf: varName! Item was removed: - ----- Method: SharedPool class>>declare:from: (in category 'adding') ----- - declare: key from: aDictionaryOrBehavior - self ensureClassPool. - ^classPool - declare: key - from: (aDictionaryOrBehavior isBehavior - ifTrue: [aDictionaryOrBehavior classPool] - ifFalse: [aDictionaryOrBehavior])! Item was removed: - ----- Method: SharedPool class>>includesKey: (in category 'name lookup') ----- - includesKey: aName - "does this pool include aName" - ^(self bindingOf: aName) notNil! Item was removed: - ----- Method: SharedPool class>>keysDo: (in category 'enumerating') ----- - keysDo: aBlock - "A hopefully temporary fix for an issue arising from miss-spelled variable names in code being compiled. The correction code (see Class>possibleVariablesFor:continuedFrom: assumes that sharedPools are Dictionaries. The proper fix would involve making sure all pools are actually subclasses of SharedPool, which they are not currently." - self bindingsDo:[:b| - aBlock value: b key]! Item was removed: - Float immediateSubclass: #SmallFloat64 - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Kernel-Numbers'! - - !SmallFloat64 commentStamp: 'eem 11/25/2014 07:54' prior: 0! - My instances represent 64-bit Floats whose exponent fits in 8 bits as immediate objects. This representation is only available on 64-bit systems, not 32-bit systems.! Item was removed: - ----- Method: SmallFloat64 class>>basicNew (in category 'instance creation') ----- - basicNew - self error: 'SmallFloat64s can only be created by performing arithmetic'! Item was removed: - ----- Method: SmallFloat64 class>>basicNew: (in category 'instance creation') ----- - basicNew: anInteger - ^self basicNew! Item was removed: - ----- Method: SmallFloat64>>* (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: 549> - ^ aNumber adaptToFloat: self andSend: #*! Item was removed: - ----- Method: SmallFloat64>>+ (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: 541> - ^ aNumber adaptToFloat: self andSend: #+! Item was removed: - ----- Method: SmallFloat64>>- (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: 542> - ^ aNumber adaptToFloat: self andSend: #-! Item was removed: - ----- Method: SmallFloat64>>/ (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: 550> - aNumber isZero ifTrue: [^(ZeroDivide dividend: self) signal]. - ^ aNumber adaptToFloat: self andSend: #/! Item was removed: - ----- Method: SmallFloat64>>< (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: 543> - ^ aNumber adaptToFloat: self andCompare: #<! Item was removed: - ----- Method: SmallFloat64>><= (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: 545> - ^ aNumber adaptToFloat: self andCompare: #<=! Item was removed: - ----- Method: SmallFloat64>>= (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: 547> - aNumber isNumber ifFalse: [^ false]. - ^ aNumber adaptToFloat: self andCompare: #=! Item was removed: - ----- Method: SmallFloat64>>> (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: 544> - ^ aNumber adaptToFloat: self andCompare: #>! Item was removed: - ----- Method: SmallFloat64>>>= (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: 546> - ^ aNumber adaptToFloat: self andCompare: #>=! Item was removed: - ----- Method: SmallFloat64>>arcTan (in category 'mathematical functions') ----- - arcTan - "Answer the angle in radians. - Optional. See Object documentation whatIsAPrimitive." - - | theta eps step sinTheta cosTheta | - <primitive: 557> - - "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: SmallFloat64>>deepCopy (in category 'copying') ----- - deepCopy - "Answer the receiver, because SmallFloat64s are unique." - ^self! Item was removed: - ----- Method: SmallFloat64>>exp (in category 'mathematical functions') ----- - exp - "Answer E raised to the receiver power. - Optional. See Object documentation whatIsAPrimitive." - - | base fract correction delta div | - <primitive: 559> - - "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: SmallFloat64>>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: 553> - ^self exponentFromBitPattern! Item was removed: - ----- Method: SmallFloat64>>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: 552> - ^self - self truncated asFloat! Item was removed: - ----- Method: SmallFloat64>>identityHash (in category 'comparing') ----- - identityHash - "Answer an integer unique to the receiver." - <primitive: 171> - ^self primitiveFailed! Item was removed: - ----- Method: SmallFloat64>>isFinite (in category 'testing') ----- - isFinite - "A SmallFloat64 is always finite. - Infinity or nan require large exponent that does not fit." - - ^true! Item was removed: - ----- Method: SmallFloat64>>isInfinite (in category 'testing') ----- - isInfinite - "A SmallFloat64 is never infinite. - Infinity require large exponent that does not fit." - - ^false! Item was removed: - ----- Method: SmallFloat64>>isNaN (in category 'testing') ----- - isNaN - "A SmallFloat64 is never nan. - nan require large exponent that does not fit." - - ^false! Item was removed: - ----- Method: SmallFloat64>>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: 558> - - "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: SmallFloat64>>nextObject (in category 'system primitives') ----- - nextObject - "Small floats are immediate objects, and, as such, do not have successors in object memory." - - self shouldNotImplement ! Item was removed: - ----- Method: SmallFloat64>>shallowCopy (in category 'copying') ----- - shallowCopy - "Answer the receiver, because SmallFloat64s are unique." - ^self! Item was removed: - ----- Method: SmallFloat64>>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: 556> - - "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: SmallFloat64>>sqrt (in category 'mathematical functions') ----- - sqrt - "Answer the square root of the receiver. - Optional. See Object documentation whatIsAPrimitive." - <primitive: 555> - ^super sqrt! Item was removed: - ----- Method: SmallFloat64>>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: 554> - ^super timesTwoPower: anInteger! Item was removed: - ----- Method: SmallFloat64>>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: 551> - "Since SmallInteger maxVal highBit >= Float precision, in 64bits image/VM, - every Float with ulp < 1 - that is which may have a fractionPart - fits in a SmallInteger. - Thus only care of Float with ulp >= 1 which have Integer value." - ^ self asTrueFraction - - - ! Item was removed: - ----- Method: SmallFloat64>>veryDeepCopyWith: (in category 'copying') ----- - veryDeepCopyWith: deepCopier - "Answer the receiver, because SmallFloat64s are unique." - ^self! Item was removed: - ----- Method: SmallFloat64>>~= (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: 548> - ^super ~= aNumber! Item was removed: - Integer immediateSubclass: #SmallInteger - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Kernel-Numbers'! - SmallInteger class - instanceVariableNames: 'minVal maxVal'! - - !SmallInteger commentStamp: 'eem 11/20/2014 08:41' prior: 0! - My instances are at least 31-bit numbers, stored in twos complement form. The allowable range in 32-bits is approximately +- 10^9 (+- 1billion). In 64-bits my instances are 61-bit numbers, stored in twos complement form. The allowable range is approximately +- 10^18 (+- 1 quintillion). The actual values are computed at start-up. See SmallInteger class startUp:, minVal, maxVal.! - SmallInteger class - instanceVariableNames: 'minVal maxVal'! Item was removed: - ----- Method: SmallInteger class>>basicNew (in category 'instance creation') ----- - basicNew - - self error: 'SmallIntegers can only be created by performing arithmetic'! Item was removed: - ----- Method: SmallInteger class>>basicNew: (in category 'instance creation') ----- - basicNew: sizeRequested - - self error: 'SmallIntegers can only be created by performing arithmetic'! Item was removed: - ----- Method: SmallInteger class>>guideToDivision (in category 'documentation') ----- - guideToDivision - "Handy guide to the kinds of Integer division: - / exact division, returns a fraction if result is not a whole integer. - // returns an Integer, rounded towards negative infinity. - \\ is modulo rounded towards negative infinity. - quo: truncated division, rounded towards zero."! Item was removed: - ----- Method: SmallInteger class>>initialize (in category 'class initialization') ----- - initialize - SmalltalkImage current addToStartUpList: self before: Delay. - self startUp: true! Item was removed: - ----- Method: SmallInteger class>>maxVal (in category 'constants') ----- - maxVal - "Answer the maximum value for a SmallInteger." - ^maxVal! Item was removed: - ----- Method: SmallInteger class>>minVal (in category 'constants') ----- - minVal - "Answer the minimum value for a SmallInteger." - ^minVal! Item was removed: - ----- Method: SmallInteger class>>new (in category 'instance creation') ----- - new - - self basicNew "generates an error"! Item was removed: - ----- Method: SmallInteger class>>startUp: (in category 'class initialization') ----- - startUp: resuming - "The image is either being newly started (resuming is true), or it's just been snapshotted. - If this has just been a snapshot, skip all the startup stuff." - | next val | - resuming ifFalse: [^self]. - val := -32768. "Assume at least 16 bits" - [next := val + val. - next class == self] whileTrue: - [val := next]. - minVal := val. - maxVal := -1 - val! Item was removed: - ----- Method: SmallInteger>>* (in category 'arithmetic') ----- - * aNumber - "Primitive. Multiply the receiver by the argument and answer with the - result if it is a SmallInteger. Fail if the argument or the result is not a - SmallInteger. Essential. No Lookup. See Object documentation whatIsAPrimitive." - - <primitive: 9> - ^ super * aNumber! Item was removed: - ----- Method: SmallInteger>>+ (in category 'arithmetic') ----- - + aNumber - "Primitive. Add the receiver to the argument and answer with the result - if it is a SmallInteger. Fail if the argument or the result is not a - SmallInteger Essential No Lookup. See Object documentation whatIsAPrimitive." - - <primitive: 1> - ^ super + aNumber! Item was removed: - ----- Method: SmallInteger>>- (in category 'arithmetic') ----- - - aNumber - "Primitive. Subtract the argument from the receiver and answer with the - result if it is a SmallInteger. Fail if the argument or the result is not a - SmallInteger. Essential. No Lookup. See Object documentation - whatIsAPrimitive." - - <primitive: 2> - ^super - aNumber! Item was removed: - ----- Method: SmallInteger>>/ (in category 'arithmetic') ----- - / aNumber - "Primitive. This primitive (for /) divides the receiver by the argument - and returns the result if the division is exact. Fail if the result is not a - whole integer. Fail if the argument is 0 or is not a SmallInteger. Optional. - No Lookup. See Object documentation whatIsAPrimitive." - - <primitive: 10> - ^super / aNumber! Item was removed: - ----- Method: SmallInteger>>// (in category 'arithmetic') ----- - // aNumber - "Primitive. Divide the receiver by the argument and answer with the - result. Round the result down towards negative infinity to make it a - whole integer. Fail if the argument is 0 or is not a SmallInteger. - Essential. No Lookup. See Object documentation whatIsAPrimitive. " - - <primitive: 12> - ^ super // aNumber "Do with quo: if primitive fails"! Item was removed: - ----- Method: SmallInteger>>< (in category 'comparing') ----- - < aNumber - "Primitive. Compare the receiver with the argument and answer with - true if the receiver is less than the argument. Otherwise answer false. - Fail if the argument is not a SmallInteger. Essential. No Lookup. See - Object documentation whatIsAPrimitive." - - <primitive: 3> - ^super < aNumber! Item was removed: - ----- Method: SmallInteger>><= (in category 'comparing') ----- - <= aNumber - "Primitive. Compare the receiver with the argument and answer true if - the receiver is less than or equal to the argument. Otherwise answer - false. Fail if the argument is not a SmallInteger. Optional. No Lookup. - See Object documentation whatIsAPrimitive. " - - <primitive: 5> - ^super <= aNumber! Item was removed: - ----- Method: SmallInteger>>= (in category 'comparing') ----- - = aNumber - "Primitive. Compare the receiver with the argument and answer true if - the receiver is equal to the argument. Otherwise answer false. Fail if the - argument is not a SmallInteger. Essential. No Lookup. See Object - documentation whatIsAPrimitive. " - - <primitive: 7> - ^super = aNumber! Item was removed: - ----- Method: SmallInteger>>> (in category 'comparing') ----- - > aNumber - "Primitive. Compare the receiver with the argument and answer true if - the receiver is greater than the argument. Otherwise answer false. Fail if - the argument is not a SmallInteger. Essential. No Lookup. See Object - documentation whatIsAPrimitive." - - <primitive: 4> - ^super > aNumber! Item was removed: - ----- Method: SmallInteger>>>= (in category 'comparing') ----- - >= aNumber - "Primitive. Compare the receiver with the argument and answer true if - the receiver is greater than or equal to the argument. Otherwise answer - false. Fail if the argument is not a SmallInteger. Optional. No Lookup. - See Object documentation whatIsAPrimitive." - - <primitive: 6> - ^super >= aNumber! Item was removed: - ----- Method: SmallInteger>>\\ (in category 'arithmetic') ----- - \\ aNumber - "Primitive. Take the receiver modulo the argument. The result is the - remainder rounded towards negative infinity, of the receiver divided by - the argument Fail if the argument is 0 or is not a SmallInteger. Optional. - No Lookup. See Object documentation whatIsAPrimitive." - - <primitive: 11> - ^ super \\ aNumber "will use // to compute it if primitive fails"! Item was removed: - ----- Method: SmallInteger>>as31BitSmallInt (in category 'converting') ----- - as31BitSmallInt - "Polymorphic with LargePositiveInteger (see comment there). - Return self since all SmallIntegers are 31 bits" - - ^ self! Item was removed: - ----- Method: SmallInteger>>asCharacter (in category 'converting') ----- - asCharacter - <primitive: 170> - ^self primitiveFailed! Item was removed: - ----- Method: SmallInteger>>asFloat (in category 'converting') ----- - asFloat - "Primitive. Answer a Float that represents the value of the receiver. - Essential. See Object documentation whatIsAPrimitive." - - <primitive: 40> - self primitiveFailed! Item was removed: - ----- Method: SmallInteger>>bitAnd: (in category 'bit manipulation') ----- - bitAnd: arg - "Primitive. Answer an Integer whose bits are the logical AND of the - receiver's bits and those of the argument, arg. - Numbers are interpreted as having 2's-complement representation. - Essential. See Object documentation whatIsAPrimitive." - - <primitive: 14> - self >= 0 ifTrue: [^arg bitAnd: self]. - ^arg < 0 - ifTrue: [(arg bitInvert bitOr: self bitInvert) bitInvert] - ifFalse: [arg bitClear: self bitInvert]! Item was removed: - ----- Method: SmallInteger>>bitCount (in category 'bit manipulation') ----- - bitCount - "Count the number of bits set to 1 in self. Overridden for performance" - - | n bitCount | - self < 0 ifTrue: [self error: 'Cannot count bits of negative integers']. - bitCount := 0. - n := self. - [ n = 0 ] whileFalse: [ - bitCount := bitCount + (BitCountPerByteTable at: (n bitAnd: 16rFF) + 1). - n := n bitShift: -8 ]. - ^bitCount! Item was removed: - ----- Method: SmallInteger>>bitCountOfByte (in category 'bit manipulation') ----- - bitCountOfByte - "Count the number of bits set to 1 in a byte." - - ^BitCountPerByteTable at: self + 1! Item was removed: - ----- Method: SmallInteger>>bitOr: (in category 'bit manipulation') ----- - bitOr: arg - "Primitive. Answer an Integer whose bits are the logical OR of the - receiver's bits and those of the argument, arg. - Numbers are interpreted as having 2's-complement representation. - Essential. See Object documentation whatIsAPrimitive." - - <primitive: 15> - self >= 0 ifTrue: [^ arg bitOr: self]. - ^ arg < 0 - ifTrue: [(self bitInvert bitAnd: arg bitInvert) bitInvert] - ifFalse: [(self bitInvert bitClear: arg) bitInvert]! Item was removed: - ----- Method: SmallInteger>>bitShift: (in category 'bit manipulation') ----- - bitShift: arg - "Primitive. Answer an Integer whose value is the receiver's value shifted - left by the number of bits indicated by the argument. Negative arguments - shift right. The receiver is interpreted as having 2's-complement representation. - Essential. See Object documentation whatIsAPrimitive." - - <primitive: 17> - self = 0 ifTrue: [^self]. - self > 0 ifTrue: [^ super bitShift: arg]. - ^ arg >= 0 - ifTrue: [(self negated bitShift: arg) negated] - ifFalse: [(self bitInvert bitShift: arg) bitInvert]! Item was removed: - ----- Method: SmallInteger>>bitXor: (in category 'bit manipulation') ----- - bitXor: arg - "Primitive. Answer an Integer whose bits are the logical XOR of the - receiver's bits and those of the argument, arg. - Numbers are interpreted as having 2's-complement representation. - Essential. See Object documentation whatIsAPrimitive." - - <primitive: 16> - self >= 0 ifTrue: [^ arg bitXor: self]. - ^ arg < 0 - ifTrue: [self bitInvert bitXor: arg bitInvert] - ifFalse: [(self bitInvert bitXor: arg) bitInvert]! Item was removed: - ----- Method: SmallInteger>>byteReversed (in category 'bit manipulation') ----- - byteReversed - "Answer the receiver with bits reversed in a byte. - The receiver must be between 0 and 255. - The constant has been obtained by this snippet: - (0 to: 255) collect: [:e | - | r | - r := ((e bitAnd: 2r11110000) bitShift: -4) + ((e bitAnd: 2r00001111) bitShift: 4). - r := ((r bitAnd: 2r11001100) bitShift: -2) + ((r bitAnd: 2r00110011) bitShift: 2). - ((r bitAnd: 2r10101010) bitShift: -1) + ((r bitAnd: 2r01010101) bitShift: 1).] as: ByteArray" - - ^#[0 128 64 192 32 160 96 224 16 144 80 208 48 176 112 240 8 136 72 200 40 168 104 232 24 152 88 216 56 184 120 248 4 132 68 196 36 164 100 228 20 148 84 212 52 180 116 244 12 140 76 204 44 172 108 236 28 156 92 220 60 188 124 252 2 130 66 194 34 162 98 226 18 146 82 210 50 178 114 242 10 138 74 202 42 170 106 234 26 154 90 218 58 186 122 250 6 134 70 198 38 166 102 230 22 150 86 214 54 182 118 246 14 142 78 206 46 174 110 238 30 158 94 222 62 190 126 254 1 129 65 193 33 161 97 225 17 145 81 209 49 177 113 241 9 137 73 201 41 169 105 233 25 153 89 217 57 185 121 249 5 133 69 197 37 165 101 229 21 149 85 213 53 181 117 245 13 141 77 205 45 173 109 237 29 157 93 221 61 189 125 253 3 131 67 195 35 163 99 227 19 147 83 211 51 179 115 243 11 139 75 203 43 171 107 235 27 155 91 219 59 187 123 251 7 135 71 199 39 167 103 231 23 151 87 215 55 183 119 247 15 143 79 207 47 175 111 239 31 159 95 223 63 191 127 255] at: 1 + self! Item was removed: - ----- Method: SmallInteger>>decimalDigitLength (in category 'printing') ----- - decimalDigitLength - "Answer the number of digits printed out in base 10. - Note that this only works for positive SmallIntegers up to 63-bits." - - self <= 99999999 "8" ifTrue: [ - self <= 9999 "4" ifTrue: [ - self <= 99 "2" ifTrue: [ - self <= 9 "1" ifTrue: [ ^1]. - ^2 ]. - self <= 999 "3" ifTrue: [ ^3]. - ^4 ]. - self <= 999999 "6" ifTrue: [ - self <= 99999 "5" ifTrue: [ ^5 ]. - ^6 ]. - self <= 9999999 "7" ifTrue: [ ^7 ]. - ^8 ]. - self <= 1073741823 "10" ifTrue: [ "This is here only to avoid LargeInteger comparisons in 32-bit VMs" - self <= 999999999 "9" ifTrue: [ ^9 ]. - ^10 ]. - self <= 999999999999999 "15" ifTrue: [ - self <= 9999999999999 "13" ifTrue: [ - self <= 99999999999 "11" ifTrue: [ - self <= 9999999999 "10" ifTrue: [ ^10 ]. - ^11 ]. - self <= 999999999999 "12" ifTrue: [ ^12 ]. - ^13 ]. - self <= 99999999999999 "14" ifTrue: [ ^14 ]. - ^15 ]. - self <= 99999999999999999 "17" ifTrue: [ - self <= 9999999999999999 "16" ifTrue: [ ^16 ]. - ^17 ]. - self <= 999999999999999999 "18" ifTrue: [ ^18 ]. - ^19 "(1 << 60 - 1) asString size"! Item was removed: - ----- Method: SmallInteger>>deepCopy (in category 'copying') ----- - deepCopy - "Answer the receiver, because SmallIntegers are unique." - ^self! Item was removed: - ----- Method: SmallInteger>>digitAt: (in category 'system primitives') ----- - digitAt: n - "Answer the value of an apparent byte-indexable field in the receiver, - analogous. to the large integers, which are organized as bytes." - - n = 1 ifTrue: "Negate carefully in case the receiver is SmallInteger minVal" - [self < 0 ifTrue: - [^-256 - self bitAnd: 255]. - ^self bitAnd: 255]. - self < 0 ifTrue: - [^(-256 - self bitShift: -8) + 1 digitAt: n - 1]. - ^(self bitShift: 8 - (n bitShift: 3)) bitAnd: 255! Item was removed: - ----- Method: SmallInteger>>digitAt:put: (in category 'system primitives') ----- - digitAt: n put: value - "Fails. The digits of a small integer can not be modified." - - self error: 'You can''t store in a SmallInteger'! Item was removed: - ----- Method: SmallInteger>>digitLength (in category 'system primitives') ----- - digitLength - "Answer the number of indexable fields in the receiver. This value is the - same as the largest legal subscript. Included so that a SmallInteger can - behave like a LargePositiveInteger or LargeNegativeInteger." - - | value length | - length := 1. - (value := self) < -255 - ifTrue: - [length := 2. - value := (-256 - self bitShift: -8) + 1 "carefully negate SmallInteger minVal"]. - [value > 255] whileTrue: - [value := value bitShift: -8. - length := length + 1]. - ^length! Item was removed: - ----- Method: SmallInteger>>digitsAsFloat (in category 'private') ----- - digitsAsFloat - "private - let the primitive take care to answer the nearest float" - <primitive: 40> - ^super digitsAsFloat * self sign! Item was removed: - ----- Method: SmallInteger>>even (in category 'testing') ----- - even - - ^(self bitAnd: 1) = 0! Item was removed: - ----- Method: SmallInteger>>fromString:radix: (in category 'private') ----- - fromString: str radix: radix - - | maxdigit c val | - maxdigit := - radix + (radix > 10 - ifTrue: [55 - 1] - ifFalse: [48 - 1]). - val := 0. - 1 to: str size do: - [:i | - c := str at: i. - (c < 48 ifFalse: [c > maxdigit]) - ifTrue: [^false]. - val := val * radix + (c <= 57 - ifTrue: [c - 48] - ifFalse: - [c < 65 ifTrue: [^false]. - c - 55])]. - ^val! Item was removed: - ----- Method: SmallInteger>>gcd: (in category 'arithmetic') ----- - gcd: anInteger - "See SmallInteger (Integer) | gcd:" - | n m | - anInteger denominator = 1 ifFalse: [^anInteger gcd: self]. - n := self. - m := anInteger. - [n = 0] - whileFalse: - [n := m \\ (m := n)]. - ^ m abs! Item was removed: - ----- Method: SmallInteger>>hash (in category 'comparing') ----- - hash - "Answer an integer value that is related to the value of the receiver. - Since the integers are by definition perfectly distributed answer self - (it is impossible to derive a hash function that is better distributed - than the SmallIntegers themselves). c.f. LargePositiveInteger hash." - - ^self! Item was removed: - ----- Method: SmallInteger>>hashMultiply (in category 'bit manipulation') ----- - hashMultiply - "This is a multiplication by by 1664525 mod 2^28 written to avoid overflowing into large integers. - The primitive is able to perform the operation with modulo arihmetic." - <primitive: 159> - | low | - low := self bitAnd: 16383. - ^(16r260D * low + ((16r260D * (self bitShift: -14) + (16r0065 * low) bitAnd: 16383) * 16384)) - bitAnd: 16r0FFFFFFF! Item was removed: - ----- Method: SmallInteger>>highBit (in category 'bit manipulation') ----- - highBit - "Answer the index of the high order bit of the receiver, or zero if the - receiver is zero. Raise an error if the receiver is negative, since - negative integers are defined to have an infinite number of leading 1's - in 2's-complement arithmetic. Use >>highBitOfMagnitude if you want to - get the highest bit of the magnitude." - <primitive: 575> - self < 0 ifTrue: [^ self error: 'highBit is not defined for negative integers']. - ^ self highBitOfPositiveReceiver! Item was removed: - ----- Method: SmallInteger>>highBitOfByte (in category 'private') ----- - highBitOfByte - "The high bits table can be obtained with: - (1 to: 8) inject: #[0] into: [:highBits :rank | highBits , (highBits collect: [:e | rank])]." - ^ #[0 1 2 2 3 3 3 3 4 4 4 4 4 4 4 4 5 5 5 5 5 5 5 5 5 5 5 5 5 5 5 5 6 6 6 6 6 6 6 6 6 6 6 6 6 6 6 6 6 6 6 6 6 6 6 6 6 6 6 6 6 6 6 6 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8] at: self + 1! Item was removed: - ----- Method: SmallInteger>>highBitOfMagnitude (in category 'bit manipulation') ----- - highBitOfMagnitude - "Answer the index of the high order bit of the receiver, or zero if the - receiver is zero. This method is used for negative SmallIntegers as well, - since Squeak's LargeIntegers are sign/magnitude." - - <primitive: 575> - self < 0 ifTrue: [^self negated highBit]. - ^self highBitOfPositiveReceiver! Item was removed: - ----- Method: SmallInteger>>highBitOfPositiveReceiver (in category 'private') ----- - highBitOfPositiveReceiver - | shifted bitNo | - "Answer the index of the high order bit of the receiver, or zero if the - receiver is zero. Receiver has to be positive!!" - shifted := self. - bitNo := 0. - [shifted < 65536] - whileFalse: - [shifted := shifted bitShift: -16. - bitNo := bitNo + 16]. - shifted < 256 - ifFalse: - [shifted := shifted bitShift: -8. - bitNo := bitNo + 8]. - ^bitNo + shifted highBitOfByte! Item was removed: - ----- Method: SmallInteger>>identityHash (in category 'comparing') ----- - identityHash - - ^self! Item was removed: - ----- Method: SmallInteger>>instVarAt: (in category 'system primitives') ----- - instVarAt: i - "Small integer has to be specially handled." - - i = 1 ifTrue: [^self]. - self error: 'argument too big for small integer instVarAt:'! Item was removed: - ----- Method: SmallInteger>>isAnExactFloat (in category 'testing') ----- - isAnExactFloat - "See super. - When you're small, the fastest way is to try" - - ^self asFloat truncated = self! Item was removed: - ----- Method: SmallInteger>>isLarge (in category 'testing') ----- - isLarge - ^false! Item was removed: - ----- Method: SmallInteger>>isPowerOfTwo (in category 'testing') ----- - isPowerOfTwo - "Return true if the receiver is an integral power of two. Optimized version." - - ^self > 0 and: [ (self bitAnd: self - 1) = 0 ]! Item was removed: - ----- Method: SmallInteger>>lowBit (in category 'bit manipulation') ----- - lowBit - " Answer the index of the low order one bit. - 2r00101000 lowBit (Answers: 4) - 2r-00101000 lowBit (Answers: 4) - First we skip bits in groups of 8, then do a lookup in a table. - While not optimal, this is a good tradeoff; long - integer #lowBit always invokes us with bytes." - - | n result lastByte | - n := self. - n = 0 ifTrue: [ ^ 0 ]. - result := 0. - [(lastByte := n bitAnd: 16rFF) = 0] - whileTrue: [ - result := result + 8. - n := n bitShift: -8 ]. - ^result + (LowBitPerByteTable at: lastByte)! Item was removed: - ----- Method: SmallInteger>>nextInstance (in category 'system primitives') ----- - nextInstance - "SmallIntegers can't be enumerated this way. There are a finite number of them from from (SmallInteger minVal) to (SmallInteger maxVal), but you'll have to enumerate them yourself with: - (SmallInteger minVal) to: (SmallInteger maxVal) do: [:integer | <your code here>]. - " - - self shouldNotImplement ! Item was removed: - ----- Method: SmallInteger>>nextObject (in category 'system primitives') ----- - nextObject - "SmallIntegers are immediate objects, and, as such, do not have successors in object memory." - - self shouldNotImplement ! Item was removed: - ----- Method: SmallInteger>>numberOfDigitsInBase: (in category 'printing') ----- - numberOfDigitsInBase: b - "Return how many digits are necessary to print this number in base b. - Mostly same as super but an optimized version for base 10 case" - - b = 10 ifFalse: [^super numberOfDigitsInBase: b]. - self < 0 ifTrue: [^self negated numberOfDigitsInBase: b]. "We can't use #decimalDigitLength here, because the receiver might be SmallInteger minVal." - ^self decimalDigitLength! Item was removed: - ----- Method: SmallInteger>>objectForDataStream: (in category 'objects from disk') ----- - objectForDataStream: refStrm - "In a 64-bit Spur VM, we may have to fake 32-bit SmallIntegers for compatibility." - - | large | - self > 16r3FFFFFFF ifTrue: [ - large := LargePositiveInteger new: self digitLength neg: false. - 1 to: self digitLength do: [:i | large digitAt: i put: (self digitAt: i)]. - ^large]. - self < -16r40000000 ifTrue: [ - large := LargeNegativeInteger new: self digitLength neg: true. - 1 to: self digitLength do: [:i | large digitAt: i put: (self digitAt: i)]. - ^large]. - ^ self! Item was removed: - ----- Method: SmallInteger>>odd (in category 'testing') ----- - odd - - ^(self bitAnd: 1) = 1! Item was removed: - ----- Method: SmallInteger>>printOn:base: (in category 'printing') ----- - printOn: stream base: base - "Append a representation of this number in base b on aStream." - - self printOn: stream base: base length: 0 padded: false! Item was removed: - ----- Method: SmallInteger>>printOn:base:length:padded: (in category 'printing') ----- - printOn: stream base: base length: minimumLength padded: padWithZeroes - - | n numberOfDigits totalLength divisor | - self < 0 - ifTrue: [ - n := self negated. - totalLength := 1 ] - ifFalse: [ - n := self. - totalLength := 0 ]. - numberOfDigits := n numberOfDigitsInBase: base. - totalLength := totalLength + numberOfDigits. - padWithZeroes ifFalse: [ - [ totalLength < minimumLength ] whileTrue: [ - stream space. - totalLength := totalLength + 1 ] ]. - self < 0 ifTrue: [ stream nextPut: $- ]. - padWithZeroes ifTrue: [ - [ totalLength < minimumLength ] whileTrue: [ - stream nextPut: $0. - totalLength := totalLength + 1 ] ]. - numberOfDigits > 1 ifTrue: [ - divisor := base = 10 - ifTrue: [ #(1 10 100 1000 10000 100000 1000000 10000000 100000000 1000000000 10000000000 100000000000 1000000000000 10000000000000 100000000000000 1000000000000000 10000000000000000 100000000000000000 1000000000000000000) at: numberOfDigits ] - ifFalse: [ base raisedToInteger: numberOfDigits - 1 ]. - [ divisor > 1 ] whileTrue: [ - | digit | - digit := n // divisor. - stream nextPut: ('0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ' at: digit + 1). - n := n - (digit * divisor). - divisor := divisor // base ] ]. - ^stream nextPut: ('0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ' at: n + 1)! Item was removed: - ----- Method: SmallInteger>>printOn:base:nDigits: (in category 'printing') ----- - printOn: aStream base: b nDigits: n - "Append a representation of this number in base b on aStream using nDigits. - self must be positive." - - self printOn: aStream base: b length: n padded: true! Item was removed: - ----- Method: SmallInteger>>printString (in category 'printing') ----- - printString - "Highly optimized version for base 10 - and that we know it is a SmallInteger." - - | integer next result len | - self = 0 ifTrue: [^'0']. - self < 0 ifTrue: [^'-', self negated printString]. - len := self decimalDigitLength. - result := String new: len. - integer := self. - len to: 1 by: -1 do: [:i | - next := integer // 10. - result byteAt: i put: 48 + (integer - (next * 10)). - integer := next]. - ^result! Item was removed: - ----- Method: SmallInteger>>printStringBase: (in category 'printing') ----- - printStringBase: b - "Return a String representation of this number in base b. - For SmallIntegers, it is more efficient to print directly in a String, - rather than using a Stream like super." - - self < 0 - ifTrue: [^ '-' - , (self negated printStringBase: b)]. - self < b - ifTrue: [^ String - with: (Character digitValue: self)]. - ^ self printStringBase: b nDigits: (self numberOfDigitsInBase: b)! Item was removed: - ----- Method: SmallInteger>>printStringBase:nDigits: (in category 'printing') ----- - printStringBase: b nDigits: n - "Return a string representation of this number in base b with n digits (left padded with 0). - Should be invoked with: 0 <= self < (b raisedToInteger: n)." - - | integer next result | - result := String new: n. - integer := self. - n to: 1 by: -1 do: [:i | - next := integer // b. - result byteAt: i put: (Character digitValue: (integer - (next * b))). - integer := next]. - ^result! Item was removed: - ----- Method: SmallInteger>>quo: (in category 'arithmetic') ----- - quo: aNumber - "Primitive. Divide the receiver by the argument and answer with the - result. Round the result down towards zero to make it a whole integer. - Fail if the argument is 0 or is not a SmallInteger. Optional. See Object - documentation whatIsAPrimitive." - <primitive: 13> - aNumber = 0 ifTrue: [^ (ZeroDivide dividend: self) signal]. - (aNumber isMemberOf: SmallInteger) - ifFalse: [^ super quo: aNumber]. - (aNumber = -1 and: [self = self class minVal]) - ifTrue: ["result is aLargeInteger" ^ self negated]. - self primitiveFailed! Item was removed: - ----- Method: SmallInteger>>scaledIdentityHash (in category 'comparing') ----- - scaledIdentityHash - "For identityHash values returned by primitive 75, answer - such values times 2^8. Otherwise, match the existing - identityHash implementation" - - ^self! Item was removed: - ----- Method: SmallInteger>>shallowCopy (in category 'copying') ----- - shallowCopy - "Answer the receiver, because SmallIntegers are unique." - ^self! Item was removed: - ----- Method: SmallInteger>>sqrt (in category 'mathematical functions') ----- - sqrt - "Answer the square root of the receiver. - If the square root is exact, answer an Integer, else answer a Float approximation" - | floatResult integerResult | - self negative ifTrue: [ - ^ DomainError signal: 'sqrt undefined for number less than zero.' ]. - floatResult := self asFloat sqrt. - integerResult := floatResult truncated. - "Note: truncated works for 60-bit SmallInteger - If self is a square s^2, but asFloat rounds down, - f = s^2*(1-e), f^0.5 = s*(1-e)^0.5 = s*(1-0.5*e-O(e^2)) - since s asFloat is exact, and e <= 0.5*ulp(1), - s*(1-0.5*e-O(e^2)) always rounds to s" - integerResult * integerResult = self ifTrue: [^integerResult]. - self isAnExactFloat ifTrue: [^floatResult]. - "self has more bits than Float precision, so self asFloat and floatResult might be inexact. - Use large integer algorithm for a guaranty of returning the nearest float to exact result. - Note that shifting by 8 is enough because SmallInteger maxVal highBit - Float precision < 8" - ^(self << 8) sqrt timesTwoPower: -4! Item was removed: - ----- Method: SmallInteger>>sqrtFloor (in category 'mathematical functions') ----- - sqrtFloor - "See super. Use asFloat sqrt which is known to be exactly rounded. - Adjust the result in case self asFloat is inexact. - An example why it is necessary with 60 bits SmallInteger is: - | i | - i := (1<<28-1) squared - 1. - i asFloat sqrt truncated squared <= i. - What happens is that i and and next perfect square above i, s^2 - are rounded to the same Float f >= s^2. - In other words, asFloat did cross the next perfect square boundary. - The guess is at most off by 1, because the next next perfect square is: - (s + 1) squared = (2*s + s squared + 1) - s squared has at most 60 bits, and 2*s has 31 bits in this case, - s squared highBit - (2*s) highBit < Float precision, - so we are sure that next next perfect square is a different Float." - - | guess | - guess := self asFloat sqrt truncated. - guess * guess > self ifTrue: [^guess - 1]. - ^guess! Item was removed: - ----- Method: SmallInteger>>sqrtRem (in category 'mathematical functions') ----- - sqrtRem - "See super" - - | s | - s := self sqrtFloor. - ^{s. self - (s*s)}! Item was removed: - ----- Method: SmallInteger>>threeDigitName (in category 'printing') ----- - threeDigitName - - | units answer | - - self = 0 ifTrue: [^'']. - units := #('one' 'two' 'three' 'four' 'five' 'six' 'seven' 'eight' 'nine' 'ten' - 'eleven' 'twelve' 'thirteen' 'fourteen' 'fifteen' 'sixteen' 'seventeen' - 'eighteen' 'nineteen'). - self > 99 ifTrue: [ - answer := (units at: self // 100),' hundred'. - (self \\ 100) = 0 ifFalse: [ - answer := answer,' ',(self \\ 100) threeDigitName - ]. - ^answer - ]. - self < 20 ifTrue: [ - ^units at: self - ]. - answer := #('twenty' 'thirty' 'forty' 'fifty' 'sixty' 'seventy' 'eighty' 'ninety') - at: self // 10 - 1. - (self \\ 10) = 0 ifFalse: [ - answer := answer,'-',(units at: self \\ 10) - ]. - ^answer! Item was removed: - ----- Method: SmallInteger>>veryDeepCopyWith: (in category 'copying') ----- - veryDeepCopyWith: deepCopier - "Answer the receiver, because SmallIntegers are unique." - ^self! Item was removed: - ----- Method: SmallInteger>>~= (in category 'comparing') ----- - ~= aNumber - "Primitive. Compare the receiver with the argument and answer true if - the receiver is not equal to the argument. Otherwise answer false. Fail if - the argument is not a SmallInteger. Essential. No Lookup. See Object - documentation whatIsAPrimitive." - - <primitive: 8> - ^super ~= aNumber! Item was removed: - NumberParser subclass: #SqNumberParser - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Kernel-Numbers'! - - !SqNumberParser commentStamp: 'nice 2/13/2010 00:36' prior: 0! - SqNumberParser is a NumberParser specialized in reading Number with Squeak syntax. - - Squeak syntax follows general Smalltalk-80 conventions for integer and floats, extended with scaled decimals. - Noticeable differences with st-80 and other Smalltalks are: - - allow both 2r-10 and -2r10 and even -2r-10 - - allow floating point with radix 2r10.011 - - do not allow single s without following digits as ScaledDecimal - - handle special case of Float (NaN Infinity and -0.0 as negative zero)! Item was removed: - ----- Method: SqNumberParser>>allowPlusSign (in category 'accessing') ----- - allowPlusSign - "return a boolean indicating if plus sign is allowed or not" - - ^false! Item was removed: - ----- Method: SqNumberParser>>exponentLetters (in category 'accessing') ----- - exponentLetters - "answer the list of possible exponents for Numbers. - Note: this parser will not honour precision attached to the exponent. - different exponent do not lead to different precisions. - only IEEE 754 floating point numbers will be created" - - ^'edq'! Item was removed: - ----- Method: SqNumberParser>>makeIntegerOrScaledInteger (in category 'parsing-private') ----- - makeIntegerOrScaledInteger - "At this point, there is no digit, nor fractionPart. - Maybe it can be a scaled decimal with fraction omitted... - Maybe it can be a Float with a negative exponent" - - neg ifTrue: - [integerPart := integerPart negated]. - self readExponent ifTrue: - ["Check that the result is an integer, otherwise answer a Float. Fractions are /not/ valid literals." - (exponent >= 0 or: [(integerPart * (base raisedToInteger: exponent)) isInteger]) ifFalse: - [base := base asFloat]. - ^integerPart * (base raisedToInteger: exponent)]. - (self readScaleWithDefaultNumberOfDigits: 0) ifTrue: - [^integerPart asScaledDecimal: scale]. - ^ integerPart! Item was removed: - ----- Method: SqNumberParser>>makeScaledDecimalWithNumberOfNonZeroFractionDigits:andNumberOfTrailingZeroInFractionPart: (in category 'parsing-private') ----- - makeScaledDecimalWithNumberOfNonZeroFractionDigits: numberOfNonZeroFractionDigits andNumberOfTrailingZeroInFractionPart: numberOfTrailingZeroInFractionPart - "at this point integerPart fractionPart and scale have been read out (in inst var). - Form a ScaledDecimal. - Care of eliminating trailing zeroes from the fractionPart" - - | decimalMultiplier decimalFraction | - decimalMultiplier := base raisedToInteger: numberOfNonZeroFractionDigits. - decimalFraction := integerPart * decimalMultiplier + (fractionPart // (base raisedTo: numberOfTrailingZeroInFractionPart)) / decimalMultiplier. - neg - ifTrue: [decimalFraction := decimalFraction negated]. - ^decimalFraction asScaledDecimal: scale! Item was removed: - ----- Method: SqNumberParser>>nextFraction (in category 'parsing-public') ----- - nextFraction - | numerator denominator numberOfTrailingZeroInIntegerPart | - base := self defaultBase. - neg := self peekSignIsMinus. - (integerPart := self nextUnsignedIntegerOrNilBase: base) - ifNil: ["No integerPart, raise an error" - ^ self expected: 'a digit']. - numberOfTrailingZeroInIntegerPart := nDigits - lastNonZero. - (sourceStream peekFor: $r) - ifTrue: ["<base>r<integer>" - (base := integerPart) < 2 - ifTrue: [ - sourceStream skip: -1. - ^ self expected: 'an integer greater than 1 as valid radix']. - self peekSignIsMinus - ifTrue: [neg := neg not]. - integerPart := self nextUnsignedIntegerBase: base. - numberOfTrailingZeroInIntegerPart := nDigits - lastNonZero]. - (sourceStream peekFor: $.) - ifTrue: - [^self readFractionPartNumberOfTrailingZeroInIntegerPart: numberOfTrailingZeroInIntegerPart]. - numerator := neg - ifTrue: [integerPart negated] - ifFalse: [integerPart]. - self readExponent ifTrue: [numerator := numerator * (base raisedToInteger: exponent)]. - (sourceStream peekFor: $/) ifFalse: [^numerator]. - base := self defaultBase. - (denominator := self nextUnsignedIntegerOrNilBase: base) - ifNil: - [sourceStream skip: -1. "Not a valid denominator, ungobble / and return numerator" - ^numerator]. - (sourceStream peekFor: $r) - ifTrue: ["<base>r<integer>" - (base := denominator) < 2 - ifTrue: [ - sourceStream skip: -1. - ^ self expected: 'an integer greater than 1 as valid radix']. - denominator := self nextUnsignedIntegerBase: base]. - self readExponent ifTrue: [denominator := denominator * (base raisedToInteger: exponent)]. - ^numerator / denominator! Item was removed: - ----- Method: SqNumberParser>>nextFractionBase: (in category 'parsing-public') ----- - nextFractionBase: aRadix - | numerator denominator | - base := aRadix. - neg := self peekSignIsMinus. - (integerPart := self nextUnsignedIntegerOrNilBase: base) - ifNil: [^self expected: 'a digit between 0 and ' , (Character digitValue: aRadix)]. - numerator := neg - ifTrue: [integerPart negated] - ifFalse: [integerPart]. - self readExponent ifTrue: [numerator := numerator * (base raisedToInteger: exponent)]. - (sourceStream peekFor: $/) ifFalse: [^numerator]. - (denominator := self nextUnsignedIntegerOrNilBase: base) - ifNil: - [sourceStream skip: -1. "Not a valid denominator, ungobble / and return numerator" - ^numerator]. - self readExponent ifTrue: [denominator := denominator * (base raisedToInteger: exponent)]. - ^numerator / denominator! Item was removed: - ----- Method: SqNumberParser>>nextInteger (in category 'parsing-public') ----- - nextInteger - "Read an Integer from sourceStream, asnwser that Integer. - In Smalltalk syntax, a radix can be specified, and an exponent too." - - | numberOfTrailingZeroInIntegerPart | - base := self defaultBase. - neg := self peekSignIsMinus. - integerPart := self nextUnsignedIntegerOrNilBase: base. - numberOfTrailingZeroInIntegerPart := nDigits - lastNonZero. - (sourceStream peekFor: $r) - ifTrue: ["<base>r<integer>" - (base := integerPart) < 2 - ifTrue: [ - sourceStream skip: -1. - ^ self expected: 'an integer greater than 1 as valid radix']. - self peekSignIsMinus - ifTrue: [neg := neg not]. - integerPart := self nextUnsignedIntegerBase: base. - numberOfTrailingZeroInIntegerPart := nDigits - lastNonZero]. - ^ self makeIntegerOrScaledInteger! Item was removed: - ----- Method: SqNumberParser>>nextNumber (in category 'parsing-public') ----- - nextNumber - "main method for reading a number. - This one can read Float Integer and ScaledDecimal" - - | numberOfTrailingZeroInIntegerPart | - base := self defaultBase. - neg := self peekSignIsMinus. - integerPart := self nextUnsignedIntegerOrNilBase: base. - integerPart ifNil: [ - "This is not a regular number beginning with a digit - It is time to check for exceptional condition NaN and Infinity" - ^self readNamedFloatOrFail]. - numberOfTrailingZeroInIntegerPart := nDigits - lastNonZero. - (sourceStream peekFor: $r) - ifTrue: ["<base>r<integer>" - (base := integerPart) < 2 - ifTrue: [ - sourceStream skip: -1. - ^ self expected: 'an integer greater than 1 as valid radix']. - self peekSignIsMinus - ifTrue: [neg := neg not]. - integerPart := self nextUnsignedIntegerBase: base. - numberOfTrailingZeroInIntegerPart := nDigits - lastNonZero]. - ^ (sourceStream peekFor: $.) - ifTrue: [self readNumberWithFractionPartNumberOfTrailingZeroInIntegerPart: numberOfTrailingZeroInIntegerPart] - ifFalse: [self makeIntegerOrScaledInteger]! Item was removed: - ----- Method: SqNumberParser>>nextNumberBase: (in category 'parsing-public') ----- - nextNumberBase: b - "Method for reading a number without radix prefix. - This one can read Float Integer and ScaledDecimal" - - | numberOfTrailingZeroInIntegerPart | - base := b. - neg := sourceStream peekFor: $-. - integerPart := self nextUnsignedIntegerOrNilBase: base. - integerPart ifNil: [ - "This is not a regular number beginning with a digit - It is time to check for exceptional condition NaN and Infinity" - ^self readNamedFloatOrFail]. - numberOfTrailingZeroInIntegerPart := nDigits - lastNonZero. - ^ (sourceStream peekFor: $.) - ifTrue: [self readNumberWithFractionPartNumberOfTrailingZeroInIntegerPart: numberOfTrailingZeroInIntegerPart] - ifFalse: [self makeIntegerOrScaledInteger]! Item was removed: - ----- Method: SqNumberParser>>nextScaledDecimal (in category 'parsing-public') ----- - nextScaledDecimal - "Main method for reading a (scaled) decimal number. - Good Gracious, do not accept a decimal in another base than 10!! - In other words, do not accept radix notation like 2r1.1, even not 10r5.3 - Do not accept exponent notation neither, like 1.0e-3" - - | numberOfNonZeroFractionDigits numberOfTrailingZeroInFractionPart | - base := self defaultBase. - neg := sourceStream peekFor: $-. - integerPart := self nextUnsignedIntegerBase: base. - (sourceStream peekFor: $.) - ifTrue: [fractionPart := self nextUnsignedIntegerOrNilBase: base. - fractionPart ifNil: ["Oops, the decimal point seems not part of this number" - sourceStream skip: -1. - ^ neg - ifTrue: [integerPart negated asScaledDecimal: 0] - ifFalse: [integerPart asScaledDecimal: 0]]. - numberOfNonZeroFractionDigits := lastNonZero. - numberOfTrailingZeroInFractionPart := nDigits - lastNonZero. - (self readScaleWithDefaultNumberOfDigits: nDigits) - ifFalse: ["No scale were provided. use number of digits after decimal point as scale" - scale := nDigits]. - ^self makeScaledDecimalWithNumberOfNonZeroFractionDigits: numberOfNonZeroFractionDigits andNumberOfTrailingZeroInFractionPart: numberOfTrailingZeroInFractionPart]. - self readScaleWithDefaultNumberOfDigits: 0. - neg ifTrue: [integerPart := integerPart negated]. - ^integerPart asScaledDecimal: scale! Item was removed: - ----- Method: SqNumberParser>>nextUnsignedInteger (in category 'parsing-public') ----- - nextUnsignedInteger - "Read an unsigned Integer from sourceStream, asnwser that Integer. - In Smalltalk syntax, a radix can be specified, and an exponent too." - - base := self defaultBase. - neg := false. - integerPart := self nextUnsignedIntegerOrNilBase: base. - (sourceStream peekFor: $r) - ifTrue: ["<base>r<integer>" - (base := integerPart) < 2 - ifTrue: [ - sourceStream skip: -1. - ^ self expected: 'an integer greater than 1 as valid radix']. - integerPart := self nextUnsignedIntegerBase: base]. - ^ self makeIntegerOrScaledInteger! Item was removed: - ----- Method: SqNumberParser>>readFractionPartNumberOfTrailingZeroInIntegerPart: (in category 'parsing-private') ----- - readFractionPartNumberOfTrailingZeroInIntegerPart: numberOfTrailingZeroInIntegerPart - "at this stage, sign integerPart and a decimal point have been read. - try and form a number with a fractionPart" - - | numberOfNonZeroFractionDigits numberOfTrailingZeroInFractionPart mantissa value | - fractionPart := self nextUnsignedIntegerOrNilBase: base. - fractionPart ifNil: ["No fractionPart found, ungobble the decimal point and return the integerPart" - sourceStream skip: -1. - ^ neg - ifTrue: [integerPart negated] - ifFalse: [integerPart]]. - numberOfNonZeroFractionDigits := lastNonZero. - numberOfTrailingZeroInFractionPart := nDigits - lastNonZero. - self readExponent. - fractionPart isZero - ifTrue: [mantissa := integerPart - // (base raisedToInteger: numberOfTrailingZeroInIntegerPart). - exponent := exponent + numberOfTrailingZeroInIntegerPart] - ifFalse: [mantissa := integerPart - * (base raisedToInteger: numberOfNonZeroFractionDigits) + (fractionPart // (base raisedToInteger: numberOfTrailingZeroInFractionPart)). - exponent := exponent - numberOfNonZeroFractionDigits]. - - value := exponent positive - ifTrue: [mantissa * (base raisedToInteger: exponent)] - ifFalse: [mantissa / (base raisedToInteger: exponent negated)]. - ^ neg - ifTrue: [value negated] - ifFalse: [value]! Item was removed: - ----- Method: SqNumberParser>>readNamedFloatOrFail (in category 'parsing-private') ----- - readNamedFloatOrFail - "This method is used when there is no digit encountered: - It try and read a named Float NaN or Infinity. - Negative sign for -Infinity has been read before sending this method, and is indicated in the neg inst.var. - Fail if no named Float is found" - - neg ifFalse: [(sourceStream nextMatchAll: 'NaN') - ifTrue: [^ Float nan]]. - (sourceStream nextMatchAll: 'Infinity') - ifTrue: [^ neg - ifTrue: [Float negativeInfinity] - ifFalse: [Float infinity]]. - ^self expected: 'a digit between 0 and ' , (String with: (Character digitValue: base - 1))! Item was removed: - ----- Method: SqNumberParser>>readNumberWithFractionPartNumberOfTrailingZeroInIntegerPart: (in category 'parsing-private') ----- - readNumberWithFractionPartNumberOfTrailingZeroInIntegerPart: numberOfTrailingZeroInIntegerPart - "at this stage, sign integerPart and a decimal point have been read. - try and form a number with a fractionPart" - - | numberOfNonZeroFractionDigits numberOfTrailingZeroInFractionPart mantissa value | - fractionPart := self nextUnsignedIntegerOrNilBase: base. - fractionPart ifNil: ["No fractionPart found,ungobble the decimal point and return the integerPart" - sourceStream skip: -1. - ^ neg - ifTrue: [integerPart negated] - ifFalse: [integerPart]]. - numberOfNonZeroFractionDigits := lastNonZero. - numberOfTrailingZeroInFractionPart := nDigits - lastNonZero. - self readExponent - ifFalse: [(self readScaleWithDefaultNumberOfDigits: nDigits) - ifTrue: [^self makeScaledDecimalWithNumberOfNonZeroFractionDigits: numberOfNonZeroFractionDigits - andNumberOfTrailingZeroInFractionPart: numberOfTrailingZeroInFractionPart]]. - - fractionPart isZero - ifTrue: [mantissa := integerPart - // (base raisedToInteger: numberOfTrailingZeroInIntegerPart). - exponent := exponent + numberOfTrailingZeroInIntegerPart] - ifFalse: [mantissa := integerPart - * (base raisedToInteger: numberOfNonZeroFractionDigits) + (fractionPart // (base raisedToInteger: numberOfTrailingZeroInFractionPart)). - exponent := exponent - numberOfNonZeroFractionDigits]. - - value := self makeFloatFromMantissa: mantissa exponent: exponent base: base. - ^ neg - ifTrue: [value isZero - ifTrue: [Float negativeZero] - ifFalse: [value negated]] - ifFalse: [value]! Item was removed: - ----- Method: SqNumberParser>>readScaleWithDefaultNumberOfDigits: (in category 'parsing-private') ----- - readScaleWithDefaultNumberOfDigits: anInteger - "Read the scale if any and store it into scale instance Variable. - Answer true if found, answer false if none. - The scale is specified by letter s, optionnally followed by a positive integer in base 10. - If no integer is specified, that means using as many digits as provided after the fraction separator, as provided by parameter anInteger. - A letter s followed by another letter is not considered as a scale specification, because it could be part of a message." - - scale := 0. - sourceStream atEnd - ifTrue: [ ^ false ]. - (sourceStream peekFor: $s) - ifFalse: [ ^ false ]. - scale := self nextUnsignedIntegerOrNilBase: self defaultBase. - scale - ifNil: [ - scale := anInteger. - (sourceStream peek ifNil: [ false ] ifNotNil: [ :nextChar | nextChar isLetter ]) - ifTrue: [ - sourceStream skip: -1. "ungobble the s" - ^ false ] - ifFalse: [ ^ true ] ]. - ^ true! Item was removed: - Model subclass: #StringHolder - instanceVariableNames: 'contents' - classVariableNames: '' - poolDictionaries: '' - category: 'Kernel-Models'! - - !StringHolder commentStamp: '<historical>' prior: 0! - I am a kind of Model that includes a piece of text. In some cases, the text can be edited, and in some the text is a method. - - Categories 'code pane menu' and 'message list menu' are messages that may be called by my menus when the text is a method, and when some pane is a list of methods. Other of my subclasses may ignore these two catagories altogether.! Item was removed: - ----- Method: StringHolder class>>initialize (in category 'class initialization') ----- - initialize - "The class variables were initialized once, and subsequently filled with - information. Re-executing this method is therefore dangerous." - - "workSpace := StringHolder new" - - "StringHolder initialize"! Item was removed: - ----- Method: StringHolder>>acceptContents: (in category 'accessing') ----- - acceptContents: aString - "Set aString to be the contents of the receiver. Return true cuz happy" - - self contents: aString. - ^ true! Item was removed: - ----- Method: StringHolder>>annotation (in category 'toolbuilder') ----- - annotation - ^''! Item was removed: - ----- Method: StringHolder>>buildCodePaneWith: (in category 'toolbuilder') ----- - buildCodePaneWith: builder - | textSpec | - textSpec := builder pluggableTextSpec new. - textSpec - model: self; - getText: #contents; - setText: #contents:notifying:; - selection: #contentsSelection; - menu: #codePaneMenu:shifted:. - ^textSpec! Item was removed: - ----- Method: StringHolder>>buildOptionalButtonsWith: (in category 'toolbuilder') ----- - buildOptionalButtonsWith: builder - - | panelSpec | - panelSpec := builder pluggablePanelSpec new. - panelSpec children: OrderedCollection new. - self optionalButtonPairs do:[:spec| - | buttonSpec | - buttonSpec := builder pluggableActionButtonSpec new. - buttonSpec model: self. - buttonSpec label: spec first. - buttonSpec action: spec second. - spec size > 2 ifTrue:[buttonSpec help: spec third]. - panelSpec children add: buttonSpec. - ]. - panelSpec layout: #horizontal. "buttons" - ^panelSpec! Item was removed: - ----- Method: StringHolder>>buildWith: (in category 'toolbuilder') ----- - buildWith: builder - | windowSpec | - windowSpec := self buildWindowWith: builder specs: { - (0 at 0corner: 1 at 1) -> [self buildCodePaneWith: builder]. - }. - ^builder build: windowSpec! Item was removed: - ----- Method: StringHolder>>classCommentIndicated (in category 'accessing') ----- - classCommentIndicated - "Answer true iff we're viewing the class comment." - ^false! Item was removed: - ----- Method: StringHolder>>clearUserEditFlag (in category 'user edits') ----- - clearUserEditFlag - "Clear the hasUnacceptedEdits flag in all my dependent views." - - self changed: #clearUserEdits! Item was removed: - ----- Method: StringHolder>>contents (in category 'accessing') ----- - contents - "Answer the contents that the receiver is holding--presumably a string." - - ^contents! Item was removed: - ----- Method: StringHolder>>contents: (in category 'accessing') ----- - contents: textOrString - "Set textOrString to be the contents of the receiver." - - contents := textOrString "asString"! Item was removed: - ----- Method: StringHolder>>contentsSelection (in category 'accessing') ----- - contentsSelection - "Return the interval of text in the code pane to select when I set the pane's contents" - - ^ 1 to: 0 "null selection"! Item was removed: - ----- Method: StringHolder>>defaultContents (in category 'initialize-release') ----- - defaultContents - - ^''! Item was removed: - ----- Method: StringHolder>>doItContext (in category 'evaluation') ----- - doItContext - "Answer the context in which a text selection can be evaluated." - - ^nil! Item was removed: - ----- Method: StringHolder>>doItReceiver (in category 'evaluation') ----- - doItReceiver - "Answer the object that should be informed of the result of evaluating a - text selection." - - ^nil! Item was removed: - ----- Method: StringHolder>>initialize (in category 'initialize-release') ----- - initialize - "Initialize the state of the receiver with its default contents." - - contents := self defaultContents. - ! Item was removed: - ----- Method: StringHolder>>noteAcceptanceOfCodeFor: (in category 'accessing') ----- - noteAcceptanceOfCodeFor: aSelector - "A method has possibly been submitted for the receiver with aSelector as its selector; If the receiver wishes to take soem action here is a chance for it to do so" - ! Item was removed: - ----- Method: StringHolder>>okToChange (in category 'user edits') ----- - okToChange - - self canDiscardEdits ifTrue: [^ true]. - self changed: #wantToChange. "Solicit cancel from view" - ^ self canDiscardEdits - ! Item was removed: - ----- Method: StringHolder>>optionalButtonPairs (in category 'toolbuilder') ----- - optionalButtonPairs - "Answer a tuple (formerly pairs) defining buttons, in the format: - button label - selector to send - help message" - ^#()! Item was removed: - ----- Method: StringHolder>>reformulateList (in category 'accessing') ----- - reformulateList - "If the receiver has a way of reformulating its message list, here is a chance for it to do so"! Item was removed: - ----- Method: StringHolder>>reformulateListNoting: (in category 'accessing') ----- - reformulateListNoting: newSelector - "A method has possibly been submitted for the receiver with newSelector as its selector; If the receiver has a way of reformulating its message list, here is a chance for it to do so" - - ^ self reformulateList! Item was removed: - ----- Method: StringHolder>>selectedClassName (in category 'accessing') ----- - selectedClassName - "I may know what class is currently selected" - - ^self selectedClass ifNotNil: [:selectedClass| selectedClass name]! Item was removed: - ----- Method: StringHolder>>selectedClassOrMetaClass (in category 'accessing') ----- - selectedClassOrMetaClass - - ^ self selectedClass "I don't know any better"! Item was removed: - ----- Method: StringHolder>>selectedClassOrMetaClassName (in category 'accessing') ----- - selectedClassOrMetaClassName - "I may know what class is currently selected" - - ^self selectedClassOrMetaClass ifNotNil: [:selectedClass| selectedClass name]! Item was removed: - ----- Method: StringHolder>>selectedMessageName (in category 'accessing') ----- - selectedMessageName - - ^ nil! Item was removed: - ----- Method: StringHolder>>setContents: (in category 'initialize-release') ----- - setContents: aString - - self contents = aString ifTrue: [^ self]. - self contents: aString. - self changed: #contents.! Item was removed: - ----- Method: StringHolder>>textContents: (in category 'accessing') ----- - textContents: aStringOrText - "Set aStringOrText to be the contents of the receiver." - - contents := aStringOrText! Item was removed: - NotImplemented subclass: #SubclassResponsibility - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Kernel-Exceptions'! - - !SubclassResponsibility commentStamp: 'fbs 1/26/2013 00:20' prior: 0! - I am signalled when a subclass fails to implement an "abstract method" and something sends an instance of this subclass the unimplemented message.! Item was removed: - ProcessLocalVariable subclass: #ThreadSafeRandom - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Kernel-Numbers'! - - !ThreadSafeRandom commentStamp: 'ul 12/17/2014 15:18' prior: 0! - I am a ProcessLocalVariable. I hold the an instance of Random for each process. If the process doesn't have such instance yet, then my class-side #default message will create one. The instance should not be shared among processes. - - I implement all methods of Random's accessing category on the class side, and proxy them to the instance. If you want to use any other methods, or the object itself, then use #value directly.! Item was removed: - ----- Method: ThreadSafeRandom class>>default (in category 'accessing') ----- - default - - ^self value: Random new! Item was removed: - ----- Method: ThreadSafeRandom class>>next (in category 'accessing') ----- - next - - ^self value next! Item was removed: - ----- Method: ThreadSafeRandom class>>next: (in category 'accessing') ----- - next: anInteger - - ^self value next: anInteger! Item was removed: - ----- Method: ThreadSafeRandom class>>next:into: (in category 'accessing') ----- - next: anInteger into: anArray - - ^self value next: anInteger into: anArray! Item was removed: - ----- Method: ThreadSafeRandom class>>nextInt: (in category 'accessing') ----- - nextInt: anInteger - - ^self value nextInt: anInteger! Item was removed: - Notification subclass: #TimedOut - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Kernel-Exceptions'! - - !TimedOut commentStamp: 'brp 10/21/2004 17:47' prior: 0! - I am signalled by #duration:timeoutDo: if the receiving block takes too long to execute. - - I am signalled by a watchdog process spawned by #duration:timeoutDo: and caught in the same method. - - I am not intended to be used elsewhere.! Item was removed: - Boolean subclass: #True - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Kernel-Objects'! - - !True commentStamp: '<historical>' prior: 0! - True defines the behavior of its single instance, true -- logical assertion. Notice how the truth-value checks become direct message sends, without the need for explicit testing. - - Be aware however that most of these methods are not sent as real messages in normal use. Most are inline coded by the compiler as test and jump bytecodes - avoiding the overhead of the full message sends. So simply redefining these methods here will have no effect.! Item was removed: - ----- Method: True class>>initializedInstance (in category 'as yet unclassified') ----- - initializedInstance - ^ true! Item was removed: - ----- Method: True>>& (in category 'logical operations') ----- - & aBoolean - "Evaluating conjunction -- could answer aBoolean since receiver is true, but let the VM quickly check the type of the argument instead." - - aBoolean ifFalse: [ ^false ]. - ^true! Item was removed: - ----- Method: True>>==> (in category 'logical operations') ----- - ==> aBlock - ^aBlock value! Item was removed: - ----- Method: True>>and: (in category 'controlling') ----- - and: alternativeBlock - "Nonevaluating conjunction -- answer the value of alternativeBlock since - the receiver is true." - - ^alternativeBlock value! Item was removed: - ----- Method: True>>asBit (in category 'printing') ----- - asBit - - ^ 1! Item was removed: - ----- Method: True>>ifFalse: (in category 'controlling') ----- - ifFalse: alternativeBlock - "Since the condition is true, the value is the true alternative, which is nil. - Execution does not actually reach here because the expression is compiled - in-line." - - ^nil! Item was removed: - ----- Method: True>>ifFalse:ifTrue: (in category 'controlling') ----- - ifFalse: falseAlternativeBlock ifTrue: trueAlternativeBlock - "Answer the value of trueAlternativeBlock. Execution does not - actually reach here because the expression is compiled in-line." - - ^trueAlternativeBlock value! Item was removed: - ----- Method: True>>ifTrue: (in category 'controlling') ----- - ifTrue: alternativeBlock - "Answer the value of alternativeBlock. Execution does not actually - reach here because the expression is compiled in-line." - - ^alternativeBlock value! Item was removed: - ----- Method: True>>ifTrue:ifFalse: (in category 'controlling') ----- - ifTrue: trueAlternativeBlock ifFalse: falseAlternativeBlock - "Answer with the value of trueAlternativeBlock. Execution does not - actually reach here because the expression is compiled in-line." - - ^trueAlternativeBlock value! Item was removed: - ----- Method: True>>not (in category 'logical operations') ----- - not - "Negation--answer false since the receiver is true." - - ^false! Item was removed: - ----- Method: True>>or: (in category 'controlling') ----- - or: alternativeBlock - "Nonevaluating disjunction -- answer true since the receiver is true." - - ^self! Item was removed: - ----- Method: True>>printOn: (in category 'printing') ----- - printOn: aStream - - aStream nextPutAll: 'true'! Item was removed: - ----- Method: True>>xor: (in category 'logical operations') ----- - xor: aBoolean - "aBoolean is either a boolean, or an object who's #value returns a boolean (usually a block)." - ^aBoolean value ifTrue: [ false ] ifFalse: [ true ]! Item was removed: - ----- Method: True>>| (in category 'logical operations') ----- - | aBoolean - "Evaluating disjunction (OR) -- answer true since the receiver is true, but let the VM quickly check the type of the argument first." - - aBoolean ifTrue: [ ^true ]. - ^true! Item was removed: - Object subclass: #UndefinedObject - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Kernel-Objects'! - - !UndefinedObject commentStamp: '<historical>' prior: 0! - I describe the behavior of my sole instance, nil. nil represents a prior value for variables that have not been initialized, or for results which are meaningless.! Item was removed: - ----- Method: UndefinedObject class>>allInstancesDo: (in category 'accessing') ----- - allInstancesDo: aBlock - "It is well known there is a single instance" - - aBlock value: nil! Item was removed: - ----- Method: UndefinedObject class>>initializedInstance (in category 'instance creation') ----- - initializedInstance - ^ nil! Item was removed: - ----- Method: UndefinedObject class>>new (in category 'instance creation') ----- - new - self error: 'You may not create any more undefined objects--use nil'! Item was removed: - ----- Method: UndefinedObject>>addDependent: (in category 'dependents access') ----- - addDependent: ignored - "Refer to the comment in Object|dependents." - - self error: 'Nil should not have dependents'! Item was removed: - ----- Method: UndefinedObject>>addSubclass: (in category 'class hierarchy') ----- - addSubclass: aClass - "Ignored -- necessary to support disjoint class hierarchies"! Item was removed: - ----- Method: UndefinedObject>>asSetElement (in category 'sets support') ----- - asSetElement - "Since nil is a singleton, we need only a single wrapper instance to represent it in set, - created in advance" - ^ SetElement withNil! Item was removed: - ----- Method: UndefinedObject>>canHandleSignal: (in category 'bottom context') ----- - canHandleSignal: exception - "When no more handler (on:do:) context left in sender chain this gets called" - - ^ false! Item was removed: - ----- Method: UndefinedObject>>deepCopy (in category 'copying') ----- - deepCopy - "Only one instance of UndefinedObject should ever be made, so answer - with self."! Item was removed: - ----- Method: UndefinedObject>>environment (in category 'class hierarchy') ----- - environment - "Necessary to support disjoint class hierarchies." - - ^self class environment! Item was removed: - ----- Method: UndefinedObject>>from3DS: (in category '3ds parser support') ----- - from3DS: aDictionary - ^aDictionary! Item was removed: - ----- Method: UndefinedObject>>haltIfNil (in category 'testing') ----- - haltIfNil - self halt! Item was removed: - ----- Method: UndefinedObject>>handleSignal: (in category 'bottom context') ----- - handleSignal: exception - "When no more handler (on:do:) context left in sender chain this gets called. Return from signal with default action." - - ^ exception resumeUnchecked: exception defaultAction! Item was removed: - ----- Method: UndefinedObject>>ifNil: (in category 'testing') ----- - ifNil: aBlock - "A convenient test, in conjunction with Object ifNil:" - - ^ aBlock value! Item was removed: - ----- Method: UndefinedObject>>ifNil:ifNotNil: (in category 'testing') ----- - ifNil: nilBlock ifNotNil: ifNotNilBlock - "Evaluate the block for nil because I'm == nil" - - ^ nilBlock value! Item was removed: - ----- Method: UndefinedObject>>ifNotNil: (in category 'testing') ----- - ifNotNil: aBlock - "A convenient test, in conjunction with Object ifNotNil:" - - ^ self! Item was removed: - ----- Method: UndefinedObject>>ifNotNil:ifNil: (in category 'testing') ----- - ifNotNil: ifNotNilBlock ifNil: nilBlock - "If I got here, I am nil, so evaluate the block nilBlock" - - ^ nilBlock value! Item was removed: - ----- Method: UndefinedObject>>isEmptyOrNil (in category 'testing') ----- - isEmptyOrNil - "Answer whether the receiver contains any elements, or is nil. Useful in numerous situations where one wishes the same reaction to an empty collection or to nil" - ^ true! Item was removed: - ----- Method: UndefinedObject>>isLiteral (in category 'testing') ----- - isLiteral - ^ true! Item was removed: - ----- Method: UndefinedObject>>isNil (in category 'testing') ----- - isNil - "Refer to the comment in Object|isNil." - - ^true! Item was removed: - ----- Method: UndefinedObject>>literalScannedAs:environment:notifying: (in category 'class hierarchy') ----- - literalScannedAs: scannedLiteral environment: anEnvironment notifying: requestor - ^ scannedLiteral! Item was removed: - ----- Method: UndefinedObject>>notNil (in category 'testing') ----- - notNil - "Refer to the comment in Object|notNil." - - ^false! Item was removed: - ----- Method: UndefinedObject>>parserClass (in category 'compiling') ----- - parserClass - - ^ Compiler parserClass! Item was removed: - ----- Method: UndefinedObject>>printAsLiteralOn: (in category 'printing') ----- - printAsLiteralOn: aStream - ^self printOn: aStream! Item was removed: - ----- Method: UndefinedObject>>printOn: (in category 'printing') ----- - printOn: aStream - "Refer to the comment in Object|printOn:." - - aStream nextPutAll: 'nil'! Item was removed: - ----- Method: UndefinedObject>>release (in category 'dependents access') ----- - release - "Nil release is a no-op"! Item was removed: - ----- Method: UndefinedObject>>removeObsoleteSubclass: (in category 'class hierarchy') ----- - removeObsoleteSubclass: aClass - "Ignored -- necessary to support disjoint class hierarchies"! Item was removed: - ----- Method: UndefinedObject>>removeSubclass: (in category 'class hierarchy') ----- - removeSubclass: aClass - "Ignored -- necessary to support disjoint class hierarchies"! Item was removed: - ----- Method: UndefinedObject>>shallowCopy (in category 'copying') ----- - shallowCopy - "Only one instance of UndefinedObject should ever be made, so answer - with self."! Item was removed: - ----- Method: UndefinedObject>>storeOn: (in category 'printing') ----- - storeOn: aStream - "Refer to the comment in Object|storeOn:." - - aStream nextPutAll: 'nil'! Item was removed: - ----- Method: UndefinedObject>>subclass:instanceVariableNames:classVariableNames:poolDictionaries:category: (in category 'class hierarchy') ----- - subclass: nameOfClass - instanceVariableNames: instVarNames - classVariableNames: classVarNames - poolDictionaries: poolDictnames - category: category - "Calling this method is now considered an accident. If you really want to create a class with a nil superclass, then create the class and then set the superclass using #superclass:" - Transcript show: ('Attempt to create ', nameOfClass, ' as a subclass of nil. Possibly a class is being loaded before its superclass.'); cr. - ^ProtoObject - subclass: nameOfClass - instanceVariableNames: instVarNames - classVariableNames: classVarNames - poolDictionaries: poolDictnames - category: category - ! Item was removed: - ----- Method: UndefinedObject>>subclassDefinerClass (in category 'class hierarchy') ----- - subclassDefinerClass - "For disjunct class hierarchies -- how should subclasses of nil be evaluated" - ^Compiler! Item was removed: - ----- Method: UndefinedObject>>subclasses (in category 'class hierarchy') ----- - subclasses - "Return all the subclasses of nil" - | classList | - classList := WriteStream on: Array new. - self subclassesDo:[:class| classList nextPut: class]. - ^classList contents! Item was removed: - ----- Method: UndefinedObject>>subclassesDo: (in category 'class hierarchy') ----- - subclassesDo: aBlock - "Evaluate aBlock with all subclasses of nil." - ^Class subclassesDo:[:cl| - cl isMeta ifTrue:[aBlock value: cl soleInstance]].! Item was removed: - ----- Method: UndefinedObject>>subclassesDoGently: (in category 'class hierarchy') ----- - subclassesDoGently: aBlock - "Evaluate aBlock with all subclasses of nil. Others are not direct subclasses of Class." - - ^ Class subclassesDoGently: [:cl | - cl isMeta ifTrue: [aBlock value: cl soleInstance]].! Item was removed: - ----- Method: UndefinedObject>>typeOfClass (in category 'class hierarchy') ----- - typeOfClass - "Necessary to support disjoint class hierarchies." - ^#normal! Item was removed: - ----- Method: UndefinedObject>>veryDeepCopyWith: (in category 'copying') ----- - veryDeepCopyWith: deepCopier - "Return self. I can't be copied. Do not record me."! Item was removed: - Exception subclass: #UnhandledError - instanceVariableNames: 'exception' - classVariableNames: '' - poolDictionaries: '' - category: 'Kernel-Exceptions'! - - !UnhandledError commentStamp: 'mt 8/25/2015 14:42' prior: 0! - This is a wrapper for an unhandled error. Having this, process stepping is able to correctly fire other unhandled errors. See Process >> #stepToHome: for further explanations.! Item was removed: - ----- Method: UnhandledError class>>signalForException: (in category 'as yet unclassified') ----- - signalForException: anError - "Very important entry point for analysis stack when stepping in a debugging session. See Process >> #stepToHome: for further explanations." - - ^ self new - exception: anError; - signal! Item was removed: - ----- Method: UnhandledError>>defaultAction (in category 'priv handling') ----- - defaultAction - "The current computation is terminated. The cause of the error should be logged or reported to the user. If the program is operating in an interactive debugging environment the computation should be suspended and the debugger activated." - - ^ (Smalltalk classNamed: #ToolSet) - ifNotNil: [:ts | ts handleError: self exception] - ifNil: [Processor activeProcess terminate]! Item was removed: - ----- Method: UnhandledError>>exception (in category 'accessing') ----- - exception - - ^ exception! Item was removed: - ----- Method: UnhandledError>>exception: (in category 'accessing') ----- - exception: anError - - exception := anError! Item was removed: - ----- Method: UnhandledError>>isResumable (in category 'priv handling') ----- - isResumable - - ^ false! Item was removed: - UnhandledError subclass: #UnhandledWarning - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Kernel-Exceptions'! Item was removed: - ----- Method: UnhandledWarning>>defaultAction (in category 'priv handling') ----- - defaultAction - - ^ (Smalltalk classNamed: #ToolSet) - ifNotNil: [:ts | ts handleWarning: self exception] - ifNil: ["Ignore like a Notification." nil]! Item was removed: - Model subclass: #ValueHolder - instanceVariableNames: 'contents' - classVariableNames: '' - poolDictionaries: '' - category: 'Kernel-Models'! Item was removed: - ----- Method: ValueHolder>>contents (in category 'accessing') ----- - contents - ^contents! Item was removed: - ----- Method: ValueHolder>>contents: (in category 'accessing') ----- - contents: newContents - - contents = newContents ifTrue: [^ self]. - contents := newContents. - self contentsChanged! Item was removed: - Notification subclass: #Warning - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Kernel-Exceptions'! - Warning class - instanceVariableNames: 'suppressed resetOnStartUp'! - - !Warning commentStamp: '<historical>' prior: 0! - A Warning is a Notification which by default should be brought to the attention of the user.! - Warning class - instanceVariableNames: 'suppressed resetOnStartUp'! Item was removed: - ----- Method: Warning class>>cleanUp: (in category 'class initialization') ----- - cleanUp: aggressive - - aggressive ifTrue: [self resetAllWarnings].! Item was removed: - ----- Method: Warning class>>initialize (in category 'class initialization') ----- - initialize - - Smalltalk addToStartUpList: self.! Item was removed: - ----- Method: Warning class>>resetAllWarnings (in category 'suppress and reset') ----- - resetAllWarnings - - self withAllSubclassesDo: [:warningClass | - warningClass resetWarnings].! Item was removed: - ----- Method: Warning class>>resetOnStartUp (in category 'accessing') ----- - resetOnStartUp - "If true, do not suppress this kind of warning anymore after image start up. This flag will be reset to false after doing this." - - ^ resetOnStartUp ifNil: [false]! Item was removed: - ----- Method: Warning class>>resetOnStartUp: (in category 'accessing') ----- - resetOnStartUp: aBoolean - - resetOnStartUp := aBoolean.! Item was removed: - ----- Method: Warning class>>resetWarnings (in category 'suppress and reset') ----- - resetWarnings - - self suppressed: false. - self resetOnStartUp: false.! Item was removed: - ----- Method: Warning class>>signal (in category 'instance creation') ----- - signal - - ^ self signal: nil! Item was removed: - ----- Method: Warning class>>signal: (in category 'instance creation') ----- - signal: signalerText - - ^ self suppressed - ifTrue: [nil] - ifFalse: [self new signal: signalerText]! Item was removed: - ----- Method: Warning class>>startUp: (in category 'class initialization') ----- - startUp: resuming - - resuming ifTrue: [ - self withAllSubclassesDo: [:warningClass | - warningClass resetOnStartUp ifTrue: [warningClass resetWarnings]]].! Item was removed: - ----- Method: Warning class>>suppressAndResetOnStartUp (in category 'suppress and reset') ----- - suppressAndResetOnStartUp - "Suppress this kind of warning but reset that after the next image start up." - - self suppressed: true. - self resetOnStartUp: true.! Item was removed: - ----- Method: Warning class>>suppressDuring: (in category 'suppress and reset') ----- - suppressDuring: aBlock - - self suppressed ifTrue: [^ aBlock value]. - - self suppressed: true. - ^ aBlock ensure: [self suppressed: false]! Item was removed: - ----- Method: Warning class>>suppressWarnings (in category 'suppress and reset') ----- - suppressWarnings - "Suppress this kind of warning." - - self suppressed: true.! Item was removed: - ----- Method: Warning class>>suppressed (in category 'accessing') ----- - suppressed - - ^ suppressed ifNil: [false]! Item was removed: - ----- Method: Warning class>>suppressed: (in category 'accessing') ----- - suppressed: aBoolean - - suppressed := aBoolean.! Item was removed: - ----- Method: Warning>>defaultAction (in category 'priv handling') ----- - defaultAction - "Inform the user of a Warning, giving them the choice of ignoring the warning (proceeding), debugging, or terminating the computation." - UnhandledWarning signalForException: self! Item was removed: - Object weakSubclass: #WeakMessageSend - instanceVariableNames: 'selector shouldBeNil arguments' - classVariableNames: '' - poolDictionaries: '' - category: 'Kernel-Objects'! - - !WeakMessageSend commentStamp: 'fn 12/10/2018 11:03' prior: 0! - Instances of WeakMessageSend encapsulate message sends to objects, like MessageSend. Unlike MessageSend it is not necessarily a valid message. A request to value only results in a send if in fact it is valid. - - See MessageSendComments also. WeakMessageSend is used primarily for event registration. - - Unlike MessageSend WeakMessageSend stores receiver (object receiving the message send) as the first and only element of its array as opposed to a named ivar. - But like MessageSend, it does have - selector Symbol -- message selector - arguments Array -- bound arguments - and it also has - shouldBeNil Array of Booleans -- used to track valid nil values in arguments array! Item was removed: - ----- Method: WeakMessageSend class>>new (in category 'instance creation') ----- - new - ^self new: 1 - ! Item was removed: - ----- Method: WeakMessageSend class>>receiver:selector: (in category 'instance creation') ----- - receiver: anObject selector: aSymbol - ^ self receiver: anObject selector: aSymbol arguments: #() - ! Item was removed: - ----- Method: WeakMessageSend class>>receiver:selector:argument: (in category 'instance creation') ----- - receiver: anObject selector: aSymbol argument: aParameter - ^ self receiver: anObject selector: aSymbol arguments: (Array with: aParameter) - ! Item was removed: - ----- Method: WeakMessageSend class>>receiver:selector:arguments: (in category 'instance creation') ----- - receiver: anObject selector: aSymbol arguments: anArray - ^ self new - receiver: anObject; - selector: aSymbol; - arguments: anArray - ! Item was removed: - ----- Method: WeakMessageSend>>= (in category 'comparing') ----- - = anObject - "Compare equal to equivalent MessageSend" - ^ anObject isMessageSend - and: [self receiver == anObject receiver - and: [selector == anObject selector - and: [(Array withAll: self arguments) = (Array withAll: anObject arguments)]]] - ! Item was removed: - ----- Method: WeakMessageSend>>arguments (in category 'accessing') ----- - arguments - ^arguments ifNil: [ Array new ] - ! Item was removed: - ----- Method: WeakMessageSend>>arguments: (in category 'accessing') ----- - arguments: anArray - arguments := WeakArray withAll: anArray. - "no reason this should be a WeakArray" - shouldBeNil := Array withAll: (anArray collect: [ :ea | ea isNil ]). - ! Item was removed: - ----- Method: WeakMessageSend>>asMessageSend (in category 'converting') ----- - asMessageSend - ^MessageSend receiver: self receiver selector: selector arguments: (Array withAll: self arguments) - ! Item was removed: - ----- Method: WeakMessageSend>>asMinimalRepresentation (in category 'converting') ----- - asMinimalRepresentation - - ^self isReceiverOrAnyArgumentGarbage - ifTrue: [ nil ] - ifFalse: [ self ]! Item was removed: - ----- Method: WeakMessageSend>>collectArguments: (in category 'private') ----- - collectArguments: anArgArray - "Private" - | staticArgs | - staticArgs := self arguments. - ^(anArgArray size = staticArgs size) - ifTrue: [anArgArray] - ifFalse: - [(staticArgs isEmpty - ifTrue: [ staticArgs := Array new: selector numArgs] - ifFalse: [Array withAll: staticArgs] ) - replaceFrom: 1 - to: (anArgArray size min: staticArgs size) - with: anArgArray - startingAt: 1] - ! Item was removed: - ----- Method: WeakMessageSend>>hash (in category 'comparing') ----- - hash - "work like MessageSend>>hash" - ^self receiver hash bitXor: selector hash - ! Item was removed: - ----- Method: WeakMessageSend>>isAnyArgumentGarbage (in category 'private') ----- - isAnyArgumentGarbage - "Make sure that my arguments haven't gone away" - arguments ifNotNil: [ - arguments with: shouldBeNil do: [ :arg :flag | - (flag not and: [arg isNil]) - ifTrue: [^true] - ] - ]. - ^false - ! Item was removed: - ----- Method: WeakMessageSend>>isMessageSend (in category 'testing') ----- - isMessageSend - ^true - ! Item was removed: - ----- Method: WeakMessageSend>>isReceiverGarbage (in category 'private') ----- - isReceiverGarbage - "Make sure that my receiver hasn't gone away" - ^self receiver isNil - ! Item was removed: - ----- Method: WeakMessageSend>>isReceiverOrAnyArgumentGarbage (in category 'private') ----- - isReceiverOrAnyArgumentGarbage - "Make sure that my receiver hasn't gone away" - ^self isReceiverGarbage - or: [self isAnyArgumentGarbage] - ! Item was removed: - ----- Method: WeakMessageSend>>printOn: (in category 'printing') ----- - printOn: aStream - - aStream - nextPutAll: self class name; - nextPut: $(. - selector printOn: aStream. - aStream nextPutAll: ' -> '. - self receiver printOn: aStream. - aStream nextPut: $) - ! Item was removed: - ----- Method: WeakMessageSend>>receiver (in category 'accessing') ----- - receiver - ^self at: 1 - ! Item was removed: - ----- Method: WeakMessageSend>>receiver: (in category 'accessing') ----- - receiver: anObject - self at: 1 put: anObject - ! Item was removed: - ----- Method: WeakMessageSend>>selector (in category 'accessing') ----- - selector - ^selector - ! Item was removed: - ----- Method: WeakMessageSend>>selector: (in category 'accessing') ----- - selector: aSymbol - selector := aSymbol - ! Item was removed: - ----- Method: WeakMessageSend>>value (in category 'evaluating') ----- - value - ^self valueOtherwise: []! Item was removed: - ----- Method: WeakMessageSend>>valueOtherwise: (in category 'evaluating') ----- - valueOtherwise: aBlock - - ^ arguments - ifNil: [ - self withEnsuredReceiverDo: [ :r | r perform: selector ] otherwise: aBlock ] - ifNotNil: [ - self - withEnsuredReceiverAndArgumentsDo: [ :r :a | - r - perform: selector - withArguments: a ] - otherwise: aBlock ]! Item was removed: - ----- Method: WeakMessageSend>>valueWithArguments: (in category 'evaluating') ----- - valueWithArguments: anArray - ^ self valueWithArguments: anArray otherwise: []! Item was removed: - ----- Method: WeakMessageSend>>valueWithArguments:otherwise: (in category 'evaluating') ----- - valueWithArguments: anArray otherwise: aBlock - | argsToUse | - - "Safe to use, because they are built before ensureing receiver and args..." - argsToUse := self collectArguments: anArray. - ^ self - withEnsuredReceiverAndArgumentsDo: [ :r :a | - r - perform: selector - withArguments: argsToUse ] - otherwise: aBlock! Item was removed: - ----- Method: WeakMessageSend>>valueWithEnoughArguments: (in category 'evaluating') ----- - valueWithEnoughArguments: anArray - "call the selector with enough arguments from arguments and anArray" - ^self - withEnsuredReceiverAndArgumentsDo: [ :r :a | - r - perform: selector - withArguments: a ] - withEnoughArguments: anArray - otherwise: [ ]! Item was removed: - ----- Method: WeakMessageSend>>withEnsuredReceiverAndArgumentsDo:otherwise: (in category 'private') ----- - withEnsuredReceiverAndArgumentsDo: aBlock otherwise: altBlock - "Grab real references to receiver and arguments. If they still exist, evaluate aBlock." - - "Return if my receiver has gone away" - | r a | - r := self receiver. - r ifNil: [ ^altBlock value ]. - - - "Make sure that my arguments haven't gone away" - a := Array withAll: self arguments. - a with: shouldBeNil do: [ :arg :flag | - arg ifNil: [ flag ifFalse: [ ^altBlock value ]] - ]. - - ^aBlock value: r value: a! Item was removed: - ----- Method: WeakMessageSend>>withEnsuredReceiverAndArgumentsDo:withEnoughArguments:otherwise: (in category 'private') ----- - withEnsuredReceiverAndArgumentsDo: aBlock withEnoughArguments: anArray otherwise: altBlock - "call the selector with enough arguments from arguments and anArray" - | r selfArgs enoughArgs | - r := self receiver. - r ifNil: [ ^altBlock value ]. - - selfArgs := self arguments. - selfArgs with: shouldBeNil do: [ :arg :flag | - arg ifNil: [ flag ifFalse: [ ^altBlock value ]] - ]. - - enoughArgs := Array new: selector numArgs. - enoughArgs replaceFrom: 1 - to: ( selfArgs size min: enoughArgs size) - with: selfArgs - startingAt: 1. - enoughArgs size > selfArgs size ifTrue: [ - enoughArgs replaceFrom: selfArgs size + 1 - to: (selfArgs size + anArray size min: enoughArgs size) - with: anArray - startingAt: 1. - ]. - ^aBlock value: r value: enoughArgs! Item was removed: - ----- Method: WeakMessageSend>>withEnsuredReceiverDo:otherwise: (in category 'private') ----- - withEnsuredReceiverDo: aBlock otherwise: altBlock - "Grab a real reference to receive. If still there, evaluate aBlock. - Use altBlock if my receiver has gone away." - ^self receiver - ifNil: [ altBlock value ] - ifNotNil: [:r | aBlock value: r ]! Item was removed: - ArithmeticError subclass: #ZeroDivide - instanceVariableNames: 'dividend' - classVariableNames: '' - poolDictionaries: '' - category: 'Kernel-Numbers-Exceptions'! - - !ZeroDivide commentStamp: '<historical>' prior: 0! - ZeroDivide may be signaled when a mathematical division by 0 is attempted.! Item was removed: - ----- Method: ZeroDivide class>>dividend: (in category 'exceptionInstantiator') ----- - dividend: argument - ^self new dividend: argument; yourself! Item was removed: - ----- Method: ZeroDivide class>>signalWithDividend: (in category 'signaling') ----- - signalWithDividend: aDividend - - ^(self dividend: aDividend) signal! Item was removed: - ----- Method: ZeroDivide>>dividend (in category 'exceptionDescription') ----- - dividend - "Answer the number that was being divided by zero." - - ^dividend! Item was removed: - ----- Method: ZeroDivide>>dividend: (in category 'exceptionBuilder') ----- - dividend: argument - "Specify the number that was being divided by zero." - - dividend := argument! Item was removed: - ----- Method: ZeroDivide>>isResumable (in category 'exceptionDescription') ----- - isResumable - "Determine whether an exception is resumable." - - ^true! Item was removed: - (PackageInfo named: 'Kernel') postscript: '"Inform the VM that it should update its image format number for multiple bytecode sets" - [CompiledCode byteCodeSetsKnownToTheVM. - CompiledCode preferredBytecodeSetEncoderClass = EncoderForSistaV1 - ifTrue: [CompiledCode multipleBytecodeSetsActive: true]] - on: Error do: ["missing VM support, do nothing"]'!
More information about the Squeak-dev mailing list |