[Pkg] The Trunk: Chronology-Core-cmm.2.mcz
commits at source.squeak.org
commits at source.squeak.org
Thu Mar 3 19:23:51 UTC 2016
Chris Muller uploaded a new version of Chronology-Core to project The Trunk:
http://source.squeak.org/trunk/Chronology-Core-cmm.2.mcz
==================== Summary ====================
Name: Chronology-Core-cmm.2
Author: cmm
Time: 3 March 2016, 1:16:34.699114 pm
UUID: 636b8fd8-011d-458c-9e27-cab8e3f913e5
Ancestors: Kernel-tfel.1001
Extracting Chronology from Kernel into Chronology-Core and Chronology-Tests.
=============== Diff against Kernel-tfel.1001 ===============
Item was removed:
- (PackageInfo named: 'Kernel') preamble: '((Mutex allInstances allSatisfy: [:m| (m instVarNamed: ''owner'') isNil])
- and: [Monitor allInstances allSatisfy: [:m| (m instVarNamed: ''ownerProcess'') isNil]]) ifFalse:
- [self error: ''Some Mutexes and/or Monitors are owned. Cannot safely mutate. ABort load and resolve this before loading for safety.'']'!
Item was changed:
+ SystemOrganization addCategory: #'Chronology-Core'!
- SystemOrganization addCategory: #'Kernel-Chronology'!
- 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>>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>>hasLiteralSuchThat: (in category 'testing') -----
- hasLiteralSuchThat: aBlock
- "Answer true if litBlock returns true for any literal in this array, even if embedded in further array structure.
- This method is only intended for private use by CompiledMethod hasLiteralSuchThat:"
- 1 to: self basicSize do: [:i |
- | propertyOrPragma "<Association|Pragma>" |
- propertyOrPragma := self basicAt: i.
- (propertyOrPragma isVariableBinding
- ifTrue: [(aBlock value: propertyOrPragma key)
- or: [(aBlock value: propertyOrPragma value)
- or: [propertyOrPragma value isArray
- and: [propertyOrPragma value hasLiteralSuchThat: aBlock]]]]
- ifFalse: [propertyOrPragma hasLiteralSuchThat: aBlock]) ifTrue:
- [^true]].
- ^false!
Item was removed:
- ----- Method: AdditionalMethodState>>hasLiteralThorough: (in category 'testing') -----
- hasLiteralThorough: literal
- "Answer true if any literal in these properties is literal,
- even if embedded in array structure."
- 1 to: self basicSize do: [:i |
- | propertyOrPragma "<Association|Pragma>" |
- propertyOrPragma := self basicAt: i.
- (propertyOrPragma isVariableBinding
- ifTrue: [propertyOrPragma key == literal
- or: [propertyOrPragma value == literal
- or: [propertyOrPragma value isArray
- and: [propertyOrPragma value hasLiteral: literal]]]]
- ifFalse: [propertyOrPragma hasLiteral: literal]) ifTrue:
- [^true]].
- ^false!
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:
- Halt 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:
- 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 'accessing') -----
- hasNoComment
- "Answer whether the class classified by the receiver has a comment."
-
- ^classComment == nil!
Item was removed:
- ----- Method: BasicClassOrganizer>>hasSubject (in category 'accessing') -----
- 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: anInstance
- "Change the class of anInstance 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>
- anInstance primitiveChangeClassTo: self basicNew.
- ^self!
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>>allInstancesEverywhereDo: (in category 'enumerating') -----
- allInstancesEverywhereDo: aBlock
- "Evaluate the argument, aBlock, for each of the current instances of the receiver. Including those in ImageSegments that are out on the disk. Bring each in briefly."
-
- self == UndefinedObject ifTrue: [^ aBlock value: nil].
- self allInstancesDo: aBlock.
- "Now iterate over instances in segments that are out on the disk."
- ImageSegment allSubInstancesDo: [:seg |
- seg allInstancesOf: self do: aBlock].
- !
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"
-
- | oldMethodOrNil |
- oldMethodOrNil := self lookupSelector: selector.
- self methodDict at: selector put: compiledMethod.
- compiledMethod methodClass: self.
- compiledMethod selector: selector.
-
- "Now flush Squeak's method cache, either by selector or by method"
- oldMethodOrNil == nil ifFalse: [oldMethodOrNil flushCache].
- 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' or: [ec == #'bad argument']) ifTrue:
- [^self handleFailingBasicNew: 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, either by selector or by method"
- oldMethod flushCache.
- 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: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)
- asSortedCollection: [: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 (MethodContext AdditionalMethodState et al)
- 4 = weak indexable objects with inst vars (WeakArray et al)
- 5 = weak non-indexable objects with inst vars (ephemerons) (Ephemeron)
- 6 = unused
- 7 = immediates (SmallInteger, Character)
- 8 = unused
- 9 = 64-bit indexable
- 10-11 = 32-bit indexable (Bitmap)
- 12-15 = 16-bit indexable
- 16-23 = 8-bit indexable
- 24-31 = compiled methods (CompiledMethod)"
- | instSpec |
- instSpec := self instSpec.
- instSpec < 9 ifTrue: [^Smalltalk wordSize].
- instSpec >= 16 ifTrue: [^1].
- instSpec >= 12 ifTrue: [^2].
- instSpec >= 10 ifTrue: [^4].
- ^8!
Item was 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>>forgetDoIts (in category 'initialize-release') -----
- forgetDoIts
- "get rid of old DoIt methods"
- self
- basicRemoveSelector: #DoIt;
- basicRemoveSelector: #DoItIn:!
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 (MethodContext AdditionalMethodState et al)
- 4 = weak indexable objects with inst vars (WeakArray et al)
- 5 = weak non-indexable objects with inst vars (ephemerons) (Ephemeron)
- 6 = unused
- 7 = immediates (SmallInteger, Character)
- 8 = unused
- 9 = 64-bit indexable
- 10-11 = 32-bit indexable (Bitmap) (plus one odd bit, unused in 32-bits)
- 12-15 = 16-bit indexable (plus two odd bits, one unused in 32-bits)
- 16-23 = 8-bit indexable (plus three odd bits, one unused in 32-bits)
- 24-31 = compiled methods (CompiledMethod) (plus three odd bits, one unused in 32-bits)
- 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)."
- ^(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 (MethodContext AdditionalMethodState et al)
- 4 = weak indexable objects with inst vars (WeakArray et al)
- 5 = weak non-indexable objects with inst vars (ephemerons) (Ephemeron)
- 6 = unused
- 7 = immediates (SmallInteger, Character)
- 8 = unused
- 9 = 64-bit indexable
- 10-11 = 32-bit indexable (Bitmap)
- 12-15 = 16-bit indexable
- 16-23 = 8-bit indexable
- 24-31 = compiled methods (CompiledMethod)"
- ^self instSpec >= 7!
Item was removed:
- ----- Method: Behavior>>isBytes (in category 'testing') -----
- isBytes
- "Answer whether the receiver has 8-bit instance variables.
- Above Cog Spur the class format is
- <5 bits inst spec><16 bits inst size>
- where the 5-bit inst spec is
- 0 = 0 sized objects (UndefinedObject True False et al)
- 1 = non-indexable objects with inst vars (Point et al)
- 2 = indexable objects with no inst vars (Array et al)
- 3 = indexable objects with inst vars (MethodContext AdditionalMethodState et al)
- 4 = weak indexable objects with inst vars (WeakArray et al)
- 5 = weak non-indexable objects with inst vars (ephemerons) (Ephemeron)
- 6 = unused
- 7 = immediates (SmallInteger, Character)
- 8 = unused
- 9 = 64-bit indexable
- 10-11 = 32-bit indexable (Bitmap)
- 12-15 = 16-bit indexable
- 16-23 = 8-bit indexable
- 24-31 = compiled methods (CompiledMethod)"
- ^self instSpec >= 16!
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>>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>>isVariable (in category 'testing') -----
- isVariable
- "Answer whether the receiver has indexable variables.
- Above Cog Spur the class format is
- <5 bits inst spec><16 bits inst size>
- where the 5-bit inst spec is
- 0 = 0 sized objects (UndefinedObject True False et al)
- 1 = non-indexable objects with inst vars (Point et al)
- 2 = indexable objects with no inst vars (Array et al)
- 3 = indexable objects with inst vars (MethodContext AdditionalMethodState et al)
- 4 = weak indexable objects with inst vars (WeakArray et al)
- 5 = weak non-indexable objects with inst vars (ephemerons) (Ephemeron)
- 6 = unused
- 7 = immediates (SmallInteger, Character)
- 8 = unused
- 9 = 64-bit indexable
- 10-11 = 32-bit indexable (Bitmap)
- 12-15 = 16-bit indexable
- 16-23 = 8-bit indexable
- 24-31 = compiled methods (CompiledMethod)"
- | instSpec |
- instSpec := self instSpec.
- ^instSpec >= 2 and: [instSpec <= 4 or: [instSpec >= 9]]!
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 true if the receiver is made of 32-bit instance variables."
-
- ^self isBytes not!
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>>literalScannedAs:notifying: (in category 'printing') -----
- literalScannedAs: scannedLiteral 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 isNil
- ifTrue: "###<metaclass soleInstance name>"
- [(self bindingOf: value) 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) ifNil:
- [self environment undeclare: 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>>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."
- ^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>>thoroughWhichSelectorsReferTo:special:byte: (in category 'testing method dictionary') -----
- thoroughWhichSelectorsReferTo: literal special: specialFlag byte: specialByte
- "Answer a set of selectors whose methods access the argument as a
- literal. Dives into the compact literal notation, making it slow but
- thorough "
-
- ^self whichSelectorsReferTo: literal special: specialFlag byte: specialByte thorough: true!
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 hasInterned: aString ifTrue: [ :aSymbol |
- ^self whichSuperclassSatisfies:
- [:aClass |
- aClass classVarNames anySatisfy: [:each | each = aSymbol]]].
- ^nil!
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."
-
- | special byte |
- special := Smalltalk hasSpecialSelector: literal ifTrueSetByte: [:b | byte := b].
- ^self whichSelectorsReferTo: literal special: special byte: byte
-
- "Rectangle whichSelectorsReferTo: #+."!
Item was removed:
- ----- Method: Behavior>>whichSelectorsReferTo:special:byte: (in category 'testing method dictionary') -----
- whichSelectorsReferTo: literal special: specialFlag byte: specialByte
- "Answer a set of selectors whose methods access the argument as a literal."
-
- ^self whichSelectorsReferTo: literal special: specialFlag byte: specialByte thorough: false!
Item was removed:
- ----- Method: Behavior>>whichSelectorsReferTo:special:byte:thorough: (in category 'testing method dictionary') -----
- whichSelectorsReferTo: literal special: specialFlag byte: specialByte thorough: thorough
- "Answer a set of selectors whose methods access the argument as a literal. If thorough is true, then dives into the compact literal notation, making it slow but thorough "
-
- | who |
- who := IdentitySet new.
- self selectorsAndMethodsDo: [ :selector :method |
- (((thorough
- ifFalse: [ method hasLiteral: literal ]
- ifTrue: [ method hasLiteralThorough: literal ]) or: [
- specialFlag and: [ method scanFor: specialByte ] ]) and: [
- literal isVariableBinding not or: [
- "N.B. (method indexOfLiteral: literal) < method numLiterals copes with l;ooking for
- Float bindingOf: #NaN, since (Float bindingOf: #NaN) ~= (Float bindingOf: #NaN)."
- (method indexOfLiteral: literal) ~= 0] ]) ifTrue: [
- who add: selector ] ].
- ^who!
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:
- 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 startpc numArgs'
- classVariableNames: ''
- poolDictionaries: ''
- category: 'Kernel-Methods'!
-
- !BlockClosure commentStamp: '<historical>' prior: 0!
- I am a block closure for Eliot's closure implementation. Not to be confused with the old BlockClosure.!
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: [startpc = aClosure startpc and: [self isClean]])
- ifTrue: [^true].
- ^outerContext = aClosure outerContext and: [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: startpc
- 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 MethodContext 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."
-
- ^(MethodContext newForMethod: outerContext method)
- setSender: aContext
- receiver: outerContext receiver
- method: outerContext method
- closure: self
- startpc: startpc;
- 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>>bench (in category 'evaluating') -----
- bench
- "See how many times I can value in 5 seconds. I'll answer a meaningful description."
-
- ^self benchFor: 5 seconds!
Item was removed:
- ----- Method: BlockClosure>>benchFor: (in category 'evaluating') -----
- benchFor: aDuration
- "See how many times I can value within the given duration. I'll answer a meaningful description."
-
- | startTime shouldRun count elapsedTime roundTo3Digits delay |
- roundTo3Digits := [:num |
- | rounded lowDigit |
- rounded := (num * 1000) rounded. "round to 1/1000"
- lowDigit := (rounded numberOfDigitsInBase: 10) - 3. "keep only first 3 digits"
- rounded := rounded roundTo:(10 raisedTo: lowDigit).
- (lowDigit >= 3 or: [rounded \\ 1000 = 0]) "display fractional part only when needed"
- ifTrue: [(rounded // 1000) asStringWithCommas]
- ifFalse: [(rounded / 1000.0) printString]].
- delay := aDuration asDelay.
- count := 0.
- shouldRun := true.
- [ delay wait. shouldRun := false ] forkAt: Processor timingPriority - 1.
- startTime := Time millisecondClockValue.
- [ shouldRun ] whileTrue: [
- self value.
- count := count + 1 ].
- elapsedTime := Time millisecondsSince: startTime.
- ^(roundTo3Digits value: count * 1000 / elapsedTime) , ' per second.', ((
- #(
- (1e-3 'seconds')
- (1 'milliseconds')
- (1e3 'microseconds')
- (1e6 'nanoseconds')
- )
- detect: [ :pair | elapsedTime * pair first >= count ]
- ifNone: [ #(1e9 'picoseconds') ])
- in: [ :pair |
- ' {1} {2} per run.' format: {
- (roundTo3Digits value: elapsedTime * pair first / count).
- pair second } ])!
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 receuver."
- | method |
- method := self method.
- ^method encoderClass
- pcOfBlockCreationBytecodeForBlockStartingAt: startpc
- 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."
-
- 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."
-
- 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."
-
- 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."
-
- 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>>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>>durationToRun (in category 'evaluating') -----
- durationToRun
-
- "Answer the duration taken to execute this block."
-
-
-
- ^ Duration milliSeconds: self timeToRun
-
-
-
- !
Item was removed:
- ----- Method: BlockClosure>>endPC (in category 'accessing') -----
- endPC
- ^self blockCreationBytecodeMessage arguments last + startpc - 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: startpc.
- 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 + startpc hash) hashMultiply!
Item was removed:
- ----- Method: BlockClosure>>home (in category 'accessing') -----
- home
- ^outerContext home!
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>>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."
- <primitive: 19> "Simulation guard"
- ^Process
- forContext:
- [self value.
- "Since control is now at the bottom there is no need to terminate (which
- runs unwinds) since all unwnds 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."
- <primitive: 19> "Simulation guard"
- ^Process
- forContext:
- [self valueWithArguments: anArray.
- "Since control is now at the bottom there is no need to terminate (which
- runs unwinds) since all unwnds 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: startpc
- in: self method)!
Item was removed:
- ----- Method: BlockClosure>>on:do: (in category 'exceptions') -----
- on: exception do: handlerAction
- "Evaluate the receiver in the scope of an exception handler."
-
- | handlerActive |
- <primitive: 199> "just a marker, fail and execute the following"
- handlerActive := true.
- ^ self value!
Item was removed:
- ----- Method: BlockClosure>>on:do:on:do: (in category 'exceptions') -----
- on: exc1 do: block1 on: exc2 do: block2
-
- ^[
- self
- on: exc1
- do: block1 ]
- on: exc2
- do: block2!
Item was removed:
- ----- Method: BlockClosure>>on:do:on:do:on:do: (in category 'exceptions') -----
- on: exc1 do: block1 on: exc2 do: block2 on: exc3 do: block3
-
- ^[
- self
- on: exc1
- do: block1 ]
- on: exc2
- do: block2
- on: exc3
- do: block3!
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: Dictionary new].
- ^cache at: startpc 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.
- startpc := aStartpc.
- numArgs := argCount.
- 1 to: self numCopiedValues do:
- [:i|
- self at: i put: (anArrayOrNil at: i)]!
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 BlockContect) 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 := (MethodContext newForMethod: outerContext method)
- setSender: aContext
- receiver: outerContext receiver
- method: outerContext method
- closure: self
- startpc: startpc.
- ((newContext objectClass: anArray) ~~ Array
- or: [numArgs ~= anArray size]) ifTrue:
- [^ContextPart primitiveFailTokenFor: nil].
- sz := self basicSize.
- newContext stackp: sz + numArgs.
- 1 to: numArgs do:
- [:i| newContext at: i put: (anArray at: i)].
- 1 to: sz do:
- [:i| newContext at: i + numArgs put: (self at: i)].
- ^newContext!
Item was 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
- ^startpc!
Item was removed:
- ----- Method: BlockClosure>>timeToRun (in category 'evaluating') -----
- timeToRun
- "Answer the number of milliseconds taken to execute this block."
-
- ^ Time millisecondsToRun: self
- !
Item was removed:
- ----- Method: BlockClosure>>timeToRunWithoutGC (in category 'evaluating') -----
- timeToRunWithoutGC
- "Answer the number of milliseconds taken to execute this block without GC time."
-
- ^(Smalltalk vmParameterAt: 8) +
- (Smalltalk vmParameterAt: 10) +
- self timeToRun -
- (Smalltalk vmParameterAt: 8) -
- (Smalltalk vmParameterAt: 10)
- !
Item was removed:
- ----- Method: BlockClosure>>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: 201>
- | newContext |
- numArgs ~= 0 ifTrue:
- [self numArgsError: 0].
- false
- ifTrue: "Old code to simulate the closure value primitive on VMs that lack it."
- [newContext := self asContextWithSender: thisContext sender.
- thisContext privSender: newContext]
- ifFalse: [self primitiveFailed]!
Item was removed:
- ----- Method: BlockClosure>>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: 202>
- | newContext |
- numArgs ~= 1 ifTrue:
- [self numArgsError: 1].
- false
- ifTrue: "Old code to simulate the closure value primitive on VMs that lack it."
- [newContext := self asContextWithSender: thisContext sender.
- newContext at: 1 put: firstArg.
- thisContext privSender: newContext]
- ifFalse: [self primitiveFailed]!
Item was removed:
- ----- Method: BlockClosure>>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: 203>
- | newContext |
- numArgs ~= 2 ifTrue:
- [self numArgsError: 2].
- false
- ifTrue: "Old code to simulate the closure value primitive on VMs that lack it."
- [newContext := self asContextWithSender: thisContext sender.
- newContext at: 1 put: firstArg.
- newContext at: 2 put: secondArg.
- thisContext privSender: newContext]
- ifFalse: [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 (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: 204>
- | newContext |
- numArgs ~= 3 ifTrue:
- [self numArgsError: 3].
- false
- ifTrue: "Old code to simulate the closure value primitive on VMs that lack it."
- [newContext := self asContextWithSender: thisContext sender.
- newContext at: 1 put: firstArg.
- newContext at: 2 put: secondArg.
- newContext at: 3 put: thirdArg.
- thisContext privSender: newContext]
- ifFalse: [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 (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: 205>
- | newContext |
- numArgs ~= 4 ifTrue:
- [self numArgsError: 4].
- false
- ifTrue: "Old code to simulate the closure value primitive on VMs that lack it."
- [newContext := self asContextWithSender: thisContext sender.
- newContext at: 1 put: firstArg.
- newContext at: 2 put: secondArg.
- newContext at: 3 put: thirdArg.
- newContext at: 4 put: fourthArg.
- thisContext privSender: newContext]
- ifFalse: [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 block 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 ] ] ] ] ]
- ifFound: [ :answer | notification resume: answer second ]
- ifNone: [
- (ProvideAnswerNotification signal: notification messageText)
- ifNil: [ notification resume ]
- ifNotNil: [ :outerAnswer | notification resume: outerAnswer ] ] ]!
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 (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: 206>
- | newContext |
- numArgs ~= anArray size ifTrue:
- [self numArgsError: anArray size].
- false
- ifTrue: "Old code to simulate the closure value primitive on VMs that lack it."
- [newContext := self asContextWithSender: thisContext sender.
- 1 to: numArgs do:
- [:i| newContext at: i put: (anArray at: i)].
- thisContext privSender: newContext]
- ifFalse: [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
- 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."
-
- | 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>>valueWithin:onTimeout: (in category 'evaluating') -----
- valueWithin: aDuration onTimeout: timeoutBlock
- "Evaluate the receiver.
- If the evaluation does not complete in less than aDuration evaluate the timeoutBlock instead"
-
- | theProcess delay watchdog tag |
-
- aDuration <= Duration zero ifTrue: [^ timeoutBlock value ].
-
- "the block will be executed in the current process"
- theProcess := Processor activeProcess.
- delay := aDuration asDelay.
- tag := self.
-
- "make a watchdog process"
- watchdog := [
- delay wait. "wait for timeout or completion"
- theProcess ifNotNil:[ theProcess signalException: (TimedOut new tag: tag)]
- ] newProcess.
-
- "Watchdog needs to run at high priority to do its job (but not at timing priority)"
- watchdog priority: Processor timingPriority-1.
-
- "catch the timeout signal"
- ^ [ watchdog resume. "start up the watchdog"
- self ensure:[ "evaluate the receiver"
- theProcess := nil. "it has completed, so ..."
- delay delaySemaphore signal. "arrange for the watchdog to exit"
- ]] on: TimedOut do: [ :e |
- e tag == tag
- ifTrue:[ timeoutBlock value ]
- ifFalse:[ e pass]].!
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: aBlock
- "Unlike #whileTrue/False: this is not compiled inline."
- ^ [self value isNil] whileTrue: [aBlock value]
- !
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:
- ContextPart variableSubclass: #BlockContext
- instanceVariableNames: 'nargs startpc home'
- classVariableNames: ''
- poolDictionaries: ''
- category: 'Kernel-Methods'!
-
- !BlockContext commentStamp: '<historical>' prior: 0!
- My instances function similarly to instances of MethodContext, but they hold the dynamic state for execution of a block in Smalltalk. They access all temporary variables and the method sender via their home pointer, so that those values are effectively shared. Their indexable part is used to store their independent value stack during execution.
-
- My instance must hold onto its home in order to work. This can cause circularities if the home is also pointing (via a temp, perhaps) to the instance. In the rare event that this happens (as in SortedCollection sortBlock:) the message fixTemps will replace home with a copy of home, thus defeating the sharing of temps but, nonetheless, eliminating the circularity.
-
- BlockContexts must only be created using the method newForMethod:. Note that it is impossible to determine the real object size of a BlockContext 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.!
Item was removed:
- ----- Method: BlockContext>>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 home return: result!
Item was removed:
- ----- Method: BlockContext>>activeHome (in category 'accessing') -----
- activeHome
- "Search senders for the home context. If the home
- context is not found on the sender chain answer nil."
- ^self caller findContextSuchThat: [:ctxt | ctxt = home]!
Item was removed:
- ----- Method: BlockContext>>argumentCount (in category 'accessing') -----
- argumentCount
- "Answers the number of arguments needed to evaluate the receiver."
- #Valuable.
- ^ self numArgs!
Item was removed:
- ----- Method: BlockContext>>asContext (in category 'scheduling') -----
- asContext
-
- ^ self!
Item was removed:
- ----- Method: BlockContext>>assert (in category 'exceptions') -----
- assert
- self assert: self!
Item was removed:
- ----- Method: BlockContext>>bench (in category 'evaluating') -----
- bench
- "See how many times I can value in 5 seconds. I'll answer a meaningful description."
-
- | startTime endTime count |
- count := 0.
- endTime := Time millisecondClockValue + 5000.
- startTime := Time millisecondClockValue.
- [ Time millisecondClockValue > endTime ] whileFalse: [ self value. count := count + 1 ].
- endTime := Time millisecondClockValue.
- ^count = 1
- ifTrue: [ ((endTime - startTime) // 1000) printString, ' seconds.' ]
- ifFalse:
- [ ((count * 1000) / (endTime - startTime)) asFloat printString, ' per second.' ]!
Item was removed:
- ----- Method: BlockContext>>blockReturnTop (in category 'instruction decoding') -----
- blockReturnTop
- "Simulate the interpreter's action when a ReturnTopOfStack bytecode is
- encountered in the receiver."
-
- | save dest |
- save := home. "Needed because return code will nil it"
- dest := self return: self pop from: self.
- home := save.
- sender := nil.
- ^ dest!
Item was removed:
- ----- Method: BlockContext>>caller (in category 'accessing') -----
- caller
- ^sender!
Item was removed:
- ----- Method: BlockContext>>cannotReturn: (in category 'private') -----
- cannotReturn: result
- "The receiver tried to return result to a method context that no longer exists."
-
- | ex newResult |
- ex := BlockCannotReturn new.
- ex result: result.
- newResult := ex signal.
- ^newResult!
Item was removed:
- ----- Method: BlockContext>>closureHome (in category 'accessing') -----
- closureHome
- "Answer the context from which an ^-return should return from."
-
- ^self home!
Item was removed:
- ----- Method: BlockContext>>contextForLocalVariables (in category 'accessing') -----
- contextForLocalVariables
- "Answer the context in which local variables (temporaries) are stored."
-
- ^home!
Item was removed:
- ----- Method: BlockContext>>copyForSaving (in category 'accessing') -----
- copyForSaving
- "Fix the values of the temporary variables used in the block that are
- ordinarily shared with the method in which the block is defined."
-
- home := home copy.
- home swapSender: nil!
Item was removed:
- ----- Method: BlockContext>>cull: (in category 'evaluating') -----
- cull: firstArg
- "Activate the receiver, with one or zero arguments."
-
- self numArgs >= 1 ifTrue: [ ^self value: firstArg ].
- ^self value!
Item was removed:
- ----- Method: BlockContext>>cull:cull: (in category 'evaluating') -----
- cull: firstArg cull: secondArg
- "Activate the receiver, with two or less arguments."
-
- self numArgs >= 2 ifTrue: [ ^self value: firstArg value: secondArg ].
- self numArgs = 1 ifTrue: [ ^self value: firstArg ].
- ^self value!
Item was removed:
- ----- Method: BlockContext>>cull:cull:cull: (in category 'evaluating') -----
- cull: firstArg cull: secondArg cull: thirdArg
- "Activate the receiver, with three or less arguments."
-
- self numArgs >= 2 ifTrue: [
- self numArgs >= 3 ifTrue: [ ^self value: firstArg value: secondArg value: thirdArg ].
- ^self value: firstArg value: secondArg ].
- self numArgs = 1 ifTrue: [ ^self value: firstArg ].
- ^self value!
Item was removed:
- ----- Method: BlockContext>>cull:cull:cull:cull: (in category 'evaluating') -----
- cull: firstArg cull: secondArg cull: thirdArg cull: fourthArg
- "Activate the receiver, with four or less arguments."
-
- self numArgs >= 3 ifTrue: [
- self numArgs >= 4 ifTrue: [
- ^self value: firstArg value: secondArg value: thirdArg value: fourthArg ].
- ^self value: firstArg value: secondArg value: thirdArg ].
- self numArgs = 2 ifTrue: [ ^self value: firstArg value: secondArg ].
- self numArgs = 1 ifTrue: [ ^self value: firstArg ].
- ^self value!
Item was removed:
- ----- Method: BlockContext>>decompile (in category 'printing') -----
- decompile
- ^ home method decompilerClass new decompileBlock: self!
Item was removed:
- ----- Method: BlockContext>>decompileString (in category 'printing') -----
- decompileString
- ^self decompile decompileString.!
Item was removed:
- ----- Method: BlockContext>>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: BlockContext>>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: BlockContext>>durationToRun (in category 'evaluating') -----
- durationToRun
- "Answer the duration taken to execute this block."
-
- ^ Duration milliSeconds: self timeToRun
-
- !
Item was removed:
- ----- Method: BlockContext>>endPC (in category 'private') -----
- endPC
- "Determine end of block from long jump preceding it"
- ^(self method at: startpc - 2)
- \\ 16 - 4 * 256
- + (self method at: startpc - 1) + startpc - 1.!
Item was removed:
- ----- Method: BlockContext>>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 value.
- complete ifNil:[
- complete := true.
- aBlock value.
- ].
- ^ returnValue!
Item was removed:
- ----- Method: BlockContext>>fixTemps (in category 'accessing') -----
- 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."
-
- home := home copy.
- home swapSender: nil!
Item was removed:
- ----- Method: BlockContext>>fork (in category 'scheduling') -----
- fork
- "Create and schedule a Process running the code in the receiver."
-
- ^ self newProcess resume!
Item was removed:
- ----- Method: BlockContext>>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: BlockContext>>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."
-
- | forkedProcess |
- forkedProcess := self newProcess.
- forkedProcess priority: priority.
- ^ forkedProcess resume
- !
Item was removed:
- ----- Method: BlockContext>>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: BlockContext>>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: BlockContext>>fullPrintOn: (in category 'printing') -----
- fullPrintOn: aStream
- aStream print: self; cr.
- (self decompile ifNil: ['--source missing--']) printOn: aStream indent: 0!
Item was removed:
- ----- Method: BlockContext>>hasInstVarRef (in category 'accessing') -----
- hasInstVarRef
- "Answer whether the receiver references an instance variable."
-
- | method scanner end printer |
-
- home ifNil: [^false].
- method := self method.
- end := self endPC.
- scanner := InstructionStream new method: method pc: startpc.
- printer := InstVarRefLocator new.
-
- [scanner pc <= end] whileTrue: [
- (printer interpretNextInstructionUsing: scanner) ifTrue: [^true].
- ].
- ^false!
Item was removed:
- ----- Method: BlockContext>>hasMethodReturn (in category 'accessing') -----
- hasMethodReturn
- "Answer whether the receiver has a return ('^') in its code."
-
- | method scanner end |
- method := self method.
- "Determine end of block from long jump preceding it"
- end := (method at: startpc-2)\\16-4*256 + (method at: startpc-1) + startpc - 1.
- scanner := InstructionStream new method: method pc: startpc.
- scanner scanFor: [:byte | (byte between: 120 and: 124) or: [scanner pc > end]].
- ^scanner pc <= end!
Item was removed:
- ----- Method: BlockContext>>hideFromDebugger (in category 'private') -----
- hideFromDebugger
-
- ^home ~~ nil and: [home hideFromDebugger]!
Item was removed:
- ----- Method: BlockContext>>home (in category 'accessing') -----
- home
- "Answer the context in which the receiver was defined."
-
- ^home!
Item was removed:
- ----- Method: BlockContext>>home:startpc:nargs: (in category 'initialize-release') -----
- home: aContextPart startpc: position nargs: anInteger
- "This is the initialization message. The receiver has been initialized with
- the correct size only."
-
- home := aContextPart.
- pc := startpc := position.
- nargs := anInteger.
- stackp := 0.!
Item was removed:
- ----- Method: BlockContext>>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 value.
- complete := true.
- ^result!
Item was removed:
- ----- Method: BlockContext>>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: BlockContext>>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: BlockContext>>isBlock (in category 'accessing') -----
- isBlock
-
- ^ true!
Item was removed:
- ----- Method: BlockContext>>isExecutingBlock (in category 'accessing') -----
- isExecutingBlock
-
- ^ true!
Item was removed:
- ----- Method: BlockContext>>method (in category 'accessing') -----
- method
- "Answer the compiled method in which the receiver was defined."
-
- ^home method!
Item was removed:
- ----- Method: BlockContext>>methodReturnContext (in category 'accessing') -----
- methodReturnContext
- "Answer the context from which an ^-return should return from."
-
- ^home!
Item was removed:
- ----- Method: BlockContext>>myEnv (in category 'private') -----
- myEnv
- "polymorphic with MethodContext"
-
- ^ nil!
Item was removed:
- ----- Method: BlockContext>>newProcess (in category 'scheduling') -----
- newProcess
- "Answer a Process running the code in the receiver. The process is not
- scheduled."
- <primitive: 19> "Simulation guard"
- ^Process
- forContext:
- [self value.
- Processor terminateActive] asContext
- priority: Processor activePriority!
Item was removed:
- ----- Method: BlockContext>>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."
- <primitive: 19> "Simulation guard"
- ^Process
- forContext:
- [self valueWithArguments: anArray.
- Processor terminateActive] asContext
- priority: Processor activePriority!
Item was removed:
- ----- Method: BlockContext>>numArgs (in category 'accessing') -----
- numArgs
- "Answer the number of arguments that must be used to evaluate this block"
-
- ^nargs!
Item was removed:
- ----- Method: BlockContext>>on:do: (in category 'exceptions') -----
- on: exception do: handlerAction
- "Evaluate the receiver in the scope of an exception handler."
- | handlerActive |
- <primitive: 199>
- handlerActive := true.
- ^self value!
Item was removed:
- ----- Method: BlockContext>>on:do:on:do: (in category 'exceptions') -----
- on: exc1 do: block1 on: exc2 do: block2
-
- ^[
- self
- on: exc1
- do: block1 ]
- on: exc2
- do: block2!
Item was removed:
- ----- Method: BlockContext>>on:do:on:do:on:do: (in category 'exceptions') -----
- on: exc1 do: block1 on: exc2 do: block2 on: exc3 do: block3
-
- ^[
- self
- on: exc1
- do: block1 ]
- on: exc2
- do: block2
- on: exc3
- do: block3!
Item was removed:
- ----- Method: BlockContext>>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 valueWithPossibleArgs: {exception}]
- ifFalse: [exception pass]
- ]!
Item was removed:
- ----- Method: BlockContext>>printOn: (in category 'printing') -----
- printOn: aStream
- | decompilation blockString truncatedBlockString |
-
- home == nil ifTrue: [^aStream nextPutAll: 'a BlockContext with home=nil'].
- aStream nextPutAll: '[] in '.
- super printOn: aStream.
- decompilation := [self decompile ifNil: ['--source missing--']]
- on: Error
- do: [:ex| ' (error in decompilation)'].
- blockString := ((decompilation isString
- ifTrue: [decompilation]
- ifFalse: [decompilation printString])
- replaceAll: Character cr with: Character space)
- replaceAll: Character tab with: Character space.
- truncatedBlockString := blockString truncateWithElipsisTo: 80.
- truncatedBlockString size < blockString size ifTrue:
- [truncatedBlockString := truncatedBlockString, ']}'].
- aStream space; nextPutAll: truncatedBlockString!
Item was removed:
- ----- Method: BlockContext>>privHome: (in category 'private') -----
- privHome: context
-
- home := context!
Item was removed:
- ----- Method: BlockContext>>privRefresh (in category 'initialize-release') -----
- privRefresh
- "Reinitialize the receiver so that it is in the state it was at its creation."
-
- pc := startpc.
- self stackp: 0.
- nargs timesRepeat: [ "skip arg popping"
- self nextInstruction selector = #popIntoTemporaryVariable:
- ifFalse: [self halt: 'unexpected bytecode instruction']
- ].
- !
Item was removed:
- ----- Method: BlockContext>>pushArgs:from: (in category 'system simulation') -----
- pushArgs: args from: sendr
- "Simulates action of the value primitive."
-
- args size ~= nargs ifTrue: [^self error: 'incorrect number of args'].
- self stackp: 0.
- args do: [:arg | self push: arg].
- sender := sendr.
- pc := startpc!
Item was removed:
- ----- Method: BlockContext>>receiver (in category 'accessing') -----
- receiver
- "Refer to the comment in ContextPart|receiver."
-
- ^home receiver!
Item was removed:
- ----- Method: BlockContext>>reentrant (in category 'accessing') -----
- reentrant
- "Copy before calling so multiple activations can exist"
-
- ^ self copy!
Item was removed:
- ----- Method: BlockContext>>repeat (in category 'controlling') -----
- repeat
- "Evaluate the receiver repeatedly, ending only if the block explicitly returns."
-
- [self value. true] whileTrue!
Item was removed:
- ----- Method: BlockContext>>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: BlockContext>>startpc (in category 'private') -----
- startpc
- "for use by the System Tracer only"
-
- ^startpc!
Item was removed:
- ----- Method: BlockContext>>stepToSendOrReturn (in category 'system simulation') -----
- stepToSendOrReturn
- pc = startpc ifTrue: [
- "pop args first"
- self numArgs timesRepeat: [self step]].
- ^super stepToSendOrReturn!
Item was removed:
- ----- Method: BlockContext>>tempAt: (in category 'accessing') -----
- tempAt: index
- "Refer to the comment in ContextPart|tempAt:."
-
- ^home at: index!
Item was removed:
- ----- Method: BlockContext>>tempAt:put: (in category 'accessing') -----
- tempAt: index put: value
- "Refer to the comment in ContextPart|tempAt:put:."
-
- ^home at: index put: value!
Item was removed:
- ----- Method: BlockContext>>timeToRun (in category 'evaluating') -----
- timeToRun
- "Answer the number of milliseconds taken to execute this block."
-
- ^ Time millisecondsToRun: self
- !
Item was removed:
- ----- Method: BlockContext>>value (in category 'evaluating') -----
- value
- "Primitive. Evaluate the block represented by the receiver. Fail if the
- block expects any arguments or if the block is already being executed.
- Optional. No Lookup. See Object documentation whatIsAPrimitive."
-
- <primitive: 81>
- ^self valueWithArguments: #()!
Item was removed:
- ----- Method: BlockContext>>value: (in category 'evaluating') -----
- value: arg
- "Primitive. Evaluate the block represented by the receiver. Fail if the
- block expects other than one argument or if the block is already being
- executed. Optional. No Lookup. See Object documentation
- whatIsAPrimitive."
-
- <primitive: 81>
- ^self valueWithArguments: (Array with: arg)!
Item was removed:
- ----- Method: BlockContext>>value:value: (in category 'evaluating') -----
- value: arg1 value: arg2
- "Primitive. Evaluate the block represented by the receiver. Fail if the
- block expects other than two arguments or if the block is already being
- executed. Optional. See Object documentation whatIsAPrimitive."
-
- <primitive: 81>
- ^self valueWithArguments: (Array with: arg1 with: arg2)!
Item was removed:
- ----- Method: BlockContext>>value:value:value: (in category 'evaluating') -----
- value: arg1 value: arg2 value: arg3
- "Primitive. Evaluate the block represented by the receiver. Fail if the
- block expects other than three arguments or if the block is already being
- executed. Optional. See Object documentation whatIsAPrimitive."
-
- <primitive: 81>
- ^self valueWithArguments:
- (Array
- with: arg1
- with: arg2
- with: arg3)!
Item was removed:
- ----- Method: BlockContext>>value:value:value:value: (in category 'evaluating') -----
- value: arg1 value: arg2 value: arg3 value: arg4
- "Primitive. Evaluate the block represented by the receiver. Fail if the
- block expects other than three arguments or if the block is already being
- executed. Optional. See Object documentation whatIsAPrimitive."
-
- <primitive: 81>
- ^self valueWithArguments:
- (Array
- with: arg1
- with: arg2
- with: arg3
- with: arg4)!
Item was removed:
- ----- Method: BlockContext>>valueAt: (in category 'scheduling') -----
- 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: BlockContext>>valueError (in category 'private') -----
- valueError
-
- self error: 'Incompatible number of args, or already active'!
Item was removed:
- ----- Method: BlockContext>>valueSupplyingAnswer: (in category 'evaluating') -----
- valueSupplyingAnswer: anObject
-
- ^ (anObject isCollection and: [anObject isString not])
- ifTrue: [self valueSupplyingAnswers: {anObject}]
- ifFalse: [self valueSupplyingAnswers: {{'*'. anObject}}]!
Item was removed:
- ----- Method: BlockContext>>valueSupplyingAnswers: (in category 'evaluating') -----
- valueSupplyingAnswers: aListOfPairs
- "evaluate the block using a list of questions / answers that might be called upon to
- automatically respond to Object>>confirm: or FillInTheBlank requests"
-
- ^self
- on: ProvideAnswerNotification
- do:
- [:notify | | answer caption |
-
- caption := notify messageText withSeparatorsCompacted. "to remove new lines"
- answer := aListOfPairs
- detect:
- [:each | caption = each first
- or: [(caption includesSubstring: each first caseSensitive: false)
- or: [each first match: caption]]]
- ifNone: [nil].
- answer
- ifNotNil: [notify resume: answer second]
- ifNil:
- [ | outerAnswer |
- outerAnswer := ProvideAnswerNotification signal: notify messageText.
- outerAnswer
- ifNil: [notify resume]
- ifNotNil: [notify resume: outerAnswer]]]!
Item was removed:
- ----- Method: BlockContext>>valueSuppressingAllMessages (in category 'evaluating') -----
- valueSuppressingAllMessages
-
- ^ self valueSuppressingMessages: #('*')!
Item was removed:
- ----- Method: BlockContext>>valueSuppressingMessages: (in category 'evaluating') -----
- valueSuppressingMessages: aListOfStrings
-
- ^ self
- valueSuppressingMessages: aListOfStrings
- supplyingAnswers: #()!
Item was removed:
- ----- Method: BlockContext>>valueSuppressingMessages:supplyingAnswers: (in category 'evaluating') -----
- valueSuppressingMessages: aListOfStrings supplyingAnswers: aListOfPairs
-
- ^ self valueSupplyingAnswers: aListOfPairs, (aListOfStrings collect: [:each | {each. true}])!
Item was removed:
- ----- Method: BlockContext>>valueUninterruptably (in category 'exceptions') -----
- valueUninterruptably
- "Temporarily make my home Context unable to return control to its sender, to guard against circumlocution of the ensured behavior."
-
- ^ self ifCurtailed: [^ self]!
Item was removed:
- ----- Method: BlockContext>>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: BlockContext>>valueWithArguments: (in category 'evaluating') -----
- valueWithArguments: anArray
- "Primitive. Evaluate the block represented by the receiver. The argument
- is an Array whose elements are the arguments for the block. Fail if the
- length of the Array is not the same as the the number of arguments that
- the block was expecting. Fail if the block is already being executed.
- Essential. See Object documentation whatIsAPrimitive."
-
- <primitive: 82>
-
- anArray isArray ifFalse: [^self error: 'valueWithArguments: expects an array'].
- self numArgs = anArray size
- ifTrue: [self error: 'Attempt to evaluate a block that is already being evaluated.']
- ifFalse: [self error:
- 'This block accepts ' ,self numArgs printString, ' argument', (self numArgs = 1 ifTrue:[''] ifFalse:['s']) ,
- ', but was called with ', anArray size printString, '.']
-
- !
Item was removed:
- ----- Method: BlockContext>>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: BlockContext>>valueWithExit (in category 'evaluating') -----
- valueWithExit
- self value: [ ^nil ]!
Item was removed:
- ----- Method: BlockContext>>valueWithPossibleArgs: (in category 'evaluating') -----
- valueWithPossibleArgs: anArray
-
- "Evaluate the block represented by the receiver.
- If the block requires arguments, take them from anArray. If anArray is too
- large, the rest is ignored, if it is too small, use nil for the other arguments"
-
- self numArgs = 0 ifTrue: [^self value].
- self numArgs = anArray size ifTrue: [^self valueWithArguments: anArray].
- self numArgs > anArray size ifTrue: [
- ^self valueWithArguments: anArray,
- (Array new: (self numArgs - anArray size))
- ].
- ^self valueWithArguments: (anArray copyFrom: 1 to: self numArgs)
-
- !
Item was removed:
- ----- Method: BlockContext>>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."
-
- self numArgs = 0 ifTrue: [^self value].
- self numArgs = 1 ifTrue: [^self value: anArg].
- self numArgs > 1 ifTrue: [^self valueWithArguments: {anArg}, (Array new: self numArgs - 1)]!
Item was removed:
- ----- Method: BlockContext>>valueWithin:onTimeout: (in category 'evaluating') -----
- valueWithin: aDuration onTimeout: timeoutBlock
- "Evaluate the receiver.
- If the evaluation does not complete in less than aDuration evaluate the timeoutBlock instead"
-
- | theProcess delay watchdog tag |
-
- aDuration <= Duration zero ifTrue: [^ timeoutBlock value ].
-
- "the block will be executed in the current process"
- theProcess := Processor activeProcess.
- delay := aDuration asDelay.
- tag := self.
-
- "make a watchdog process"
- watchdog := [
- delay wait. "wait for timeout or completion"
- theProcess ifNotNil:[ theProcess signalException: (TimedOut new tag: tag)]
- ] newProcess.
-
- "Watchdog needs to run at high priority to do its job (but not at timing priority)"
- watchdog priority: Processor timingPriority-1.
-
- "catch the timeout signal"
- ^ [ watchdog resume. "start up the watchdog"
- self ensure:[ "evaluate the receiver"
- theProcess := nil. "it has completed, so ..."
- delay delaySemaphore signal. "arrange for the watchdog to exit"
- ]] on: TimedOut do: [ :e |
- e tag == tag
- ifTrue:[ timeoutBlock value ]
- ifFalse:[ e pass]].!
Item was removed:
- ----- Method: BlockContext>>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: BlockContext>>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: BlockContext>>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: BlockContext>>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: #BlockStartLocator
- instanceVariableNames: 'nextJumpIsAroundBlock'
- classVariableNames: ''
- poolDictionaries: ''
- category: 'Kernel-Methods'!
Item was removed:
- ----- Method: BlockStartLocator>>initialize (in category 'initialize-release') -----
- initialize
- nextJumpIsAroundBlock := false!
Item was removed:
- ----- Method: BlockStartLocator>>jump: (in category 'instruction decoding') -----
- jump: offset
- "If this jump is around a block answer the size of that block."
-
- nextJumpIsAroundBlock ifTrue:
- [nextJumpIsAroundBlock := false.
- ^offset]!
Item was removed:
- ----- Method: BlockStartLocator>>pushClosureCopyNumCopiedValues:numArgs:blockSize: (in category 'instruction decoding') -----
- pushClosureCopyNumCopiedValues: numCopied numArgs: numArgs blockSize: blockSize
- "Answer the size of the block"
- ^blockSize!
Item was removed:
- ----- Method: BlockStartLocator>>send:super:numArgs: (in category 'instruction decoding') -----
- send: selector super: supered numArgs: numberArguments
- nextJumpIsAroundBlock := #closureCopy:copiedValues: == selector
- "Don't use
- nextJumpIsAroundBlock := #(blockCopy: closureCopy:copiedValues:) includes: selector
- since BlueBook BlockContexts do not have their own temps."!
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>>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>>clone (in category 'copying') -----
- clone
- "Receiver has two concrete subclasses, True and False.
- Only one instance of each should be made, so return self."!
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>>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>>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>>| (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."
- | exp guess eps delta |
- <primitive: 55>
- #Numeric.
- "Changed 200/01/19 For ANSI <number> support."
- "Newton-Raphson"
- self <= 0.0
- ifTrue: [self = 0.0
- ifTrue: [^ 0.0]
- ifFalse: ["v Chg"
- ^ DomainError signal: 'sqrt undefined for number less than zero.']].
- "first guess is half the exponent"
- exp := self exponent // 2.
- guess := self timesTwoPower: 0 - exp.
- "get eps value"
- eps := guess * Epsilon.
- eps := eps * eps.
- delta := self - (guess * guess) / (guess * 2.0).
- [delta * delta > eps]
- whileTrue:
- [guess := guess + delta.
- delta := self - (guess * guess) / (guess * 2.0)].
- ^ guess!
Item was removed:
- ----- Method: 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>
- 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
- ifTrue:
- [| deltaToUnderflow |
- deltaToUnderflow := Float emin - self exponent max: Float emin.
- 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 > -29 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: BoxedFloat64>>truncated (in category 'truncation and round off') -----
- truncated
- "Answer with a SmallInteger equal to the value of the receiver without
- its fractional part. The primitive fails if the truncated value cannot be
- represented as a SmallInteger. In that case, the code below will compute
- a LargeInteger truncated value.
- Essential. See Object documentation whatIsAPrimitive. "
-
- <primitive: 51>
- self isFinite ifFalse: [self error: 'Cannot truncate this number'].
-
- self abs < 2.0e16
- ifTrue: ["Fastest way when it may not be an integer"
- | di df q r |
- di := 1 + (SmallInteger maxVal bitShift: -1).
- df := di asFloat.
- q := self quo: df.
- r := self - (q asFloat * df).
- ^q * di + r truncated]
- ifFalse: [^ self asTrueFraction. "Extract all bits of the mantissa and shift if necess"]
-
-
-
- !
Item was 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:
- 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"
- 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 temp 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 selectors |
- catSpec := categorySpecs at: i.
- newCategories at: i put: catSpec first asSymbol.
- selectors := catSpec allButFirst collect: [:each | each isSymbol
- ifTrue: [each]
- ifFalse: [each printString asSymbol]].
- selectors asSortedCollection do:
- [:elem |
- (oldElements remove: elem ifAbsent: [nil]) notNil ifTrue:
- [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"
- temp := categoryArray asOrderedCollection.
- temp removeAll: categoryArray asSet asOrderedCollection.
- temp do: [:dup | | ii dup2 num |
- ii := categoryArray indexOf: dup.
- 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 'accessing') -----
- classify: element under: heading
- self classify: element under: heading suppressIfDefault: true!
Item was removed:
- ----- Method: Categorizer>>classify:under:suppressIfDefault: (in category 'accessing') -----
- 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 |
- ((heading = NullCategory) or: [heading == nil])
- ifTrue: [realHeading := Default]
- ifFalse: [realHeading := heading asSymbol].
- (catName := self categoryOfElement: element) = realHeading
- ifTrue: [^ self]. "done if already under that category"
-
- catName ~~ nil ifTrue:
- [(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 'accessing') -----
- 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>>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 |
- categoryIndex := 1.
- elementIndex := 0.
- [(elementIndex := elementIndex + 1) <= elementArray size]
- 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
- ^ String streamContents: [ :stream | self printOn: stream ].!
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 changed:
SharedPool subclass: #ChronologyConstants
instanceVariableNames: 'seconds offset jdn nanos'
classVariableNames: 'DayNames DaysInMonth MicrosecondsInDay MonthNames NanosInMillisecond NanosInSecond OneDay SecondsInDay SecondsInHour SecondsInMinute SqueakEpoch Zero'
poolDictionaries: ''
+ category: 'Chronology-Core'!
- category: 'Kernel-Chronology'!
!ChronologyConstants commentStamp: 'brp 3/12/2004 14:34' prior: 0!
ChronologyConstants is a SharedPool for the constants used by the Kernel-Chronology classes.!
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 select: [:each | each isBehavior and: [each superclass isNil]]) asOrderedCollection!
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"
- | binding |
- binding := self environment associationAt: name ifAbsent: [nil -> self].
- ^binding value == self ifTrue:[binding] ifFalse:[nil -> 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 classVar dictionary."
- (self classThatDefinesClassVariable: aSymbol) ifNotNil:
- [:x | ^x classPool bindingOf: aSymbol].
-
- "Next look in shared pools."
- self sharedPools do:[:pool |
- binding := pool bindingOf: aSymbol.
- binding ifNotNil:[^binding].
- ].
-
- "Next look in declared environment."
- binding := anEnvironment bindingOf: aSymbol.
- binding ifNotNil:[^binding].
-
- "Finally look higher up the superclass chain and fail at the end."
- superclass == nil
- ifTrue: [^ nil]
- ifFalse: [^ superclass 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.
- SystemOrganization 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>>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>>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>>newSubclass (in category 'subclass creation') -----
- newSubclass
- | i className |
- i := 1.
- [className := (self name , i printString) asSymbol.
- self environment includesKey: className]
- whileTrue: [i := i + 1].
-
- ^ self subclass: className
- instanceVariableNames: ''
- classVariableNames: ''
- poolDictionaries: ''
- category: Object categoryForUniclasses
-
- "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: [self inform: '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 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 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>>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 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 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 (MethodContext AdditionalMethodState et al)
- 4 = weak indexable objects with inst vars (WeakArray et al)
- 5 = weak non-indexable objects with inst vars (ephemerons) (Ephemeron)
- 6 = unused
- 7 = immediates (SmallInteger, Character, 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>>format:variable:words:pointers:weak: (in category 'class format') -----
- format: nInstVars variable: isVar words: is32BitWords pointers: isPointers weak: isWeak
- "Compute the format for the given instance specfication.
- Above Cog Spur the class format is
- <5 bits inst spec><16 bits inst size>
- where the 5-bit inst spec is
- 0 = 0 sized objects (UndefinedObject True False et al)
- 1 = non-indexable objects with inst vars (Point et al)
- 2 = indexable objects with no inst vars (Array et al)
- 3 = indexable objects with inst vars (MethodContext AdditionalMethodState et al)
- 4 = weak indexable objects with inst vars (WeakArray et al)
- 5 = weak non-indexable objects with inst vars (ephemerons) (Ephemeron)
- 6 = unused
- 7 = immediates (SmallInteger, Character)
- 8 = unused
- 9 = reserved for 64-bit indexable
- 10-11 = 32-bit indexable (Bitmap)
- 12-15 = 16-bit indexable
- 16-23 = 8-bit indexable
- 24-31 = compiled methods (CompiledMethod)"
- | instSpec |
- instSpec := isWeak
- ifTrue:
- [isVar
- ifTrue: [4]
- ifFalse: [5]]
- ifFalse:
- [isPointers
- ifTrue:
- [isVar
- ifTrue: [nInstVars > 0 ifTrue: [3] ifFalse: [2]]
- ifFalse: [nInstVars > 0 ifTrue: [1] ifFalse: [0]]]
- ifFalse:
- [isVar
- ifTrue: [is32BitWords ifTrue: [10] ifFalse: [16]]
- ifFalse: [7]]].
- ^(instSpec bitShift: 16) + nInstVars!
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 ..."
- 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 clone].
-
- 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 clone.
- 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'
- 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: ' \' withCRs) size < 2 ifTrue:
- [^self error: 'cannot make an ephemeron class with less than two named instance varaibles'].
- 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: 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 byte-sized nonpointer variables."
- | oldClassOrNil actualType env |
- (aClass instSize > 0)
- ifTrue: [^self error: 'cannot make a byte subclass of a class with named fields'].
- (aClass isVariable and: [aClass isWords])
- ifTrue: [^self error: 'cannot make a byte subclass of a class with word 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].
- actualType := (oldClassOrNil notNil
- and: [oldClassOrNil typeOfClass == #compiledMethod])
- ifTrue: [#compiledMethod]
- ifFalse: [#bytes].
- env := CurrentEnvironment signal ifNil: [aClass environment].
- ^self
- name: t
- inEnvironment: env
- subclassOf: aClass
- type: actualType
- 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 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 isBytes])
- ifTrue: [^self error: 'cannot make a word subclass of a class with byte 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 ContextPart BlockContext MethodContext BlockClosure
- "Superclasses of basic collections"
- Collection SequenceableCollection ArrayedCollection
- "Collections known to the VM"
- Array Bitmap String Symbol ByteArray CompiledMethod
- "Basic Numbers"
- Magnitude Number SmallInteger Float
- "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 becomeForward: newClass.
- oldClass updateMethodBindingsTo: oldClass binding]
- ifFalse:
- [{oldClass. oldClass class} elementsForwardIdentityTo: {newClass. newClass class}.
- oldClass updateMethodBindingsTo: oldClass binding.
- oldClass class updateMethodBindingsTo: oldClass class binding].
-
- "eem 5/31/2014 07:22 At this point there used to be a garbage collect whose purpose was
- to ensure no old instances existed after the becomeForward:. Without the GC it was possible
- to resurrect old instances using e.g. allInstancesDo:. This was because the becomeForward:
- updated references from the old objects to new objects but didn't destroy the old objects.
- But as of late 2013/early 2014 becomeForward: has been modified to free all the old objects."]
- valueUnpreemptively!
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"
- | instVars usedNames temp |
- instVarArray isEmpty ifTrue:[^true]. "Okay"
- newSuper allowsSubInstVars ifFalse: [
- self error: newSuper printString, ' does not allow subclass inst vars. See allowsSubInstVars.'. ^ false].
-
- "Validate the inst var names"
- usedNames := instVarArray asSet.
- usedNames size = instVarArray size
- ifFalse:[ instVarArray 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 allInstVarNames asSet.
- instVarArray do:[:iv|
- (usedNames includes: iv) ifTrue:[
- newSuper withAllSuperclassesDo:[:cl|
- (cl instVarNames 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 instVarNames].
- instVars := instVarArray.
- newSuper == nil ifFalse:[instVars := instVars, newSuper allInstVarNames].
- instVars do:[:iv|
- (usedNames includes: iv) ifTrue:[
- (DuplicateVariableError new)
- superclass: oldClass;
- variable: iv;
- signal: iv,' is already defined in a subclass of ', temp name]]].
- ^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 'as yet unclassified') -----
- 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 'as yet unclassified') -----
- scanFrom: aStream environment: anEnvironment
- ^ self scanFrom: aStream!
Item was removed:
- ----- Method: ClassCommentReader>>scanFromNoCompile: (in category 'as yet unclassified') -----
- 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: '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>>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"
-
- ^ 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 := OrderedCollection new.
- self withAllSuperclasses do:
- [:aClass |
- (aClass includesBehavior: mostGenericClass)
- ifTrue: [aColl addAll: aClass organization categories]].
- aColl remove: 'no messages' asSymbol ifAbsent: [].
-
- ^aColl asSet 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 "
- | aColl |
- aColl := OrderedCollection new.
- self withAllSuperclasses
- do: [:aClass | aColl
- addAll: (aName = ClassOrganizer allCategory
- ifTrue: [aClass organization allMethodSelectors]
- ifFalse: [aClass organization listAtCategoryNamed: aName])].
- ^ aColl asSet asSortedArray
-
- "TileMorph allMethodsInCategory: #initialization"!
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 asSortedArray.
- allVars isEmpty ifTrue: [^ self inform: 'There are no
- instance variables'].
-
- 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 reverseDo:
- [ : 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 := UIManager default
- chooseFrom: (labelStream contents subStrings: {Character cr})
- 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 asSortedCollection do: [:each |
- stream
- crtab; nextPutAll: each;
- nextPut: $:;
- tab: 2;
- nextPutAll: '<Object>'].
- stream cr.
- self instVarNames asSortedCollection 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
- | methodAndNode selector |
- methodAndNode := self
- compile: text asString
- notifying: requestor
- trailer: (self defaultMethodTrailerIfLogSource: logSource)
- ifFail: [ ^ nil ].
- selector := methodAndNode selector.
- logSource ifTrue:
- [ self
- logMethodSource: text
- forMethodWithNode: methodAndNode
- inCategory: category
- withStamp: changeStamp
- notifying: requestor.
- RecentMessages default
- recordSelector: selector
- forClass: methodAndNode method methodClass
- inEnvironment: CurrentEnvironment signal ].
- self
- addAndClassifySelector: selector
- withMethod: methodAndNode method
- inProtocol: category
- notifying: requestor.
- self instanceSide
- noteCompilationOf: selector
- meta: self isClassSide.
- ^ selector!
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
- | methodAndNode context methodNode |
- context := CompilationCue
- source: text
- class: self
- environment: anEnvironment
- requestor: requestor.
- methodNode := self newCompiler compile: context ifFail: [^ nil].
- methodAndNode := CompiledMethodWithNode
- generateMethodFromNode: methodNode
- trailer: (self defaultMethodTrailerIfLogSource: logSource).
-
- logSource ifTrue: [
- self logMethodSource: text forMethodWithNode: methodAndNode
- inCategory: category withStamp: changeStamp notifying: requestor.
- ].
- self addAndClassifySelector: methodAndNode selector withMethod: methodAndNode
- method inProtocol: category notifying: requestor.
- self instanceSide noteCompilationOf: methodAndNode selector meta: self isClassSide.
- ^ methodAndNode selector!
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>>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."
-
- ^ SystemChangeNotifier uniqueInstance
- doSilently: [self compile: code 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."
-
- | 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: [code asString = (self sourceMethodAt: sel) asString
- ifFalse: [self error: self name
- , ' '
- , sel
- , ' will be redefined if you proceed.']].
- self compile: code classified: category]!
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: (SystemOrganization 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 doWithIndex: [:each :index |
- index > max ifFalse:
- [object instVarAt: index put: each]].
- ^ object!
Item was removed:
- ----- Method: ClassDescription>>forgetDoIts (in category 'initialize-release') -----
- forgetDoIts
- "get rid of old DoIt methods and bogus entries in the ClassOrganizer."
- SystemChangeNotifier uniqueInstance doSilently: [
- self organization
- removeElement: #DoIt;
- removeElement: #DoItIn:.
- ].
- super forgetDoIts.!
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 == nil
- ifTrue: [0]
- ifFalse: [instanceVariables indexOf: instVarName ifAbsent: [0]].
- index = 0 ifTrue:
- [^superclass == nil
- ifTrue: [aBlock value]
- ifFalse: [superclass instVarIndexFor: instVarName ifAbsent: aBlock]].
- ^superclass == nil
- ifTrue: [index]
- ifFalse: [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>>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; nextPutAll: '** 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 asSortedCollection:[: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"
- "Player removeUninstantiatedSubclassesSilently"
-
- | candidatesForRemoval oldFree |
-
- oldFree := Smalltalk garbageCollect.
- candidatesForRemoval :=
- self subclasses select: [:c |
- (c instanceCount = 0) and: [c subclasses size = 0]].
- candidatesForRemoval do: [: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 elementsForwardIdentityTo: 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.
- "Now fix up instances in segments that are out on the disk."
- ImageSegment allSubInstancesDo:
- [:seg |
- seg segUpdateInstancesOf: oldClass toBe: self 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:[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>>classify:under:logged: (in category 'accessing') -----
- 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 'accessing') -----
- 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 'accessing') -----
- 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>>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>>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>>scanner (in category 'accessing') -----
- scanner
- ^ scanner!
Item was removed:
- ----- Method: ClosureExtractor>>scanner: (in category 'accessing') -----
- scanner: anInstructionStream
- scanner := anInstructionStream.
- currentContext := MethodContext
- sender: nil
- receiver: nil
- method: scanner method
- arguments: (Array new: scanner method numArgs)!
Item was removed:
- ByteArray variableByteSubclass: #CompiledMethod
- instanceVariableNames: ''
- classVariableNames: 'LargeFrame PrimaryBytecodeSetEncoderClass SecondaryBytecodeSetEncoderClass SmallFrame'
- poolDictionaries: ''
- category: 'Kernel-Methods'!
-
- !CompiledMethod commentStamp: 'eem 1/22/2015 15:47' prior: 0!
- CompiledMethod instances are methods suitable for interpretation by the virtual machine. Instances of CompiledMethod and its subclasses are the only objects in the system that have both indexable pointer fields and indexable 8-bit integer fields. The first part of a CompiledMethod is pointers, the second part is bytes. CompiledMethod inherits from ByteArray to avoid duplicating some of ByteArray's methods, not because a CompiledMethod is-a ByteArray.
-
- Class variables:
- SmallFrame - the number of stack slots in a small frame Context
- LargeFrame - the number of stack slots in a large frame Context
- PrimaryBytecodeSetEncoderClass - the encoder class that defines the primary instruction set
- SecondaryBytecodeSetEncoderClass - the encoder class that defines the secondary instruction set
-
- The current format of a CompiledMethod is as follows:
-
- header (4 or 8 bytes, SmallInteger)
- literals (4 or 8 bytes each, Object, see "The last literal..." below)
- 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: is optimized - 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.
-
- The trailer is an encoding of an instance of CompiledMethodTrailer. It is typically used to encode the index into the source files array of the method's source, but may be used to encode other values, e.g. tempNames, source as a string, etc. See the class CompiledMethodTrailer.
-
- The last literal in a CompiledMethod must be its methodClassAssociation, a binding whose value is the class the method is installed in. The methodClassAssociation is used to implement super sends. If a method contains no super send then its methodClassAssociation may be nil (as would be the case for example of methods providing a pool of inst var accessors). By convention the penultimate literal of a method is either its selector or an instance of AdditionalMethodState. AdditionalMethodState holds any pragmas and properties of a method, but may also be used to add instance variables to a method, albeit ones held in the method's AdditionalMethodState. Subclasses of CompiledMethod that want to add state should subclass AdditionalMethodState to add the state they want, and implement methodPropertiesClass on the class side of the CompiledMethod subclass to answer the specialized subclass of AdditionalMethodState.!
Item was removed:
- ----- Method: CompiledMethod class>>abstractMarkers (in category 'constants') -----
- abstractMarkers
- ^ #(subclassResponsibility shouldNotImplement)!
Item was removed:
- ----- Method: CompiledMethod class>>basicNew (in category 'instance creation') -----
- basicNew
-
- self error: 'CompiledMethods may only be created with newMethod:header:' !
Item was removed:
- ----- Method: CompiledMethod class>>basicNew: (in category 'instance creation') -----
- basicNew: size
-
- self error: 'CompiledMethods may only be created with newMethod:header:' !
Item was removed:
- ----- Method: CompiledMethod class>>disabledMarker (in category 'constants') -----
- disabledMarker
- ^ #shouldNotImplement!
Item was removed:
- ----- Method: CompiledMethod class>>fullFrameSize (in category 'constants') -----
- fullFrameSize "CompiledMethod fullFrameSize"
- ^ LargeFrame!
Item was removed:
- ----- Method: CompiledMethod class>>handleFailingFailingNewMethod:header: (in category 'private') -----
- handleFailingFailingNewMethod: numberOfBytes header: headerWord
- "This newMethod:header: gets sent after handleFailingBasicNew: has done a full
- garbage collection and possibly grown memory. If this basicNew: fails then the
- system really is low on space, so raise the OutOfMemory signal.
-
- Primitive. Answer an instance of this class with the number of indexable variables
- specified by the argument, headerWord, and the number of bytecodes specified
- by numberOfBytes. Fail if this if the arguments are not Integers, or if numberOfBytes
- is negative, or if the receiver is not a CompiledMethod class, or if there is not enough
- memory available. Essential. See Object documentation whatIsAPrimitive."
-
- <primitive: 79>
- "space must be low."
- OutOfMemory signal.
- "retry if user proceeds"
- ^self newMethod: numberOfBytes header: headerWord!
Item was removed:
- ----- Method: CompiledMethod class>>handleFailingNewMethod:header: (in category 'private') -----
- handleFailingNewMethod: numberOfBytes header: headerWord
- "This newMethod:header: gets sent after newMethod:header: has failed
- and allowed a scavenging garbage collection to occur. The scavenging
- collection will have happened as the VM is activating the (failing) basicNew:.
- If handleFailingBasicNew: fails then the scavenge failed to reclaim sufficient
- space and a global garbage collection is required. Retry after garbage
- collecting and growing memory if necessary.
-
- Primitive. Answer an instance of this class with the number of indexable variables
- specified by the argument, headerWord, and the number of bytecodes specified
- by numberOfBytes. Fail if this if the arguments are not Integers, or if numberOfBytes
- is negative, or if the receiver is not a CompiledMethod class, or if there is not enough
- memory available. Essential. See Object documentation whatIsAPrimitive."
-
- <primitive: 79>
- | bytesRequested |
- bytesRequested := (headerWord bitAnd: 16rFFFF) + 1 * Smalltalk wordSize + numberOfBytes + 16.
- Smalltalk garbageCollect < bytesRequested ifTrue:
- [Smalltalk growMemoryByAtLeast: bytesRequested].
- "retry after global garbage collect and possible grow"
- ^self handleFailingFailingNewMethod: numberOfBytes header: headerWord!
Item was removed:
- ----- Method: CompiledMethod class>>headerFlagForEncoder: (in category 'method encoding') -----
- headerFlagForEncoder: anEncoder
- anEncoder class == PrimaryBytecodeSetEncoderClass ifTrue:
- [^0].
- anEncoder class == SecondaryBytecodeSetEncoderClass ifTrue:
- [^SmallInteger minVal].
- self error: 'The encoder is not one of the two installed bytecode sets'!
Item was removed:
- ----- Method: CompiledMethod 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 := EncoderForV3PlusClosures]!
Item was removed:
- ----- Method: CompiledMethod class>>installPrimaryBytecodeSet: (in category 'class initialization') -----
- installPrimaryBytecodeSet: aBytecodeEncoderSubclass
- PrimaryBytecodeSetEncoderClass == aBytecodeEncoderSubclass ifTrue:
- [^self].
- (aBytecodeEncoderSubclass inheritsFrom: BytecodeEncoder) ifFalse:
- [self error: 'A bytecode set encoder is expected to be a subclass of BytecodeEncoder'].
- (self allSubInstances
- detect: [:m| m header >= 0 and: [m encoderClass ~~ aBytecodeEncoderSubclass]]
- ifNone: []) ifNotNil:
- [Warning signal: 'There are existing CompiledMethods with a different encoderClass.'].
- PrimaryBytecodeSetEncoderClass := aBytecodeEncoderSubclass!
Item was removed:
- ----- Method: CompiledMethod class>>installSecondaryBytecodeSet: (in category 'class initialization') -----
- installSecondaryBytecodeSet: aBytecodeEncoderSubclass
- PrimaryBytecodeSetEncoderClass == aBytecodeEncoderSubclass ifTrue:
- [^self].
- (aBytecodeEncoderSubclass inheritsFrom: BytecodeEncoder) ifFalse:
- [self error: 'A bytecode set encoder is expected to be a subclass of BytecodeEncoder'].
- (self allSubInstances
- detect: [:m| m header < 0 and: [m encoderClass ~~ aBytecodeEncoderSubclass]]
- ifNone: []) ifNotNil:
- [Warning signal: 'There are existing CompiledMethods with a different encoderClass.'].
- SecondaryBytecodeSetEncoderClass := aBytecodeEncoderSubclass!
Item was removed:
- ----- Method: CompiledMethod 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: 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>>new (in category 'instance creation') -----
- new
- "This will not make a meaningful method, but it could be used
- to invoke some otherwise useful method in this class."
- ^self newMethod: 2 header: 1024!
Item was removed:
- ----- Method: CompiledMethod class>>new: (in category 'instance creation') -----
- new: size
-
- self error: 'CompiledMethods may only be created with newMethod:header:'!
Item was removed:
- ----- Method: CompiledMethod class>>newBytes:trailerBytes:nArgs:nTemps:nStack:nLits:primitive: (in category 'instance creation') -----
- newBytes: numberOfBytes trailerBytes: trailer nArgs: nArgs nTemps: nTemps nStack: stackSize nLits: nLits primitive: primitiveIndex
- "Answer an instance of me. The header is specified by the message
- arguments. The remaining parts are not as yet determined."
- | method pc |
- nArgs > 15 ifTrue:
- [^self error: 'Cannot compile -- too many arguments'].
- 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: CompiledMethod class>>newBytes:trailerBytes:nArgs:nTemps:nStack:nLits:primitive:flag: (in category 'instance creation') -----
- newBytes: numberOfBytes trailerBytes: trailer nArgs: nArgs nTemps: nTemps nStack: stackSize nLits: nLits primitive: primitiveIndex flag: flag
- "Answer an instance of me. The header is specified by the message
- arguments. The remaining parts are not as yet determined."
- | method pc |
- nArgs > 15 ifTrue:
- [^self error: 'Cannot compile -- too many arguments'].
- 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: CompiledMethod 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: CompiledMethod 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: CompiledMethod 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: 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>
- ^receiver withArgs: argArray executeMethod: compiledMethod!
Item was removed:
- ----- Method: CompiledMethod class>>smallFrameSize (in category 'constants') -----
- smallFrameSize
-
- ^ SmallFrame!
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>>= (in category 'comparing') -----
- = method
- "Answer whether the receiver implements the same code as the argument, method.
- 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."
- | numLits |
- method isCompiledMethod ifFalse: [^false].
- self size = method size ifFalse: [^false].
- self header = method header ifFalse: [^false]. "N.B. includes numLiterals comparison."
- self initialPC to: self endPC do:
- [:i | (self at: i) = (method at: i) ifFalse: [^false]].
- numLits := self numLiterals.
- 1 to: numLits do:
- [:i| | lit1 lit2 |
- lit1 := self literalAt: i.
- lit2 := method 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: method properties)
- ifFalse: [^false]]
- ifFalse: "last literal (methodClassAssociation) of class-side methods is not unique"
- [(i = numLits
- and: [lit1 isVariableBinding
- and: [lit2 isVariableBinding
- and: [lit1 key == lit2 key
- and: [lit1 value == lit2 value]]]]) ifFalse:
- [^false]]]]].
- ^true!
Item was removed:
- ----- Method: CompiledMethod>>abstractBytecodeMessageAt: (in category 'scanning') -----
- abstractBytecodeMessageAt: pc
- "Answer the abstract bytecode message at pc in the receiver."
- ^[(InstructionStream new method: self pc: pc) interpretNextInstructionFor: nil]
- on: MessageNotUnderstood
- do: [:ex| ex message]!
Item was removed:
- ----- Method: CompiledMethod>>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.
- CompiledMethod >> #abstractBytecodeMessagesFrom:to: abstractBytecodeMessagesDo:
- [:msg| msgs add: msg selector].
- msgs"!
Item was removed:
- ----- Method: CompiledMethod>>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 |
- scanner := InstructionStream new method: self pc: startpc.
- [scanner pc <= endpc] whileTrue:
- [[scanner interpretNextInstructionFor: nil]
- on: MessageNotUnderstood
- do: [:ex| aBlock value: ex message]]
-
- "| m msgs |
- msgs := OrderedCollection new.
- (m := CompiledMethod >> #abstractBytecodeMessagesFrom:to:)
- abstractBytecodeMessagesFrom: m initialPC
- to: m endPC
- do: [:msg| msgs add: msg selector].
- msgs"!
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>>allLiterals (in category 'literals') -----
- allLiterals
- ^self literals!
Item was removed:
- ----- Method: CompiledMethod>>asString (in category 'converting') -----
- asString
-
- ^self printString!
Item was removed:
- ----- Method: CompiledMethod>>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: CompiledMethod>>bytecodeSetName (in category 'accessing') -----
- bytecodeSetName
- ^self encoderClass name copyReplaceAll: 'EncoderFor' with: ''!
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>>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: CompiledMethod>>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: 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>>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 isCompiledMethod
- 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: 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 compiledMethodAt: #copyWithTrailerBytes:)
- tempNamesPut: 'copy end '
- "
- | 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 | copy literalAt: i put: (self literalAt: i)].
- 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>>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: 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:
- ["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].
- tempNames := (class newCompiler
- parse: source asString
- in: class
- notifying: nil)
- generate: CompiledMethodTrailer empty;
- schematicTempNamesString].
-
- ^(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>>dropSourcePointer (in category 'source code management') -----
- dropSourcePointer
- self trailer hasSourcePointer ifTrue: [
- self becomeForward:
- (self copyWithTrailerBytes:
- (CompiledMethodTrailer new sourceCode: self getSource))]
- !
Item was removed:
- ----- Method: CompiledMethod>>embeddedBlockClosures (in category 'closures') -----
- embeddedBlockClosures
- | bms extractor scanner endPC |
- bms := OrderedCollection new.
- scanner := self scanner.
- extractor := ClosureExtractor withAction: [ :c | bms add: c ] andScanner: scanner.
- endPC := self endPC.
- [ scanner pc <= endPC ] whileTrue: [ scanner interpretNextInstructionFor: extractor ].
- ^ bms!
Item was removed:
- ----- Method: CompiledMethod>>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: CompiledMethod>>endPC (in category 'accessing') -----
- endPC
- "Answer the index of the last bytecode."
- ^ self trailer endPC
- !
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>>flag (in category 'accessing') -----
- flag
- "Answer the user-level flag bit"
-
- ^((self header bitShift: -29) bitAnd: 1) = 1!
Item was removed:
- ----- Method: CompiledMethod>>flushCache (in category 'accessing') -----
- flushCache
- "Tell the interpreter to remove all references to this method from its method lookup cache, if it has one. This primitive must be called whenever a method is defined or removed.
- NOTE: Only one of two selective flush methods needs to be used.
- Squeak 2.2 and earlier uses 119 (See Symbol flushCache).
- Squeak 2.3 and later uses 116 (See CompiledMethod flushCache)."
-
- <primitive: 116>
- !
Item was removed:
- ----- Method: CompiledMethod>>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: CompiledMethod>>getPreambleFrom:at: (in category 'source code management') -----
- getPreambleFrom: aFileStream at: endPosition
- "This method is an ugly hack. This method assumes that source files have ASCII-compatible encoding and that preambles contain no non-ASCII characters."
-
- | chunkSize chunk |
- chunkSize := 160 min: endPosition.
- [
- | index |
- chunk := aFileStream
- position: (endPosition - chunkSize + 1 max: 0);
- basicNext: chunkSize.
- (index := chunk lastIndexOf: $!! startingAt: chunk size ifAbsent: 0) ~= 0 ifTrue: [
- ^chunk copyFrom: index + 1 to: chunk size ].
- chunkSize := chunkSize * 2.
- chunkSize <= endPosition ] whileTrue.
- ^chunk!
Item was removed:
- ----- Method: CompiledMethod>>getSource (in category 'source code management') -----
- getSource
- ^ self getSourceFor: self selector in:self methodClass.!
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>>hasBreakpoint (in category '*Kernel-tool support') -----
- hasBreakpoint
- ^ self class environment
- at: #BreakpointManager
- ifPresent: [:bpm | bpm methodHasBreakpoint: self]
- ifAbsent: [false]!
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>>hasLiteral: (in category 'literals') -----
- hasLiteral: literal
- "Answer whether the receiver references the argument, literal."
- 2 to: self numLiterals - 1 do: "exclude superclass + selector/properties"
- [:index |
- ((self objectAt: index) literalEqual: literal) ifTrue: [^true]].
- ^false!
Item was removed:
- ----- Method: CompiledMethod>>hasLiteralSuchThat: (in category 'literals') -----
- hasLiteralSuchThat: litBlock
- "Answer true if litBlock returns true for any literal in this method, even if embedded in array structure."
- (self penultimateLiteral isMethodProperties
- and: [self penultimateLiteral hasLiteralSuchThat: litBlock]) ifTrue:
- [^true].
- 2 to: self numLiterals + 1 do:
- [:index | | lit |
- lit := self objectAt: index.
- ((litBlock value: lit)
- or: [lit isArray and: [lit hasLiteralSuchThat: litBlock]]) ifTrue:
- [^true]].
- ^false!
Item was removed:
- ----- Method: CompiledMethod>>hasLiteralThorough: (in category 'literals') -----
- hasLiteralThorough: literal
- "Answer true if any literal in this method is literal,
- even if embedded in array structure."
-
- (self penultimateLiteral isMethodProperties
- and: [self penultimateLiteral hasLiteralThorough: literal]) ifTrue:[^true].
- 2 to: self numLiterals - 1 "exclude superclass + selector/properties"
- do:[:index | | lit |
- (((lit := self objectAt: index) literalEqual: literal)
- or: [(lit isVariableBinding and: [lit key == literal])
- or: [lit isArray and: [lit hasLiteral: literal]]]) ifTrue:
- [^ true]].
- ^ false !
Item was removed:
- ----- Method: CompiledMethod>>hasNewPropertyFormat (in category 'testing') -----
- hasNewPropertyFormat
- "As of the closure compiler all methods have (or better have) the new
- format where the penultimate literal is either the method's selector
- or its properties and the ultimate literal is the class association."
- ^true!
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>>hash (in category 'comparing') -----
- hash
- "CompiledMethod>>#= compares code, i.e. same literals and same bytecode.
- So we look at the header, methodClass and some bytes between initialPC and endPC,
- but /not/ the selector because the equal method does not compare selectors.
- Note that we must override ByteArray>hash which looks at all bytes of the receiver.
- Using bytes from the pointer part of a COmpiledmethod 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 species hash + self header + initialPC + endPC + self methodClass hash bitAnd: 16rFFFFFFF.
- "sample approximately 20 bytes"
- initialPC to: endPC by: (endPC - initialPC // 20 max: 1) do:
- [:i| hash := hash + (self at: i)].
- ^hash
-
- "(CompiledMethod>>#hash) hash"!
Item was removed:
- ----- Method: CompiledMethod>>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.
- There are two different formats, selected by the sign bit. These are
-
- Original Squeak V3:
- 30:sign:0 29:flag 28:prim (high bit) 27-24:numArgs 23-18:numTemps 17:largeFrameFlag 16-9:numLits 8-0:prim (low 9 bits)
-
- Alternate Bytecode Set
- 30:sign:1 29-28:accessModifier 27-24:numArgs 23-18:numTemps 17:largeFrameFlag 16:hasPrimitive 15-0:numLits
-
- i.e. the Alternate Bytecode Set expands the number of literals to 65535 by assuming a CallPrimitive bytecode."
-
- ^self objectAt: 1!
Item was removed:
- ----- Method: CompiledMethod>>headerDescription (in category 'literals') -----
- headerDescription
- "Answer a description containing the information about the form of the
- receiver and the form of the context needed to run the receiver."
-
- ^(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>>indexOfLiteral: (in category 'literals') -----
- indexOfLiteral: literal
- "Answer the literal index of the argument, literal, or zero if none."
- 2 to: self numLiterals - 1 "exclude superclass + selector/properties"
- do:
- [:index |
- literal == (self objectAt: index) ifTrue: [^index - 1]].
- ^0!
Item was removed:
- ----- Method: CompiledMethod>>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: 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>>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>>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>>literalAt: (in category 'literals') -----
- literalAt: index
- "Answer the literal indexed by the argument."
-
- ^self objectAt: index + 1!
Item was removed:
- ----- Method: CompiledMethod>>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: 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>>literals (in category 'literals') -----
- literals
- "Answer an Array of the literals referenced by the receiver."
- | literals numberLiterals |
- literals := Array new: (numberLiterals := self numLiterals).
- 1 to: numberLiterals do:
- [:index |
- literals at: index put: (self objectAt: index + 1)].
- ^literals!
Item was removed:
- ----- Method: CompiledMethod>>literalsDo: (in category 'literals') -----
- literalsDo: aBlock
- "Evaluate aBlock for each of the literals referenced by the receiver."
- 1 to: self numLiterals do:
- [:index |
- aBlock value: (self objectAt: index + 1)]!
Item was removed:
- ----- Method: CompiledMethod>>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: 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>>messages (in category 'scanning') -----
- messages
- "Answer a Set of all the message selectors sent by this method."
-
- | scanner aSet |
- aSet := Set new.
- scanner := InstructionStream on: self.
- scanner
- scanFor:
- [:x |
- scanner addSelectorTo: aSet.
- false "keep scanning"].
- ^aSet!
Item was removed:
- ----- Method: CompiledMethod>>messagesDo: (in category 'scanning') -----
- messagesDo: aBlock
-
- ^ self messages do:aBlock.!
Item was removed:
- ----- Method: CompiledMethod>>messagesSequence (in category 'scanning') -----
- messagesSequence
- "Answer a Set of all the message selectors sent by this method."
-
- ^Array streamContents:
- [:str| | scanner |
- scanner := InstructionStream on: self.
- scanner scanFor:
- [:x | | selectorOrSelf |
- (selectorOrSelf := scanner selectorToSendOrSelf) == scanner ifFalse:
- [str nextPut: selectorOrSelf].
- false "keep scanning"]]!
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>>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 or: [ self primitive = 84 "perform:withArguments:"])
- ifTrue: [largeFrameBit]
- ifFalse: [0])!
Item was removed:
- ----- Method: CompiledMethod>>numArgs (in category 'accessing') -----
- numArgs
- "Answer the number of arguments the receiver takes."
-
- ^ (self header bitShift: -24) bitAnd: 16r0F!
Item was removed:
- ----- Method: CompiledMethod>>numLiterals (in category 'accessing') -----
- numLiterals
- "Answer the number of literals used by the receiver."
- ^self header bitAnd: 16r7FFF!
Item was removed:
- ----- Method: CompiledMethod>>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: CompiledMethod>>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: CompiledMethod>>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: CompiledMethod>>objectForDataStream: (in category 'file in/out') -----
- objectForDataStream: refStrm
-
- self primitive = 117 ifTrue: [self literals first at: 4 put: 0].
- !
Item was removed:
- ----- Method: CompiledMethod>>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: 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]!
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>>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>>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: 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>>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: CompiledMethod>>printSignatureOn: (in category 'printing') -----
- printSignatureOn: 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: 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>>protocol (in category 'accessing') -----
- protocol
- ^self methodClass ifNotNil:
- [:class|
- self selector ifNotNil:
- [:selector|
- class whichCategoryIncludesSelector: selector]]!
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>>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: 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]].
- scanner := InstructionStream on: self.
- ^scanner scanFor:(self encoderClass instVarReadScanBlockFor: varIndexCode using: scanner)!
Item was removed:
- ----- Method: CompiledMethod>>readsRef: (in category 'scanning') -----
- readsRef: variableBinding
- "Answer whether the receiver reads the value of the argument."
- "eem 5/24/2008 Rewritten to no longer assume the compler uses the
- most compact encoding available (for EncoderForLongFormV3 support)."
- | litIndex scanner |
- (litIndex := self indexOfLiteral: variableBinding) = 0 ifTrue:
- [^false].
- scanner := InstructionStream on: self.
- ^scanner scanFor: (self encoderClass bindingReadScanBlockFor: litIndex - 1 using: scanner)!
Item was removed:
- ----- Method: CompiledMethod>>reference (in category 'printing') -----
- reference
- ^ String streamContents: [ : stream | self printReferenceOn: stream ]!
Item was removed:
- ----- Method: CompiledMethod>>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: CompiledMethod>>refersToLiteral: (in category 'literals') -----
- refersToLiteral:aLiteral
-
- ^self hasLiteral: aLiteral.!
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>>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."
- ^ (InstructionStream on: self) scanFor: (byteOrClosure isBlock
- ifTrue: [byteOrClosure]
- ifFalse: [[:instr | instr = byteOrClosure]])
- "
- Smalltalk browseAllSelect: [:m | m scanFor: 134]
- "!
Item was removed:
- ----- Method: CompiledMethod>>scanner (in category 'accessing') -----
- scanner
-
- ^ InstructionStream on: self!
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 MethodProperties 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>>sendsSelector: (in category 'literals') -----
- sendsSelector: aSelector
- | scanner |
- scanner := InstructionStream on: self.
- scanner scanFor:
- [:x |
- scanner selectorToSendOrSelf == aSelector ifTrue:
- [^true].
- false "keep scanning"].
- ^false!
Item was removed:
- ----- Method: CompiledMethod>>sendsToSuper (in category 'scanning') -----
- sendsToSuper
- "Answer whether the receiver sends any message to super."
- | scanner |
- scanner := InstructionStream on: self.
- ^scanner scanFor: (self encoderClass superSendScanBlockUsing: scanner)!
Item was removed:
- ----- Method: CompiledMethod>>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: CompiledMethod>>setSourcePointer: (in category 'source code management') -----
- setSourcePointer: srcPointer
- "We can't change the trailer of existing method, since it could have a
- completely different format. Therefore we need to generate a copy
- with new trailer, containing a srcPointer, and then #become it."
- | trailer copy start |
- trailer := srcPointer = 0
- ifTrue: "catch the common case of setting the source pointer to 0 when already 0"
- [self sourcePointer = 0 ifTrue:
- [^self].
- CompiledMethodTrailer empty]
- ifFalse:
- [CompiledMethodTrailer new sourcePointer: srcPointer].
- copy := self copyWithTrailerBytes: trailer.
-
- "ar 3/31/2010: Be a bit more clever since #become: is slow.
- If the old and the new trailer have the same size, just replace it."
- (self trailer class == trailer class and:[self size = copy size])
- ifTrue:
- [start := self endPC + 1.
- self replaceFrom: start to: self size with: copy startingAt: start]
- ifFalse:
- [self becomeForward: copy].
-
- ^self "will be copy if #become was needed"
- !
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>>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: 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>>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)].
- lits*4+1 to: byteLength do:
- [:ii | aDataStream byteStream nextPut: (self basicAt: ii)].
- "write bytes straight through to the file"!
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>>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: CompiledMethod>>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: CompiledMethod>>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: 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>>trailer (in category 'accessing') -----
- trailer
- "Answer the receiver's trailer"
- ^ CompiledMethodTrailer new method: self
- !
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
-
- "This should be changed after the release of Squeak 4.3 to
- ^self class receiver: aReceiver withArguments: anArray executeMethod: self"
- ^ aReceiver withArgs: anArray executeMethod: self!
Item was removed:
- ----- Method: CompiledMethod>>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: 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."
-
- | scanner |
- self isQuick ifTrue: [^false].
- scanner := InstructionStream on: self.
- ^scanner scanFor: (self encoderClass instVarWriteScanBlockFor: varIndex - 1 using: scanner)!
Item was removed:
- ----- Method: CompiledMethod>>writesRef: (in category 'scanning') -----
- writesRef: variableBinding
- "Answer whether the receiver writes the value of the argument."
- "eem 5/24/2008 Rewritten to no longer assume the compler uses the
- most compact encoding available (for EncoderForLongFormV3 support)."
- | litIndex scanner |
- (litIndex := self indexOfLiteral: variableBinding) = 0 ifTrue:
- [^false].
- scanner := InstructionStream on: self.
- ^scanner scanFor: (self encoderClass bindingWriteScanBlockFor: litIndex - 1 using: scanner)!
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 #decodeUndefined #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>>createMethod:class:header: (in category 'creating a method') -----
- createMethod: numberOfBytesForAllButTrailer class: aCompiledMethodClass header: headerWord
- | meth |
- encodedData ifNil: [self encode].
-
- meth := aCompiledMethodClass newMethod: numberOfBytesForAllButTrailer + size header: headerWord.
- "copy the encoded trailer data"
- 1 to: size do:
- [:i | meth at: meth size - size + i put: (encodedData at: i)].
-
- ^meth!
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 ifAbsent: 0.
- (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"
- ^ 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 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).
- ^ 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 |
- anObject isComplex ifTrue:
- [a := self real.
- b := self imaginary.
- c := anObject real.
- d := anObject imaginary.
- newReal := ((a * c) + (b * d)) / ((c * c) + (d * d)).
- newImaginary := ((b * c) - (a * d)) / ((c * c) + (d * d)).
- ^ 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 devision"
-
- | s ars ais brs bis newReal newImaginary |
- anObject isComplex ifTrue:
- [s := anObject real abs + anObject imaginary abs.
- ars := self real / s.
- ais := self imaginary / s.
- brs := anObject real / s.
- bis := anObject imaginary / s.
- s := brs squared + bis squared.
-
- newReal := ars*brs + (ais*bis) /s.
- newImaginary := ais*brs - (ars*bis)/s.
- ^ 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.
- 0 <= imaginary
- 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>>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: self) 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 imaginary part."
-
- | u v |
- (imaginary = 0 and: [real >= 0])
- ifTrue: [^self class real: real sqrt imaginary: 0].
- v := (self abs - real / 2) sqrt.
- u := imaginary / 2 / v.
- ^self class real: u imaginary: v!
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>>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 subclass: #ContextPart
- instanceVariableNames: 'stackp'
- classVariableNames: 'MaxLengthForASingleDebugLogReport MaxStackDepthForASingleDebugLogReport PrimitiveFailToken QuickStep ValueIndex'
- poolDictionaries: ''
- category: 'Kernel-Methods'!
-
- !ContextPart commentStamp: '<historical>' prior: 0!
- To the instruction parsing ability of InstructionStream I add the actual semantics for execution. The execution state is stored in the indexable fields of my subclasses. This includes temporary variables and a stack of values used in evaluating expressions. The actual semantics of execution can be found in my category "system simulation" and "instruction decode". These methods exactly parallel the operation of the Smalltalk machine itself.
-
- The simulator is a group of my methods that do what the Smalltalk interpreter does: execute Smalltalk bytecodes. By adding code to the simulator, you may take statistics on the running of Smalltalk methods. For example,
- Transcript show: (ContextPart runSimulated: [3 factorial]) printString.!
Item was removed:
- ----- Method: ContextPart 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: ContextPart 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: ContextPart class>>contextEnsure: (in category 'special context creation') -----
- contextEnsure: block
- "Create an #ensure: context that is ready to return from executing its receiver"
-
- | ctxt chain |
- ctxt := thisContext.
- [chain := thisContext sender cut: ctxt. ctxt jump] ensure: block.
- "jump above will resume here without unwinding chain"
- ^ chain!
Item was removed:
- ----- Method: ContextPart 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"
-
- | ctxt chain |
- ctxt := thisContext.
- [chain := thisContext sender cut: ctxt. ctxt jump] on: exceptionClass do: block.
- "jump above will resume here without unwinding chain"
- ^ chain!
Item was removed:
- ----- Method: ContextPart 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: ContextPart class>>initializedInstance (in category 'instance creation') -----
- initializedInstance
- ^ nil!
Item was removed:
- ----- Method: ContextPart class>>isContextClass (in category 'private') -----
- isContextClass
- ^true!
Item was removed:
- ----- Method: ContextPart 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: ContextPart class>>maxLengthForASingleDebugLogReport: (in category 'preferences') -----
- maxLengthForASingleDebugLogReport: anInteger
- MaxLengthForASingleDebugLogReport := anInteger!
Item was removed:
- ----- Method: ContextPart 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: ContextPart class>>maxStackDepthForASingleDebugLogReport: (in category 'preferences') -----
- maxStackDepthForASingleDebugLogReport: anInteger
- MaxStackDepthForASingleDebugLogReport := anInteger!
Item was removed:
- ----- Method: ContextPart class>>new (in category 'instance creation') -----
- new
-
- self error: 'Contexts must only be created with newForMethod:'!
Item was removed:
- ----- Method: ContextPart class>>new: (in category 'instance creation') -----
- new: size
-
- self error: 'Contexts must only be created with newForMethod:'!
Item was removed:
- ----- Method: ContextPart 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: ContextPart class>>primitiveFailToken (in category 'simulation') -----
- primitiveFailToken
-
- ^ PrimitiveFailToken!
Item was removed:
- ----- Method: ContextPart class>>primitiveFailTokenFor: (in category 'simulation') -----
- primitiveFailTokenFor: errorCode
-
- ^{PrimitiveFailToken. errorCode}!
Item was removed:
- ----- Method: ContextPart class>>runSimulated: (in category 'simulation') -----
- runSimulated: aBlock
- "Simulate the execution of the argument, current. Answer the result it
- returns."
-
- ^ thisContext sender
- runSimulated: aBlock
- contextAtEachStep: [:ignored]
-
- "ContextPart runSimulated: [Pen new defaultNib: 5; go: 100]"!
Item was removed:
- ----- Method: ContextPart 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 sender
- runSimulated: aBlock
- contextAtEachStep:
- [:current | tallies add: current nextByte].
- ^tallies sortedElements
-
- "ContextPart tallyInstructions: [3.14159 printString]"!
Item was removed:
- ----- Method: ContextPart 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 sender
- runSimulated: aBlock
- contextAtEachStep:
- [:current |
- current == prev ifFalse: "call or return"
- [prev sender == nil ifFalse: "call only"
- [tallies add: current printString].
- prev := current]].
- ^tallies sortedCounts
-
- "ContextPart tallyMethods: [3.14159 printString]"!
Item was removed:
- ----- Method: ContextPart 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: ContextPart class>>trace: (in category 'examples') -----
- trace: aBlock "ContextPart 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: ContextPart class>>trace:on: (in category 'examples') -----
- trace: aBlock on: aStream "ContextPart trace: [3 factorial]"
- "This method uses the simulator to print calls to a file."
- | prev |
- prev := aBlock.
- ^ thisContext sender
- 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: ContextPart class>>trace:onFileNamed: (in category 'examples') -----
- trace: aBlock onFileNamed: fileName
- "ContextPart 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: ContextPart>>activateMethod:withArgs:receiver:class: (in category 'controlling') -----
- activateMethod: newMethod withArgs: args receiver: rcvr class: class
- "Answer a ContextPart initialized with the arguments."
-
- ^MethodContext
- sender: self
- receiver: rcvr
- method: newMethod
- arguments: args!
Item was removed:
- ----- Method: ContextPart>>activateReturn:value: (in category 'private') -----
- activateReturn: aContext value: value
- "Activate 'aContext return: value' in place of self, so execution will return to aContext's sender"
-
- ^MethodContext
- sender: self
- receiver: aContext
- method: MethodContext theReturnMethod
- arguments: {value}!
Item was removed:
- ----- Method: ContextPart>>arguments (in category 'accessing') -----
- arguments
-
- ^ Array new: self numArgs streamContents: [:args |
- 1 to: self numArgs do: [: i |
- args nextPut: (self tempAt: i)]]!
Item was removed:
- ----- Method: ContextPart>>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: ContextPart>>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: ContextPart>>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: ContextPart>>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: ContextPart>>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: ContextPart>>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: ContextPart>>blockCopy: (in category 'controlling') -----
- blockCopy: numArgs
- "Primitive. Distinguish a block of code from its enclosing method by
- creating a new BlockContext for that block. The compiler inserts into all
- methods that contain blocks the bytecodes to send the message
- blockCopy:. Do not use blockCopy: in code that you write!! Only the
- compiler can decide to send the message blockCopy:. Fail if numArgs is
- not a SmallInteger. Optional. No Lookup. See Object documentation
- whatIsAPrimitive."
-
- <primitive: 80>
- ^ (BlockContext newForMethod: self method)
- home: self home
- startpc: pc + 2
- nargs: numArgs!
Item was removed:
- ----- Method: ContextPart>>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: ContextPart>>cachesStack (in category 'private-debugger') -----
- cachesStack
-
- ^false!
Item was removed:
- ----- Method: ContextPart>>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 tempAt: 1) handles: exception) and: [self tempAt: 3])
- or: [self nextHandlerContext canHandleSignal: exception].
- !
Item was removed:
- ----- Method: ContextPart>>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: ContextPart>>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: ContextPart>>closureCopy:copiedValues: (in category 'controlling') -----
- closureCopy: numArgs copiedValues: anArray
- "Distinguish a block of code from its enclosing method by
- creating a BlockClosure for that block. The compiler inserts into all
- methods that contain blocks the bytecodes to send the message
- closureCopy:copiedValues:. Do not use closureCopy:copiedValues: in code that you write!! Only the
- compiler can decide to send the message closureCopy:copiedValues:. Fail if numArgs is
- not a SmallInteger. Optional. No Lookup. See Object documentation
- whatIsAPrimitive."
-
- <primitive: 200>
- ^BlockClosure outerContext: self startpc: pc + 2 numArgs: numArgs copiedValues: anArray!
Item was removed:
- ----- Method: ContextPart>>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: ContextPart>>contextForLocalVariables (in category 'accessing') -----
- contextForLocalVariables
- "Answer the context in which local variables (temporaries) are stored."
-
- self subclassResponsibility!
Item was removed:
- ----- Method: ContextPart>>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: ContextPart>>copyStack (in category 'query') -----
- copyStack
-
- ^ self copyTo: nil!
Item was removed:
- ----- Method: ContextPart>>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."
-
- | copy |
- self == aContext ifTrue: [ ^nil ].
- copy := self copy.
- sender ifNotNil: [ copy privSender: (sender copyTo: aContext) ].
- ^copy!
Item was removed:
- ----- Method: ContextPart>>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: ContextPart>>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: ContextPart>>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: ContextPart>>doDup (in category 'instruction decoding') -----
- doDup
- "Simulate the action of a 'duplicate top of stack' bytecode."
-
- self push: self top!
Item was removed:
- ----- Method: ContextPart>>doPop (in category 'instruction decoding') -----
- doPop
- "Simulate the action of a 'remove top of stack' bytecode."
-
- self pop!
Item was removed:
- ----- Method: ContextPart>>doPrimitive:method:receiver:args: (in category 'private') -----
- doPrimitive: primitiveIndex method: meth receiver: receiver args: arguments
- "Simulate a primitive method whose index is primitiveIndex. The simulated receiver and
- arguments are given as arguments to this message. If successful, push result and return
- resuming context, else ^ {errCode, PrimitiveFailToken}. Any primitive which provokes
- execution needs to be intercepted and simulated to avoid execution running away."
-
- | 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:
- [ToolSet
- debugContext: self
- label:'Code simulation error'
- contents: nil].
-
- ((primitiveIndex between: 201 and: 222)
- and: [(self objectClass: receiver) includesBehavior: BlockClosure]) ifTrue:
- [((primitiveIndex between: 201 and: 205) "BlockClosure>>value[:value:...]"
- or: [primitiveIndex between: 221 and: 222]) ifTrue: "BlockClosure>>valueNoContextSwitch[:]"
- [^receiver simulateValueWithArguments: arguments caller: self].
- primitiveIndex = 206 ifTrue: "BlockClosure>>valueWithArguments:"
- [^receiver simulateValueWithArguments: arguments first caller: self]].
-
- primitiveIndex = 83 ifTrue: "afr 9/11/1998 19:50" "Object>>perform:[with:...]"
- [^self send: arguments first to: receiver with: arguments allButFirst super: false].
- primitiveIndex = 84 ifTrue: "afr 9/11/1998 19:50 & eem 8/18/2009 17:04" "Object>>perform:withArguments:"
- [^self send: arguments first to: receiver with: (arguments at: 2) lookupIn: (self objectClass: receiver)].
- primitiveIndex = 100 ifTrue: "eem 8/18/2009 16:57" "Object>>perform:withArguments:inSuperclass:"
- [^self send: arguments first to: receiver with: (arguments at: 2) lookupIn: (arguments at: 3)].
-
- "Mutex>>primitiveEnterCriticalSection
- Mutex>>primitiveTestAndSetOwnershipOfCriticalSection"
- (primitiveIndex = 186 or: [primitiveIndex = 187]) ifTrue:
- [| active effective |
- active := Processor activeProcess.
- effective := active effectiveProcess.
- "active == effective"
- value := primitiveIndex = 186
- ifTrue: [receiver primitiveEnterCriticalSectionOnBehalfOf: effective]
- ifFalse: [receiver primitiveTestAndSetOwnershipOfCriticalSectionOnBehalfOf: effective].
- ^(self isPrimFailToken: value)
- ifTrue: [value]
- ifFalse: [self push: value]].
-
- primitiveIndex = 188 ifTrue: "eem 5/27/2008 11:10 Object>>withArgs:executeMethod:"
- [^MethodContext
- sender: self
- receiver: receiver
- method: (arguments at: 2)
- arguments: (arguments at: 1)].
-
- "Closure primitives"
- (primitiveIndex = 200 and: [self == receiver]) ifTrue:
- "ContextPart>>closureCopy:copiedValues:; simulated to get startpc right"
- [^self push: (BlockClosure
- outerContext: receiver
- startpc: pc + 2
- numArgs: arguments first
- copiedValues: arguments last)].
-
- primitiveIndex = 118 ifTrue: "tryPrimitive:withArgs:; avoid recursing in the VM"
- [(arguments size = 2
- and: [arguments first isInteger
- and: [(self objectClass: arguments last) == Array]]) ifFalse:
- [^ContextPart primitiveFailTokenFor: nil].
- ^self doPrimitive: arguments first method: meth receiver: receiver args: arguments last].
-
- value := primitiveIndex = 120 "FFI method"
- ifTrue: [(meth literalAt: 1) tryInvokeWithArguments: arguments]
- ifFalse:
- [primitiveIndex = 117 "named primitives"
- ifTrue: [self tryNamedPrimitiveIn: meth for: receiver withArgs: arguments]
- ifFalse: [receiver tryPrimitive: primitiveIndex withArgs: arguments]].
-
- ^(self isPrimFailToken: value)
- ifTrue: [value]
- ifFalse: [self push: value]!
Item was removed:
- ----- Method: ContextPart>>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: ContextPart>>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: ContextPart>>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: ContextPart>>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: ContextPart>>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: ContextPart>>findSimilarSender (in category 'query') -----
- findSimilarSender
- "Return the closest sender with the same method, return nil if none found"
-
- | meth |
- meth := self method.
- ^ self sender findContextSuchThat: [:c | c method == meth]!
Item was removed:
- ----- Method: ContextPart>>handleSignal: (in category 'private-exceptions') -----
- handleSignal: exception
- "Sent to handler (on:do:) contexts only. If my exception class (first arg) handles exception
- and the handler is active then execute my handle block (second arg), otherwise forward
- this message to the next handler context. If none left, execute exception's defaultAction
- (see nil>>handleSignal:)."
-
- | handlerActive val |
- "If the context has been returned from the handlerActive temp var may not be accessible."
- handlerActive := stackp >= 3 and: [(self tempAt: 3) == true].
- (((self tempAt: 1) handles: exception) and: [handlerActive]) ifFalse:
- [^self nextHandlerContext handleSignal: exception].
-
- exception privHandlerContext: self contextTag.
- self tempAt: 3 put: false. "disable self while executing handle block"
- val := [(self tempAt: 2) cull: exception]
- ensure: [self tempAt: 3 put: true].
- self return: val "return from self if not otherwise directed in handle block"
- !
Item was removed:
- ----- Method: ContextPart>>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: ContextPart>>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: ContextPart>>home (in category 'accessing') -----
- home
- "Answer the context in which the receiver was defined."
-
- self subclassResponsibility!
Item was removed:
- ----- Method: ContextPart>>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: ContextPart>>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: ContextPart>>isClosureContext (in category 'query') -----
- isClosureContext
-
- ^ false!
Item was removed:
- ----- Method: ContextPart>>isContext (in category 'query') -----
- isContext
- ^true!
Item was removed:
- ----- Method: ContextPart>>isDead (in category 'query') -----
- isDead
- "Has self finished"
-
- ^ pc isNil!
Item was removed:
- ----- Method: ContextPart>>isHandlerContext (in category 'private-exceptions') -----
- isHandlerContext
- ^false!
Item was removed:
- ----- Method: ContextPart>>isPrimFailToken: (in category 'private') -----
- isPrimFailToken: anObject
- ^(self objectClass: anObject) == Array
- and: [anObject size = 2
- and: [anObject first == PrimitiveFailToken]]!
Item was removed:
- ----- Method: ContextPart>>isUnwindContext (in category 'private-exceptions') -----
- isUnwindContext
-
- ^false!
Item was removed:
- ----- Method: ContextPart>>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: ContextPart>>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: ContextPart>>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.
- (bool == true or: [bool == false]) ifFalse: [
- ^self
- send: #mustBeBooleanIn:
- to: bool
- with: {self}
- super: false].
- (bool eqv: condition) ifTrue: [self jump: distance]!
Item was removed:
- ----- Method: ContextPart>>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: ContextPart>>method (in category 'accessing') -----
- method
- "Answer the method of this context."
-
- self subclassResponsibility!
Item was removed:
- ----- Method: ContextPart>>methodClass (in category 'debugger access') -----
- methodClass
- "Answer the class in which the receiver's method was found."
-
- ^self method methodClass ifNil: [self objectClass: self receiver].!
Item was removed:
- ----- Method: ContextPart>>methodNode (in category 'accessing') -----
- methodNode
- ^ self method methodNode.!
Item was removed:
- ----- Method: ContextPart>>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: ContextPart>>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: ContextPart>>methodReturnContext (in category 'accessing') -----
- methodReturnContext
- "Answer the context from which an ^-return should return from."
-
- self subclassResponsibility!
Item was removed:
- ----- Method: ContextPart>>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: ContextPart>>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: ContextPart>>namedTempAt: (in category 'debugger access') -----
- namedTempAt: index
- "Answer the value of the temp at index in the receiver's sequence of tempNames."
- ^self debuggerMap namedTempAt: index in: self!
Item was removed:
- ----- Method: ContextPart>>namedTempAt:put: (in category 'debugger access') -----
- namedTempAt: index put: aValue
- "Set the value of the temp at index in the receiver's sequence of tempNames.
- (Note that if the value is a copied value it is also set out along the lexical chain,
- but alas not in along the lexical chain.)."
- ^self debuggerMap namedTempAt: index put: aValue in: self!
Item was removed:
- ----- Method: ContextPart>>nextHandlerContext (in category 'private-exceptions') -----
- nextHandlerContext
-
- ^ self sender findNextHandlerContextStarting!
Item was removed:
- ----- Method: ContextPart>>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: ContextPart>>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 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>
- index isInteger
- ifTrue: [(index >= 1 and: [index <= (self objectSize: anObject)])
- ifTrue: [self errorImproperStore]
- ifFalse: [self errorSubscriptBounds: index]].
- index isNumber
- ifTrue: [^self object: anObject basicAt: index asInteger put: value]
- ifFalse: [self errorNonIntegerIndex]!
Item was removed:
- ----- Method: ContextPart>>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: ContextPart>>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: 73>
- "Access beyond fixed variables."
- ^self object: anObject basicAt: anIndex - (self objectClass: anObject) instSize!
Item was removed:
- ----- Method: ContextPart>>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. 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: 74>
- "Access beyond fixed fields"
- ^self object: anObject basicAt: anIndex - (self objectClass: anObject) instSize put: aValue!
Item was removed:
- ----- Method: ContextPart>>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: ContextPart>>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: ContextPart>>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: ContextPart>>pc (in category 'debugger access') -----
- pc
- "Answer the index of the next bytecode to be executed."
-
- ^pc!
Item was removed:
- ----- Method: ContextPart>>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: ContextPart>>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."
-
- self object: value instVarAt: ValueIndex put: self pop!
Item was removed:
- ----- Method: ContextPart>>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."
-
- self object: self receiver instVarAt: offset + 1 put: self pop!
Item was removed:
- ----- Method: ContextPart>>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: ContextPart>>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 contextForLocalVariables at: offset + 1 put: self pop!
Item was removed:
- ----- Method: ContextPart>>print:on: (in category 'debugger access') -----
- print: anObject on: aStream
- "Safely print anObject in the face of direct ProtoObject subclasses."
- | objClass title |
- objClass := self objectClass: anObject.
- (objClass canUnderstand: #printOn:) ifTrue:
- [^anObject printOn: aStream].
- title := objClass name.
- aStream
- nextPutAll: (title first isVowel ifTrue: ['an '] ifFalse: ['a ']);
- nextPutAll: title!
Item was removed:
- ----- Method: ContextPart>>printDetails: (in category 'printing') -----
- printDetails: strm
- "Put my class>>selector and arguments and temporaries on the stream. Protect against errors during printing."
-
- | str |
- self printOn: strm.
-
- strm cr; tab; nextPutAll: 'Arguments and temporary variables: '; cr.
- str := [self tempsAndValuesLimitedTo: 160 indent: 2] ifError: [:err :rcvr |
- '<<error during printing>>'].
- strm nextPutAll: str.
- strm peekLast == Character cr ifFalse: [strm cr].!
Item was removed:
- ----- Method: ContextPart>>printOn: (in category 'printing') -----
- printOn: aStream
- | method selector class mclass |
- (method := self method) ifNil: [^super printOn: aStream].
- 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 closure isNil
- and: [(self objectClass: (self tempAt: 1)) == Message]]) ifTrue:
- [aStream space.
- (self tempAt: 1) selector printOn: aStream]!
Item was removed:
- ----- Method: ContextPart>>privSender: (in category 'private') -----
- privSender: aContext
-
- sender := aContext!
Item was removed:
- ----- Method: ContextPart>>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: ContextPart>>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: ContextPart>>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: ContextPart>>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
- outerContext: self
- startpc: pc
- numArgs: numArgs
- copiedValues: copiedValues).
- self jump: blockSize!
Item was removed:
- ----- Method: ContextPart>>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: ContextPart>>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: ContextPart>>pushNewArrayOfSize: (in category 'instruction decoding') -----
- pushNewArrayOfSize: arraySize
- self push: (Array new: arraySize)!
Item was removed:
- ----- Method: ContextPart>>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: ContextPart>>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: ContextPart>>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: ContextPart>>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 contextForLocalVariables at: offset + 1)!
Item was removed:
- ----- Method: ContextPart>>quickSend:to:with:super: (in category 'controlling') -----
- quickSend: selector to: rcvr with: arguments super: superFlag
- "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 due to
- Hans-Martin Mosner. Eliot Miranda merely added the mirror primitive code."
- | oldSender contextToReturnTo result lookupClass |
- contextToReturnTo := self.
- lookupClass := superFlag
- ifTrue: [self method methodClassAssociation value superclass]
- ifFalse: [self objectClass: rcvr].
- [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: ContextPart>>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: ContextPart>>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 tempAt: 3 put: true. aBlock value]
- ensure: [self tempAt: 3 put: false]!
Item was removed:
- ----- Method: ContextPart>>receiver (in category 'accessing') -----
- receiver
- "Answer the receiver of the message that created this context."
-
- self subclassResponsibility!
Item was removed:
- ----- Method: ContextPart>>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: ContextPart>>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: ContextPart>>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: ContextPart>>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: ContextPart>>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"
-
- | ctxt unwindBlock |
- self isDead ifTrue: [self cannotReturn: value to: self].
- 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.
- ^ value
- !
Item was removed:
- ----- Method: ContextPart>>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: ContextPart>>return (in category 'controlling') -----
- return
- "Unwind until my sender is on top"
-
- self return: self receiver!
Item was removed:
- ----- Method: ContextPart>>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: ContextPart>>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 ctxt |
- aSender isDead ifTrue: [
- ^ self send: #cannotReturn: to: self with: {value} super: false].
- newTop := aSender sender.
- ctxt := self findNextUnwindContextUpTo: newTop.
- ctxt ifNotNil: [
- ^ self send: #aboutToReturn:through: to: self with: {value. ctxt} super: false].
- self releaseTo: newTop.
- newTop ifNotNil: [newTop push: value].
- ^ newTop
- !
Item was removed:
- ----- Method: ContextPart>>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: ContextPart>>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: ContextPart>>runSimulated:contextAtEachStep: (in category 'system simulation') -----
- runSimulated: aBlock contextAtEachStep: block2
- "Simulate the execution of the argument, aBlock, until it ends. aBlock
- MUST NOT contain an '^'. Evaluate block2 with the current context
- prior to each instruction executed. Answer the simulated value of aBlock."
- | current |
- aBlock hasMethodReturn
- ifTrue: [self error: 'simulation of blocks with ^ can run loose'].
- current := aBlock asContext.
- current pushArgs: Array new from: self.
- [current == self]
- whileFalse:
- [block2 value: current.
- current := current step].
- ^self pop!
Item was removed:
- ----- Method: ContextPart>>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: (ContextPart
- contextOn: UnhandledError do: [:ex |
- error ifNil: [
- error := ex exception.
- topContext := thisContext.
- ex resumeUnchecked: here jump]
- ifNotNil: [ex pass]
- ]).
- ctxt := ctxt insertSender: (ContextPart
- 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: ContextPart>>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: ContextPart>>selector (in category 'debugger access') -----
- selector
- "Answer the selector of the method that created the receiver."
-
- ^self method selector ifNil: [self method defaultSelector].!
Item was removed:
- ----- Method: ContextPart>>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: ContextPart>>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."
-
- | receiver arguments |
- 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 super: superFlag].
- ^self send: selector to: receiver with: arguments super: superFlag!
Item was removed:
- ----- Method: ContextPart>>send:to:with:lookupIn: (in category 'controlling') -----
- send: selector to: rcvr with: arguments lookupIn: lookupClass
- "Simulate the action of sending a message with selector and arguments
- to rcvr. The argument, lookupClass, is the class in which to lookup the
- message. This is the receiver's class for normal messages, but for super
- messages it will be some specific class related to the source method."
-
- | meth primIndex val ctxt |
- (meth := lookupClass lookupSelector: selector) ifNil:
- [^self send: #doesNotUnderstand:
- to: rcvr
- with: {Message selector: selector arguments: arguments}
- lookupIn: lookupClass].
- (primIndex := meth primitive) > 0 ifTrue:
- [val := self doPrimitive: primIndex method: meth receiver: rcvr args: arguments.
- (self isPrimFailToken: val) ifFalse:
- [^val]].
- (selector == #doesNotUnderstand: and: [lookupClass == ProtoObject]) ifTrue:
- [^self error: 'Simulated message ', arguments first selector, ' not understood'].
- ctxt := MethodContext sender: self receiver: rcvr method: meth arguments: arguments.
- primIndex > 0 ifTrue:
- [ctxt failPrimitiveWith: val].
- ^ctxt!
Item was removed:
- ----- Method: ContextPart>>send:to:with:startClass: (in category 'controlling') -----
- send: selector to: rcvr with: args startClass: startClassOrNil
- "Simulate the action of sending a message with selector, selector, and
- arguments, args, to receiver. The argument, startClassOrNil, tells whether
- the selector should be looked up in startClassOrNil or the class of the receiver."
-
- | class meth val ctxt |
- class := startClassOrNil ifNil: [self objectClass: rcvr].
- meth := class lookupSelector: selector.
- meth == nil ifTrue:
- [^self
- send: #doesNotUnderstand:
- to: rcvr
- with: (Array with: (Message selector: selector arguments: args))
- startClass: class].
- (args isArray
- and: [args size = meth numArgs]) ifFalse:
- [^ContextPart primitiveFailTokenFor: nil].
- val := self tryPrimitiveFor: meth receiver: rcvr args: args.
- ((self objectClass: val) == Array
- and: [val size = 2
- and: [val first == PrimitiveFailToken]]) ifFalse:
- [^val].
- (selector == #doesNotUnderstand:
- and: [class == ProtoObject]) ifTrue:
- [^self error: 'Simulated message ' , (args at: 1) selector, ' not understood'].
- ctxt := self activateMethod: meth withArgs: args receiver: rcvr class: class.
- ((self objectClass: val) == Array
- and: [val size = 2
- and: [val first == PrimitiveFailToken
- and: [val last notNil
- and: [(ctxt method at: ctxt pc) = 129 "long store temp"]]]]) ifTrue:
- [ctxt at: ctxt stackPtr put: val last].
- ^ctxt!
Item was removed:
- ----- Method: ContextPart>>send:to:with:super: (in category 'controlling') -----
- send: selector to: rcvr with: arguments super: superFlag
- "Simulate the action of sending a message with selector arguments
- to rcvr. The argument, superFlag, tells whether the receiver of the
- message was specified with 'super' in the source method."
-
- ^self send: selector
- to: rcvr
- with: arguments
- lookupIn: (superFlag
- ifTrue: [self method methodClassAssociation value superclass]
- ifFalse: [self objectClass: rcvr])!
Item was removed:
- ----- Method: ContextPart>>sender (in category 'debugger access') -----
- sender
- "Answer the context that sent the message that created the receiver."
-
- ^sender!
Item was removed:
- ----- Method: ContextPart>>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: ContextPart>>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: ContextPart>>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: ContextPart>>sourceCode (in category 'debugger access') -----
- 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: ContextPart>>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: ContextPart>>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: ContextPart>>stackPtr (in category 'private') -----
- stackPtr "For use only by the SystemTracer and the Debugger, Inspectors etc"
- ^ stackp!
Item was removed:
- ----- Method: ContextPart>>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: ContextPart>>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: ContextPart>>stepToCallee (in category 'system simulation') -----
- stepToCallee
- "Step to callee or sender"
-
- | ctxt |
- ctxt := self.
- [(ctxt := ctxt step) == self] whileTrue.
- ^ ctxt!
Item was removed:
- ----- Method: ContextPart>>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 willStore]]] whileFalse:
- [ctxt := self step.
- ctxt == self ifFalse:
- [self halt.
- "Caused by mustBeBoolean handling"
- ^ctxt]]!
Item was removed:
- ----- Method: ContextPart>>storeDataOn: (in category 'objects from disk') -----
- storeDataOn: aDataStream
- "Contexts are not allowed go to out in DataStreams. They must be included inside an ImageSegment."
-
- aDataStream insideASegment ifTrue: [^ super storeDataOn: aDataStream].
-
- self error: 'This Context was not included in the ImageSegment'.
- "or perhaps ImageSegments were not used at all"
- ^ nil!
Item was removed:
- ----- Method: ContextPart>>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."
-
- self object: value instVarAt: ValueIndex put: self top!
Item was removed:
- ----- Method: ContextPart>>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."
-
- self object: self receiver instVarAt: offset + 1 put: self top!
Item was removed:
- ----- Method: ContextPart>>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: ContextPart>>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 contextForLocalVariables at: offset + 1 put: self top!
Item was removed:
- ----- Method: ContextPart>>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: ContextPart>>tempAt: (in category 'accessing') -----
- tempAt: index
- "Answer the value of the temporary variable whose index is the
- argument, index."
-
- self subclassResponsibility!
Item was removed:
- ----- Method: ContextPart>>tempAt:put: (in category 'accessing') -----
- tempAt: index put: value
- "Store the argument, value, as the temporary variable whose index is the
- argument, index."
-
- self subclassResponsibility!
Item was removed:
- ----- Method: ContextPart>>tempNames (in category 'debugger access') -----
- tempNames
- "Answer a SequenceableCollection of the names of the receiver's temporary
- variables, which are strings."
-
- ^ self debuggerMap tempNamesForContext: self!
Item was removed:
- ----- Method: ContextPart>>tempsAndValues (in category 'debugger access') -----
- tempsAndValues
- "Return a string of the temporary variables and their current values"
- ^self debuggerMap tempsAndValuesForContext: self!
Item was removed:
- ----- Method: ContextPart>>tempsAndValuesLimitedTo:indent: (in category 'debugger access') -----
- tempsAndValuesLimitedTo: sizeLimit indent: indent
- "Return a string of the temporary variabls and their current values"
-
- | aStream |
- aStream := WriteStream on: (String new: 100).
- self tempNames
- doWithIndex: [:title :index |
- indent timesRepeat: [aStream tab].
- aStream nextPutAll: title; nextPut: $:; space; tab.
- aStream nextPutAll:
- ((self tempAt: index) printStringLimitedTo: (sizeLimit -3 -title size max: 1)).
- aStream cr].
- ^aStream contents!
Item was removed:
- ----- Method: ContextPart>>terminate (in category 'controlling') -----
- terminate
- "Make myself unresumable."
-
- sender := nil.
- pc := nil.
- !
Item was removed:
- ----- Method: ContextPart>>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: ContextPart>>top (in category 'controlling') -----
- top
- "Answer the top of the receiver's stack."
-
- ^self at: stackp!
Item was removed:
- ----- Method: ContextPart>>tryNamedPrimitiveIn:for:withArgs: (in category 'private') -----
- tryNamedPrimitiveIn: aCompiledMethod for: aReceiver withArgs: arguments
- "Invoke the named primitive for aCompiledMethod, answering its result, or,
- if the primiitve fails, answering the error code."
- <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: ContextPart>>tryPrimitiveFor:receiver:args: (in category 'private') -----
- tryPrimitiveFor: method receiver: receiver args: arguments
- "If this method has a primitive index, then run the primitive and return its result.
- Otherwise (and also if the primitive fails) return PrimitiveFailToken,
- as an indication that the method should be activated and run as bytecodes."
- | primIndex |
- (primIndex := method primitive) = 0 ifTrue: [^{PrimitiveFailToken. nil}].
- ^ self doPrimitive: primIndex method: method receiver: receiver args: arguments!
Item was removed:
- ----- Method: ContextPart>>unwindTo: (in category 'private-exceptions') -----
- unwindTo: aContext
-
- | ctx unwindBlock |
- ctx := self.
- [(ctx := ctx findNextUnwindContextUpTo: aContext) isNil] whileFalse: [
- (ctx tempAt: 2) ifNil:[
- ctx tempAt: 2 put: true.
- unwindBlock := ctx tempAt: 1.
- unwindBlock value]
- ].
- !
Item was changed:
Timespan subclass: #Date
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: 'ChronologyConstants'
+ category: 'Chronology-Core'!
- category: 'Kernel-Chronology'!
!Date commentStamp: 'cmm 2/3/2012 17:30' prior: 0!
Instances of Date are Timespans with duration of 1 day.
Their default creation assumes a start of midnight of UTC to provide the fast, globalized Dates out of the box. The legacy behavior that creates Timezone-sensitive Dates can be used by sending #localizedDates.
!
Item was changed:
Magnitude subclass: #DateAndTime
instanceVariableNames: 'seconds offset jdn nanos'
classVariableNames: 'AutomaticTimezone ClockProvider LastClockValue LocalTimeZone NanoOffset'
poolDictionaries: 'ChronologyConstants'
+ category: 'Chronology-Core'!
- category: 'Kernel-Chronology'!
!DateAndTime commentStamp: 'bf 2/18/2016 16:20' prior: 0!
I represent a point in UTC time as defined by ISO 8601. I have zero duration.
My implementation uses three SmallIntegers
and a Duration:
jdn - julian day number.
seconds - number of seconds since midnight.
nanos - the number of nanoseconds since the second.
offset - duration from UTC (possibly nil if no timezone information)
The nanosecond attribute is almost always zero but it defined for full ISO compliance and is suitable for timestamping.
!
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>>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:atMilliseconds: (in category 'primitives') -----
- primSignal: aSemaphore atMilliseconds: aSmallInteger
- "Signal the semaphore when the millisecond clock reaches the value of the second argument. Fail if the first argument is neither a Semaphore nor nil. Essential. See Object documentation whatIsAPrimitive."
- <primitive: 136>
- ^self primitiveFailed!
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 atMilliseconds: 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.
- !
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."
-
- 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 suspend; 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>>maybeSignalDeprecationFor:message:explanation: (in category 'utilities') -----
- maybeSignalDeprecationFor: context message: messageString explanation: explanationString
- self showDeprecationWarnings ifTrue:
- [ | message |
- message := context method reference, ' has been deprecated', messageString, '.'.
- explanationString ifNotEmpty: [message := message, ' ', explanationString].
- self signal: message].!
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:
- 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 changed:
Magnitude subclass: #Duration
instanceVariableNames: 'nanos seconds'
classVariableNames: ''
poolDictionaries: 'ChronologyConstants'
+ category: 'Chronology-Core'!
- category: 'Kernel-Chronology'!
!Duration commentStamp: 'dtl 7/11/2009 15:03' prior: 0!
I represent a duration of time. I have nanosecond precision!
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: '<historical>' 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.
-
- Additional notes:
- Error>defaultAction uses an explicit test for the presence of the Debugger class to decide whether or not it is in development mode. In the future, TFEI hopes to enhance the semantics of #defaultAction to improve support for pluggable default handlers.!
Item was removed:
- ----- Method: Error>>defaultAction (in category 'exceptionDescription') -----
- 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 'private') -----
- isResumable
- "Determine whether an exception is resumable."
-
- ^ false!
Item was removed:
- Object subclass: #EventSensor
- instanceVariableNames: 'mouseButtons mousePosition keyboardBuffer interruptKey interruptSemaphore eventQueue inputSemaphore lastEventPoll hasInputSemaphore'
- classVariableNames: 'ButtonDecodeTable EventPollPeriod EventTicklerProcess InterruptSemaphore InterruptWatcherProcess KeyDecodeTable'
- poolDictionaries: 'EventSensorConstants'
- category: 'Kernel-Processes'!
-
- !EventSensor commentStamp: 'dtl 1/30/2016 14:44' 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.
- Structure:
- [1] - event type 1
- [2] - time stamp
- [3] - mouse x position
- [4] - mouse y position
- [5] - button state; bitfield with the following entries:
- 1 - yellow (e.g., right) button
- 2 - blue (e.g., middle) button
- 4 - 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] - reserved.
-
- Keyboard events
- ====================
- Keyboard events are generated when keyboard input is detected.
- [1] - event type 2
- [2] - time stamp
- [3] - character code
- For now the character code is in Mac Roman encoding.
- [4] - press state; integer with the following meaning
- 0 - character
- 1 - key press (down)
- 2 - key release (up)
- [5] - modifier keys (same as in mouse events)
- [6] - reserved.
- [7] - reserved.
- [8] - reserved.
- !
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>>defaultCrossPlatformKeys (in category 'class initialization') -----
- defaultCrossPlatformKeys
- "Answer a list of key letters that are used for common editing operations
- on different platforms."
- ^{ $c . $x . $v . $a . $s . $f . $g . $z }
- !
Item was removed:
- ----- Method: EventSensor class>>duplicateAllControlAndAltKeysChanged (in category 'preference change notification') -----
- duplicateAllControlAndAltKeysChanged
- "The Preference for duplicateAllControlAndAltKeys has changed; reset the other two."
- "At some point the various exclusive CtrlAlt-key prefs should become a radio button set, then these methods wouldn't be needed."
- (Preferences
- valueOfFlag: #swapControlAndAltKeys
- ifAbsent: [false]) ifTrue: [
- self inform: 'Resetting swapControlAndAltKeys preference'.
- (Preferences preferenceAt: #swapControlAndAltKeys) rawValue: false.
- ].
- (Preferences
- valueOfFlag: #duplicateControlAndAltKeys
- ifAbsent: [false]) ifTrue: [
- self inform: 'Resetting duplicateControlAndAltKeys preference'.
- (Preferences preferenceAt: #duplicateControlAndAltKeys) rawValue: false.
- ].
- self installKeyDecodeTable.
- !
Item was removed:
- ----- Method: EventSensor class>>duplicateControlAndAltKeysChanged (in category 'preference change notification') -----
- duplicateControlAndAltKeysChanged
- "The Preference for duplicateControlAndAltKeys has changed; reset the other two."
- (Preferences
- valueOfFlag: #swapControlAndAltKeys
- ifAbsent: [false]) ifTrue: [
- self inform: 'Resetting swapControlAndAltKeys preference'.
- (Preferences preferenceAt: #swapControlAndAltKeys) rawValue: false.
- ].
- (Preferences
- valueOfFlag: #duplicateAllControlAndAltKeys
- ifAbsent: [false]) ifTrue: [
- self inform: 'Resetting duplicateAllControlAndAltKeys preference'.
- (Preferences preferenceAt: #duplicateAllControlAndAltKeys) rawValue: false.
- ].
- self installKeyDecodeTable.
- !
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>>initialize (in category 'class initialization') -----
- initialize
-
- Smalltalk addToStartUpList: self after: Cursor.
- Smalltalk addToShutDownList: self.
-
- self installKeyDecodeTable.
- self installMouseDecodeTable.
- self install.
-
- !
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>>installDuplicateKeyEntryFor: (in category 'key decode table') -----
- installDuplicateKeyEntryFor: c
- | key |
- key := c asInteger.
- "first do control->alt key"
- KeyDecodeTable at: { key bitAnd: 16r9F . 2 } put: { key . 8 }.
- "then alt->alt key"
- KeyDecodeTable at: { key . 8 } put: { key . 8 }
- !
Item was removed:
- ----- Method: EventSensor class>>installKeyDecodeTable (in category 'class initialization') -----
- installKeyDecodeTable
- "Create a decode table that swaps some keys if
- Preferences swapControlAndAltKeys is set"
- KeyDecodeTable := Dictionary new.
- Preferences duplicateControlAndAltKeys
- ifTrue: [ self defaultCrossPlatformKeys do:
- [ :c | self installDuplicateKeyEntryFor: c ] ].
- Preferences swapControlAndAltKeys
- ifTrue: [ self defaultCrossPlatformKeys do:
- [ :c | self installSwappedKeyEntryFor: c ] ].
- Preferences duplicateAllControlAndAltKeys
- ifTrue: [ (Character allByteCharacters select: [:ea | ea isAlphaNumeric]) do:
- [ :c | self installDuplicateKeyEntryFor: c ] ].
- !
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>>installSwappedKeyEntryFor: (in category 'key decode table') -----
- installSwappedKeyEntryFor: c
- | key |
- key := c asInteger.
- "first do control->alt key"
- KeyDecodeTable at: { key bitAnd: 16r9F . 2 } put: { key . 8 }.
- "then alt->control key"
- KeyDecodeTable at: { key . 8 } put: { key bitAnd: 16r9F . 2 }!
Item was removed:
- ----- Method: EventSensor class>>keyDecodeTable (in category 'key decode table') -----
- keyDecodeTable
- ^KeyDecodeTable ifNil: [ self installKeyDecodeTable ]!
Item was removed:
- ----- Method: EventSensor class>>shutDown (in category 'system startup') -----
- shutDown
- self default shutDown.!
Item was removed:
- ----- Method: EventSensor class>>startUp (in category 'system startup') -----
- startUp
-
- self installMouseDecodeTable.
- self installKeyDecodeTable.
- self default startUp!
Item was removed:
- ----- Method: EventSensor class>>swapControlAndAltKeysChanged (in category 'preference change notification') -----
- swapControlAndAltKeysChanged
- "The Preference for swapControlAndAltKeys has changed; reset the other two."
- (Preferences
- valueOfFlag: #duplicateControlAndAltKeys
- ifAbsent: [false]) ifTrue: [
- self inform: 'Resetting duplicateControlAndAltKeys preference'.
- (Preferences preferenceAt: #duplicateControlAndAltKeys) rawValue: false.
- ].
- (Preferences
- valueOfFlag: #duplicateAllControlAndAltKeys
- ifAbsent: [false]) ifTrue: [
- self inform: 'Resetting duplicateAllControlAndAltKeys preference'.
- (Preferences preferenceAt: #duplicateAllControlAndAltKeys) rawValue: false.
- ].
- self installKeyDecodeTable.
- !
Item was removed:
- ----- Method: EventSensor>>anyButtonPressed (in category 'mouse') -----
- anyButtonPressed
- "Answer whether at least one mouse button is currently being pressed."
-
- ^ self primMouseButtons anyMask: 7
- !
Item was removed:
- ----- Method: EventSensor>>anyModifierKeyPressed (in category 'modifier keys') -----
- anyModifierKeyPressed
- "ignore, however, the shift keys 'cause that's not REALLY a command key"
-
- ^ self primMouseButtons anyMask: 16r70 "cmd | opt | ctrl"!
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 primMouseButtons bitAnd: 7) = 1
- !
Item was removed:
- ----- Method: EventSensor>>characterForKeycode: (in category 'keyboard') -----
- characterForKeycode: keycode
- "Map the given keycode to a Smalltalk character object. Encoding:
- A keycode is 12 bits: <4 modifer bits><8 bit ISO character>
- Modifier bits are: <command><option><control><shift>"
-
- "NOTE: the command and option keys are specific to the Macintosh and may not have equivalents on other platforms."
-
- keycode = nil ifTrue: [ ^nil ].
- keycode class = Character ifTrue: [ ^keycode ]. "to smooth the transition!!"
- ^ Character value: (keycode bitAnd: 16rFF)!
Item was removed:
- ----- Method: EventSensor>>commandKeyPressed (in category 'modifier keys') -----
- commandKeyPressed
- "Answer whether the command key on the keyboard is being held down."
-
- ^ self primMouseButtons anyMask: 64!
Item was removed:
- ----- Method: EventSensor>>controlKeyPressed (in category 'modifier keys') -----
- controlKeyPressed
- "Answer whether the control key on the keyboard is being held down."
-
- ^ self primMouseButtons anyMask: 16!
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 primMouseButtons.
- pos := self primMousePt.
- modifiers := buttons bitShift: -3.
- buttons := buttons bitAnd: 7.
- mapped := self mapButtons: buttons modifiers: modifiers.
- eventBuffer
- at: 1
- put: EventTypeMouse;
- at: 2 put: Time eventMillisecondClock;
- 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 'cursor') -----
- cursorPoint
- "Answer a Point indicating the cursor location."
-
- ^ self peekPosition!
Item was removed:
- ----- Method: EventSensor>>cursorPoint: (in category 'cursor') -----
- 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>>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>>flushAllButDandDEvents (in category 'accessing') -----
- flushAllButDandDEvents
- | newQueue oldQueue |
-
- newQueue := SharedQueue new.
- self eventQueue ifNil: [
- self eventQueue: newQueue.
- ^ self].
- oldQueue := self eventQueue.
- [oldQueue size > 0] whileTrue:
- [| item type |
- item := oldQueue next.
- type := item at: 1.
- type = EventTypeDragDropFiles ifTrue: [ newQueue nextPut: item]].
- self eventQueue: newQueue.!
Item was removed:
- ----- Method: EventSensor>>flushEvents (in category 'accessing') -----
- flushEvents
- self eventQueue ifNotNil:[:queue | queue flush].!
Item was removed:
- ----- Method: EventSensor>>flushKeyboard (in category 'keyboard') -----
- flushKeyboard
- "Remove all characters from the keyboard buffer."
-
- [self keyboardPressed]
- whileTrue: [self keyboard]!
Item was removed:
- ----- Method: EventSensor>>flushNonKbdEvents (in category 'private') -----
- flushNonKbdEvents
-
- self eventQueue ifNotNil: [:queue |
- queue flushAllSuchThat: [:buf | (self isKbdEvent: buf) not]].!
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
- "Initialize the receiver"
- mouseButtons := 0.
- mousePosition := 0 @ 0.
- keyboardBuffer := SharedQueue new.
- self setInterruptKey: (interruptKey ifNil: [$. asciiValue bitOr: 16r0800 ]). "cmd-."
- interruptSemaphore := (Smalltalk specialObjectsArray at: 31) ifNil: [Semaphore new].
- self flushAllButDandDEvents.
- 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].
- InterruptSemaphore := Semaphore new.
- InterruptWatcherProcess := [self userInterruptWatcher] forkAt: Processor lowIOPriority.
- self primInterruptSemaphore: InterruptSemaphore.!
Item was removed:
- ----- Method: EventSensor>>interruptWatcherProcess (in category 'user interrupts') -----
- interruptWatcherProcess
- "Answer my interrupt watcher process, if any"
- ^InterruptWatcherProcess!
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>>kbdTest (in category 'keyboard') -----
- kbdTest "Sensor kbdTest"
- "This test routine will print the unmodified character, its keycode,
- and the OR of all its modifier bits, until the character x is typed"
- | char evt |
- char := nil.
- [char = $x] whileFalse:
- [[(evt := self peekKeyboardEvent) isNil] whileTrue.
- char := self characterForKeycode: evt third.
- (String streamContents:
- [:s |
- s nextPut: char.
- (3 to: 8) with: 'cpmurw' do:
- [:i :c|
- s space; nextPut: c; nextPut: $:; print: (evt at: i); nextPutAll: ' ']])
- displayAt: 10 at 10]!
Item was removed:
- ----- Method: EventSensor>>keyboard (in category 'keyboard') -----
- keyboard
- "Answer the next character from the keyboard."
-
- | firstCharacter secondCharactor stream multiCharacter converter |
- firstCharacter := self characterForKeycode: self primKbdNext.
- secondCharactor := self characterForKeycode: self primKbdPeek.
- secondCharactor isNil
- ifTrue: [^ firstCharacter].
- converter := TextConverter defaultSystemConverter.
- converter isNil
- ifTrue: [^ firstCharacter].
- stream := ReadStream
- on: (String with: firstCharacter with: secondCharactor).
- multiCharacter := converter nextFromStream: stream.
- multiCharacter isOctetCharacter
- ifTrue: [^ multiCharacter].
- self primKbdNext.
- ^ multiCharacter
- !
Item was removed:
- ----- Method: EventSensor>>keyboardPeek (in category 'keyboard') -----
- keyboardPeek
- "Answer the next character in the keyboard buffer without removing it, or nil if it is empty."
-
- ^ self characterForKeycode: self primKbdPeek!
Item was removed:
- ----- Method: EventSensor>>keyboardPressed (in category 'keyboard') -----
- keyboardPressed
- "Answer true if keystrokes are available."
-
- ^self primKbdPeek notNil!
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 primMouseButtons 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 primMouseButtons bitAnd: 7
- !
Item was removed:
- ----- Method: EventSensor>>nextEvent (in category 'accessing') -----
- nextEvent
- "Return the next event from the receiver."
-
- ^ self eventQueue
- ifNil: [self nextEventSynthesized]
- ifNotNil: [self nextEventFromQueue]
- !
Item was removed:
- ----- Method: EventSensor>>nextEventFromQueue (in category 'private') -----
- nextEventFromQueue
- "Return the next event from the receiver. If the queue is empty, try to fetch more events once."
-
- self eventQueue isEmpty
- ifTrue: [self fetchMoreEvents].
-
- ^ self eventQueue isEmpty
- ifTrue: [nil]
- ifFalse: [self eventQueue next]!
Item was removed:
- ----- Method: EventSensor>>nextEventSynthesized (in category 'private') -----
- nextEventSynthesized
- "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.
- kbd := self primKbdNext.
- kbd ifNotNil:
- ["simulate keyboard event"
- array at: 1 put: EventTypeKeyboard. "evt type"
- array at: 2 put: Time eventMillisecondClock. "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"
- ^ array].
-
- "Then check for mouse"
- pos := self primMousePt.
- buttons := mouseButtons.
- modifiers := buttons bitShift: -3.
- buttons := buttons bitAnd: 7.
- mapped := self mapButtons: buttons modifiers: modifiers.
- array
- at: 1 put: EventTypeMouse;
- at: 2 put: Time eventMillisecondClock;
- at: 3 put: pos x;
- at: 4 put: pos y;
- at: 5 put: mapped;
- at: 6 put: modifiers.
- ^ array
-
- !
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>>peekButtons (in category 'accessing') -----
- peekButtons
- self fetchMoreEvents.
- ^mouseButtons!
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: [nil]
- ifNotNil: [:queue |
- self fetchMoreEvents.
- queue peek]!
Item was removed:
- ----- Method: EventSensor>>peekKeyboardEvent (in category 'accessing') -----
- peekKeyboardEvent
- "Return the next keyboard char event from the receiver or nil if none available"
-
- ^ self eventQueue
- ifNil: [nil]
- ifNotNil: [:queue |
- self fetchMoreEvents.
- queue nextOrNilSuchThat: [:buf |
- buf first = EventTypeKeyboard and: [(buf fourth) = EventKeyChar]]]!
Item was removed:
- ----- Method: EventSensor>>peekPosition (in category 'accessing') -----
- peekPosition
- ^ self primMousePt!
Item was removed:
- ----- Method: EventSensor>>primCursorLocPut: (in category 'primitives-cursor') -----
- 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 'primitives-cursor') -----
- 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: Time eventMillisecondClock. "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: Time eventMillisecondClock;
- at: 3 put: pos x;
- at: 4 put: pos y;
- at: 5 put: mapped;
- at: 6 put: modifiers.
- !
Item was removed:
- ----- Method: EventSensor>>primInterruptSemaphore: (in category 'private') -----
- primInterruptSemaphore: 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."
- interruptSemaphore := aSemaphore.
- "backward compatibility: use the old primitive which is obsolete now"
- self oldPrimInterruptSemaphore: aSemaphore!
Item was removed:
- ----- Method: EventSensor>>primKbdNext (in category 'private') -----
- primKbdNext
- "Allows for use of old Sensor protocol to get at the keyboard,
- as when running kbdTest or the InterpreterSimulator in Morphic"
- | evtBuf |
- self fetchMoreEvents.
- keyboardBuffer isEmpty ifFalse:[^ keyboardBuffer next].
- self eventQueue ifNotNil: [:queue |
- evtBuf := queue nextOrNilSuchThat: [:buf | self isKbdEvent: buf].
- self flushNonKbdEvents].
- ^ evtBuf ifNotNil: [evtBuf at: 3]
- !
Item was removed:
- ----- Method: EventSensor>>primKbdPeek (in category 'private') -----
- primKbdPeek
- "Allows for use of old Sensor protocol to get at the keyboard,
- as when running kbdTest or the InterpreterSimulator in Morphic"
- | char |
- self fetchMoreEvents.
- keyboardBuffer isEmpty ifFalse: [^ keyboardBuffer peek].
- char := nil.
- self eventQueue ifNotNil: [:queue |
- queue nextOrNilSuchThat: "NOTE: must not return out of this block, so loop to end"
- [:buf | (self isKbdEvent: buf) ifTrue: [char ifNil: [char := buf at: 3]].
- false "NOTE: block value must be false so Queue won't advance"]].
- ^ char!
Item was removed:
- ----- Method: EventSensor>>primMouseButtons (in category 'private') -----
- primMouseButtons
- self fetchMoreEvents.
- self flushNonKbdEvents.
- ^ mouseButtons!
Item was removed:
- ----- Method: EventSensor>>primMousePt (in category 'private') -----
- primMousePt
- self fetchMoreEvents.
- "self flushNonKbdEvents. -- mt: Should not be necessary here."
- ^ mousePosition!
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>>primSetInterruptKey: (in category 'private') -----
- primSetInterruptKey: 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>."
- interruptKey := anInteger.
- "backward compatibility: use the old primitive which is obsolete now"
- self oldPrimSetInterruptKey: anInteger!
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.
-
- "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 first"
- type = EventTypeMouse
- 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.
- self processMouseEvent: evt .
- ^self].
-
-
- "Store the event in the queue if there's any"
- type = EventTypeKeyboard
- ifTrue: [ "Check if the event is a user interrupt"
- ((evt at: 4) = 0
- and: [((evt at: 3)
- bitOr: (((evt at: 5)
- bitAnd: 8)
- bitShift: 8))
- = interruptKey])
- ifTrue: ["interrupt key is meta - not reported as event"
- ^ interruptSemaphore signal].
- "Else swap ctrl/alt keys if neeeded.
- Look at the Unicode char first, then ascii."
- KeyDecodeTable
- at: {evt at: 6. evt at: 5}
- ifPresent: [:a | evt at: 6 put: a first;
- at: 5 put: a second].
- KeyDecodeTable
- at: {evt at: 3. evt at: 5}
- ifPresent: [:a | evt at: 3 put: a first;
- at: 5 put: a second].
- self queueEvent: evt.
- self processKeyboardEvent: evt .
- ^self ].
-
- "Handle all events other than Keyborad 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"
- | charCode pressCode |
- "Never update keyboardBuffer if we have an eventQueue active"
- mouseButtons := (mouseButtons bitAnd: 7) bitOr: ((evt at: 5) bitShift: 3).
- self eventQueue ifNotNil:[^self].
- charCode := evt at: 3.
- charCode = nil ifTrue:[^self]. "extra characters not handled in MVC"
- pressCode := evt at: 4.
- pressCode = EventKeyChar ifFalse:[^self]. "key down/up not handled in MVC"
- "mix in modifiers"
- charCode := charCode bitOr: ((evt at: 5) bitShift: 8).
- keyboardBuffer nextPut: charCode.!
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: 3).!
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 clone].!
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 primMouseButtons anyMask: 32!
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 primMouseButtons bitAnd: 7) = 4
- !
Item was removed:
- ----- Method: EventSensor>>setInterruptKey: (in category 'user interrupts') -----
- setInterruptKey: anInteger
- "Register the given keycode as the user interrupt key."
-
- self primSetInterruptKey: anInteger.
- !
Item was removed:
- ----- Method: EventSensor>>shiftPressed (in category 'modifier keys') -----
- shiftPressed
- "Answer whether the shift key on the keyboard is being held down."
-
- ^ self primMouseButtons anyMask: 8
- !
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.
-
- Smalltalk isMorphic ifTrue: [self flushAllButDandDEvents].
-
- "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 defaultOrNil ifNotNil: [ : soundSystem | soundSystem shutDown ].
- 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 primMouseButtons 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 EventTypeNone EventTypeWindow OptionKeyBit RedButtonBit ShiftKeyBit TouchPhaseBegan TouchPhaseCancelled TouchPhaseEnded TouchPhaseMoved TouchPhaseStationary WindowEventActivated WindowEventClose WindowEventIconise WindowEventMetricChange WindowEventPaint WindowEventStinks 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.
-
- "Press codes for keyboard events"
- EventKeyChar := 0.
- EventKeyDown := 1.
- EventKeyUp := 2.
-
- "Host window events"
- WindowEventMetricChange := 1.
- WindowEventClose := 2.
- WindowEventIconise := 3.
- WindowEventActivated := 4.
- WindowEventPaint := 5.
- WindowEventStinks := 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: '<historical>' 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 BlockContext>>valueUninterruptably (and by extension, #ensure: and #ifCurtailed:), and we imported the following methods with little or no modification:
-
- ContextPart>>terminateTo:
- ContextPart>>terminate
- MethodContext>>receiver:
- MethodContext>>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>>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 |
- self isResumable ifTrue: [
- 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 nextHandlerContext handleSignal: self!
Item was removed:
- ----- Method: Exception>>printOn: (in category 'printing') -----
- printOn: stream
-
- stream nextPutAll: self description!
Item was removed:
- ----- Method: Exception>>printVerboseOn: (in category 'printing') -----
- printVerboseOn: aStream
- aStream
- nextPutAll: 'vvvvvvvvvvvvvvvvvv ' , self description , ' vvvvvvvvvvvvvvvvvv' ;
- cr ;
- nextPutAll: 'The time is ', DateAndTime now asString ;
- cr.
- "Allow applications to optionally print extra details without overriding a base package."
- (self respondsTo: #printDetailsOn:) ifTrue: [ self printDetailsOn: aStream ].
- aStream
- nextPutAll: self signalerContext longStack ;
- cr ;
- nextPutAll: '^^^^^^^^^^^^^^^^^^ ' , self description , ' ^^^^^^^^^^^^^^^^^^' ;
- cr ;
- flush!
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>>resignalAs: (in category 'handling') -----
- resignalAs: replacementException
- "Signal an alternative exception in place of the receiver."
-
- self resumeUnchecked: 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>>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."
-
- | ctxt |
- outerContext ifNil: [
- signalContext return: resumptionValue
- ] ifNotNil: [
- ctxt := outerContext.
- outerContext := ctxt tempAt: 1. "prevOuterContext in #outer"
- ctxt return: 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 ContextHandlers in the sender chain to handle this signal. The default is to execute and return my defaultAction."
-
- signalContext := thisContext contextTag.
- ^ thisContext nextHandlerContext 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:
- Notification subclass: #ExceptionAboutToReturn
- instanceVariableNames: ''
- classVariableNames: ''
- poolDictionaries: ''
- category: 'Kernel-Exceptions-Kernel'!
-
- !ExceptionAboutToReturn 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. Not even slightly.!
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 do:
- [:ex |
- (ex handles: anException)
- ifTrue: [^true]].
- ^false!
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 := 10.
- 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.
- (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 := 10.
- 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 := 10.
- (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."
-
- ^self!
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
- "Posted by Eliot Miranda to squeak-dev on 3/24/2009"
-
- ^aBoolean!
Item was removed:
- ----- Method: False>>| (in category 'logical operations') -----
- | aBoolean
- "Evaluating disjunction (OR) -- answer with the argument, aBoolean."
-
- ^aBoolean!
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>>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.
- !
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>>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.
- Optional. See Object documentation whatIsAPrimitive.
- Implementation note: use sign in order to catch cases of negativeZero"
-
- ^self = 0.0
- ifTrue: [denominator sign >= 0
- ifTrue: [ 0 ]
- ifFalse: [ self sign >= 0
- ifTrue: [ Pi ]
- ifFalse: [ Pi negated ]]]
- ifFalse: [denominator = 0.0
- ifTrue: [self > 0.0
- ifTrue: [ Halfpi ]
- ifFalse: [ Halfpi negated ]]
- ifFalse: [denominator > 0
- ifTrue: [ (self / denominator) arcTan ]
- ifFalse: [self > 0
- ifTrue: [ ((self / denominator) arcTan) + Pi ]
- ifFalse: [ ((self / denominator) arcTan) - Pi ]]]]!
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 asApproximateFractionAtOrder: 0!
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"
-
- | num1 denom1 num2 denom2 int frac newD temp order |
- num1 := self asInteger. "The first of two alternating numerators"
- denom1 := 1. "The first of two alternating denominators"
- num2 := 1. "The second numerator"
- denom2 := 0. "The second denominator--will update"
- int := num1. "The integer part of self"
- frac := self fractionPart. "The fractional part of self"
- order := maxOrder = 0 ifTrue: [-1] ifFalse: [maxOrder].
- [frac = 0 or: [order = 0] ]
- whileFalse:
- ["repeat while the fractional part is not zero and max order is not reached"
- order := order - 1.
- newD := 1.0 / frac. "Take reciprocal of the fractional part"
- int := newD asInteger. "get the integer part of this"
- frac := newD fractionPart. "and save the fractional part for next time"
- temp := num2. "Get old numerator and save it"
- num2 := num1. "Set second numerator to first"
- num1 := num1 * int + temp. "Update first numerator"
- temp := denom2. "Get old denominator and save it"
- denom2 := denom1. "Set second denominator to first"
- denom1 := int * denom1 + temp. "Update first denominator"
- 10000000000.0 < denom1
- ifTrue:
- ["Is ratio past float precision? If so, pick which
- of the two ratios to use"
- num2 = 0.0
- ifTrue: ["Is second denominator 0?"
- ^ Fraction numerator: num1 denominator: denom1].
- ^ Fraction numerator: num2 denominator: denom2]].
- "If fractional part is zero, return the first ratio"
- 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>>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 only."
-
- | word1 word2 sign mantissa exponent destWord 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"
- destWord := (sign bitOr: ((exponent max: 0) bitShift: 23)) bitOr: mantissa.
- ^ destWord!
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 alows 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 == nil ifTrue: "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 alows 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 == nil ifTrue: "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 sign = -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: [(self - num) abs / (self abs max: num abs) < 0.0001]!
Item was removed:
- ----- Method: Float>>copySignTo: (in category 'mathematical functions') -----
- copySignTo: aNumber
- "Return a number with same magnitude as aNumber and same sign as self.
- Implementation note: take care of Float negativeZero, which is considered as having a negative sign."
-
- (self > 0.0 or: [(self at: 1) = 0]) ifTrue: [^ aNumber abs].
- ^aNumber withNegativeSign!
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>>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>>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.
- Floats never return true here."
- ^false!
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>>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>>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 sign = -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 sign = -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 sign = -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 rounded]!
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>>sign (in category 'mathematical functions') -----
- sign
- "Answer 1 if the receiver is greater than 0, -1 if less than 0, else 0.
- Handle IEEE-754 negative-zero by reporting a sign of -1"
-
- self > 0.0 ifTrue: [^ 1].
- (self < 0.0 or: [((self at: 1) bitShift: -31) = 1]) ifTrue: [^ -1].
- ^ 0!
Item was removed:
- ----- Method: Float>>sign: (in category 'mathematical functions') -----
- sign: aNumber
- "Return a Number with the same sign as aNumber and same magnitude as self.
- Implementation is different from super to handle the special case of Float negativeZero."
-
- (self = 0.0 and: [aNumber sign negative]) ifTrue: [^Float negativeZero].
- ^aNumber copySignTo: self!
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>>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 sign = -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>>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 clone!
Item was removed:
- ----- Method: Float>>withNegativeSign (in category 'converting') -----
- withNegativeSign
- "Same as super, but handle the subtle case of Float negativeZero"
-
- self = 0.0 ifTrue: [^self class negativeZero].
- ^super withNegativeSign!
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: '<historical>' prior: 0!
- Fraction provides methods for dealing with fractions like 1/3 as fractions (not as 0.33333...). All public arithmetic operations answer reduced fractions (see examples).
-
- instance variables: 'numerator denominator '
-
- Examples: (note the parentheses required to get the right answers in Smalltalk and Squeak):
-
- (2/3) + (2/3)
- (2/3) + (1/2) "answers shows the reduced fraction"
- (2/3) raisedToInteger: 5 "fractions also can have exponents"
- !
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 isFraction
- ifTrue: [numerator = 0 ifTrue: [^ aNumber numerator = 0].
- ^ (numerator * aNumber denominator) =
- (aNumber numerator * denominator)
- "Note: used to just compare num and denom,
- but this fails for improper fractions"].
- ^ 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: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: 10].
- 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>>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>>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>>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."
-
- | d n |
- n := numerator nthRoot: aPositiveInteger.
- d := denominator nthRoot: aPositiveInteger.
- "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 nthRoot: aPositiveInteger ].
- ^n / d!
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>>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 = 0
- ifTrue: [^(ZeroDivide dividend: n) signal]
- ifFalse:
- [numerator := n asInteger.
- denominator := d asInteger abs. "keep sign in numerator"
- d < 0 ifTrue: [numerator := numerator 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:
- 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>
- 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: 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: 73>
- "Access beyond fixed variables."
- ^self basicAt: index - self class instSize !
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: 74>
- "Access beyond fixed fields"
- ^self basicAt: anInteger - self class instSize put: anObject!
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:
- Notification subclass: #InMidstOfFileinNotification
- instanceVariableNames: ''
- classVariableNames: ''
- poolDictionaries: ''
- category: 'Kernel-Exceptions'!
Item was removed:
- ----- Method: InMidstOfFileinNotification>>defaultAction (in category 'handling') -----
- defaultAction
-
- self resume: false!
Item was removed:
- InstructionClient subclass: #InstVarRefLocator
- instanceVariableNames: 'bingo'
- classVariableNames: ''
- poolDictionaries: ''
- category: 'Kernel-Methods'!
-
- !InstVarRefLocator commentStamp: 'md 4/8/2003 12:50' prior: 0!
- My job is to scan bytecodes for instance variable references.
-
- BlockContext allInstances collect: [ :x |
- {x. x 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:
- Object 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>>blockReturnTop (in category 'instruction decoding') -----
- blockReturnTop
- "Return Top Of Stack bytecode."
-
- !
Item was removed:
- ----- Method: InstructionClient>>callPrimitive: (in category 'instruction decoding') -----
- callPrimitive: pimIndex
- "V3PlusClosures: 139 10001011 iiiiiiii jjjjjjjj Call Primitive #iiiiiiii + (jjjjjjjj * 256)
- NewsqueakV4: 249 11111001 iiiiiiii jjjjjjjj Call Primitive #iiiiiiii + (jjjjjjjj * 256)
- SistaV1: 248 11111000 iiiiiiii mjjjjjjj Call Primitive #iiiiiiii + ( jjjjjjj * 256)
- m=1 means inlined primitive, no hard return after execution."!
Item was 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>>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:
- InstructionClient subclass: #InstructionPrinter
- instanceVariableNames: 'method scanner stream oldPC innerIndents indent printPC indentSpanOfFollowingJump'
- 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>>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."
-
- self print: 'callPrimitive: ' , index printString!
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.
- [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>>pushLiteralVariable: (in category 'instruction decoding') -----
- pushLiteralVariable: anAssociation
- "Print the Push Contents Of anAssociation On Top Of Stack bytecode."
-
- self print: 'pushLit: ' , anAssociation key!
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).
- indentSpanOfFollowingJump := #(blockCopy: #closureCopy:copiedValues:) includes: selector!
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:
- 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."
-
- SpecialConstants :=
- (Array with: true with: false with: nil)
- , (Array with: -1 with: 0 with: 1 with: 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 ContextPart 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>>abstractPC (in category 'debugger access') -----
- abstractPC
- ^self method abstractPCForConcretePC: pc!
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>>debuggerMap (in category 'debugger access') -----
- debuggerMap
- ^self method debuggerMap!
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>>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>>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 pushConstant: (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
- send: (Smalltalk specialSelectorAt: offset + 1)
- super: false
- numArgs: (Smalltalk specialNargsAt: offset + 1)].
- type = 12 ifTrue: "non-arithmetic special selector sends"
- [^ client
- send: (Smalltalk specialSelectorAt: offset + 17)
- super: false
- 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 pushConstant: (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
- send: (Smalltalk specialSelectorAt: offset + 1)
- super: false
- numArgs: (Smalltalk specialNargsAt: offset + 1)].
- type = 12 ifTrue: "non-arithmetic special selector sends"
- [^ client
- send: (Smalltalk specialSelectorAt: offset + 17)
- super: false
- 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>>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>>secondByte (in category 'scanning') -----
- secondByte
- "Answer the second byte of the current bytecode."
-
- ^self method at: pc + 1!
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>>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: '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!
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: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 digitMultiply: aNumber
- neg: self negative ~~ aNumber negative].
- ^ 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 / "
- | quoRem |
- aNumber isInteger ifTrue:
- [quoRem := self digitDiv: aNumber neg: self negative ~~ aNumber negative.
- (quoRem at: 2) = 0
- ifTrue: [^ (quoRem at: 1) normalize]
- ifFalse: [^ (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 isInteger ifTrue: [
- aNumber class == self class ifFalse: [ ^false ].
- ^(self digitCompare: aNumber) = 0 ].
- 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>>asYear (in category 'converting') -----
- asYear
-
- ^ Year year: self
- !
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 + (self digitAt: i) bitCountOfByte].
- ^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>>destinationBuffer: (in category 'printing') -----
- destinationBuffer:digitLength
- digitLength <= 1
- ifTrue: [self]
- ifFalse: [LargePositiveInteger new: digitLength].!
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>>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 |
- <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.
- div := div growto: div digitLength + 1.
- "shifts so high order word is >=128"
- rem := self digitLshift: d.
- rem digitLength = self digitLength ifTrue: [rem := rem growto: self digitLength + 1].
- "makes a copy and shifts"
- quo := Integer new: l neg: ng.
- dl := div digitLength - 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 := rem digitLength + 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: div digitLength 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: div digitLength do:
- [:i |
- a := (a bitShift: -8)
- + (rem digitAt: l) + (div digitAt: i).
- rem digitAt: l put: (a bitAnd: 255).
- l := l + 1]].
- quo digitAt: quo digitLength + 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
- | prod prodLen carry digit k ab |
- <primitive: 'primDigitMultiplyNegative' module:'LargeIntegers'>
- (arg digitLength = 1 and: [(arg digitAt: 1)
- = 0])
- ifTrue: [^ 0].
- (self digitLength = 1 and: [(self digitAt: 1)
- = 0])
- ifTrue: [^ 0].
- prodLen := self digitLength + arg digitLength.
- prod := Integer new: prodLen neg: ng.
- "prod starts out all zero"
- 1 to: self digitLength do: [:i | (digit := self digitAt: i) ~= 0
- ifTrue:
- [k := i.
- carry := 0.
- "Loop invariant: 0<=carry<=0377, k=i+j-1"
- 1 to: arg digitLength 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>>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: 10].
- 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 |
- 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>>hash (in category 'comparing') -----
- hash
- "Hash is reimplemented because = is implemented."
-
- ^(self lastDigit bitShift: 8) + (self digitAt: 1)!
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>>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: [h - self abs lowBit < Float precision]!
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>>isPowerOfTwo (in category 'testing') -----
- isPowerOfTwo
- "Return true if the receiver is an integral power of two."
-
- ^self strictlyPositive and: [ (self bitAnd: self - 1) = 0 ]!
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)."
-
- self <= 1 ifTrue: [ ^false ].
- self even ifTrue: [ ^self = 2].
- 3 to: self sqrtFloor by: 2 do: [ :each |
- self \\ each = 0 ifTrue: [ ^false ] ].
- ^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>>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>>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 p |
-
- guess := self nthRootRounded: aPositiveInteger.
- (guess raisedTo: aPositiveInteger) = self
- ifTrue: [ ^ guess ].
-
- p := Float precision - guess highBitOfMagnitude.
- p < 0 ifTrue: [ ^ guess asFloat ].
-
- guess := self << (p * aPositiveInteger) nthRootRounded: aPositiveInteger.
- ^(guess / (1 << p)) 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.
- ^self * 2 > ((guess + 1 raisedTo: aPositiveInteger) + (guess raisedTo: aPositiveInteger))
- ifTrue: [guess + 1]
- ifFalse: [guess]!
Item was removed:
- ----- Method: Integer>>nthRootTruncated: (in category 'mathematical functions') -----
- nthRootTruncated: aPositiveInteger
- "Answer the integer part of the nth root of the receiver."
- | guess guessToTheNthMinusOne delta |
- self = 0 ifTrue: [^0].
- self negative
- ifTrue:
- [aPositiveInteger even ifTrue: [ ArithmeticError signal: 'Negative numbers don''t have even roots.' ].
- ^(self negated nthRootTruncated: aPositiveInteger) negated].
- guess := 1 bitShift: self highBitOfMagnitude + aPositiveInteger - 1 // aPositiveInteger.
- [
- guessToTheNthMinusOne := guess raisedTo: aPositiveInteger - 1.
- delta := (guess * guessToTheNthMinusOne - self) // (guessToTheNthMinusOne * aPositiveInteger).
- delta = 0 ] whileFalse:
- [ guess := guess - delta ].
- ( (guess := guess - 1) raisedTo: aPositiveInteger) > 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>>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: "
- | ng quo |
- aNumber isInteger ifTrue:
- [ng := self negative == aNumber negative == false.
- quo := (self digitDiv: aNumber neg: ng) 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>>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>>rounded (in category 'truncation and round off') -----
- rounded
- "Refer to the comment in Number|rounded."!
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 << 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 * (oddPowersOfSelf at: index + 1) \\ m].
- k := k - 1].
- ^pow!
Item was removed:
- ----- Method: Integer>>sqrt (in category 'mathematical functions') -----
- sqrt
- "Answer the square root of the receiver."
-
- | selfAsFloat floatResult guess |
- selfAsFloat := self asFloat.
- floatResult := selfAsFloat sqrt.
-
- floatResult isInfinite ifFalse: [
- guess := floatResult truncated.
-
- "If got an exact answer, answer it. Otherwise answer float approximate answer."
- guess squared = self
- ifTrue: [ ^ guess ]].
-
- "In this case, maybe it failed because we are such a big integer that the Float method becomes
- inexact, even if we are a whole square number. So, try the slower but more general method"
- selfAsFloat >= Float maxExactInteger asFloat squared
- ifTrue: [
- guess := self sqrtFloor.
- guess squared = self ifTrue: [
- ^guess ].
-
- "Nothing else can be done. No exact answer means answer must be a Float.
- Answer the best we have which is the rounded sqrt."
- guess := (self * 4) sqrtFloor.
- ^(guess // 2 + (guess \\ 2)) asFloat].
-
- "We need an approximate result"
- ^floatResult!
Item was removed:
- ----- Method: Integer>>sqrtFloor (in category 'mathematical functions') -----
- sqrtFloor
- "Return the integer part of the square root of self"
-
- | guess delta |
- guess := 1 bitShift: self highBit + 1 // 2.
- [
- delta := guess squared - self // (guess bitShift: 1).
- delta = 0 ] whileFalse: [
- guess := guess - delta ].
- ^guess - 1!
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."
-
- | count |
- count := 1.
- [count <= self]
- whileTrue:
- [aBlock value.
- count := count + 1]!
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: 22727272 bytecodes/sec; 984169 sends/sec"
- "On a 400 MHz PII/Win98: 18028169 bytecodes/sec; 1081272 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) printString, ' bytecodes/sec; ',
- ((r * 1000) // t2) printString, ' 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>>asFloat (in category 'converting') -----
- asFloat
- ^super asFloat 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>>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>>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>>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>>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: ''
- 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>>* (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 a
- SmallInteger or a LargePositiveInteger less than 2-to-the-30th (1073741824). 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 a
- SmallInteger or a LargePositiveInteger less than 2-to-the-30th (1073741824). 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 a
- SmallInteger or a LargePositiveInteger less than 2-to-the-30th (1073741824). 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
- a SmallInteger or a LargePositiveInteger less than 2-to-the-30th (1073741824). 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 a SmallInteger or a LargePositiveInteger less than 2-to-the-30th (1073741824).
- 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 true if
- the receiver is less than the argument. Otherwise answer false. Fail if the
- argument is not a SmallInteger or a LargePositiveInteger less than 2-to-the-30th (1073741824).
- 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 true if
- the receiver is less than or equal to the argument. Otherwise answer false.
- Fail if the argument is not a SmallInteger or a LargePositiveInteger less
- than 2-to-the-30th (1073741824). 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 true if
- the receiver is greater than the argument. Otherwise answer false. Fail if
- the argument is not a SmallInteger or a LargePositiveInteger less than
- 2-to-the-30th (1073741824). 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 true if
- the receiver is greater than or equal to the argument. Otherwise answer
- false. Fail if the argument is not a SmallInteger or a LargePositiveInteger
- less than 2-to-the-30th (1073741824). 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 less than
- 2-to-the-30th (1073741824). Optional. See Object documentation whatIsAPrimitive."
-
- <primitive: 31>
- aNumber isInteger
- ifTrue:
- [| neg qr q r |
- neg := self negative == aNumber negative == false.
- qr := self digitDiv: aNumber neg: neg.
- q := qr first normalize.
- r := qr last normalize.
- ^(q negative
- ifTrue: [r isZero not]
- ifFalse: [q isZero and: [neg]])
- 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 mantissa.
- 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 mantissa 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 mantissa is left unchanged.
- If next bit after floating point is 1, an odd mantissa is always rounded upper.
- An even mantissa 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.
- This can be obtained by splitting the mantissa plus excess bits in two part with less bits than Float precision.
- 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."
-
- | mantissa shift excess result n |
-
- "Check how many bits excess the maximum precision of a Float mantissa."
- excess := self highBitOfMagnitude - Float precision.
- excess > 7
- ifTrue:
- ["Remove the excess bits but seven."
- mantissa := self bitShiftMagnitude: 7 - excess.
- shift := excess - 7.
- "An even mantissa 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 round excess bits upper manually."
- ((mantissa digitAt: 1) = 2r01000000 and: [self anyBitOfMagnitudeFrom: 1 to: shift])
- ifTrue: [mantissa := mantissa + 1]]
- ifFalse:
- [mantissa := self.
- shift := 0].
-
- "There will be a single inexact round off at last iteration"
- result := (mantissa digitAt: (n := mantissa digitLength)) asFloat.
- [(n := n - 1) > 0] whileTrue: [
- result := 256.0 * result + (mantissa digitAt: n) asFloat].
- ^result 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 bitShift: highBit - (digitSize * 8)!
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>>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>>hash (in category 'comparing') -----
- hash
-
- ^ByteArray
- hashBytes: self
- startingWith: self species hash!
Item was removed:
- ----- Method: LargePositiveInteger>>hashMultiply (in category 'bit manipulation') -----
- hashMultiply
- "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>>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>>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>>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 |
- "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.
- head := self quo: halfPower.
- tail := self - (head * halfPower).
-
- "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 |
- 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.
- head := self quo: half.
- tail := self - (head * half).
- 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 return 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 less than 2-to-the-30th (1073741824). 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:.
- This is defined only to speed up case of large integers."
-
- <primitive: 20>
- aNumber isInteger
- ifTrue:
- [| ng rem |
- ng := self negative == aNumber negative == false.
- rem := (self digitDiv: aNumber neg: ng) 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."
- <primitive: 105>
- ^ super replaceFrom: start to: stop with: replacement startingAt: repStart!
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>>sqrt (in category 'mathematical functions') -----
- sqrt
- "If we know for sure no exact solution exists, then just answer the cheap float approximation without wasting time."
- | selfAsFloat |
- self mightBeASquare
- ifFalse:
- [selfAsFloat := self asFloat.
- selfAsFloat isFinite ifTrue: [^self asFloat sqrt ]].
-
- "If some exact solution might exist, or self asFloat isInfinite, call potentially expensive super"
- ^super sqrt!
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:
- 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>>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>>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: (Array with: 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>>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 withArguments: { firstArg. secondArg. thirdArg. fourthArg }!
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>>allInstancesEverywhereDo: (in category 'enumerating') -----
- allInstancesEverywhereDo: aBlock
- "There should be only one"
- thisClass class == self ifTrue:[^ aBlock value: thisClass].
- ^ super allInstancesEverywhereDo: 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>>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>>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>>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>>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>>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:
- ContextPart variableSubclass: #MethodContext
- instanceVariableNames: 'method closureOrNil receiver'
- classVariableNames: ''
- poolDictionaries: ''
- category: 'Kernel-Methods'!
-
- !MethodContext commentStamp: '<historical>' 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 and temporary variables.
-
- MethodContexts, 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.
-
- MethodContexts must only be created using the method newForMethod:. Note that it is impossible to determine the real object size of a MethodContext 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.!
Item was removed:
- ----- Method: MethodContext class>>allInstances (in category 'enumerating') -----
- allInstances
- "Answer all instances of the receiver."
- <primitive: 177>
- "The primitive can fail because memory is low. If so, fall back on the old
- enumeration code, which gives the system a chance to GC and/or grow.
- Because aBlock might change the class of inst (for example, using become:),
- it is essential to compute next before aBlock value: inst.
- Only count until thisContext since this context has been created only to
- compute the existing instances."
- | inst insts next |
- insts := WriteStream on: (Array new: 64).
- inst := self someInstance.
- [inst == thisContext or: [inst == nil]] whileFalse:
- [next := inst nextInstance.
- insts nextPut: inst.
- inst := next].
- ^insts contents!
Item was removed:
- ----- Method: MethodContext class>>allInstancesDo: (in category 'private') -----
- allInstancesDo: aBlock
- "Evaluate aBlock with each of the current instances of the receiver."
- | instances inst next |
- instances := self allInstancesOrNil.
- instances ifNotNil:
- [instances do: aBlock.
- ^self].
- "allInstancesOrNil can fail because memory is low. If so, fall back on the old
- enumeration code. Because aBlock might change the class of inst (for example,
- using become:), it is essential to compute next before aBlock value: inst.
- Only count until thisContext since evaluation of aBlock will create new contexts."
- inst := self someInstance.
- [inst == thisContext or: [inst == nil]] whileFalse:
- [next := inst nextInstance.
- aBlock value: inst.
- inst := next]!
Item was removed:
- ----- Method: MethodContext class>>myEnvFieldIndex (in category 'closure support') -----
- myEnvFieldIndex
-
- ^ self allInstVarNames indexOf: 'receiverMap'!
Item was removed:
- ----- Method: MethodContext 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: MethodContext>>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: MethodContext>>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: MethodContext>>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: MethodContext>>asContext (in category 'closure support') -----
- asContext
-
- ^ self!
Item was removed:
- ----- Method: MethodContext>>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: MethodContext>>blockReturnTop (in category 'instruction decoding (closures)') -----
- 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: MethodContext>>cachesStack (in category 'private-debugger') -----
- cachesStack
-
- ^ false
- "^self selector == #valueUninterruptably
- and: [self receiver class == BlockContext]"!
Item was removed:
- ----- Method: MethodContext>>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: MethodContext>>cannotReturn: (in category 'private-exceptions') -----
- cannotReturn: result
-
- closureOrNil notNil ifTrue:
- [^self cannotReturn: result to: self home sender].
- ToolSet
- debugContext: thisContext
- label: 'computation has been terminated'
- contents: nil!
Item was removed:
- ----- Method: MethodContext>>capturedTempNames (in category 'closure support') -----
- capturedTempNames
-
- ^ self methodNode scope capturedVars collect: [:var | var name]!
Item was removed:
- ----- Method: MethodContext>>closure (in category 'accessing') -----
- closure
- ^closureOrNil!
Item was removed:
- ----- Method: MethodContext>>contextForLocalVariables (in category 'accessing') -----
- contextForLocalVariables
- "Answer the context in which local variables (temporaries) are stored."
-
- ^self!
Item was removed:
- ----- Method: MethodContext>>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: MethodContext>>doItScope (in category 'closure support') -----
- doItScope
- "scope (environment) for expressions executed within a method context. self will be the receiver of the do-it method. We want temp vars directly accessible"
-
- ^ self methodNode scope asDoItScope!
Item was removed:
- ----- Method: MethodContext>>endPC (in category 'private') -----
- endPC
- ^closureOrNil
- ifNil: [self method endPC]
- ifNotNil: [closureOrNil endPC]!
Item was removed:
- ----- Method: MethodContext>>failPrimitiveWith: (in category 'system simulation') -----
- failPrimitiveWith: maybePrimFailToken
- "The receiver is a freshly-created context on a primitive method. Skip the callPrimitive:
- bytecode and store the primitive fail code if there is one and the method consumes it."
- self skipCallPrimitive.
- ((self isPrimFailToken: maybePrimFailToken)
- and: [method encoderClass isStoreAt: pc in: method]) ifTrue:
- [self at: stackp put: maybePrimFailToken last]!
Item was removed:
- ----- Method: MethodContext>>freeNames (in category 'closure support') -----
- freeNames
-
- ^ self methodNode freeNames!
Item was removed:
- ----- Method: MethodContext>>freeNamesAndValues (in category 'closure support') -----
- freeNamesAndValues
-
- | aStream eval |
- eval := [:string |
- self class evaluatorClass new
- evaluate2: (ReadStream on: string)
- in: self
- to: nil
- notifying: nil "fix this"
- ifFail: [self error: 'bug']
- logged: false].
-
- aStream := '' writeStream.
- self freeNames doWithIndex: [:name :index |
- aStream nextPutAll: name; nextPut: $:; space; tab.
- (eval value: name) printOn: aStream.
- aStream cr].
- ^ aStream contents!
Item was removed:
- ----- Method: MethodContext>>hasInstVarRef (in category 'accessing') -----
- hasInstVarRef
- "Answer whether the receiver references an instance variable."
-
- ^self method hasInstVarRef.!
Item was removed:
- ----- Method: MethodContext>>hasMethodReturn (in category 'accessing') -----
- hasMethodReturn
- ^closureOrNil hasMethodReturn!
Item was removed:
- ----- Method: MethodContext>>hideFromDebugger (in category 'private-debugger') -----
- hideFromDebugger
-
- | sndr sndrHome |
- ^self cachesStack
- or: [(sndr := self sender) ~~ nil
- and: [(sndrHome := sndr home) ~~ nil
- and: [sndrHome cachesStack]]]!
Item was removed:
- ----- Method: MethodContext>>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: MethodContext>>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: MethodContext>>isClosureContext (in category 'closure support') -----
- isClosureContext
- ^closureOrNil ~~ nil!
Item was removed:
- ----- Method: MethodContext>>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: MethodContext>>isHandlerContext (in category 'private-exceptions') -----
- isHandlerContext
- "is this context for method that is marked?"
- ^method primitive = 199!
Item was removed:
- ----- Method: MethodContext>>isMethodContext (in category 'testing') -----
- isMethodContext
- ^ true!
Item was removed:
- ----- Method: MethodContext>>isUnwindContext (in category 'private-exceptions') -----
- isUnwindContext
- "is this context for method that is marked?"
- ^method primitive = 198!
Item was removed:
- ----- Method: MethodContext>>method (in category 'accessing') -----
- method
-
- ^method!
Item was removed:
- ----- Method: MethodContext>>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: MethodContext>>numArgs (in category 'accessing') -----
- numArgs
- "Answer the number of arguments for this activation."
- ^closureOrNil
- ifNil: [method numArgs]
- ifNotNil: [closureOrNil numArgs]!
Item was removed:
- ----- Method: MethodContext>>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: MethodContext>>outerContext (in category 'accessing') -----
- outerContext
- "Answer the context within which the receiver is nested."
-
- ^closureOrNil == nil ifFalse:
- [closureOrNil outerContext]!
Item was removed:
- ----- Method: MethodContext>>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: MethodContext>>printOn: (in category 'printing') -----
- printOn: aStream
-
- self outerContext
- ifNil: [super printOn: aStream]
- ifNotNil:
- [:outerContext|
- aStream nextPutAll: '[] in '.
- outerContext printOn: aStream]!
Item was removed:
- ----- Method: MethodContext>>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: MethodContext>>privRefresh (in category 'initialize-release') -----
- privRefresh
- "Reinitialize the receiver so that it is in the state it was at its creation."
-
- closureOrNil
- ifNotNil:
- [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: MethodContext>>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: MethodContext>>pushArgs:from: (in category 'system simulation') -----
- pushArgs: args "<Array>" from: sendr "<ContextPart>"
- "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: MethodContext>>pushConsArrayWithElements: (in category 'instruction decoding (closures)') -----
- 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: MethodContext>>receiver (in category 'accessing') -----
- receiver
- "Refer to the comment in ContextPart|receiver."
-
- ^receiver!
Item was removed:
- ----- Method: MethodContext>>receiver: (in category 'private-exceptions') -----
- receiver: r
-
- receiver := r!
Item was removed:
- ----- Method: MethodContext>>removeSelf (in category 'accessing') -----
- removeSelf
- "Nil the receiver pointer and answer its former value."
-
- | tempSelf |
- tempSelf := receiver.
- receiver := nil.
- ^tempSelf!
Item was removed:
- ----- Method: MethodContext>>restartWithNewReceiver: (in category 'private-exceptions') -----
- restartWithNewReceiver: obj
-
- self
- swapReceiver: obj;
- restart!
Item was removed:
- ----- Method: MethodContext>>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: MethodContext>>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: MethodContext>>startpc (in category 'private') -----
- startpc
- ^closureOrNil
- ifNil: [self method initialPC]
- ifNotNil: [closureOrNil startpc]!
Item was removed:
- ----- Method: MethodContext>>swapReceiver: (in category 'private-exceptions') -----
- swapReceiver: r
-
- receiver := r!
Item was removed:
- ----- Method: MethodContext>>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: MethodContext>>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:
- 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 |
- | 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>>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: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 ].
- array at: index put: nil.
- self basicAt: index put: nil.
- tally := tally - 1.
- 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>>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 |
- index := start := anObject identityHash \\ array size + 1.
- [
- | element |
- ((element := self basicAt: index) == nil or: [ element == anObject ])
- ifTrue: [ ^index ].
- (index := index \\ array 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: '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>>windowActiveOnFirstClick (in category 'preferences') -----
- windowActiveOnFirstClick
- <preference: 'Window Active On First Click'
- category: 'windows'
- description: 'Whether or not you want to directly interact with a widget (e.g. button) in a not-yet-active window'
- type: #Boolean>
- ^ WindowActiveOnFirstClick ifNil: [ false ]!
Item was removed:
- ----- Method: Model class>>windowActiveOnFirstClick: (in category 'preferences') -----
- windowActiveOnFirstClick: aBoolean
-
- WindowActiveOnFirstClick := aBoolean.!
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>>myDependents (in category 'dependents') -----
- myDependents
- ^ dependents!
Item was removed:
- ----- Method: Model>>myDependents: (in category 'dependents') -----
- myDependents: aCollectionOrNil
- dependents := aCollectionOrNil!
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:
- LinkedList subclass: #Monitor
- instanceVariableNames: 'ownerProcess defaultQueue queueDict queuesMutex mutex 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
- ifNil: [false]
- ifNotNil:
- [:alreadyOwner|
- alreadyOwner
- or: [self primitiveExitCriticalSection.
- false]]) ifFalse:
- [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>>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: Monitor>>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: 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 := Semaphore forMutualExclusion!
Item was removed:
- ----- Method: Monitor>>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: Monitor>>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: Monitor>>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 primitiveFail
- "In the spirit of the following"
- "[owner ifNil:
- [owningProcess := Processor activeProcess.
- ^false].
- owner = Processor activeProcess ifTrue: [^true].
- ^nil] valueUnpreemptively"!
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 changed:
Timespan subclass: #Month
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: 'ChronologyConstants'
+ category: 'Chronology-Core'!
- category: 'Kernel-Chronology'!
!Month commentStamp: 'cbr 7/28/2010 18:11' prior: 0!
I represent a month.
For example, to get the number of days this month, you can evaluate the following expression:
Month current daysInMonth!
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>>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>>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 primitiveFail
- "In the spirit of the following"
- "[owner ifNil:
- [owningProcess := Processor activeProcess.
- ^false].
- owner = Processor activeProcess ifTrue: [^true].
- ^nil] valueUnpreemptively"!
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:
- ArithmeticError subclass: #NaNError
- instanceVariableNames: ''
- classVariableNames: ''
- poolDictionaries: ''
- category: 'Kernel-Numbers-Exceptions'!
-
- !NaNError commentStamp: 'ar 12/14/2010 00:03' prior: 0!
- NaNError is signaled by various operations that would either result in or operate on an NaN input.!
Item was removed:
- ----- Method: NaNError>>isResumable (in category 'testing') -----
- isResumable
- "NaNError is always resumable"
- ^true!
Item was removed:
- ----- Method: NaNError>>messageText (in category 'accessing') -----
- messageText
- "Return an exception's message text."
-
- ^messageText ifNil:['This operation would result in NaN ']!
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 'exceptionDescription') -----
- 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 'exceptionDescription') -----
- 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 '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 positive not].
- (selector = #> or: [selector = #'>='])
- ifTrue: [^ rcvr positive].
- ^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>>asDuration (in category 'converting') -----
- asDuration
-
- ^ Duration nanoSeconds: self asInteger
- !
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 positive
- ifTrue: [aNumber abs]
- ifFalse: [aNumber withNegativeSign].!
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>>day (in category 'converting') -----
- day
-
- ^ self sign days!
Item was removed:
- ----- Method: Number>>days (in category 'converting') -----
- days
-
- ^ Duration days: self!
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 printString!
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>>hour (in category 'converting') -----
- hour
-
- ^ self sign hours
- !
Item was removed:
- ----- Method: Number>>hours (in category 'converting') -----
- hours
-
- ^ Duration hours: self!
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>>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>>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>>log: (in category 'mathematical functions') -----
- log: aNumber
- "Answer the log base aNumber of the receiver."
-
- ^self ln / aNumber ln!
Item was removed:
- ----- Method: Number>>milliSecond (in category 'converting') -----
- milliSecond
-
- ^ self sign milliSeconds
- !
Item was removed:
- ----- Method: Number>>milliSeconds (in category 'converting') -----
- milliSeconds
-
- ^ Duration milliSeconds: self
- !
Item was removed:
- ----- Method: Number>>minute (in category 'converting') -----
- minute
-
- ^ self sign minutes
- !
Item was removed:
- ----- Method: Number>>minutes (in category 'converting') -----
- minutes
-
- ^ Duration minutes: self!
Item was removed:
- ----- Method: Number>>nanoSecond (in category 'converting') -----
- nanoSecond
-
- ^ self sign nanoSeconds
- !
Item was removed:
- ----- Method: Number>>nanoSeconds (in category 'converting') -----
- nanoSeconds
-
- ^ Duration nanoSeconds: self.!
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 nthRoot: aNumber denominator) raisedToInteger: aNumber numerator ].
- 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: self) signal]
- ifFalse: [^ self]].
- ^ (aNumber * self ln) exp "Otherwise use logarithms"!
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 ifFalse: [result := result * self].
- bitProbe := bitProbe bitShift: -1.
- bitProbe > 0 ]
- whileTrue: [result := result * result].
-
- ^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>>second (in category 'converting') -----
- second
-
- ^ self sign seconds
- !
Item was removed:
- ----- Method: Number>>seconds (in category 'converting') -----
- seconds
-
- ^ Duration seconds: self!
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>>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:
- ----- Method: Number>>week (in category 'converting') -----
- week
-
- ^ self sign weeks
- !
Item was removed:
- ----- Method: Number>>weeks (in category 'converting') -----
- weeks
-
- ^ Duration weeks: self!
Item was removed:
- ----- Method: Number>>withNegativeSign (in category 'converting') -----
- withNegativeSign
- "Answer a number with same magnitude than receiver and negative sign."
- ^self abs negated!
Item was removed:
- Object subclass: #NumberParser
- instanceVariableNames: 'sourceStream base neg integerPart fractionPart exponent scale nDigits lastNonZero requestor failBlock'
- classVariableNames: ''
- poolDictionaries: ''
- category: 'Kernel-Numbers'!
-
- !NumberParser commentStamp: 'nice 3/15/2010 00:16' 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)
- !
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>>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>>makeFloatFromMantissa:exponent:base: (in category 'parsing-private') -----
- makeFloatFromMantissa: m exponent: k base: aRadix
- "Convert infinite precision arithmetic into Floating point.
- This alogrithm rely on correct IEEE rounding mode
- being implemented in Integer>>asFloat and Fraction>>asFloat"
-
- ^(k positive
- ifTrue: [m * (aRadix raisedToInteger: k)]
- ifFalse: [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 or: [(char := sourceStream next) == nil
- or: [digit := char digitValue.
- (0 > digit or: [digit >= aRadix])
- and: [sourceStream skip: -1.
- true]]]]
- whileFalse: [
- nDigits := nDigits + 1.
- 0 = digit
- ifFalse: [lastNonZero := nDigits].
- value := value * aRadix + digit].
- ^value!
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 := 10.
- ^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 := 10.
- ^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 := 10.
- 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.
- sourceStream atEnd ifTrue: [^ false].
- (self exponentLetters includes: sourceStream peek)
- ifFalse: [^ false].
- sourceStream next.
- eneg := sourceStream peekFor: $-.
- epos := eneg not and: [self allowPlusSignInExponent and: [sourceStream peekFor: $+]].
- exponent := self nextUnsignedIntegerOrNilBase: 10.
- 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>>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. Code
- which sends special selectors compiles into fewer bytes than normal. 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.
- This is much faster than a normal message lookup.
-
- A selector which is a special selector solely in order to save space has a
- normal behavior. Methods whose selectors are special in order to
- gain speed contain the comment, 'No Lookup'. When the interpreter
- 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 with any of + - * / \\ bitOr: bitShift: bitAnd: //
- SmallInteger with any of = ~= > < >= <=
- Any class with ==
- Any class with @
- Point with either of x y
- ContextPart with blockCopy:
- BlockContext with either of value value:
- "
-
- 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 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].
- ^ 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>>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."
-
- | object |
- (Compiler couldEvaluate: textStringOrStream)
- ifFalse: [^ self error: 'expected String, Stream, or Text'].
- object := Compiler evaluate: textStringOrStream for: nil
- notifying: #error: "signal we want errors".
- (object isKindOf: self) ifFalse: [self error: self name, ' expected'].
- ^object!
Item was removed:
- ----- Method: Object class>>readFrom: (in category 'instance creation') -----
- readFrom: textStringOrStream
- "Create an object based on the contents of textStringOrStream."
-
- | object |
- (Compiler couldEvaluate: textStringOrStream)
- ifFalse: [^ self error: 'expected String, Stream, or Text'].
- object := Compiler evaluate: textStringOrStream.
- (object isKindOf: self) ifFalse: [self error: self name, ' expected'].
- ^object!
Item was removed:
- ----- Method: Object class>>releaseExternalSettings (in category 'private') -----
- releaseExternalSettings
- "Do nothing as a default"!
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 interpreter rather than by evaluating
- expressions in a method. The methods for these messages indicate the
- presence of a primitive response by including <primitive: xx> 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 interpreter 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 interpreter 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
- 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'. Some
- methods will have the comment, 'No Lookup'. See Object
- howToModifyPrimitives for an explanation of special selectors which are
- not looked up.
-
- For the primitives for +, -, *, and bitShift: in SmallInteger, and truncated
- in Float, the primitive constructs and returns a 16-bit
- LargePositiveInteger when the result warrants it. Returning 16-bit
- LargePositiveIntegers from these primitives instead of failing is
- optional in the same sense that the LargePositiveInteger arithmetic
- primitives are optional. 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 interpreter in the Smalltalk book."
-
- 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>>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>>addInstanceVarNamed:withValue: (in category 'accessing') -----
- addInstanceVarNamed: aName withValue: aValue
- "Add an instance variable named aName and give it value aValue"
- self class addInstVarName: aName asString.
- self instVarAt: self class instSize put: aValue!
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"
- Preferences cmdGesturesEnabled ifTrue: [ "build mode"
- aCustomMenu add: 'inspect model' translated target: self action: #inspect.
- ].
-
- ^aCustomMenu
- !
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
- ^ self printString!
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: value
- "Primitive. Assumes receiver is indexable. Store the 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. See Object documentation whatIsAPrimitive."
-
- <primitive: 61>
- index isInteger ifTrue:
- [self class isVariable
- ifTrue: [(index >= 1 and: [index <= self size])
- ifTrue: [self errorImproperStore]
- ifFalse: [self errorSubscriptBounds: index]]
- ifFalse: [self errorNotIndexable]].
- index isNumber
- ifTrue: [^self at: index asInteger put: value]
- ifFalse: [self errorNonIntegerIndex]!
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
- maybeSignalDeprecationFor: thisContext sender
- message: ' (but will be kept for compatibility)'
- explanation: explanationString!
Item was removed:
- ----- Method: Object>>basicAddInstanceVarNamed:withValue: (in category 'accessing') -----
- basicAddInstanceVarNamed: aName withValue: aValue
- "Add an instance variable named aName and give it value aValue"
- self class addInstVarName: aName asString.
- self instVarAt: self class instSize put: aValue!
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: 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>
- 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: 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>>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>>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 (', self printString, '), and no otherwise clause'!
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 value
-
- "| 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]"!
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>>clone (in category 'copying') -----
- clone
- "Answer a shallow copy of the receiver."
- <primitive: 148 error: ec>
- | class newObject |
- ec == #'insufficient object memory' ifFalse:
- [^self primitiveFailed].
- "If the primitive fails due to insufficient memory, instantiate via basicNew: to invoke
- the garbage collector before retrying, and use copyFrom: to copy state."
- newObject := (class := self class) isVariable
- ifTrue:
- [class isCompiledMethodClass
- ifTrue:
- [class newMethod: self basicSize - self initialPC + 1 header: self header]
- ifFalse:
- [class basicNew: self basicSize]]
- ifFalse:
- [class basicNew].
- ^newObject copyFrom: self!
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 doWithIndex: [: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 clone.
- 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>>currentEvent (in category 'macpal') -----
- currentEvent
- "Answer the current Morphic event. This method never returns nil."
- ^ActiveEvent ifNil:[self currentHand lastEvent]!
Item was removed:
- ----- Method: Object>>currentHand (in category 'macpal') -----
- currentHand
- "Return a usable HandMorph -- the one associated with the object's current environment. This method will always return a hand, even if it has to conjure one up as a last resort. If a particular hand is actually handling events at the moment (such as a remote hand or a ghost hand), it will be returned."
-
- ^ActiveHand ifNil: [ self currentWorld primaryHand ]!
Item was removed:
- ----- Method: Object>>currentWorld (in category 'macpal') -----
- currentWorld
- "Answer a morphic world that is the current UI focus."
- ^ActiveWorld ifNil:[World]!
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."
-
- | 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>>defaultBackgroundColor (in category 'user interface') -----
- defaultBackgroundColor
- "Answer the color to be used as the base window color for a window whose model is an object of the receiver's class"
-
- ^ Preferences windowColorFor: self class name!
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
- maybeSignalDeprecationFor: 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
- maybeSignalDeprecationFor: 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
- maybeSignalDeprecationFor: 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)."
-
- "Testing: (3 activeProcess)"
-
- | exception resumeValue |
- (exception := MessageNotUnderstood new)
- message: aMessage;
- receiver: self.
- resumeValue := exception signal.
- ^exception reachedDefaultHandler
- ifTrue: [aMessage sentTo: self]
- 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 'dependents access') -----
- 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 valueWithPossibleArgument: 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>>hasLiteralSuchThat: (in category 'testing') -----
- hasLiteralSuchThat: testBlock
- "This is the end of the imbedded structure path so return false."
-
- ^ false!
Item was removed:
- ----- Method: Object>>hasModelYellowButtonMenuItems (in category 'graph model') -----
- hasModelYellowButtonMenuItems
- ^Preferences cmdGesturesEnabled!
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>>ifNil:ifNotNilDo: (in category 'accessing') -----
- ifNil: nilBlock ifNotNilDo: aBlock
- "Evaluate aBlock with the receiver as its argument."
-
- ^ aBlock value: self
- !
Item was removed:
- ----- Method: Object>>ifNotNilDo: (in category 'accessing') -----
- ifNotNilDo: aBlock
- "Evaluate the given block with the receiver as its argument."
-
- ^ aBlock value: self
- !
Item was removed:
- ----- Method: Object>>ifNotNilDo:ifNil: (in category 'accessing') -----
- ifNotNilDo: aBlock ifNil: nilBlock
- "Evaluate aBlock with the receiver as its argument."
-
- ^ aBlock value: self
- !
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 do:
- [:elem | Symbol hasInterned: elem asString ifTrue:
- [:elemSymbol |
- | aClass |
- (((aClass := Smalltalk at: elemSymbol ifAbsent: [nil]) isKindOf: Class)
- and: [self isKindOf: aClass])
- ifTrue:
- [^ true]]].
- ^ false
-
-
- "
- {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 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
- variable. Essential. See Object documentation whatIsAPrimitive."
-
- <primitive: 174 error: ec>
- 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>>isCharacter (in category 'testing') -----
- isCharacter
-
- ^ false.
- !
Item was removed:
- ----- Method: Object>>isClosure (in category 'testing') -----
- isClosure
- ^false!
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>>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>>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 'system primitives') -----
- isPinned
- "Answer if the receiver is pinned. The VM's garbage collector routinely moves
- objects as it reclaims and compacts memory. But it can also pin an object so
- that it will not be moved, which can make it easier to pass objects out through
- the FFI."
- <primitive: 183 error: ec>
- ^self primitiveFailed!
Item was 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>>isPseudoContext (in category 'testing') -----
- isPseudoContext
- ^false!
Item was removed:
- ----- Method: Object>>isRectangle (in category 'testing') -----
- isRectangle
- ^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: (ActiveWorld 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 doWithIndex:
- [: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 doWithIndex:
- [: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: (Array new: 0)!
Item was removed:
- ----- Method: Object>>perform:orSendTo: (in category 'message handling') -----
- perform: selector orSendTo: otherTarget
- "If I wish to intercept and handle selector myself, do it; else send it to otherTarget"
- ^ (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: (Array with: 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: (Array with: firstObject with: 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: (Array with: firstObject with: secondObject with: 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: (Array with: firstObject with: secondObject with: thirdObject with: fourthObject)!
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 'system primitives') -----
- pin
- "The VM's garbage collector routinely moves objects as it reclaims and compacts
- memory. But it can also pin an object so that it will not be moved, which can make
- it easier to pass objects out through the FFI. Objects are unpinnned when created.
- This method ensures an object is pinned, and answers whether it was already pinned."
- ^self setPinned: true!
Item was 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 SmallIntegers, or the receiver is an instance of a compact class and the argument isn't, or when the argument's class is compact and the receiver isn't, 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 most cases that you think might work. This is mostly because of a) the difference between compact and non-compact classes, and b) because of differences in the format. As an example, '(Array new: 3) primitiveChangeClassTo: Morph basicNew' would fail for three of the reasons mentioned above. Array is compact, Morph is not (failure #1). Array is variable and Morph is fixed (different format - failure #2). Morph is a fixed-field-only object 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>
- 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 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. tk 6/26/97 13:48"
-
- | aFileName |
- aFileName := self class name asFileName. "do better?"
- aFileName := UIManager default
- request: 'File name?' translated initialAnswer: aFileName.
- aFileName size = 0 ifTrue: [^ 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 asFileName.
- 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>>setPinned: (in category 'system primitives') -----
- setPinned: aBoolean
- "The VM's garbage collector routinely moves objects as it reclaims and compacts
- memory. But it can also pin an object so that it will not be moved, which can make
- it easier to pass objects out through the FFI. Objects are unpinnned when created.
- This primitive either pins or unpins an object, and answers if it was already pinned."
- <primitive: 184 error: ec>
- ^self primitiveFailed!
Item was removed:
- ----- Method: Object>>shallowCopy (in category 'copying') -----
- shallowCopy
- "Answer a copy of the receiver which shares the receiver's instance variables."
- | class newObject index |
- <primitive: 148 error: ec>
- ec == #'insufficient object memory' ifFalse:
- [^self primitiveFailed].
- class := self class.
- class isVariable
- ifTrue:
- [index := self basicSize.
- newObject := class basicNew: index.
- [index > 0] whileTrue:
- [newObject basicAt: index put: (self basicAt: index).
- index := index - 1]]
- ifFalse: [newObject := class basicNew].
- index := class instSize.
- [index > 0] whileTrue:
- [newObject instVarAt: index put: (self instVarAt: index).
- index := index - 1].
- ^newObject!
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 class
- 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 'system primitives') -----
- unpin
- "The VM's garbage collector routinely moves objects as it reclaims and compacts
- memory. But it can also pin an object so that it will not be moved, which can make
- it easier to pass objects out through the FFI. Objects are unpinnned when created.
- This method ensures an object is unpinned, and answers whether it was pinned."
- ^self setPinned: false!
Item was 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 initialize: 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 initialize: 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 clone.
- (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>>initialize (in category 'initialize-release') -----
- initialize
- "Fix for inconsistent image state in which ObjectTracer improperly appears as a subclass
- of Class. This initialization should appear in the Squeak update stream in order to repair
- existing images, and may be removed in a future update."
-
- Class removeSubclass: ObjectTracer class!
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
- "All external messages (those not caused by the re-send) get trapped here"
- "Present a dubugger before proceeding to re-send the message"
-
- ToolSet debugContext: thisContext
- label: 'About to perform: ', aMessage selector
- contents: nil.
- ^ aMessage sentTo: 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.
- newValue := valueBlock valueWithPossibleArgument: aMessage.
- newValue = lastValue ifFalse:
- [changeBlock valueWithPossibleArgument: 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>>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 'testing') -----
- hasLiteral: aLiteral
- ^keyword == aLiteral
- or: [arguments hasLiteral: aLiteral]!
Item was removed:
- ----- Method: Pragma>>hasLiteralSuchThat: (in category 'testing') -----
- hasLiteralSuchThat: aBlock
- "Answer true if litBlock returns true for any literal in the receiver, even if embedded in further array structure.
- This method is only intended for private use by CompiledMethod hasLiteralSuchThat:"
- ^(aBlock value: keyword)
- or: [arguments hasLiteralSuchThat: aBlock]!
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: $<.
- self keyword precedence = 1
- ifTrue: [ aStream nextPutAll: self keyword ]
- ifFalse: [
- self keyword keywords with: self arguments do: [ :key :arg |
- aStream nextPutAll: key; space; print: arg; space ].
- aStream skip: -1 ].
- 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: 'ul 3/22/2011 05:18' 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.
-
- (If anyone ever makes a subclass of Process, be sure to use allSubInstances in anyProcessesAbove:.)
-
- The threadId variable is used by multi-threaded CogVMs to control process-to-thread binding. It's required to be the fourth instance variable. See SmalltalkImage >> #processHasThreadIdInstVar: for further information.
-
- The island and env instance variables are not used by core squeak, but are used by external packages and included here because Monticello cannot handle external instance variables:
- island: used by Tweak and Croquet to partition the image into multiple address spaces
- env: used by ProcessSpecific to implement per-process variables!
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."
-
- | newProcess |
- newProcess := self new.
- newProcess suspendedContext: aContext.
- newProcess priority: anInteger.
- ^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
- "Run self until aContext is popped or an unhandled error is raised. Return self's new top context, unless an unhandled error was raised then return the signaler context (rather than open a debugger)."
-
- | ctxt pair error |
- 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:
- ["Give a debugger a chance to update its title to reflect the new exception"
- Notification new
- tag: {aContext. error};
- signal.
- ^error signalerContext].
- ^ 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 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>>debug (in category 'debugging') -----
- debug
- self debugWithTitle: 'Debug'.!
Item was removed:
- ----- Method: Process>>debug:title: (in category 'debugging') -----
- debug: context title: title
- "Open debugger on self with context shown on top"
-
- self debug: context title: title full: false.
- !
Item was removed:
- ----- Method: Process>>debug:title:full: (in category 'debugging') -----
- debug: context title: title full: bool
- "Open debugger on self with context shown on top"
-
- | topCtxt |
- topCtxt := self isActiveProcess ifTrue: [thisContext] ifFalse: [self suspendedContext].
- (topCtxt hasContext: context) ifFalse: [^ self error: 'context not in process'].
- ToolSet debug: self context: context label: title contents: nil fullView: bool.
- !
Item was removed:
- ----- Method: Process>>debugWithTitle: (in category 'debugging') -----
- debugWithTitle: title
- "Open debugger on self"
-
- | context |
- context := self isActiveProcess ifTrue: [thisContext] ifFalse: [self suspendedContext].
- self debug: context title: title full: true.
- !
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, and all other variables other than
- the scheduling ones to those of aProcess. Used in the execution simulation machinery
- to ensure that Processor activeProcess evaluates correctly when debugging."
- | range savedVariables |
- "range accesses everything after myList, e.g. threadId, effectiveProcess, name, island, env"
- range := 5 to: Process instSize.
- savedVariables := range collect: [:i| self instVarAt: i].
- range do:
- [:i| self instVarAt: i put: (aProcess instVarAt: i)].
- effectiveProcess := aProcess.
- ^aBlock ensure:
- ["write back any assigned-to variables."
- range do:
- [:i| | v |
- ((v := self instVarAt: i) ~~ (aProcess instVarAt: i)
- and: [v notNil]) ifTrue:
- [aProcess instVarAt: i put: v]].
- "restore old values"
- range with: savedVariables do:
- [:i :var| self instVarAt: i put: var]]!
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 has been suspended with the suspend primitive.
- It is distinguishable from the active process and a terminated process by
- having a non-nil suspendedContext that is either not the bottom context
- or has not reached its endPC."
- ^nil == myList
- and: [nil ~~ suspendedContext
- and: [suspendedContext isBottomContext
- ifTrue: [suspendedContext closure
- ifNil: [suspendedContext methodClass ~~ Process
- or: [suspendedContext selector ~~ #terminate]]
- ifNotNil: [suspendedContext pc < suspendedContext closure endPC]]
- ifFalse: [true]]]!
Item was removed:
- ----- Method: Process>>isTerminated (in category 'testing') -----
- isTerminated
- "Answer if the receiver is terminated, or at least terminating."
- self isActiveProcess ifTrue: [^ false].
- ^suspendedContext isNil
- or: ["If the suspendedContext is the bottomContext it is the block in Process>>newProcess.
- If so, and the pc is at the endPC, the block has already sent and returned
- from value and there is nothing more to do."
- suspendedContext isBottomContext
- and: [suspendedContext closure
- ifNil: [suspendedContext methodClass == Process
- and: [suspendedContext selector == #terminate]]
- ifNotNil: [suspendedContext pc >= suspendedContext closure endPC]]]!
Item was removed:
- ----- Method: Process>>longPrintOn: (in category 'printing') -----
- longPrintOn: stream
-
- | ctxt |
- super printOn: stream.
- 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 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>>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 := MethodContext
- 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>
- 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"
- | oldList |
- "If we are the active process, go ahead and signal the exception"
- self isActiveProcess ifTrue: [^anException signal].
-
- "Suspend myself first to ensure that I won't run away in the
- midst of the following modifications."
- myList ifNotNil:[oldList := self suspend].
-
- "Add a new method context to the stack that will signal the exception"
- suspendedContext := MethodContext
- sender: suspendedContext
- receiver: self
- method: (self class lookupSelector: #pvtSignal:list:)
- arguments: (Array with: anException with: oldList).
-
- "If we are on a list to run, then suspend and restart the receiver
- (this lets the receiver run if it is currently blocked on a semaphore). If
- we are not on a list to be run (i.e. this process is suspended), then when the
- process is resumed, it will signal the exception"
-
- oldList ifNotNil: [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
- "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)."
- | oldList |
- <primitive: 88>
- "This is fallback code for VMs which only support the old primitiveSuspend which
- would not accept processes that are waiting to be run."
- myList ifNil:[^nil]. "this allows us to use suspend multiple times"
- oldList := myList.
- 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: aContext
-
- suspendedContext := aContext!
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."
-
- | ctxt unwindBlock oldList |
- self isActiveProcess ifTrue: [
- ctxt := thisContext.
- [ ctxt := ctxt findNextUnwindContextUpTo: nil.
- ctxt isNil
- ] whileFalse: [
- (ctxt tempAt: 2) ifNil:[
- ctxt tempAt: 2 put: nil.
- unwindBlock := ctxt tempAt: 1.
- thisContext terminateTo: ctxt.
- unwindBlock value].
- ].
- thisContext terminateTo: nil.
- self suspend.
- ] ifFalse:[
- "Always suspend the process first so it doesn't accidentally get woken up"
- oldList := self suspend.
- suspendedContext ifNotNil:[
- "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."
- (suspendedContext isClosureContext
- and: [(suspendedContext method pragmaAt: #criticalSection) notNil
- and: [suspendedContext startpc > suspendedContext closure startpc]]) ifTrue:
- [suspendedContext := suspendedContext home].
-
- "If we are terminating a process halfways through an unwind, try
- to complete that unwind block first."
- (suspendedContext findNextUnwindContextUpTo: nil) ifNotNil:
- [:outer|
- (suspendedContext findContextSuchThat:[:c| c closure == (outer tempAt: 1)]) ifNotNil:
- [:inner| "This is an unwind block currently under evaluation"
- suspendedContext runUntilErrorOrReturnFrom: inner]].
-
- ctxt := self popTo: suspendedContext bottomContext.
- ctxt == suspendedContext bottomContext ifFalse:
- [self debug: ctxt title: 'Unwind error during termination'].
- "Set the context to its endPC for the benefit of isTerminated."
- ctxt pc: ctxt endPC]]!
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 activeProcess'
- 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>>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
- "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."
-
- Smalltalk processPreemptionYields ifTrue:
- [Smalltalk processPreemptionYields: false].
- resuming ifTrue:
- [Smalltalk installLowSpaceWatcher.
- BackgroundProcess ifNotNil:
- [BackgroundProcess terminate].
- (BackgroundProcess := [self idleProcess] newProcess)
- priority: SystemRockBottomPriority;
- resume]!
Item was removed:
- ----- Method: ProcessorScheduler>>activePriority (in category 'accessing') -----
- activePriority
- "Answer the priority level of the currently running Process."
-
- ^activeProcess effectiveProcess priority!
Item was removed:
- ----- Method: ProcessorScheduler>>activeProcess (in category 'accessing') -----
- activeProcess
- "Answer the currently running Process."
-
- ^activeProcess effectiveProcess!
Item was removed:
- ----- Method: ProcessorScheduler>>anyProcessesAbove: (in category 'private') -----
- anyProcessesAbove: highestPriority
- "Do any instances of Process exist with higher priorities?"
-
- ^(Process allSubInstances select: [:aProcess |
- aProcess priority > highestPriority]) isEmpty
- "If anyone ever makes a subclass of Process, be sure to use allSubInstances."!
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."
-
- | continue 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 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."
- | list |
- activeProcess priority to: 1 by: -1 do:[:priority|
- list := quiescentProcessLists at: priority.
- list isEmpty ifFalse:[^list last].
- ].
- ^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."
-
- activeProcess effectiveProcess 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: 'onError value resolvers mutex state error rejectors rejecters'
- classVariableNames: ''
- poolDictionaries: ''
- category: 'Kernel-Processes'!
-
- !Promise commentStamp: 'fbs 5/17/2013 18:23' 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, or from #pending -> #rejected. No other state changes may occur. Once #fulfilled or #rejected, a Promise's value must change.!
Item was removed:
- ----- Method: Promise class>>ifRejected: (in category 'instance creation') -----
- ifRejected: aBlock
- ^ Promise 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."
- ^ Promise basicNew initializeWithResolvedValue: anObject.!
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>>ifRejected: (in category 'monad') -----
- ifRejected: errBlock
- ^ self then: [:ignored | "Do nothing"] 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>>rejectWith: (in category 'resolving') -----
- rejectWith: anObject
- "Reject this promise."
- mutex critical: [
- (state == #fulfilled) ifTrue: [self error: 'Promise was already resolved'].
- (state == #rejected) ifTrue: [self error: 'Promise was already rejected'].
- error := anObject.
- state := #rejected.
- rejecters do: [:r | self evaluateRejecter: r]].!
Item was removed:
- ----- Method: Promise>>resolveWith: (in category 'resolving') -----
- resolveWith: arg
- "Resolve this promise"
- mutex critical: [
- (state == #fulfilled) ifTrue: [self error: 'Promise was already resolved'].
- (state == #rejected) ifTrue: [self error: 'Promise was already resolved'].
- value := arg.
- state := #fulfilled.
- resolvers do: [:r |
- self evaluateResolver: r]].!
Item was removed:
- ----- Method: Promise>>then: (in category 'monad') -----
- then: resolvedBlock
- ^ self then: resolvedBlock ifRejected: [:ignored | "Do nothing"].!
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 := Promise new.
- self whenResolved: [:v |
- [p resolveWith: (resolvedBlock value: v)]
- on: Error do: [:e | p rejectWith: e]].
- self whenRejected: [:e | p rejectWith: (errBlock value: e)].
- ^ 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 resolve."
- | sema |
- sema := Semaphore new.
- self whenResolved:[sema signal].
- sema wait.
- ^value!
Item was removed:
- ----- Method: Promise>>waitTimeoutMSecs: (in category 'waiting') -----
- waitTimeoutMSecs: msecs
- "Wait for at most the given number of milliseconds for this promise to resolve. Answer true if it is resolved, false otherwise."
- | sema delay |
- sema := Semaphore new.
- self whenResolved: [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: [
- rejecters := rejecters copyWith: aBlock.
- self isRejected ifTrue:[self evaluateRejecter: aBlock].
- ]!
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: [
- resolvers := resolvers copyWith: aBlock.
- self isResolved ifTrue:[self evaluateResolver: aBlock].
- ]!
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>>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 an immediate such as a SmallInteger."
-
- {self} elementsExchangeIdentityWith: {otherObject}!
Item was removed:
- ----- Method: ProtoObject>>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."
-
- {self} elementsForwardIdentityTo: {otherObject}!
Item was removed:
- ----- Method: ProtoObject>>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."
-
- {self}
- elementsForwardIdentityTo: {otherObject}
- copyHash: copyHash!
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 SmallInteger.
- Primitive. Fails if the receiver is a SmallInteger. 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>>tryNamedPrimitive (in category 'apply primitives') -----
- tryNamedPrimitive
- "This method is a template that the Smalltalk simulator uses to
- execute primitives. See Object documentation whatIsAPrimitive."
- <primitive:'' module:'' error: errorCode>
- ^ContextPart primitiveFailTokenFor: errorCode!
Item was removed:
- ----- Method: ProtoObject>>tryNamedPrimitive: (in category 'apply primitives') -----
- tryNamedPrimitive: arg1
- "This method is a template that the Smalltalk simulator uses to
- execute primitives. See Object documentation whatIsAPrimitive."
- <primitive:'' module:'' error: errorCode>
- ^ContextPart primitiveFailTokenFor: errorCode!
Item was removed:
- ----- Method: ProtoObject>>tryNamedPrimitive:with: (in category 'apply primitives') -----
- tryNamedPrimitive: arg1 with: arg2
- "This method is a template that the Smalltalk simulator uses to
- execute primitives. See Object documentation whatIsAPrimitive."
- <primitive:'' module:'' error: errorCode>
- ^ContextPart primitiveFailTokenFor: errorCode!
Item was removed:
- ----- Method: ProtoObject>>tryNamedPrimitive:with:with: (in category 'apply primitives') -----
- tryNamedPrimitive: arg1 with: arg2 with: arg3
- "This method is a template that the Smalltalk simulator uses to
- execute primitives. See Object documentation whatIsAPrimitive."
- <primitive:'' module:'' error: errorCode>
- ^ContextPart primitiveFailTokenFor: errorCode!
Item was removed:
- ----- Method: ProtoObject>>tryNamedPrimitive:with:with:with: (in category 'apply primitives') -----
- tryNamedPrimitive: arg1 with: arg2 with: arg3 with: arg4
- "This method is a template that the Smalltalk simulator uses to
- execute primitives. See Object documentation whatIsAPrimitive."
- <primitive:'' module:'' error: errorCode>
- ^ContextPart primitiveFailTokenFor: errorCode!
Item was removed:
- ----- Method: ProtoObject>>tryNamedPrimitive:with:with:with:with: (in category 'apply primitives') -----
- tryNamedPrimitive: arg1 with: arg2 with: arg3 with: arg4 with: arg5
- "This method is a template that the Smalltalk simulator uses to
- execute primitives. See Object documentation whatIsAPrimitive."
- <primitive:'' module:'' error: errorCode>
- ^ContextPart primitiveFailTokenFor: errorCode!
Item was removed:
- ----- Method: ProtoObject>>tryNamedPrimitive:with:with:with:with:with: (in category 'apply primitives') -----
- tryNamedPrimitive: arg1 with: arg2 with: arg3 with: arg4 with: arg5 with: arg6
- "This method is a template that the Smalltalk simulator uses to
- execute primitives. See Object documentation whatIsAPrimitive."
- <primitive:'' module:'' error: errorCode>
- ^ContextPart primitiveFailTokenFor: errorCode!
Item was removed:
- ----- Method: ProtoObject>>tryNamedPrimitive:with:with:with:with:with:with: (in category 'apply primitives') -----
- tryNamedPrimitive: arg1 with: arg2 with: arg3 with: arg4 with: arg5 with: arg6 with: arg7
- "This method is a template that the Smalltalk simulator uses to
- execute primitives. See Object documentation whatIsAPrimitive."
- <primitive:'' module:'' error: errorCode>
- ^ContextPart primitiveFailTokenFor: errorCode!
Item was removed:
- ----- Method: ProtoObject>>tryNamedPrimitive:with:with:with:with:with:with:with: (in category 'apply primitives') -----
- tryNamedPrimitive: arg1 with: arg2 with: arg3 with: arg4 with: arg5 with: arg6 with: arg7 with: arg8
- "This method is a template that the Smalltalk simulator uses to
- execute primitives. See Object documentation whatIsAPrimitive."
- <primitive:'' module:'' error: errorCode>
- ^ContextPart primitiveFailTokenFor: errorCode!
Item was removed:
- ----- Method: ProtoObject>>tryPrimitive:withArgs: (in category 'apply primitives') -----
- tryPrimitive: primIndex withArgs: argumentArray
- "This method is a template that the Smalltalk simulator uses to
- execute primitives. See Object documentation whatIsAPrimitive."
-
- <primitive: 118 error: errorCode>
- ^ContextPart 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>>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: [^ Number 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.
- 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 expr}
- 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.
- token := self diceToken: stream]
- ifFalse: [token == $d
- ifTrue: [dice := 1]
- ifFalse: [res := 0]].
- 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."
-
- | 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;
- generateStates!
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:
- 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>>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>>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>>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>>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 changed:
Timespan subclass: #Schedule
instanceVariableNames: 'schedule'
classVariableNames: ''
poolDictionaries: ''
+ category: 'Chronology-Core'!
- category: 'Kernel-Chronology'!
!Schedule commentStamp: 'brp 5/13/2003 09:48' prior: 0!
I represent a powerful class for implementing recurring schedules.!
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>
- | caught |
- "We need to catch eventual interruptions very carefully.
- The naive approach of just doing, e.g.,:
- self wait.
- aBlock ensure:[self signal].
- will fail if the active process gets terminated while in the wait.
- However, the equally naive:
- [self wait.
- aBlock value] ensure:[self signal].
- will fail too, since the active process may get interrupted while
- entering the ensured block and leave the semaphore signaled twice.
- To avoid both problems we make use of the fact that interrupts only
- occur on sends (or backward jumps) and use an assignment (bytecode)
- right before we go into the wait primitive (which cannot be preempted)."
-
- caught := false.
- ^[
- caught := true.
- self wait.
- mutuallyExcludedBlock value
- ] ensure: [ caught ifTrue: [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."
-
- | caught |
- caught := false.
- ^[
- "We're using #== here instead of #=, because it won't introduce a
- suspension point, while #= may do that."
- excessSignals == 0
- ifTrue: [ alternativeBlock value ]
- ifFalse: [
- excessSignals := excessSignals - 1.
- caught := true.
- mutuallyExcludedBlock value ] ]
- ensure: [ caught ifTrue: [ 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>>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:
==== ERROR ===
Error: Unrecognized class type
3 March 2016 7:23:50.433 pm
VM: unix - a SmalltalkImage
Image: Squeak3.11alpha [latest update: #8824]
SecurityManager state:
Restricted: false
FileAccess: true
SocketAccess: true
Working Dir /home/squeaksource
Trusted Dir /home/squeaksource/secure
Untrusted Dir /home/squeaksource/My Squeak
MCClassDefinition(Object)>>error:
Receiver: a MCClassDefinition(SmallFloat64)
Arguments and temporary variables:
aString: 'Unrecognized class type'
Receiver's instance variables:
name: #SmallFloat64
superclassName: #Float
variables: an OrderedCollection()
category: #'Kernel-Numbers'
type: #immediate
comment: 'My instances represent 64-bit Floats whose exponent fits in 8 bits as...etc...
commentStamp: 'eem 11/25/2014 07:54'
traitComposition: nil
classTraitComposition: nil
MCClassDefinition>>kindOfSubclass
Receiver: a MCClassDefinition(SmallFloat64)
Arguments and temporary variables:
Receiver's instance variables:
name: #SmallFloat64
superclassName: #Float
variables: an OrderedCollection()
category: #'Kernel-Numbers'
type: #immediate
comment: 'My instances represent 64-bit Floats whose exponent fits in 8 bits as...etc...
commentStamp: 'eem 11/25/2014 07:54'
traitComposition: nil
classTraitComposition: nil
MCClassDefinition>>printDefinitionOn:
Receiver: a MCClassDefinition(SmallFloat64)
Arguments and temporary variables:
stream: a WriteStream
Receiver's instance variables:
name: #SmallFloat64
superclassName: #Float
variables: an OrderedCollection()
category: #'Kernel-Numbers'
type: #immediate
comment: 'My instances represent 64-bit Floats whose exponent fits in 8 bits as...etc...
commentStamp: 'eem 11/25/2014 07:54'
traitComposition: nil
classTraitComposition: nil
[] in MCDiffyTextWriter(MCStWriter)>>writeClassDefinition:
Receiver: a MCDiffyTextWriter
Arguments and temporary variables:
definition: a WriteStream
s: a MCClassDefinition(SmallFloat64)
Receiver's instance variables:
stream: a WriteStream
initStream: nil
--- The full stack ---
MCClassDefinition(Object)>>error:
MCClassDefinition>>kindOfSubclass
MCClassDefinition>>printDefinitionOn:
[] in MCDiffyTextWriter(MCStWriter)>>writeClassDefinition:
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
String class(SequenceableCollection class)>>new:streamContents:
String class(SequenceableCollection class)>>streamContents:
MCDiffyTextWriter(MCTextWriter)>>chunkContents:
MCDiffyTextWriter(MCStWriter)>>writeClassDefinition:
MCDiffyTextWriter(MCStWriter)>>visitClassDefinition:
MCClassDefinition>>accept:
[] in MCDiffyTextWriter(MCTextWriter)>>visitInFork:
String class(SequenceableCollection class)>>new:streamContents:
String class(SequenceableCollection class)>>streamContents:
MCDiffyTextWriter(MCTextWriter)>>visitInFork:
MCDiffyTextWriter>>writePatchFrom:to:
MCDiffyTextWriter>>writeRemoval:
[] in MCDiffyTextWriter>>writePatch:
SortedCollection(OrderedCollection)>>do:
MCDiffyTextWriter>>writePatch:
SSDiffyTextWriter>>writePatch:
[] in SSDiffyTextWriter>>writeVersion:for:
BlockClosure>>on:do:
SSDiffyTextWriter>>writeVersion:for:
[] in SSEMailSubscription>>versionAdded:to:
BlockClosure>>on:do:
SSEMailSubscription>>versionAdded:to:
[] in [] in SSProject>>versionAdded:
[] in BlockClosure>>newProcess
More information about the Packages
mailing list