[Pkg] The Trunk: Kernel-bf.7.mcz
commits at source.squeak.org
commits at source.squeak.org
Mon Aug 29 13:05:02 UTC 2016
Tim Felgentreff uploaded a new version of Kernel to project The Trunk:
http://source.squeak.org/trunk/Kernel-bf.7.mcz
==================== Summary ====================
Name: Kernel-bf.7
Author: bf
Time: 24 June 2012, 5:45:51 pm
UUID: 80638d99-85ed-402f-8587-13ec6273e9fa
Ancestors: Kernel-kfr.6
Change Set: monthAndDayOfWeek-sw
Date: 22 June 2012
Author: Scott Wallace
Makes the month names January...December and weekday names Monday..Sunday appear for translation in the translation tools.
(modified by bf: do not add a method but mark the original definitions for translation)
==================== Snapshot ====================
SystemOrganization addCategory: #'Kernel-Chronology'!
SystemOrganization addCategory: #'Kernel-Classes'!
SystemOrganization addCategory: #'Kernel-Contexts'!
SystemOrganization addCategory: #'Kernel-Methods'!
SystemOrganization addCategory: #'Kernel-Numbers'!
SystemOrganization addCategory: #'Kernel-Objects'!
SystemOrganization addCategory: #'Kernel-Processes'!
SystemOrganization addCategory: #'Kernel-Models'!
----- Method: ModifiedClassDefinitionEvent>>anyChanges (in category '*Kernel-Classes') -----
anyChanges
^ self isSuperclassModified or: [self areInstVarsModified or: [self areClassVarsModified or: [self areSharedPoolsModified]]]!
----- Method: ModifiedClassDefinitionEvent>>printOn: (in category '*Kernel-Classes') -----
printOn: aStream
super printOn: aStream.
aStream
nextPutAll: ' Super: ';
print: self isSuperclassModified;
nextPutAll: ' InstVars: ';
print: self areInstVarsModified;
nextPutAll: ' ClassVars: ';
print: self areClassVarsModified;
nextPutAll: ' SharedPools: ';
print: self areSharedPoolsModified.!
Dictionary variableSubclass: #MethodDictionary
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Kernel-Methods'!
!MethodDictionary commentStamp: '<historical>' prior: 0!
I am just like a normal Dictionary, except that I am implemented differently. Each Class has an instances 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.!
----- Method: MethodDictionary class>>new (in category 'instance creation') -----
new
"change the default size to be a bit bigger to help reduce the number of #grows while filing in"
^self new: 16!
----- Method: MethodDictionary class>>new: (in category 'instance creation') -----
new: nElements
"Create a Dictionary large enough to hold nElements without growing.
Note that the basic size must be a power of 2.
It is VITAL (see grow) that size gets doubled if nElements is a power of 2"
| size |
size _ 1 bitShift: nElements highBit.
^ (self basicNew: size) init: size!
----- Method: MethodDictionary>>add: (in category 'accessing') -----
add: anAssociation
^ self at: anAssociation key put: anAssociation value!
----- Method: MethodDictionary>>associationsDo: (in category 'enumeration') -----
associationsDo: aBlock
| key |
tally = 0 ifTrue: [^ self].
1 to: self basicSize do:
[:i | (key _ self basicAt: i) == nil ifFalse:
[aBlock value: (Association key: key
value: (array at: i))]]!
----- Method: MethodDictionary>>at:ifAbsent: (in category 'accessing') -----
at: key ifAbsent: aBlock
| index |
index _ self findElementOrNil: key.
(self basicAt: index) == nil ifTrue: [ ^ aBlock value ].
^ array at: index!
----- Method: MethodDictionary>>at:put: (in category 'accessing') -----
at: key put: value
"Set the value at key to be value."
| index |
index _ self findElementOrNil: key.
(self basicAt: index) == nil
ifTrue:
[tally _ tally + 1.
self basicAt: index put: key]
ifFalse:
[(array at: index) flushCache].
array at: index put: value.
self fullCheck.
^ value!
----- Method: MethodDictionary>>at:putNoBecome: (in category 'accessing') -----
at: key putNoBecome: value
"Set the value at key to be value. Answer the resulting MethodDictionary"
| index |
index _ self findElementOrNil: key.
(self basicAt: index) == nil
ifTrue:
[tally _ tally + 1.
self basicAt: index put: key]
ifFalse:
[(array at: index) flushCache].
array at: index put: value.
^self fullCheckNoBecome!
----- Method: MethodDictionary>>copy (in category 'private') -----
copy
^ self shallowCopy withArray: array shallowCopy!
----- Method: MethodDictionary>>fullCheckNoBecome (in category 'private') -----
fullCheckNoBecome
"Keep array at least 1/4 free for decent hash behavior"
array size - tally < (array size // 4 max: 1)
ifTrue: [^self growNoBecome].
^self
!
----- Method: MethodDictionary>>grow (in category 'private') -----
grow
| newSelf key |
newSelf _ self species new: self basicSize. "This will double the size"
1 to: self basicSize do:
[:i | key _ self basicAt: i.
key == nil ifFalse: [newSelf at: key put: (array at: i)]].
self become: newSelf!
----- Method: MethodDictionary>>growNoBecome (in category 'private') -----
growNoBecome
| newSelf key |
newSelf _ self species new: self basicSize. "This will double the size"
1 to: self basicSize do:
[:i | key _ self basicAt: i.
key == nil ifFalse: [newSelf at: key put: (array at: i)]].
^newSelf!
----- Method: MethodDictionary>>includesKey: (in category 'accessing') -----
includesKey: aSymbol
"This override assumes that pointsTo is a fast primitive"
aSymbol ifNil: [^ false].
^ super pointsTo: aSymbol!
----- Method: MethodDictionary>>keyAt: (in category 'private') -----
keyAt: index
^ self basicAt: index!
----- 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."
| theKey |
1 to: self basicSize do:
[:index |
value == (array at: index)
ifTrue:
[(theKey _ self basicAt: index) == nil
ifFalse: [^ theKey]]].
^ exceptionBlock value!
----- 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."
| theKey |
1 to: self basicSize do:
[:index |
value = (array at: index)
ifTrue:
[(theKey _ self basicAt: index) == nil
ifFalse: [^ theKey]]].
^ exceptionBlock value!
----- Method: MethodDictionary>>keysAndValuesDo: (in category 'enumeration') -----
keysAndValuesDo: aBlock
"Enumerate the receiver with all the keys and values passed to the block"
| key |
tally = 0 ifTrue: [^ self].
1 to: self basicSize do:
[:i | (key _ self basicAt: i) == nil ifFalse:
[aBlock value: key value: (array at: i)]
]!
----- Method: MethodDictionary>>keysDo: (in category 'enumeration') -----
keysDo: aBlock
| key |
tally = 0 ifTrue: [^ self].
1 to: self basicSize do:
[:i | (key _ self basicAt: i) == nil
ifFalse: [aBlock value: key]]!
----- Method: MethodDictionary>>methodArray (in category 'private') -----
methodArray
^ array!
----- Method: MethodDictionary>>rehash (in category 'private') -----
rehash
| newSelf key |
newSelf _ self species new: self size.
1 to: self basicSize do:
[:i | key _ self basicAt: i.
key == nil ifFalse: [newSelf at: key put: (array at: i)]].
self become: newSelf!
----- Method: MethodDictionary>>rehashWithoutBecome (in category 'private') -----
rehashWithoutBecome
| newSelf key |
newSelf _ self species new: self size.
1 to: self basicSize do:
[:i | key _ self basicAt: i.
key == nil ifFalse: [newSelf at: key put: (array at: i)]].
^newSelf!
----- 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 findElementOrNil: key.
(self basicAt: index) == nil ifTrue: [ ^ aBlock value ].
element _ array at: index.
array at: index put: nil.
self basicAt: index put: nil.
tally _ tally - 1.
self fixCollisionsFrom: index.
^ element!
----- 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 become that copy"
| copy |
copy _ self copy.
copy removeDangerouslyKey: key ifAbsent: [^ errorBlock value].
self become: copy!
----- Method: MethodDictionary>>removeKeyNoBecome: (in category 'removing') -----
removeKeyNoBecome: key
"The interpreter might be using this MethodDict while
this method is running!! Therefore we perform the removal
in a copy, and then return the copy for subsequent installation"
| copy |
copy _ self copy.
copy removeDangerouslyKey: key ifAbsent: [^ self].
^copy!
----- 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 zero if no slot is found. This method will be overridden in various subclasses that have different interpretations for matching elements."
| element start finish |
finish _ array size.
start _ (anObject identityHash \\ finish) + 1.
"Search from (hash mod size) to the end."
start to: finish do:
[:index | ((element _ self basicAt: index) == nil or: [element == anObject])
ifTrue: [^ index ]].
"Search from 1 to where we started."
1 to: start-1 do:
[:index | ((element _ self basicAt: index) == nil or: [element == anObject])
ifTrue: [^ index ]].
^ 0 "No match AND no empty slot"!
----- 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.
super swap: oneIndex with: otherIndex.
!
----- Method: MethodDictionary>>valuesDo: (in category 'enumeration') -----
valuesDo: aBlock
| value |
tally = 0 ifTrue: [^ self].
1 to: self basicSize do:
[:i | (value _ array at: i) == nil
ifFalse: [aBlock value: value]]!
----- Method: MethodReference>>actualClass (in category '*Kernel-Traits') -----
actualClass
| actualClass |
actualClass _ Smalltalk atOrBelow: classSymbol ifAbsent: [^nil].
classIsMeta ifTrue: [^actualClass class].
^actualClass
!
Link subclass: #Process
instanceVariableNames: 'suspendedContext priority myList errorHandler name'
classVariableNames: ''
poolDictionaries: ''
category: 'Kernel-Processes'!
!Process commentStamp: '<historical>' 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:.)!
----- 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!
----- 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"
^ suspendedContext _ suspendedContext activateReturn: aContext value: value!
----- Method: Process>>browserPrintString (in category 'printing') -----
browserPrintString
^self browserPrintStringWith: suspendedContext!
----- 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!
----- 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']!
----- 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 _ ctxt runUntilErrorOrReturnFrom: aContext.
suspendedContext _ pair first.
error _ pair second.
error ifNotNil: [^ error signalerContext].
^ suspendedContext!
----- 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"!
----- 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)!
----- Method: Process>>copyStack (in category 'accessing') -----
copyStack
^ self copy install: suspendedContext copyStack!
----- Method: Process>>debug (in category 'debugging') -----
debug
self debugWithTitle: 'Debug'.!
----- 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.
!
----- 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'].
Debugger openOn: self context: context label: title contents: nil fullView: bool.
!
----- Method: Process>>debug:title:full:contents: (in category 'debugging') -----
debug: context title: title full: bool contents: contents
"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'].
Debugger openOn: self context: context label: title contents: contents fullView: bool.
!
----- 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.
!
----- Method: Process>>errorHandler (in category 'error handling') -----
errorHandler
^ errorHandler!
----- Method: Process>>errorHandler: (in category 'error handling') -----
errorHandler: aBlock
errorHandler _ aBlock!
----- 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!
----- Method: Process>>isActiveProcess (in category 'accessing') -----
isActiveProcess
^ self == Processor activeProcess!
----- Method: Process>>isSuspended (in category 'accessing') -----
isSuspended
^myList isNil!
----- Method: Process>>isTerminated (in category 'accessing') -----
isTerminated
self isActiveProcess ifTrue: [^ false].
^ suspendedContext isNil or: [
suspendedContext == suspendedContext bottomContext and: [
suspendedContext pc > suspendedContext startpc]]!
----- 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.
].
!
----- Method: Process>>name (in category 'accessing') -----
name
^name ifNil: [ self hash asString forceTo: 5 paddingStartWith: $ ]!
----- Method: Process>>name: (in category 'accessing') -----
name: aString
name _ aString!
----- 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!
----- Method: Process>>offList (in category 'accessing') -----
offList
"Inform the receiver that it has been taken off a list that it was
suspended on. This is to break a backpointer."
myList _ nil!
----- 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."
| callee |
self == Processor activeProcess
ifTrue: [^ self error: 'The active process cannot pop contexts'].
callee _ (self calleeOf: aContext) ifNil: [^ aContext]. "aContext is on top"
^ self return: callee value: callee receiver!
----- 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."
| callee |
self == Processor activeProcess
ifTrue: [^ self error: 'The active process cannot pop contexts'].
callee _ (self calleeOf: aContext) ifNil: [^ self]. "aContext is on top"
self return: callee value: aValue!
----- Method: Process>>primitiveResume (in category 'changing process state') -----
primitiveResume
"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).
Essential. See Object documentation whatIsAPrimitive."
<primitive: 87>
self primitiveFailed!
----- Method: Process>>primitiveSuspend (in category 'changing process state') -----
primitiveSuspend
"Primitive. Stop the process that self represents in such a way
that it can be restarted at a later time (by sending #resume).
ASSUMES self is the active process.
Essential. See Object documentation whatIsAPrimitive."
<primitive: 88>
self primitiveFailed!
----- Method: Process>>printOn: (in category 'printing') -----
printOn: aStream
super printOn: aStream.
aStream nextPutAll: ' in '.
suspendedContext printOn: aStream!
----- Method: Process>>priority (in category 'accessing') -----
priority
"Answer the priority of the receiver."
^priority!
----- 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]!
----- 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.
!
----- Method: Process>>restartTop (in category 'changing suspended state') -----
restartTop
"Rollback top context and replace with new method. Assumes self is suspended"
suspendedContext privRefresh!
----- 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 privRefreshWith: method ].
!
----- Method: Process>>resume (in category 'changing process state') -----
resume
"Allow the process that the receiver represents to continue. Put
the receiver in line to become the activeProcess. Check for a nil
suspendedContext, which indicates a previously terminated Process that
would cause a vm crash if the resume attempt were permitted"
suspendedContext ifNil: [^ self primitiveFailed].
^ self primitiveResume!
----- 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: [
^ suspendedContext _ aContext return: value from: aContext].
self activateReturn: aContext value: value.
^ self complete: aContext.
!
----- 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!
----- Method: Process>>signalException: (in category 'signaling') -----
signalException: anException
"Signal an exception in the receiver process...if the receiver is currently
suspended, the exception will get signaled when the receiver is resumed. If
the receiver is blocked on a Semaphore, it will be immediately re-awakened
and the exception will be signaled; if the exception is resumed, then the receiver
will return to a blocked state unless the blocking Semaphore has excess signals"
"If we are the active process, go ahead and signal the exception"
self isActiveProcess ifTrue: [^anException signal].
"Add a new method context to the stack that will signal the exception"
suspendedContext := MethodContext
sender: suspendedContext
receiver: self
method: (self class methodDict at: #pvtSignal:list:)
arguments: (Array with: anException with: myList).
"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"
myList ifNotNil: [self suspend; resume].!
----- Method: Process>>step (in category 'changing suspended state') -----
step
^ suspendedContext _ suspendedContext step!
----- 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"
^ self suspendedContext == aContext
ifTrue: [self step]
ifFalse: [self complete: (self calleeOf: aContext)]!
----- Method: Process>>stepToCallee (in category 'changing suspended state') -----
stepToCallee
"Step until top context changes"
| ctxt |
ctxt _ suspendedContext.
[ctxt == suspendedContext] whileTrue: [
suspendedContext _ suspendedContext step].
^ suspendedContext!
----- 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."
| home ctxt |
home _ aContext home.
[ ctxt _ self step.
home == ctxt home.
] whileFalse: [
home isDead ifTrue: [^ self suspendedContext].
].
^ self suspendedContext!
----- Method: Process>>stepToSendOrReturn (in category 'changing suspended state') -----
stepToSendOrReturn
^ suspendedContext _ suspendedContext stepToSendOrReturn!
----- Method: Process>>suspend (in category 'changing process state') -----
suspend
"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."
self isActiveProcess ifTrue: [
myList _ nil.
self primitiveSuspend.
] ifFalse: [
myList ifNotNil: [
myList remove: self ifAbsent: [].
myList _ nil].
]
!
----- Method: Process>>suspendedContext (in category 'accessing') -----
suspendedContext
"Answer the context the receiver has suspended."
^suspendedContext!
----- Method: Process>>suspendedContext: (in category 'private') -----
suspendedContext: aContext
suspendedContext _ aContext!
----- Method: Process>>suspendingList (in category 'accessing') -----
suspendingList
"Answer the list on which the receiver has been suspended."
^myList!
----- 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 |
self isActiveProcess ifTrue: [
ctxt _ thisContext.
[ ctxt _ ctxt findNextUnwindContextUpTo: nil.
ctxt isNil
] whileFalse: [
unwindBlock _ ctxt tempAt: 1.
unwindBlock ifNotNil: [
ctxt tempAt: 1 put: nil.
thisContext terminateTo: ctxt.
unwindBlock value].
].
thisContext terminateTo: nil.
myList _ nil.
self primitiveSuspend.
] ifFalse: [
myList ifNotNil: [
myList remove: self ifAbsent: [].
myList _ nil].
suspendedContext ifNotNil: [
ctxt _ self popTo: suspendedContext bottomContext.
ctxt == suspendedContext bottomContext ifFalse: [
self debug: ctxt title: 'Unwind error during termination']].
].
!
Array weakSubclass: #DependentsArray
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Kernel-Models'!
!DependentsArray commentStamp: '<historical>' prior: 0!
An array of (weak) dependents of some object.!
----- Method: DependentsArray>>copyWith: (in category 'copying') -----
copyWith: newElement
"Re-implemented to not copy any niled out dependents"
^self class streamContents:[:s|
self do:[:item| s nextPut: item].
s nextPut: newElement].!
----- Method: DependentsArray>>do: (in category 'enumerating') -----
do: aBlock
"Refer to the comment in Collection|do:."
| dep |
1 to: self basicSize do:[:i|
(dep _ self at: i) ifNotNil:[aBlock value: dep]].!
----- Method: DependentsArray>>select: (in category 'enumerating') -----
select: aBlock
"Refer to the comment in Collection|select:."
| aStream |
aStream _ WriteStream on: (self species new: self size).
self do:[:obj|
(aBlock value: obj)
ifTrue: [aStream nextPut: obj]].
^ aStream contents!
----- Method: DependentsArray>>size (in category 'accessing') -----
size
^self inject: 0 into: [ :count :dep | dep ifNotNil: [ count _ count + 1 ]]!
Array variableSubclass: #WeakActionSequence
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Kernel-Objects'!
----- Method: WeakActionSequence>>asActionSequence (in category 'converting') -----
asActionSequence
^self!
----- Method: WeakActionSequence>>asActionSequenceTrappingErrors (in category 'converting') -----
asActionSequenceTrappingErrors
^WeakActionSequenceTrappingErrors withAll: self!
----- Method: WeakActionSequence>>asMinimalRepresentation (in category 'converting') -----
asMinimalRepresentation
| valid |
valid := self select: [:e | e isValid ].
valid size = 0
ifTrue: [^nil].
valid size = 1
ifTrue: [^valid first].
^valid!
----- Method: WeakActionSequence>>printOn: (in category 'printing') -----
printOn: aStream
self size < 2 ifTrue: [^super printOn: aStream].
aStream nextPutAll: '#('.
self
do: [:each | each printOn: aStream]
separatedBy: [aStream cr].
aStream nextPut: $)!
----- Method: WeakActionSequence>>value (in category 'evaluating') -----
value
"Answer the result of evaluating the elements of the receiver.
Actually, return just the last result."
| answer |
self do:
[:each | each isValid ifTrue: [answer := each value]].
^answer!
----- Method: WeakActionSequence>>valueWithArguments: (in category 'evaluating') -----
valueWithArguments: anArray
"Return the last result"
| answer |
self do:
[:each |
each isValid ifTrue: [answer := each valueWithArguments: anArray]].
^answer!
ByteArray variableByteSubclass: #CompiledMethod
instanceVariableNames: ''
classVariableNames: 'BlockNodeCache LargeFrame SmallFrame SpecialConstants TempNameCache'
poolDictionaries: ''
category: 'Kernel-Methods'!
!CompiledMethod commentStamp: 'ls 7/5/2003 13:48' prior: 0!
My instances are methods suitable for interpretation by the virtual machine. This is the only class in the system whose instances intermix both indexable pointer fields and indexable integer fields.
The current format of a CompiledMethod is as follows:
header (4 bytes)
literals (4 bytes each)
bytecodes (variable)
trailer (variable)
The header is a 30-bit integer with the following format:
(index 0) 9 bits: main part of primitive number (#primitive)
(index 9) 8 bits: number of literals (#numLiterals)
(index 17) 1 bit: whether a large frame size is needed (#frameSize)
(index 18) 6 bits: number of temporary variables (#numTemps)
(index 24) 4 bits: number of arguments to the method (#numArgs)
(index 28) 1 bit: high-bit of primitive number (#primitive)
(index 29) 1 bit: flag bit, ignored by the VM (#flag)
The trailer has two variant formats. In the first variant, the last byte is at least 252 and the last four bytes represent a source pointer into one of the sources files (see #sourcePointer). In the second variant, the last byte is less than 252, and the last several bytes are a compressed version of the names of the method's temporary variables. The number of bytes used for this purpose is the value of the last byte in the method.
!
----- Method: CompiledMethod class>>basicNew: (in category 'instance creation') -----
basicNew: size
self error: 'CompiledMethods may only be created with newMethod:header:' !
----- Method: CompiledMethod class>>fullFrameSize (in category 'class initialization') -----
fullFrameSize "CompiledMethod fullFrameSize"
^ LargeFrame!
----- 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.
self classPool at: #BlockNodeCache ifAbsentPut: [nil->nil].!
----- 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: 0 header: 0!
----- Method: CompiledMethod class>>new: (in category 'instance creation') -----
new: size
self error: 'CompiledMethods may only be created with newMethod:header:'!
----- 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."
| largeBit primBits method |
nTemps > 63 ifTrue:
[^ self error: 'Cannot compile -- too many temporary variables'].
nLits > 255 ifTrue:
[^ self error: 'Cannot compile -- too many literals variables'].
largeBit := (nTemps + stackSize) > SmallFrame ifTrue: [1] ifFalse: [0].
primBits := primitiveIndex <= 16r1FF
ifTrue: [primitiveIndex]
ifFalse: ["For now the high bit of primitive no. is in the 29th bit of header"
primitiveIndex > 16r3FF ifTrue: [self error: 'prim num too large'].
(primitiveIndex bitAnd: 16r1FF) + ((primitiveIndex bitAnd: 16r200) bitShift: 19)].
method := self newMethod: numberOfBytes + trailer size
header: (nArgs bitShift: 24) +
(nTemps bitShift: 18) +
(largeBit bitShift: 17) +
(nLits bitShift: 9) +
primBits.
1 to: trailer size do: "Copy the source code trailer to the end"
[:i | method at: method size - trailer size + i put: (trailer at: i)].
^ method!
----- 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."
| largeBit primBits method flagBit |
nTemps > 63 ifTrue:
[^ self error: 'Cannot compile -- too many temporary variables'].
nLits > 255 ifTrue:
[^ self error: 'Cannot compile -- too many literals variables'].
largeBit := (nTemps + stackSize) > SmallFrame ifTrue: [1] ifFalse: [0].
"For now the high bit of the primitive no. is in a high bit of the header"
primBits := (primitiveIndex bitAnd: 16r1FF) + ((primitiveIndex bitAnd: 16r200) bitShift: 19).
flagBit := flag ifTrue: [ 1 ] ifFalse: [ 0 ].
method := self newMethod: numberOfBytes + trailer size
header: (nArgs bitShift: 24) +
(nTemps bitShift: 18) +
(largeBit bitShift: 17) +
(nLits bitShift: 9) +
primBits +
(flagBit bitShift: 29).
"Copy the source code trailer to the end"
1 to: trailer size do:
[:i | method at: method size - trailer size + i put: (trailer at: i)].
^ method!
----- 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 the headerWord. The first argument specifies
the number of fields for bytecodes in the method. Fail if either
argument is not a SmallInteger, or if numberOfBytes is negative. Once
the header of a method is set by this primitive, it cannot be changed in
any way. Essential. See Object documentation whatIsAPrimitive."
<primitive: 79>
(numberOfBytes isInteger and:
[headerWord isInteger and:
[numberOfBytes >= 0]]) ifTrue: [
"args okay; space must be low"
Smalltalk signalLowSpace.
"retry if user proceeds"
^ self newMethod: numberOfBytes header: headerWord
].
^self primitiveFailed!
----- 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!
----- Method: CompiledMethod class>>smallFrameSize (in category 'class initialization') -----
smallFrameSize
^ SmallFrame!
----- 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: 0 trailerBytes: trailer nArgs: 0 nTemps: 0 nStack: 0 nLits: 2 primitive: 256 + index
!
----- 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: 0 trailerBytes: trailer nArgs: 0 nTemps: 0 nStack: 0 nLits: 2 primitive: 264 + field
!
----- 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: #(0 0 0 0)!
----- 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: 0 trailerBytes: trailer nArgs: 0 nTemps: 0 nStack: 0 nLits: 2 primitive: 256
!
----- Method: CompiledMethod>>= (in category 'comparing') -----
= method
| myLits otherLits |
"Answer whether the receiver implements the same code as the
argument, method."
(method isKindOf: CompiledMethod) ifFalse: [^false].
self size = method size ifFalse: [^false].
self header = method header ifFalse: [^false].
self initialPC to: self endPC do:
[:i | (self at: i) = (method at: i) ifFalse: [^false]].
(myLits _ self literals) = (otherLits _ method literals) ifFalse:
[myLits size = otherLits size ifFalse: [^ false].
"Dont bother checking FFI and named primitives"
(#(117 120) includes: self primitive) ifTrue: [^ true].
myLits with: otherLits do:
[:lit1 :lit2 | lit1 = lit2 ifFalse:
[(lit1 isVariableBinding)
ifTrue:
["Associations match if value is equal, since associations
used for super may have key = nil or name of class."
lit1 value == lit2 value ifFalse: [^ false]]
ifFalse:
[(lit1 isMemberOf: Float)
ifTrue:
["Floats match if values are close, due to roundoff error."
(lit1 closeTo: lit2) ifFalse: [^ false]]
ifFalse:
["any other discrepancy is a failure"
^ false]]]]].
^ true!
----- Method: CompiledMethod>>allLiterals (in category 'literals') -----
allLiterals
^self literals!
----- Method: CompiledMethod>>blockNode (in category 'decompiling') -----
blockNode
BlockNodeCache key == self ifTrue: [^ BlockNodeCache value].
^ self blockNodeIn: nil!
----- Method: CompiledMethod>>blockNodeIn: (in category 'decompiling') -----
blockNodeIn: homeMethodNode
"Return the block node for self"
homeMethodNode ifNil: [
^ self decompilerClass new decompileBlock: self].
homeMethodNode ir compiledMethod. "generate method"
homeMethodNode nodesDo: [:node |
(node isBlock and:
[node scope isInlined not and:
[node ir compiledMethod = self]])
ifTrue: [
BlockNodeCache _ self -> node.
^ node]
].
self errorNodeNotFound!
----- Method: CompiledMethod>>cacheTempNames: (in category 'source code management') -----
cacheTempNames: names
TempNameCache _ Association key: self value: names!
----- Method: CompiledMethod>>checkOKToAdd:at: (in category 'source code management') -----
checkOKToAdd: size at: filePosition
"Issue several warnings as the end of the changes file approaches its limit,
and finally halt with an error when the end is reached."
| fileSizeLimit margin |
fileSizeLimit _ 16r2000000.
3 to: 1 by: -1 do:
[:i | margin _ i*100000.
(filePosition + size + margin) > fileSizeLimit
ifTrue: [(filePosition + margin) > fileSizeLimit ifFalse:
[self inform: 'WARNING: your changes file is within
' , margin printString , ' characters of its size limit.
You should take action soon to reduce its size.
You may proceed.']]
ifFalse: [^ self]].
(filePosition + size > fileSizeLimit) ifFalse: [^ self].
self error: 'You have reached the size limit of the changes file.
You must take action now to reduce it.
Close this error. Do not attempt to proceed.'!
----- Method: CompiledMethod>>clearFlag (in category 'accessing') -----
clearFlag
"Clear the user-level flag bit"
self objectAt: 1 put: (self header bitAnd: (1 << 29) bitInvert)!
----- Method: CompiledMethod>>copyWithTempNames: (in category 'source code management') -----
copyWithTempNames: tempNames
| tempStr compressed |
tempStr _ String streamContents:
[:strm | tempNames do: [:n | strm nextPutAll: n; space]].
compressed := self qCompress: tempStr firstTry: true.
compressed ifNil:
["failure case (tempStr too big) will just decompile with tNN names"
^ self copyWithTrailerBytes: #(0 0 0 0)].
^ self copyWithTrailerBytes: compressed!
----- Method: CompiledMethod>>copyWithTrailerBytes: (in category 'initialize-release') -----
copyWithTrailerBytes: bytes
"Testing:
(CompiledMethod compiledMethodAt: #copyWithTrailerBytes:)
tempNamesPut: 'copy end '
"
| copy end start |
start _ self initialPC.
end _ self endPC.
copy _ CompiledMethod newMethod: end - start + 1 + bytes size
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)].
1 to: bytes size do: [:i | copy at: end + i put: (bytes at: i)].
^ copy!
----- 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]!
----- 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.!
----- Method: CompiledMethod>>decompileClass:selector: (in category 'decompiling') -----
decompileClass: aClass selector: selector
"Return the decompiled parse tree that represents self"
^ self decompilerClass new decompile: selector in: aClass method: self!
----- Method: CompiledMethod>>decompileString (in category 'printing') -----
decompileString
| clAndSel cl sel |
clAndSel _ self who.
clAndSel = #(unknown unknown)
ifTrue:
[cl _ Object.
sel _ #xxxUnknown.
self numArgs >= 1
ifTrue:
[sel _ sel , ':'.
2 to: self numArgs do: [:i | sel _ sel , 'with:'].
sel _ sel asSymbol]]
ifFalse:
[cl _ clAndSel first.
sel _ clAndSel last].
^ (cl decompilerClass new
decompile: sel in: cl method: self) decompileString!
----- Method: CompiledMethod>>decompilerClass (in category 'decompiling') -----
decompilerClass
^Decompiler
!
----- 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."
| aStream |
aStream _ WriteStream on: (String new: 16).
aStream nextPutAll: 'DoIt'.
1 to: self numArgs do: [:i | aStream nextPutAll: 'with:'].
^aStream contents asSymbol!
----- Method: CompiledMethod>>endPC (in category 'accessing') -----
endPC
"Answer the index of the last bytecode."
| flagByte |
flagByte _ self last.
flagByte = 0 ifTrue:
["If last byte = 0, may be either 0, 0, 0, 0 or just 0"
1 to: 4 do: [:i | (self at: self size - i) = 0 ifFalse: [^ self size - i]]].
flagByte < 252 ifTrue:
["Magic sources (tempnames encoded in last few bytes)"
^ self size - self last - 1].
"Normal 4-byte source pointer"
^ self size - 4!
----- Method: CompiledMethod>>fileIndex (in category 'source code management') -----
fileIndex
^SourceFiles fileIndexFromSourcePointer: self sourcePointer!
----- Method: CompiledMethod>>filePosition (in category 'source code management') -----
filePosition
^SourceFiles filePositionFromSourcePointer: self sourcePointer!
----- Method: CompiledMethod>>flag (in category 'accessing') -----
flag
"Answer the user-level flag bit"
^((self header bitShift: -29) bitAnd: 1) = 1!
----- 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>
!
----- 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]
!
----- Method: CompiledMethod>>getPreambleFrom:at: (in category 'source code management') -----
getPreambleFrom: aFileStream at: position
| writeStream |
writeStream _ String new writeStream.
position
to: 0
by: -1
do: [:p |
| c |
aFileStream position: p.
c _ aFileStream basicNext.
c == $!!
ifTrue: [^ writeStream contents reverse]
ifFalse: [writeStream nextPut: c]]!
----- Method: CompiledMethod>>getSourceFor:in: (in category 'source code management') -----
getSourceFor: selector in: class
"Retrieve or reconstruct the source code for this method."
| source flagByte |
flagByte _ self last.
(flagByte = 0
or: [flagByte = 251 "some source-less methods have flag = 251, rest = 0"
and: [((1 to: 3) collect: [:i | self at: self size - i]) = #(0 0 0)]])
ifTrue:
["No source pointer -- decompile without temp names"
^ (class decompilerClass new decompile: selector in: class method: self)
decompileString].
flagByte < 252 ifTrue:
["Magic sources -- decompile with temp names"
^ ((class decompilerClass new withTempNames: self tempNames)
decompile: selector in: class method: self)
decompileString].
"Situation normal; read the sourceCode from the file"
(source _ self getSourceFromFile) == nil ifFalse: [^ source].
"Something really wrong -- decompile blind (no temps)"
^ (class decompilerClass new decompile: selector in: class method: self)
decompileString!
----- Method: CompiledMethod>>getSourceFromFile (in category 'source code management') -----
getSourceFromFile
"Read the source code from file, determining source file index and
file position from the last 3 bytes of this method."
| position |
(position _ self filePosition) = 0 ifTrue: [^ nil].
^ (RemoteString newFileNumber: self fileIndex position: position)
text!
----- Method: CompiledMethod>>hasBreakpoint (in category 'debugger support') -----
hasBreakpoint
^BreakpointManager methodHasBreakpoint: self!
----- Method: CompiledMethod>>hasLiteral: (in category 'literals') -----
hasLiteral: literal
"Answer whether the receiver references the argument, literal."
2 to: self numLiterals - 1 "exclude superclass + selector/properties"
do:[:index |
literal == (self objectAt: index) ifTrue: [^true]].
^false!
----- 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!
----- 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) == literal
or: [(lit isVariableBinding and: [lit key == literal])
or: [lit isArray and: [lit hasLiteral: literal]]]) ifTrue:
[^ true]].
^ false !
----- 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!
----- 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."
| assoc |
#(doOnlyOnce: halt halt: hottest printDirectlyToDisplay toRemove personal urgent) do:
[:aLit | (self hasLiteral: aLit) ifTrue: [^ true]].
#(Transcript AA BB CC DD EE) do:
[:aSymbol | (assoc _ (Smalltalk associationAt: aSymbol ifAbsent: [nil])) ifNotNil:
[(self hasLiteral: assoc) ifTrue: [^ true]]].
^ false!
----- 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."
^self objectAt: 1!
----- 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."
| s |
s _ '' writeStream.
self header printOn: s.
s cr; nextPutAll: '"primitive: '.
self primitive printOn: s.
s cr; nextPutAll: ' numArgs: '.
self numArgs printOn: s.
s cr; nextPutAll: ' numTemps: '.
self numTemps printOn: s.
s cr; nextPutAll: ' numLiterals: '.
self numLiterals printOn: s.
s cr; nextPutAll: ' frameSize: '.
self frameSize printOn: s.
s cr; nextPutAll: ' isClosureCompiled: '.
self isClosureCompiled printOn: s.
s nextPut: $"; cr.
^ s contents!
----- Method: CompiledMethod>>holdsTempNames (in category 'source code management') -----
holdsTempNames
"Are tempNames stored in trailer bytes"
| flagByte |
flagByte _ self last.
(flagByte = 0 or: [flagByte = 251 "some source-less methods have flag = 251, rest = 0"
and: [((1 to: 3) collect: [:i | self at: self size - i]) = #(0 0 0)]])
ifTrue: [^ false]. "No source pointer & no temp names"
flagByte < 252 ifTrue: [^ true]. "temp names compressed"
^ false "Source pointer"
!
----- 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!
----- Method: CompiledMethod>>initialPC (in category 'accessing') -----
initialPC
"Answer the program counter for the receiver's first bytecode."
^ (self numLiterals + 1) * 4 + 1!
----- Method: CompiledMethod>>isClosureCompiled (in category 'testing') -----
isClosureCompiled
"Return true if this method was compiled with the new closure compiler, Parser2 (compiled while Preference compileBlocksAsClosures was true). Return false if it was compiled with the old compiler."
^ self header < 0!
----- Method: CompiledMethod>>isCompiledMethod (in category 'testing') -----
isCompiledMethod
^ true!
----- 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!
----- 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!
----- Method: CompiledMethod>>isReturnSelf (in category 'testing') -----
isReturnSelf
"Answer whether the receiver is a quick return of self."
^ self primitive = 256!
----- 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!
----- Method: CompiledMethod>>literalAt: (in category 'literals') -----
literalAt: index
"Answer the literal indexed by the argument."
^self objectAt: index + 1!
----- 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!
----- 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!
----- 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!
----- 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)]!
----- 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!
----- 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.
!
----- 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!
----- Method: CompiledMethod>>methodClass (in category 'accessing') -----
methodClass
"answer the class that I am installed in"
^(self literalAt: self numLiterals) value.!
----- 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!
----- 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!
----- Method: CompiledMethod>>methodNode (in category 'decompiling') -----
methodNode
"Return the parse tree that represents self"
| class selector |
class := self methodClass ifNil: [Object].
selector := self selector ifNil: [self defaultSelector].
^ self methodNodeDecompileClass: class selector: selector!
----- Method: CompiledMethod>>methodNodeDecompileClass:selector: (in category 'decompiling') -----
methodNodeDecompileClass: aClass selector: selector
"Return the parse tree that represents self"
| source |
^ ((source _ self getSourceFromFile) isNil or: [
(MMetaCompiler metaProductionName: source asString) notNil]) ifTrue: [
self decompileClass: aClass selector: selector
] ifFalse: [self parserClass new parse: source class: (aClass ifNil: [self sourceClass])]
!
----- Method: CompiledMethod>>methodNodeFormattedAndDecorated: (in category 'decompiling') -----
methodNodeFormattedAndDecorated: decorate
"Return the parse tree that represents self"
^ self methodNodeFormattedDecompileClass: nil selector: nil decorate: decorate!
----- Method: CompiledMethod>>methodNodeFormattedDecompileClass:selector:decorate: (in category 'decompiling') -----
methodNodeFormattedDecompileClass: aClass selector: selector decorate: decorated
"Return the parse tree that represents self, using pretty-printed source text if possible."
| source sClass node |
source := self getSourceFromFile.
sClass _ aClass ifNil: [self sourceClass].
source ifNil: [ ^self decompileClass: sClass selector: selector].
source _ sClass compilerClass new
format: source
in: sClass
notifying: nil
decorated: decorated.
node _ sClass parserClass new
parse: source
class: sClass.
node sourceText: source.
^node!
----- Method: CompiledMethod>>methodReference (in category 'accessing') -----
methodReference
| who |
who _ self who.
who = #(unknown unknown) ifTrue: [ ^nil ].
^MethodReference new setStandardClass: who first methodSymbol: who second.
!
----- 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
ifTrue: [largeFrameBit]
ifFalse: [0])!
----- Method: CompiledMethod>>numArgs (in category 'accessing') -----
numArgs
"Answer the number of arguments the receiver takes."
^ (self header bitShift: -24) bitAnd: 16r0F!
----- Method: CompiledMethod>>numLiterals (in category 'accessing') -----
numLiterals
"Answer the number of literals used by the receiver."
^ (self header bitShift: -9) bitAnd: 16rFF!
----- Method: CompiledMethod>>numTemps (in category 'accessing') -----
numTemps
"Answer the number of temporary variables used by the receiver."
^ (self header bitShift: -18) bitAnd: 16r3F!
----- 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!
----- 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!
----- Method: CompiledMethod>>objectForDataStream: (in category 'file in/out') -----
objectForDataStream: refStrm
self primitive = 117 ifTrue: [self literals first at: 4 put: 0].
!
----- Method: CompiledMethod>>parserClass (in category 'decompiling') -----
parserClass
^Parser!
----- 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]!
----- Method: CompiledMethod>>penultimateLiteral: (in category 'private') -----
penultimateLiteral: anObject
"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 put: anObject]
ifFalse: [self error: 'insufficient literals']!
----- 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]!
----- Method: CompiledMethod>>pragmas (in category 'accessing-pragmas & properties') -----
pragmas
| selectorOrProperties |
^(selectorOrProperties := self penultimateLiteral) isMethodProperties
ifTrue: [selectorOrProperties pragmas]
ifFalse: [#()]!
----- Method: CompiledMethod>>primitive (in category 'accessing') -----
primitive
"Answer the primitive index associated with the receiver.
Zero indicates that this is not a primitive method.
We currently allow 10 bits of primitive index, but they are in two places
for backward compatibility. The time to unpack is negligible,
since the reconstituted full index is stored in the method cache."
| primBits |
primBits _ self header bitAnd: 16r100001FF.
^ (primBits bitAnd: 16r1FF) + (primBits bitShift: -19)
!
----- 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!
----- Method: CompiledMethod>>primitiveNode (in category 'decompiling') -----
primitiveNode
| primNode n |
primNode _ PrimitiveNode new num: (n _ self primitive).
(n = 117 or: [n = 120]) ifTrue: [
primNode spec: (self literalAt: 1)].
^ primNode!
----- Method: CompiledMethod>>printOn: (in category 'printing') -----
printOn: aStream
"Overrides method inherited from the byte arrayed collection."
self printNameOn: aStream.
aStream space; nextPutAll: self identityHashPrintString!
----- Method: CompiledMethod>>printOnStream: (in category 'printing') -----
printOnStream: aStream
"Overrides method inherited from the byte arrayed collection."
aStream print: 'a CompiledMethod'!
----- Method: CompiledMethod>>printPrimitiveOn: (in category 'printing') -----
printPrimitiveOn: aStream
"Print the primitive on aStream"
| primIndex primDecl |
primIndex _ self primitive.
primIndex = 0 ifTrue:[^self].
primIndex = 120 "External call spec"
ifTrue:[^aStream print: (self literalAt: 1); cr].
aStream nextPutAll: '<primitive: '.
primIndex = 117 ifTrue:[
primDecl _ self literalAt: 1.
aStream
nextPut: $';
nextPutAll: (primDecl at: 2);
nextPut:$'.
(primDecl at: 1) notNil ifTrue:[
aStream
nextPutAll:' module:';
nextPut:$';
nextPutAll: (primDecl at: 1);
nextPut:$'.
].
] ifFalse:[aStream print: primIndex].
aStream nextPut: $>; cr!
----- Method: CompiledMethod>>properties (in category 'accessing') -----
properties
"Answer the method properties of the receiver."
| propertiesOrSelector |
^(propertiesOrSelector := self penultimateLiteral) isMethodProperties
ifTrue: [propertiesOrSelector]
ifFalse: [AdditionalMethodState forMethod: self selector: propertiesOrSelector]!
----- 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])!
----- 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]!
----- Method: CompiledMethod>>propertyValueAt: (in category 'accessing-pragmas & properties') -----
propertyValueAt: propName
| propertiesOrSelector |
^(propertiesOrSelector := self penultimateLiteral) isMethodProperties
ifTrue: [propertiesOrSelector propertyValueAt: propName ifAbsent: [nil]]
ifFalse: [nil]!
----- 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]!
----- 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: ((AdditionalMethodState
selector: propertiesOrSelector
with: (Association
key: propName asSymbol
value: propValue))
setMethod: self;
yourself).
^propValue].
(propertiesOrSelector includesProperty: propName) ifTrue:
[^propertiesOrSelector at: propName put: propValue].
self penultimateLiteral: (propertiesOrSelector
copyWith: (Association
key: propName asSymbol
value: propValue)).
^propValue!
----- 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]!
----- 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]!
----- 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 st80str |
methodNode ifNil: [^ self]. "If temp names are not available via methodNode, no reason to proceed."
(SourceFiles == nil or: [(file _ SourceFiles at: fileIndex) == nil or: [file isReadOnly]]) ifTrue:
[^ self become: (self copyWithTempNames: methodNode tempNames)].
SmalltalkImage current assureStartupStampLogged.
file setToEnd.
preambleBlock value: file. "Write the preamble"
(methodNode isKindOf: DialectMethodNode)
ifTrue:
["This source was parsed from an alternate syntax.
We must convert to ST80 before logging it."
st80str _ (DialectStream dialect: #ST80 contents: [:strm | methodNode printOn: strm])
asString.
remoteString _ RemoteString newString: st80str
onFileNumber: fileIndex toFile: file]
ifFalse:
[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!
----- Method: CompiledMethod>>qCompress:firstTry: (in category 'source code management') -----
qCompress: string firstTry: firstTry
"A very simple text compression routine designed for method temp names.
Most common 12 chars get values 0-11 packed in one 4-bit nibble;
others get values 12-15 (2 bits) * 16 plus next nibble.
Last char of str must be a space so it may be dropped without
consequence if output ends on odd nibble.
Normal call is with firstTry == true."
| charTable odd ix oddNibble names shorterStr maybe str temps |
str _ string isOctetString
ifTrue: [string]
ifFalse: [temps _ string findTokens: ' '.
String
streamContents: [:stream | 1
to: temps size
do: [:index |
stream nextPut: $t.
stream nextPutAll: index asString.
stream space]]].
charTable _ "Character encoding table must match qDecompress:"
' eatrnoislcm bdfghjkpquvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789'.
^ ByteArray streamContents:
[:strm | odd _ true. "Flag for odd or even nibble out"
oddNibble _ nil.
str do:
[:char | ix _ (charTable indexOf: char) - 1.
(ix <= 12 ifTrue: [Array with: ix]
ifFalse: [Array with: ix//16+12 with: ix\\16])
do:
[:nibble | (odd _ odd not)
ifTrue: [strm nextPut: oddNibble*16 + nibble]
ifFalse: [oddNibble _ nibble]]].
strm position > 251 ifTrue:
["Only values 1...251 are available for the flag byte
that signals compressed temps. See the logic in endPC."
"Before giving up completely, we attempt to encode most of
the temps, but with the last few shortened to tNN-style names."
firstTry ifFalse: [^ nil "already tried --give up now"].
names _ str findTokens: ' '.
names size < 8 ifTrue: [^ nil "weird case -- give up now"].
4 to: names size//2 by: 4 do:
[:i | shorterStr _ String streamContents:
[:s |
1 to: names size - i do: [:j | s nextPutAll: (names at: j); space].
1 to: i do: [:j | s nextPutAll: 't' , j printString; space]].
(maybe _ self qCompress: shorterStr firstTry: false) ifNotNil: [^ maybe]].
^ nil].
strm nextPut: strm position]
"
| m s | m _ CompiledMethod new.
s _ 'charTable odd ix oddNibble '.
^ Array with: s size with: (m qCompress: s) size
with: (m qDecompress: (m qCompress: s))
"
!
----- Method: CompiledMethod>>qDecompress: (in category 'source code management') -----
qDecompress: byteArray
"Decompress strings compressed by qCompress:.
Most common 12 chars get values 0-11 packed in one 4-bit nibble;
others get values 12-15 (2 bits) * 16 plus next nibble"
| charTable extended ext |
charTable _ "Character encoding table must match qCompress:"
' eatrnoislcm bdfghjkpquvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789'.
^ String streamContents:
[:strm | extended _ false. "Flag for 2-nibble characters"
byteArray do:
[:byte |
(Array with: byte//16 with: byte\\16)
do:
[:nibble | extended
ifTrue: [strm nextPut: (charTable at: ext*16+nibble + 1). extended _ false]
ifFalse: [nibble < 12 ifTrue: [strm nextPut: (charTable at: nibble + 1)]
ifFalse: [ext _ nibble-12. extended _ true]]]]]!
----- 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'.!
----- Method: CompiledMethod>>readsField: (in category 'scanning') -----
readsField: varIndex
"Answer whether the receiver loads the instance variable indexed by the
argument."
self isReturnField ifTrue: [^self returnField + 1 = varIndex].
varIndex <= 16 ifTrue: [^ self scanFor: varIndex - 1].
varIndex <= 64 ifTrue: [^ self scanLongLoad: varIndex - 1].
^ self scanVeryLongLoad: 64 offset: varIndex - 1!
----- Method: CompiledMethod>>readsRef: (in category 'scanning') -----
readsRef: literalAssociation
"Answer whether the receiver loads the argument."
| lit |
lit _ self literals indexOf: literalAssociation ifAbsent: [^false].
lit <= 32 ifTrue: [^self scanFor: 64 + lit - 1].
lit <= 64 ifTrue: [^self scanLongLoad: 192 + lit - 1].
^ self scanVeryLongLoad: 128 offset: lit - 1!
----- 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 |
value := self propertyValueAt: propName ifAbsent: [^nil].
self penultimateLiteral: (self penultimateLiteral copyWithout:
(Association
key: propName
value: value)).
^value!
----- 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 |
value := self propertyValueAt: propName ifAbsent: [^aBlock value].
self penultimateLiteral: (self penultimateLiteral copyWithout:
(Association
key: propName
value: value)).
^value!
----- 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]!
----- Method: CompiledMethod>>scanFor: (in category 'scanning') -----
scanFor: byte
"Answer whether the receiver contains the argument as a bytecode."
^ (InstructionStream on: self) scanFor: [:instr | instr = byte]
"
Smalltalk browseAllSelect: [:m | m scanFor: 134]
"!
----- Method: CompiledMethod>>scanLongLoad: (in category 'scanning') -----
scanLongLoad: extension
"Answer whether the receiver contains a long load whose extension is the
argument."
| scanner |
scanner _ InstructionStream on: self.
^scanner scanFor: [:instr | instr = 128 and: [scanner followingByte = extension]]!
----- Method: CompiledMethod>>scanLongStore: (in category 'scanning') -----
scanLongStore: extension
"Answer whether the receiver contains a long store whose extension is
the argument."
| scanner |
scanner _ InstructionStream on: self.
^scanner scanFor:
[:instr | (instr = 129 or: [instr = 130]) and: [scanner followingByte = extension]]!
----- Method: CompiledMethod>>scanVeryLongLoad:offset: (in category 'scanning') -----
scanVeryLongLoad: extension offset: offset
"Answer whether the receiver contains a long load whose extension is the
argument."
| scanner |
scanner _ InstructionStream on: self.
^ scanner scanFor: [:instr | (instr = 132 and: [scanner followingByte = extension])
and: [scanner thirdByte = offset]]!
----- Method: CompiledMethod>>scanVeryLongStore:offset: (in category 'scanning') -----
scanVeryLongStore: extension offset: offset
"Answer whether the receiver contains a long load with the given offset.
Note that the constant +32 is the known difference between a
store and a storePop for instVars, and it will always fail on literal variables,
but these only use store (followed by pop) anyway."
| scanner ext |
scanner _ InstructionStream on: self.
^ scanner scanFor:
[:instr | (instr = 132 and: [(ext _ scanner followingByte) = extension
or: ["might be a store/pop into rcvr"
ext = (extension+32)]])
and: [scanner thirdByte = offset]]!
----- 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]!
----- 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]!
----- Method: CompiledMethod>>sendsToSuper (in category 'scanning') -----
sendsToSuper
"Answer whether the receiver sends any message to super."
| scanner |
scanner _ InstructionStream on: self.
^ scanner scanFor:
[:instr | instr = 16r85 or: [instr = 16r84
and: [scanner followingByte between: 16r20 and: 16r3F]]]!
----- Method: CompiledMethod>>setSourcePointer: (in category 'source code management') -----
setSourcePointer: srcPointer
srcPointer = 0 ifTrue: [
self at: self size put: 0.
^self].
(srcPointer between: 16r1000000 and: 16r4FFFFFF) ifFalse: [self error: 'Source pointer out of range'].
self at: self size put: (srcPointer bitShift: -24) + 251.
1 to: 3 do: [:i |
self at: self size-i put: ((srcPointer bitShift: (i-3)*8) bitAnd: 16rFF)]!
----- Method: CompiledMethod>>setSourcePosition:inFile: (in category 'source code management') -----
setSourcePosition: position inFile: fileIndex
self setSourcePointer: (SourceFiles sourcePointerFromFileIndex: fileIndex andPosition: position)!
----- Method: CompiledMethod>>setTempNamesIfCached: (in category 'source code management') -----
setTempNamesIfCached: aBlock
"This is a cache used by the debugger, independent of the storage of
temp names when the system is converted to decompilation with temps."
TempNameCache == nil ifTrue: [^self].
TempNameCache key == self
ifTrue: [aBlock value: TempNameCache value]!
----- 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]!
----- 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!
----- 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 returned value is either 0 (if no source is stored) or a number between 16r1000000 and 16r4FFFFFF.
The actual interpretation of this number is up to the SourceFileArray stored in the global variable SourceFiles."
| pos |
self last < 252 ifTrue: [^ 0 "no source"].
pos _ self last - 251.
self size - 1 to: self size - 3 by: -1 do: [:i | pos _ pos * 256 + (self at: i)].
^pos!
----- 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].
^ Compiler parserClass new parseSelector: sourceString!
----- 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"!
----- 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]!
----- 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: $)!
----- 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!
----- Method: CompiledMethod>>tempNames (in category 'source code management') -----
tempNames
| byteCount bytes |
self holdsTempNames ifFalse: [
^ (1 to: self numTemps) collect: [:i | 't', i printString]
].
byteCount _ self at: self size.
byteCount = 0 ifTrue: [^ Array new].
bytes _ (ByteArray new: byteCount)
replaceFrom: 1 to: byteCount with: self
startingAt: self size - byteCount.
^ (self qDecompress: bytes) findTokens: ' '!
----- 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"
| file preamble stamp tokens tokenCount |
self fileIndex == 0 ifTrue: [^ String new]. "no source pointer for this method"
file _ SourceFiles at: self fileIndex.
file ifNil: [^ String new]. "sources file not available"
"file does not exist happens in secure mode"
file _ [file readOnlyCopy] on: FileDoesNotExistException do:[:ex| nil].
file ifNil: [^ String new].
preamble _ self getPreambleFrom: file at: (0 max: self filePosition - 3).
stamp _ String new.
tokens _ (preamble findString: 'methodsFor:' startingAt: 1) > 0
ifTrue: [Scanner new scanTokens: preamble]
ifFalse: [Array new "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]].
file close.
^ stamp
!
----- Method: CompiledMethod>>trailer (in category 'accessing') -----
trailer
| end trailer |
end _ self endPC.
trailer _ ByteArray new: self size - end.
end + 1 to: self size do: [:i |
trailer at: i - end put: (self at: i)].
^ trailer!
----- Method: CompiledMethod>>valueWithReceiver:arguments: (in category 'evaluating') -----
valueWithReceiver: aReceiver arguments: anArray
^ aReceiver withArgs: anArray executeMethod: self!
----- 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."!
----- Method: CompiledMethod>>who (in category 'printing') -----
who
"Answer an Array of the class in which the receiver is defined and the
selector to which it corresponds."
self hasNewPropertyFormat ifTrue:[^{self methodClass. self selector}].
self systemNavigation allBehaviorsDo:
[:class |
(class methodDict keyAtIdentityValue: self ifAbsent: [nil]) ifNotNilDo:
[:sel| ^Array with: class with: sel]].
^Array with: #unknown with: #unknown!
----- Method: CompiledMethod>>writesField: (in category 'scanning') -----
writesField: field
"Answer whether the receiver stores into the instance variable indexed
by the argument."
self isQuick ifTrue: [^ false].
field <= 8 ifTrue:
[^ (self scanFor: 96 + field - 1) or: [self scanLongStore: field - 1]].
field <= 64 ifTrue:
[^ self scanLongStore: field - 1].
^ self scanVeryLongStore: 160 offset: field - 1!
----- Method: CompiledMethod>>writesRef: (in category 'scanning') -----
writesRef: ref
"Answer whether the receiver stores the argument."
| lit |
lit _ self literals indexOf: ref ifAbsent: [^false].
lit <= 64 ifTrue: [^ self scanLongStore: 192 + lit - 1].
^ self scanVeryLongStore: 224 offset: lit - 1!
----- Method: CompiledMethod>>zapSourcePointer (in category 'file in/out') -----
zapSourcePointer
"clobber the source pointer since it will be wrong"
0 to: 3 do: [ :i | self at: self size - i put: 0].
!
ArrayedCollection variableSubclass: #TranslatedMethod
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Kernel-Methods'!
----- Method: TranslatedMethod class>>initialize (in category 'class initialization') -----
initialize
self becomeCompact.
Smalltalk recreateSpecialObjectsArray.
Smalltalk specialObjectsArray size = 41
ifFalse: [self error: 'Please check size of special objects array!!']!
nil 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.
!
----- Method: ObjectTracer class>>on: (in category 'instance creation') -----
on: anObject
^ self new xxxViewedObject: anObject!
----- 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."
Debugger openContext: thisContext
label: 'About to perform: ', aMessage selector
contents: nil.
^ aMessage sentTo: tracedObject.
!
----- Method: ObjectTracer>>xxxUnTrace (in category 'very few messages') -----
xxxUnTrace
tracedObject become: self!
----- Method: ObjectTracer>>xxxViewedObject (in category 'very few messages') -----
xxxViewedObject
"This message name must not clash with any other (natch)."
^ tracedObject!
----- Method: ObjectTracer>>xxxViewedObject: (in category 'very few messages') -----
xxxViewedObject: anObject
"This message name must not clash with any other (natch)."
tracedObject _ anObject!
ObjectTracer subclass: #ObjectViewer
instanceVariableNames: 'valueBlock lastValue changeBlock'
classVariableNames: ''
poolDictionaries: ''
category: 'Kernel-Objects'!
!ObjectViewer commentStamp: '<historical>' 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 InputSensor 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
!
----- Method: ObjectViewer class>>on:evaluate:wheneverChangeIn: (in category 'instance creation') -----
on: viewedObject evaluate: block1 wheneverChangeIn: block2
^ self new xxxViewedObject: viewedObject evaluate: block1 wheneverChangeIn: block2!
----- Method: ObjectViewer>>doesNotUnderstand: (in category 'very few messages') -----
doesNotUnderstand: aMessage
"Check for change after sending aMessage"
| returnValue newValue |
recursionFlag ifTrue: [^ aMessage sentTo: tracedObject].
recursionFlag _ true.
returnValue _ aMessage sentTo: tracedObject.
newValue _ valueBlock value.
newValue = lastValue ifFalse:
[changeBlock value.
lastValue _ newValue].
recursionFlag _ false.
^ returnValue!
----- 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!
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.!
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.
!
----- Method: MessageCatcher>>doesNotUnderstand: (in category 'as yet unclassified') -----
doesNotUnderstand: aMessage
accumulator ifNotNil: [accumulator add: aMessage].
^ aMessage!
----- Method: MessageCatcher>>privAccumulator (in category 'as yet unclassified') -----
privAccumulator
^ accumulator!
----- Method: MessageCatcher>>privAccumulator: (in category 'as yet unclassified') -----
privAccumulator: collection
accumulator _ collection!
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.!
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.!
----- Method: AdditionalMethodState class>>forMethod:selector: (in category 'instance creation') -----
forMethod: aMethod selector: aSelector
^(self basicNew: 0)
selector: aSelector;
setMethod: aMethod;
yourself!
----- Method: AdditionalMethodState class>>selector:with: (in category 'instance creation') -----
selector: aSelector with: aPropertyOrPragma
^(self basicNew: 1)
selector: aSelector;
basicAt: 1 put: aPropertyOrPragma;
yourself!
----- Method: AdditionalMethodState>>analogousCodeTo: (in category 'testing') -----
analogousCodeTo: aMethodProperties
| bs |
(bs := self basicSize) ~= aMethodProperties basicSize ifTrue:
[^false].
1 to: bs do:
[:i|
((self basicAt: i) analogousCodeTo: (aMethodProperties basicAt: i)) ifFalse:
[^false]].
^true!
----- 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']!
----- 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!
----- 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!
----- Method: AdditionalMethodState>>at:put: (in category 'accessing') -----
at: aKey put: aValue
"Replace the property value or pragma associated with aKey."
1 to: self basicSize do:
[:i |
| propertyOrPragma "<Association|Pragma>" |
(propertyOrPragma := self basicAt: i) key == aKey ifTrue:
[propertyOrPragma isVariableBinding
ifTrue: [propertyOrPragma value: aValue]
ifFalse: [self basicAt: i put: aValue]]].
^method propertyValueAt: aKey put: aValue!
----- 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.'].
copy := self class new: (bs := self basicSize) + 1.
1 to: bs do:
[:i|
copy basicAt: i put: (self basicAt: i)].
copy basicAt: bs + 1 put: aPropertyOrPragma.
^copy
selector: selector;
setMethod: method;
yourself
!
----- Method: AdditionalMethodState>>copyWithout: (in category 'copying') -----
copyWithout: aPropertyOrPragma "<Association|Pragma>"
"Answer a copy of the receiver which no longer includes aPropertyOrPragma"
| bs copy offset |
copy := self class new: (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)]].
^copy
selector: selector;
setMethod: method;
yourself
!
----- 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!
----- 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!
----- 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!
----- 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!
----- 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!
----- Method: AdditionalMethodState>>isEmpty (in category 'testing') -----
isEmpty
^self basicSize = 0!
----- Method: AdditionalMethodState>>isMethodProperties (in category 'testing') -----
isMethodProperties
^true!
----- 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]]!
----- Method: AdditionalMethodState>>method: (in category 'decompiling') -----
method: aMethodNodeOrNil
"For decompilation"
method := aMethodNodeOrNil!
----- Method: AdditionalMethodState>>notEmpty (in category 'testing') -----
notEmpty
^self basicSize > 0!
----- 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!
----- 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!
----- 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]]!
----- Method: AdditionalMethodState>>propertyValueAt: (in category 'properties') -----
propertyValueAt: aKey
"Answer the property value associated with aKey."
^ self propertyValueAt: aKey ifAbsent: [ self error: 'Property not found' ].!
----- 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!
----- 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' ].!
----- 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!
----- Method: AdditionalMethodState>>selector (in category 'accessing') -----
selector
^selector!
----- Method: AdditionalMethodState>>selector: (in category 'accessing') -----
selector: aSymbol
selector := aSymbol!
----- 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]]!
Object subclass: #Behavior
instanceVariableNames: 'superclass methodDict format'
classVariableNames: 'ObsoleteSubclasses'
poolDictionaries: ''
category: 'Kernel-Classes'!
!Behavior commentStamp: '<historical>' 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).!
----- 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!
----- Method: Behavior class>>flushObsoleteSubclasses (in category 'class initialization') -----
flushObsoleteSubclasses
"Behavior flushObsoleteSubclasses"
ObsoleteSubclasses finalizeValues.!
----- 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]!
----- Method: Behavior class>>initializeObsoleteSubclasses (in category 'class initialization') -----
initializeObsoleteSubclasses
ObsoleteSubclasses _ WeakKeyToCollectionDictionary new.!
----- Method: Behavior class>>new (in category 'instance creation') -----
new
| classInstance |
classInstance := self basicNew.
classInstance methodDictionary: classInstance emptyMethodDictionary.
classInstance superclass: Object.
classInstance setFormat: Object format.
^ classInstance!
----- 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
!
----- 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.
!
----- Method: Behavior>>addSelector:withMethod: (in category 'adding/removing methods') -----
addSelector: selector withMethod: compiledMethod
^ self addSelector: selector withMethod: compiledMethod notifying: nil!
----- Method: Behavior>>addSelector:withMethod:notifying: (in category 'adding/removing methods') -----
addSelector: selector withMethod: compiledMethod notifying: requestor
^ self addSelectorSilently: selector withMethod: compiledMethod!
----- Method: Behavior>>addSelectorSilently:withMethod: (in category 'adding/removing methods') -----
addSelectorSilently: 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.
"Now flush Squeak's method cache, either by selector or by method"
oldMethodOrNil == nil ifFalse: [oldMethodOrNil flushCache].
selector flushCache.!
----- 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!
----- 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!
----- Method: Behavior>>allInstances (in category 'accessing instances and variables') -----
allInstances
"Answer a collection of all current instances of the receiver."
| all |
all _ OrderedCollection new.
self allInstancesDo: [:x | x == all ifFalse: [all add: x]].
^ all asArray
!
----- Method: Behavior>>allInstancesDo: (in category 'enumerating') -----
allInstancesDo: aBlock
"Evaluate the argument, aBlock, for each of the current instances of the
receiver.
Because aBlock might change the class of inst (for example, using become:),
it is essential to compute next before aBlock value: inst."
| inst next |
self == UndefinedObject ifTrue: [^ aBlock value: nil].
inst _ self someInstance.
[inst == nil]
whileFalse:
[
next _ inst nextInstance.
aBlock value: inst.
inst _ next]!
----- 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].
!
----- Method: Behavior>>allLocalCallsOn: (in category 'user interface') -----
allLocalCallsOn: aSymbol
"Answer a SortedCollection of all the methods that call on aSymbol, anywhere in my class hierarchy."
| aSet special byte cls |
aSet _ Set new.
cls _ self theNonMetaClass.
special _ self environment hasSpecialSelector: aSymbol
ifTrueSetByte: [:b | byte _ b ].
cls withAllSuperAndSubclassesDoGently: [ :class |
(class whichSelectorsReferTo: aSymbol special: special byte: byte)
do: [:sel |
sel ~~ #DoIt ifTrue: [aSet add: class name , ' ', sel]]].
cls class withAllSuperAndSubclassesDoGently: [ :class |
(class whichSelectorsReferTo: aSymbol special: special byte: byte)
do: [:sel |
sel ~~ #DoIt ifTrue: [aSet add: class name , ' ', sel]]].
^aSet!
----- Method: Behavior>>allSelectors (in category 'accessing method dictionary') -----
allSelectors
"Answer all selectors understood by instances of the receiver"
| coll |
coll _ OrderedCollection new.
self withAllSuperclasses do:
[:aClass | coll addAll: aClass selectors].
^ coll asIdentitySet!
----- Method: Behavior>>allSelectorsUnderstood (in category 'deprecated') -----
allSelectorsUnderstood
"Answer a list of all selectors understood by instances of the receiver"
| aList |
self deprecated: 'Use allSelectors instead.'.
aList _ OrderedCollection new.
self withAllSuperclasses do:
[:aClass | aList addAll: aClass selectors].
^ aList asSet asArray
"SketchMorph allSelectorsUnderstood size"!
----- 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!
----- 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!
----- 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]!
----- Method: Behavior>>allSubclasses (in category 'accessing class hierarchy') -----
allSubclasses
"Answer a Set 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 asSet!
----- 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]!
----- 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]]!
----- Method: Behavior>>allSubclassesWithLevelDo:startingLevel: (in category 'accessing class hierarchy') -----
allSubclassesWithLevelDo: classAndLevelBlock startingLevel: level
"Walk the tree of subclasses, giving the class and its level"
| subclassNames |
classAndLevelBlock value: self value: level.
self == Class ifTrue: [^ self]. "Don't visit all the metaclasses"
"Visit subclasses in alphabetical order"
subclassNames _ SortedCollection new.
self subclassesDo: [:subC | subclassNames add: subC name].
subclassNames do:
[:name | (self environment at: name)
allSubclassesWithLevelDo: classAndLevelBlock
startingLevel: level+1]!
----- 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]!
----- 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]!
----- 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"
| any definingClass |
^ self allInstVarNames copy reject:
[:ivn | any _ false.
definingClass _ self classThatDefinesInstanceVariable: ivn.
definingClass withAllSubclasses do:
[:class | any ifFalse:
[(class whichSelectorsAccess: ivn asSymbol) do:
[:sel | sel ~~ #DoIt ifTrue: [any _ true]]]].
any]!
----- 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!
----- Method: Behavior>>basicCompile:notifying:trailer:ifFail: (in category 'private') -----
basicCompile: code notifying: requestor trailer: bytes ifFail: failBlock
"Compile code without logging the source in the changes file"
| methodNode |
methodNode _ self compilerClass new
compile: code
in: self
notifying: requestor
ifFail: failBlock.
methodNode encoder requestor: requestor.
^ CompiledMethodWithNode generateMethodFromNode: methodNode trailer: bytes.!
----- Method: Behavior>>basicCompile:notifying:trailer:ifFail:for: (in category 'private') -----
basicCompile: code notifying: requestor trailer: bytes ifFail: failBlock for: anInstance
"Compile code without logging the source in the changes file"
| methodNode |
methodNode _ self compilerClass new
compile: code
in: self
notifying: requestor
ifFail: failBlock for: anInstance.
methodNode encoder requestor: requestor.
^ CompiledMethodWithNode generateMethodFromNode: methodNode trailer: bytes.!
----- 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."
<primitive: 70>
self isVariable ifTrue: [ ^ self basicNew: 0 ].
"space must be low"
self environment signalLowSpace.
^ self basicNew "retry if user proceeds"
!
----- 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."
<primitive: 71>
self isVariable ifFalse:
[self error: self printString, ' cannot have variable sized instances'].
(sizeRequested isInteger and: [sizeRequested >= 0]) ifTrue:
["arg okay; space must be low."
self environment signalLowSpace.
^ self basicNew: sizeRequested "retry if user proceeds"].
self primitiveFailed!
----- 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."
| oldMethod |
oldMethod _ self methodDict at: selector ifAbsent: [^ self].
self methodDict removeKey: selector.
"Now flush Squeak's method cache, either by selector or by method"
oldMethod flushCache.
selector flushCache.!
----- Method: Behavior>>becomeCompact (in category 'private') -----
becomeCompact
"Here are the restrictions on compact classes in order for export segments to work: A compact class index may not be reused. If a class was compact in a release of Squeak, no other class may use that index. The class might not be compact later, and there should be nil in its place in the array."
| cct index |
self isWeak ifTrue:[^ self halt: 'You must not make a weak class compact'].
cct _ self environment compactClassesArray.
(self indexIfCompact > 0 or: [cct includes: self])
ifTrue: [^ self halt: self name , 'is already compact'].
index _ cct indexOf: nil
ifAbsent: [^ self halt: 'compact class table is full'].
"Install this class in the compact class table"
cct at: index put: self.
"Update instspec so future instances will be compact"
format _ format + (index bitShift: 11).
"Make up new instances and become old ones into them"
self updateInstancesFrom: self.
"Purge any old instances"
Smalltalk garbageCollect.!
----- Method: Behavior>>becomeCompactSimplyAt: (in category 'private') -----
becomeCompactSimplyAt: index
"Make me compact, but don't update the instances. For importing segments."
"Here are the restrictions on compact classes in order for export segments to work: A compact class index may not be reused. If a class was compact in a release of Squeak, no other class may use that index. The class might not be compact later, and there should be nil in its place in the array."
| cct |
self isWeak ifTrue:[^ self halt: 'You must not make a weak class compact'].
cct _ self environment compactClassesArray.
(self indexIfCompact > 0 or: [cct includes: self])
ifTrue: [^ self halt: self name , 'is already compact'].
(cct at: index) ifNotNil: [^ self halt: 'compact table slot already in use'].
"Install this class in the compact class table"
cct at: index put: self.
"Update instspec so future instances will be compact"
format _ format + (index bitShift: 11).
"Caller must convert the instances"
!
----- Method: Behavior>>becomeUncompact (in category 'private') -----
becomeUncompact
| cct index |
cct _ self environment compactClassesArray.
(index _ self indexIfCompact) = 0
ifTrue: [^ self].
(cct includes: self)
ifFalse: [^ self halt "inconsistent state"].
"Update instspec so future instances will not be compact"
format _ format - (index bitShift: 11).
"Make up new instances and become old ones into them"
self updateInstancesFrom: self.
"Make sure there are no compact ones left around"
Smalltalk garbageCollect.
"Remove this class from the compact class table"
cct at: index put: nil.
!
----- 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!
----- 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!
----- Method: Behavior>>canZapMethodDictionary (in category 'testing') -----
canZapMethodDictionary
"Return true if it is safe to zap the method dictionary on #obsolete"
^true!
----- Method: Behavior>>changeRecordsAt: (in category 'accessing method dictionary') -----
changeRecordsAt: selector
"Return a list of ChangeRecords for all versions of the method at selector. Source code can be retrieved by sending string to any one. Return nil if the method is absent."
"(Pen changeRecordsAt: #go:) collect: [:cRec | cRec string]"
| aList |
aList _ VersionsBrowser new
scanVersionsOf: (self compiledMethodAt: selector ifAbsent: [^ nil])
class: self meta: self isMeta
category: (self whichCategoryIncludesSelector: selector)
selector: selector.
^ aList ifNotNil: [aList changeList]!
----- 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!
----- Method: Behavior>>classDepth (in category 'accessing') -----
classDepth
superclass ifNil: [^ 1].
^ superclass classDepth + 1!
----- Method: Behavior>>classVarNames (in category 'accessing instances and variables') -----
classVarNames
"Answer a Set of the receiver's class variable names."
^Set new!
----- 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!
----- Method: Behavior>>compile:classified:notifying:trailer:ifFail: (in category 'compiling') -----
compile: code classified: category notifying: requestor trailer: bytes ifFail: failBlock
"Compile code without logging the source in the changes file"
| methodNode |
methodNode := self compilerClass new
compile: code
in: self
"classified: category" "not in Etoys image yet"
notifying: requestor
ifFail: failBlock.
^ CompiledMethodWithNode generateMethodFromNode: methodNode trailer: bytes.!
----- 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
basicCompile: code "a Text"
notifying: requestor
trailer: self defaultMethodTrailer
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!
----- Method: Behavior>>compileAll (in category 'compiling') -----
compileAll
^ self compileAllFrom: self!
----- 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].
self environment currentProjectDo: [:proj | proj compileAllIsolated: self from: oldClass].!
----- 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!
----- 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 value]!
----- Method: Behavior>>compilerClass (in category 'compiling') -----
compilerClass
"Answer a compiler class appropriate for source methods of this class."
^Compiler!
----- Method: Behavior>>compress (in category 'accessing method dictionary') -----
compress
"Compact the method dictionary of the receiver."
self methodDict rehash!
----- 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 compilerClass new 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])!
----- Method: Behavior>>copy (in category 'copying') -----
copy
"Answer a copy of the receiver without a list of subclasses."
| myCopy |
myCopy _ self shallowCopy.
^myCopy methodDictionary: self methodDict copy!
----- Method: Behavior>>copyOfMethodDictionary (in category 'copying') -----
copyOfMethodDictionary
"Return a copy of the receiver's method dictionary"
^ self methodDict copy!
----- 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 asSortedCollection asArray collect: [:x | Array
with: (String with: Character cr), x
with: (self whichSelectorsReferTo: x)]
"Point crossReference."!
----- 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!
----- Method: Behavior>>decompilerClass (in category 'compiling') -----
decompilerClass
"Answer a decompiler class appropriate for compiled methods of this class."
^Decompiler!
----- Method: Behavior>>deepCopy (in category 'copying') -----
deepCopy
"Classes should only be shallowCopied or made anew."
^ self shallowCopy!
----- Method: Behavior>>defaultMethodTrailer (in category 'compiling') -----
defaultMethodTrailer
^ #(0 0 0 0)!
----- 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!
----- Method: Behavior>>emptyMethodDictionary (in category 'initialize-release') -----
emptyMethodDictionary
^ MethodDictionary new!
----- Method: Behavior>>environment (in category 'accessing') -----
environment
"Return the environment in which the receiver is visible"
^Smalltalk!
----- Method: Behavior>>evaluatorClass (in category 'compiling') -----
evaluatorClass
"Answer an evaluator class appropriate for evaluating expressions in the
context of this class."
^Compiler!
----- 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."
| sourceString commentStart pos nextQuotePos |
sourceString _ (self sourceCodeAt: selector) asString.
sourceString size == 0 ifTrue: [^ ''].
commentStart _ sourceString findString: '"' startingAt: 1.
commentStart == 0 ifTrue: [^ ''].
pos _ commentStart + 1.
[(nextQuotePos _ sourceString findString: '"' startingAt: pos) == (sourceString findString: '""' startingAt: pos)]
whileTrue:
[pos _ nextQuotePos + 2].
commentStart == nextQuotePos ifTrue: [^ '']. "Must have been a quote in string literal"
^ (sourceString copyFrom: commentStart + 1 to: nextQuotePos - 1) copyReplaceAll: '""' with: '"'
"Behavior firstCommentAt: #firstCommentAt:"!
----- 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:"
(MessageSet isPseudoSelector: selector)
ifTrue:
["Not really a selector"
^ nil].
source _ self sourceCodeAt: selector asSymbol ifAbsent: [^ nil].
parser _ self parserClass new.
tree _
parser
parse: (ReadStream on: source)
class: self
noPattern: false
context: nil
notifying: nil
ifFail: [^ nil].
^ (tree comment ifNil: [^ nil]) first!
----- 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!
----- Method: Behavior>>forgetDoIts (in category 'initialize-release') -----
forgetDoIts
"get rid of old DoIt methods"
self
basicRemoveSelector: #DoIt;
basicRemoveSelector: #DoItIn:!
----- 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:
"
!
----- Method: Behavior>>formalParametersAt: (in category 'accessing method dictionary') -----
formalParametersAt: aSelector
"Return the names of the arguments used in this method."
| source parser message list params |
source _ self sourceCodeAt: aSelector ifAbsent: [^ #()]. "for now"
(parser _ self parserClass new) parseSelector: source.
message _ source copyFrom: 1 to: (parser endOfLastToken min: source size).
list _ message string findTokens: Character separators.
params _ OrderedCollection new.
list withIndexDo: [:token :ind | ind even ifTrue: [params addLast: token]].
^ params!
----- Method: Behavior>>format (in category 'accessing') -----
format
"Answer an Integer that encodes the kinds and numbers of variables of
instances of the receiver."
^format!
----- 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!
----- Method: Behavior>>hasMethods (in category 'testing method dictionary') -----
hasMethods
"Answer whether the receiver has any methods in its method dictionary."
^ self methodDict size > 0!
----- Method: Behavior>>includesBehavior: (in category 'testing class hierarchy') -----
includesBehavior: aClass
^self == aClass or:[self inheritsFrom: aClass]!
----- Method: Behavior>>includesLocalSelector: (in category 'testing method dictionary') -----
includesLocalSelector: aSymbol
^self includesSelector: aSymbol!
----- 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!
----- Method: Behavior>>indexIfCompact (in category 'private') -----
indexIfCompact
"If these 5 bits are non-zero, then instances of this class
will be compact. It is crucial that there be an entry in
Smalltalk compactClassesArray for any class so optimized.
See the msgs becomeCompact and becomeUncompact."
^ (format bitShift: -11) bitAnd: 16r1F
"
Smalltalk compactClassesArray doWithIndex:
[:c :i | c == nil ifFalse:
[c indexIfCompact = i ifFalse: [self halt]]]
"!
----- 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!
----- 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!
----- Method: Behavior>>inspectAllInstances (in category 'accessing instances and variables') -----
inspectAllInstances
"Inpsect all instances of the receiver. 1/26/96 sw"
| all allSize prefix |
all _ self allInstances.
(allSize _ all size) == 0 ifTrue: [^ self inform: 'There are no
instances of ', self name].
prefix _ allSize == 1
ifTrue: ['The lone instance']
ifFalse: ['The ', allSize printString, ' instances'].
all asArray inspectWithLabel: (prefix, ' of ', self name)!
----- Method: Behavior>>inspectSubInstances (in category 'accessing instances and variables') -----
inspectSubInstances
"Inspect all instances of the receiver and all its subclasses. CAUTION - don't do this for something as generic as Object!! 1/26/96 sw"
| all allSize prefix |
all _ self allSubInstances.
(allSize _ all size) == 0 ifTrue: [^ self inform: 'There are no
instances of ', self name, '
or any of its subclasses'].
prefix _ allSize == 1
ifTrue: ['The lone instance']
ifFalse: ['The ', allSize printString, ' instances'].
all asArray inspectWithLabel: (prefix, ' of ', self name, ' & its subclasses')!
----- Method: Behavior>>instSize (in category 'testing') -----
instSize
"Answer the number of named instance variables
(as opposed to indexed variables) of the receiver."
self flag: #instSizeChange. "Smalltalk browseAllCallsOn: #instSizeChange"
"
NOTE: This code supports the backward-compatible extension to 8 bits of instSize.
When we revise the image format, it should become...
^ ((format bitShift: -1) bitAnd: 16rFF) - 1
Note also that every other method in this category will require
2 bits more of right shift after the change.
"
^ ((format bitShift: -10) bitAnd: 16rC0) + ((format bitShift: -1) bitAnd: 16r3F) - 1!
----- Method: Behavior>>instSpec (in category 'testing') -----
instSpec
^ (format bitShift: -7) bitAnd: 16rF!
----- 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]!
----- 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!
----- Method: Behavior>>isBehavior (in category 'testing') -----
isBehavior
"Return true if the receiver is a behavior"
^true!
----- Method: Behavior>>isBits (in category 'testing') -----
isBits
"Answer whether the receiver contains just bits (not pointers)."
^ self instSpec >= 6!
----- Method: Behavior>>isBytes (in category 'testing') -----
isBytes
"Answer whether the receiver has 8-bit instance variables."
^ self instSpec >= 8!
----- Method: Behavior>>isFixed (in category 'testing') -----
isFixed
"Answer whether the receiver does not have a variable (indexable) part."
^self isVariable not!
----- Method: Behavior>>isMeta (in category 'testing') -----
isMeta
^ false!
----- Method: Behavior>>isObsolete (in category 'testing') -----
isObsolete
"Return true if the receiver is obsolete."
^self instanceCount = 0!
----- Method: Behavior>>isPointers (in category 'testing') -----
isPointers
"Answer whether the receiver contains just pointers (not bits)."
^self isBits not!
----- Method: Behavior>>isVariable (in category 'testing') -----
isVariable
"Answer whether the receiver has indexable variables."
^ self instSpec >= 2!
----- Method: Behavior>>isWeak (in category 'testing') -----
isWeak
"Answer whether the receiver has contains weak references."
^ self instSpec = 4!
----- Method: Behavior>>isWords (in category 'testing') -----
isWords
"Answer whether the receiver has 16-bit instance variables."
^self isBytes not!
----- 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, or a weakSubclass."
self isWeak
ifTrue: [^ ' weakSubclass: '].
^ self isVariable
ifTrue: [self isBits
ifTrue: [self isBytes
ifTrue: [ ' variableByteSubclass: ']
ifFalse: [ ' variableWordSubclass: ']]
ifFalse: [ ' variableSubclass: ']]
ifFalse: [ ' subclass: ']!
----- 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) ifNotNilDo:[: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) ifNotNilDo:[:assoc | ^assoc].
Undeclared at: key put: nil.
^Undeclared bindingOf: 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
"!
----- 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.!
----- 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!
----- Method: Behavior>>methodDict (in category 'accessing') -----
methodDict
methodDict == nil ifTrue: [self recoverFromMDFaultWithTrace].
^ methodDict!
----- Method: Behavior>>methodDictionary (in category 'accessing method dictionary') -----
methodDictionary
"Convenience"
^self methodDict!
----- Method: Behavior>>methodDictionary: (in category 'accessing method dictionary') -----
methodDictionary: aDictionary
"Store the argument, aDictionary, as the method dictionary of the
receiver."
methodDict _ aDictionary.!
----- 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 parserClass new) parseSelector: sourceString.
^ sourceString asString copyFrom: 1 to: (parser endOfLastToken min: sourceString size)
"Behavior methodHeaderFor: #methodHeaderFor: "
!
----- 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!
----- Method: Behavior>>name (in category 'accessing') -----
name
"Answer a String that is the name of the receiver."
^'a subclass of ', superclass name!
----- 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
!
----- 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 !
----- 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!
----- Method: Behavior>>obsolete (in category 'initialize-release') -----
obsolete
"Invalidate and recycle local messages,
e.g., zap the method dictionary if can be done safely."
self canZapMethodDictionary
ifTrue:[ methodDict _ self emptyMethodDictionary ].!
----- 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!
----- Method: Behavior>>parserClass (in category 'compiling') -----
parserClass
"Answer a parser class to use for parsing method headers."
^self compilerClass parserClass!
----- 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]!
----- 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!
----- Method: Behavior>>printOn: (in category 'printing') -----
printOn: aStream
"Refer to the comment in Object|printOn:."
aStream nextPutAll: 'a descendent of '.
superclass printOn: aStream!
----- Method: Behavior>>printOnStream: (in category 'printing') -----
printOnStream: aStream
"Refer to the comment in Object|printOn:."
aStream print: 'a descendent of '; write:superclass.!
----- 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!
----- 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 compilerClass new
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 addSelectorSilently: selector withMethod: (methodNode generate: trailer).
!
----- 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 selectorsDo:
[:sel | (self compiledMethodAt: sel) fileIndex > 1 ifTrue:
[self recompile: sel from: self]]!
----- 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 compilerClass new
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
!
----- Method: Behavior>>removeAllObsoleteSubclasses (in category 'obsolete subclasses') -----
removeAllObsoleteSubclasses
"Remove all the obsolete subclasses of the receiver"
ObsoleteSubclasses removeKey: self ifAbsent: [].
!
----- 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!
----- Method: Behavior>>removeSelector: (in category 'adding/removing methods') -----
removeSelector: selector
"Assuming that the argument, selector (a Symbol), is a message selector
in my method dictionary, remove it and its method."
^ self basicRemoveSelector: selector!
----- Method: Behavior>>removeSelectorSilently: (in category 'adding/removing methods') -----
removeSelectorSilently: selector
"Remove selector without sending system change notifications"
^ SystemChangeNotifier uniqueInstance doSilently: [self removeSelector: selector].!
----- Method: Behavior>>removeSelectorSimply: (in category 'deprecated') -----
removeSelectorSimply: selector
"Assuming that the argument, selector (a Symbol), is a message selector
in my method dictionary, remove it and its method."
| oldMethod |
self deprecated: 'Use basicRemoveSelector: instead.'.
oldMethod _ self methodDict at: selector ifAbsent: [^ self].
self methodDict removeKey: selector.
"Now flush Squeak's method cache, either by selector or by method"
oldMethod flushCache.
selector flushCache.!
----- Method: Behavior>>rootStubInImageSegment: (in category 'accessing method dictionary') -----
rootStubInImageSegment: imageSegment
^ ImageSegmentRootStub new
xxSuperclass: superclass
format: format
segment: imageSegment!
----- Method: Behavior>>scopeHas:ifTrue: (in category 'testing method dictionary') -----
scopeHas: varName ifTrue: aBlock
"Obsolete. Kept around for possible spurios senders which we don't know about"
(self bindingOf: varName) ifNotNilDo:[:binding|
aBlock value: binding.
^true].
^false!
----- 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!
----- 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!
----- Method: Behavior>>selectorAtMethod:setClass: (in category 'accessing method dictionary') -----
selectorAtMethod: method setClass: classResultBlock
"Answer both the message selector associated with the compiled method
and the class in which that selector is defined."
| sel |
sel _ self methodDict keyAtIdentityValue: method
ifAbsent:
[superclass == nil
ifTrue:
[classResultBlock value: self.
^method defaultSelector].
sel _ superclass selectorAtMethod: method setClass: classResultBlock.
"Set class to be self, rather than that returned from
superclass. "
sel == method defaultSelector ifTrue: [classResultBlock value: self].
^sel].
classResultBlock value: self.
^sel!
----- Method: Behavior>>selectors (in category 'accessing method dictionary') -----
selectors
"Answer a Set of all the message selectors specified in the receiver's
method dictionary."
^ self methodDict keys
"Point selectors."!
----- Method: Behavior>>selectorsAndMethodsDo: (in category 'accessing method dictionary') -----
selectorsAndMethodsDo: aBlock
"Evaluate selectorBlock for all the message selectors in my method dictionary."
^ self methodDict keysAndValuesDo: aBlock!
----- 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!
----- Method: Behavior>>selectorsWithArgs: (in category 'accessing method dictionary') -----
selectorsWithArgs: numberOfArgs
"Return all selectors defined in this class that take this number of arguments. Could use String.keywords. Could see how compiler does this."
| list num |
list _ OrderedCollection new.
self selectorsDo: [:aSel |
num _ aSel count: [:char | char == $:].
num = 0 ifTrue: [aSel last isLetter ifFalse: [num _ 1]].
num = numberOfArgs ifTrue: [list add: aSel]].
^ list!
----- 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
!
----- 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!
----- Method: Behavior>>shouldNotBeRedefined (in category 'testing') -----
shouldNotBeRedefined
"Return true if the receiver should not be redefined.
The assumption is that compact classes,
classes in Smalltalk specialObjects and
Behaviors should not be redefined"
^(self environment compactClassesArray includes: self)
or:[(self environment specialObjectsArray includes: self)
or:[self isKindOf: self]]!
----- Method: Behavior>>shutDown (in category 'system startup') -----
shutDown
"This message is sent on system shutdown to registered classes"
!
----- Method: Behavior>>shutDown: (in category 'system startup') -----
shutDown: quitting
"This message is sent on system shutdown to registered classes"
^self shutDown.!
----- 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!
----- Method: Behavior>>sourceCodeAt: (in category 'accessing method dictionary') -----
sourceCodeAt: selector
^ (self methodDict at: selector) getSourceFor: selector in: self!
----- Method: Behavior>>sourceCodeAt:ifAbsent: (in category 'accessing method dictionary') -----
sourceCodeAt: selector ifAbsent: aBlock
^ (self methodDict at: selector ifAbsent: [^ aBlock value]) getSourceFor: selector in: self!
----- Method: Behavior>>sourceCodeTemplate (in category 'compiling') -----
sourceCodeTemplate
"Answer an expression to be edited and evaluated in order to define
methods in this class."
^'message selector and argument names
"comment stating purpose of message"
| temporary variable names |
statements'!
----- 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!
----- 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!
----- 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 method |
space _ 0.
self selectorsDo: [:sel |
space _ space + 16. "dict and org'n space"
method _ self compiledMethodAt: sel.
space _ space + (method size + 6 "hdr + avg pad").
method literals do: [: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!
----- 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:' '.
].
].
!
----- Method: Behavior>>startUp (in category 'system startup') -----
startUp
"This message is sent to registered classes when the system is coming up."
!
----- Method: Behavior>>startUp: (in category 'system startup') -----
startUp: resuming
"This message is sent to registered classes when the system is coming up."
^self startUp!
----- Method: Behavior>>startUpFrom: (in category 'system startup') -----
startUpFrom: anImageSegment
"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!
----- 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!
----- Method: Behavior>>subclassDefinerClass (in category 'accessing') -----
subclassDefinerClass
"Answer an evaluator class appropriate for evaluating definitions of new
subclasses of this class."
^Compiler!
----- 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!
----- 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 ]!
----- Method: Behavior>>superclass (in category 'accessing class hierarchy') -----
superclass
"Answer the receiver's superclass, a Class."
^superclass!
----- 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']!
----- 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.!
----- 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:"]!
----- 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 "
| who |
who _ Set new.
self selectorsAndMethodsDo:
[:sel :method |
((method hasLiteralThorough: literal) or: [specialFlag and: [method scanFor: specialByte]])
ifTrue:
[((literal isVariableBinding) not
or: [method sendsToSuper not
or: [method literals allButLast includes: literal]])
ifTrue: [who add: sel]]].
^ who!
----- Method: Behavior>>traitComposition (in category 'traits') -----
traitComposition
"Backstop. When traits are unloaded we never have a trait composition"
^#()!
----- Method: Behavior>>traitCompositionString (in category 'traits') -----
traitCompositionString
"Backstop. Monticello needs a traitCompositionString even with traits unloaded"
^'{}'!
----- Method: Behavior>>typeOfClass (in category 'accessing') -----
typeOfClass
"Answer a symbol uniquely describing the type of the receiver"
self instSpec = CompiledMethod instSpec ifTrue:[^#compiledMethod]. "Very special!!"
self isBytes ifTrue:[^#bytes].
(self isWords and:[self isPointers not]) ifTrue:[^#words].
self isWeak ifTrue:[^#weak].
self isVariable ifTrue:[^#variable].
^#normal.!
----- 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. 2/26/96 sw"
| any |
^ self instVarNames copy reject:
[:ivn | any _ false.
self withAllSubclasses do:
[:class | (class whichSelectorsAccess: ivn) do:
[:sel | sel ~~ #DoIt ifTrue: [any _ true]]].
any]
"Ob unreferencedInstanceVariables"!
----- 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!
----- Method: Behavior>>whichSelectorsAccess: (in category 'testing method dictionary') -----
whichSelectorsAccess: instVarName
"Answer a Set of selectors whose methods access the argument,
instVarName, as a named instance variable."
| instVarIndex |
instVarIndex _ self allInstVarNames indexOf: instVarName ifAbsent: [^Set new].
^ self methodDict keys select:
[:sel |
((self methodDict at: sel)
readsField: instVarIndex)
or: [(self methodDict at: sel) writesField: instVarIndex]]
"Point whichSelectorsAccess: 'x'."!
----- 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 _ self environment hasSpecialSelector: literal ifTrueSetByte: [:b |
byte _ b].
^self whichSelectorsReferTo: literal special: special byte: byte
"Rectangle whichSelectorsReferTo: #+."!
----- 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."
| who |
who _ Set new.
self selectorsAndMethodsDo:
[:sel :method |
((method hasLiteral: literal) or: [specialFlag and: [method scanFor: specialByte]])
ifTrue:
[((literal isVariableBinding) not
or: [method sendsToSuper not
or: [method literals allButLast includes: literal]])
ifTrue: [who add: sel]]].
^ who!
----- Method: Behavior>>whichSelectorsStoreInto: (in category 'testing method dictionary') -----
whichSelectorsStoreInto: instVarName
"Answer a Set of selectors whose methods access the argument,
instVarName, as a named instance variable."
| instVarIndex |
instVarIndex _ self allInstVarNames indexOf: instVarName ifAbsent: [^Set new].
^ self methodDict keys select:
[:sel | (self methodDict at: sel) writesField: instVarIndex]
"Point whichSelectorsStoreInto: 'x'."!
----- Method: Behavior>>withAllSubAndSuperclassesDo: (in category 'user interface') -----
withAllSubAndSuperclassesDo: aBlock
self withAllSubclassesDo: aBlock.
self allSuperclassesDo: aBlock.
!
----- Method: Behavior>>withAllSubclasses (in category 'accessing class hierarchy') -----
withAllSubclasses
"Answer a Set of the receiver, the receiver's descendent's, and the
receiver's descendent's subclasses."
^ self allSubclasses add: self;
yourself!
----- 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!
----- Method: Behavior>>withAllSuperAndSubclassesDoGently: (in category 'enumerating') -----
withAllSuperAndSubclassesDoGently: aBlock
self allSuperclassesDo: aBlock.
aBlock value: self.
self allSubclassesDoGently: aBlock!
----- 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!
----- 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]!
----- 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]!
Behavior subclass: #ClassDescription
instanceVariableNames: 'instanceVariables organization'
classVariableNames: ''
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.).!
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. !
----- 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.
!
----- 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 !
----- 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"
Preferences printAlternateSyntax
ifTrue: [^ priorClassName asString, ' subclass (#NameOfSubclass)
instanceVariableNames ('''')
classVariableNames ('''')
poolDictionaries ('''')
category (''' , systemCategoryName asString , ''')']
ifFalse: [^ priorClassName asString, ' subclass: #NameOfSubclass
instanceVariableNames: ''''
classVariableNames: ''''
poolDictionaries: ''''
category: ''' , systemCategoryName asString , '''']!
----- 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 |
(subclass bindingOf: symbol) ifNotNil:[
^ self error: aString
, ' is already used as a variable name in class '
, subclass name]].
classPool == nil ifTrue: [classPool _ Dictionary new].
(classPool includesKey: symbol) ifFalse:
["Pick up any refs in Undeclared"
classPool declare: symbol from: Undeclared.
SystemChangeNotifier uniqueInstance classDefinitionChangedFrom: oldState to: self]!
----- 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: superclass
type: self typeOfClass
instanceVariableNames: self instanceVariablesString, ' ', aString
classVariableNames: self classVariablesString
poolDictionaries: self sharedPoolsString
category: self category
!
----- Method: Class>>addInstVarNames: (in category 'instance variables') -----
addInstVarNames: aCollection
| newInstVarString |
newInstVarString _ self instanceVariablesString.
aCollection do:
[:varName | (self instVarNames includes: varName) ifFalse: [newInstVarString _ newInstVarString , ' ' , varName]].
^(ClassBuilder new)
name: self name
inEnvironment: self environment
subclassOf: superclass
type: self typeOfClass
instanceVariableNames: newInstVarString
classVariableNames: self classVariablesString
poolDictionaries: self sharedPoolsString
category: self category
!
----- 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]!
----- 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.!
----- 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 |
superclass == nil
ifTrue:
[^self classVarNames] "This is the keys so it is a new Set."
ifFalse:
[aSet _ superclass allClassVarNames.
aSet addAll: self classVarNames.
^aSet]!
----- 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 |
^ superclass == nil
ifTrue: [self sharedPools copy]
ifFalse: [aSet _ superclass allSharedPools.
aSet addAll: self sharedPools.
aSet]!
----- Method: Class>>bindingOf: (in category 'compiling') -----
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 |
binding := pool bindingOf: aSymbol.
binding ifNotNil:[^binding].
].
"Next look in declared environment."
binding := self environment 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].
!
----- 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 bindingOf: varName) notNil].
!
----- Method: Class>>classPool (in category 'accessing') -----
classPool
"Answer the dictionary of class variables."
classPool == nil
ifTrue: [^Dictionary new]
ifFalse: [^classPool]!
----- Method: Class>>classPoolFrom: (in category 'accessing') -----
classPoolFrom: aClass
"share the classPool with aClass."
classPool := aClass classPool!
----- Method: Class>>classVarNames (in category 'class variables') -----
classVarNames
"Answer a Set of the names of the class variables defined in the receiver."
^self classPool keys!
----- Method: Class>>compileAll (in category 'compiling') -----
compileAll
super compileAll.
self class compileAll.!
----- 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!
----- Method: Class>>copy (in category 'copying') -----
copy
| 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.
Class instSize+1 to: self class instSize do:
[:offset | newClass instVarAt: offset put: (self instVarAt: offset)].
^ newClass!
----- 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 bindingOf: var) notNil
ifTrue:
[self error: var , ' is defined elsewhere'.
conflicts _ true]].
newVars size > 0
ifTrue:
[classPool _ self classPool.
"in case it was nil"
newVars do: [:var | classPool declare: var from: Undeclared]].
^conflicts!
----- Method: Class>>ensureClassPool (in category 'class variables') -----
ensureClassPool
classPool ifNil: [classPool _ Dictionary new].!
----- Method: Class>>environment (in category 'organization') -----
environment
environment == nil ifTrue: [^ super environment].
^ environment!
----- Method: Class>>environment: (in category 'organization') -----
environment: anEnvironment
environment _ anEnvironment!
----- Method: Class>>externalName (in category 'class name') -----
externalName
"Answer a name by which the receiver can be known."
^ name!
----- 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!
----- 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.
!
----- Method: Class>>fileOutInitializerOn: (in category 'fileIn/Out') -----
fileOutInitializerOn: aStream
^self class fileOutInitializerOn: aStream!
----- 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!
----- 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: 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]!
----- Method: Class>>fileOutPool:onFileStream: (in category 'fileIn/Out') -----
fileOutPool: aPool onFileStream: aFileStream
| aPoolName aValue |
(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 asSortedCollection do: [ :aKey |
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!
----- 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].
!
----- 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]!
----- Method: Class>>isObsolete (in category 'testing') -----
isObsolete
"Return true if the receiver is obsolete."
^(self environment at: name ifAbsent:[nil]) ~~ self!
----- 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!
----- Method: Class>>name (in category 'accessing') -----
name
"Answer the name of the receiver."
name == nil
ifTrue: [^super name]
ifFalse: [^name]!
----- 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']!
----- 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"!
----- 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]
!
----- 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'].
name _ 'AnObsolete' , name.
Object class instSize + 1 to: self class instSize do:
[:i | self instVarAt: i put: nil]. "Store nil over class instVars."
classPool _ nil.
sharedPools _ nil.
self class obsolete.
super obsolete.
!
----- 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!
----- 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 ]!
----- 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"!
----- 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) '.
^Undeclared declare: 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:[^Undeclared declare: aSymbol from: classPool]
ifFalse:[^self]]]].
classPool removeKey: aSymbol.
classPool isEmpty ifTrue: [classPool := nil].
!
----- 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!
----- 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.!
----- 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 unload itself"
self 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.!
----- 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!
----- 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: superclass
type: self typeOfClass
instanceVariableNames: newInstVarString
classVariableNames: self classVariablesString
poolDictionaries: self sharedPoolsString
category: self category!
----- Method: Class>>removeInstVarNames: (in category 'instance variables') -----
removeInstVarNames: aCollection
| newInstVarString |
aCollection do: [:aString |
(self instVarNames includes: aString)
ifFalse: [self error: aString , ' is not one of my instance variables'].
].
newInstVarString _ ''.
(self instVarNames copyWithoutAll: aCollection) do:
[:varName | newInstVarString _ newInstVarString , ' ' , varName].
^(ClassBuilder new)
name: self name
inEnvironment: self environment
subclassOf: superclass
type: self typeOfClass
instanceVariableNames: newInstVarString
classVariableNames: self classVariablesString
poolDictionaries: self sharedPoolsString
category: self category
!
----- 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]!
----- 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]].
!
----- Method: Class>>rename: (in category 'class name') -----
rename: aString
"The new name of the receiver is the argument, aString."
| newName |
(newName _ aString asSymbol) ~= self name
ifFalse: [^ self].
(self environment includesKey: newName)
ifTrue: [^ self error: newName , ' already exists'].
(Undeclared includesKey: newName)
ifTrue: [self inform: 'There are references to, ' , aString printString , '
from Undeclared. Check them after this change.'].
self environment renameClass: self as: newName.
name _ newName!
----- Method: Class>>setName: (in category 'private') -----
setName: aSymbol
"Private - set the name of the class"
name _ aSymbol.!
----- 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]!
----- Method: Class>>sharing: (in category 'initialize-release') -----
sharing: poolString
"Set up sharedPools. Answer whether recompilation is advisable."
| oldPools found |
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 _ false.
self sharedPools do: [:p | p == pool ifTrue: [found _ true]].
found ifFalse: [^ true "A pool got deleted"]].
^ false!
----- 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, '?')!
----- 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?'!
----- Method: Class>>spaceUsed (in category 'private') -----
spaceUsed
"Object spaceUsed"
^ super spaceUsed + self class spaceUsed!
----- 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'!
----- 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
!
----- Method: Class>>subclasses (in category 'accessing class hierarchy') -----
subclasses
"Answer a Set containing the receiver's subclasses."
^subclasses == nil
ifTrue: [#()]
ifFalse: [subclasses copy]!
----- 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]!
----- 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]!
----- 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.!
----- 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"
!
----- 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."
""
!
----- 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
!
----- 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
!
----- 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
!
----- 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!
----- Method: Class>>withClassVersion: (in category 'fileIn/Out') -----
withClassVersion: aVersion
aVersion = self classVersion ifTrue:[^self].
^self error: 'Invalid class version'!
----- 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!
----- 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].!
----- Method: ClassDescription>>addInstVarName: (in category 'instance variables') -----
addInstVarName: aString
"Add the argument, aString, as one of the receiver's instance variables."
self subclassResponsibility!
----- 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].!
----- 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"!
----- 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 asSortedCollection: [:a :b | a asLowercase < b asLowercase]) asArray
"ColorTileMorph allMethodCategoriesIntegratedThrough: TileMorph"!
----- 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"!
----- Method: ClassDescription>>category (in category 'organization') -----
category
"Answer the system organization category for the receiver."
^SystemOrganization categoryOfElement: self name!
----- Method: ClassDescription>>category: (in category 'organization') -----
category: cat
"Categorize the receiver under the system category, cat, removing it from
any previous categorization."
| oldCat |
oldCat := self category.
(cat isString)
ifTrue: [SystemOrganization classify: self name under: cat asSymbol]
ifFalse: [self errorCategoryName].
SystemChangeNotifier uniqueInstance class: self recategorizedFrom: oldCat to: cat asSymbol!
----- Method: ClassDescription>>categoryFromUserWithPrompt: (in category 'deprecated') -----
categoryFromUserWithPrompt: aPrompt
"SystemDictionary categoryFromUserWithPrompt: 'testing'"
self deprecated: 'Use CodeHolder>>categoryFromUserWithPrompt: aPrompt for: aClass instead'.
"this deprecation helps to remove UI dependency from the core of Squeak.
Normally only CodeHolder was calling this method"
CodeHolder new categoryFromUserWithPrompt: aPrompt for: self!
----- 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!
----- Method: ClassDescription>>chooseClassVarName (in category 'instance variables') -----
chooseClassVarName
"Present the user with a list of class variable names and answer the one selected, or nil if none"
| lines labelStream vars allVars index |
lines _ OrderedCollection new.
allVars _ OrderedCollection new.
labelStream _ WriteStream on: (String new: 200).
self withAllSuperclasses reverseDo:
[:class |
vars _ class classVarNames asSortedCollection.
vars do:
[:var |
labelStream nextPutAll: var; cr.
allVars add: var].
vars isEmpty ifFalse: [lines add: allVars size]].
labelStream contents isEmpty ifTrue: [^Beeper beep]. "handle nil superclass better"
labelStream skip: -1 "cut last CR".
index _ (PopUpMenu labels: labelStream contents lines: lines) startUp.
index = 0 ifTrue: [^ nil].
^ allVars at: index!
----- 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 _ (PopUpMenu labelArray: allVars lines: #()) startUpWithCaption: 'Instance variables in
', self name.
index = 0 ifTrue: [^ self].
aBlock value: (allVars at: index)!
----- Method: ClassDescription>>chooseInstVarThenDo: (in category 'instance variables') -----
chooseInstVarThenDo: 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. If the list is 6 or larger, then offer an alphabetical
formulation as an alternative. triggered by a 'show alphabetically' item
at the top of the list."
| lines labelStream vars allVars index count offerAlpha |
(count _ self allInstVarNames size) = 0 ifTrue:
[^ self inform: 'There are no
instance variables.'].
allVars _ OrderedCollection new.
lines _ OrderedCollection new.
labelStream _ WriteStream on: (String new: 200).
(offerAlpha _ count > 5)
ifTrue:
[lines add: 1.
allVars add: 'show alphabetically'.
labelStream nextPutAll: allVars first; cr].
self withAllSuperclasses reverseDo:
[:class |
vars _ class instVarNames.
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 _ (PopUpMenu labels: labelStream contents lines: lines)
startUpWithCaption: 'Instance variables in
', self name.
index = 0 ifTrue: [^ self].
(index = 1 and: [offerAlpha]) ifTrue: [^ self
chooseInstVarAlphabeticallyThenDo: aBlock].
aBlock value: (allVars at: index)!
----- 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>'!
----- 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 notNil and: [(file _ SourceFiles at: 2) notNil and: [file isReadOnly not]]) ifTrue: [
[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.
SystemChangeNotifier uniqueInstance classCommented: self.
!
----- Method: ClassDescription>>classSide (in category 'accessing parallel hierarchy') -----
classSide
^self theMetaClass!
----- 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].
^ superclass ifNotNil: [superclass classThatDefinesClassVariable: classVarName]!
----- Method: ClassDescription>>classThatDefinesInstanceVariable: (in category 'instance variables') -----
classThatDefinesInstanceVariable: instVarName
(instanceVariables notNil and: [instanceVariables includes: instVarName asString]) ifTrue: [^ self].
^ superclass ifNotNil: [superclass classThatDefinesInstanceVariable: instVarName]!
----- Method: ClassDescription>>classVariablesString (in category 'printing') -----
classVariablesString
"Answer a string of my class variable names separated by spaces."
^String streamContents: [ :stream |
self classPool keys asSortedCollection
do: [ :each | stream nextPutAll: each ]
separatedBy: [ stream space ] ]!
----- 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!
----- 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)]]!
----- Method: ClassDescription>>comment (in category 'accessing comment') -----
comment
"Answer the receiver's comment. (If missing, supply a template) "
| aString |
aString _ self theNonMetaClass organization classComment.
aString isEmpty ifFalse: [^ aString].
^
'Main comment stating the purpose of this class and relevant relationship to other classes.
Possible useful expressions for doIt or printIt.
Structure:
instVar1 type -- comment about the purpose of instVar1
instVar2 type -- comment about the purpose of instVar2
Any further useful comments about the general approach of this implementation.'!
----- Method: ClassDescription>>comment: (in category 'accessing comment') -----
comment: aStringOrText
"Set the receiver's comment to be the argument, aStringOrText."
self theNonMetaClass classComment: aStringOrText.!
----- Method: ClassDescription>>comment:stamp: (in category 'accessing comment') -----
comment: aStringOrText stamp: aStamp
"Set the receiver's comment to be the argument, aStringOrText."
self theNonMetaClass classComment: aStringOrText stamp: aStamp.!
----- 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"!
----- 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: $-), '*'!
----- Method: ClassDescription>>commentStamp: (in category 'fileIn/Out') -----
commentStamp: changeStamp
self organization commentStamp: changeStamp.
^ self commentStamp: changeStamp prior: 0!
----- 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
!
----- 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: (SyntaxError new category: heading)!
----- 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
!
----- 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!
----- Method: ClassDescription>>compile:classified:withStamp:notifying:logSource: (in category 'compiling') -----
compile: text classified: category withStamp: changeStamp notifying: requestor logSource: logSource
| methodAndNode |
methodAndNode _ self basicCompile: text asString notifying: requestor
trailer: self defaultMethodTrailer ifFail: [^nil].
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 theNonMetaClass noteCompilationOf: methodAndNode selector meta: self isMeta.
^ methodAndNode selector!
----- Method: ClassDescription>>compile:classified:withStamp:notifying:logSource:for: (in category 'compiling') -----
compile: text classified: category withStamp: changeStamp notifying: requestor logSource: logSource for: anInstance
| methodAndNode |
methodAndNode _ self basicCompile: text asString notifying: requestor
trailer: self defaultMethodTrailer ifFail: [^nil] for: anInstance.
methodAndNode method: (methodAndNode method copyWithTempNames: (methodAndNode node tempNames)).
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 theNonMetaClass noteCompilationOf: methodAndNode selector meta: self isMeta.
^ methodAndNode selector!
----- 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!
----- Method: ClassDescription>>compileInobtrusively:classified: (in category 'deprecated') -----
compileInobtrusively: 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."
| methodNode newMethod |
self deprecated: 'Use compileSilently:classified: instead.'.
methodNode _ self compilerClass new compile: code in: self notifying: nil ifFail: [^ nil].
self addSelectorSilently: methodNode selector withMethod: (newMethod _ methodNode generate: #(0 0 0 0)).
SystemChangeNotifier uniqueInstance doSilently: [self organization classify: methodNode selector under: category].
^ newMethod!
----- Method: ClassDescription>>compileProgrammatically:classified: (in category 'deprecated') -----
compileProgrammatically: code classified: cat
"compile the given code programmatically. In the current theory, we always do this unlogged as well, and do not accumulate the change in the current change set"
self deprecated: 'Use compileSilently:classified: instead.'.
^ self compileSilently: code classified: cat
"
| oldInitials |
oldInitials _ Utilities authorInitialsPerSe.
Utilities setAuthorInitials: 'programmatic'.
self compile: code classified: cat.
Utilities setAuthorInitials: oldInitials.
"!
----- 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.!
----- Method: ClassDescription>>compileSilently:classified:for: (in category 'compiling') -----
compileSilently: code classified: category for: anInstance
"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 for: anInstance!
----- 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].!
----- Method: ClassDescription>>compileSilently:classified:notifying:for: (in category 'compiling') -----
compileSilently: code classified: category notifying: requestor for: anInstance
"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 for: anInstance].!
----- Method: ClassDescription>>compileUnlogged:classified:notifying: (in category 'deprecated') -----
compileUnlogged: text classified: category notifying: requestor
self deprecated: 'Use compileSilently:classified:notifying: instead.'.
^ self compileSilently: text classified: category notifying: requestor.
"
| selector |
self compile: text asString
notifying: requestor
trailer: #(0 0 0 0)
ifFail: [^ nil]
elseSetSelectorAndNode:
[:sel :node | selector _ sel].
self organization classify: selector under: category.
^ selector
"!
----- 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!
----- 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]!
----- 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!
----- 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]!
----- 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]!
----- 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]!
----- 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]!
----- 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!
----- 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!
----- 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!
----- Method: ClassDescription>>copyMethodDictionaryFrom: (in category 'copying') -----
copyMethodDictionaryFrom: donorClass
"Copy the method dictionary of the donor class over to the receiver"
methodDict _ donorClass copyOfMethodDictionary.
self organization: donorClass organization deepCopy.!
----- 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 compileInobtrusively: code classified: category]!
----- 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!
----- Method: ClassDescription>>definition (in category 'fileIn/Out') -----
definition
"Answer a String that defines the receiver in good old ST-80."
^ self definitionST80!
----- Method: ClassDescription>>definitionST80 (in category 'fileIn/Out') -----
definitionST80
"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.
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!
----- Method: ClassDescription>>definitionST80: (in category 'fileIn/Out') -----
definitionST80: isST80
"Answer a String that defines the receiver."
| aStream path |
isST80 ifTrue: [^ self definitionST80].
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 nextPutKeyword: self kindOfSubclass
withArg: self name.
aStream cr; tab; nextPutKeyword: 'instanceVariableNames: '
withArg: self instanceVariablesString.
aStream cr; tab; nextPutKeyword: 'classVariableNames: 'withArg: self classVariablesString.
aStream cr; tab; nextPutKeyword: 'poolDictionaries: '
withArg: self sharedPoolsString.
aStream cr; tab; nextPutKeyword: 'category: '
withArg: (SystemOrganization categoryOfElement: self name) asString.
superclass ifNil: [
aStream nextPutAll: '.'; cr.
aStream nextPutAll: self name.
aStream space; nextPutAll: 'superclass (nil)'. ].
^ aStream contents!
----- 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."!
----- Method: ClassDescription>>errorCategoryName (in category 'private') -----
errorCategoryName
self error: 'Category name must be a String'!
----- Method: ClassDescription>>fileOutCategory: (in category 'fileIn/Out') -----
fileOutCategory: catName
^ self fileOutCategory: catName asHtml: false!
----- 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.
!
----- 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 ].
"Overridden to preserve author stamps in sources file regardless"
selectors do: [:sel |
self printMethodChunk: sel
withPreamble: true
on: aFileStream
moveSource: moveSource
toFile: fileIndex].
^ self!
----- 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!
----- 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 sels |
(org _ self organization) categories do:
[:cat |
sels _ (org listAtCategoryNamed: cat) select: [:sel | aSet includes: sel].
sels do:
[:sel | self printMethodChunk: sel withPreamble: true on: aFileStream
moveSource: moveSource toFile: fileIndex]]!
----- 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 sels |
(org _ self organization) categories do:
[:cat |
sels _ (org listAtCategoryNamed: cat) select: [:sel | aSet includes: sel].
sels do:
[:sel | self printMethodChunkHistorically: sel on: aFileStream
moveSource: moveSource toFile: fileIndex]]!
----- 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!
----- 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.
!
----- Method: ClassDescription>>fileOutOn: (in category 'fileIn/Out') -----
fileOutOn: aFileStream
"File a description of the receiver on aFileStream."
self fileOutOn: aFileStream
moveSource: false
toFile: 0!
----- Method: ClassDescription>>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."
aFileStream command: 'H3'.
aFileStream nextChunkPut: self definition.
aFileStream command: '/H3'.
self organization
putCommentOnFile: aFileStream
numbered: fileIndex
moveSource: moveSource
forClass: self.
self organization categories do:
[:heading |
self fileOutCategory: heading
on: aFileStream
moveSource: moveSource
toFile: fileIndex]!
----- 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!
----- 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!
----- 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.!
----- Method: ClassDescription>>hasComment (in category 'accessing comment') -----
hasComment
"return whether this class truly has a comment other than the default"
| org |
org := self theNonMetaClass organization.
^org classComment notNil and: [
org classComment isEmpty not ].
!
----- 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!
----- 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.
^self allInstVarNames
collect: [:instVarName | oldInstVarNames indexOf: instVarName].
!
----- Method: ClassDescription>>instVarNames (in category 'instance variables') -----
instVarNames
"Answer an Array of the receiver's instance variable names."
instanceVariables == nil
ifTrue: [^#()]
ifFalse: [^instanceVariables]!
----- Method: ClassDescription>>instanceSide (in category 'accessing parallel hierarchy') -----
instanceSide
^ self theNonMetaClass!
----- 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 ] ]!
----- Method: ClassDescription>>isClassSide (in category 'accessing parallel hierarchy') -----
isClassSide
^self == self classSide!
----- Method: ClassDescription>>isInstanceSide (in category 'accessing parallel hierarchy') -----
isInstanceSide
^self isClassSide not!
----- Method: ClassDescription>>isUniClass (in category 'accessing method dictionary') -----
isUniClass
"Answer whether the receiver is a uniclass."
^ self name endsWithDigit!
----- Method: ClassDescription>>letUserReclassify: (in category 'deprecated') -----
letUserReclassify: anElement
"Put up a list of categories and solicit one from the user.
Answer true if user indeed made a change, else false"
self deprecated: 'Use CodeHolder>>letUserReclassify: anElement in: aClass'.
CodeHolder new letUserReclassify: anElement in: self.!
----- Method: ClassDescription>>linesOfCode (in category 'private') -----
linesOfCode "InterpreterSimulator linesOfCode 790"
"An approximate measure of lines of code.
Includes comments, but excludes blank lines."
| lines code strm line |
lines _ 0.
self selectorsDo: [:sel |
code _ self sourceCodeAt: sel.
strm _ ReadStream on: code.
[strm atEnd] whileFalse:
[line _ strm upTo: Character cr.
line isEmpty ifFalse: [lines _ lines+1]]].
self isMeta
ifTrue: [^ lines]
ifFalse: [^ lines + self class linesOfCode]
"
(SystemOrganization categories select: [:c | 'Fabrik*' match: c]) detectSum:
[:c | (SystemOrganization superclassOrder: c) detectSum: [:cl | cl linesOfCode]] 24878
"!
----- 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: [].
newText _ ((requestor == nil or: [requestor isKindOf: SyntaxError]) not
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.!
----- 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!
----- 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"!
----- 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!
----- Method: ClassDescription>>methodsFor:stamp: (in category 'fileIn/Out') -----
methodsFor: categoryName stamp: changeStamp
^ self methodsFor: categoryName stamp: (Utilities fixStamp: changeStamp) prior: 0!
----- 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:"!
----- 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 methodDict at: sel) fileIndex > 1].
self fileOutChangedMessages: changes
on: newFile
moveSource: true
toFile: 2!
----- 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 methodDict keys select: [:sel | (self methodDict at: sel) fileIndex > 1].
self fileOutChangedMessagesHistorically: changes
on: newFile
moveSource: true
toFile: 2!
----- 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!
----- 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!
----- Method: ClassDescription>>noteCompilationOf:meta: (in category 'compiling') -----
noteCompilationOf: aSelector meta: isMeta
"A hook allowing some classes to react to recompilation of certain selectors"!
----- Method: ClassDescription>>obsolete (in category 'initialize-release') -----
obsolete
"Make the receiver obsolete."
superclass removeSubclass: self.
self organization: nil.
super obsolete.!
----- 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 asSortedCollection asArray)].
(organization isMemberOf: Array) ifTrue:
[self recoverFromMDFaultWithTrace].
"Making sure that subject is set correctly. It should not be necessary."
organization ifNotNil: [organization setSubject: self].
^ organization!
----- 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!
----- Method: ClassDescription>>printCategoryChunk:on: (in category 'fileIn/Out') -----
printCategoryChunk: categoryName on: aFileStream
^ self printCategoryChunk: categoryName withStamp: '' on: aFileStream!
----- 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!
----- 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'.!
----- Method: ClassDescription>>printCategoryChunk:withStamp:on: (in category 'fileIn/Out') -----
printCategoryChunk: categoryName withStamp: changeStamp on: aFileStream
^ self printCategoryChunk: categoryName on: aFileStream withStamp: changeStamp
priorMethod: nil!
----- 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: (self decompilerClass new decompile: selector
in: self method: 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!
----- 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 true, then also set the source code pointer of the method."
| preamble method newPos sourceFile endPos category changeList prior |
category _ self organization categoryOfElement: selector.
preamble _ self name , ' methodsFor: ', category asString printString.
method _ self methodDict at: selector.
((method fileIndex = 0
or: [(SourceFiles at: method fileIndex) == nil])
or: [method filePosition = 0])
ifTrue: [
outStream cr; nextPut: $!!; nextChunkPut: preamble; cr.
outStream nextChunkPut: (
self decompilerClass new
decompile: selector in: self method: method) decompileString.
outStream nextChunkPut: ' '; cr]
ifFalse: [
changeList _ (VersionsBrowser new
scanVersionsOf: method
class: self
meta: self isMeta
category: category
selector: selector) changeList.
newPos _ nil.
sourceFile _ SourceFiles at: method fileIndex.
changeList reverseDo: [ :chgRec |
chgRec fileIndex = fileIndex ifTrue: [
outStream copyPreamble: preamble from: sourceFile at: chgRec position.
(prior _ chgRec prior) ifNotNil: [
outStream position: outStream position - 2.
outStream nextPutAll: ' prior: ', (
prior first = method fileIndex ifFalse: [prior third] ifTrue: [
SourceFiles
sourcePointerFromFileIndex: method fileIndex
andPosition: newPos]) printString.
outStream nextPut: $!!; cr].
"Copy the method chunk"
newPos _ outStream position.
outStream copyMethodChunkFrom: sourceFile at: chgRec position.
sourceFile skipSeparators. "The following chunk may have ]style["
sourceFile peek == $] ifTrue: [
outStream cr; copyMethodChunkFrom: sourceFile].
outStream nextChunkPut: ' '; cr]].
moveSource ifTrue: [
endPos _ outStream position.
method checkOKToAdd: endPos - newPos at: newPos.
method setSourcePosition: newPos inFile: fileIndex]].
^ outStream!
----- Method: ClassDescription>>printOn: (in category 'printing') -----
printOn: aStream
aStream nextPutAll: self name!
----- Method: ClassDescription>>printOnStream: (in category 'printing') -----
printOnStream: aStream
aStream print: self name!
----- 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]!
----- 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."
| 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: 2 toFile: aFileStream) stamp: aStamp
"--------------------------------------------------------------------------------------------------------------------------------------
Here is a comment to protect the next method in the .sources file doesn't get confused with the ending stamp : keyword.
---------------------------------------------------------------------------------------------------------------------------------------"!
----- 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.
!
----- 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.
"!
----- 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]!
----- Method: ClassDescription>>reformatMethodAt: (in category 'compiling') -----
reformatMethodAt: selector
| newCodeString method |
newCodeString _ (self compilerClass new)
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!
----- 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!
----- 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!
----- Method: ClassDescription>>removeSelector: (in category 'accessing method dictionary') -----
removeSelector: selector
| priorMethod priorProtocol |
"Remove the message whose selector is given from the method
dictionary of the receiver, if it is there. Answer nil otherwise."
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.!
----- Method: ClassDescription>>removeSelectorUnlogged: (in category 'deprecated') -----
removeSelectorUnlogged: aSymbol
"Remove the message whose selector is aSymbol from the method dictionary of the receiver, if it is there. Answer nil otherwise. Do not log the action either to the current change set or to the changes log"
self deprecated: 'Use removeSelectorSilently: instead'.
(self methodDict includesKey: aSymbol) ifFalse: [^ nil].
SystemChangeNotifier uniqueInstance doSilently: [
self organization removeElement: aSymbol].
super removeSelector: aSymbol.!
----- 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 _ self environment garbageCollect.
candidatesForRemoval _
self subclasses select: [:c |
(c instanceCount = 0) and: [c subclasses size = 0]].
candidatesForRemoval do: [:c | c removeFromSystem].
^ self environment garbageCollect - oldFree!
----- 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!
----- Method: ClassDescription>>renameSilentlyInstVar:to: (in category 'instance variables') -----
renameSilentlyInstVar: old to: new
| i oldName newName |
oldName _ old asString.
newName _ new asString.
(i _ instanceVariables 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]].
instanceVariables replaceFrom: i to: i with: (Array with: newName).
self replaceSilently: oldName to: newName. "replace in text body of all methods"!
----- 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!
----- 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"
| oldCode newCode parser header body sels oldName newName |
oldName _ old asString.
newName _ new asString.
self withAllSubclasses do:
[:cls | sels _ cls selectors.
sels removeAllFoundIn: #(DoIt DoItIn:).
sels do:
[:sel |
oldCode _ cls sourceCodeAt: sel.
"Don't make changes in the method header"
(parser _ cls parserClass new) 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 _ cls comment.
newCode _ oldCode copyReplaceTokens: oldName with: newName.
newCode ~= oldCode ifTrue:
[cls comment: newCode]]]!
----- 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].!
----- 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 ] ]!
----- Method: ClassDescription>>storeOn: (in category 'printing') -----
storeOn: aStream
"Classes and Metaclasses have global names."
aStream nextPutAll: self name!
----- Method: ClassDescription>>subclasses (in category 'accessing class hierarchy') -----
subclasses
^ Array new!
----- 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!
----- 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.!
----- Method: ClassDescription>>theMetaClass (in category 'accessing parallel hierarchy') -----
theMetaClass
"Sent to a class or metaclass, always return the metaclass"
^self class!
----- Method: ClassDescription>>theNonMetaClass (in category 'accessing parallel hierarchy') -----
theNonMetaClass
"Sent to a class or metaclass, always return the class"
^self!
----- Method: ClassDescription>>theNonMetaClassName (in category 'accessing') -----
theNonMetaClassName
^self name.
!
----- Method: ClassDescription>>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]]!
----- 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. Return the array of old instances (none of which should be pointed to legally by anyone but the array)."
"If there are any contexts having an old instance as receiver it might crash the system because the layout has changed, and the method only knows about the old layout."
| map variable instSize newInstances |
oldInstances isEmpty ifTrue:[^#()]. "no instances to convert"
isMeta ifTrue: [
oldInstances size = 1 ifFalse:[^self error:'Metaclasses can only have one instance'].
self soleInstance class == self ifTrue:[
^self error:'Metaclasses can only have one instance']].
map _ self instVarMappingFrom: oldClass.
variable _ self isVariable.
instSize _ self instSize.
newInstances _ Array new: oldInstances size.
1 to: oldInstances size do:[:i|
newInstances at: i put: (
self newInstanceFrom: (oldInstances at: i) variable: variable size: instSize map: map)].
"Now perform a bulk mutation of old instances into new ones"
oldInstances elementsExchangeIdentityWith: newInstances.
^newInstances "which are now old"!
----- 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. Return the array of old instances (none of which should be
pointed to legally by anyone but the array)."
"ar 7/15/1999: The updating below is possibly dangerous. If there are any
contexts having an old instance as receiver it might crash the system if
the new receiver in which the context is executed has a different layout.
See bottom below for a simple example:"
| oldInstances |
oldInstances _ oldClass allInstances asArray.
oldInstances _ self updateInstances: oldInstances from: oldClass isMeta: self isMeta.
"Now fix up instances in segments that are out on the disk."
ImageSegment allSubInstancesDo: [:seg |
seg segUpdateInstancesOf: oldClass toBe: self isMeta: self isMeta].
^oldInstances
" | 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.
crashingBlock value.
"
!
----- 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!
----- Method: ClassDescription>>wantsRecompilationProgressReported (in category 'compiling') -----
wantsRecompilationProgressReported
"Answer whether the receiver would like progress of its recompilation reported interactively to the user."
^ true!
----- 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]!
----- 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 organization: nil.
self isMeta ifFalse: [self class zapOrganization]!
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.!
----- 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
!
----- 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!
----- Method: Metaclass>>addInstVarName: (in category 'instance variables') -----
addInstVarName: aString
"Add the argument, aString, as one of the receiver's instance variables."
| fullString |
fullString _ aString.
self instVarNames do: [:aString2 | fullString _ aString2 , ' ' , fullString].
self instanceVariableNames: fullString!
----- Method: Metaclass>>addObsoleteSubclass: (in category 'class hierarchy') -----
addObsoleteSubclass: aClass
"Do nothing."!
----- Method: Metaclass>>addSubclass: (in category 'class hierarchy') -----
addSubclass: aClass
"Do nothing."!
----- 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)!
----- Method: Metaclass>>allInstances (in category 'accessing') -----
allInstances
thisClass class == self ifTrue:[^Array with: thisClass].
^super allInstances!
----- Method: Metaclass>>allInstancesDo: (in category 'enumerating') -----
allInstancesDo: aBlock
"There should be only one"
thisClass class == self ifTrue:[^aBlock value: thisClass].
^super allInstancesDo: aBlock!
----- Method: Metaclass>>allInstancesEverywhereDo: (in category 'enumerating') -----
allInstancesEverywhereDo: aBlock
"There should be only one"
thisClass class == self ifTrue:[^ aBlock value: thisClass].
^ super allInstancesEverywhereDo: aBlock!
----- Method: Metaclass>>bindingOf: (in category 'compiling') -----
bindingOf: varName
^thisClass classBindingOf: varName!
----- 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]!
----- Method: Metaclass>>classPool (in category 'pool variables') -----
classPool
"Answer the dictionary of class variables."
^thisClass classPool!
----- Method: Metaclass>>copy (in category 'copying') -----
copy
"Make a copy of the receiver without a list of subclasses. Share the
reference to the sole instance."
| copy t |
t _ thisClass.
thisClass _ nil.
copy _ super copy.
thisClass _ t.
^copy!
----- Method: Metaclass>>definitionST80 (in category 'fileIn/Out') -----
definitionST80
"Refer to the comment in ClassDescription|definition."
^ String streamContents:
[:strm |
strm print: self;
crtab;
nextPutAll: 'instanceVariableNames: ';
store: self instanceVariablesString]!
----- Method: Metaclass>>definitionST80: (in category 'fileIn/Out') -----
definitionST80: isST80
"Refer to the comment in ClassDescription|definition."
isST80 ifTrue: [^ self definitionST80].
^ String streamContents:
[:strm |
strm print: self;
nextPutKeyword: ' instanceVariableNames: '
withArg: self instanceVariablesString]!
----- Method: Metaclass>>environment (in category 'accessing') -----
environment
^thisClass environment!
----- Method: Metaclass>>fileOutInitializerOn: (in category 'fileIn/Out') -----
fileOutInitializerOn: aStream
(self methodDict includesKey: #initialize) ifTrue:
[aStream cr.
aStream nextChunkPut: thisClass name , ' initialize'].!
----- Method: Metaclass>>fileOutOn:moveSource:toFile: (in category 'fileIn/Out') -----
fileOutOn: aFileStream moveSource: moveSource toFile: fileIndex
^self fileOutOn: aFileStream moveSource: moveSource toFile: fileIndex initializing: true!
----- 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 not and: [self methodDict includesKey: #initialize]]) ifTrue:
[aFileStream cr.
aFileStream cr.
aFileStream nextChunkPut: thisClass name , ' initialize'.
aFileStream cr]!
----- Method: Metaclass>>instanceVariableNames: (in category 'initialize-release') -----
instanceVariableNames: instVarString
"Declare additional named variables for my instance."
^(ClassBuilder new)
class: self
instanceVariableNames: instVarString!
----- Method: Metaclass>>isMeta (in category 'testing') -----
isMeta
^ true!
----- 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"!
----- Method: Metaclass>>isSystemDefined (in category 'accessing') -----
isSystemDefined
"Answer false if I am a UniClass (an instance-specific lightweight class)"
^ true!
----- 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']!
----- 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!!']!
----- 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]!
----- 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
!
----- 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]"!
----- Method: Metaclass>>possibleVariablesFor:continuedFrom: (in category 'compiling') -----
possibleVariablesFor: misspelled continuedFrom: oldResults
^ thisClass possibleVariablesFor: misspelled continuedFrom: oldResults
!
----- 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!
----- Method: Metaclass>>removeObsoleteSubclass: (in category 'class hierarchy') -----
removeObsoleteSubclass: aClass
"Do nothing."!
----- Method: Metaclass>>removeSubclass: (in category 'class hierarchy') -----
removeSubclass: aClass
"Do nothing."!
----- 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.!
----- Method: Metaclass>>soleInstance (in category 'accessing') -----
soleInstance
"The receiver has only one instance. Answer it."
^thisClass!
----- 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'!
----- 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]"!
----- 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]].!
----- 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]]].!
----- Method: Metaclass>>theMetaClass (in category 'accessing parallel hierarchy') -----
theMetaClass
"Sent to a class or metaclass, always return the metaclass"
^self!
----- Method: Metaclass>>theNonMetaClass (in category 'accessing parallel hierarchy') -----
theNonMetaClass
"Sent to a class or metaclass, always return the class"
^thisClass!
----- Method: Metaclass>>theNonMetaClassName (in category 'accessing') -----
theNonMetaClassName
^thisClass name
!
----- Method: Metaclass>>veryDeepCopyWith: (in category 'copying') -----
veryDeepCopyWith: deepCopier
"Return self. Must be created, not copied. Do not record me."!
----- 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!
----- Method: Metaclass>>wantsRecompilationProgressReported (in category 'compiling') -----
wantsRecompilationProgressReported
"The metaclass follows the rule of the class itself."
^ thisClass wantsRecompilationProgressReported!
Object subclass: #BlockClosure
instanceVariableNames: 'method environment'
classVariableNames: ''
poolDictionaries: ''
category: 'Kernel-Methods'!
!BlockClosure commentStamp: 'ajh 7/19/2004 14:57' prior: 0!
A BlockClosure is a block of Smalltalk code (enclosed within []) that may be executed later by sending #valueWithArguments: (or one of its variants) to it. A block can take arguments by specifying the names of the arguments in the beginning of the block, as in "[:arg1 :arg2 | ...]", and can have its own local temps, as in "[:arg1 | | temp1 temp2 | ...]". The block may reference variables outside its scope directly by name. It also may return from its home context by using ^, otherwise, the value of the last statement is returned to the sender of valueWithArguments:.
Structure:
method CompiledMethod2
Contains the block's code. It has its own method separate from its home method.
environment ClosureEnvironment | Object
The lexical environment the block was created in. The environment only contains variables that were captured/reference by this block or other sister blocks. If only self and/or its instance variables are captured then the environment is simply the receiver object.
Each non-inlined blocks has its own CompiledMethod. These block methods are held in the literals of the home method and sent the #createBlock: message at runtime to create BlockClosures. Home method temps captured by inner blocks are placed inside a ClosureEnvironment when the home method is started. This environment is supplied as the argument to each #createBlock:. When #value... is sent to a block closure, its method is executed in a new MethodContext with its closure environment as the receiver. The block method accesses its free variables (captured home temps) via this environment.
Closure environments are nested mirroring the nesting of blocks. Each environment points to its parent environment (the top method environment has no parent). However, for efficiency, environments that have no captured temps are skipped (never created). For example, an environment's parent may actually be its grand-parent. There is no special parent variable in ClosureEnvironment, it is just another named variable such as 'self' or 'parent env' (special var with space so it can't be referenced by user code), or it may not be their at all.
A block closure that returns to its home context does so by finding the thisContext sender that owns the top environment. A return inside a block forces the home environment to be created even if it has no captured temps. Each context holds its local environment (which holds its captured temps) in its #myEnv instance variable (previously the unused #receiverMap variable). Code that references captured temps goes through the #myEnv context variable.
Block closures are totally separate from their home context. They are reentrant and each activation has its own block-local temps. So except for the thisContext psuedo-variable, contexts are now LIFO (assuming we get rid of old block contexts and recompile the whole image).
!
----- Method: BlockClosure>>= (in category 'comparing') -----
= other
self class == other class ifFalse: [^ false].
self env = other env ifFalse: [^ false].
^ self method = other method!
----- 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)"
^ MethodContext
sender: nil
receiver: environment
method: method
arguments: #()!
----- Method: BlockClosure>>assert (in category 'exceptions') -----
assert
self assert: self!
----- Method: BlockClosure>>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.' ]!
----- Method: BlockClosure>>callCC (in category 'scheduling') -----
callCC
"Call with current continuation, ala Scheme.
Evaluate self against a copy of the sender's call stack, which can be resumed later"
^ self value: thisContext sender asContinuation!
----- Method: BlockClosure>>copyForSaving (in category 'private') -----
copyForSaving
"obsolete"!
----- 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!
----- 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!
----- Method: BlockClosure>>durationToRun (in category 'evaluating') -----
durationToRun
"Answer the duration taken to execute this block."
^ Duration milliSeconds: self timeToRun
!
----- Method: BlockClosure>>ensure: (in category 'exceptions') -----
ensure: aBlock
"Evaluate a termination block after evaluating the receiver, regardless of whether the receiver's evaluation completes."
| returnValue b |
<primitive: 198>
returnValue := self value.
"aBlock wasn't nil when execution of this method began; it is nil'd out by the unwind machinery, and that's how we know it's already been evaluated ... otherwise, obviously, it needs to be evaluated"
aBlock == nil ifFalse: [
"nil out aBlock temp before evaluating aBlock so it is not executed again if aBlock remote returns"
b _ aBlock.
thisContext tempAt: 1 put: nil. "aBlock _ nil"
b value.
].
^ returnValue!
----- Method: BlockClosure>>env (in category 'accessing') -----
env
^ environment!
----- Method: BlockClosure>>env: (in category 'initializing') -----
env: aClosureEnvironment
"the outer environment"
environment _ aClosureEnvironment!
----- Method: BlockClosure>>fixTemps (in category 'private') -----
fixTemps
"obsolete"!
----- Method: BlockClosure>>fork (in category 'scheduling') -----
fork
"Create and schedule a Process running the code in the receiver."
^ self newProcess resume!
----- Method: BlockClosure>>forkAndWait (in category 'scheduling') -----
forkAndWait
"Suspend current process while self runs"
| semaphore |
semaphore _ Semaphore new.
[self ensure: [semaphore signal]] fork.
semaphore wait.
!
----- 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!
----- 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!
----- 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!
----- Method: BlockClosure>>hasLiteralSuchThat: (in category 'accessing') -----
hasLiteralSuchThat: testBlock
(testBlock value: method) ifTrue: [^ true].
^ method hasLiteralSuchThat: testBlock!
----- Method: BlockClosure>>hasLiteralThorough: (in category 'accessing') -----
hasLiteralThorough: literal
"Answer true if literal is identical to any literal imbedded in my method"
method == literal ifTrue: [^ true].
^ method hasLiteralThorough: literal!
----- Method: BlockClosure>>hasMethodReturn (in category 'testing') -----
hasMethodReturn
"Answer whether the receiver has a return ('^') in its code."
^ self method remoteReturns!
----- Method: BlockClosure>>hash (in category 'comparing') -----
hash
^ method hash!
----- Method: BlockClosure>>ifCurtailed: (in category 'exceptions') -----
ifCurtailed: aBlock
"Evaluate the receiver with an abnormal termination action."
<primitive: 198>
^ self value!
----- 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 valueWithPossibleArgs: {ex description. ex receiver}]!
----- Method: BlockClosure>>isBlock (in category 'accessing') -----
isBlock
^ true!
----- Method: BlockClosure>>method (in category 'accessing') -----
method
^ method!
----- Method: BlockClosure>>method: (in category 'initializing') -----
method: compiledMethod
"compiledMethod will be the code I execute when I'm evaluated"
method _ compiledMethod!
----- 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.
Processor terminateActive] asContext
priority: Processor activePriority!
----- Method: BlockClosure>>numArgs (in category 'accessing') -----
numArgs
^ method numArgs!
----- 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!
----- 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 valueWithPossibleArgs: {exception}]
ifFalse: [exception pass]
]!
----- Method: BlockClosure>>printOn: (in category 'printing') -----
printOn: aStream
super printOn: aStream.
aStream space; nextPutAll: self identityHashPrintString!
----- Method: BlockClosure>>reentrant (in category 'private') -----
reentrant!
----- Method: BlockClosure>>repeat (in category 'controlling') -----
repeat
"Evaluate the receiver repeatedly, ending only if the block explicitly returns."
[self value. true] whileTrue!
----- 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!
----- Method: BlockClosure>>simulate (in category 'scheduling') -----
simulate
"Like run except interpret self using Smalltalk instead of VM. It is much slower."
^ self newProcess simulate!
----- Method: BlockClosure>>timeToRun (in category 'evaluating') -----
timeToRun
"Answer the number of milliseconds taken to execute this block."
^ Time millisecondsToRun: self
!
----- Method: BlockClosure>>value (in category 'evaluating') -----
value
"Evaluate the block with no args. Fail if the block expects other than 0 arguments."
^ environment executeMethod: method!
----- Method: BlockClosure>>value: (in category 'evaluating') -----
value: arg1
"Evaluate the block with the given args. Fail if the block expects other than 1 arguments."
^ environment with: arg1 executeMethod: method!
----- Method: BlockClosure>>value:value: (in category 'evaluating') -----
value: arg1 value: arg2
"Evaluate the block with the given args. Fail if the block expects other than 2 arguments."
^ environment with: arg1 with: arg2 executeMethod: method!
----- Method: BlockClosure>>value:value:value: (in category 'evaluating') -----
value: arg1 value: arg2 value: arg3
"Evaluate the block with the given args. Fail if the block expects other than 3 arguments."
^ environment with: arg1 with: arg2 with: arg3 executeMethod: method!
----- Method: BlockClosure>>value:value:value:value: (in category 'evaluating') -----
value: arg1 value: arg2 value: arg3 value: arg4
"Evaluate the block with the given args. Fail if the block expects other than 4 arguments."
^ environment with: arg1 with: arg2 with: arg3 with: arg4 executeMethod: method!
----- Method: BlockClosure>>valueError (in category 'private') -----
valueError
self error: 'Incompatible number of args'!
----- 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]!
----- 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!
----- Method: BlockClosure>>valueWithArguments: (in category 'evaluating') -----
valueWithArguments: anArray
"Evaluate the block with given args. Fail if the block expects other than the given number of arguments."
^ environment withArgs: anArray executeMethod: method!
----- Method: BlockClosure>>valueWithPossibleArgs: (in category 'evaluating') -----
valueWithPossibleArgs: anArray
| n |
(n _ self numArgs) = 0 ifTrue: [^ self value].
n = anArray size ifTrue: [^ self valueWithArguments: anArray].
^ self valueWithArguments: (n > anArray size
ifTrue: [anArray, (Array new: n - anArray size)]
ifFalse: [anArray copyFrom: 1 to: n])!
----- 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."
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)]!
----- 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 done result |
aDuration <= Duration zero ifTrue: [^ timeoutBlock value ].
"the block will be executed in the current process"
theProcess := Processor activeProcess.
delay := aDuration asDelay.
"make a watchdog process"
watchdog := [
delay wait. "wait for timeout or completion"
done ifFalse: [ theProcess signalException: TimedOut ]
] newProcess.
"watchdog needs to run at high priority to do its job"
watchdog priority: Processor timingPriority.
"catch the timeout signal"
^ [ done := false.
watchdog resume. "start up the watchdog"
result := self value. "evaluate the receiver"
done := true. "it has completed, so ..."
delay delaySemaphore signal. "arrange for the watchdog to exit"
result ]
on: TimedOut do: [ :e | timeoutBlock value ].
!
----- Method: BlockClosure>>veryDeepInner: (in category 'private') -----
veryDeepInner: deepCopier
"Do not copy my method (which can be shared because CompiledMethod2 are basically treated as immutables) or my home context (MethodContexts are treated as immutables too)"
super veryDeepInner: deepCopier.
method _ method.
environment _ environment.
!
----- 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: []!
----- 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]!
----- 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: []!
----- 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]!
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.!
----- Method: Boolean class>>ccg:emitLoadFor:from:on: (in category 'plugin generation') -----
ccg: cg emitLoadFor: aString from: anInteger on: aStream
cg emitLoad: aString asBooleanValueFrom: anInteger on: aStream !
----- Method: Boolean class>>ccg:generateCoerceToOopFrom:on: (in category 'plugin generation') -----
ccg: cg generateCoerceToOopFrom: aNode on: aStream
cg generateCoerceToBooleanObjectFrom: aNode on: aStream!
----- Method: Boolean class>>ccg:generateCoerceToValueFrom:on: (in category 'plugin generation') -----
ccg: cg generateCoerceToValueFrom: aNode on: aStream
cg generateCoerceToBooleanValueFrom: aNode on: aStream!
----- Method: Boolean class>>ccg:prolog:expr:index: (in category 'plugin generation') -----
ccg: cg prolog: aBlock expr: aString index: anInteger
^cg ccgLoad: aBlock expr: aString asBooleanValueFrom: anInteger!
----- Method: Boolean class>>initializedInstance (in category 'instance creation') -----
initializedInstance
^ nil!
----- Method: Boolean class>>new (in category 'instance creation') -----
new
self error: 'You may not create any more Booleans - this is two-valued logic'!
----- 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!
----- 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!
----- 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!
----- 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!
----- 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!
----- 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."!
----- 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."!
----- Method: Boolean>>eqv: (in category 'logical operations') -----
eqv: aBoolean
"Answer true if the receiver is equivalent to aBoolean."
^self == aBoolean!
----- 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!
----- Method: Boolean>>ifFalse:ifTrue: (in category 'controlling') -----
ifFalse: falseAlternativeBlock ifTrue: trueAlternativeBlock
"Same as ifTrue:ifFalse:."
self subclassResponsibility!
----- 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!
----- 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!
----- 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!
----- 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!
----- 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!
----- 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!
----- 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!
----- 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."!
----- Method: Boolean>>storeOn: (in category 'printing') -----
storeOn: aStream
"Refer to the comment in Object|storeOn:."
self printOn: aStream!
----- Method: Boolean>>veryDeepCopyWith: (in category 'copying') -----
veryDeepCopyWith: deepCopier
"Return self. I can't be copied. Do not record me."!
----- Method: Boolean>>xor: (in category 'logical operations') -----
xor: aBoolean
"Exclusive OR. Answer true if the receiver is not equivalent to aBoolean."
^(self == aBoolean) not!
----- 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!
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.!
----- Method: False class>>initializedInstance (in category 'as yet unclassified') -----
initializedInstance
^ false!
----- Method: False>>& (in category 'logical operations') -----
& alternativeObject
"Evaluating conjunction -- answer false since receiver is false."
^self!
----- Method: False>>and: (in category 'controlling') -----
and: alternativeBlock
"Nonevaluating conjunction -- answer with false since the receiver is false."
^self!
----- Method: False>>asBit (in category 'printing') -----
asBit
^ 0!
----- 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!
----- 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!
----- 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!
----- 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!
----- Method: False>>not (in category 'logical operations') -----
not
"Negation -- answer true since the receiver is false."
^true!
----- Method: False>>or: (in category 'controlling') -----
or: alternativeBlock
"Nonevaluating disjunction -- answer value of alternativeBlock."
^alternativeBlock value!
----- Method: False>>printOn: (in category 'printing') -----
printOn: aStream
aStream nextPutAll: 'false'!
----- Method: False>>| (in category 'logical operations') -----
| aBoolean
"Evaluating disjunction (OR) -- answer with the argument, aBoolean."
^aBoolean!
Boolean subclass: #True
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Kernel-Objects'!
!True commentStamp: '<historical>' prior: 0!
True defines the behavior of its single instance, true -- logical assertion. Notice how the truth-value checks become direct message sends, without the need for explicit testing.
Be aware however that most of these methods are not sent as real messages in normal use. Most are inline coded by the compiler as test and jump bytecodes - avoiding the overhead of the full message sends. So simply redefining these methods here will have no effect.!
----- Method: True class>>initializedInstance (in category 'as yet unclassified') -----
initializedInstance
^ true!
----- Method: True>>& (in category 'logical operations') -----
& alternativeObject
"Evaluating conjunction -- answer alternativeObject since receiver is true."
^alternativeObject!
----- Method: True>>and: (in category 'controlling') -----
and: alternativeBlock
"Nonevaluating conjunction -- answer the value of alternativeBlock since
the receiver is true."
^alternativeBlock value!
----- Method: True>>asBit (in category 'printing') -----
asBit
^ 1!
----- Method: True>>ifFalse: (in category 'controlling') -----
ifFalse: alternativeBlock
"Since the condition is true, the value is the true alternative, which is nil.
Execution does not actually reach here because the expression is compiled
in-line."
^nil!
----- Method: True>>ifFalse:ifTrue: (in category 'controlling') -----
ifFalse: falseAlternativeBlock ifTrue: trueAlternativeBlock
"Answer the value of trueAlternativeBlock. Execution does not
actually reach here because the expression is compiled in-line."
^trueAlternativeBlock value!
----- Method: True>>ifTrue: (in category 'controlling') -----
ifTrue: alternativeBlock
"Answer the value of alternativeBlock. Execution does not actually
reach here because the expression is compiled in-line."
^alternativeBlock value!
----- Method: True>>ifTrue:ifFalse: (in category 'controlling') -----
ifTrue: trueAlternativeBlock ifFalse: falseAlternativeBlock
"Answer with the value of trueAlternativeBlock. Execution does not
actually reach here because the expression is compiled in-line."
^trueAlternativeBlock value!
----- Method: True>>not (in category 'logical operations') -----
not
"Negation--answer false since the receiver is true."
^false!
----- Method: True>>or: (in category 'controlling') -----
or: alternativeBlock
"Nonevaluating disjunction -- answer true since the receiver is true."
^self!
----- Method: True>>printOn: (in category 'printing') -----
printOn: aStream
aStream nextPutAll: 'true'!
----- Method: True>>| (in category 'logical operations') -----
| aBoolean
"Evaluating disjunction (OR) -- answer true since the receiver is true."
^self!
Object subclass: #Categorizer
instanceVariableNames: 'categoryArray categoryStops elementArray'
classVariableNames: 'Default NullCategory'
poolDictionaries: ''
category: 'Kernel-Classes'!
Categorizer subclass: #BasicClassOrganizer
instanceVariableNames: 'subject classComment commentStamp'
classVariableNames: ''
poolDictionaries: ''
category: 'Kernel-Classes'!
----- Method: BasicClassOrganizer class>>class: (in category 'instance creation') -----
class: aClassDescription
^ self new setSubject: aClassDescription!
----- Method: BasicClassOrganizer class>>class:defaultList: (in category 'instance creation') -----
class: aClassDescription defaultList: aSortedCollection
| inst |
inst _ self defaultList: aSortedCollection.
inst setSubject: aClassDescription.
^ inst!
----- Method: BasicClassOrganizer>>classComment (in category 'accessing') -----
classComment
classComment
ifNil: [^ ''].
^ classComment text ifNil: ['']!
----- 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?"!
----- 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?"!
----- Method: BasicClassOrganizer>>commentRemoteStr (in category 'accessing') -----
commentRemoteStr
^ classComment!
----- Method: BasicClassOrganizer>>commentStamp (in category 'accessing') -----
commentStamp
"Answer the comment stamp for the class"
^ commentStamp!
----- Method: BasicClassOrganizer>>commentStamp: (in category 'accessing') -----
commentStamp: aStamp
commentStamp _ aStamp!
----- 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]!
----- 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 notNil and: [classComment text notNil]) ifTrue:
[aFileStream cr.
fileComment _ RemoteString newString: classComment text
onFileNumber: fileIndex toFile: aFileStream.
moveSource ifTrue: [classComment _ fileComment]]!
----- Method: BasicClassOrganizer>>hasNoComment (in category 'accessing') -----
hasNoComment
"Answer whether the class classified by the receiver has a comment."
^classComment == nil!
----- Method: BasicClassOrganizer>>hasSubject (in category 'accessing') -----
hasSubject
^ self subject notNil!
----- 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]!
----- 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"
!
----- 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 notNil and: [classComment text notNil]) ifTrue:
[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]!
----- Method: BasicClassOrganizer>>setSubject: (in category 'private') -----
setSubject: aClassDescription
subject _ aClassDescription!
----- Method: BasicClassOrganizer>>subject (in category 'accessing') -----
subject
^ subject.!
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!!!
----- Method: ClassOrganizer>>addCategory:before: (in category 'accessing') -----
addCategory: catString before: nextCategory
| oldCategories |
oldCategories _ self categories copy.
SystemChangeNotifier uniqueInstance doSilently: [
super addCategory: catString before: nextCategory].
self notifyOfChangedCategoriesFrom: oldCategories to: self categories.!
----- 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.!
----- Method: ClassOrganizer>>classify:under:suppressIfDefault: (in category 'accessing') -----
classify: element under: heading suppressIfDefault: aBoolean
| 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.!
----- Method: ClassOrganizer>>notifyOfChangedCategoriesFrom:to: (in category 'private') -----
notifyOfChangedCategoriesFrom: oldCollectionOrNil to: newCollectionOrNil
(self hasSubject and: [oldCollectionOrNil ~= newCollectionOrNil])
ifTrue: [SystemChangeNotifier uniqueInstance classReorganized: self subject].!
----- Method: ClassOrganizer>>notifyOfChangedCategoryFrom:to: (in category 'private') -----
notifyOfChangedCategoryFrom: oldNameOrNil to: newNameOrNil
(self hasSubject and: [oldNameOrNil ~= newNameOrNil])
ifTrue: [SystemChangeNotifier uniqueInstance classReorganized: self subject].!
----- Method: ClassOrganizer>>notifyOfChangedSelector:from:to: (in category 'private') -----
notifyOfChangedSelector: element from: oldCategory to: newCategory
(self hasSubject and: [(oldCategory ~= newCategory)]) ifTrue: [
SystemChangeNotifier uniqueInstance selector: element recategorizedFrom: oldCategory to: newCategory inClass: self subject
].!
----- Method: ClassOrganizer>>notifyOfChangedSelectorsOldDict:newDict: (in category 'private') -----
notifyOfChangedSelectorsOldDict: oldDictionaryOrNil newDict: newDictionaryOrNil
| newCat |
(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 _ newDictionaryOrNil at: el.
self notifyOfChangedSelector: el from: cat to: newCat.
].!
----- Method: ClassOrganizer>>removeCategory: (in category 'accessing') -----
removeCategory: cat
| oldCategories |
oldCategories _ self categories copy.
SystemChangeNotifier uniqueInstance doSilently: [
super removeCategory: cat].
self notifyOfChangedCategoriesFrom: oldCategories to: self categories.!
----- 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).!
----- Method: ClassOrganizer>>removeEmptyCategories (in category 'accessing') -----
removeEmptyCategories
| oldCategories |
oldCategories _ self categories copy.
SystemChangeNotifier uniqueInstance doSilently: [
super removeEmptyCategories].
self notifyOfChangedCategoriesFrom: oldCategories to: self categories.!
----- Method: ClassOrganizer>>renameCategory:toBe: (in category 'accessing') -----
renameCategory: oldCatString toBe: newCatString
| oldCat newCat oldElementsBefore oldElementsAfter |
oldCat _ oldCatString asSymbol.
newCat _ newCatString asSymbol.
oldElementsBefore _ self listAtCategoryNamed: oldCat.
SystemChangeNotifier uniqueInstance doSilently: [
super renameCategory: oldCatString toBe: newCatString].
oldElementsAfter _ (self listAtCategoryNamed: oldCat) asSet.
oldElementsBefore do: [:each |
(oldElementsAfter includes: each)
ifFalse: [self notifyOfChangedSelector: each from: oldCat to: newCat].
].
self notifyOfChangedCategoryFrom: oldCat to: newCat.!
----- 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.!
----- Method: ClassOrganizer>>sortCategories (in category 'accessing') -----
sortCategories
| oldCategories |
oldCategories _ self categories copy.
SystemChangeNotifier uniqueInstance doSilently: [
super sortCategories].
self notifyOfChangedCategoriesFrom: oldCategories to: self categories.!
----- Method: Categorizer class>>allCategory (in category 'class initialization') -----
allCategory
"Return a symbol that represents the virtual all methods category."
^ '-- all --' asSymbol!
----- Method: Categorizer class>>default (in category 'class initialization') -----
default
^ Default!
----- 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!
----- 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." !
----- Method: Categorizer class>>initialize (in category 'class initialization') -----
initialize
" self initialize "
Default _ 'as yet unclassified' asSymbol.
NullCategory _ 'no messages' asSymbol.!
----- Method: Categorizer class>>nullCategory (in category 'class initialization') -----
nullCategory
^ NullCategory!
----- Method: Categorizer class>>sortAllCategories (in category 'housekeeping') -----
sortAllCategories
self allSubInstances
do: [:x | x sortCategories]!
----- Method: Categorizer>>addCategory: (in category 'accessing') -----
addCategory: newCategory
^ self addCategory: newCategory before: nil !
----- 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]!
----- Method: Categorizer>>allMethodSelectors (in category 'accessing') -----
allMethodSelectors
"give a list of all method selectors."
^ elementArray copy sort!
----- Method: Categorizer>>categories (in category 'accessing') -----
categories
"Answer an Array of categories (names)."
categoryArray isNil ifTrue: [^ nil].
(categoryArray size = 1
and: [categoryArray first = Default & (elementArray size = 0)])
ifTrue: [^Array with: NullCategory].
^categoryArray!
----- 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 |
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!
----- 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]!
----- 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."
| oldElements newElements newCategories newStops currentStop temp ii cc catSpec |
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 | | 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 _ categoryArray indexOf: dup.
[dup _ (dup,' #2') asSymbol. cc includes: dup] whileTrue.
cc add: dup.
categoryArray at: ii put: dup]].
categoryStops _ newStops.
elementArray _ newElements.
oldElements do: [:pair | self classify: pair last under: pair first].!
----- 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!
----- Method: Categorizer>>classify:under: (in category 'accessing') -----
classify: element under: heading
self classify: element under: heading suppressIfDefault: true!
----- 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 removeElement: 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].
(self listAtCategoryNamed: Default) size = 0 ifTrue: [self removeCategory: Default]!
----- Method: Categorizer>>classifyAll:under: (in category 'accessing') -----
classifyAll: aCollection under: heading
aCollection do:
[:element | self classify: element under: heading]!
----- Method: Categorizer>>elementArray (in category 'private') -----
elementArray
^ elementArray!
----- 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.!
----- Method: Categorizer>>firstIndexOfCategoryNumber: (in category 'private') -----
firstIndexOfCategoryNumber: anInteger
anInteger < 1 ifTrue: [^ nil].
^ (anInteger > 1
ifTrue: [(categoryStops at: anInteger - 1) + 1]
ifFalse: [1]).!
----- Method: Categorizer>>isEmptyCategoryNamed: (in category 'accessing') -----
isEmptyCategoryNamed: categoryName
| i |
i _ categoryArray indexOf: categoryName ifAbsent: [^false].
^self isEmptyCategoryNumber: i!
----- 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!
----- Method: Categorizer>>lastIndexOfCategoryNumber: (in category 'private') -----
lastIndexOfCategoryNumber: anInteger
anInteger > categoryStops size ifTrue: [^ nil].
^ categoryStops at: anInteger!
----- 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!
----- 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!
----- 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!
----- 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]!
----- Method: Categorizer>>printOnStream: (in category 'printing') -----
printOnStream: aStream
"Refer to the comment in Object|printOn:."
| elementIndex |
elementIndex _ 1.
1 to: categoryArray size do:
[:i |
aStream print: '(';
write:(categoryArray at:i). " is the asString redundant? "
[elementIndex <= (categoryStops at: i)]
whileTrue:
[aStream print:' '; write:(elementArray at: elementIndex).
elementIndex _ elementIndex + 1].
aStream print:')'.
aStream cr]!
----- 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]
!
----- Method: Categorizer>>removeElement: (in category 'accessing') -----
removeElement: 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!
----- 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]."!
----- 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!
----- 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.!
----- Method: Categorizer>>setDefaultList: (in category 'private') -----
setDefaultList: aSortedCollection
categoryArray _ Array with: Default.
categoryStops _ Array with: aSortedCollection size.
elementArray _ aSortedCollection asArray!
----- 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 asSortedCollection asOrderedCollection
addAll: privateCategories asSortedCollection;
asArray.
self categories: newCategories!
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.
!
----- Method: ClassBuilder class>>beSilent: (in category 'accessing') -----
beSilent: aBool
"ClassDefiner beSilent: true"
"ClassDefiner beSilent: false"
QuietMode _ aBool.!
----- 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!
----- 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"
Utilities informUserDuring:[:bar|
self checkClassHierarchyConsistency: bar.
].!
----- 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'.!
----- 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!!']
].!
----- 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."
Utilities informUserDuring:[:bar|
self cleanupAndCheckClassHierarchy: bar.
].
!
----- 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.!
----- Method: ClassBuilder class>>cleanupClassHierarchy (in category 'cleanup obsolete classes') -----
cleanupClassHierarchy
"Makes the class hierarchy consistent and removes obsolete classes from the SystemDictionary."
Utilities informUserDuring:[:bar|
self cleanupClassHierarchy: bar.
].!
----- 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'.!
----- 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 keys asArray do: [:each |
(each asString = myName and: [(Smalltalk at: each) == aClassDescription])
ifTrue: [Smalltalk 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]].
!
----- 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!!!!'].!
----- 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]!
----- Method: ClassBuilder class>>isSilent (in category 'accessing') -----
isSilent
^QuietMode == true!
----- 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!
----- Method: ClassBuilder class>>reallyObsoleteMetaclasses (in category 'cleanup obsolete classes') -----
reallyObsoleteMetaclasses
^ Metaclass allInstances select: [:each | self isReallyObsolete: each].!
----- 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!
----- 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!
----- Method: ClassBuilder>>computeFormat:instSize:forSuper:ccIndex: (in category 'class format') -----
computeFormat: type instSize: newInstSize forSuper: newSuper ccIndex: ccIndex
"Compute the new format for making oldClass a subclass of newSuper.
Return the format or nil if there is any problem."
| instSize isVar isWords isPointers isWeak |
instSize _ newInstSize + (newSuper ifNil:[0] ifNotNil:[newSuper instSize]).
instSize > 254 ifTrue:[
self error: 'Class has too many instance variables (', instSize printString,')'.
^nil].
type == #compiledMethod
ifTrue:[^CompiledMethod instSpec].
type == #normal ifTrue:[isVar _ isWeak _ false. isWords _ isPointers _ true].
type == #bytes ifTrue:[isVar _ true. isWords _ isPointers _ isWeak _ false].
type == #words ifTrue:[isVar _ isWords _ true. isPointers _ isWeak _ false].
type == #variable ifTrue:[isVar _ isPointers _ isWords _ true. isWeak _ false].
type == #weak ifTrue:[isVar _ isWeak _ isWords _ isPointers _ true].
(isPointers not and:[instSize > 0]) ifTrue:[
self error:'A non-pointer class cannot have instance variables'.
^nil].
^(self format: instSize
variable: isVar
words: isWords
pointers: isPointers
weak: isWeak) + (ccIndex bitShift: 11).!
----- Method: ClassBuilder>>doneCompiling: (in category 'initialize') -----
doneCompiling: aClass
"The receiver has finished modifying the class hierarchy.
Do any necessary cleanup."
aClass doneCompiling.
Behavior flushObsoleteSubclasses.!
----- Method: ClassBuilder>>format:variable:words:pointers:weak: (in category 'class format') -----
format: nInstVars variable: isVar words: isWords pointers: isPointers weak: isWeak
"Compute the format for the given instance specfication."
| cClass instSpec sizeHiBits fmt |
self flag: #instSizeChange.
"
Smalltalk browseAllCallsOn: #instSizeChange.
Smalltalk browseAllImplementorsOf: #fixedFieldsOf:.
Smalltalk browseAllImplementorsOf: #instantiateClass:indexableSize:.
"
"
NOTE: This code supports the backward-compatible extension to 8 bits of instSize.
For now the format word is...
<2 bits=instSize//64><5 bits=cClass><4 bits=instSpec><6 bits=instSize\\64><1 bit=0>
But when we revise the image format, it should become...
<5 bits=cClass><4 bits=instSpec><8 bits=instSize><1 bit=0>
"
sizeHiBits _ (nInstVars+1) // 64.
cClass _ 0. "for now"
instSpec _ isWeak
ifTrue:[4]
ifFalse:[isPointers
ifTrue: [isVar
ifTrue: [nInstVars>0 ifTrue: [3] ifFalse: [2]]
ifFalse: [nInstVars>0 ifTrue: [1] ifFalse: [0]]]
ifFalse: [isWords ifTrue: [6] ifFalse: [8]]].
fmt _ sizeHiBits.
fmt _ (fmt bitShift: 5) + cClass.
fmt _ (fmt bitShift: 4) + instSpec.
fmt _ (fmt bitShift: 6) + ((nInstVars+1)\\64). "+1 since prim size field includes header"
fmt _ (fmt bitShift: 1). "This shift plus integer bit lets wordSize work like byteSize"
^fmt!
----- Method: ClassBuilder>>informUserDuring: (in category 'private') -----
informUserDuring: aBlock
self class isSilent ifTrue:[^aBlock value].
Utilities informUserDuring:[:bar|
progress _ bar.
aBlock value].
progress _ nil.!
----- Method: ClassBuilder>>initialize (in category 'initialize') -----
initialize
environ _ Smalltalk.
instVarMap _ IdentityDictionary new.!
----- 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!
----- 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."
| newSubclass |
self showProgressFor: oldClass.
"Convert the subclasses"
oldClass subclasses do:[:oldSubclass|
newSubclass _ self reshapeClass: oldSubclass toSuper: newClass.
self mutate: oldSubclass to: newSubclass.
].
"And any obsolete ones"
oldClass obsoleteSubclasses do:[:oldSubclass|
oldSubclass ifNotNil:[
newSubclass _ self reshapeClass: oldSubclass toSuper: newClass.
self mutate: oldSubclass to: newSubclass.
].
].
self update: oldClass to: newClass.
^newClass!
----- 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!
----- 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 newClass organization instVars classVars force needNew oldCategory copyOfOldClass newCategory |
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:"
copyOfOldClass _ oldClass copy.
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.
] 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.
newClass environment: environ.
"... 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].
Smalltalk flushClassNameCache.
].
self doneCompiling: newClass.
"... notify interested clients ..."
oldClass isNil ifTrue: [
SystemChangeNotifier uniqueInstance classAdded: newClass inCategory: newCategory.
^ newClass].
SystemChangeNotifier uniqueInstance classDefinitionChangedFrom: copyOfOldClass to: newClass.
newCategory ~= oldCategory
ifTrue: [SystemChangeNotifier uniqueInstance class: newClass recategorizedFrom: oldCategory to: category].
^newClass!
----- 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
ccIndex: (oldClass ifNil:[0] ifNotNil:[oldClass indexIfCompact]).
newFormat == nil ifTrue:[^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
!
----- 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
ccIndex: (oldClass ifNil:[0] ifNotNil:[oldClass indexIfCompact]).
newFormat == nil ifTrue:[^nil].
(oldClass == nil or:[oldClass isMeta not])
ifTrue:[newClass _ self privateNewSubclassOf: newSuper from: oldClass]
ifFalse:[newClass _ oldClass clone].
newClass
superclass: newSuper
methodDictionary: MethodDictionary new
format: newFormat;
setInstVarNames: instVars.
oldClass ifNotNil:[
newClass organization: oldClass organization.
"Recompile the new class"
oldClass hasMethods
ifTrue:[newClass compileAllFrom: oldClass].
self recordClass: oldClass replacedBy: newClass.
].
(oldClass == nil or:[oldClass isObsolete not])
ifTrue:[newSuper addSubclass: newClass]
ifFalse:[newSuper addObsoleteSubclass: newClass].
^newClass!
----- 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
!
----- 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: MethodDictionary new
format: (self computeFormat: oldMeta typeOfClass
instSize: oldMeta instVarNames size
forSuper: newSuperMeta
ccIndex: 0);
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!
----- 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].
newClass withAllSubclassesDo:[:cl|
self showProgressFor: cl.
cl compileAll]].
^newClass].
"Recompile and mutate oldClass to newClass"
self informUserDuring:[
newClass isSystemDefined ifFalse:[progress _ nil].
self mutate: oldClass to: newClass.
].
^oldClass "now mutated to newClass"!
----- 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.
].!
----- 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).!
----- 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 |
"ar 9/22/2002: The following is a left-over from some older code.
I do *not* know why we uncompact oldClass here. If you do, then
please let me know so I can put a comment here..."
oldClass becomeUncompact.
instVars _ instVarMap at: oldClass name ifAbsent:[oldClass instVarNames].
^self newSubclassOf: newSuper
type: oldClass typeOfClass
instanceVariables: instVars
from: oldClass!
----- 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,')')]!
----- 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.!
----- 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."
^self
name: t
inEnvironment: newSuper environment
subclassOf: newSuper
type: newSuper typeOfClass
instanceVariableNames: f
classVariableNames: d
poolDictionaries: s
category: cat!
----- 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."
(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'].
^self
name: t
inEnvironment: aClass environment
subclassOf: aClass
type: #bytes
instanceVariableNames: f
classVariableNames: d
poolDictionaries: s
category: cat!
----- 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."
aClass isBits
ifTrue: [^self error: 'cannot make a pointer subclass of a class with non-pointer fields'].
^self
name: t
inEnvironment: aClass environment
subclassOf: aClass
type: #variable
instanceVariableNames: f
classVariableNames: d
poolDictionaries: s
category: cat!
----- 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."
(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'].
^self
name: t
inEnvironment: aClass environment
subclassOf: aClass
type: #words
instanceVariableNames: f
classVariableNames: d
poolDictionaries: s
category: cat!
----- 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."
aClass isBits
ifTrue: [^self error: 'cannot make a pointer subclass of a class with non-pointer fields'].
^self
name: t
inEnvironment: aClass environment
subclassOf: aClass
type: #weak
instanceVariableNames: f
classVariableNames: d
poolDictionaries: s
category: cat!
----- 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"
Object
"Contexts and their superclasses"
InstructionStream ContextPart BlockContext MethodContext
"Superclasses of basic collections"
Collection SequenceableCollection ArrayedCollection
"Collections known to the VM"
Array Bitmap String Symbol ByteArray CompiledMethod TranslatedMethod
"Basic Numbers"
Magnitude Number SmallInteger Float
"Misc other"
LookupKey Association Link Point Rectangle Behavior PositionableStream UndefinedObject
)
!
----- 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 pointer to any old instances. After the forwarding become there will be no pointers to the old class or meta class either. Meaning that if we throw in a nice fat GC at the end of the critical block, everything will be gone (but see the comment right there). There's no need to worry.
"
| meta |
meta _ oldClass isMeta.
"Note: Everything from here on will run without the ability to get interrupted
to prevent any other process to create new instances of the old class."
[
"Note: The following removal may look somewhat obscure and needs an explanation. When we mutate the class hierarchy we create new classes for any existing subclass. So it may look as if we don't have to remove the old class from its superclass. However, at the top of the hierarchy (the first class we reshape) that superclass itself is not newly created so therefore it will hold both the oldClass and newClass in its (obsolete or not) subclasses. Since the #become: below will transparently replace the pointers to oldClass with newClass the superclass would have newClass in its subclasses TWICE. With rather unclear effects if we consider that we may convert the meta-class hierarchy itself (which is derived from the non-meta class hierarchy).
Due to this problem ALL classes are removed from their superclass just prior to converting them. Here, breaking the superclass/subclass invariant really doesn't matter since we will effectively remove the oldClass (become+GC) just a few lines below."
oldClass superclass removeSubclass: oldClass.
oldClass superclass removeObsoleteSubclass: oldClass.
"Convert the instances of oldClass into instances of newClass"
newClass updateInstancesFrom: oldClass.
meta
ifTrue:[oldClass becomeForward: newClass]
ifFalse:[(Array with: oldClass with: oldClass class)
elementsForwardIdentityTo:
(Array with: newClass with: newClass class)].
Smalltalk garbageCollect.
"Warning: Read this before you even think about removing the GC. Yes, it slows us down. Quite heavily if you have a large image. However, there's no good and simple alternative here, since unfortunately, #become: does change class pointers. What happens is that after the above become all of the instances of the old class will have a class pointer identifying them as instances of newClass. If we get our hands on any of these instances we will break immediately since their expected instance layout (that of its class, e.g., newClass) will not match their actual instance layout (that of oldClass). And getting your hands on any of those instances is really simple - just reshaping one class two times in rapid succession will do it. Reflection techniques, interrupts, etc. will only add to this problem. In the case of Metaclass things get even worse since when we recompile the entire class hierarchy we will recompile both, Metaclass and its instances (and some of its instances will have the old and some the new layout).
The only easy solution to this problem would be to 'fix up' the class pointers of the old instances to point to the old class (using primitiveChangeClassTo:). But this won't work either - as we do a one-way become we would have to search the entire object memory for the oldClass and couldn't even clearly identify it unless we give it some 'special token' which sounds quite error-prone. If you really need to get rid of the GC here are some alternatives:
On the image level, one could create a copy of the oldClass before becoming it into the new class and, after becoming it, 'fix up' the old instances. That would certainly work but it sounds quite complex, as we need to make sure we're not breaking any of the superclass/subclass meta/non-meta class variants.
Alternatively, fix up #becomeForward on the VM-level to 'dump the source objects' of #become. This would be quite doable (just 'convert' them into a well known special class such as bitmap) yet it has problems if (accidentally or not) one of the objects in #become: appears on 'both sides of the fence' (right now, this will work ... in a way ... even though the consequences are unclear).
Another alternative is to provide a dedicated primitive for this (instead of using it implicitly in become) which would allow us to dump all the existing instances right here. This is equivalent to a more general primitiveChangeClassTo: and might be worthwhile but it would likely have to keep in mind the differences between bits and pointer thingies etc.
Since all of the alternatives seem rather complex and magical compared to a straight-forward GC it seems best to stick with the GC solution for now. If someone has a real need to fix this problem, that person will likely be motivated enough to check out the alternatives. Personally I'd probably go for #1 (copy the old class and remap the instances to it) since it's a solution that could be easily reverted from within the image if there's any problem with it."
] valueUnpreemptively.
!
----- 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 forgetDoIts.
(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!
----- 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!
----- 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!
----- 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]].
self error: iv, ' is already defined in ', temp name.
^false]]].
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:[
self error: iv, ' is already defined in a subclass of ', oldClass name.
^false]]].
^true!
----- 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]].
self error: iv,' is already defined in ', temp name.
^false]]].
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:[
self error: iv, ' is already defined in a subclass of ', oldClass name.
^false]]].
^true!
----- 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"
"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!
----- 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!
----- 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!
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.!
----- 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: (SyntaxError new category: category)]!
----- 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 parserClass new parseSelector: methodText.
(class compiledMethodAt: selector) putSource: methodText
fromParseNode: nil class: class category: category
withStamp: changeStamp inFile: 2 priorMethod: nil]]!
----- Method: ClassCategoryReader>>scanFromNoCompile:forSegment: (in category 'fileIn/Out') -----
scanFromNoCompile: aStream forSegment: anImageSegment
^self scanFromNoCompile: aStream "subclasses may care about the segment"!
----- Method: ClassCategoryReader>>setClass:category: (in category 'private') -----
setClass: aClass category: aCategory
^ self setClass: aClass category: aCategory changeStamp: String new
!
----- Method: ClassCategoryReader>>setClass:category:changeStamp: (in category 'private') -----
setClass: aClass category: aCategory changeStamp: aString
class _ aClass.
category _ aCategory.
changeStamp _ aString
!
----- Method: ClassCategoryReader>>theClass (in category 'private') -----
theClass
^ class!
ClassCategoryReader subclass: #ClassCommentReader
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Kernel-Classes'!
----- 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"!
----- 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"!
ClassCategoryReader subclass: #RenamedClassSourceReader
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Kernel-Classes'!
----- Method: RenamedClassSourceReader class>>formerClassName:methodsFor:stamp: (in category 'as yet unclassified') -----
formerClassName: formerClassName methodsFor: aCategory stamp: aString
^self new
setClass: formerClassName
category: aCategory
changeStamp: aString!
----- Method: RenamedClassSourceReader class>>scanner (in category 'as yet unclassified') -----
scanner
^self new!
----- Method: RenamedClassSourceReader>>scanFrom: (in category 'as yet unclassified') -----
scanFrom: aStream
self flag: #bob. "should this ever happen?"
self halt.!
----- Method: RenamedClassSourceReader>>scanFromNoCompile: (in category 'as yet unclassified') -----
scanFromNoCompile: aStream
self flag: #bob. "should this ever happen?"
self halt.!
----- Method: RenamedClassSourceReader>>scanFromNoCompile:forSegment: (in category 'as yet unclassified') -----
scanFromNoCompile: aStream forSegment: anImageSegment
"Just move the source code for the methods from aStream."
| methodText d |
[
(methodText _ aStream nextChunkText) size > 0
] whileTrue: [
(SourceFiles at: 2) ifNotNil: [
d _ Dictionary new.
d
at: #oldClassName put: class; "may be 'Player1' or 'Player1 class'"
at: #methodText put: methodText;
at: #changeStamp put: changeStamp;
at: #category put: category.
anImageSegment acceptSingleMethodSource: d.
]
]!
Object variableSubclass: #ClosureEnvironment
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Kernel-Contexts'!
!ClosureEnvironment commentStamp: 'ajh 6/24/2004 03:33' prior: 0!
An environment is a collection of temporary variable values that have escaped the original method context and placed in this environment because blocks existed in the method that reference these variables (and blocks may out live their creating context). Nested blocks create nested environments when temp vars are introduced at multiple levels and referenced at lower levels. So each environment has a parent environment in its first slot. The top environment has the original receiver in it first slot (if referenced by an inner block).
A block consists of its outer environment and a method to execute while the outer environment is in the receiver position.
A block that remote returns from its home context holds the home environment in its outer environment. The remote return unwinds the call stack to the context that created the home context.
!
----- Method: ClosureEnvironment>>= (in category 'as yet unclassified') -----
= other
self class == other class ifFalse: [^ false].
self size = other size ifFalse: [^ false].
1 to: self size do: [:i |
(self at: i) = (other at: i) ifFalse: [^ false].
].
^ true!
----- Method: ClosureEnvironment>>hash (in category 'as yet unclassified') -----
hash
"Answer an integer hash value for the receiver such that,
-- the hash value of an unchanged object is constant over time, and
-- two equal objects have equal hash values"
| hash |
hash _ self species hash.
self size <= 10 ifTrue:
[self do: [:elem | hash _ hash bitXor: elem hash]].
^hash bitXor: self size hash!
----- Method: ClosureEnvironment>>return: (in category 'as yet unclassified') -----
return: value
"Find thisContext sender that is owner of self and return from it"
| home |
home _ thisContext findContextSuchThat: [:ctxt | ctxt myEnv == self].
home return: value!
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!
----- Method: Complex class>>abs:arg: (in category 'instance creation') -----
abs: aNumber1 arg: aNumber2
| real imaginary |
real _ aNumber1 * aNumber2 cos.
imaginary _ aNumber1 * aNumber2 sin.
^ real + imaginary i!
----- Method: Complex class>>new (in category 'instance creation') -----
new
^ self real: 0 imaginary: 0!
----- Method: Complex class>>real:imaginary: (in category 'instance creation') -----
real: aNumber1 imaginary: aNumber2
| newComplex |
newComplex _ super new.
newComplex
real: aNumber1;
imaginary: aNumber2.
^ newComplex!
----- 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: #*]!
----- 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: #+]!
----- 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: #-]!
----- 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: #/.!
----- Method: Complex>>= (in category 'comparing') -----
= anObject
anObject isComplex
ifTrue: [^ (real = anObject real) & (imaginary = anObject imaginary)]
ifFalse: [^ anObject adaptToComplex: self andSend: #=]!
----- Method: Complex>>abs (in category 'arithmetic') -----
abs
"Answer the distance of the receiver from zero (0 + 0 i)."
^ ((real * real) + (imaginary * imaginary)) sqrt!
----- 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]!
----- 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!
----- 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!
----- 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!
----- Method: Complex>>arg (in category 'arithmetic') -----
arg
"Answer the argument of the receiver."
self isZero ifTrue: [self error: 'zero has no argument.'].
0 < real ifTrue: [^ (imaginary / real) arcTan].
0 = real ifTrue:
[0 < imaginary
ifTrue: [^ Float pi / 2]
ifFalse: [^ (Float pi / 2) negated]].
real < 0 ifTrue:
[0 <= imaginary
ifTrue: [^ (imaginary / real) arcTan + Float pi]
ifFalse: [^ (imaginary / real) arcTan - Float pi]]!
----- Method: Complex>>cos (in category 'mathematical functions') -----
cos
"Answer receiver's cosine."
| iself |
iself _ 1 i * self.
^ (iself exp + iself negated exp) / 2!
----- Method: Complex>>cosh (in category 'mathematical functions') -----
cosh
"Answer receiver's hyperbolic cosine."
^ (self exp + self negated exp) / 2!
----- 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: #/.!
----- 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: #/.!
----- Method: Complex>>exp (in category 'mathematical functions') -----
exp
"Answer the exponential of the receiver."
^ real exp * (imaginary cos + (1 i * imaginary sin))!
----- Method: Complex>>hash (in category 'comparing') -----
hash
"Hash is reimplemented because = is implemented."
^ real hash bitXor: imaginary hash.!
----- Method: Complex>>imaginary (in category 'accessing') -----
imaginary
^ imaginary!
----- Method: Complex>>imaginary: (in category 'private') -----
imaginary: aNumber
imaginary _ aNumber.!
----- Method: Complex>>isComplex (in category 'testing') -----
isComplex
^ true!
----- Method: Complex>>isZero (in category 'testing') -----
isZero
^ self = 0!
----- Method: Complex>>ln (in category 'mathematical functions') -----
ln
"Answer the natural log of the receiver."
^ self arg ln + (1 i * self arg)!
----- Method: Complex>>log: (in category 'mathematical functions') -----
log: aNumber
"Answer the log base aNumber of the receiver."
^self ln / aNumber ln!
----- Method: Complex>>negated (in category 'arithmetic') -----
negated
"Answer a Number that is the negation of the receiver."
^0 - self!
----- 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
!
----- Method: Complex>>real (in category 'accessing') -----
real
^ real!
----- Method: Complex>>real: (in category 'private') -----
real: aNumber
real _ aNumber.!
----- 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]
!
----- Method: Complex>>sin (in category 'mathematical functions') -----
sin
"Answer receiver's sine."
| iself |
iself _ 1 i * self.
^ (iself exp - iself negated exp) / 2 i!
----- Method: Complex>>sinh (in category 'mathematical functions') -----
sinh
"Answer receiver's hyperbolic sine."
^ (self exp - self negated exp) / 2!
----- Method: Complex>>squared (in category 'mathematical functions') -----
squared
"Answer the receiver multipled by itself."
^self * self!
----- Method: Complex>>tan (in category 'mathematical functions') -----
tan
"Answer receivers tangent."
^ self sin / self cos!
Object subclass: #Delay
instanceVariableNames: 'delayDuration resumptionTime delaySemaphore beingWaitedOn'
classVariableNames: 'AccessProtect ActiveDelay ActiveDelayStartTime FinishedDelay RunTimerEventLoop ScheduledDelay SuspendedDelays TimerEventLoop TimingSemaphore'
poolDictionaries: ''
category: 'Kernel-Processes'!
!Delay commentStamp: 'ls 10/14/2003 11:46' 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.
The maximum delay is (SmallInteger maxVal // 2) milliseconds, or about six days. A delay in progress when an image snapshot is saved is resumed when the snapshot is re-started. Delays work across millisecond clock roll-overs.
For a more complex example, see #testDelayOf:for:rect: .!
----- Method: Delay class>>anyActive (in category 'testing') -----
anyActive
"Return true if there is any delay currently active"
^ActiveDelay notNil!
----- Method: Delay class>>forDuration: (in category 'instance creation') -----
forDuration: aDuration
^ self forMilliseconds: aDuration asMilliSeconds
!
----- 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
!
----- 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
!
----- 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."
| nextTick |
"Wait until there is work to do."
TimingSemaphore wait.
"Process any schedule requests"
ScheduledDelay ifNotNil:[
"Schedule the given delay"
self scheduleDelay: ScheduledDelay.
ScheduledDelay := nil.
].
"Process any unschedule requests"
FinishedDelay ifNotNil:[
self unscheduleDelay: FinishedDelay.
FinishedDelay := nil.
].
"Check for clock wrap-around."
nextTick := Time millisecondClockValue.
nextTick < ActiveDelayStartTime ifTrue: [
"clock wrapped"
self saveResumptionTimes.
self restoreResumptionTimes.
].
ActiveDelayStartTime := nextTick.
"Signal any expired delays"
[ActiveDelay notNil and:[
Time millisecondClockValue >= ActiveDelay resumptionTime]] whileTrue:[
ActiveDelay signalWaitingProcess.
SuspendedDelays isEmpty
ifTrue: [ActiveDelay := nil]
ifFalse:[ActiveDelay := 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 := Time millisecondClockValue + 1000.
ActiveDelay ifNotNil:[nextTick := nextTick min: ActiveDelay resumptionTime].
nextTick := nextTick min: SmallInteger maxVal.
"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 atMilliseconds: nextTick.
!
----- Method: Delay class>>initialize (in category 'class initialization') -----
initialize
"Delay initialize"
self startTimerEventLoop.!
----- Method: Delay class>>nextWakeUpTime (in category 'testing') -----
nextWakeUpTime
^ AccessProtect
critical: [ActiveDelay isNil
ifTrue: [0]
ifFalse: [ActiveDelay resumptionTime]]!
----- 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
!
----- Method: Delay class>>restoreResumptionTimes (in category 'snapshotting') -----
restoreResumptionTimes
"Private!! Restore the resumption times of all scheduled Delays after a snapshot or clock roll-over. This method should be called only while the AccessProtect semaphore is held."
| newBaseTime |
newBaseTime _ Time millisecondClockValue.
SuspendedDelays do: [:d | d adjustResumptionTimeOldBase: 0 newBase: newBaseTime].
ActiveDelay == nil ifFalse: [
ActiveDelay adjustResumptionTimeOldBase: 0 newBase: newBaseTime.
ActiveDelay activate].
!
----- Method: Delay class>>runTimerEventLoop (in category 'timer process') -----
runTimerEventLoop
"Run the timer event loop."
[
[RunTimerEventLoop] whileTrue: [self handleTimerEvent]
] on: Error do:[:ex|
"Clear out the process so it does't get killed"
TimerEventLoop := nil.
"Launch the old-style interrupt watcher"
self startTimerInterruptWatcher.
"And pass the exception on"
ex pass.
].!
----- Method: Delay class>>saveResumptionTimes (in category 'snapshotting') -----
saveResumptionTimes
"Private!! Record the resumption times of all Delays relative to a base time of zero. This is done prior to snapshotting or adjusting the resumption times after a clock roll-over. This method should be called only while the AccessProtect semaphore is held."
| oldBaseTime |
oldBaseTime _ Time millisecondClockValue.
ActiveDelay == nil
ifFalse: [
oldBaseTime < ActiveDelayStartTime
ifTrue: [oldBaseTime _ ActiveDelayStartTime]. "clock rolled over"
ActiveDelay adjustResumptionTimeOldBase: oldBaseTime newBase: 0].
SuspendedDelays do:
[:d | d adjustResumptionTimeOldBase: oldBaseTime newBase: 0].
!
----- Method: Delay class>>scheduleDelay: (in category 'timer process') -----
scheduleDelay: aDelay
"Private. Schedule this Delay."
aDelay beingWaitedOn: true.
ActiveDelay ifNil:[
ActiveDelay := aDelay
] ifNotNil:[
aDelay resumptionTime < ActiveDelay resumptionTime ifTrue:[
SuspendedDelays add: ActiveDelay.
ActiveDelay := aDelay.
] ifFalse: [SuspendedDelays add: aDelay].
].
!
----- 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.
!
----- Method: Delay class>>startTimerEventLoop (in category 'timer process') -----
startTimerEventLoop
"Start the timer event loop"
"Delay startTimerEventLoop"
self stopTimerEventLoop.
self stopTimerInterruptWatcher.
AccessProtect := Semaphore forMutualExclusion.
ActiveDelayStartTime := Time millisecondClockValue.
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"
!
----- Method: Delay class>>startTimerInterruptWatcher (in category 'timer process') -----
startTimerInterruptWatcher
"Reset the class variables that keep track of active Delays and re-start the timer interrupt watcher process. Any currently scheduled delays are forgotten."
"Delay startTimerInterruptWatcher"
| p |
self stopTimerEventLoop.
self stopTimerInterruptWatcher.
TimingSemaphore := Semaphore new.
AccessProtect := Semaphore forMutualExclusion.
SuspendedDelays :=
SortedCollection sortBlock:
[:d1 :d2 | d1 resumptionTime <= d2 resumptionTime].
ActiveDelay := nil.
p := [self timerInterruptWatcher] newProcess.
p priority: Processor timingPriority.
p resume.
!
----- Method: Delay class>>startUp (in category 'snapshotting') -----
startUp
"Restart active delay, if any, when resuming a snapshot."
self restoreResumptionTimes.
ActiveDelay == nil ifFalse: [ActiveDelay activate].
AccessProtect signal.
!
----- Method: Delay class>>stopTimerEventLoop (in category 'timer process') -----
stopTimerEventLoop
"Stop the timer event loop"
RunTimerEventLoop := false.
TimingSemaphore signal.
TimerEventLoop := nil.!
----- Method: Delay class>>stopTimerInterruptWatcher (in category 'timer process') -----
stopTimerInterruptWatcher
"Reset the class variables that keep track of active Delays and re-start the timer interrupt watcher process. Any currently scheduled delays are forgotten."
"Delay startTimerInterruptWatcher"
self primSignal: nil atMilliseconds: 0.
TimingSemaphore ifNotNil:[TimingSemaphore terminateProcess].!
----- 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.
!
----- 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
!
----- Method: Delay class>>timerInterruptWatcher (in category 'timer process') -----
timerInterruptWatcher
"This loop runs in its own process. It waits for a timer interrupt and wakes up the active delay. Note that timer interrupts are only enabled when there are active delays."
[true] whileTrue: [
TimingSemaphore wait.
AccessProtect critical: [
ActiveDelay == nil ifFalse: [
ActiveDelay signalWaitingProcess.
Time millisecondClockValue < ActiveDelayStartTime
ifTrue: [ "clock wrapped"
self saveResumptionTimes.
self restoreResumptionTimes]].
SuspendedDelays isEmpty
ifTrue: [
ActiveDelay _ nil.
ActiveDelayStartTime _ nil]
ifFalse: [
SuspendedDelays removeFirst activate]]].
!
----- Method: Delay class>>unscheduleDelay: (in category 'timer process') -----
unscheduleDelay: aDelay
"Private. Unschedule this Delay."
ActiveDelay == aDelay ifTrue: [
SuspendedDelays isEmpty ifTrue:[
ActiveDelay := nil.
] ifFalse: [
ActiveDelay := SuspendedDelays removeFirst.
]
] ifFalse:[
SuspendedDelays remove: aDelay ifAbsent: [].
].
aDelay beingWaitedOn: false.!
----- Method: Delay>>activate (in category 'private') -----
activate
"Private!! Make the receiver the Delay to be awoken when the next timer interrupt occurs. This method should only be called from a block protected by the AccessProtect semaphore."
TimerEventLoop ifNotNil:[^nil].
ActiveDelay := self.
ActiveDelayStartTime := Time millisecondClockValue.
ActiveDelayStartTime > resumptionTime ifTrue:[
ActiveDelay signalWaitingProcess.
SuspendedDelays isEmpty ifTrue:[
ActiveDelay := nil.
ActiveDelayStartTime := nil.
] ifFalse:[SuspendedDelays removeFirst activate].
] ifFalse:[
TimingSemaphore initSignals.
Delay primSignal: TimingSemaphore atMilliseconds: resumptionTime.
].!
----- 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).
!
----- Method: Delay>>beingWaitedOn (in category 'public') -----
beingWaitedOn
"Answer whether this delay is currently scheduled, e.g., being waited on"
^beingWaitedOn!
----- Method: Delay>>beingWaitedOn: (in category 'public') -----
beingWaitedOn: aBool
"Indicate whether this delay is currently scheduled, e.g., being waited on"
beingWaitedOn := aBool!
----- Method: Delay>>delayDuration (in category 'public') -----
delayDuration
^delayDuration!
----- Method: Delay>>delaySemaphore (in category 'public') -----
delaySemaphore
^ delaySemaphore!
----- Method: Delay>>isExpired (in category 'delaying') -----
isExpired
^delaySemaphore isSignaled.
!
----- 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
!
----- Method: Delay>>schedule (in category 'private') -----
schedule
"Private!! Schedule this Delay, but return immediately rather than waiting. The receiver's semaphore will be signalled when its delay duration has elapsed."
beingWaitedOn ifTrue: [self error: 'This Delay has already been scheduled.'].
TimerEventLoop ifNotNil:[^self scheduleEvent].
AccessProtect critical: [
beingWaitedOn := true.
resumptionTime := Time millisecondClockValue + delayDuration.
ActiveDelay == nil
ifTrue: [self activate]
ifFalse: [
resumptionTime < ActiveDelay resumptionTime
ifTrue: [
SuspendedDelays add: ActiveDelay.
self activate]
ifFalse: [SuspendedDelays add: self]]].
!
----- Method: Delay>>scheduleEvent (in category 'private') -----
scheduleEvent
"Schedule this delay"
resumptionTime := Time millisecondClockValue + delayDuration.
AccessProtect critical:[
ScheduledDelay := self.
TimingSemaphore signal.
].!
----- 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.
!
----- Method: Delay>>signalWaitingProcess (in category 'private') -----
signalWaitingProcess
"The delay time has elapsed; signal the waiting process."
beingWaitedOn _ false.
delaySemaphore signal.
!
----- Method: Delay>>unschedule (in category 'private') -----
unschedule
"Unschedule this Delay. Do nothing if it wasn't scheduled."
| done |
TimerEventLoop ifNotNil:[^self unscheduleEvent].
AccessProtect critical: [
done := false.
[done] whileFalse:
[SuspendedDelays remove: self ifAbsent: [done := true]].
ActiveDelay == self ifTrue: [
SuspendedDelays isEmpty
ifTrue: [
ActiveDelay := nil.
ActiveDelayStartTime := nil]
ifFalse: [
SuspendedDelays removeFirst activate]]].
!
----- Method: Delay>>unscheduleEvent (in category 'private') -----
unscheduleEvent
AccessProtect critical:[
FinishedDelay := self.
TimingSemaphore signal.
].!
----- 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.
!
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.!
----- 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!
----- 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.!
----- Method: MonitorDelay>>signalWaitingProcess (in category 'private') -----
signalWaitingProcess
"The delay time has elapsed; signal the waiting process."
beingWaitedOn _ false.
monitor signalLock: delaySemaphore inQueue: queue.
!
Object subclass: #InputSensor
instanceVariableNames: ''
classVariableNames: 'ButtonDecodeTable InterruptSemaphore InterruptWatcherProcess KeyDecodeTable'
poolDictionaries: ''
category: 'Kernel-Processes'!
!InputSensor commentStamp: '<historical>' prior: 0!
An InputSensor is an interface to the user input devices.
There is at least one (sub)instance of InputSensor named Sensor in the system.
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.!
----- Method: InputSensor class>>default (in category 'public') -----
default
"Answer the default system InputSensor, Sensor."
^ Sensor!
----- Method: InputSensor 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 }
!
----- Method: InputSensor class>>duplicateControlAndAltKeys: (in category 'public') -----
duplicateControlAndAltKeys: aBoolean
"InputSensor duplicateControlAndAltKeys: true"
Preferences setPreference: #duplicateControlAndAltKeys toValue: aBoolean.
self installKeyDecodeTable
!
----- Method: InputSensor class>>duplicateControlAndAltKeysChanged (in category 'preference change notification') -----
duplicateControlAndAltKeysChanged
"The Preference for duplicateControlAndAltKeys has changed."
(Preferences
valueOfFlag: #swapControlAndAltKeys
ifAbsent: [false]) ifTrue: [
self inform: 'Resetting swapControlAndAltKeys preference'.
(Preferences preferenceAt: #swapControlAndAltKeys) rawValue: false.
].
self installKeyDecodeTable.
!
----- Method: InputSensor class>>installDuplicateKeyEntryFor: (in category 'public') -----
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 }
!
----- Method: InputSensor 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 ] ].
!
----- Method: InputSensor 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)]!
----- Method: InputSensor class>>installSwappedKeyEntryFor: (in category 'public') -----
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 }!
----- Method: InputSensor class>>keyDecodeTable (in category 'public') -----
keyDecodeTable
^KeyDecodeTable ifNil: [ self installKeyDecodeTable ]!
----- Method: InputSensor class>>shutDown (in category 'system startup') -----
shutDown
self default shutDown.!
----- Method: InputSensor class>>startUp (in category 'system startup') -----
startUp
self installMouseDecodeTable.
self installKeyDecodeTable.
self default startUp!
----- Method: InputSensor class>>swapControlAndAltKeys: (in category 'public') -----
swapControlAndAltKeys: aBoolean
"InputSensor swapControlAndAltKeys: true"
Preferences setPreference: #swapControlAndAltKeys toValue: aBoolean.
self installKeyDecodeTable!
----- Method: InputSensor class>>swapControlAndAltKeysChanged (in category 'preference change notification') -----
swapControlAndAltKeysChanged
"The Preference for swapControlAndAltKeys has changed."
(Preferences
valueOfFlag: #duplicateControlAndAltKeys
ifAbsent: [false]) ifTrue: [
self inform: 'Resetting duplicateControlAndAltKeys preference'.
(Preferences preferenceAt: #duplicateControlAndAltKeys) rawValue: false.
].
self installKeyDecodeTable.
!
----- Method: InputSensor class>>swapMouseButtons: (in category 'public') -----
swapMouseButtons: aBoolean
"InputSensor swapMouseButtons: true"
Preferences setPreference: #swapMouseButtons toValue: aBoolean.
self installMouseDecodeTable.!
----- Method: InputSensor>>anyButtonPressed (in category 'mouse') -----
anyButtonPressed
"Answer whether at least one mouse button is currently being pressed."
^ self primMouseButtons anyMask: 7
!
----- Method: InputSensor>>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"!
----- Method: InputSensor>>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
!
----- Method: InputSensor>>buttons (in category 'buttons') -----
buttons
"Answer the result of primMouseButtons, but swap the mouse
buttons if Preferences swapMouseButtons is set."
^ ButtonDecodeTable at: self primMouseButtons + 1!
----- Method: InputSensor>>characterForKeycode: (in category 'private') -----
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)!
----- Method: InputSensor>>commandKeyPressed (in category 'modifier keys') -----
commandKeyPressed
"Answer whether the command key on the keyboard is being held down."
^ self primMouseButtons anyMask: 64!
----- Method: InputSensor>>controlKeyPressed (in category 'modifier keys') -----
controlKeyPressed
"Answer whether the control key on the keyboard is being held down."
^ self primMouseButtons anyMask: 16!
----- Method: InputSensor>>currentCursor (in category 'cursor') -----
currentCursor
"The current cursor is maintained in class Cursor."
^ Cursor currentCursor!
----- Method: InputSensor>>currentCursor: (in category 'cursor') -----
currentCursor: newCursor
"The current cursor is maintained in class Cursor."
Cursor currentCursor: newCursor.!
----- Method: InputSensor>>cursorPoint (in category 'cursor') -----
cursorPoint
"Answer a Point indicating the cursor location."
^self mousePoint!
----- Method: InputSensor>>cursorPoint: (in category 'cursor') -----
cursorPoint: aPoint
"Set aPoint to be the current cursor location."
^self primCursorLocPut: aPoint!
----- Method: InputSensor>>eventQueue (in category 'accessing') -----
eventQueue
^nil!
----- Method: InputSensor>>eventQueue: (in category 'accessing') -----
eventQueue: aSharedQueue
!
----- Method: InputSensor>>eventTicklerProcess (in category 'user interrupts') -----
eventTicklerProcess
"Answer my event tickler process, if any"
^nil!
----- Method: InputSensor>>flushAllButDandDEvents (in category 'accessing') -----
flushAllButDandDEvents!
----- Method: InputSensor>>flushEvents (in category 'initialize') -----
flushEvents
"Do nothing"!
----- Method: InputSensor>>flushKeyboard (in category 'keyboard') -----
flushKeyboard
"Remove all characters from the keyboard buffer."
[self keyboardPressed]
whileTrue: [self keyboard]!
----- Method: InputSensor>>hasTablet (in category 'tablet') -----
hasTablet
"Answer true if there is a pen tablet available on this computer."
^ (self primTabletGetParameters: 1) notNil
!
----- Method: InputSensor>>inputProcess (in category 'user interrupts') -----
inputProcess
"For non-event image compatibility"
^ nil!
----- Method: InputSensor>>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.!
----- Method: InputSensor>>interruptWatcherProcess (in category 'user interrupts') -----
interruptWatcherProcess
"Answer my interrupt watcher process, if any"
^InterruptWatcherProcess!
----- Method: InputSensor>>joystickButtons: (in category 'joystick') -----
joystickButtons: index
^ ((self primReadJoystick: index) bitShift: -22) bitAnd: 16r71F
!
----- Method: InputSensor>>joystickOn: (in category 'joystick') -----
joystickOn: index
^ (((self primReadJoystick: index) bitShift: -27) bitAnd: 1) ~= 0
!
----- Method: InputSensor>>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
!
----- Method: InputSensor>>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 |
char _ nil.
[char = $x] whileFalse:
[[self keyboardPressed] whileFalse: [].
char _ self characterForKeycode: self keyboard.
(String streamContents:
[:s | s nextPut: char; space; print: char asciiValue;
space; print: self primMouseButtons; nextPutAll: ' '])
displayAt: 10 at 10]!
----- Method: InputSensor>>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
!
----- Method: InputSensor>>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!
----- Method: InputSensor>>keyboardPressed (in category 'keyboard') -----
keyboardPressed
"Answer true if keystrokes are available."
^self primKbdPeek notNil!
----- Method: InputSensor>>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!
----- Method: InputSensor>>macOptionKeyPressed (in category 'modifier keys') -----
macOptionKeyPressed
"Answer whether the option key on the Macintosh keyboard is being held down. Macintosh specific."
Preferences macOptionKeyAllowed ifFalse: [self notifyWithLabel: 'Portability note:
InputSensor>>macOptionKeyPressed is not portable.
Please use InputSensor>>yellowButtonPressed instead!!'].
^ self primMouseButtons anyMask: 32!
----- Method: InputSensor>>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
!
----- Method: InputSensor>>mousePoint (in category 'mouse') -----
mousePoint
"Answer a Point indicating the coordinates of the current mouse location."
^self primMousePt!
----- Method: InputSensor>>noButtonPressed (in category 'mouse') -----
noButtonPressed
"Answer whether any mouse button is not being pressed."
^self anyButtonPressed not
!
----- Method: InputSensor>>peekButtons (in category 'mouse') -----
peekButtons
^self primMouseButtons!
----- Method: InputSensor>>peekMousePt (in category 'mouse') -----
peekMousePt
^self primMousePt!
----- Method: InputSensor>>peekPosition (in category 'cursor') -----
peekPosition
^self cursorPoint!
----- Method: InputSensor>>primCursorLocPut: (in category 'private') -----
primCursorLocPut: aPoint
"If the primitive fails, try again with a rounded point."
<primitive: 91>
^ self primCursorLocPutAgain: aPoint rounded!
----- Method: InputSensor>>primCursorLocPutAgain: (in category 'private') -----
primCursorLocPutAgain: aPoint
"Do nothing if primitive is not implemented."
<primitive: 91>
^ self!
----- Method: InputSensor>>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."
<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."!
----- Method: InputSensor>>primKbdNext (in category 'private') -----
primKbdNext
<primitive: 108>
^ nil!
----- Method: InputSensor>>primKbdPeek (in category 'private') -----
primKbdPeek
<primitive: 109>
^ nil!
----- Method: InputSensor>>primMouseButtons (in category 'private') -----
primMouseButtons
<primitive: 107>
^ 0!
----- Method: InputSensor>>primMousePt (in category 'private') -----
primMousePt
"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!
----- Method: InputSensor>>primReadJoystick: (in category 'private') -----
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
!
----- Method: InputSensor>>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>."
<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."!
----- Method: InputSensor>>primTabletGetParameters: (in category 'private') -----
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
!
----- Method: InputSensor>>primTabletRead: (in category 'private') -----
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
!
----- Method: InputSensor>>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!
----- Method: InputSensor>>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
!
----- Method: InputSensor>>setInterruptKey: (in category 'user interrupts') -----
setInterruptKey: anInteger
"Register the given keycode as the user interrupt key."
self primSetInterruptKey: anInteger.
!
----- Method: InputSensor>>shiftPressed (in category 'modifier keys') -----
shiftPressed
"Answer whether the shift key on the keyboard is being held down."
^ self primMouseButtons anyMask: 8
!
----- Method: InputSensor>>shutDown (in category 'initialize') -----
shutDown
InterruptWatcherProcess ifNotNil: [
InterruptWatcherProcess terminate.
InterruptWatcherProcess _ nil ].!
----- Method: InputSensor>>startUp (in category 'initialize') -----
startUp
self installInterruptWatcher.!
----- Method: InputSensor>>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)
!
----- Method: InputSensor>>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)
!
----- Method: InputSensor>>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)
!
----- Method: InputSensor>>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
!
----- Method: InputSensor>>testJoystick: (in category 'joystick') -----
testJoystick: index
"Sensor testJoystick: 3"
| f pt buttons status |
f _ Form extent: 110 at 50.
[Sensor anyButtonPressed] whileFalse: [
pt _ Sensor joystickXY: index.
buttons _ Sensor joystickButtons: index.
status _
'xy: ', pt printString, '
buttons: ', buttons hex.
f fillWhite.
status displayOn: f at: 10 at 10.
f displayOn: Display at: 10 at 10.
].
!
----- Method: InputSensor>>userInterruptWatcher (in category 'user interrupts') -----
userInterruptWatcher
"Wait for user interrupts and open a notifier on the active process when one occurs."
[true] whileTrue: [
InterruptSemaphore wait.
Display deferUpdates: false.
SoundService default shutDown.
Smalltalk handleUserInterrupt]
!
----- Method: InputSensor>>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
!
----- Method: InputSensor>>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
!
----- Method: InputSensor>>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!
----- Method: InputSensor>>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
!
----- Method: InputSensor>>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
!
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. !
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}
].!
----- Method: InstVarRefLocator>>interpretNextInstructionUsing: (in category 'initialize-release') -----
interpretNextInstructionUsing: aScanner
bingo _ false.
aScanner interpretNextInstructionFor: self.
^bingo!
----- Method: InstVarRefLocator>>popIntoReceiverVariable: (in category 'instruction decoding') -----
popIntoReceiverVariable: offset
bingo _ true!
----- Method: InstVarRefLocator>>pushReceiverVariable: (in category 'instruction decoding') -----
pushReceiverVariable: offset
bingo _ true!
----- Method: InstVarRefLocator>>storeIntoReceiverVariable: (in category 'instruction decoding') -----
storeIntoReceiverVariable: offset
bingo _ true!
----- Method: InstructionClient>>blockReturnTop (in category 'instruction decoding') -----
blockReturnTop
"Return Top Of Stack bytecode."
!
----- Method: InstructionClient>>doDup (in category 'instruction decoding') -----
doDup
"Duplicate Top Of Stack bytecode."
!
----- Method: InstructionClient>>doPop (in category 'instruction decoding') -----
doPop
"Remove Top Of Stack bytecode."
!
----- Method: InstructionClient>>jump: (in category 'instruction decoding') -----
jump: offset
"Unconditional Jump bytecode."
!
----- Method: InstructionClient>>jump:if: (in category 'instruction decoding') -----
jump: offset if: condition
"Conditional Jump bytecode."
!
----- Method: InstructionClient>>methodReturnConstant: (in category 'instruction decoding') -----
methodReturnConstant: value
"Return Constant bytecode."
!
----- Method: InstructionClient>>methodReturnReceiver (in category 'instruction decoding') -----
methodReturnReceiver
"Return Self bytecode."
!
----- Method: InstructionClient>>methodReturnTop (in category 'instruction decoding') -----
methodReturnTop
"Return Top Of Stack bytecode."
!
----- Method: InstructionClient>>popIntoLiteralVariable: (in category 'instruction decoding') -----
popIntoLiteralVariable: anAssociation
"Remove Top Of Stack And Store Into Literal Variable bytecode."
!
----- Method: InstructionClient>>popIntoReceiverVariable: (in category 'instruction decoding') -----
popIntoReceiverVariable: offset
"Remove Top Of Stack And Store Into Instance Variable bytecode."
!
----- Method: InstructionClient>>popIntoTemporaryVariable: (in category 'instruction decoding') -----
popIntoTemporaryVariable: offset
"Remove Top Of Stack And Store Into Temporary Variable bytecode."
!
----- Method: InstructionClient>>pushActiveContext (in category 'instruction decoding') -----
pushActiveContext
"Push Active Context On Top Of Its Own Stack bytecode."
!
----- Method: InstructionClient>>pushConstant: (in category 'instruction decoding') -----
pushConstant: value
"Push Constant, value, on Top Of Stack bytecode."
!
----- Method: InstructionClient>>pushLiteralVariable: (in category 'instruction decoding') -----
pushLiteralVariable: anAssociation
"Push Contents Of anAssociation On Top Of Stack bytecode."
!
----- Method: InstructionClient>>pushReceiver (in category 'instruction decoding') -----
pushReceiver
"Push Active Context's Receiver on Top Of Stack bytecode."
!
----- 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."
!
----- 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."
!
----- 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."
!
----- Method: InstructionClient>>storeIntoLiteralVariable: (in category 'instruction decoding') -----
storeIntoLiteralVariable: anAssociation
"Store Top Of Stack Into Literal Variable Of Method bytecode."
!
----- Method: InstructionClient>>storeIntoReceiverVariable: (in category 'instruction decoding') -----
storeIntoReceiverVariable: offset
"Store Top Of Stack Into Instance Variable Of Method bytecode."
!
----- Method: InstructionClient>>storeIntoTemporaryVariable: (in category 'instruction decoding') -----
storeIntoTemporaryVariable: offset
"Store Top Of Stack Into Temporary Variable Of Method bytecode."
!
InstructionClient subclass: #InstructionPrinter
instanceVariableNames: 'method scanner stream oldPC indent'
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.!
----- Method: InstructionPrinter class>>on: (in category 'printing') -----
on: aMethod
^self new method: aMethod.
!
----- 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 selectors do:
[:sel |
file cr; nextPutAll: sel; cr.
(self on: (class compiledMethodAt: sel)) printInstructionsOn: file].
file close
"InstructionPrinter printClass: Parser."
!
----- Method: InstructionPrinter>>blockReturnTop (in category 'instruction decoding') -----
blockReturnTop
"Print the Return Top Of Stack bytecode."
self print: 'blockReturn'!
----- Method: InstructionPrinter>>doDup (in category 'instruction decoding') -----
doDup
"Print the Duplicate Top Of Stack bytecode."
self print: 'dup'!
----- Method: InstructionPrinter>>doPop (in category 'instruction decoding') -----
doPop
"Print the Remove Top Of Stack bytecode."
self print: 'pop'!
----- Method: InstructionPrinter>>indent (in category 'accessing') -----
indent
^ indent ifNil: [0]!
----- Method: InstructionPrinter>>indent: (in category 'initialize-release') -----
indent: numTabs
indent _ numTabs!
----- Method: InstructionPrinter>>jump: (in category 'instruction decoding') -----
jump: offset
"Print the Unconditional Jump bytecode."
self print: 'jumpTo: ' , (scanner pc + offset) printString!
----- 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!
----- Method: InstructionPrinter>>method (in category 'accessing') -----
method
^method.!
----- Method: InstructionPrinter>>method: (in category 'accessing') -----
method: aMethod
method := aMethod.!
----- Method: InstructionPrinter>>methodReturnConstant: (in category 'instruction decoding') -----
methodReturnConstant: value
"Print the Return Constant bytecode."
self print: 'return: ' , value printString!
----- Method: InstructionPrinter>>methodReturnReceiver (in category 'instruction decoding') -----
methodReturnReceiver
"Print the Return Self bytecode."
self print: 'returnSelf'!
----- Method: InstructionPrinter>>methodReturnTop (in category 'instruction decoding') -----
methodReturnTop
"Print the Return Top Of Stack bytecode."
self print: 'returnTop'!
----- 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!
----- 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!
----- 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!
----- Method: InstructionPrinter>>print: (in category 'printing') -----
print: instruction
"Append to the receiver a description of the bytecode, instruction."
| code |
stream tab: self indent; print: oldPC; space.
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."
!
----- 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.
[scanner pc <= end]
whileTrue: [scanner interpretNextInstructionFor: self]!
----- Method: InstructionPrinter>>pushActiveContext (in category 'instruction decoding') -----
pushActiveContext
"Print the Push Active Context On Top Of Its Own Stack bytecode."
self print: 'pushThisContext: '!
----- Method: InstructionPrinter>>pushConstant: (in category 'instruction decoding') -----
pushConstant: obj
"Print the Push Constant, obj, on Top Of Stack bytecode."
self print: 'pushConstant: ' , (String streamContents: [:s |
(obj isKindOf: LookupKey)
ifFalse: [s withStyleFor: #literal do: [obj printOn: s]]
ifTrue: [obj key
ifNotNil: [s nextPutAll: '##'; nextPutAll: obj key]
ifNil: [s nextPutAll: '###'; nextPutAll: obj value soleInstance name]]
]).
(obj isKindOf: CompiledMethod) ifTrue: [
obj longPrintOn: stream indent: self indent + 2. ^ self].
Smalltalk at: #BlockClosure ifPresent:[:aClass|
(obj isKindOf: aClass) ifTrue: [
obj method longPrintOn: stream indent: self indent + 2. ^ self]].!
----- 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!
----- Method: InstructionPrinter>>pushReceiver (in category 'instruction decoding') -----
pushReceiver
"Print the Push Active Context's Receiver on Top Of Stack bytecode."
self print: 'self'!
----- 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!
----- 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!
----- Method: InstructionPrinter>>send:super:numArgs: (in category 'instruction decoding') -----
send: selector super: supered numArgs: numberArguments
"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: ']) , selector!
----- 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!
----- 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!
----- 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!
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.!
InstructionStream subclass: #ContextPart
instanceVariableNames: 'stackp'
classVariableNames: 'PrimitiveFailToken QuickStep'
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.!
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.!
----- 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!
----- Method: BlockContext>>asContext (in category 'scheduling') -----
asContext
^ self!
----- Method: BlockContext>>assert (in category 'exceptions') -----
assert
self assert: self!
----- 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.' ]!
----- Method: BlockContext>>blockHome (in category 'accessing') -----
blockHome
^ self home!
----- 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!
----- 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!
----- 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!
----- Method: BlockContext>>copyTo:blocks: (in category 'private') -----
copyTo: aContext blocks: dict
"Copy self and my sender chain down to, but not including, aContext. End of copied chain will have nil sender. BlockContexts whose home is also copied will point to the copy. However, blockContexts that are not on the stack but may be later will not have their home pointing in the new copied thread. So an error will be raised if one of these tries to return directly to its home."
| copy |
self == aContext ifTrue: [^ nil].
copy _ self copy.
(dict at: self home ifAbsentPut: [OrderedCollection new]) add: copy.
self sender ifNotNil: [
copy privSender: (self sender copyTo: aContext blocks: dict)].
^ copy!
----- Method: BlockContext>>decompile (in category 'printing') -----
decompile
^ Decompiler new decompileBlock: self!
----- 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!
----- 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!
----- Method: BlockContext>>durationToRun (in category 'evaluating') -----
durationToRun
"Answer the duration taken to execute this block."
^ Duration milliSeconds: self timeToRun
!
----- Method: BlockContext>>ensure: (in category 'exceptions') -----
ensure: aBlock
"Evaluate a termination block after evaluating the receiver, regardless of whether the receiver's evaluation completes."
| returnValue b |
<primitive: 198>
returnValue := self value.
"aBlock wasn't nil when execution of this method began; it is nil'd out by the unwind machinery, and that's how we know it's already been evaluated ... otherwise, obviously, it needs to be evaluated"
aBlock == nil ifFalse: [
"nil out aBlock temp before evaluating aBlock so it is not executed again if aBlock remote returns"
b _ aBlock.
thisContext tempAt: 1 put: nil. "aBlock _ nil"
b value.
].
^ returnValue!
----- Method: BlockContext>>finalBlockHome (in category 'accessing') -----
finalBlockHome
^ self home!
----- 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!
----- Method: BlockContext>>fork (in category 'scheduling') -----
fork
"Create and schedule a Process running the code in the receiver."
^ self newProcess resume!
----- 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.
!
----- 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
!
----- 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!
----- 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!
----- Method: BlockContext>>fullPrintOn: (in category 'printing') -----
fullPrintOn: aStream
aStream print: self; cr.
(self decompile ifNil: ['--source missing--']) fullPrintOn: aStream
!
----- 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.
"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.
printer _ InstVarRefLocator new.
[scanner pc <= end] whileTrue: [
(printer interpretNextInstructionUsing: scanner) ifTrue: [^true].
].
^false!
----- 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!
----- Method: BlockContext>>hideFromDebugger (in category 'private') -----
hideFromDebugger
^home ~~ nil and: [home hideFromDebugger]!
----- Method: BlockContext>>home (in category 'accessing') -----
home
"Answer the context in which the receiver was defined."
^home!
----- 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.!
----- Method: BlockContext>>ifCurtailed: (in category 'exceptions') -----
ifCurtailed: aBlock
"Evaluate the receiver with an abnormal termination action."
<primitive: 198>
^ self value!
----- 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 valueWithPossibleArgs: {ex description. ex receiver}]!
----- Method: BlockContext>>ifProperUnwindSupportedElseSignalAboutToReturn (in category 'private-exceptions') -----
ifProperUnwindSupportedElseSignalAboutToReturn
"A really ugly hack to simulate the necessary unwind behavior for VMs not having proper unwind support"
<primitive: 123>
"The above indicates new EH primitives supported. In this case is identical to #value. Sender is expected to use [nil] ifProperUnwindSupportedElseSignalAboutToReturn."
^ExceptionAboutToReturn signal.!
----- Method: BlockContext>>instVarAt:put: (in category 'private') -----
instVarAt: index put: value
index = 3 ifTrue: [self stackp: value. ^ value].
^ super instVarAt: index put: value!
----- Method: BlockContext>>isBlock (in category 'accessing') -----
isBlock
^ true!
----- Method: BlockContext>>isExecutingBlock (in category 'accessing') -----
isExecutingBlock
^ true!
----- Method: BlockContext>>isMethodContext (in category 'accessing') -----
isMethodContext
^ false!
----- Method: BlockContext>>method (in category 'accessing') -----
method
"Answer the compiled method in which the receiver was defined."
^home method!
----- Method: BlockContext>>myEnv (in category 'private') -----
myEnv
"polymorphic with MethodContext"
^ nil!
----- 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!
----- 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!
----- Method: BlockContext>>numArgs (in category 'accessing') -----
numArgs
"Answer the number of arguments that must be used to evaluate this block"
^nargs!
----- 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!
----- 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]
]!
----- Method: BlockContext>>printOn: (in category 'printing') -----
printOn: aStream
| blockString truncatedBlockString |
home == nil ifTrue: [^aStream nextPutAll: 'a BlockContext with home=nil'].
aStream nextPutAll: '[] in '.
super printOn: aStream.
aStream nextPutAll: ' '.
blockString _ ((self decompile ifNil: ['--source missing--']) 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 nextPutAll: truncatedBlockString.
!
----- Method: BlockContext>>printOnStream: (in category 'printing') -----
printOnStream: aStream
home == nil ifTrue: [^aStream print: 'a BlockContext with home=nil'].
aStream print: '[] in '.
super printOnStream: aStream!
----- Method: BlockContext>>privHome: (in category 'private') -----
privHome: context
home _ context!
----- 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']
].
!
----- 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!
----- Method: BlockContext>>receiver (in category 'accessing') -----
receiver
"Refer to the comment in ContextPart|receiver."
^home receiver!
----- Method: BlockContext>>reentrant (in category 'accessing') -----
reentrant
"Copy before calling so multiple activations can exist"
^ self copy!
----- Method: BlockContext>>repeat (in category 'controlling') -----
repeat
"Evaluate the receiver repeatedly, ending only if the block explicitly returns."
[self value. true] whileTrue!
----- 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!
----- Method: BlockContext>>startpc (in category 'private') -----
startpc
"for use by the System Tracer only"
^startpc!
----- Method: BlockContext>>stepToSendOrReturn (in category 'system simulation') -----
stepToSendOrReturn
pc = startpc ifTrue: [
"pop args first"
self numArgs timesRepeat: [self step]].
^super stepToSendOrReturn!
----- Method: BlockContext>>tempAt: (in category 'accessing') -----
tempAt: index
"Refer to the comment in ContextPart|tempAt:."
^home at: index!
----- Method: BlockContext>>tempAt:put: (in category 'accessing') -----
tempAt: index put: value
"Refer to the comment in ContextPart|tempAt:put:."
^home at: index put: value!
----- Method: BlockContext>>timeToRun (in category 'evaluating') -----
timeToRun
"Answer the number of milliseconds taken to execute this block."
^ Time millisecondsToRun: self
!
----- 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: #()!
----- 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)!
----- 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)!
----- 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)!
----- 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)!
----- 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!
----- Method: BlockContext>>valueError (in category 'private') -----
valueError
self error: 'Incompatible number of args, or already active'!
----- Method: BlockContext>>valueSupplyingAnswer: (in category 'evaluating') -----
valueSupplyingAnswer: anObject
^ (anObject isCollection and: [anObject isString not])
ifTrue: [self valueSupplyingAnswers: {anObject}]
ifFalse: [self valueSupplyingAnswers: {{'*'. anObject}}]!
----- 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 value]
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]]]!
----- Method: BlockContext>>valueSuppressingAllMessages (in category 'evaluating') -----
valueSuppressingAllMessages
^ self valueSuppressingMessages: #('*')!
----- Method: BlockContext>>valueSuppressingMessages: (in category 'evaluating') -----
valueSuppressingMessages: aListOfStrings
^ self
valueSuppressingMessages: aListOfStrings
supplyingAnswers: #()!
----- Method: BlockContext>>valueSuppressingMessages:supplyingAnswers: (in category 'evaluating') -----
valueSuppressingMessages: aListOfStrings supplyingAnswers: aListOfPairs
^ self valueSupplyingAnswers: aListOfPairs, (aListOfStrings collect: [:each | {each. true}])!
----- 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]!
----- 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!
----- 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>
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, '.']
!
----- 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!
----- 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)
!
----- 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)]!
----- 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 done result |
aDuration <= Duration zero ifTrue: [^ timeoutBlock value ].
"the block will be executed in the current process"
theProcess := Processor activeProcess.
delay := aDuration asDelay.
"make a watchdog process"
watchdog := [
delay wait. "wait for timeout or completion"
done ifFalse: [ theProcess signalException: TimedOut ]
] newProcess.
"watchdog needs to run at high priority to do its job"
watchdog priority: Processor timingPriority.
"catch the timeout signal"
^ [ done := false.
watchdog resume. "start up the watchdog"
result := self value. "evaluate the receiver"
done := true. "it has completed, so ..."
delay delaySemaphore signal. "arrange for the watchdog to exit"
result ]
on: TimedOut do: [ :e | timeoutBlock value ].
!
----- 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: []!
----- 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]!
----- 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: []!
----- 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]!
----- Method: ContextPart class>>basicNew: (in category 'instance creation') -----
basicNew: size
self error: 'Contexts must only be created with newForMethod:'!
----- Method: ContextPart class>>carefullyPrint:on: (in category 'private') -----
carefullyPrint: anObject on: aStream
aStream nextPutAll: ([anObject printString]
on: Error
do: ['unprintable ' , anObject class name])!
----- 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!
----- 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!
----- Method: ContextPart class>>initialize (in category 'simulation') -----
initialize
"A unique object to be returned when a primitive fails during simulation"
PrimitiveFailToken _ Object new !
----- Method: ContextPart class>>initializedInstance (in category 'instance creation') -----
initializedInstance
^ nil!
----- Method: ContextPart class>>new (in category 'instance creation') -----
new
self error: 'Contexts must only be created with newForMethod:'!
----- Method: ContextPart class>>new: (in category 'instance creation') -----
new: size
self error: 'Contexts must only be created with newForMethod:'!
----- 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!
----- Method: ContextPart class>>primitiveFailToken (in category 'simulation') -----
primitiveFailToken
^ PrimitiveFailToken!
----- 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]"!
----- 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]"!
----- 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]"!
----- 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!
----- 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!
----- 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]]!
----- 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."
| aStream |
^ [aStream _ FileStream fileNamed: fileName.
self trace: aBlock on: aStream] ensure: [aStream close]!
----- 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!
----- 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"
^ self
activateMethod: ContextPart theReturnMethod
withArgs: {value}
receiver: aContext
class: aContext class!
----- 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 home method)
home: self home
startpc: pc + 2
nargs: numArgs!
----- Method: ContextPart>>blockHome (in category 'query') -----
blockHome
^ self!
----- 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]!
----- Method: ContextPart>>cachesStack (in category 'private-debugger') -----
cachesStack
^false!
----- 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].
!
----- 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!
----- Method: ContextPart>>client (in category 'accessing') -----
client
"Answer the client, that is, the object that sent the message that created this context."
^sender receiver!
----- 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!
----- Method: ContextPart>>contextStack (in category 'debugger access') -----
contextStack
"Answer an Array of the contexts on the receiver's sender chain."
^self stackOfSize: 100000!
----- Method: ContextPart>>copyStack (in category 'query') -----
copyStack
^ self copyTo: nil!
----- 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. BlockContexts whose home is also copied will point to the copy. However, blockContexts that are not on the stack but may be later will not have their home pointing in the new copied thread. So an error will be raised if one of these tries to return directly to its home. It is best to use BlockClosures instead. They only hold a ContextTag, which will work for all copies of the original home context."
^ self copyTo: aContext blocks: IdentityDictionary new!
----- Method: ContextPart>>copyTo:blocks: (in category 'private') -----
copyTo: aContext blocks: dict
"Copy self and my sender chain down to, but not including, aContext. End of copied chain will have nil sender. BlockContexts whose home is also copied will point to the copy. However, blockContexts that are not on the stack but may be later will not have their home pointing in the new copied thread. So an error will be raised if one of these tries to return directly to its home."
| copy |
self == aContext ifTrue: [^ nil].
copy _ self copy.
dict at: self ifPresent: [:blocks | blocks do: [:b | b privHome: copy]].
self sender ifNotNil: [
copy privSender: (self sender copyTo: aContext blocks: dict)].
^ copy!
----- 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.
!
----- 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!
----- Method: ContextPart>>doDup (in category 'instruction decoding') -----
doDup
"Simulate the action of a 'duplicate top of stack' bytecode."
self push: self top!
----- Method: ContextPart>>doPop (in category 'instruction decoding') -----
doPop
"Simulate the action of a 'remove top of stack' bytecode."
self pop!
----- 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."
| value |
<primitive: 19> "Simulation guard"
"If successful, push result and return resuming context,
else ^ PrimitiveFailToken"
(primitiveIndex = 19) ifTrue:[
Debugger
openContext: self
label:'Code simulation error'
contents: nil].
(primitiveIndex = 80 and: [receiver isKindOf: ContextPart])
ifTrue: [^self push: ((BlockContext newForMethod: receiver home method)
home: receiver home
startpc: pc + 2
nargs: (arguments at: 1))].
(primitiveIndex = 81 and: [receiver isMemberOf: BlockContext])
ifTrue: [^receiver pushArgs: arguments from: self].
(primitiveIndex = 82 and: [receiver isMemberOf: BlockContext])
ifTrue: [^receiver pushArgs: arguments first from: self].
primitiveIndex = 83 "afr 9/11/1998 19:50"
ifTrue: [^ self send: arguments first to: receiver
with: arguments allButFirst
super: false].
primitiveIndex = 84 "afr 9/11/1998 19:50"
ifTrue: [^ self send: arguments first to: receiver
with: (arguments at: 2)
super: false].
arguments size > 6 ifTrue: [^ PrimitiveFailToken].
primitiveIndex = 117
ifTrue:[value _ self tryNamedPrimitiveIn: meth for: receiver withArgs: arguments]
ifFalse:[value _ receiver tryPrimitive: primitiveIndex withArgs: arguments].
value == PrimitiveFailToken
ifTrue: [^ PrimitiveFailToken]
ifFalse: [^ self push: value]!
----- Method: ContextPart>>errorReportOn: (in category 'debugger access') -----
errorReportOn: strm
"Write a detailed error report on the stack (above me) on a stream. For both the error file, and emailing a bug report. Suppress any errors while getting printStrings. Limit the length."
| cnt aContext startPos |
strm print: Date today; space; print: Time now; cr.
strm cr.
strm nextPutAll: 'VM: ';
nextPutAll: SmalltalkImage current platformName asString;
nextPutAll: ' - ';
nextPutAll: SmalltalkImage current asString;
cr.
strm nextPutAll: 'Image: ';
nextPutAll: SystemVersion current version asString;
nextPutAll: ' [';
nextPutAll: SmalltalkImage current lastUpdateString asString;
nextPutAll: ']';
cr.
strm cr.
SecurityManager default printStateOn: strm.
"Note: The following is an open-coded version of ContextPart>>stackOfSize: since this method may be called during a low space condition and we might run out of space for allocating the full stack."
cnt _ 0. startPos _ strm position.
aContext _ self.
[aContext notNil and: [(cnt _ cnt + 1) < 5]] whileTrue:
[aContext printDetails: strm. "variable values"
strm cr.
aContext _ aContext sender].
strm cr; nextPutAll: '--- The full stack ---'; cr.
aContext _ self.
cnt _ 0.
[aContext == nil] whileFalse:
[cnt _ cnt + 1.
cnt = 5 ifTrue: [strm nextPutAll: ' - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -'; cr].
strm print: aContext; cr. "just class>>selector"
strm position > (startPos+4000) ifTrue: [strm nextPutAll: '...etc...'.
^ self]. "exit early"
cnt > 60 ifTrue: [strm nextPutAll: '-- and more not shown --'. ^ self].
aContext _ aContext sender].
!
----- 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!
----- 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!
----- 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!
----- Method: ContextPart>>handleSignal: (in category 'private-exceptions') -----
handleSignal: exception
"Sent to handler (on:do:) contexts only. If my exception class (first arg) handles exception 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:)."
| val |
(((self tempAt: 1) handles: exception) and: [self tempAt: 3]) ifFalse: [
^ self nextHandlerContext handleSignal: exception].
exception privHandlerContext: self contextTag.
self tempAt: 3 put: false. "disable self while executing handle block"
val _ [(self tempAt: 2) valueWithPossibleArgs: {exception}]
ensure: [self tempAt: 3 put: true].
self return: val. "return from self if not otherwise directed in handle block"
!
----- Method: ContextPart>>hasContext: (in category 'query') -----
hasContext: aContext
"Answer whether aContext is me or one of my senders"
^ (self findContextSuchThat: [:c | c == aContext]) notNil!
----- 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!
----- Method: ContextPart>>home (in category 'accessing') -----
home
"Answer the context in which the receiver was defined."
self subclassResponsibility!
----- 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!
----- Method: ContextPart>>isDead (in category 'query') -----
isDead
"Has self finished"
^ pc isNil!
----- Method: ContextPart>>isHandlerContext (in category 'private-exceptions') -----
isHandlerContext
^false!
----- Method: ContextPart>>isUnwindContext (in category 'private-exceptions') -----
isUnwindContext
^false!
----- 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!
----- 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!
----- 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]!
----- 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]]!
----- Method: ContextPart>>mclass (in category 'debugger access') -----
mclass
"Answer the class in which the receiver's method was found."
| mclass |
self receiver class selectorAtMethod: self method setClass: [:mc |
mclass _ mc ].
^mclass!
----- Method: ContextPart>>method (in category 'accessing') -----
method
"Answer the method of this context."
self subclassResponsibility!
----- Method: ContextPart>>methodNode (in category 'accessing') -----
methodNode
| selector methodClass |
selector _ self receiver class
selectorAtMethod: self method
setClass: [:mclass | methodClass _ mclass].
^ self method methodNodeDecompileClass: methodClass selector: selector!
----- Method: ContextPart>>methodNodeFormattedAndDecorated: (in category 'accessing') -----
methodNodeFormattedAndDecorated: decorate
"Answer a method node made from pretty-printed (and colorized, if decorate is true) source text."
| selector methodClass |
selector _ self receiver class
selectorAtMethod: self method
setClass: [:mclass | methodClass _ mclass].
^ self method methodNodeFormattedDecompileClass: methodClass selector: selector decorate: decorate!
----- 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 home!
----- 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 home!
----- 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 home!
----- Method: ContextPart>>methodSelector (in category 'debugger access') -----
methodSelector
"Answer the selector of the method that created the receiver."
^self receiver class
selectorAtMethod: self method
setClass: [:ignored]!
----- Method: ContextPart>>nextHandlerContext (in category 'private-exceptions') -----
nextHandlerContext
^ self sender findNextHandlerContextStarting!
----- Method: ContextPart>>pc (in category 'debugger access') -----
pc
"Answer the index of the next bytecode to be executed."
^pc!
----- 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!
----- 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."
value value: self pop!
----- 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 receiver instVarAt: offset + 1 put: self pop!
----- 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 home at: offset + 1 put: self pop!
----- 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: 80 indent: 2] ifError: [:err :rcvr |
'<<error during printing>>'].
strm nextPutAll: str.
strm peekLast == Character cr ifFalse: [strm cr].!
----- Method: ContextPart>>printOn: (in category 'printing') -----
printOn: aStream
| selector class mclass |
self method == nil ifTrue: [^ super printOn: aStream].
selector _
(class _ self receiver class)
selectorAtMethod: self method
setClass: [:c | mclass _ c].
selector == #?
ifTrue:
[aStream nextPut: $?; print: self method who.
^self].
aStream nextPutAll: class name.
mclass == class
ifFalse:
[aStream nextPut: $(.
aStream nextPutAll: mclass name.
aStream nextPut: $)].
aStream nextPutAll: '>>'.
aStream nextPutAll: selector.
selector = #doesNotUnderstand: ifTrue: [
aStream space.
(self tempAt: 1) selector printOn: aStream.
].
!
----- Method: ContextPart>>privSender: (in category 'private') -----
privSender: aContext
sender _ aContext!
----- Method: ContextPart>>push: (in category 'controlling') -----
push: val
"Push val on the receiver's stack."
self stackp: stackp + 1.
self at: stackp put: val!
----- 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)]!
----- 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!
----- 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!
----- 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: value value!
----- 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!
----- 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 receiver instVarAt: offset + 1)!
----- 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 home at: offset + 1)!
----- Method: ContextPart>>quickSend:to:with:super: (in category 'controlling') -----
quickSend: selector to: receiver 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!!"
| oldSender contextToReturnTo result lookupClass |
contextToReturnTo _ self.
lookupClass _ superFlag
ifTrue: [(self method literalAt: self method numLiterals) value superclass]
ifFalse: [receiver class].
[oldSender _ thisContext sender swapSender: self.
result _ receiver perform: selector withArguments: arguments inSuperclass: lookupClass.
thisContext sender swapSender: oldSender] ifCurtailed: [
contextToReturnTo _ thisContext sender receiver. "The block context returning nonlocally"
contextToReturnTo jump: -1. "skip to front of return bytecode causing this unwind"
contextToReturnTo nextByte = 16r7C 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!
----- 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!
----- Method: ContextPart>>receiver (in category 'accessing') -----
receiver
"Answer the receiver of the message that created this context."
self subclassResponsibility!
----- 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!
----- 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]!
----- 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: [
unwindBlock _ ctxt tempAt: 1.
unwindBlock ifNotNil: [
ctxt tempAt: 1 put: nil.
thisContext terminateTo: ctxt.
unwindBlock value].
].
thisContext terminateTo: self.
self jump.
!
----- 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!
----- 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: [
unwindBlock _ ctxt tempAt: 1.
unwindBlock ifNotNil: [
ctxt tempAt: 1 put: nil.
thisContext terminateTo: ctxt.
unwindBlock value].
].
thisContext terminateTo: self.
^ value
!
----- Method: ContextPart>>return (in category 'controlling') -----
return
"Unwind until my sender is on top"
self return: self receiver!
----- 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!
----- 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
!
----- 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!
----- 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.
current pushArgs: Array new from: self.
[current == self]
whileFalse:
[block2 value: current.
current _ current step].
^self pop!
----- 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}
].
!
----- 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]!
----- Method: ContextPart>>selector (in category 'debugger access') -----
selector
"Answer the selector of the method that created the receiver."
^self receiver class
selectorAtMethod: self method
setClass: [:ignored]!
----- 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 answer |
arguments _ Array new: numArgs.
numArgs to: 1 by: -1 do: [ :i | arguments at: i put: self pop].
receiver _ self pop.
selector == #doPrimitive:method:receiver:args:
ifTrue: [answer _ receiver
doPrimitive: (arguments at: 1)
method: (arguments at: 2)
receiver: (arguments at: 3)
args: (arguments at: 4).
self push: answer.
^self].
QuickStep == self ifTrue: [
QuickStep _ nil.
^self quickSend: selector to: receiver with: arguments super: superFlag].
^self send: selector to: receiver with: arguments super: superFlag!
----- Method: ContextPart>>send:to:with:super: (in category 'controlling') -----
send: selector to: rcvr with: args super: superFlag
"Simulate the action of sending a message with selector, selector, and
arguments, args, to receiver. The argument, superFlag, tells whether the
receiver of the message was specified with 'super' in the source method."
| class meth val |
class _ superFlag
ifTrue: [(self method literalAt: self method numLiterals) value superclass]
ifFalse: [rcvr class].
meth _ class lookupSelector: selector.
meth == nil
ifTrue: [^ self send: #doesNotUnderstand:
to: rcvr
with: (Array with: (Message selector: selector arguments: args))
super: superFlag]
ifFalse: [val _ self tryPrimitiveFor: meth
receiver: rcvr
args: args.
val == PrimitiveFailToken ifFalse: [^ val].
(selector == #doesNotUnderstand: and: [class == ProtoObject]) ifTrue:
[^ self error: 'Simulated message ' , (args at: 1) selector
, ' not understood'].
^ self activateMethod: meth
withArgs: args
receiver: rcvr
class: class]!
----- Method: ContextPart>>sender (in category 'debugger access') -----
sender
"Answer the context that sent the message that created the receiver."
^sender!
----- 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]]!
----- 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.
!
----- Method: ContextPart>>sourceCode (in category 'debugger access') -----
sourceCode
| selector methodClass |
selector _ self receiver class selectorAtMethod: self method
setClass: [:mclass | methodClass _ mclass].
^self method getSourceFor: selector in: methodClass
"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."!
----- Method: ContextPart>>stack (in category 'debugger access') -----
stack
"Answer an Array of the contexts on the receiver's sender chain."
^self stackOfSize: 9999!
----- Method: ContextPart>>stackOfSize: (in category 'debugger access') -----
stackOfSize: limit
"Answer an OrderedCollection of the top 'limit' contexts
on the receiver's sender chain."
| a stack cachedStackTop newLimit |
stack _ OrderedCollection new.
stack addLast: (a _ self).
[(a _ a sender) ~~ nil and: [stack size < limit]]
whileTrue:
[a hideFromDebugger ifFalse: [stack addLast: a].
a cachesStack ifTrue: [cachedStackTop := a cachedStackTop]].
^cachedStackTop == nil
ifTrue: [stack]
ifFalse:
[newLimit := limit - stack size.
newLimit > 0
ifTrue: [stack addAllLast: (cachedStackTop stackOfSize: newLimit); yourself]
ifFalse: [stack]]!
----- Method: ContextPart>>stackPtr (in category 'private') -----
stackPtr "For use only by the SystemTracer"
^ stackp!
----- 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]
"!
----- 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!
----- Method: ContextPart>>stepToCallee (in category 'system simulation') -----
stepToCallee
"Step to callee or sender"
| ctxt |
ctxt _ self.
[(ctxt _ ctxt step) == self] whileTrue.
^ ctxt!
----- 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 | self willReturn | self willStore]
whileFalse: [
ctxt _ self step.
ctxt == self ifFalse: [self halt.
"Caused by mustBeBoolean handling"
^ctxt]]!
----- 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!
----- 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."
value value: self top!
----- 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 receiver instVarAt: offset + 1 put: self top!
----- 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 home at: offset + 1 put: self top!
----- 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!
----- Method: ContextPart>>tempAt: (in category 'accessing') -----
tempAt: index
"Answer the value of the temporary variable whose index is the
argument, index."
self subclassResponsibility!
----- 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!
----- Method: ContextPart>>tempNames (in category 'debugger access') -----
tempNames
"Answer an OrderedCollection of the names of the receiver's temporary
variables, which are strings."
^ self methodNode tempNames!
----- Method: ContextPart>>tempsAndValues (in category 'debugger access') -----
tempsAndValues
"Return a string of the temporary variabls and their current values"
| aStream |
aStream _ WriteStream on: (String new: 100).
self tempNames
doWithIndex: [:title :index |
aStream nextPutAll: title; nextPut: $:; space; tab.
(self tempAt: index) printOn: aStream.
aStream cr].
^aStream contents!
----- 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!
----- Method: ContextPart>>terminate (in category 'controlling') -----
terminate
"Make myself unresumable."
sender _ nil.
pc _ nil.
!
----- 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!
----- Method: ContextPart>>top (in category 'controlling') -----
top
"Answer the top of the receiver's stack."
^self at: stackp!
----- Method: ContextPart>>tryNamedPrimitiveIn:for:withArgs: (in category 'private') -----
tryNamedPrimitiveIn: aCompiledMethod for: aReceiver withArgs: arguments
"Hack. Attempt to execute the named primitive from the given compiled method"
| selector theMethod spec |
arguments size > 8 ifTrue:[^PrimitiveFailToken].
selector _ #(
tryNamedPrimitive
tryNamedPrimitive:
tryNamedPrimitive:with:
tryNamedPrimitive:with:with:
tryNamedPrimitive:with:with:with:
tryNamedPrimitive:with:with:with:with:
tryNamedPrimitive:with:with:with:with:with:
tryNamedPrimitive:with:with:with:with:with:with:
tryNamedPrimitive:with:with:with:with:with:with:with:) at: arguments size+1.
theMethod _ aReceiver class lookupSelector: selector.
theMethod == nil ifTrue:[^PrimitiveFailToken].
spec _ theMethod literalAt: 1.
spec replaceFrom: 1 to: spec size with: (aCompiledMethod literalAt: 1) startingAt: 1.
^aReceiver perform: selector withArguments: arguments!
----- 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].
^ self doPrimitive: primIndex method: method receiver: receiver args: arguments!
----- Method: ContextPart>>unwindTo: (in category 'private-exceptions') -----
unwindTo: aContext
| ctx unwindBlock |
ctx := self.
[(ctx _ ctx findNextUnwindContextUpTo: aContext) isNil] whileFalse: [
unwindBlock := ctx tempAt: 1.
unwindBlock == nil ifFalse: [
ctx tempAt: 1 put: nil.
unwindBlock value]
].
!
ContextPart variableSubclass: #MethodContext
instanceVariableNames: 'method receiverMap receiver'
classVariableNames: ''
poolDictionaries: ''
category: 'Kernel-Methods'!
!MethodContext commentStamp: '<historical>' prior: 0!
My instances hold all the dynamic state associated with the execution of a CompiledMethod. In addition to their inherited state, this includes the receiver, a method, and temporary space in the variable part of the context.
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.!
----- 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!
----- Method: MethodContext>>answer: (in category 'controlling') -----
answer: anObject
"ar 3/6/2001: OBSOLETE. Must not be used. Will be removed VERY SOON."
"Modify my code, from the current program counter value, to answer anObject."
self push: anObject.
(method at: pc) = 124 ifFalse: [
method _ (
(method clone)
at: pc + 1 put: 124;
yourself)]!
----- Method: MethodContext>>blockHome (in category 'accessing') -----
blockHome
"If executing closure, search senders for method containing my closure method. If not found return nil."
| m |
self isExecutingBlock ifFalse: [^ self].
self sender ifNil: [^ nil].
m _ self method.
^ self sender findContextSuchThat: [:c | c method hasLiteralThorough: m]!
----- Method: MethodContext>>cachedStackTop (in category 'private-debugger') -----
cachedStackTop
"WARNING - this method depends on a very dirty trick, viz. snitching information off the variable stack of a particular CompiledMethod. So if you add/remove a temp in BlockContext>>valueUninterruptably, this method will fail, probably with some horrible consequences I'd rather not think through just now ... assumption is that the variable declaration in that method looks like:
| sendingContext result homeSender |"
^self tempAt: 3!
----- Method: MethodContext>>cachesStack (in category 'private-debugger') -----
cachesStack
^ false
"^self selector == #valueUninterruptably
and: [self receiver class == BlockContext]"!
----- Method: MethodContext>>cannotReturn: (in category 'private-exceptions') -----
cannotReturn: result
Debugger
openContext: thisContext
label: 'computation has been terminated'
contents: thisContext printString!
----- 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!
----- Method: MethodContext>>finalBlockHome (in category 'accessing') -----
finalBlockHome
"If executing closure, search senders for original method containing my closure method. If not found return nil."
| h |
self isExecutingBlock ifFalse: [^ self].
^ (h _ self blockHome) ifNotNil: [h finalBlockHome]!
----- Method: MethodContext>>hasInstVarRef (in category 'accessing') -----
hasInstVarRef
"Answer whether the receiver references an instance variable."
| scanner end printer |
scanner _ InstructionStream on: method.
printer _ InstVarRefLocator new.
end _ self method endPC.
[scanner pc <= end] whileTrue: [
(printer interpretNextInstructionUsing: scanner) ifTrue: [^true].
].
^false!
----- 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]]]!
----- Method: MethodContext>>home (in category 'accessing') -----
home
"Refer to the comment in ContextPart|home."
^self!
----- Method: MethodContext>>instVarAt:put: (in category 'private') -----
instVarAt: index put: value
index = 3 ifTrue: [self stackp: value. ^ value].
^ super instVarAt: index put: value!
----- Method: MethodContext>>isExecutingBlock (in category 'accessing') -----
isExecutingBlock
"Is this executing a block versus a method"
| r |
Smalltalk at: #BlockClosure ifPresent:[:aClass|
^((r _ self receiver) isKindOf: aClass) and: [r method == self method]
].
^false!
----- Method: MethodContext>>isHandlerContext (in category 'private-exceptions') -----
isHandlerContext
"is this context for method that is marked?"
^method primitive = 199!
----- Method: MethodContext>>isMethodContext (in category 'testing') -----
isMethodContext
^ true!
----- Method: MethodContext>>isUnwindContext (in category 'private-exceptions') -----
isUnwindContext
"is this context for method that is marked?"
^method primitive = 198!
----- Method: MethodContext>>method (in category 'accessing') -----
method
^method!
----- Method: MethodContext>>methodNode (in category 'accessing') -----
methodNode
| h |
^ self isExecutingBlock
ifTrue: [self method blockNodeIn: ((h _ self blockHome) ifNotNil: [h methodNode])]
ifFalse: [super methodNode]!
----- 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].!
----- Method: MethodContext>>printOn: (in category 'printing') -----
printOn: aStream
| h |
self isExecutingBlock ifFalse: [^ super printOn: aStream].
h _ self blockHome.
h ifNil: [^ aStream nextPutAll: '[]'].
aStream nextPutAll: '[] from '.
h printOn: aStream!
----- Method: MethodContext>>printString (in category 'printing') -----
printString
"Answer an emphasized string in case of a breakpoint method"
^self method hasBreakpoint
ifTrue:[(super printString , ' [break]') asText allBold]
ifFalse:[super printString]!
----- Method: MethodContext>>privRefresh (in category 'initialize-release') -----
privRefresh
"Reinitialize the receiver so that it is in the state it was at its creation."
pc _ method initialPC.
self stackp: method numTemps.
method numArgs+1 to: method numTemps
do: [:i | self tempAt: i put: nil]!
----- 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."
method _ aCompiledMethod.
receiverMap _ nil.
self privRefresh!
----- Method: MethodContext>>receiver (in category 'accessing') -----
receiver
"Refer to the comment in ContextPart|receiver."
^receiver!
----- Method: MethodContext>>receiver: (in category 'private-exceptions') -----
receiver: r
receiver := r!
----- Method: MethodContext>>removeSelf (in category 'accessing') -----
removeSelf
"Nil the receiver pointer and answer its former value."
| tempSelf |
tempSelf _ receiver.
receiver _ nil.
^tempSelf!
----- Method: MethodContext>>restartWithNewReceiver: (in category 'private-exceptions') -----
restartWithNewReceiver: obj
self
swapReceiver: obj;
restart!
----- 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.
receiverMap _ nil.
pc _ method initialPC.
self stackp: method numTemps.
1 to: args size do: [:i | self at: i put: (args at: i)]!
----- Method: MethodContext>>startpc (in category 'private') -----
startpc
^ self method initialPC!
----- Method: MethodContext>>swapReceiver: (in category 'private-exceptions') -----
swapReceiver: r
receiver := r!
----- Method: MethodContext>>tempAt: (in category 'accessing') -----
tempAt: index
"Refer to the comment in ContextPart|tempAt:."
^self at: index!
----- Method: MethodContext>>tempAt:put: (in category 'accessing') -----
tempAt: index put: value
"Refer to the comment in ContextPart|tempAt:put:."
^self at: index put: value!
----- Method: MethodContext>>who (in category 'printing') -----
who
| sel mcls |
self method ifNil: [^ Array with: #unknown with: #unknown].
sel _ self receiver class
selectorAtMethod: self method
setClass: [:c | mcls _ c].
sel == #? ifTrue: [^ self method who].
^ Array with: mcls with: sel
!
----- 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."
!
----- 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!
----- Method: InstructionStream>>addSelectorTo: (in category 'scanning') -----
addSelectorTo: set
"If this instruction is a send, add its selector to set."
| byte literalNumber byte2 |
byte _ self method at: pc.
byte < 128 ifTrue: [^self].
byte >= 176
ifTrue:
["special byte or short send"
byte >= 208
ifTrue: [set add: (self method literalAt: (byte bitAnd: 15) + 1)]
ifFalse: [set add: (Smalltalk specialSelectorAt: byte - 176 + 1)]]
ifFalse:
[(byte between: 131 and: 134)
ifTrue:
[byte2 _ self method at: pc + 1.
byte = 131 ifTrue: [set add: (self method literalAt: byte2 \\ 32 + 1)].
byte = 132 ifTrue: [byte2 < 64 ifTrue: [set add: (self method literalAt: (self method at: pc + 2) + 1)]].
byte = 133 ifTrue: [set add: (self method literalAt: byte2 \\ 32 + 1)].
byte = 134 ifTrue: [set add: (self method literalAt: byte2 \\ 64 + 1)]]]!
----- Method: InstructionStream>>atEnd (in category 'decoding') -----
atEnd
^ pc > self method endPC!
----- Method: InstructionStream>>followingByte (in category 'scanning') -----
followingByte
"Answer the next bytecode."
^self method at: pc + 1!
----- Method: InstructionStream>>interpret (in category 'decoding') -----
interpret
[self atEnd] whileFalse: [self interpretNextInstructionFor: self]!
----- Method: InstructionStream>>interpretExtension:in:for: (in category 'private') -----
interpretExtension: 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 error: 'unusedBytecode'!
----- Method: InstructionStream>>interpretJump (in category 'decoding') -----
interpretJump
| 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!
----- Method: InstructionStream>>interpretNextInstructionFor: (in category 'decoding') -----
interpretNextInstructionFor: 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.
type=0 ifTrue: [^client pushReceiverVariable: offset].
type=1 ifTrue: [^client pushTemporaryVariable: offset].
type=2 ifTrue: [^client pushConstant: (method literalAt: offset+1)].
type=3 ifTrue: [^client pushConstant: (method literalAt: offset+17)].
type=4 ifTrue: [^client pushLiteralVariable: (method literalAt: offset+1)].
type=5 ifTrue: [^client pushLiteralVariable: (method literalAt: offset+17)].
type=6
ifTrue: [offset<8
ifTrue: [^client popIntoReceiverVariable: offset]
ifFalse: [^client popIntoTemporaryVariable: offset-8]].
type=7
ifTrue: [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].
offset>13 ifTrue: [^self error: 'unusedBytecode']].
type=8 ifTrue: [^self interpretExtension: offset in: method for: client].
type=9
ifTrue: "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
ifTrue:
[^client
send: (Smalltalk specialSelectorAt: offset+1)
super: false
numArgs: (Smalltalk specialNargsAt: offset+1)].
type=12
ifTrue:
[^client
send: (Smalltalk specialSelectorAt: offset+17)
super: false
numArgs: (Smalltalk specialNargsAt: offset+17)].
type>12
ifTrue:
[^client send: (method literalAt: offset+1)
super: false
numArgs: type-13]!
----- 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)"!
----- 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!
----- Method: InstructionStream>>nextByte (in category 'scanning') -----
nextByte
"Answer the next bytecode."
^self method at: pc!
----- 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!
----- Method: InstructionStream>>pc (in category 'scanning') -----
pc
"Answer the index of the next bytecode."
^pc!
----- Method: InstructionStream>>pc: (in category 'private') -----
pc: n
pc _ n!
----- 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!
----- Method: InstructionStream>>previousPc (in category 'scanning') -----
previousPc
| currentPc dummy prevPc |
currentPc _ pc.
pc _ self method initialPC.
dummy _ MessageCatcher new.
[pc = currentPc] whileFalse: [
prevPc _ pc.
self interpretNextInstructionFor: dummy.
].
^ prevPc!
----- Method: InstructionStream>>scanFor: (in category 'scanning') -----
scanFor: scanBlock
"Answer the index of the first bytecode for which scanBlock answer true
when supplied with that bytecode."
| method end byte type |
method _ self method.
end _ method endPC.
[pc <= end]
whileTrue:
[(scanBlock value: (byte _ method at: pc)) ifTrue: [^true].
type _ byte // 16.
pc _
type = 8
ifTrue: ["extensions"
pc + (#(2 2 2 2 3 2 2 1 1 1 ) at: byte \\ 16 + 1)]
ifFalse: [type = 10
ifTrue: [pc + 2"long jumps"]
ifFalse: [pc + 1]]].
^false!
----- Method: InstructionStream>>skipBackBeforeJump (in category 'scanning') -----
skipBackBeforeJump
"Assuming that the receiver is positioned jast after a jump, skip back one or two bytes, depending on the size of the previous jump instruction."
| strm short |
strm _ InstructionStream on: self method.
(strm scanFor: [:byte |
((short _ byte between: 152 and: 159) or: [byte between: 168 and: 175])
and: [strm pc = (short ifTrue: [pc-1] ifFalse: [pc-2])]]) ifFalse: [self error: 'Where''s the jump??'].
self jump: (short ifTrue: [-1] ifFalse: [-2]).
!
----- Method: InstructionStream>>thirdByte (in category 'scanning') -----
thirdByte
"Answer the next bytecode."
^self method at: pc + 2!
----- Method: InstructionStream>>willBlockReturn (in category 'testing') -----
willBlockReturn
^ (self method at: pc) = Encoder blockReturnCode!
----- Method: InstructionStream>>willJump (in category 'testing') -----
willJump
"unconditionally"
| byte |
byte _ self method at: pc.
^ (byte between: 144 and: 151) or: [byte between: 160 and: 167]!
----- Method: InstructionStream>>willJumpIfFalse (in category 'testing') -----
willJumpIfFalse
"Answer whether the next bytecode is a jump-if-false."
| byte |
byte _ self method at: pc.
^(byte between: 152 and: 159) or: [byte between: 172 and: 175]!
----- Method: InstructionStream>>willJumpIfTrue (in category 'testing') -----
willJumpIfTrue
"Answer whether the next bytecode is a jump-if-true."
| byte |
byte _ self method at: pc.
^ byte between: 168 and: 171!
----- Method: InstructionStream>>willJustPop (in category 'testing') -----
willJustPop
^ (self method at: pc) = Encoder popCode!
----- Method: InstructionStream>>willReallySend (in category 'testing') -----
willReallySend
"Answer whether the next bytecode is a real message-send,
not blockCopy:."
| byte |
byte _ self method at: pc.
byte < 128 ifTrue: [^false].
byte == 200 ifTrue: [^false].
byte >= 176 ifTrue: [^true]. "special send or short send"
^byte between: 131 and: 134 "long sends"!
----- Method: InstructionStream>>willReturn (in category 'testing') -----
willReturn
"Answer whether the next bytecode is a return."
^(self method at: pc) between: 120 and: 125!
----- Method: InstructionStream>>willSend (in category 'testing') -----
willSend
"Answer whether the next bytecode is a message-send."
| byte |
byte _ self method at: pc.
byte < 128 ifTrue: [^false].
byte >= 176 ifTrue: [^true]. "special send or short send"
^byte between: 131 and: 134 "long sends"!
----- Method: InstructionStream>>willStore (in category 'testing') -----
willStore
"Answer whether the next bytecode is a store or store-pop"
| byte |
byte _ self method at: pc.
^(byte between: 96 and: 132) and: [
byte <= 111 or: [byte >= 129 and: [
byte <= 130 or: [byte = 132 and: [
(self method at: pc+1) >= 160]]]]]!
----- Method: InstructionStream>>willStorePop (in category 'testing') -----
willStorePop
"Answer whether the next bytecode is a store-pop."
| byte |
byte _ self method at: pc.
^byte = 130 or: [byte between: 96 and: 111]!
Object subclass: #Magnitude
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Kernel-Numbers'!
!Magnitude commentStamp: '<historical>' prior: 0!
Magnitude has methods for dealing with linearly ordered collections.
Subclasses represent dates, times, and numbers.
Example for interval-testing (answers a Boolean):
7 between: 5 and: 10
No instance-variables.
!
----- Method: Magnitude>>< (in category 'comparing') -----
< aMagnitude
"Answer whether the receiver is less than the argument."
^self subclassResponsibility!
----- Method: Magnitude>><= (in category 'comparing') -----
<= aMagnitude
"Answer whether the receiver is less than or equal to the argument."
^(self > aMagnitude) not!
----- 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!
----- Method: Magnitude>>> (in category 'comparing') -----
> aMagnitude
"Answer whether the receiver is greater than the argument."
^aMagnitude < self!
----- Method: Magnitude>>>= (in category 'comparing') -----
>= aMagnitude
"Answer whether the receiver is greater than or equal to the argument."
^(self < aMagnitude) not!
----- 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."
^self >= min and: [self <= max]!
----- Method: Magnitude>>hash (in category 'comparing') -----
hash
"Hash must be redefined whenever = is redefined."
^self subclassResponsibility!
----- Method: Magnitude>>hashMappedBy: (in category 'comparing') -----
hashMappedBy: map
"My hash is independent of my oop."
^self hash!
----- 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]!
----- 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]!
----- Method: Magnitude>>min:max: (in category 'testing') -----
min: aMin max: aMax
^ (self min: aMin) max: aMax!
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.!
Number variableWordSubclass: #Float
instanceVariableNames: ''
classVariableNames: 'E Epsilon Halfpi Infinity Ln10 Ln2 MaxVal MaxValLn MinValLogBase2 NaN NegativeInfinity NegativeZero Pi RadiansPerDegree Sqrt2 ThreePi Twopi'
poolDictionaries: ''
category: 'Kernel-Numbers'!
!Float commentStamp: '<historical>' prior: 0!
My instances represent IEEE-754 floating-point double-precision numbers. They have about 16 digits of accuracy and their range is between plus and minus 10^307. Some valid examples are:
8.0 13.3 0.3 2.5e6 1.27e-30 1.27e-31 -12.987654e12
Mainly: no embedded blanks, little e for tens power, and a digit on both sides of the decimal point. It is actually possible to specify a radix for Squeak Float constants. This is great for teaching about numbers, but may be confusing to the average reader:
3r20.2 --> 6.66666666666667
8r20.2 --> 16.25
If you don't have access to the definition of IEEE-754, you can figure out what is going on by printing various simple values in Float hex. It may help you to know that the basic format is...
sign 1 bit
exponent 11 bits with bias of 1023 (16r3FF) to produce an exponent
in the range -1023 .. +1024
- 16r000:
significand = 0: Float zero
significand ~= 0: Denormalized number (exp = -1024, no hidden '1' bit)
- 16r7FF:
significand = 0: Infinity
significand ~= 0: Not A Number (NaN) representation
mantissa 53 bits, but only 52 are stored (20 in the first word, 32 in the second). This is because a normalized mantissa, by definition, has a 1 to the right of its floating point, and IEEE-754 omits this redundant bit to gain an extra bit of precision instead. People talk about the mantissa without its leading one as the FRACTION, and with its leading 1 as the SIGNFICAND.
The single-precision format is...
sign 1 bit
exponent 8 bits, with bias of 127, to represent -126 to +127
- 0x0 and 0xFF reserved for Float zero (mantissa is ignored)
- 16r7F reserved for Float underflow/overflow (mantissa is ignored)
mantissa 24 bits, but only 23 are stored
This format is used in FloatArray (qv), and much can be learned from the conversion routines, Float asIEEE32BitWord, and Float class fromIEEE32Bit:.
Thanks to Rich Harmon for asking many questions and to Tim Olson, Bruce Cohen, Rick Zaccone and others for the answers that I have collected here.!
----- Method: Float class>>ccg:emitLoadFor:from:on: (in category 'plugin generation') -----
ccg: cg emitLoadFor: aString from: anInteger on: aStream
cg emitLoad: aString asFloatValueFrom: anInteger on: aStream!
----- Method: Float class>>ccg:generateCoerceToOopFrom:on: (in category 'plugin generation') -----
ccg: cg generateCoerceToOopFrom: aNode on: aStream
cg generateCoerceToFloatObjectFrom: aNode on: aStream!
----- Method: Float class>>ccg:generateCoerceToValueFrom:on: (in category 'plugin generation') -----
ccg: cg generateCoerceToValueFrom: aNode on: aStream
cg generateCoerceToFloatValueFrom: aNode on: aStream!
----- Method: Float class>>ccg:prolog:expr:index: (in category 'plugin generation') -----
ccg: cg prolog: aBlock expr: aString index: anInteger
^cg ccgLoad: aBlock expr: aString asFloatValueFrom: anInteger!
----- Method: Float class>>ccgCanConvertFrom: (in category 'plugin generation') -----
ccgCanConvertFrom: anObject
^anObject class == self!
----- Method: Float class>>ccgDeclareCForVar: (in category 'plugin generation') -----
ccgDeclareCForVar: aSymbolOrString
^'double ', aSymbolOrString!
----- Method: Float class>>e (in category 'constants') -----
e
"Answer the constant, E."
^E!
----- Method: Float class>>fromIEEE32Bit: (in category 'instance creation') -----
fromIEEE32Bit: word
"Convert the given 32 bit word (which is supposed to be a positive 32bit value) from a 32bit IEEE floating point representation into an actual Squeak float object (being 64bit wide). Should only be used for conversion in FloatArrays or likewise objects."
| sign mantissa exponent newFloat |
word negative ifTrue: [^ self error:'Cannot deal with negative numbers'].
word = 0 ifTrue:[^ 0.0].
mantissa _ word bitAnd: 16r7FFFFF.
exponent _ ((word bitShift: -23) bitAnd: 16rFF) - 127.
sign _ word bitAnd: 16r80000000.
exponent = 128 ifTrue:["Either NAN or INF"
mantissa = 0 ifFalse:[^ Float nan].
sign = 0
ifTrue:[^ Float infinity]
ifFalse:[^ Float infinity negated]].
"Create new float"
newFloat _ self new: 2.
newFloat basicAt: 1 put: ((sign bitOr: (1023 + exponent bitShift: 20)) bitOr: (mantissa bitShift: -3)).
newFloat basicAt: 2 put: ((mantissa bitAnd: 7) bitShift: 29).
^newFloat!
----- Method: Float class>>halfPi (in category 'constants') -----
halfPi
^ Halfpi!
----- Method: Float class>>infinity (in category 'constants') -----
infinity
"Answer the value used to represent an infinite magnitude"
^ Infinity!
----- 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.7976931348623159e308.
MaxValLn _ 709.782712893384.
MinValLogBase2 _ -1074.
Infinity _ MaxVal * MaxVal.
NegativeInfinity _ 0.0 - Infinity.
NaN _ Infinity - Infinity.
NegativeZero _ 1.0 / Infinity negated.
!
----- Method: Float class>>nan (in category 'constants') -----
nan
"Answer the canonical value used to represent Not-A-Number"
^ NaN!
----- Method: Float class>>negativeZero (in category 'constants') -----
negativeZero
^ NegativeZero!
----- Method: Float class>>pi (in category 'constants') -----
pi
"Answer the constant, Pi."
^Pi!
----- Method: Float class>>readFrom: (in category 'instance creation') -----
readFrom: aStream
"Answer a new Float as described on the stream, aStream."
^(super readFrom: aStream) asFloat!
----- Method: Float class>>threePi (in category 'constants') -----
threePi
^ ThreePi
!
----- Method: Float class>>twoPi (in category 'constants') -----
twoPi
^ Twopi
!
----- Method: Float>>* (in category 'arithmetic') -----
* aNumber
"Primitive. Answer the result of multiplying the receiver by aNumber.
Fail if the argument is not a Float. Essential. See Object documentation
whatIsAPrimitive."
<primitive: 49>
^ aNumber adaptToFloat: self andSend: #*!
----- Method: Float>>+ (in category 'arithmetic') -----
+ aNumber
"Primitive. Answer the sum of the receiver and aNumber. Essential.
Fail if the argument is not a Float. See Object documentation
whatIsAPrimitive."
<primitive: 41>
^ aNumber adaptToFloat: self andSend: #+!
----- Method: Float>>- (in category 'arithmetic') -----
- aNumber
"Primitive. Answer the difference between the receiver and aNumber.
Fail if the argument is not a Float. Essential. See Object documentation
whatIsAPrimitive."
<primitive: 42>
^ aNumber adaptToFloat: self andSend: #-!
----- Method: Float>>/ (in category 'arithmetic') -----
/ aNumber
"Primitive. Answer the result of dividing receiver by aNumber.
Fail if the argument is not a Float. Essential. See Object documentation
whatIsAPrimitive."
<primitive: 50>
aNumber isZero ifTrue: [^ Preferences eToyFriendly ifTrue: [ScriptingSystem reportToUser: 'division by zero' translated] ifFalse: [(ZeroDivide dividend: self) signal]].
^ aNumber adaptToFloat: self andSend: #/!
----- Method: Float>>< (in category 'comparing') -----
< aNumber
"Primitive. Compare the receiver with the argument and return true
if the receiver is less than the argument. Otherwise return false.
Fail if the argument is not a Float. Essential. See Object documentation
whatIsAPrimitive."
<primitive: 43>
^ aNumber adaptToFloat: self andSend: #<!
----- Method: Float>><= (in category 'comparing') -----
<= aNumber
"Primitive. Compare the receiver with the argument and return true
if the receiver is less than or equal to the argument. Otherwise return
false. Fail if the argument is not a Float. Optional. See Object
documentation whatIsAPrimitive."
<primitive: 45>
^ aNumber adaptToFloat: self andSend: #<=!
----- Method: Float>>= (in category 'comparing') -----
= aNumber
"Primitive. Compare the receiver with the argument and return true
if the receiver is equal to the argument. Otherwise return false.
Fail if the argument is not a Float. Essential. See Object documentation
whatIsAPrimitive."
<primitive: 47>
aNumber isNumber ifFalse: [^ false].
^ aNumber adaptToFloat: self andSend: #=!
----- Method: Float>>> (in category 'comparing') -----
> aNumber
"Primitive. Compare the receiver with the argument and return true
if the receiver is greater than the argument. Otherwise return false.
Fail if the argument is not a Float. Essential. See Object documentation
whatIsAPrimitive."
<primitive: 44>
^ aNumber adaptToFloat: self andSend: #>!
----- Method: Float>>>= (in category 'comparing') -----
>= aNumber
"Primitive. Compare the receiver with the argument and return true
if the receiver is greater than or equal to the argument. Otherwise return
false. Fail if the argument is not a Float. Optional. See Object documentation
whatIsAPrimitive. "
<primitive: 46>
^ aNumber adaptToFloat: self andSend: #>!
----- Method: Float>>abs (in category 'arithmetic') -----
abs
"This is faster than using Number abs."
self < 0.0
ifTrue: [^ 0.0 - self]
ifFalse: [^ self]!
----- 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]!
----- 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."
| fBase significand exp baseExpEstimate be be1 r s mPlus mMinus scale roundingIncludesLimits d tc1 tc2 fixedFormat decPointCount |
self isInfinite ifTrue: [aStream nextPutAll: 'Infinity'. ^ self].
fBase _ base asFloat.
significand _ self significandAsInteger.
roundingIncludesLimits _ significand even.
exp _ (self exponent - 52) max: MinValLogBase2.
baseExpEstimate _ (self exponent * fBase reciprocalLogBase2 - 1.0e-10) ceiling.
exp >= 0
ifTrue:
[be _ 1 << exp.
significand ~= 16r10000000000000
ifTrue:
[r _ significand * be * 2.
s _ 2.
mPlus _ be.
mMinus _ be]
ifFalse:
[be1 _ be * 2.
r _ significand * be1 * 2.
s _ 4.
mPlus _ be1.
mMinus _ be]]
ifFalse:
[(exp = MinValLogBase2) | (significand ~= 16r10000000000000)
ifTrue:
[r _ significand * 2.
s _ (1 << (exp negated)) * 2.
mPlus _ 1.
mMinus _ 1]
ifFalse:
[r _ significand * 4.
s _ (1 << (exp negated + 1)) * 2.
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) | (roundingIncludesLimits & (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].
[d _ r // s.
r _ r \\ s.
(tc1 _ (r < mMinus) | (roundingIncludesLimits & (r = mMinus))) |
(tc2 _ (r + mPlus > s) | (roundingIncludesLimits & (r + mPlus = s)))] whileFalse:
[aStream nextPut: (Character digitValue: d).
r _ r * base.
mPlus _ mPlus * base.
mMinus _ mMinus * base.
decPointCount _ decPointCount - 1.
decPointCount = 0 ifTrue: [aStream nextPut: $.]].
tc2 ifTrue:
[tc1 not | (tc1 & (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]!
----- 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:
[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 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]!
----- Method: Float>>absPrintOn:base:digitCount: (in category 'private') -----
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 isInf ifTrue: [^ aStream nextPutAll: 'Inf'].
fBase _ base asFloat.
"x is myself normalized to [1.0, fBase), exp is my exponent"
exp _
self < 1.0
ifTrue: [self reciprocalFloorLog: fBase]
ifFalse: [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]!
----- Method: Float>>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!
----- 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!
----- 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!
----- Method: Float>>arcCos (in category 'mathematical functions') -----
arcCos
"Answer the angle in radians."
^ Halfpi - self arcSin!
----- Method: Float>>arcSin (in category 'mathematical functions') -----
arcSin
"Answer the angle in radians."
((self < -1.0) or: [self > 1.0]) ifTrue: [self error: 'Value out of range'].
((self = -1.0) or: [self = 1.0])
ifTrue: [^ Halfpi * self]
ifFalse: [^ (self / (1.0 - (self * self)) sqrt) arcTan]!
----- Method: Float>>arcTan (in category 'mathematical functions') -----
arcTan
"Answer the angle in radians.
Optional. See Object documentation whatIsAPrimitive."
| theta eps step sinTheta cosTheta |
<primitive: 57>
"Newton-Raphson"
self < 0.0 ifTrue: [ ^ 0.0 - (0.0 - self) arcTan ].
"first guess"
theta _ (self * Halfpi) / (self + 1.0).
"iterate"
eps _ Halfpi * Epsilon.
step _ theta.
[(step * step) > eps] whileTrue: [
sinTheta _ theta sin.
cosTheta _ theta cos.
step _ (sinTheta * cosTheta) - (self * cosTheta * cosTheta).
theta _ theta - step].
^ theta!
----- Method: Float>>arcTan: (in category 'mathematical functions') -----
arcTan: denominator
"Answer the angle in radians.
Optional. See Object documentation whatIsAPrimitive."
| result |
(self = 0.0) ifTrue: [ (denominator > 0.0) ifTrue: [ result _ 0 ]
ifFalse: [ result _ Pi ]
]
ifFalse: [(denominator = 0.0)
ifTrue: [ (self > 0.0) ifTrue: [ result _ Halfpi ]
ifFalse: [ result _ Halfpi negated ]
]
ifFalse: [ (denominator > 0) ifTrue: [ result _ (self / denominator) arcTan ]
ifFalse: [ result _ ((self / denominator) arcTan) + Pi ]
].
].
^ result.!
----- 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!
----- 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]!
----- Method: Float>>asComplex (in category 'converting') -----
asComplex
"Answer a Complex number that represents value of the the receiver."
^ Complex real: self imaginary: 0!
----- Method: Float>>asFloat (in category 'converting') -----
asFloat
"Answer the receiver itself."
^self!
----- Method: Float>>asFraction (in category 'converting') -----
asFraction
^ self asTrueFraction !
----- 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 |
self = 0.0 ifTrue:[^0].
word1 _ self basicAt: 1.
word2 _ self basicAt: 2.
mantissa _ (word2 bitShift: -29) + ((word1 bitAnd: 16rFFFFF) bitShift: 3).
exponent _ ((word1 bitShift: -20) bitAnd: 16r7FF) - 1023 + 127.
exponent < 0 ifTrue:[^0]. "Underflow"
exponent > 254 ifTrue:["Overflow"
exponent _ 255.
mantissa _ 0].
sign _ word1 bitAnd: 16r80000000.
destWord _ (sign bitOr: (exponent bitShift: 23)) bitOr: mantissa.
^ destWord!
----- 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 not handle gradual underflow or NANs.)
By David N. Smith with significant performance
improvements by Luciano Esteban Notarfrancesco.
(Version of 11April97)"
| shifty sign expPart exp fraction fractionPart 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 bits of an IEEE double float "
shifty := ((self basicAt: 1) bitShift: 32) + (self basicAt: 2).
" Extract the sign and the biased exponent "
sign := (shifty bitShift: -63) = 0 ifTrue: [1] ifFalse: [-1].
expPart := (shifty bitShift: -52) bitAnd: 16r7FF.
" Extract fractional part; answer 0 if this is a true 0.0 value "
fractionPart := shifty bitAnd: 16r000FFFFFFFFFFFFF.
( expPart=0 and: [ fractionPart=0 ] ) ifTrue: [ ^ 0 ].
" Replace omitted leading 1 in fraction "
fraction := fractionPart bitOr: 16r0010000000000000.
"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 := sign * fraction 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 := sign * fraction bitShift:
zeroBitsCount negated ]
ifFalse: [
result := Fraction
numerator: (sign * fraction
bitShift: zeroBitsCount negated)
denominator: (1 bitShift:
exp) ] ].
"Low cost validation omitted after extensive testing"
"(result asFloat = self) ifFalse: [self error: 'asTrueFraction validation failed']."
^ result !
----- 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]]!
----- Method: Float>>closeTo: (in category 'comparing') -----
closeTo: num
"are these two numbers close?"
| fuzz ans |
num isNumber ifFalse: [
[ans _ self = num] ifError: [:aString :aReceiver | ^ false].
^ ans].
self = 0.0 ifTrue: [^ num abs < 0.0001].
num = 0.0 ifTrue: [^ self abs < 0.0001].
self isNaN == num isNaN ifFalse: [^ false].
self isInfinite == num isInfinite ifFalse: [^ false].
fuzz := (self abs max: num abs) * 0.0001.
^ (self - num) abs <= fuzz!
----- Method: Float>>cos (in category 'mathematical functions') -----
cos
"Answer the cosine of the receiver taken as an angle in radians."
^ (self + Halfpi) sin!
----- Method: Float>>cubeRoot (in category 'mathematical functions') -----
cubeRoot
"Answer the cube root of the receiver."
^ self sign * (self abs raisedTo: 1 / 3)
"
8 cubeRoot
0 cubeRoot
1728 cubeRoot
3.14159265 cubeRoot
"!
----- Method: Float>>deepCopy (in category 'copying') -----
deepCopy
^self copy!
----- Method: Float>>degreeArcTan (in category 'mathematical functions') -----
degreeArcTan
"The receiver is the tangent of an angle. Answer the angle measured in degrees."
^ self arcTan radiansToDegrees!
----- Method: Float>>degreeCos (in category 'mathematical functions') -----
degreeCos
"Answer the cosine of the receiver taken as an angle in degrees."
^ self degreesToRadians cos!
----- Method: Float>>degreeSin (in category 'mathematical functions') -----
degreeSin
"Answer the sine of the receiver taken as an angle in degrees."
^ self degreesToRadians sin!
----- Method: Float>>degreeTan (in category 'mathematical functions') -----
degreeTan
"Answer the tangent of the receiver taken as an angle in degrees."
^ self degreesToRadians tan!
----- Method: Float>>degreesToRadians (in category 'converting') -----
degreesToRadians
"Answer the receiver in radians. Assumes the receiver is in degrees."
^self * RadiansPerDegree!
----- Method: Float>>exp (in category 'mathematical functions') -----
exp
"Answer E raised to the receiver power.
Optional. See Object documentation whatIsAPrimitive."
| base fract correction delta div |
<primitive: 59>
"Taylor series"
"check the special cases"
self < 0.0 ifTrue: [^ (self negated exp) reciprocal].
self = 0.0 ifTrue: [^ 1].
self abs > MaxValLn ifTrue: [self error: 'exp overflow'].
"get first approximation by raising e to integer power"
base _ E raisedToInteger: (self truncated).
"now compute the correction with a short Taylor series"
"fract will be 0..1, so correction will be 1..E"
"in the worst case, convergance time is logarithmic with 1/Epsilon"
fract _ self fractionPart.
fract = 0.0 ifTrue: [ ^ base ]. "no correction required"
correction _ 1.0 + fract.
delta _ fract * fract / 2.0.
div _ 2.0.
[delta > Epsilon] whileTrue: [
correction _ correction + delta.
div _ div + 1.0.
delta _ delta * fract / div].
correction _ correction + delta.
^ base * correction!
----- Method: Float>>exponent (in category 'truncation and round off') -----
exponent
"Primitive. Consider the receiver to be represented as a power of two
multiplied by a mantissa (between one and two). Answer with the
SmallInteger to whose power two is raised. Optional. See Object
documentation whatIsAPrimitive."
| positive |
<primitive: 53>
self >= 1.0 ifTrue: [^self floorLog: 2].
self > 0.0
ifTrue:
[positive _ (1.0 / self) exponent.
self = (1.0 / (1.0 timesTwoPower: positive))
ifTrue: [^positive negated]
ifFalse: [^positive negated - 1]].
self = 0.0 ifTrue: [^-1].
^self negated exponent!
----- Method: Float>>floorLog: (in category 'mathematical functions') -----
floorLog: radix
"Answer the floor of the log base radix of the receiver."
^ (self log: radix) floor
!
----- Method: Float>>fractionPart (in category 'truncation and round off') -----
fractionPart
"Primitive. Answer a Float whose value is the difference between the
receiver and the receiver's asInteger value. Optional. See Object
documentation whatIsAPrimitive."
<primitive: 52>
^self - self truncated asFloat!
----- Method: Float>>hash (in category 'comparing') -----
hash
"Hash is reimplemented because = is implemented. Both words of the float are used; 8 bits are removed from each end to clear most of the exponent regardless of the byte ordering. (The bitAnd:'s ensure that the intermediate results do not become a large integer.) Slower than the original version in the ratios 12:5 to 2:1 depending on values. (DNS, 11 May, 1997)"
^ (((self basicAt: 1) bitAnd: 16r00FFFF00) +
((self basicAt: 2) bitAnd: 16r00FFFF00)) bitShift: -8
!
----- Method: Float>>hex (in category 'printing') -----
hex "If ya really want to know..."
| word nibble |
^ String streamContents:
[:strm |
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]
"!
----- Method: Float>>integerPart (in category 'truncation and round off') -----
integerPart
"Answer a Float whose value is the receiver's truncated value."
^self - self fractionPart!
----- Method: Float>>isFloat (in category 'testing') -----
isFloat
^ true!
----- Method: Float>>isInf (in category 'converting') -----
isInf
"simple, byte-order independent test for +/- Infinity"
^ self = (self * 1.5 + 1.0)!
----- Method: Float>>isInfinite (in category 'testing') -----
isInfinite
"Return true if the receiver is positive or negative infinity."
^ self = Infinity or: [self = NegativeInfinity]
!
----- Method: Float>>isLiteral (in category 'testing') -----
isLiteral
^true!
----- Method: Float>>isNaN (in category 'testing') -----
isNaN
"simple, byte-order independent test for Not-a-Number"
^ self ~= self!
----- Method: Float>>isPowerOfTwo (in category 'testing') -----
isPowerOfTwo
"Return true if the receiver is an integral power of two.
Floats never return true here."
^false!
----- Method: Float>>isZero (in category 'testing') -----
isZero
^self = 0.0!
----- Method: Float>>ln (in category 'mathematical functions') -----
ln
"Answer the natural logarithm of the receiver.
Optional. See Object documentation whatIsAPrimitive."
| expt n mant x div pow delta sum eps |
<primitive: 58>
"Taylor series"
self <= 0.0 ifTrue: [self error: '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"!
----- Method: Float>>log (in category 'mathematical functions') -----
log
"Answer the base 10 logarithm of the receiver."
^ self ln / Ln10!
----- Method: Float>>negated (in category 'arithmetic') -----
negated
"Answer a Number that is the negation of the receiver."
^0.0 - self!
----- Method: Float>>printOn:base: (in category 'printing') -----
printOn: aStream base: base
"Handle sign, zero, and NaNs; all other values passed to absPrintOn:base:"
self isNaN ifTrue: [aStream nextPutAll: 'NaN'. ^ self]. "check for NaN before sign"
self > 0.0
ifTrue: [self absPrintOn: aStream base: base]
ifFalse:
[self sign = -1
ifTrue: [aStream nextPutAll: '-'].
self = 0.0
ifTrue: [aStream nextPutAll: '0.0'. ^ self]
ifFalse: [self negated absPrintOn: aStream base: base]]!
----- Method: Float>>radiansToDegrees (in category 'converting') -----
radiansToDegrees
"Answer the receiver in degrees. Assumes the receiver is in radians."
^self / RadiansPerDegree!
----- Method: Float>>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].
self < 0.0 ifTrue:
[ ArithmeticError signal: ' raised to a non-integer power' ].
0.0 = aNumber ifTrue: [^ 1.0]. "special case for exponent = 0.0"
(self= 0.0) | (aNumber = 1.0) ifTrue: [^ self]. "special case for self = 1.0"
^ (self ln * aNumber asFloat) exp "otherwise use logarithms"
!
----- Method: Float>>reciprocal (in category 'arithmetic') -----
reciprocal
^ 1.0 / self!
----- 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!
----- 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]!
----- 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]!
----- Method: Float>>rounded (in category 'truncation and round off') -----
rounded
"Answer the integer nearest the receiver."
self >= 0.0
ifTrue: [^(self + 0.5) truncated]
ifFalse: [^(self - 0.5) truncated]!
----- 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]!
----- Method: Float>>safeLn (in category 'mathematical functions') -----
safeLn
"Answer the natural logarithm of the receiver, safely"
self <= 0 ifTrue: [ScriptingSystem reportToUser: 'Ln of a nonpositive number, ' translated, self printString. ^ 0].
^ [self ln] on: FloatingPointException do:
[:exc |
ScriptingSystem reportToUser: 'Ln of negative number, ' translated, self printString.
exc return: 0]!
----- Method: Float>>safeLog (in category 'mathematical functions') -----
safeLog
"Answer the base-10 log of the receiver, safely"
self <= 0 ifTrue: [ScriptingSystem reportToUser: 'log of a nonpositive number, ' translated, self printString. ^ 0].
^ [self log] on: FloatingPointException do:
[:exc |
ScriptingSystem reportToUser:'logarithm does not exist' translated.
exc return: 0]!
----- Method: Float>>safeSquareRoot (in category 'mathematical functions') -----
safeSquareRoot
"Answer the square root of the receiver. If the receiver is negative, answer zero and swallow the error."
^ [self sqrt] on: FloatingPointException do: [:exc | ScriptingSystem reportToUser:'square root of negative number' translated. ^ 0]!
----- Method: Float>>shallowCopy (in category 'copying') -----
shallowCopy
^self + 0.0!
----- Method: Float>>sign (in category 'testing') -----
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 ifTrue: [^ 1].
(self < 0 or: [((self at: 1) bitShift: -31) = 1]) ifTrue: [^ -1].
^ 0!
----- Method: Float>>significand (in category 'truncation and round off') -----
significand
^ self timesTwoPower: (self exponent negated)!
----- Method: Float>>significandAsInteger (in category 'truncation and round off') -----
significandAsInteger
| exp sig |
exp _ self exponent.
sig _ (((self at: 1) bitAnd: 16r000FFFFF) bitShift: 32) bitOr: (self at: 2).
exp > -1023
ifTrue: [sig _ sig bitOr: (1 bitShift: 52)].
^ sig.!
----- Method: Float>>sin (in category 'mathematical functions') -----
sin
"Answer the sine of the receiver taken as an angle in radians.
Optional. See Object documentation whatIsAPrimitive."
| sum delta self2 i |
<primitive: 56>
"Taylor series"
"normalize to the range [0..Pi/2]"
self < 0.0 ifTrue: [^ (0.0 - ((0.0 - self) sin))].
self > Twopi ifTrue: [^ (self \\ Twopi) sin].
self > Pi ifTrue: [^ (0.0 - (self - Pi) sin)].
self > Halfpi ifTrue: [^ (Pi - self) sin].
"unroll loop to avoid use of abs"
sum _ delta _ self.
self2 _ 0.0 - (self * self).
i _ 2.0.
[delta > Epsilon] whileTrue: [
"once"
delta _ (delta * self2) / (i * (i + 1.0)).
i _ i + 2.0.
sum _ sum + delta.
"twice"
delta _ (delta * self2) / (i * (i + 1.0)).
i _ i + 2.0.
sum _ sum + delta].
^ sum!
----- Method: Float>>sqrt (in category 'mathematical functions') -----
sqrt
"Answer the square root of the receiver.
Optional. See Object documentation whatIsAPrimitive."
| exp guess eps delta |
<primitive: 55>
"Newton-Raphson"
self <= 0.0 ifTrue: [
self = 0.0
ifTrue: [^ 0.0]
ifFalse: [^ self error: 'sqrt is invalid for x < 0']].
"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!
----- Method: Float>>tan (in category 'mathematical functions') -----
tan
"Answer the tangent of the receiver taken as an angle in radians."
^ self sin / self cos!
----- Method: Float>>timesTwoPower: (in category 'mathematical functions') -----
timesTwoPower: anInteger
"Primitive. Answer with the receiver multiplied by 2.0 raised
to the power of the argument.
Optional. See Object documentation whatIsAPrimitive."
<primitive: 54>
anInteger < -29 ifTrue: [^ self * (2.0 raisedToInteger: anInteger)].
anInteger < 0 ifTrue: [^ self / (1 bitShift: (0 - anInteger)) asFloat].
anInteger < 30 ifTrue: [^ self * (1 bitShift: anInteger) asFloat].
^ self * (2.0 raisedToInteger: anInteger)!
----- Method: Float>>truncated (in category 'truncation and round off') -----
truncated
"Answer with a SmallInteger equal to the value of the receiver without
its fractional part. The primitive fails if the truncated value cannot be
represented as a SmallInteger. In that case, the code below will compute
a LargeInteger truncated value.
Essential. See Object documentation whatIsAPrimitive. "
<primitive: 51>
(self isInfinite or: [self isNaN]) ifTrue: [^ FloatingPointException signal: 'Cannot truncate this number' translated].
self abs < 2.0e16
ifTrue: ["Fastest way when it may not be an integer"
^ (self quo: 1073741823.0) * 1073741823 + (self rem: 1073741823.0) truncated]
ifFalse: [^ self asTrueFraction. "Extract all bits of the mantissa and shift if necess"]!
----- Method: Float>>veryDeepCopyWith: (in category 'copying') -----
veryDeepCopyWith: deepCopier
"Return self. Do not record me."
^ self clone!
----- Method: Float>>~= (in category 'comparing') -----
~= aNumber
"Primitive. Compare the receiver with the argument and return true
if the receiver is not equal to the argument. Otherwise return false.
Fail if the argument is not a Float. Optional. See Object documentation
whatIsAPrimitive."
<primitive: 48>
^super ~= aNumber!
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"
!
----- 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!
----- 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: #*!
----- Method: Fraction>>+ (in category 'arithmetic') -----
+ aNumber
"Answer the sum of the receiver and aNumber."
| n d d1 d2 |
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: #+!
----- Method: Fraction>>- (in category 'arithmetic') -----
- aNumber
"Answer the difference between the receiver and aNumber."
aNumber isFraction ifTrue:
[^ self + aNumber negated].
^ aNumber adaptToFraction: self andSend: #-!
----- 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: #/!
----- Method: Fraction>>< (in category 'comparing') -----
< aNumber
aNumber isFraction ifTrue:
[^ numerator * aNumber denominator < (aNumber numerator * denominator)].
^ aNumber adaptToFraction: self andSend: #<!
----- 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 andSend: #=!
----- Method: Fraction>>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!
----- 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."
^ rcvr asFraction perform: selector with: self!
----- Method: Fraction>>asComplex (in category 'converting') -----
asComplex
"Answer a Complex number that represents value of the the receiver."
^ Complex real: self imaginary: 0!
----- Method: Fraction>>asFloat (in category 'converting') -----
asFloat
"Answer a Float that closely approximates the value of the receiver.
Ideally, answer the Float that most closely approximates the receiver."
| nScaleBits dScaleBits nScaled dScaled |
"Scale the numerator by throwing away all but the
top 8 digits (57 to 64 significant bits) then making that a Float.
This keeps all of the precision of a Float (53 significand bits) but
guarantees that we do not exceed the range representable as a Float
(about 2 to the 1024th)"
nScaleBits _ 8 * ((numerator digitLength - 8) max: 0).
nScaled _ (numerator bitShift: nScaleBits negated) asFloat.
"Scale the denominator the same way."
dScaleBits _ 8 * ((denominator digitLength - 8) max: 0).
dScaled _ (denominator bitShift: dScaleBits negated) asFloat.
"Divide the scaled numerator and denominator to make the
right mantissa, then scale to correct the exponent."
^ (nScaled / dScaled) timesTwoPower: (nScaleBits - dScaleBits).!
----- Method: Fraction>>asFraction (in category 'converting') -----
asFraction
"Answer the receiver itself."
^self!
----- Method: Fraction>>denominator (in category 'private') -----
denominator
^denominator!
----- Method: Fraction>>hash (in category 'comparing') -----
hash
"Hash is reimplemented because = is implemented."
^numerator hash bitXor: denominator hash!
----- Method: Fraction>>isFraction (in category 'converting') -----
isFraction
^ true!
----- Method: Fraction>>negated (in category 'arithmetic') -----
negated
"Refer to the comment in Number|negated."
^ Fraction
numerator: numerator negated
denominator: denominator!
----- Method: Fraction>>numerator (in category 'private') -----
numerator
^numerator!
----- Method: Fraction>>printOn: (in category 'printing') -----
printOn: aStream
aStream nextPut: $(.
numerator printOn: aStream.
aStream nextPut: $/.
denominator printOn: aStream.
aStream nextPut: $).
!
----- 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: $).
!
----- 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)!
----- Method: Fraction>>reciprocal (in category 'private') -----
reciprocal
"Refer to the comment in Number|reciprocal."
numerator = 0 ifTrue: [self error: '0 has no reciprocal'].
numerator = 1 ifTrue: [^denominator].
numerator = -1 ifTrue: [^denominator negated].
^Fraction numerator: denominator denominator: numerator!
----- 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!
----- 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]]!
----- Method: Fraction>>squared (in category 'mathematical functions') -----
squared
"See Fraction (Number) | squared"
^ Fraction numerator: numerator squared denominator: denominator squared!
----- 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: $).
!
----- Method: Fraction>>truncated (in category 'truncation and round off') -----
truncated
"Refer to the comment in Number|truncated."
^numerator quo: denominator!
Number subclass: #Integer
instanceVariableNames: ''
classVariableNames: ''
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!
----- 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!
----- Method: Integer class>>byte1:byte2:byte3:byte4: (in category 'instance creation') -----
byte1: byte1 byte2: byte2 byte3: byte3 byte4: byte4
"Depending on high-order byte copy directly into a LargeInteger,
or build up a SmallInteger by shifting"
| value |
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!
----- Method: Integer class>>initializedInstance (in category 'instance creation') -----
initializedInstance
^ 2468!
----- 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]]!
----- 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 4 *GIGA*bytes).
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."
| limit flags maskBitIndex bitIndex maskBit byteIndex index primesUpTo2310 indexLimit |
limit _ max asInteger - 1.
indexLimit _ max sqrt truncated + 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).
1 to: 5 do:[:i| aBlock value: (primesUpTo2310 at: i)].
index _ 6.
2 to: 2309 do:[:n|
[(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)].
].
].
"Now the real work begins...
Start with 13 since multiples of 2,3,5,7,11 are handled by the storage method;
increment by 2 for odd numbers only."
13 to: limit by: 2 do:[:n|
(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 * i 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 bitAnd: 1) = 0 ifTrue:[index _ index + 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 + (2 * n)].
].
].
].
].
!
----- 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!
----- 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]!
----- 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]]!
----- 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"
| limit flags prime k |
limit _ max asInteger - 1.
"Fall back into #largePrimesUpTo:do: if we'd require more than 100k of memory;
the alternative will only requre 1/154th of the amount we need here and is almost as fast."
limit > 25000 ifTrue:[^self largePrimesUpTo: max do: aBlock].
flags _ (Array new: limit) atAllPut: true.
1 to: limit do: [:i |
(flags at: i) ifTrue: [
prime _ i + 1.
k _ i + prime.
[k <= limit] whileTrue: [
flags at: k put: false.
k _ k + prime].
aBlock value: prime]].
!
----- Method: Integer class>>readFrom: (in category 'instance creation') -----
readFrom: aStream
"Answer a new Integer as described on the stream, aStream.
Embedded radix specifiers not allowed - use Number readFrom: for that."
^self readFrom: aStream base: 10!
----- Method: Integer class>>readFrom:base: (in category 'instance creation') -----
readFrom: aStream base: base
"Answer an instance of one of my concrete subclasses. Initial minus sign
accepted, and bases > 10 use letters A-Z. Embedded radix specifiers not
allowed--use Number readFrom: for that. Answer zero (not an error) if
there are no digits."
| digit value neg startPos |
neg _ aStream peekFor: $-.
neg ifFalse: [aStream peekFor: $+].
value _ 0.
startPos _ aStream position.
[aStream atEnd]
whileFalse:
[digit _ aStream next digitValue.
(digit < 0 or: [digit >= base])
ifTrue:
[aStream skip: -1.
aStream position = startPos ifTrue: [self error: 'At least one digit expected here'].
neg ifTrue: [^ value negated].
^ value]
ifFalse: [value _ value * base + digit]].
neg ifTrue: [^ value negated].
^ value!
----- 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]].!
----- 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 nowTime |
lastTime _ Time millisecondClockValue.
Utilities informUserDuring:[:bar|
bar value:'Computing primes...'.
self primesUpTo: max do:[:prime|
aBlock value: prime.
nowTime _ Time millisecondClockValue.
(nowTime - lastTime > 1000) ifTrue:[
lastTime _ nowTime.
bar value:'Last prime found: ', prime printString]]].!
----- 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: #*!
----- 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 adaptToInteger: self andSend: #+!
----- 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 adaptToInteger: self andSend: #-!
----- Method: Integer>>/ (in category 'arithmetic') -----
/ aNumber
"Refer to the comment in Number / "
| quoRem |
aNumber isInteger ifTrue:
[quoRem _ self digitDiv: aNumber abs "*****I've added abs here*****"
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: #/!
----- Method: Integer>>// (in category 'arithmetic') -----
// aNumber
| q |
aNumber = 0 ifTrue: [^self error: 'division by 0'].
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]!
----- 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 andSend: #<!
----- Method: Integer>><< (in category 'bit manipulation') -----
<< shiftAmount "left shift"
shiftAmount < 0 ifTrue: [self error: 'negative arg'].
^ self bitShift: shiftAmount!
----- Method: Integer>>= (in category 'comparing') -----
= aNumber
aNumber isNumber ifFalse: [^ false].
aNumber isInteger ifTrue:
[aNumber negative == self negative
ifTrue: [^ (self digitCompare: aNumber) = 0]
ifFalse: [^ false]].
^ aNumber adaptToInteger: self andSend: #=!
----- 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 andSend: #>!
----- Method: Integer>>>> (in category 'bit manipulation') -----
>> shiftAmount "left shift"
shiftAmount < 0 ifTrue: [self error: 'negative arg'].
^ self bitShift: 0 - shiftAmount!
----- Method: Integer>>\\\ (in category 'arithmetic') -----
\\\ anInteger
"a modulo method for use in DSA. Be careful if you try to use this elsewhere."
^self \\ anInteger!
----- Method: Integer>>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!
----- Method: Integer>>adaptToFraction:andSend: (in category 'converting') -----
adaptToFraction: rcvr andSend: selector
"If I am involved in arithmetic with a Fraction, convert me to a Fraction."
^ rcvr perform: selector with: self asFraction!
----- 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"!
----- 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)!
----- 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!
----- 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)!
----- Method: Integer>>asCharacter (in category 'converting') -----
asCharacter
"Answer the Character whose value is the receiver."
^Character value: self!
----- Method: Integer>>asColorOfDepth: (in category 'converting') -----
asColorOfDepth: d
"Return a color value representing the receiver as color of the given depth"
^Color colorFromPixelValue: self depth: d!
----- Method: Integer>>asComplex (in category 'converting') -----
asComplex
"Answer a Complex number that represents value of the the receiver."
^ Complex real: self imaginary: 0!
----- Method: Integer>>asFloat (in category 'converting') -----
asFloat
"Answer a Float that represents the value of the receiver.
Optimized to process only the significant digits of a LargeInteger.
SqR: 11/30/1998 21:11"
| sum firstByte shift |
shift _ 0.
sum _ 0.0.
firstByte _ self size - 7 max: 1.
firstByte to: self size do:
[:byteIndex |
sum _ ((self digitAt: byteIndex) asFloat timesTwoPower: shift) + sum.
shift _ shift + 8].
^sum * self sign asFloat timesTwoPower: firstByte - 1 * 8!
----- Method: Integer>>asFraction (in category 'converting') -----
asFraction
"Answer a Fraction that represents value of the the receiver."
^Fraction numerator: self denominator: 1!
----- Method: Integer>>asHexDigit (in category 'converting') -----
asHexDigit
^'0123456789ABCDEF' at: self+1!
----- Method: Integer>>asInteger (in category 'converting') -----
asInteger
"Answer with the receiver itself."
^self
!
----- 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)]!
----- Method: Integer>>asPowerOfTwo (in category 'truncation and round off') -----
asPowerOfTwo
"Convert the receiver into a power of two"
^self asSmallerPowerOfTwo!
----- Method: Integer>>asPrecedenceName (in category 'tiles') -----
asPrecedenceName
^#('unary' 'binary' 'keyword') at: self
!
----- 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)]!
----- Method: Integer>>asStringWithCommas (in category 'printing') -----
asStringWithCommas
"123456789 asStringWithCommas"
"-123456789 asStringWithCommas"
| digits |
digits _ self abs printString.
^ String streamContents:
[:strm |
self sign = -1 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: $,]]]!
----- Method: Integer>>asStringWithCommasSigned (in category 'printing') -----
asStringWithCommasSigned
"123456789 asStringWithCommasSigned"
"-123456789 asStringWithCommasSigned"
| digits |
digits _ self abs printString.
^ String streamContents:
[:strm |
self sign = -1 ifTrue: [strm nextPut: $-] ifFalse:[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: $,]]]!
----- 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
"!
----- 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!
----- Method: Integer>>asYear (in category 'converting') -----
asYear
^ Year year: self
!
----- Method: Integer>>atRandom (in category 'truncation and round off') -----
atRandom
"Answer a random integer from 1 to self. This implementation uses a
shared generator. Heavy users should their own implementation or use
Interval>atRandom: directly."
self = 0 ifTrue: [ ^0 ].
self < 0 ifTrue: [ ^self negated atRandom negated ].
^Collection mutexForPicking critical: [
self atRandom: Collection randomForPicking ]!
----- 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!
----- 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]
!
----- 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!
----- 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)!
----- 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!
----- 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.!
----- Method: Integer>>bitInvert32 (in category 'bit manipulation') -----
bitInvert32
"Answer the 32-bit complement of the receiver."
^ self bitXor: 16rFFFFFFFF!
----- 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)!
----- 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]!
----- 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!
----- 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)!
----- Method: Integer>>byteEncode:base: (in category 'printing-numerative') -----
byteEncode: aStream base: base
aStream nextPutAll: (self printStringBase: base)
!
----- Method: Integer>>ceiling (in category 'truncation and round off') -----
ceiling
"Refer to the comment in Number|ceiling."!
----- Method: Integer>>copyto: (in category 'private') -----
copyto: x
| stop |
stop _ self digitLength min: x digitLength.
^ x replaceFrom: 1 to: stop with: self startingAt: 1!
----- Method: Integer>>destinationBuffer: (in category 'printing') -----
destinationBuffer:digitLength
digitLength <= 1
ifTrue: [self]
ifFalse: [LargePositiveInteger new: digitLength].!
----- 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!
----- Method: Integer>>digitBuffer: (in category 'printing') -----
digitBuffer:digitLength
^Array new:digitLength*8.!
----- 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!
----- 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 highBitOfPositiveReceiver.
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!
----- Method: Integer>>digitLogic:op:length: (in category 'private') -----
digitLogic: arg op: op length: len
| 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.
1 to: result digitLength do:
[:i |
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!
----- 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!
----- 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!
----- 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!
----- 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!
----- Method: Integer>>even (in category 'testing') -----
even
"Refer to the comment in Number|even."
^((self digitAt: 1) bitAnd: 1) = 0!
----- 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'!
----- Method: Integer>>floor (in category 'truncation and round off') -----
floor
"Refer to the comment in Number|floor."!
----- 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!
----- Method: Integer>>growby: (in category 'private') -----
growby: n
^self growto: self digitLength + n!
----- Method: Integer>>growto: (in category 'private') -----
growto: n
^self copyto: (self species new: n)!
----- Method: Integer>>hash (in category 'comparing') -----
hash
"Hash is reimplemented because = is implemented."
^(self lastDigit bitShift: 8) + (self digitAt: 1)!
----- Method: Integer>>hex (in category 'printing') -----
hex
self deprecated: 'Use ', self printString, ' printStringHex or ', self printString, ' storeStringHex instead!!'.
^ self storeStringBase: 16!
----- Method: Integer>>hex8 (in category 'deprecated') -----
hex8 "16r3333 hex8"
| hex |
self deprecated: 'Use ', self printString, ' storeStringBase: 16 length: 11 padded: true instead!!'.
hex _ self hex. "16rNNN"
hex size < 11
ifTrue: [^ hex copyReplaceFrom: 4 to: 3
with: ('00000000' copyFrom: 1 to: 11-hex size)]
ifFalse: [^ hex]!
----- 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!
----- 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!
----- Method: Integer>>isInteger (in category 'testing') -----
isInteger
"True for all subclasses of Integer."
^ true!
----- Method: Integer>>isLiteral (in category 'printing') -----
isLiteral
^true!
----- Method: Integer>>isPowerOfTwo (in category 'testing') -----
isPowerOfTwo
"Return true if the receiver is an integral power of two."
^ (self bitAnd: self-1) = 0!
----- 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!
----- Method: Integer>>lcm: (in category 'mathematical functions') -----
lcm: n
"Answer the least common multiple of the receiver and n."
^self // (self gcd: n) * n!
----- Method: Integer>>lowBit (in category 'bit manipulation') -----
lowBit
"Answer the index of the low order bit of this number."
| index |
self = 0 ifTrue: [ ^ 0 ].
index := 1.
[ (self digitAt: index) = 0 ]
whileTrue:
[ index := index + 1 ].
^ (self digitAt: index) lowBit + (8 * (index - 1))!
----- 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)!
----- Method: Integer>>normalize (in category 'truncation and round off') -----
normalize
"SmallInts OK; LgInts override"
^ self!
----- 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
!
----- Method: Integer>>printOn:base: (in category 'printing-numerative') -----
printOn: aStream base: base
aStream nextPutAll: (self printStringBase: base)!
----- 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
!
----- Method: Integer>>printShowingDecimalPlaces: (in category 'printing') -----
printShowingDecimalPlaces: placesDesired
"Print the receiver showing the given number of decimal places."
^ (self abs > 1.0e15)
ifTrue:
[super printShowingDecimalPlaces: placesDesired]
ifFalse:
[placesDesired > 0
ifTrue:
[self printString, '.', ('' padded: #right to: placesDesired with: $0)]
ifFalse:
[self printString]]!
----- Method: Integer>>printStringBase: (in category 'printing-numerative') -----
printStringBase: base
| stream integer next |
self = 0 ifTrue: [^'0'].
self negative ifTrue: [^'-', (self negated printStringBase: base)].
stream _ WriteStream on: String new.
integer _ self normalize.
[integer > 0] whileTrue: [
next _ integer quo: base.
stream nextPut: (Character digitValue: integer - (next * base)).
integer _ next].
^stream contents reversed
!
----- 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]!
----- Method: Integer>>printStringHex (in category 'printing-numerative') -----
printStringHex
^self printStringBase: 16!
----- Method: Integer>>printStringLength: (in category 'printing-numerative') -----
printStringLength: minimal
^self printStringLength: minimal padded: false
!
----- Method: Integer>>printStringLength:padded: (in category 'printing-numerative') -----
printStringLength: minimal padded: zeroFlag
^self printStringBase: 10 length: minimal padded: zeroFlag!
----- Method: Integer>>printStringPadded: (in category 'printing-numerative') -----
printStringPadded: minimal
^self printStringLength: minimal padded: true
!
----- Method: Integer>>printStringRoman (in category 'printing-numerative') -----
printStringRoman
| stream integer |
stream _ WriteStream on: String new.
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.
^stream contents!
----- 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 class == SmallInteger
ifTrue: [aNumber abs]
ifFalse: [aNumber])
neg: ng) at: 1.
^ quo normalize].
^ aNumber adaptToInteger: self andSend: #quo:!
----- Method: Integer>>radix: (in category 'printing-numerative') -----
radix: base
^ self printStringBase: base!
----- Method: Integer>>raisedTo:modulo: (in category 'mathematical functions') -----
raisedTo: y modulo: n
"Answer the modular exponential. Code by Jesse Welton."
| s t u |
s _ 1.
t _ self.
u _ y.
[u = 0] whileFalse: [
u odd ifTrue: [
s _ s * t.
s >= n ifTrue: [s _ s \\\ n]].
t _ t * t.
t >= n ifTrue: [t _ t \\\ n].
u _ u bitShift: -1].
^ s.
!
----- 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]!
----- 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]!
----- Method: Integer>>romanString (in category 'deprecated') -----
romanString "1999 romanString"
self deprecated: 'Use ', self printString, ' printStringRoman instead!!'.
[self > 0] assert.
^ String streamContents:
[:s |
self // 1000 timesRepeat: [s nextPut: $M].
self romanDigits: 'MDC' for: 100 on: s.
self romanDigits: 'CLX' for: 10 on: s.
self romanDigits: 'XVI' for: 1 on: s]!
----- Method: Integer>>rounded (in category 'truncation and round off') -----
rounded
"Refer to the comment in Number|rounded."!
----- Method: Integer>>safeFactorial (in category 'mathematical functions') -----
safeFactorial
"Answer the factorial of the receiver, guarding against bad argument"
self = 0 ifTrue: [^ 1].
self > 0 ifTrue: [^ self * (self - 1) factorial].
ScriptingSystem reportToUser: 'Factorial not defined for negative numbers' translated!
----- 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).
!
----- 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
!
----- 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]!
----- Method: Integer>>storeStringHex (in category 'printing-numerative') -----
storeStringHex
^self storeStringBase: 16!
----- 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!
----- 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]!
----- 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(n^2)."
^ ((n1 * 500000 * 1000) // t1) printString, ' bytecodes/sec; ',
((r * 1000) // t2) printString, ' sends/sec'!
----- Method: Integer>>truncated (in category 'truncation and round off') -----
truncated
"Refer to the comment in Number|truncated."!
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.!
LargePositiveInteger variableByteSubclass: #LargeNegativeInteger
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Kernel-Numbers'!
!LargeNegativeInteger commentStamp: '<historical>' prior: 0!
Just like LargePositiveInteger, but represents a negative number.!
----- Method: LargeNegativeInteger class>>initializedInstance (in category 'as yet unclassified') -----
initializedInstance
^ -9876543210987654321 copy!
----- Method: LargeNegativeInteger>>abs (in category 'arithmetic') -----
abs
^ self negated!
----- 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!
----- Method: LargeNegativeInteger>>negated (in category 'arithmetic') -----
negated
^ self copyto: (LargePositiveInteger new: self digitLength)!
----- Method: LargeNegativeInteger>>negative (in category 'testing') -----
negative
"Answer whether the receiver is mathematically negative."
^ true!
----- 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"
sLen _ 4 "SmallInteger minVal digitLength".
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]!
----- Method: LargeNegativeInteger>>positive (in category 'testing') -----
positive
"Answer whether the receiver is positive or equal to 0. (ST-80 protocol).
See also strictlyPositive"
^ false!
----- Method: LargeNegativeInteger>>sign (in category 'testing') -----
sign
"Optimization. Answer -1 since receiver is less than 0."
^ -1
!
----- Method: LargeNegativeInteger>>strictlyPositive (in category 'testing') -----
strictlyPositive
"Answer whether the receiver is mathematically positive."
^ false!
----- Method: LargePositiveInteger class>>initializedInstance (in category 'testing') -----
initializedInstance
^ 12345678901234567 copy!
----- 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!
----- 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!
----- 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!
----- 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!
----- 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!
----- 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!
----- 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!
----- Method: LargePositiveInteger>>= (in category 'comparing') -----
= anInteger
"Primitive. Compare the receiver with the argument and answer true if
the receiver is equal to the argument. Otherwise answer false. Fail if the
receiver or argument is negative or greater than 32 bits.
Optional. See Object documentation whatIsAPrimitive."
<primitive: 7>
^ super = anInteger!
----- 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!
----- 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!
----- Method: LargePositiveInteger>>\\ (in category 'arithmetic') -----
\\ anInteger
"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>
^super \\ anInteger!
----- Method: LargePositiveInteger>>\\\ (in category 'arithmetic') -----
\\\ anInteger
"a faster modulo method for use in DSA. Be careful if you try to use this elsewhere"
^(self digitDiv: anInteger neg: false) second!
----- Method: LargePositiveInteger>>abs (in category 'arithmetic') -----
abs!
----- 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!
----- Method: LargePositiveInteger>>bitAnd: (in category 'bit manipulation') -----
bitAnd: anInteger
"Primitive. Answer an Integer whose bits are the logical AND of the
receiver's bits and those of the argument. Fail if the receiver or argument
is greater than 32 bits. See Object documentation whatIsAPrimitive."
<primitive: 14>
^ super bitAnd: anInteger!
----- Method: LargePositiveInteger>>bitOr: (in category 'bit manipulation') -----
bitOr: anInteger
"Primitive. Answer an Integer whose bits are the logical OR of the
receiver's bits and those of the argument. Fail if the receiver or argument
is greater than 32 bits. See Object documentation whatIsAPrimitive."
<primitive: 15>
^ super bitOr: anInteger!
----- Method: LargePositiveInteger>>bitShift: (in category 'bit manipulation') -----
bitShift: anInteger
"Primitive. 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. The sign bit is extended in right shifts.
Fail if the receiver or result is greater than 32 bits.
See Object documentation whatIsAPrimitive."
<primitive: 17>
^super bitShift: anInteger!
----- Method: LargePositiveInteger>>bitXor: (in category 'bit manipulation') -----
bitXor: anInteger
"Primitive. Answer an Integer whose bits are the logical XOR of the
receiver's bits and those of the argument. Fail if the receiver or argument
is greater than 32 bits. See Object documentation whatIsAPrimitive."
<primitive: 16>
^ super bitXor: anInteger!
----- 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]!
----- 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!
----- 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!
----- Method: LargePositiveInteger>>hash (in category 'comparing') -----
hash
^ByteArray
hashBytes: self
startingWith: self species hash!
----- Method: LargePositiveInteger>>hashMultiply (in category 'bit manipulation') -----
hashMultiply
"Truncate to 28 bits and try again"
^(self bitAnd: 16rFFFFFFF) hashMultiply!
----- 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!
----- 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 highBitOfPositiveReceiver + (8 * (realLength - 1))!
----- Method: LargePositiveInteger>>negated (in category 'arithmetic') -----
negated
^ (self copyto: (LargeNegativeInteger new: self digitLength))
normalize "Need to normalize to catch SmallInteger minVal"!
----- Method: LargePositiveInteger>>negative (in category 'testing') -----
negative
"Answer whether the receiver is mathematically negative."
^ false!
----- 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"
sLen _ SmallInteger maxVal digitLength.
(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]!
----- Method: LargePositiveInteger>>positive (in category 'testing') -----
positive
"Answer whether the receiver is positive or equal to 0. (ST-80 protocol).
See also strictlyPositive"
^ true!
----- 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!
----- 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!
----- Method: LargePositiveInteger>>sign (in category 'testing') -----
sign
"Optimization. Answer 1 since receiver is greater than 0."
^ 1
!
----- Method: LargePositiveInteger>>strictlyPositive (in category 'testing') -----
strictlyPositive
"Answer whether the receiver is mathematically positive."
^ true!
----- 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!
----- Method: LargePositiveInteger>>~= (in category 'comparing') -----
~= anInteger
"Primitive. Compare the receiver with the argument and answer true if
the receiver is equal to the argument. Otherwise answer false. Fail if the
receiver or argument is negative or greater than 32 bits.
Optional. See Object documentation whatIsAPrimitive."
<primitive: 8>
^ super ~= anInteger!
Integer subclass: #SmallInteger
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Kernel-Numbers'!
!SmallInteger commentStamp: '<historical>' prior: 0!
My instances are 31-bit numbers, stored in twos complement form. The allowable range is approximately +- 1 billion (see SmallInteger minVal, maxVal).!
----- Method: SmallInteger class>>basicNew (in category 'instance creation') -----
basicNew
self error: 'SmallIntegers can only be created by performing arithmetic'!
----- Method: SmallInteger class>>ccg:generateCoerceToOopFrom:on: (in category 'plugin generation') -----
ccg: cg generateCoerceToOopFrom: aNode on: aStream
cg generateCoerceToSmallIntegerObjectFrom: aNode on: aStream!
----- Method: SmallInteger class>>ccg:generateCoerceToValueFrom:on: (in category 'plugin generation') -----
ccg: cg generateCoerceToValueFrom: aNode on: aStream
cg generateCoerceToSmallIntegerValueFrom: aNode on: aStream!
----- Method: SmallInteger class>>ccg:prolog:expr:index: (in category 'plugin generation') -----
ccg: cg prolog: aBlock expr: aString index: anInteger
^cg ccgLoad: aBlock expr: aString asIntegerValueFrom: anInteger!
----- Method: SmallInteger class>>ccgCanConvertFrom: (in category 'plugin generation') -----
ccgCanConvertFrom: anObject
^anObject class == self!
----- Method: SmallInteger class>>guideToDivision (in category 'documentation') -----
guideToDivision
"Handy guide to the kinds of Integer division:
/ exact division, returns a fraction if result is not a whole integer.
// returns an Integer, rounded towards negative infinity.
\\ is modulo rounded towards negative infinity.
quo: truncated division, rounded towards zero."!
----- Method: SmallInteger class>>maxVal (in category 'constants') -----
maxVal
"Answer the maximum value for a SmallInteger."
^ 16r3FFFFFFF!
----- Method: SmallInteger class>>minVal (in category 'constants') -----
minVal
"Answer the minimum value for a SmallInteger."
^ -16r40000000!
----- Method: SmallInteger class>>new (in category 'instance creation') -----
new
self basicNew "generates an error"!
----- Method: SmallInteger>>* (in category 'arithmetic') -----
* aNumber
"Primitive. Multiply the receiver by the argument and answer with the
result if it is a SmallInteger. Fail if the argument or the result is not a
SmallInteger. Essential. No Lookup. See Object documentation whatIsAPrimitive."
<primitive: 9>
^ super * aNumber!
----- Method: SmallInteger>>+ (in category 'arithmetic') -----
+ aNumber
"Primitive. Add the receiver to the argument and answer with the result
if it is a SmallInteger. Fail if the argument or the result is not a
SmallInteger Essential No Lookup. See Object documentation whatIsAPrimitive."
<primitive: 1>
^ super + aNumber!
----- Method: SmallInteger>>- (in category 'arithmetic') -----
- aNumber
"Primitive. Subtract the argument from the receiver and answer with the
result if it is a SmallInteger. Fail if the argument or the result is not a
SmallInteger. Essential. No Lookup. See Object documentation
whatIsAPrimitive."
<primitive: 2>
^super - aNumber!
----- Method: SmallInteger>>/ (in category 'arithmetic') -----
/ aNumber
"Primitive. This primitive (for /) divides the receiver by the argument
and returns the result if the division is exact. Fail if the result is not a
whole integer. Fail if the argument is 0 or is not a SmallInteger. Optional.
No Lookup. See Object documentation whatIsAPrimitive."
<primitive: 10>
aNumber isZero ifTrue: [^(ZeroDivide dividend: self) signal].
^(aNumber isMemberOf: SmallInteger)
ifTrue: [(Fraction numerator: self denominator: aNumber) reduced]
ifFalse: [super / aNumber]!
----- Method: SmallInteger>>// (in category 'arithmetic') -----
// aNumber
"Primitive. Divide the receiver by the argument and answer with the
result. Round the result down towards negative infinity to make it a
whole integer. Fail if the argument is 0 or is not a SmallInteger.
Essential. No Lookup. See Object documentation whatIsAPrimitive. "
<primitive: 12>
^ super // aNumber "Do with quo: if primitive fails"!
----- Method: SmallInteger>>< (in category 'comparing') -----
< aNumber
"Primitive. Compare the receiver with the argument and answer with
true if the receiver is less than the argument. Otherwise answer false.
Fail if the argument is not a SmallInteger. Essential. No Lookup. See
Object documentation whatIsAPrimitive."
<primitive: 3>
^super < aNumber!
----- Method: SmallInteger>><= (in category 'comparing') -----
<= aNumber
"Primitive. Compare the receiver with the argument and answer true if
the receiver is less than or equal to the argument. Otherwise answer
false. Fail if the argument is not a SmallInteger. Optional. No Lookup.
See Object documentation whatIsAPrimitive. "
<primitive: 5>
^super <= aNumber!
----- Method: SmallInteger>>= (in category 'comparing') -----
= aNumber
"Primitive. Compare the receiver with the argument and answer true if
the receiver is equal to the argument. Otherwise answer false. Fail if the
argument is not a SmallInteger. Essential. No Lookup. See Object
documentation whatIsAPrimitive. "
<primitive: 7>
^super = aNumber!
----- Method: SmallInteger>>> (in category 'comparing') -----
> aNumber
"Primitive. Compare the receiver with the argument and answer true if
the receiver is greater than the argument. Otherwise answer false. Fail if
the argument is not a SmallInteger. Essential. No Lookup. See Object
documentation whatIsAPrimitive."
<primitive: 4>
^super > aNumber!
----- Method: SmallInteger>>>= (in category 'comparing') -----
>= aNumber
"Primitive. Compare the receiver with the argument and answer true if
the receiver is greater than or equal to the argument. Otherwise answer
false. Fail if the argument is not a SmallInteger. Optional. No Lookup.
See Object documentation whatIsAPrimitive."
<primitive: 6>
^super >= aNumber!
----- Method: SmallInteger>>\\ (in category 'arithmetic') -----
\\ aNumber
"Primitive. Take the receiver modulo the argument. The result is the
remainder rounded towards negative infinity, of the receiver divided by
the argument Fail if the argument is 0 or is not a SmallInteger. Optional.
No Lookup. See Object documentation whatIsAPrimitive."
<primitive: 11>
^ super \\ aNumber "will use // to compute it if primitive fails"!
----- Method: SmallInteger>>as31BitSmallInt (in category 'converting') -----
as31BitSmallInt
"Polymorphic with LargePositiveInteger (see comment there).
Return self since all SmallIntegers are 31 bits"
^ self!
----- Method: SmallInteger>>asFloat (in category 'converting') -----
asFloat
"Primitive. Answer a Float that represents the value of the receiver.
Essential. See Object documentation whatIsAPrimitive."
<primitive: 40>
self primitiveFailed!
----- Method: SmallInteger>>asOop (in category 'system primitives') -----
asOop
"Answer an object pointer as an integer, return negative number for SmallInteger"
^ self!
----- Method: SmallInteger>>bitAnd: (in category 'bit manipulation') -----
bitAnd: arg
"Primitive. Answer an Integer whose bits are the logical OR of the
receiver's bits and those of the argument, arg.
Numbers are interpreted as having 2's-complement representation.
Essential. See Object documentation whatIsAPrimitive."
<primitive: 14>
self >= 0 ifTrue: [^ arg bitAnd: self].
^ (self bitInvert bitOr: arg bitInvert) bitInvert.!
----- Method: SmallInteger>>bitOr: (in category 'bit manipulation') -----
bitOr: arg
"Primitive. Answer an Integer whose bits are the logical OR of the
receiver's bits and those of the argument, arg.
Numbers are interpreted as having 2's-complement representation.
Essential. See Object documentation whatIsAPrimitive."
<primitive: 15>
self >= 0 ifTrue: [^ arg bitOr: self].
^ arg < 0
ifTrue: [(self bitInvert bitAnd: arg bitInvert) bitInvert]
ifFalse: [(self bitInvert bitClear: arg) bitInvert]!
----- Method: SmallInteger>>bitShift: (in category 'bit manipulation') -----
bitShift: arg
"Primitive. Answer an Integer whose value is the receiver's value shifted
left by the number of bits indicated by the argument. Negative arguments
shift right. The receiver is interpreted as having 2's-complement representation.
Essential. See Object documentation whatIsAPrimitive."
<primitive: 17>
self >= 0 ifTrue: [^ super bitShift: arg].
^ arg >= 0
ifTrue: [(self negated bitShift: arg) negated]
ifFalse: [(self bitInvert bitShift: arg) bitInvert].!
----- Method: SmallInteger>>bitXor: (in category 'bit manipulation') -----
bitXor: arg
"Primitive. Answer an Integer whose bits are the logical XOR of the
receiver's bits and those of the argument, arg.
Numbers are interpreted as having 2's-complement representation.
Essential. See Object documentation whatIsAPrimitive."
<primitive: 16>
self >= 0 ifTrue: [^ arg bitXor: self].
^ arg < 0
ifTrue: [self bitInvert bitXor: arg bitInvert]
ifFalse: [(self bitInvert bitXor: arg) bitInvert].!
----- Method: SmallInteger>>clone (in category 'copying') -----
clone
!
----- Method: SmallInteger>>deepCopy (in category 'copying') -----
deepCopy!
----- Method: SmallInteger>>destinationBuffer: (in category 'printing') -----
destinationBuffer:digitLength
^ LargePositiveInteger new: digitLength.!
----- Method: SmallInteger>>digitAt: (in category 'system primitives') -----
digitAt: n
"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."
n>4 ifTrue: [^ 0].
self < 0
ifTrue:
[self = SmallInteger minVal ifTrue:
["Can't negate minVal -- treat specially"
^ #(0 0 0 64) at: n].
^ ((0-self) bitShift: (1-n)*8) bitAnd: 16rFF]
ifFalse: [^ (self bitShift: (1-n)*8) bitAnd: 16rFF]!
----- Method: SmallInteger>>digitAt:put: (in category 'system primitives') -----
digitAt: n put: value
"Fails. The digits of a small integer can not be modified."
self error: 'You can''t store in a SmallInteger'!
----- Method: SmallInteger>>digitLength (in category 'system primitives') -----
digitLength
"Answer the number of indexable fields in the receiver. This value is the
same as the largest legal subscript. Included so that a SmallInteger can
behave like a LargePositiveInteger or LargeNegativeInteger."
(self < 16r100 and: [self > -16r100]) ifTrue: [^ 1].
(self < 16r10000 and: [self > -16r10000]) ifTrue: [^ 2].
(self < 16r1000000 and: [self > -16r1000000]) ifTrue: [^ 3].
^ 4!
----- Method: SmallInteger>>even (in category 'testing') -----
even
^(self bitAnd: 1) = 0!
----- Method: SmallInteger>>fromString:radix: (in category 'private') -----
fromString: str radix: radix
| maxdigit c val |
maxdigit _
radix + (radix > 10
ifTrue: [55 - 1]
ifFalse: [48 - 1]).
val _ 0.
1 to: str size do:
[:i |
c _ str at: i.
(c < 48 ifFalse: [c > maxdigit])
ifTrue: [^false].
val _ val * radix + (c <= 57
ifTrue: [c - 48]
ifFalse:
[c < 65 ifTrue: [^false].
c - 55])].
^val!
----- Method: SmallInteger>>gcd: (in category 'arithmetic') -----
gcd: anInteger
"See SmallInteger (Integer) | gcd:"
| n m |
n _ self.
m _ anInteger.
[n = 0]
whileFalse:
[n _ m \\ (m _ n)].
^ m abs!
----- Method: SmallInteger>>hash (in category 'comparing') -----
hash
^self!
----- Method: SmallInteger>>hashMultiply (in category 'bit manipulation') -----
hashMultiply
| low |
low _ self bitAnd: 16383.
^(16r260D * low + ((16r260D * (self bitShift: -14) + (16r0065 * low) bitAnd: 16383) * 16384))
bitAnd: 16r0FFFFFFF!
----- Method: SmallInteger>>highBit (in category 'bit manipulation') -----
highBit
"Answer the index of the high order bit of the receiver, or zero if the
receiver is zero. Raise an error if the receiver is negative, since
negative integers are defined to have an infinite number of leading 1's
in 2's-complement arithmetic. Use >>highBitOfMagnitude if you want to
get the highest bit of the magnitude."
self < 0 ifTrue: [^ self error: 'highBit is not defined for negative integers'].
^ self highBitOfPositiveReceiver!
----- Method: SmallInteger>>highBitOfMagnitude (in category 'bit manipulation') -----
highBitOfMagnitude
"Answer the index of the high order bit of the receiver, or zero if the
receiver is zero. This method is used for negative SmallIntegers as well,
since Squeak's LargeIntegers are sign/magnitude."
^ self abs highBitOfPositiveReceiver!
----- Method: SmallInteger>>highBitOfPositiveReceiver (in category 'private') -----
highBitOfPositiveReceiver
| shifted bitNo |
"Answer the index of the high order bit of the receiver, or zero if the
receiver is zero. Receiver has to be positive!!"
shifted _ self.
bitNo _ 0.
[shifted < 16]
whileFalse:
[shifted _ shifted bitShift: -4.
bitNo _ bitNo + 4].
[shifted = 0]
whileFalse:
[shifted _ shifted bitShift: -1.
bitNo _ bitNo + 1].
^ bitNo!
----- Method: SmallInteger>>identityHash (in category 'comparing') -----
identityHash
^self!
----- Method: SmallInteger>>identityHashMappedBy: (in category 'comparing') -----
identityHashMappedBy: map
^ self!
----- Method: SmallInteger>>instVarAt: (in category 'system primitives') -----
instVarAt: i
"Small integer has to be specially handled."
i = 1 ifTrue: [^self].
self error: 'argument too big for small integer instVarAt:'!
----- Method: SmallInteger>>lowBit (in category 'bit manipulation') -----
lowBit
" Answer the index of the low order one bit.
2r00101000 lowBit (Answers: 4)
2r-00101000 lowBit (Answers: 4)
First we skip bits in groups of 4, then single bits.
While not optimal, this is a good tradeoff; long
integer #lowBit always invokes us with bytes."
| n result |
n := self.
n = 0 ifTrue: [ ^ 0 ].
result := 1.
[ (n bitAnd: 16rF) = 0 ]
whileTrue: [
result := result + 4.
n := n bitShift: -4 ].
[ (n bitAnd: 1) = 0 ]
whileTrue: [
result := result + 1.
n := n bitShift: -1 ].
^ result!
----- Method: SmallInteger>>nextInstance (in category 'system primitives') -----
nextInstance
"SmallIntegers can't be enumerated this way. There are a finite number of them from from (SmallInteger minVal) to (SmallInteger maxVal), but you'll have to enumerate them yourself with:
(SmallInteger minVal) to: (SmallInteger maxVal) do: [:integer | <your code here>].
"
self shouldNotImplement !
----- Method: SmallInteger>>nextObject (in category 'system primitives') -----
nextObject
"SmallIntegers are immediate objects, and, as such, do not have successors in object memory."
self shouldNotImplement !
----- Method: SmallInteger>>odd (in category 'testing') -----
odd
^(self bitAnd: 1) = 1!
----- Method: SmallInteger>>quo: (in category 'arithmetic') -----
quo: aNumber
"Primitive. Divide the receiver by the argument and answer with the
result. Round the result down towards zero to make it a whole integer.
Fail if the argument is 0 or is not a SmallInteger. Optional. See Object
documentation whatIsAPrimitive."
<primitive: 13>
aNumber = 0 ifTrue: [^ (ZeroDivide dividend: self) signal].
(aNumber isMemberOf: SmallInteger)
ifFalse: [^ super quo: aNumber].
(aNumber == -1 and: [self == self class minVal])
ifTrue: ["result is aLargeInteger" ^ self negated].
self primitiveFailed!
----- Method: SmallInteger>>shallowCopy (in category 'copying') -----
shallowCopy!
----- Method: SmallInteger>>threeDigitName (in category 'printing') -----
threeDigitName
| units answer |
self = 0 ifTrue: [^''].
units _ #('one' 'two' 'three' 'four' 'five' 'six' 'seven' 'eight' 'nine' 'ten'
'eleven' 'twelve' 'thirteen' 'fourteen' 'fifteen' 'sixteen' 'seventeen'
'eighteen' 'nineteen').
self > 99 ifTrue: [
answer _ (units at: self // 100),' hundred'.
(self \\ 100) = 0 ifFalse: [
answer _ answer,' ',(self \\ 100) threeDigitName
].
^answer
].
self < 20 ifTrue: [
^units at: self
].
answer _ #('twenty' 'thirty' 'forty' 'fifty' 'sixty' 'seventy' 'eighty' 'ninety')
at: self // 10 - 1.
(self \\ 10) = 0 ifFalse: [
answer _ answer,'-',(units at: self \\ 10)
].
^answer!
----- Method: SmallInteger>>veryDeepCopyWith: (in category 'copying') -----
veryDeepCopyWith: deepCopier
"Return self. I can't be copied. Do not record me."!
----- Method: SmallInteger>>~= (in category 'comparing') -----
~= aNumber
"Primitive. Compare the receiver with the argument and answer true if
the receiver is not equal to the argument. Otherwise answer false. Fail if
the argument is not a SmallInteger. Essential. No Lookup. See Object
documentation whatIsAPrimitive."
<primitive: 8>
^super ~= aNumber!
----- Method: Number class>>canParseAsScaledDecimal:fractionPart:digits:base:sign:from: (in category 'private') -----
canParseAsScaledDecimal: integerPart fractionPart: fractionPart digits: fractionDigits base: base sign: sign from: aStream
"Answer true if parsing a ScaleDecimal will succeed. Read from a copy
of aStream to test the parsing."
^ aStream peek == $s
and: [(self
readScaledDecimal: integerPart
fractionPart: fractionPart
digits: fractionDigits
base: base
sign: sign
from: aStream copy) notNil]!
----- Method: Number class>>canParseExponentFor:base:from: (in category 'private') -----
canParseExponentFor: baseValue base: base from: aStream
"Answer true if parsing the expoenent for a number will succeed. Read from
a copy of aStream to test the parsing."
^ ('edq' includes: aStream peek)
and: [(self
readExponent: baseValue
base: base
from: aStream copy) notNil]!
----- Method: Number class>>canParseExponentOrScaledDecimal:integerPart:fractionPart:digits:base:sign:from: (in category 'private') -----
canParseExponentOrScaledDecimal: value integerPart: integerPart fractionPart: fractionPart digits: fractionDigits base: base sign: sign from: aStream
"Answer true if aStream contains parseable characters. The state of aStream is not changed."
^ (self
canParseExponentFor: value
base: base
from: aStream)
or: [self
canParseAsScaledDecimal: integerPart
fractionPart: fractionPart
digits: fractionDigits
base: base
sign: sign
from: aStream]!
----- Method: Number class>>readEToyNumberFrom: (in category 'instance creation') -----
readEToyNumberFrom: aString
"Answer a number as described in the string"
| value aStream sign |
aStream := ReadStream on: (aString copyWithout: $ ).
(aStream nextMatchAll: 'NaN') ifTrue: [^ Float nan].
sign _ (aStream peekFor: $-) ifTrue: [-1] ifFalse: [1].
(aStream peekFor: $.) ifTrue: "Don't gag on leading decimal point without whole-number part"
[sign = 1
ifTrue: "leading decimal point"
[^ self readEToyNumberFrom: '0', aString]
ifFalse: "minus-sign followed by a decimal point"
[^ self readEToyNumberFrom: '-0', aString allButFirst]].
(aStream nextMatchAll: 'Infinity') ifTrue: [^ Float infinity * sign].
value _ [Integer readFrom: aStream base: 10] ifError:
[self inform: aString, ' is not a number;
please correct and try again' translated.
^ nil].
^ self readRemainderOf: value from: aStream base: 10 withSign: sign!
----- Method: Number class>>readExponent:base:from: (in category 'private') -----
readExponent: baseValue base: base from: aStream
"Complete creation of a number, reading exponent from aStream. Answer the
number, or nil if parsing fails.
<number>(e|d|q)<exponent>>"
| sign exp value |
aStream next. "skip e|d|q"
sign _ ((aStream peek) == $-)
ifTrue: [aStream next. -1]
ifFalse: [1].
(aStream peek digitValue between: 0 and: 9) ifFalse: [^ nil]. "Avoid throwing an error"
exp _ (Integer readFrom: aStream base: 10) * sign.
value := baseValue * (base raisedTo: exp).
^ value
!
----- Method: Number class>>readFrom: (in category 'instance creation') -----
readFrom: stringOrStream
"Answer a number as described on aStream. The number may
include a leading radix specification, as in 16rFADE"
| value base aStream sign |
aStream _ (stringOrStream isString)
ifTrue: [ReadStream on: stringOrStream]
ifFalse: [stringOrStream].
(aStream nextMatchAll: 'NaN') ifTrue: [^ Float nan].
sign _ (aStream peekFor: $-) ifTrue: [-1] ifFalse: [1].
(aStream nextMatchAll: 'Infinity') ifTrue: [^ Float infinity * sign].
base _ 10.
value _ Integer readFrom: aStream base: base.
(aStream peekFor: $r)
ifTrue:
["<base>r<integer>"
(base _ value) < 2 ifTrue: [^self error: 'Invalid radix'].
(aStream peekFor: $-) ifTrue: [sign _ sign negated].
value _ Integer readFrom: aStream base: base].
^ self readRemainderOf: value from: aStream base: base withSign: sign.!
----- 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."
| aStream sign |
aStream _ (stringOrStream isString)
ifTrue: [ReadStream on: stringOrStream]
ifFalse: [stringOrStream].
(aStream nextMatchAll: 'NaN') ifTrue: [^ Float nan].
sign _ (aStream peekFor: $-) ifTrue: [-1] ifFalse: [1].
(aStream nextMatchAll: 'Infinity') ifTrue: [^ Float infinity * sign].
^ self readRemainderOf: (Integer readFrom: aStream base: base)
from: aStream base: base withSign: sign!
----- Method: Number class>>readRemainderOf:from:base:withSign: (in category 'private') -----
readRemainderOf: integerPart from: aStream base: base withSign: sign
"Read optional fractional part and exponent or decimal scale, and return the final result"
"Changed 200/01/19 For ANSI Numeric Literals support."
"Number readFrom: '3r-22.2'"
| value fraction fractionDigits fracpos fractionPart scaledDecimal |
#Numeric.
value := integerPart.
fractionDigits := 0.
(aStream peekFor: $.)
ifTrue: ["<integer>.<fraction>"
(aStream atEnd not
and: [aStream peek digitValue between: 0 and: base - 1])
ifTrue: [fracpos := aStream position.
fractionPart := Integer readFrom: aStream base: base.
fraction := fractionPart asFloat
/ (base raisedTo: aStream position - fracpos).
fractionDigits := aStream position - fracpos.
value := value asFloat + fraction]
ifFalse: [(self
canParseExponentOrScaledDecimal: value
integerPart: integerPart
fractionPart: fractionPart
digits: fractionDigits
base: base
sign: sign
from: aStream)
ifFalse: ["oops - just <integer>."
aStream skip: -1.
"un-gobble the period"
^ value * sign]]].
(self canParseAsScaledDecimal: integerPart
fractionPart: fractionPart
digits: fractionDigits
base: base
sign: sign
from: aStream)
ifTrue: ["<number>s[<scale>]"
(scaledDecimal := self
readScaledDecimal: integerPart
fractionPart: fractionPart
digits: fractionDigits
base: base
sign: sign
from: aStream)
ifNotNil: [^ scaledDecimal]].
(self canParseExponentFor: value
base: base
from: aStream)
ifTrue: ["<number>(e|d|q)<exponent>>"
value := self
readExponent: value
base: base
from: aStream].
(value isFloat
and: [value = 0.0
and: [sign = -1]])
ifTrue: [^ Float negativeZero]
ifFalse: [^ value * sign]!
----- Method: Number class>>readScaledDecimal:fractionPart:digits:base:sign:from: (in category 'private') -----
readScaledDecimal: integerPart fractionPart: fractionPart digits: fractionDigits base: base sign: sign from: aStream
"Complete creation of a ScaledDecimal, reading scale from aStream. Answer
a ScaledDecimal, or nil if parsing fails.
<number>s[<scale>]"
| scale decimalMultiplier decimalFraction |
aStream atEnd ifTrue: [^ nil].
(aStream next == $s) ifFalse: [^ nil].
"<number>s<scale>"
(aStream peek digitValue between: 0 and: 10)
ifTrue: [scale := Integer readFrom: aStream]
ifFalse: [^ nil].
scale isNil
ifTrue: ["<number>s"
fractionDigits = 0
ifTrue: ["<integer>s"
scale := 0]
ifFalse: ["<integer>.<fraction>s"
scale := fractionDigits]].
fractionPart isNil
ifTrue: [^ ScaledDecimal newFromNumber: integerPart * sign scale: scale]
ifFalse: [decimalMultiplier := base raisedTo: fractionDigits.
decimalFraction := integerPart * decimalMultiplier + fractionPart * sign / decimalMultiplier.
^ ScaledDecimal newFromNumber: decimalFraction scale: scale]!
----- Method: Number>>* (in category 'arithmetic') -----
* aNumber
"Answer the result of multiplying the receiver by aNumber."
self subclassResponsibility!
----- Method: Number>>+ (in category 'arithmetic') -----
+ aNumber
"Answer the sum of the receiver and aNumber."
self subclassResponsibility!
----- Method: Number>>- (in category 'arithmetic') -----
- aNumber
"Answer the difference between the receiver and aNumber."
self subclassResponsibility!
----- Method: Number>>/ (in category 'arithmetic') -----
/ aNumber
"Answer the result of dividing the receiver by aNumber."
self subclassResponsibility!
----- 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!
----- Method: Number>>@ (in category 'converting') -----
@ y
"Primitive. Answer a Point whose x value is the receiver and whose y
value is the argument. Optional. No Lookup. See Object documentation
whatIsAPrimitive."
<primitive: 18>
^Point x: self y: y!
----- 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)!
----- 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]!
----- 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]!
----- 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!
----- 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!
----- 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!
----- 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!
----- 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!
----- 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!
----- 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!
----- 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!
----- 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.!
----- 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]!
----- Method: Number>>asB3DVector3 (in category 'converting') -----
asB3DVector3
^self at self@self!
----- Method: Number>>asDuration (in category 'converting') -----
asDuration
^ Duration nanoSeconds: self asInteger
!
----- Method: Number>>asInteger (in category 'converting') -----
asInteger
"Answer an Integer nearest the receiver toward zero."
^self truncated!
----- Method: Number>>asNumber (in category 'converting') -----
asNumber
^ self!
----- 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!
----- Method: Number>>asScaledDecimal (in category 'converting') -----
asScaledDecimal
"Answer a scaled decimal number approximating the receiver."
#Numeric.
^ self asScaledDecimal: 8
!
----- 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]"!
----- Method: Number>>asSmallPositiveDegrees (in category 'converting') -----
asSmallPositiveDegrees
"Return the receiver normalized to lie within the range (0, 360)"
| result |
result _ self.
[result < 0] whileTrue: [result _ result + 360].
^ result \\ 360
"#(-500 -300 -150 -5 0 5 150 300 500 1200) collect: [:n | n asSmallPositiveDegrees]"!
----- Method: Number>>byteEncode: (in category 'filter streaming') -----
byteEncode:aStream
^aStream writeNumber:self.
!
----- Method: Number>>ceiling (in category 'truncation and round off') -----
ceiling
"Answer the integer nearest the receiver toward positive infinity."
self <= 0.0
ifTrue: [^self truncated]
ifFalse: [^self negated floor negated]!
----- Method: Number>>closeTo: (in category 'comparing') -----
closeTo: num
"are these two numbers close?"
| ans |
num isFloat ifTrue: [^ num closeTo: self asFloat].
[ans _ self = num] ifError: [:aString :aReceiver | ^ false].
^ ans!
----- Method: Number>>cos (in category 'mathematical functions') -----
cos
"The receiver represents an angle measured in radians. Answer its cosine."
^self asFloat cos!
----- Method: Number>>cubeRoot (in category 'mathematical functions') -----
cubeRoot
"Answer the cube root of the receiver."
^ self asFloat cubeRoot!
----- Method: Number>>cubed (in category 'mathematical functions') -----
cubed
"Answer the cube of the receiver."
^ self * self * self!
----- Method: Number>>day (in category 'converting') -----
day
^ self sign days!
----- Method: Number>>days (in category 'converting') -----
days
^ Duration days: self!
----- 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!
----- Method: Number>>degreeArcTan (in category 'mathematical functions') -----
degreeArcTan
"The receiver is the tangent of an angle. Answer the angle measured in degrees."
^ self asFloat degreeArcTan!
----- Method: Number>>degreeCos (in category 'mathematical functions') -----
degreeCos
"Answer the cosine of the receiver taken as an angle in degrees."
^ (90 + self) degreeSin!
----- Method: Number>>degreeSin (in category 'mathematical functions') -----
degreeSin
"Answer the sine of the receiver taken as an angle in degrees."
^ self asFloat degreesToRadians sin!
----- Method: Number>>degreeTan (in category 'mathematical functions') -----
degreeTan
"Answer the tangent of the receiver taken as an angle in degrees."
^ self asFloat degreeTan!
----- Method: Number>>degreesToRadians (in category 'converting') -----
degreesToRadians
"The receiver is assumed to represent degrees. Answer the conversion to
radians."
^self asFloat degreesToRadians!
----- 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]
"!
----- Method: Number>>even (in category 'testing') -----
even
"Answer whether the receiver is an even number."
^self \\ 2 = 0!
----- Method: Number>>exp (in category 'mathematical functions') -----
exp
"Answer the exponential of the receiver as a floating point number."
^self asFloat exp!
----- Method: Number>>factorial (in category 'mathematical functions') -----
factorial
"Answer the factorial of the receiver."
^ self truncated factorial!
----- 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]!
----- Method: Number>>floorLog: (in category 'mathematical functions') -----
floorLog: radix
"Answer the floor of the log base radix of the receiver."
^ self asFloat floorLog: radix
!
----- Method: Number>>fractionPart (in category 'truncation and round off') -----
fractionPart
^ self asFloat fractionPart.
!
----- Method: Number>>grouped (in category 'arithmetic') -----
grouped
"Sent as a pseudo-function for parenthesizing in tile scripts."
^ self!
----- Method: Number>>hour (in category 'converting') -----
hour
^ self sign hours
!
----- Method: Number>>hours (in category 'converting') -----
hours
^ Duration hours: self!
----- Method: Number>>i (in category 'converting') -----
i
^ Complex real: 0 imaginary: self!
----- Method: Number>>integerPart (in category 'truncation and round off') -----
integerPart
^ self asFloat integerPart!
----- Method: Number>>interpolateTo:at: (in category 'mathematical functions') -----
interpolateTo: aNumber at: param
^self + (aNumber - self * param)!
----- Method: Number>>isDivisibleBy: (in category 'testing') -----
isDivisibleBy: aNumber
aNumber = 0 ifTrue: [^ false].
aNumber isInteger ifFalse: [^ false].
^ (self \\ aNumber) = 0!
----- Method: Number>>isInf (in category 'testing') -----
isInf
^ false!
----- Method: Number>>isInfinite (in category 'testing') -----
isInfinite
^ false!
----- Method: Number>>isNaN (in category 'testing') -----
isNaN
^ false!
----- Method: Number>>isNumber (in category 'testing') -----
isNumber
^ true!
----- 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']"!
----- Method: Number>>isZero (in category 'testing') -----
isZero
^self = 0!
----- Method: Number>>ln (in category 'mathematical functions') -----
ln
"Answer the natural log of the receiver."
^self asFloat ln!
----- Method: Number>>log (in category 'mathematical functions') -----
log
"Answer the base-10 log of the receiver."
^self asFloat log!
----- Method: Number>>log: (in category 'mathematical functions') -----
log: aNumber
"Answer the log base aNumber of the receiver."
^self ln / aNumber ln!
----- Method: Number>>milliSecond (in category 'converting') -----
milliSecond
^ self sign milliSeconds
!
----- Method: Number>>milliSeconds (in category 'converting') -----
milliSeconds
^ Duration milliSeconds: self
!
----- Method: Number>>minute (in category 'converting') -----
minute
^ self sign minutes
!
----- Method: Number>>minutes (in category 'converting') -----
minutes
^ Duration minutes: self!
----- Method: Number>>nanoSecond (in category 'converting') -----
nanoSecond
^ self sign nanoSeconds
!
----- Method: Number>>nanoSeconds (in category 'converting') -----
nanoSeconds
^ Duration nanoSeconds: self.!
----- Method: Number>>negated (in category 'arithmetic') -----
negated
"Answer a Number that is the negation of the receiver."
^0 - self!
----- Method: Number>>negative (in category 'testing') -----
negative
"Answer whether the receiver is mathematically negative."
^ self < 0!
----- Method: Number>>odd (in category 'testing') -----
odd
"Answer whether the receiver is an odd number."
^self even == false!
----- 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!
----- Method: Number>>printOn: (in category 'printing') -----
printOn: aStream
self printOn: aStream base: 10!
----- Method: Number>>printOn:base: (in category 'printing') -----
printOn: aStream base: base
^self subclassResponsibility!
----- 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. If the nature of the receiver is such that e-notation should be used, that is done."
| precision rounded frac sign integerString fractionString result aString aFloat decPt between myAbs |
self isNaN ifTrue: [^ 'NaN'].
aString := (aFloat := self asFloat) printString.
aFloat isInfinite ifTrue: [^ aFloat printString].
myAbs := aFloat abs.
(aString indexOf: $e ifAbsent: [nil]) ifNotNilDo:
[:ePosition | ((myAbs < 1.0e-15) or: [myAbs > 1.0e15]) ifTrue:
[decPt := aString indexOf: $. ifAbsent: [^ aString].
between := aString copyFrom: (decPt + 1) to: (ePosition - 1).
^ String streamContents: [:aStream |
aStream nextPutAll: (aString copyFrom: 1 to: decPt).
aStream nextPutAll: between.
aStream nextPutAll: (aString copyFrom: ePosition to: aString size)]]].
"The remainder of this method is courtesy of Frank Sergeant, Dec/06"
placesDesired <= 0 ifTrue: [^ self rounded printString].
precision _ Utilities floatPrecisionForDecimalPlaces: placesDesired.
rounded _ self roundTo: precision.
sign := rounded negative ifTrue: ['-'] ifFalse: [''].
integerString := rounded abs integerPart asInteger printString.
frac := ((rounded abs fractionPart roundTo: precision) * (10 raisedToInteger: placesDesired)) asInteger.
fractionString := frac printString padded: #left to: placesDesired with: $0.
result := sign , integerString , '.' , fractionString.
^ result
"
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: 2
-0.98 printShowingDecimalPlaces: 2
2.567 printShowingDecimalPlaces: 2
-2.567 printShowingDecimalPlaces: 2
0 printShowingDecimalPlaces: 2
Float infinity printShowingDecimalPlaces: 5
2345.67890123 printShowingDecimalPlaces: 5
23456789.0012345 printShowingDecimalPlaces: 3
"!
----- Method: Number>>printString (in category 'printing') -----
printString
^self printStringBase: 10!
----- Method: Number>>printStringBase: (in category 'printing') -----
printStringBase: base
^ String streamContents:
[:strm | self printOn: strm base: base]!
----- 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!
----- Method: Number>>radiansToDegrees (in category 'converting') -----
radiansToDegrees
"The receiver is assumed to represent radians. Answer the conversion to
degrees."
^self asFloat radiansToDegrees!
----- 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 = 0 ifTrue: [^1]. "Special case of exponent=0"
aNumber = 1 ifTrue: [^self]. "Special case of exponent=1"
^(aNumber * self ln) exp "Otherwise raise it to the power using logarithms"!
----- Method: Number>>raisedToInteger: (in category 'mathematical functions') -----
raisedToInteger: anInteger
"Answer the receiver raised to the power anInteger where the argument
must be a kind of Integer. This is a special case of raisedTo:."
(anInteger isInteger)
ifFalse: [^self error: 'raisedToInteger: only works for integral arguments'].
anInteger = 0 ifTrue: [^1].
anInteger = 1 ifTrue: [^self].
anInteger > 1
ifTrue: [^(self * self raisedToInteger: anInteger // 2)
* (self raisedToInteger: anInteger \\ 2)].
^(self raisedToInteger: anInteger negated) reciprocal!
----- Method: Number>>random (in category 'truncation and round off') -----
random
"Answer a random integer between 1 and the receiver."
^ self asInteger atRandom!
----- Method: Number>>reciprocal (in category 'arithmetic') -----
reciprocal
"Answer 1 divided by the receiver. Create an error notification if the
receiver is 0."
self = 0
ifTrue: [^self error: 'zero has no reciprocal']
ifFalse: [^1 / self]!
----- Method: Number>>reduce (in category 'truncation and round off') -----
reduce
"If self is close to an integer, return that integer"
^ self!
----- 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)!
----- 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!
----- Method: Number>>roundUpTo: (in category 'truncation and round off') -----
roundUpTo: aNumber
"Answer the next multiple of aNumber toward infinity that is nearest the
receiver."
^(self/aNumber) ceiling * aNumber!
----- Method: Number>>rounded (in category 'truncation and round off') -----
rounded
"Answer the integer nearest the receiver."
^(self + (self sign / 2)) truncated!
----- Method: Number>>safeFactorial (in category 'mathematical functions') -----
safeFactorial
"Answer the factorial of the receiver."
^ self truncated safeFactorial!
----- Method: Number>>safeLn (in category 'mathematical functions') -----
safeLn
"Answer the natural logarithm of the receiver, safely"
^ self asFloat safeLn!
----- Method: Number>>safeLog (in category 'mathematical functions') -----
safeLog
"Answer the base-10 log of the receiver, safely"
^ self asFloat safeLog!
----- Method: Number>>safeSquareRoot (in category 'mathematical functions') -----
safeSquareRoot
"Answer the square root of the receiver. If the receiver is negative, answer zero and swallow the error."
^ self asFloat safeSquareRoot!
----- Method: Number>>second (in category 'converting') -----
second
^ self sign seconds
!
----- Method: Number>>seconds (in category 'converting') -----
seconds
^ Duration seconds: self!
----- Method: Number>>sign (in category 'testing') -----
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!
----- Method: Number>>sign: (in category 'converting') -----
sign: aNumber
"Return a Number with the same sign as aNumber"
^ aNumber positive ifTrue: [self abs] ifFalse: [self abs negated].!
----- Method: Number>>sin (in category 'mathematical functions') -----
sin
"The receiver represents an angle measured in radians. Answer its sine."
^self asFloat sin!
----- Method: Number>>sqrt (in category 'mathematical functions') -----
sqrt
"Answer the square root of the receiver."
^self asFloat sqrt!
----- Method: Number>>squared (in category 'mathematical functions') -----
squared
"Answer the receiver multipled by itself."
^self * self!
----- Method: Number>>storeOn: (in category 'printing') -----
storeOn: aStream
self printOn: aStream!
----- Method: Number>>storeOn:base: (in category 'printing') -----
storeOn: aStream base: base
self printOn: aStream base: base!
----- Method: Number>>storeStringBase: (in category 'printing') -----
storeStringBase: base
^ String streamContents: [:strm | self storeOn: strm base: base]!
----- Method: Number>>strictlyPositive (in category 'testing') -----
strictlyPositive
"Answer whether the receiver is mathematically positive."
^ self > 0!
----- Method: Number>>stringForReadout (in category 'printing') -----
stringForReadout
^ self rounded printString!
----- Method: Number>>tan (in category 'mathematical functions') -----
tan
"The receiver represents an angle measured in radians. Answer its
tangent."
^self asFloat tan!
----- Method: Number>>timesRepeat: (in category 'enumerating') -----
timesRepeat: aBlock
"Evaluate the argument, aBlock, the number of times represented by the
receiver."
^ self asInteger timesRepeat: aBlock!
----- 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!
----- 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!
----- 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]]!
----- 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]!
----- Method: Number>>truncateTo: (in category 'truncation and round off') -----
truncateTo: aNumber
"Answer the next multiple of aNumber toward zero that is nearest the
receiver."
^(self quo: aNumber)
* aNumber!
----- Method: Number>>truncated (in category 'truncation and round off') -----
truncated
"Answer an integer nearest the receiver toward zero."
^self quo: 1!
----- Method: Number>>week (in category 'converting') -----
week
^ self sign weeks
!
----- Method: Number>>weeks (in category 'converting') -----
weeks
^ Duration weeks: self!
Magnitude subclass: #Timespan
instanceVariableNames: 'start duration'
classVariableNames: ''
poolDictionaries: ''
category: 'Kernel-Chronology'!
!Timespan commentStamp: 'brp 5/13/2003 08:07' prior: 0!
I represent a duration starting on a specific DateAndTime.
!
Timespan subclass: #Schedule
instanceVariableNames: 'schedule'
classVariableNames: ''
poolDictionaries: ''
category: 'Kernel-Chronology'!
!Schedule commentStamp: 'brp 5/13/2003 09:48' prior: 0!
I represent a powerful class for implementing recurring schedules.!
----- Method: Schedule>>between:and:do: (in category 'enumerating') -----
between: aStart and: anEnd do: aBlock
| element end i |
end _ self end min: anEnd.
element _ self start.
i _ 1.
[ element < aStart ] whileTrue:
[ element _ element + (schedule at: i).
i _ i + 1. (i > schedule size) ifTrue: [i _ 1]].
i _ 1.
[ element <= end ] whileTrue:
[ aBlock value: element.
element _ element + (schedule at: i).
i _ i + 1.
(i > schedule size) ifTrue: [i _ 1]]
.
!
----- Method: Schedule>>dateAndTimes (in category 'enumerating') -----
dateAndTimes
| dateAndTimes |
dateAndTimes _ OrderedCollection new.
self scheduleDo: [ :e | dateAndTimes add: e ].
^ dateAndTimes asArray.!
----- Method: Schedule>>includes: (in category 'squeak protocol') -----
includes: aDateAndTime
| dt |
dt _ aDateAndTime asDateAndTime.
self scheduleDo: [ :e | e = dt ifTrue: [^true] ].
^ false.
!
----- Method: Schedule>>schedule (in category 'enumerating') -----
schedule
^ schedule
!
----- Method: Schedule>>schedule: (in category 'enumerating') -----
schedule: anArrayOfDurations
schedule _ anArrayOfDurations
!
----- Method: Schedule>>scheduleDo: (in category 'enumerating') -----
scheduleDo: aBlock
self between: (self start) and: (self end) do: aBlock.
!
----- Method: Timespan class>>current (in category 'squeak protocol') -----
current
^ self starting: DateAndTime now
!
----- Method: Timespan class>>fromDate: (in category 'deprecated') -----
fromDate: aDate
^ self
deprecated: 'Use #starting: ';
starting: aDate
!
----- Method: Timespan class>>new (in category 'squeak protocol') -----
new
"Answer a Timespan starting on the Squeak epoch: 1 January 1901"
^ self starting: DateAndTime new
!
----- Method: Timespan class>>starting: (in category 'squeak protocol') -----
starting: aDateAndTime
^ self starting: aDateAndTime duration: Duration zero
!
----- Method: Timespan class>>starting:duration: (in category 'squeak protocol') -----
starting: aDateAndTime duration: aDuration
^ self basicNew
start: aDateAndTime asDateAndTime;
duration: aDuration;
yourself.!
----- Method: Timespan class>>starting:ending: (in category 'squeak protocol') -----
starting: startDateAndTime ending: endDateAndTime
^ self
starting: startDateAndTime
duration: (endDateAndTime asDateAndTime - startDateAndTime).
!
----- Method: Timespan>>+ (in category 'ansi protocol') -----
+ operand
"operand conforms to protocol Duration"
^ self class starting: (self start + operand) duration: self duration
!
----- Method: Timespan>>- (in category 'ansi protocol') -----
- operand
"operand conforms to protocol DateAndTime or protocol Duration"
^ (operand respondsTo: #asDateAndTime)
ifTrue: [ self start - operand ]
ifFalse: [ self + (operand negated) ].
!
----- Method: Timespan>>< (in category 'ansi protocol') -----
< comparand
^ self start < comparand
!
----- Method: Timespan>>= (in category 'ansi protocol') -----
= comparand
^ (self start = comparand start) and: [self duration = comparand duration]
!
----- Method: Timespan>>asDate (in category 'squeak protocol') -----
asDate
^ start asDate
!
----- Method: Timespan>>asDateAndTime (in category 'squeak protocol') -----
asDateAndTime
^ start
!
----- Method: Timespan>>asDuration (in category 'squeak protocol') -----
asDuration
^ self duration!
----- Method: Timespan>>asMonth (in category 'squeak protocol') -----
asMonth
^ start asMonth
!
----- Method: Timespan>>asTime (in category 'squeak protocol') -----
asTime
^ start asTime!
----- Method: Timespan>>asTimeStamp (in category 'squeak protocol') -----
asTimeStamp
^ start asTimeStamp!
----- Method: Timespan>>asWeek (in category 'squeak protocol') -----
asWeek
^ start asWeek
!
----- Method: Timespan>>asYear (in category 'squeak protocol') -----
asYear
^ start asYear!
----- Method: Timespan>>dates (in category 'enumerating') -----
dates
| dates |
dates _ OrderedCollection new.
self datesDo: [ :m | dates add: m ].
^ dates asArray.!
----- Method: Timespan>>datesDo: (in category 'enumerating') -----
datesDo: aBlock
self do: aBlock with: start asDate.
!
----- Method: Timespan>>day (in category 'smalltalk-80') -----
day
"Answer the day of the year represented by the receiver."
^ self dayOfYear!
----- Method: Timespan>>dayOfMonth (in category 'ansi protocol') -----
dayOfMonth
"Answer the day of the month represented by the receiver."
^ start dayOfMonth!
----- Method: Timespan>>dayOfWeek (in category 'ansi protocol') -----
dayOfWeek
"Answer the day of the week represented by the receiver."
^ start dayOfWeek!
----- Method: Timespan>>dayOfWeekName (in category 'ansi protocol') -----
dayOfWeekName
"Answer the day of the week represented by the receiver."
^ start dayOfWeekName!
----- Method: Timespan>>dayOfYear (in category 'ansi protocol') -----
dayOfYear
"Answer the day of the year represented by the receiver."
^ start dayOfYear!
----- Method: Timespan>>daysInMonth (in category 'smalltalk-80') -----
daysInMonth
^ start daysInMonth
!
----- Method: Timespan>>daysInYear (in category 'smalltalk-80') -----
daysInYear
"Answer the number of days in the month represented by the receiver."
^ start daysInYear
!
----- Method: Timespan>>daysLeftInYear (in category 'smalltalk-80') -----
daysLeftInYear
^ start daysLeftInYear!
----- Method: Timespan>>do:with: (in category 'private') -----
do: aBlock with: aFirstElement
self do: aBlock with: aFirstElement when: [ :t | true ].
!
----- Method: Timespan>>do:with:when: (in category 'private') -----
do: aBlock with: aFirstElement when: aConditionBlock
| element end |
element _ aFirstElement.
end _ self end.
[ element start <= end ] whileTrue:
[(aConditionBlock value: element)
ifTrue: [ aBlock value: element ].
element _ element next. ]!
----- Method: Timespan>>duration (in category 'squeak protocol') -----
duration
"Answer the Duration of this timespan"
^ duration
!
----- Method: Timespan>>duration: (in category 'private') -----
duration: aDuration
"Set the Duration of this timespan"
duration _ aDuration
!
----- Method: Timespan>>end (in category 'squeak protocol') -----
end
^ self duration asNanoSeconds = 0
ifTrue: [ self start ]
ifFalse: [ self next start - DateAndTime clockPrecision ]!
----- Method: Timespan>>every:do: (in category 'enumerating') -----
every: aDuration do: aBlock
| element end |
element _ self start.
end _ self end.
[ element <= end ] whileTrue:
[ aBlock value: element.
element _ element + aDuration. ]
!
----- Method: Timespan>>firstDate (in category 'deprecated') -----
firstDate
self deprecated: 'Use #start'.
^ self start asDate!
----- Method: Timespan>>firstDayOfMonth (in category 'smalltalk-80') -----
firstDayOfMonth
^ start firstDayOfMonth!
----- Method: Timespan>>hash (in category 'ansi protocol') -----
hash
^ start hash + duration hash
!
----- Method: Timespan>>includes: (in category 'squeak protocol') -----
includes: aDateAndTime
^ (aDateAndTime isKindOf: Timespan)
ifTrue: [ (self includes: aDateAndTime start)
and: [ self includes: aDateAndTime end ] ]
ifFalse: [ aDateAndTime asDateAndTime between: start and: self end ]
!
----- Method: Timespan>>includesAllOf: (in category 'squeak protocol') -----
includesAllOf: aCollection
"Answer whether all the elements of aCollection are in the receiver."
aCollection do: [:elem | (self includes: elem) ifFalse: [^ false]].
^ true
!
----- Method: Timespan>>includesAnyOf: (in category 'squeak protocol') -----
includesAnyOf: aCollection
"Answer whether any element of aCollection is included in the receiver"
aCollection do: [ :elem | (self includes: elem) ifTrue: [^ true]].
^false
!
----- Method: Timespan>>intersection: (in category 'squeak protocol') -----
intersection: aTimespan
"Return the Timespan both have in common, or nil"
| aBegin anEnd |
aBegin _ self start max: aTimespan start.
anEnd _ self end min: aTimespan end.
anEnd < aBegin ifTrue: [^nil].
^ self class starting: aBegin ending: anEnd.
!
----- Method: Timespan>>isLeapYear (in category 'ansi protocol') -----
isLeapYear
^ start isLeapYear
!
----- Method: Timespan>>julianDayNumber (in category 'squeak protocol') -----
julianDayNumber
^ start julianDayNumber
!
----- Method: Timespan>>lastDate (in category 'deprecated') -----
lastDate
self deprecated: 'Use #end'.
^ self end asDate!
----- Method: Timespan>>month (in category 'ansi protocol') -----
month
^ start month
!
----- Method: Timespan>>monthAbbreviation (in category 'ansi protocol') -----
monthAbbreviation
^ start monthAbbreviation
!
----- Method: Timespan>>monthIndex (in category 'smalltalk-80') -----
monthIndex
^ self month
!
----- Method: Timespan>>monthName (in category 'ansi protocol') -----
monthName
^ start monthName
!
----- Method: Timespan>>months (in category 'enumerating') -----
months
| months |
months _ OrderedCollection new: 12.
self monthsDo: [ :m | months add: m ].
^ months asArray.!
----- Method: Timespan>>monthsDo: (in category 'enumerating') -----
monthsDo: aBlock
self do: aBlock with: start asMonth.!
----- Method: Timespan>>next (in category 'smalltalk-80') -----
next
^ self class starting: (start + duration) duration: duration
!
----- Method: Timespan>>previous (in category 'smalltalk-80') -----
previous
^ self class starting: (start - duration) duration: duration
!
----- Method: Timespan>>printOn: (in category 'squeak protocol') -----
printOn: aStream
super printOn: aStream.
aStream
nextPut: $(;
print: start;
nextPut: $D;
print: duration;
nextPut: $).
!
----- Method: Timespan>>start (in category 'squeak protocol') -----
start
"Answer the start DateAndTime of this timespan"
^ start
!
----- Method: Timespan>>start: (in category 'squeak protocol') -----
start: aDateAndTime
"Store the start DateAndTime of this timespan"
start _ aDateAndTime asDateAndTime
!
----- Method: Timespan>>to: (in category 'squeak protocol') -----
to: anEnd
"Answer an Timespan. anEnd must be aDateAndTime or a Timespan"
^ Timespan starting: (self start) ending: (anEnd asDateAndTime).
!
----- Method: Timespan>>union: (in category 'squeak protocol') -----
union: aTimespan
"Return the Timespan spanned by both"
| aBegin anEnd |
aBegin _ self start min: aTimespan start.
anEnd _ self end max: aTimespan end.
^ Timespan starting: aBegin ending: (anEnd + DateAndTime clockPrecision).
!
----- Method: Timespan>>weeks (in category 'enumerating') -----
weeks
| weeks |
weeks _ OrderedCollection new.
self weeksDo: [ :m | weeks add: m ].
^ weeks asArray.!
----- Method: Timespan>>weeksDo: (in category 'enumerating') -----
weeksDo: aBlock
self do: aBlock with: self asWeek.!
----- Method: Timespan>>workDatesDo: (in category 'enumerating') -----
workDatesDo: aBlock
"Exclude Saturday and Sunday"
self do: aBlock with: start asDate when: [ :d | d dayOfWeek < 6 ].
!
----- Method: Timespan>>year (in category 'ansi protocol') -----
year
^ start year
!
----- Method: Timespan>>years (in category 'enumerating') -----
years
| years |
years _ OrderedCollection new.
self yearsDo: [ :m | years add: m ].
^ years asArray.!
----- Method: Timespan>>yearsDo: (in category 'enumerating') -----
yearsDo: aBlock
self do: aBlock with: start asYear.!
Timespan subclass: #Year
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Kernel-Chronology'!
!Year commentStamp: '<historical>' prior: 0!
I represent a year.
!
----- Method: Year class>>current (in category 'squeak protocol') -----
current
^ self year: (DateAndTime now year)
!
----- Method: Year class>>daysInYear: (in category 'smalltalk-80') -----
daysInYear: yearInteger
^ 365 + ((self isLeapYear: yearInteger) ifTrue: [1] ifFalse: [0]).
!
----- Method: Year class>>isLeapYear: (in category 'squeak protocol') -----
isLeapYear: aYearInteger
| adjustedYear |
adjustedYear _ aYearInteger > 0
ifTrue: [aYearInteger]
ifFalse: [(aYearInteger + 1) negated].
"There was no year 0"
^ ((adjustedYear \\ 4 ~= 0) or: [(adjustedYear \\ 100 = 0) and: [adjustedYear \\ 400 ~= 0]]) not.!
----- Method: Year class>>leapYear: (in category 'smalltalk-80') -----
leapYear: yearInteger
^ (self isLeapYear: yearInteger)
ifTrue: [1]
ifFalse: [0]!
----- Method: Year class>>starting:duration: (in category 'squeak protocol') -----
starting: aDateAndTime duration: aDuration
"Override - start from midnight"
| midnight |
midnight _ aDateAndTime asDateAndTime midnight.
^ super
starting: midnight
duration: (Duration days: (self daysInYear: midnight year)).!
----- Method: Year class>>year: (in category 'squeak protocol') -----
year: aYear
^ self starting: (DateAndTime year: aYear month: 1 day: 1).!
----- Method: Year>>asYear (in category 'squeak protocol') -----
asYear
^ self
!
----- Method: Year>>daysInMonth (in category 'squeak protocol') -----
daysInMonth
self shouldNotImplement
!
----- Method: Year>>daysInYear (in category 'squeak protocol') -----
daysInYear
^ self duration days.!
----- Method: Year>>printOn: (in category 'squeak protocol') -----
printOn: aStream
aStream nextPutAll: 'a Year ('.
self start year printOn: aStream.
aStream nextPutAll: ')'.
!
Object subclass: #Message
instanceVariableNames: 'selector args lookupClass'
classVariableNames: ''
poolDictionaries: ''
category: 'Kernel-Methods'!
!Message commentStamp: 'tk 3/26/2007 11:37' 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.
A note on copying: Strictly speaking, a Message should weakly copy its argument. If a Message has a Morph as its argument, sending veryDeepCopy to the Message should not duplicate the Morph. Except when it is part of a larger copy that includes the Morph. To keep things simple, we have not forced weak copying of the argument.!
----- Method: Message class>>catcher (in category 'instance creation') -----
catcher
^ MessageCatcher new!
----- 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)!
----- 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)!
----- 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!
----- Method: Message>>argument (in category 'accessing') -----
argument
"Answer the first (presumably sole) argument"
^args at: 1!
----- Method: Message>>argument: (in category 'accessing') -----
argument: newValue
"Change the first argument to newValue and answer self"
args at: 1 put: newValue!
----- Method: Message>>arguments (in category 'accessing') -----
arguments
"Answer the arguments of the receiver."
^args!
----- Method: Message>>createStubMethod (in category 'stub creation') -----
createStubMethod
| argNames aOrAn argName arg argClassName |
argNames _ Set new.
^ String streamContents: [ :s |
self selector keywords doWithIndex: [ :key :i |
s nextPutAll: key.
((key last = $:) or: [self selector isInfix]) ifTrue: [
arg _ self arguments at: i.
argClassName _ (arg isKindOf: Class) ifTrue: ['Class'] ifFalse: [arg class name].
aOrAn _ argClassName first isVowel ifTrue: ['an'] ifFalse: ['a'].
argName _ aOrAn, argClassName.
[argNames includes: argName] whileTrue: [argName _ argName, i asString].
argNames add: argName.
s nextPutAll: ' '; nextPutAll: argName; space
].
].
s cr; tab.
s nextPutAll: 'self shouldBeImplemented'
]!
----- Method: Message>>lookupClass (in category 'accessing') -----
lookupClass
^ lookupClass!
----- Method: Message>>lookupClass: (in category 'private') -----
lookupClass: aClass
lookupClass _ aClass!
----- 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.
!
----- Method: Message>>pushReceiver (in category 'as yet unclassified') -----
pushReceiver!
----- Method: Message>>selector (in category 'accessing') -----
selector
"Answer the selector of the receiver."
^selector!
----- Method: Message>>sendTo: (in category 'sending') -----
sendTo: receiver
"answer the result of sending this message to receiver"
^ receiver perform: selector withArguments: args!
----- Method: Message>>sends: (in category 'accessing') -----
sends: aSelector
"answer whether this message's selector is aSelector"
^selector == aSelector!
----- 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]!
----- Method: Message>>setSelector: (in category 'private') -----
setSelector: aSymbol
selector _ aSymbol.
!
----- Method: Message>>setSelector:arguments: (in category 'private') -----
setSelector: aSymbol arguments: anArray
selector _ aSymbol.
args _ anArray!
----- 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: $)!
Object subclass: #MessageSend
instanceVariableNames: 'receiver selector arguments'
classVariableNames: ''
poolDictionaries: ''
category: 'Kernel-Objects'!
!MessageSend commentStamp: 'tk 3/26/2007 11:37' prior: 0!
Instances of MessageSend encapsulate message sends to objects. Arguments can be either predefined or supplied when the message send is performed. MessageSends are used to implement the #when:send:to: event system.
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
A note on copying: Strictly speaking, a MessageSend should weakly copy its receiver and arguments. If a MessageSend has a Morph as an argument, sending veryDeepCopy to the MessageSend should not duplicate the Morph. Except when the copy is part of a larger copy that includes the Morph. To keep things simple, we have not enforced weak copying here.!
----- Method: MessageSend class>>receiver:selector: (in category 'instance creation') -----
receiver: anObject selector: aSymbol
^ self receiver: anObject selector: aSymbol arguments: #()!
----- 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)!
----- Method: MessageSend class>>receiver:selector:arguments: (in category 'instance creation') -----
receiver: anObject selector: aSymbol arguments: anArray
^ self new
receiver: anObject;
selector: aSymbol;
arguments: anArray!
----- Method: MessageSend>>= (in category 'comparing') -----
= anObject
^ anObject species == self species
and: [receiver == anObject receiver
and: [selector == anObject selector
and: [arguments = anObject arguments]]]!
----- Method: MessageSend>>arguments (in category 'accessing') -----
arguments
^ arguments!
----- Method: MessageSend>>arguments: (in category 'accessing') -----
arguments: anArray
arguments _ anArray!
----- Method: MessageSend>>asMinimalRepresentation (in category 'converting') -----
asMinimalRepresentation
^self!
----- 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]!
----- Method: MessageSend>>fixTemps (in category 'evaluating') -----
fixTemps
"compatible interface with BlockContext"!
----- Method: MessageSend>>hash (in category 'comparing') -----
hash
^ receiver hash bitXor: selector hash!
----- Method: MessageSend>>isMessageSend (in category 'testing') -----
isMessageSend
^true
!
----- Method: MessageSend>>isValid (in category 'testing') -----
isValid
^true!
----- Method: MessageSend>>printOn: (in category 'printing') -----
printOn: aStream
aStream
nextPutAll: self class name;
nextPut: $(.
selector printOn: aStream.
aStream nextPutAll: ' -> '.
receiver printOn: aStream.
aStream nextPut: $)!
----- Method: MessageSend>>receiver (in category 'accessing') -----
receiver
^ receiver!
----- Method: MessageSend>>receiver: (in category 'accessing') -----
receiver: anObject
receiver _ anObject!
----- Method: MessageSend>>selector (in category 'accessing') -----
selector
^ selector!
----- Method: MessageSend>>selector: (in category 'accessing') -----
selector: aSymbol
selector _ aSymbol!
----- Method: MessageSend>>stringFor: (in category 'tiles') -----
stringFor: anObject
"Return a string suitable for compiling. Literal or reference from global ref dictionary. self is always named via the ref dictionary."
| generic aName |
anObject isLiteral ifTrue: [^ anObject printString].
anObject class == Color ifTrue: [^ anObject printString].
anObject class superclass == Boolean ifTrue: [^ anObject printString].
anObject class == BlockContext ifTrue: [^ '[''do nothing'']']. "default block"
"Real blocks need to construct tiles in a different way"
anObject class isMeta ifTrue: ["a class" ^ anObject name].
generic _ anObject knownName. "may be nil or 'Ellipse' "
aName _ anObject uniqueNameForReference.
generic ifNil:
[(anObject respondsTo: #renameTo:)
ifTrue: [anObject renameTo: aName]
ifFalse: [aName _ anObject storeString]]. "for Fraction, LargeInt, etc"
^ aName
!
----- 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)!
----- Method: MessageSend>>valueWithArguments: (in category 'evaluating') -----
valueWithArguments: anArray
^ receiver
perform: selector
withArguments: (self collectArguments: anArray)!
----- 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!
Object subclass: #MethodFinder
instanceVariableNames: 'data answers selector argMap thisData mapStage mapList expressions cachedClass cachedArgNum cachedSelectorLists'
classVariableNames: 'AddAndRemove Approved Blocks Dangerous'
poolDictionaries: ''
category: 'Kernel-Methods'!
!MethodFinder commentStamp: 'tk 3/26/2007 11:51' prior: 0!
Find a method in the system from a set of examples. Done by brute force, trying every possible selector. Errors are skipped over using ( [3 + 'xyz'] ifError: [^ false] ).
Submit an array of the form ((data1 data2) answer (data1 data2) answer).
MethodFinder methodFor: #( (4 3) 7 (0 5) 5 (5 5) 10).
answer: 'data1 + data2'
More generally, use the brace notation to construct live examples.
The program tries data1 as the receiver, and
tries all other permutations of the data for the receiver and args, and
tries leaving out one argument, and
uses all selectors data understands, and
uses all selectors in all of data's superclasses.
Floating point values must be precise to 0.01 percent, or (X * 0.0001).
If you get a Notifier window, you have probably discovered a selector that needs to be removed from the Approved list. See MethodFinder.initialize. Please email the Squeak Team.
Only considers 0, 1, 2, and 3 argument messages. The argument data may have 1 to 5 entries, but only a max of 4 used at a time. For now, we only test messages that use given number of args or one fewer. For example, this data (100 true 0.6) would test the receiver plus two args, and the receiver plus one arg, but not any other patterns.
Three sets of selectors: Approved, AddAndRemove, and Blocks selectors. When testing a selector in AddAndRemove, deepCopy the receiver. We do not handle selectors that modify an argument (printOn: etc.). Blocks is a set of (selector argNumber) where that argument must be a block.
For perform, the selector is tested. It must be in the Approved list.
do: is not on the Approved list. It does not produce a result that can be tested. Type 'do' into the upper pane of the Selector Finder to find messages related to 'do'.
Future Improvements:
1. Later, allow the user to supply a block that tests the answer, not just the literal answer.
2. When searching for ifTrue:ifFalse: as in (MethodFinder methodFor: { { true. [3]. [4]}. 3}) allow this to work without the brackets around 3 and 4. Allow this for any block argument.!
----- Method: MethodFinder class>>methodFor: (in category 'as yet unclassified') -----
methodFor: dataAndAnswers
"Return a Squeak expression that computes these answers. (This method is called by the comment in the bottom pane of a MethodFinder. Do not delete this method.)"
| resultOC selFinder resultString |
resultOC _ (self new) load: dataAndAnswers; findMessage.
resultString _ String streamContents: [:strm |
resultOC do: [:exp | strm nextPut: $(; nextPutAll: exp; nextPut: $); space]].
Smalltalk isMorphic ifTrue: [
selFinder _ (ActiveWorld
submorphThat: [:mm | mm class == SystemWindow and:
[mm model isKindOf: SelectorBrowser]]
ifNone: [^ resultString]) model.
selFinder searchResult: resultOC].
^ resultString!
----- Method: MethodFinder>>allNumbers (in category 'find a constant') -----
allNumbers
"Return true if all answers and all data are numbers."
answers do: [:aa | aa isNumber ifFalse: [^ false]].
thisData do: [:vec |
vec do: [:nn | nn isNumber ifFalse: [^ false]]].
^ true!
----- Method: MethodFinder>>answers (in category 'access') -----
answers
^ answers!
----- Method: MethodFinder>>argMap (in category 'arg maps') -----
argMap
^ argMap !
----- Method: MethodFinder>>cleanInputs: (in category 'initialize') -----
cleanInputs: dataAndAnswerString
"Find an remove common mistakes. Complain when ill formed."
| fixed ddd rs places |
ddd _ dataAndAnswerString.
fixed _ false.
rs _ ReadStream on: ddd, ' '.
places _ OrderedCollection new.
[rs upToAll: '#true'. rs atEnd] whileFalse: [places addFirst: rs position-4].
places do: [:pos | ddd _ ddd copyReplaceFrom: pos to: pos with: ''.
fixed _ true]. "remove #"
rs _ ReadStream on: ddd.
places _ OrderedCollection new.
[rs upToAll: '#false'. rs atEnd] whileFalse: [places addFirst: rs position-5].
places do: [:pos | ddd _ ddd copyReplaceFrom: pos to: pos with: ''.
fixed _ true]. "remove #"
fixed ifTrue: [self inform: '#(true false) are Symbols, not Booleans.
Next time use { true. false }.'].
fixed _ false.
rs _ ReadStream on: ddd.
places _ OrderedCollection new.
[rs upToAll: '#nil'. rs atEnd] whileFalse: [places addFirst: rs position-3].
places do: [:pos | ddd _ ddd copyReplaceFrom: pos to: pos with: ''.
fixed _ true]. "remove #"
fixed ifTrue: [self inform: '#nil is a Symbol, not the authentic UndefinedObject.
Next time use nil instead of #nil'].
^ ddd
!
----- Method: MethodFinder>>const (in category 'find a constant') -----
const
| const |
"See if (^ constant) is the answer"
"quick test"
((const _ answers at: 1) closeTo: (answers at: 2)) ifFalse: [^ false].
3 to: answers size do: [:ii | (const closeTo: (answers at: ii)) ifFalse: [^ false]].
expressions add: '^ ', const printString.
selector add: #yourself.
^ true!
----- Method: MethodFinder>>constDiv (in category 'find a constant') -----
constDiv
| const subTest got |
"See if (data1 // C) is the answer"
const _ ((thisData at: 1) at: 1) // (answers at: 1). "May not be right!!"
got _ (subTest _ MethodFinder new copy: self addArg: const)
searchForOne isEmpty not.
got ifFalse: [^ false].
"replace data2 with const in expressions"
subTest expressions do: [:exp |
expressions add: (exp copyReplaceAll: 'data2' with: const printString)].
selector addAll: subTest selectors.
^ true!
----- Method: MethodFinder>>constEquiv (in category 'find a constant') -----
constEquiv
| const subTest got jj |
"See if (data1 = C) or (data1 ~= C) is the answer"
"quick test"
((answers at: 1) class superclass == Boolean) ifFalse: [^ false].
2 to: answers size do: [:ii |
((answers at: ii) class superclass == Boolean) ifFalse: [^ false]].
const _ (thisData at: 1) at: 1.
got _ (subTest _ MethodFinder new copy: self addArg: const)
searchForOne isEmpty not.
got ifFalse: ["try other polarity for ~~ "
(jj _ answers indexOf: (answers at: 1) not) > 0 ifTrue: [
const _ (thisData at: jj) at: 1.
got _ (subTest _ MethodFinder new copy: self addArg: const)
searchForOne isEmpty not]].
got ifFalse: [^ false].
"replace data2 with const in expressions"
subTest expressions do: [:exp |
expressions add: (exp copyReplaceAll: 'data2' with: const printString)].
selector addAll: subTest selectors.
^ true!
----- Method: MethodFinder>>constLinear (in category 'find a constant') -----
constLinear
| const subTest got denom num slope offset |
"See if (data1 * C1) + C2 is the answer. In the form #(C2 C1) polynomialEval: data1 "
denom _ ((thisData at: 2) at: 1) - ((thisData at: 1) at: 1).
denom = 0 ifTrue: [^ false]. "will divide by it"
num _ (answers at: 2) - (answers at: 1).
slope := (num asFloat / denom) reduce.
offset := ((answers at: 2) - (((thisData at: 2) at: 1) * slope)) reduce.
const _ Array with: offset with: slope.
got _ (subTest _ MethodFinder new copy: self addArg: const)
searchForOne isEmpty not.
got ifFalse: [^ false].
"replace data2 with const in expressions"
subTest expressions do: [:exp |
expressions add: (exp copyReplaceAll: 'data2' with: const printString)].
selector addAll: subTest selectors.
^ true!
----- Method: MethodFinder>>constMod (in category 'find a constant') -----
constMod
| subTest low |
"See if mod, (data1 \\ C) is the answer"
low _ answers max.
low+1 to: low+20 do: [:const |
subTest _ MethodFinder new copy: self addArg: const.
(subTest testPerfect: #\\) ifTrue: [
expressions add: 'data1 \\ ', const printString.
selector add: #\\.
^ true]].
^ false!
----- Method: MethodFinder>>constMult (in category 'find a constant') -----
constMult
| const subTest got |
"See if (data1 * C) is the answer"
((thisData at: 1) at: 1) = 0 ifTrue: [^ false].
const _ ((answers at: 1) asFloat / ((thisData at: 1) at: 1)) reduce.
got _ (subTest _ MethodFinder new copy: self addArg: const)
searchForOne isEmpty not.
got ifFalse: [^ false].
"replace data2 with const in expressions"
subTest expressions do: [:exp |
expressions add: (exp copyReplaceAll: 'data2' with: const printString)].
selector addAll: subTest selectors.
^ true!
----- Method: MethodFinder>>constPlus (in category 'find a constant') -----
constPlus
| const subTest got |
"See if (data1 + C) is the answer"
const _ (answers at: 1) - ((thisData at: 1) at: 1).
got _ (subTest _ MethodFinder new copy: self addArg: const)
searchForOne isEmpty not.
got ifFalse: [^ false].
"replace data2 with const in expressions"
subTest expressions do: [:exp |
expressions add: (exp copyReplaceAll: 'data2' with: const printString)].
selector addAll: subTest selectors.
^ true!
----- Method: MethodFinder>>constUsingData1Value (in category 'find a constant') -----
constUsingData1Value
| const subTest got |
"See if (data1 <= C) or (data1 >= C) is the answer"
"quick test"
((answers at: 1) class superclass == Boolean) ifFalse: [^ false].
2 to: answers size do: [:ii |
((answers at: ii) class superclass == Boolean) ifFalse: [^ false]].
thisData do: [:datums |
const _ datums first. "use data as a constant!!"
got _ (subTest _ MethodFinder new copy: self addArg: const)
searchForOne isEmpty not.
got ifTrue: [
"replace data2 with const in expressions"
subTest expressions do: [:exp |
expressions add: (exp copyReplaceAll: 'data2' with: const printString)].
selector addAll: subTest selectors.
^ true]].
^ false!
----- Method: MethodFinder>>copy:addArg: (in category 'initialize') -----
copy: mthFinder addArg: aConstant
| more |
"Copy inputs and answers, add an additional data argument to the inputs. The same constant for every example"
more _ Array with: aConstant.
data _ mthFinder data collect: [:argList | argList, more].
answers _ mthFinder answers.
self load: nil.
!
----- Method: MethodFinder>>data (in category 'access') -----
data
^ data!
----- Method: MethodFinder>>exceptions (in category 'search') -----
exceptions
"Handle some very slippery selectors.
asSymbol -- want to be able to produce it, but do not want to make every string submitted into a Symbol!!"
| aSel |
answers first isSymbol ifFalse: [^ self].
thisData first first isString ifFalse: [^ self].
aSel _ #asSymbol.
(self testPerfect: aSel) ifTrue: [
selector add: aSel.
expressions add: (String streamContents: [:strm |
strm nextPutAll: 'data', argMap first printString.
aSel keywords doWithIndex: [:key :ind |
strm nextPutAll: ' ',key.
(key last == $:) | (key first isLetter not)
ifTrue: [strm nextPutAll: ' data',
(argMap at: ind+1) printString]]])].
!
----- Method: MethodFinder>>expressions (in category 'access') -----
expressions
^ expressions!
----- Method: MethodFinder>>findMessage (in category 'search') -----
findMessage
"Control the search."
data do: [:alist |
(alist isKindOf: SequenceableCollection) ifFalse: [
^ OrderedCollection with: 'first and third items are not Arrays']].
Approved ifNil: [self initialize]. "Sets of allowed selectors"
expressions _ OrderedCollection new.
self search: true. "multi"
expressions isEmpty ifTrue: [^ OrderedCollection with: 'no single method does that function'].
expressions isString ifTrue: [^ OrderedCollection with: expressions].
^ expressions!
----- Method: MethodFinder>>initialize (in category 'initialize') -----
initialize
"The methods we are allowed to use. (MethodFinder new initialize) "
Approved _ Set new.
AddAndRemove _ Set new.
Blocks _ Set new.
"These modify an argument and are not used by the MethodFinder: longPrintOn: printOn: storeOn: sentTo: storeOn:base: printOn:base: absPrintExactlyOn:base: absPrintOn:base: absPrintOn:base:digitCount: writeOn: writeScanOn: possibleVariablesFor:continuedFrom: printOn:format:"
"Object"
#("in class, instance creation" categoryForUniclasses chooseUniqueClassName initialInstance isSystemDefined newFrom: officialClass readCarefullyFrom:
"accessing" at: basicAt: basicSize bindWithTemp: in: size yourself
"testing" basicType ifNil: ifNil:ifNotNil: ifNotNil: ifNotNil:ifNil: isColor isFloat isFraction isInMemory isInteger isMorph isNil isNumber isPoint isPseudoContext isText isTransparent isWebBrowser knownName notNil pointsTo: wantsSteps
"comparing" = == closeTo: hash hashMappedBy: identityHash identityHashMappedBy: identityHashPrintString ~= ~~
"copying" clone copy shallowCopy
"dependents access" canDiscardEdits dependents hasUnacceptedEdits
"updating" changed changed: okToChange update: windowIsClosing
"printing" fullPrintString isLiteral longPrintString printString storeString stringForReadout stringRepresentation
"class membership" class isKindOf: isKindOf:orOf: isMemberOf: respondsTo: xxxClass
"error handling"
"user interface" addModelMenuItemsTo:forMorph:hand: defaultBackgroundColor defaultLabelForInspector fullScreenSize initialExtent modelWakeUp mouseUpBalk: newTileMorphRepresentative windowActiveOnFirstClick windowReqNewLabel:
"system primitives" asOop instVarAt: instVarNamed:
"private"
"associating" ->
"converting" as: asOrderedCollection asString
"casing" caseOf: caseOf:otherwise:
"binding" bindingOf:
"macpal" contentsChanged currentEvent currentHand currentWorld flash ifKindOf:thenDo: instanceVariableValues scriptPerformer
"flagging" flag:
"translation support" "objects from disk" "finalization" ) do: [:sel | Approved add: sel].
#(at:add: at:modify: at:put: basicAt:put: "NOT instVar:at:"
"message handling" perform: perform:orSendTo: perform:with: perform:with:with: perform:with:with:with: perform:withArguments: perform:withArguments:inSuperclass:
) do: [:sel | AddAndRemove add: sel].
"Boolean, True, False, UndefinedObject"
#("logical operations" & eqv: not xor: |
"controlling" and: ifFalse: ifFalse:ifTrue: ifTrue: ifTrue:ifFalse: or:
"copying"
"testing" isEmptyOrNil) do: [:sel | Approved add: sel].
"Behavior"
#("initialize-release"
"accessing" compilerClass decompilerClass evaluatorClass format methodDict parserClass sourceCodeTemplate subclassDefinerClass
"testing" instSize instSpec isBits isBytes isFixed isPointers isVariable isWeak isWords
"copying"
"printing" defaultNameStemForInstances printHierarchy
"creating class hierarchy"
"creating method dictionary"
"instance creation" basicNew basicNew: new new:
"accessing class hierarchy" allSubclasses allSubclassesWithLevelDo:startingLevel: allSuperclasses subclasses superclass withAllSubclasses withAllSuperclasses
"accessing method dictionary" allSelectors changeRecordsAt: compiledMethodAt: compiledMethodAt:ifAbsent: firstCommentAt: lookupSelector: selectors selectorsDo: selectorsWithArgs: "slow but useful ->" sourceCodeAt: sourceCodeAt:ifAbsent: sourceMethodAt: sourceMethodAt:ifAbsent:
"accessing instances and variables" allClassVarNames allInstVarNames allSharedPools classVarNames instVarNames instanceCount sharedPools someInstance subclassInstVarNames
"testing class hierarchy" inheritsFrom: kindOfSubclass
"testing method dictionary" canUnderstand: classThatUnderstands: hasMethods includesSelector: scopeHas:ifTrue: whichClassIncludesSelector: whichSelectorsAccess: whichSelectorsReferTo: whichSelectorsReferTo:special:byte: whichSelectorsStoreInto:
"enumerating"
"user interface"
"private" indexIfCompact) do: [:sel | Approved add: sel].
"ClassDescription"
#("initialize-release"
"accessing" classVersion isMeta name theNonMetaClass
"copying"
"printing" classVariablesString instanceVariablesString sharedPoolsString
"instance variables" checkForInstVarsOK:
"method dictionary"
"organization" category organization whichCategoryIncludesSelector:
"compiling" acceptsLoggingOfCompilation wantsChangeSetLogging
"fileIn/Out" definition
"private" ) do: [:sel | Approved add: sel].
"Class"
#("initialize-release"
"accessing" classPool
"testing"
"copying"
"class name"
"instance variables"
"class variables" classVarAt: classVariableAssociationAt:
"pool variables"
"compiling"
"subclass creation"
"fileIn/Out" ) do: [:sel | Approved add: sel].
"Metaclass"
#("initialize-release"
"accessing" isSystemDefined soleInstance
"copying" "instance creation" "instance variables" "pool variables" "class hierarchy" "compiling"
"fileIn/Out" nonTrivial ) do: [:sel | Approved add: sel].
"Context, BlockContext"
#(receiver client method receiver tempAt:
"debugger access" mclass pc selector sender shortStack sourceCode tempNames tempsAndValues
"controlling" "printing" "system simulation"
"initialize-release"
"accessing" hasMethodReturn home numArgs
"evaluating" value value:ifError: value:value: value:value:value: value:value:value:value: valueWithArguments:
"controlling" "scheduling" "instruction decoding" "printing" "private" "system simulation" ) do: [:sel | Approved add: sel].
#(value: "<- Association has it as a store" ) do: [:sel | AddAndRemove add: sel].
"Message"
#("inclass, instance creation" selector: selector:argument: selector:arguments:
"accessing" argument argument: arguments sends:
"printing" "sending" ) do: [:sel | Approved add: sel].
#("private" setSelector:arguments:) do: [:sel | AddAndRemove add: sel].
"Magnitude"
#("comparing" < <= > >= between:and:
"testing" max: min: min:max: ) do: [:sel | Approved add: sel].
"Date, Time"
#("in class, instance creation" fromDays: fromSeconds: fromString: newDay:month:year: newDay:year: today
"in class, general inquiries" dateAndTimeNow dayOfWeek: daysInMonth:forYear: daysInYear: firstWeekdayOfMonth:year: indexOfMonth: leapYear: nameOfDay: nameOfMonth:
"accessing" day leap monthIndex monthName weekday year
"arithmetic" addDays: subtractDate: subtractDays:
"comparing"
"inquiries" dayOfMonth daysInMonth daysInYear daysLeftInYear firstDayOfMonth previous:
"converting" asSeconds
"printing" mmddyy mmddyyyy printFormat:
"private" firstDayOfMonthIndex: weekdayIndex
"in class, instance creation" fromSeconds: now
"in class, general inquiries" dateAndTimeFromSeconds: dateAndTimeNow millisecondClockValue millisecondsToRun: totalSeconds
"accessing" hours minutes seconds
"arithmetic" addTime: subtractTime:
"comparing"
"printing" intervalString print24
"converting") do: [:sel | Approved add: sel].
#("private" hours: hours:minutes:seconds: day:year:
) do: [:sel | AddAndRemove add: sel].
"Number"
#("in class" readFrom:base:
"arithmetic" * + - / // \\ abs negated quo: reciprocal rem:
"mathematical functions" arcCos arcSin arcTan arcTan: cos exp floorLog: ln log log: raisedTo: raisedToInteger: sin sqrt squared tan
"truncation and round off" ceiling detentBy:atMultiplesOf:snap: floor roundTo: roundUpTo: rounded truncateTo: truncated
"comparing"
"testing" even isDivisibleBy: isInf isInfinite isNaN isZero negative odd positive sign strictlyPositive
"converting" @ asInteger asNumber asPoint asSmallAngleDegrees degreesToRadians radiansToDegrees
"intervals" to: to:by:
"printing" printStringBase: storeStringBase: ) do: [:sel | Approved add: sel].
"Integer"
#("in class" primesUpTo:
"testing" isPowerOfTwo
"arithmetic" alignedTo:
"comparing"
"truncation and round off" atRandom normalize
"enumerating" timesRepeat:
"mathematical functions" degreeCos degreeSin factorial gcd: lcm: take:
"bit manipulation" << >> allMask: anyMask: bitAnd: bitClear: bitInvert bitInvert32 bitOr: bitShift: bitXor: lowBit noMask:
"converting" asCharacter asColorOfDepth: asFloat asFraction asHexDigit
"printing" asStringWithCommas hex hex8 radix:
"system primitives" lastDigit replaceFrom:to:with:startingAt:
"private" "benchmarks" ) do: [:sel | Approved add: sel].
"SmallInteger, LargeNegativeInteger, LargePositiveInteger"
#("arithmetic" "bit manipulation" highBit "testing" "comparing" "copying" "converting" "printing"
"system primitives" digitAt: digitLength
"private" fromString:radix: ) do: [:sel | Approved add: sel].
#(digitAt:put: ) do: [:sel | AddAndRemove add: sel].
"Float"
#("arithmetic"
"mathematical functions" reciprocalFloorLog: reciprocalLogBase2 timesTwoPower:
"comparing" "testing"
"truncation and round off" exponent fractionPart integerPart significand significandAsInteger
"converting" asApproximateFraction asIEEE32BitWord asTrueFraction
"copying") do: [:sel | Approved add: sel].
"Fraction, Random"
#(denominator numerator reduced next nextValue) do: [:sel | Approved add: sel].
#(setNumerator:denominator:) do: [:sel | AddAndRemove add: sel].
"Collection"
#("accessing" anyOne
"testing" includes: includesAllOf: includesAnyOf: includesSubstringAnywhere: isEmpty isSequenceable occurrencesOf:
"enumerating" collect: collect:thenSelect: count: detect: detect:ifNone: detectMax: detectMin: detectSum: inject:into: reject: select: select:thenCollect: intersection:
"converting" asBag asCharacterSet asSet asSortedArray asSortedCollection asSortedCollection:
"printing"
"private" maxSize
"arithmetic"
"math functions" average max median min range sum) do: [:sel | Approved add: sel].
#("adding" add: addAll: addIfNotPresent:
"removing" remove: remove:ifAbsent: removeAll: removeAllFoundIn: removeAllSuchThat: remove:ifAbsent:) do: [:sel | AddAndRemove add: sel].
"SequenceableCollection"
#("comparing" hasEqualElements:
"accessing" allButFirst allButLast at:ifAbsent: atAll: atPin: atRandom: atWrap: fifth first fourth identityIndexOf: identityIndexOf:ifAbsent: indexOf: indexOf:ifAbsent: indexOf:startingAt:ifAbsent: indexOfSubCollection:startingAt: indexOfSubCollection:startingAt:ifAbsent: last second sixth third
"removing"
"copying" , copyAfterLast: copyAt:put: copyFrom:to: copyReplaceAll:with: copyReplaceFrom:to:with: copyUpTo: copyUpToLast: copyWith: copyWithout: copyWithoutAll: forceTo:paddingWith: shuffled sortBy:
"enumerating" collectWithIndex: findFirst: findLast: pairsCollect: with:collect: withIndexCollect: polynomialEval:
"converting" asArray asDictionary asFloatArray asIntegerArray asStringWithCr asWordArray reversed
"private" copyReplaceAll:with:asTokens: ) do: [:sel | Approved add: sel].
#( swap:with:) do: [:sel | AddAndRemove add: sel].
"ArrayedCollection, Bag"
#("private" defaultElement
"sorting" isSorted
"accessing" cumulativeCounts sortedCounts sortedElements "testing" "adding" add:withOccurrences: "removing" "enumerating"
) do: [:sel | Approved add: sel].
#( mergeSortFrom:to:by: sort sort: add: add:withOccurrences:
"private" setDictionary ) do: [:sel | AddAndRemove add: sel].
"Other messages that modify the receiver"
#(atAll:put: atAll:putAll: atAllPut: atWrap:put: replaceAll:with: replaceFrom:to:with: removeFirst removeLast) do: [:sel | AddAndRemove add: sel].
self initialize2.
"
MethodFinder new initialize.
MethodFinder new organizationFiltered: Set
"
!
----- Method: MethodFinder>>initialize2 (in category 'initialize') -----
initialize2
"The methods we are allowed to use. (MethodFinder new initialize) "
"Set"
#("in class" sizeFor:
"testing" "adding" "removing" "enumerating"
"private" array findElementOrNil:
"accessing" someElement) do: [:sel | Approved add: sel].
"Dictionary, IdentityDictionary, IdentitySet"
#("accessing" associationAt: associationAt:ifAbsent: at:ifPresent: keyAtIdentityValue: keyAtIdentityValue:ifAbsent: keyAtValue: keyAtValue:ifAbsent: keys
"testing" includesKey: ) do: [:sel | Approved add: sel].
#(removeKey: removeKey:ifAbsent:
) do: [:sel | AddAndRemove add: sel].
"LinkedList, Interval, MappedCollection"
#("in class" from:to: from:to:by:
"accessing" contents) do: [:sel | Approved add: sel].
#(
"adding" addFirst: addLast:) do: [:sel | AddAndRemove add: sel].
"OrderedCollection, SortedCollection"
#("accessing" after: before:
"copying" copyEmpty
"adding" growSize
"removing" "enumerating" "private"
"accessing" sortBlock) do: [:sel | Approved add: sel].
#("adding" add:after: add:afterIndex: add:before: addAllFirst: addAllLast: addFirst: addLast:
"removing" removeAt: removeFirst removeLast
"accessing" sortBlock:) do: [:sel | AddAndRemove add: sel].
"Character"
#("in class, instance creation" allCharacters digitValue: new separators
"accessing untypeable characters" backspace cr enter lf linefeed nbsp newPage space tab
"constants" alphabet characterTable
"accessing" asciiValue digitValue
"comparing"
"testing" isAlphaNumeric isDigit isLetter isLowercase isSafeForHTTP isSeparator isSpecial isUppercase isVowel tokenish
"copying"
"converting" asIRCLowercase asLowercase asUppercase
) do: [:sel | Approved add: sel].
"String"
#("in class, instance creation" crlf fromPacked:
"primitives" findFirstInString:inSet:startingAt: indexOfAscii:inString:startingAt: "internet" valueOfHtmlEntity:
"accessing" byteAt: endsWithDigit findAnySubStr:startingAt: findBetweenSubStrs: findDelimiters:startingAt: findString:startingAt: findString:startingAt:caseSensitive: findTokens: findTokens:includes: findTokens:keep: includesSubString: includesSubstring:caseSensitive: indexOf:startingAt: indexOfAnyOf: indexOfAnyOf:ifAbsent: indexOfAnyOf:startingAt: indexOfAnyOf:startingAt:ifAbsent: lineCorrespondingToIndex: lineCount lineNumber: skipAnySubStr:startingAt: skipDelimiters:startingAt: startsWithDigit
"comparing" alike: beginsWith: caseSensitiveLessOrEqual: charactersExactlyMatching: compare: crc16 endsWith: endsWithAnyOf: sameAs: startingAt:match:startingAt:
"copying" copyReplaceTokens:with: padded:to:with:
"converting" asByteArray asDate asDisplayText asFileName asHtml asLegalSelector asPacked asParagraph asText asTime asUnHtml asUrl asUrlRelativeTo: capitalized compressWithTable: contractTo: correctAgainst: encodeForHTTP initialIntegerOrNil keywords quoted sansPeriodSuffix splitInteger stemAndNumericSuffix substrings surroundedBySingleQuotes truncateWithElipsisTo: withBlanksTrimmed withFirstCharacterDownshifted withNoLineLongerThan: withSeparatorsCompacted withoutLeadingDigits withoutTrailingBlanks
"displaying" "printing"
"system primitives" compare:with:collated:
"Celeste" withCRs
"internet" decodeMimeHeader decodeQuotedPrintable unescapePercents withInternetLineEndings withSqueakLineEndings withoutQuoting
"testing" isAllSeparators lastSpacePosition
"paragraph support" indentationIfBlank:
"arithmetic" ) do: [:sel | Approved add: sel].
#(byteAt:put: translateToLowercase match:) do: [:sel | AddAndRemove add: sel].
"Symbol"
#("in class, private" hasInterned:ifTrue:
"access" morePossibleSelectorsFor: possibleSelectorsFor: selectorsContaining: thatStarts:skipping:
"accessing" "comparing" "copying" "converting" "printing"
"testing" isInfix isKeyword isPvtSelector isUnary) do: [:sel | Approved add: sel].
"Array"
#("comparing" "converting" evalStrings
"printing" "private" hasLiteralSuchThat:) do: [:sel | Approved add: sel].
"Array2D"
#("access" at:at: atCol: atCol:put: atRow: extent extent:fromArray: height width width:height:type:) do: [:sel | Approved add: sel].
#(at:at:add: at:at:put: atRow:put: ) do: [:sel | AddAndRemove add: sel].
"ByteArray"
#("accessing" doubleWordAt: wordAt:
"platform independent access" longAt:bigEndian: shortAt:bigEndian: unsignedLongAt:bigEndian: unsignedShortAt:bigEndian:
"converting") do: [:sel | Approved add: sel].
#(doubleWordAt:put: wordAt:put: longAt:put:bigEndian: shortAt:put:bigEndian: unsignedLongAt:put:bigEndian: unsignedShortAt:put:bigEndian:
) do: [:sel | AddAndRemove add: sel].
"FloatArray" "Dont know what happens when prims not here"
false ifTrue: [#("accessing" "arithmetic" *= += -= /=
"comparing"
"primitives-plugin" primAddArray: primAddScalar: primDivArray: primDivScalar: primMulArray: primMulScalar: primSubArray: primSubScalar:
"primitives-translated" primAddArray:withArray:from:to: primMulArray:withArray:from:to: primSubArray:withArray:from:to:
"converting" "private" "user interface") do: [:sel | Approved add: sel].
].
"IntegerArray, WordArray"
"RunArray"
#("in class, instance creation" runs:values: scanFrom:
"accessing" runLengthAt:
"adding" "copying"
"private" runs values) do: [:sel | Approved add: sel].
#(coalesce addLast:times: repeatLast:ifEmpty: repeatLastIfEmpty:
) do: [:sel | AddAndRemove add: sel].
"Stream -- many operations change its state"
#("testing" atEnd) do: [:sel | Approved add: sel].
#("accessing" next: nextMatchAll: nextMatchFor: upToEnd
next:put: nextPut: nextPutAll: "printing" print: printHtml:
) do: [:sel | AddAndRemove add: sel].
"PositionableStream"
#("accessing" contentsOfEntireFile originalContents peek peekFor: "testing"
"positioning" position ) do: [:sel | Approved add: sel].
#(nextDelimited: nextLine upTo: position: reset resetContents setToEnd skip: skipTo: upToAll: ) do: [:sel | AddAndRemove add: sel].
"Because it is so difficult to test the result of an operation on a Stream (you have to supply another Stream in the same state), we don't support Streams beyond the basics. We want to find the messages that convert Streams to other things."
"ReadWriteStream"
#("file status" closed) do: [:sel | Approved add: sel].
#("accessing" next: on: ) do: [:sel | AddAndRemove add: sel].
"WriteStream"
#("in class, instance creation" on:from:to: with: with:from:to:
) do: [:sel | Approved add: sel].
#("positioning" resetToStart
"character writing" crtab crtab:) do: [:sel | AddAndRemove add: sel].
"LookupKey, Association, Link"
#("accessing" key nextLink) do: [:sel | Approved add: sel].
#(key: key:value: nextLink:) do: [:sel | AddAndRemove add: sel].
"Point"
#("in class, instance creation" r:degrees: x:y:
"accessing" x y "comparing" "arithmetic" "truncation and round off"
"polar coordinates" degrees r theta
"point functions" bearingToPoint: crossProduct: dist: dotProduct: eightNeighbors flipBy:centerAt: fourNeighbors grid: nearestPointAlongLineFrom:to: nearestPointOnLineFrom:to: normal normalized octantOf: onLineFrom:to: onLineFrom:to:within: quadrantOf: rotateBy:centerAt: transposed unitVector
"converting" asFloatPoint asIntegerPoint corner: extent: rect:
"transforming" adhereTo: rotateBy:about: scaleBy: scaleFrom:to: translateBy: "copying"
"interpolating" interpolateTo:at:) do: [:sel | Approved add: sel].
"Rectangle"
#("in class, instance creation" center:extent: encompassing: left:right:top:bottom:
merging: origin:corner: origin:extent:
"accessing" area bottom bottomCenter bottomLeft bottomRight boundingBox center corner corners innerCorners left leftCenter origin right rightCenter top topCenter topLeft topRight
"comparing"
"rectangle functions" adjustTo:along: amountToTranslateWithin: areasOutside: bordersOn:along: encompass: expandBy: extendBy: forPoint:closestSideDistLen: insetBy: insetOriginBy:cornerBy: intersect: merge: pointNearestTo: quickMerge: rectanglesAt:height: sideNearestTo: translatedToBeWithin: withBottom: withHeight: withLeft: withRight: withSide:setTo: withTop: withWidth:
"testing" containsPoint: containsRect: hasPositiveExtent intersects: isTall isWide
"truncation and round off"
"transforming" align:with: centeredBeneath: newRectFrom: squishedWithin: "copying"
) do: [:sel | Approved add: sel].
"Color"
#("in class, instance creation" colorFrom: colorFromPixelValue:depth: fromRgbTriplet: gray: h:s:v: r:g:b: r:g:b:alpha: r:g:b:range:
"named colors" black blue brown cyan darkGray gray green lightBlue lightBrown lightCyan lightGray lightGreen lightMagenta lightOrange lightRed lightYellow magenta orange red transparent veryDarkGray veryLightGray veryVeryDarkGray veryVeryLightGray white yellow
"other" colorNames indexedColors pixelScreenForDepth: quickHighLight:
"access" alpha blue brightness green hue luminance red saturation
"equality"
"queries" isBitmapFill isBlack isGray isSolidFill isTranslucent isTranslucentColor
"transformations" alpha: dansDarker darker lighter mixed:with: muchLighter slightlyDarker slightlyLighter veryMuchLighter alphaMixed:with:
"groups of shades" darkShades: lightShades: mix:shades: wheel:
"printing" shortPrintString
"other" colorForInsets rgbTriplet
"conversions" asB3DColor asColor balancedPatternForDepth: bitPatternForDepth: closestPixelValue1 closestPixelValue2 closestPixelValue4 closestPixelValue8 dominantColor halfTonePattern1 halfTonePattern2 indexInMap: pixelValueForDepth: pixelWordFor:filledWith: pixelWordForDepth: scaledPixelValue32
"private" privateAlpha privateBlue privateGreen privateRGB privateRed "copying"
) do: [:sel | Approved add: sel].
" For each selector that requires a block argument, add (selector argNum)
to the set Blocks."
"ourClasses _ #(Object Boolean True False UndefinedObject Behavior ClassDescription Class Metaclass MethodContext BlockContext Message Magnitude Date Time Number Integer SmallInteger LargeNegativeInteger LargePositiveInteger Float Fraction Random Collection SequenceableCollection ArrayedCollection Bag Set Dictionary IdentityDictionary IdentitySet LinkedList Interval MappedCollection OrderedCollection SortedCollection Character String Symbol Array Array2D ByteArray FloatArray IntegerArray WordArray RunArray Stream PositionableStream ReadWriteStream WriteStream LookupKey Association Link Point Rectangle Color).
ourClasses do: [:clsName | cls _ Smalltalk at: clsName.
(cls selectors) do: [:aSel |
((Approved includes: aSel) or: [AddAndRemove includes: aSel]) ifTrue: [
(cls formalParametersAt: aSel) withIndexDo: [:tName :ind |
(tName endsWith: 'Block') ifTrue: [
Blocks add: (Array with: aSel with: ind)]]]]].
"
#((timesRepeat: 1 ) (indexOf:ifAbsent: 2 ) (pairsCollect: 1 ) (mergeSortFrom:to:by: 3 ) (ifNotNil:ifNil: 1 ) (ifNotNil:ifNil: 2 ) (ifNil: 1 ) (at:ifAbsent: 2 ) (ifNil:ifNotNil: 1 ) (ifNil:ifNotNil: 2 ) (ifNotNil: 1 ) (at:modify: 2 ) (identityIndexOf:ifAbsent: 2 ) (sort: 1 ) (sortBlock: 1 ) (detectMax: 1 ) (repeatLastIfEmpty: 1 ) (allSubclassesWithLevelDo:startingLevel: 1 ) (keyAtValue:ifAbsent: 2 ) (in: 1 ) (ifTrue: 1 ) (or: 1 ) (select: 1 ) (inject:into: 2 ) (ifKindOf:thenDo: 2 ) (forPoint:closestSideDistLen: 2 ) (value:ifError: 2 ) (selectorsDo: 1 ) (removeAllSuchThat: 1 ) (keyAtIdentityValue:ifAbsent: 2 ) (detectMin: 1 ) (detect:ifNone: 1 ) (ifTrue:ifFalse: 1 ) (ifTrue:ifFalse: 2 ) (detect:ifNone: 2 ) (hasLiteralSuchThat: 1 ) (indexOfAnyOf:ifAbsent: 2 ) (reject: 1 ) (newRectFrom: 1 ) (removeKey:ifAbsent: 2 ) (at:ifPresent: 2 ) (associationAt:ifAbsent: 2 ) (withIndexCollect: 1 ) (repeatLast:ifEmpty: 2 ) (findLast: 1 ) (indexOf:startingAt:ifAbsent: 3 ) (remove:ifAbsent: 2 ) (ifFalse:ifTrue: 1 ) (ifFalse:ifTrue: 2 ) (caseOf:otherwise: 2 ) (count: 1 ) (collect: 1 ) (sortBy: 1 ) (and: 1 ) (asSortedCollection: 1 ) (with:collect: 2 ) (sourceCodeAt:ifAbsent: 2 ) (detect: 1 ) (scopeHas:ifTrue: 2 ) (collectWithIndex: 1 ) (compiledMethodAt:ifAbsent: 2 ) (bindWithTemp: 1 ) (detectSum: 1 ) (indexOfSubCollection:startingAt:ifAbsent: 3 ) (findFirst: 1 ) (sourceMethodAt:ifAbsent: 2 ) (collect:thenSelect: 1 ) (collect:thenSelect: 2 ) (select:thenCollect: 1 ) (select:thenCollect: 2 ) (ifFalse: 1 ) (indexOfAnyOf:startingAt:ifAbsent: 3 ) (indentationIfBlank: 1 ) ) do: [:anArray |
Blocks add: anArray].
self initialize3.
"
MethodFinder new initialize.
MethodFinder new organizationFiltered: TranslucentColor class
"
"Do not forget class messages for each of these classes"
!
----- Method: MethodFinder>>initialize3 (in category 'initialize') -----
initialize3
"additional selectors to consider"
#(asWords threeDigitName ) do: [:sel | Approved add: sel].!
----- Method: MethodFinder>>insertConstants (in category 'search') -----
insertConstants
"see if one of several known expressions will do it. C is the constant we discover here."
"C data1+C data1*C data1//C (data1*C1 + C2) (data1 = C) (data1 ~= C) (data1 <= C) (data1 >= C)
(data1 mod C)"
thisData size >= 2 ifFalse: [^ false]. "need 2 examples"
(thisData at: 1) size = 1 ifFalse: [^ false]. "only one arg, data1"
self const ifTrue: [^ true].
self constUsingData1Value ifTrue: [^ true].
"(data1 ?? const), where const is one of the values of data1"
" == ~~ ~= = <= >= "
self allNumbers ifFalse: [^ false].
self constMod ifTrue: [^ true].
self constPlus ifTrue: [^ true].
self constMult ifTrue: [^ true].
self constDiv ifTrue: [^ true].
self constLinear ifTrue: [^ true].
^ false!
----- Method: MethodFinder>>load: (in category 'initialize') -----
load: dataWithAnswers
"Find a function that takes the data and gives the answers. Odd list entries are data for it, even ones are the answers. nil input means data and answers were supplied already."
" (MethodFinder new) load: #( (4 3) 7 (-10 5) -5 (-3 11) 8);
findMessage "
dataWithAnswers ifNotNil: [
data _ Array new: dataWithAnswers size // 2.
1 to: data size do: [:ii | data at: ii put: (dataWithAnswers at: ii*2-1)].
answers _ Array new: data size.
1 to: answers size do: [:ii | answers at: ii put: (dataWithAnswers at: ii*2)]].
data do: [:list |
(list isKindOf: SequenceableCollection) ifFalse: [
^ self inform: 'first and third items are not Arrays'].
].
argMap _ (1 to: data first size) asArray.
data do: [:list | list size = argMap size ifFalse: [
self inform: 'data arrays must all be the same size']].
argMap size > 4 ifTrue: [self inform: 'No more than a receiver and
three arguments allowed'].
"Really only test receiver and three args."
thisData _ data copy.
mapStage _ mapList _ nil.
!
----- Method: MethodFinder>>makeAllMaps (in category 'arg maps') -----
makeAllMaps
"Make a giant list of all permutations of the args. To find the function, we will try these permutations of the input data. receiver, args."
| ii |
mapList _ Array new: argMap size factorial.
ii _ 1.
argMap permutationsDo: [:perm |
mapList at: ii put: perm copy.
ii _ ii + 1].
mapStage _ 1. "about to be bumped"!
----- Method: MethodFinder>>mapData (in category 'arg maps') -----
mapData
"Force the data through the map (permutation) to create the data to test."
thisData _ data collect: [:realData |
argMap collect: [:ind | realData at: ind]].
!
----- Method: MethodFinder>>noteDangerous (in category 'initialize') -----
noteDangerous
"Remember the methods with really bad side effects."
Dangerous _ Set new.
"Object accessing, testing, copying, dependent access, macpal, flagging"
#(addInstanceVarNamed:withValue: haltIfNil copyAddedStateFrom: veryDeepCopy veryDeepCopyWith: veryDeepFixupWith: veryDeepInner: addDependent: evaluate:wheneverChangeIn: codeStrippedOut: playSoundNamed: isThisEverCalled isThisEverCalled: logEntry logExecution logExit)
do: [:sel | Dangerous add: sel].
"Object error handling"
#(cannotInterpret: caseError confirm: confirm:orCancel: doesNotUnderstand: error: halt halt: notify: notify:at: primitiveFailed shouldNotImplement subclassResponsibility tryToDefineVariableAccess:)
do: [:sel | Dangerous add: sel].
"Object user interface"
#(basicInspect beep inform: inspect inspectWithLabel: notYetImplemented inspectElement )
do: [:sel | Dangerous add: sel].
"Object system primitives"
#(become: becomeForward: instVarAt:put: instVarNamed:put: nextInstance nextObject rootStubInImageSegment: someObject tryPrimitive:withArgs:)
do: [:sel | Dangerous add: sel].
"Object private"
#(errorImproperStore errorNonIntegerIndex errorNotIndexable errorSubscriptBounds: mustBeBoolean primitiveError: species storeAt:inTempFrame:)
do: [:sel | Dangerous add: sel].
"Object, translation support"
#(cCode: cCode:inSmalltalk: cCoerce:to: export: inline: returnTypeC: sharedCodeNamed:inCase: var:declareC:)
do: [:sel | Dangerous add: sel].
"Object, objects from disk, finalization. And UndefinedObject"
#(comeFullyUpOnReload: objectForDataStream: readDataFrom:size: rehash saveOnFile storeDataOn: actAsExecutor executor finalize retryWithGC:until: suspend)
do: [:sel | Dangerous add: sel].
"No Restrictions: Boolean, False, True, "
"Morph"
#()
do: [:sel | Dangerous add: sel].
"Behavior"
#(obsolete confirmRemovalOf: copyOfMethodDictionary literalScannedAs:notifying: storeLiteral:on: addSubclass: removeSubclass: superclass:
"creating method dictionary" addSelector:withMethod: compile: compile:notifying: compileAll compileAllFrom: compress decompile: defaultSelectorForMethod: methodDictionary: recompile:from: recompileChanges removeSelector: compressedSourceCodeAt: selectorAtMethod:setClass: allInstances allSubInstances inspectAllInstances inspectSubInstances thoroughWhichSelectorsReferTo:special:byte: "enumerating" allInstancesDo: allSubInstancesDo: allSubclassesDo: allSuperclassesDo: selectSubclasses: selectSuperclasses: subclassesDo: withAllSubclassesDo:
"too slow->" crossReference removeUninstantiatedSubclassesSilently "too slow->" unreferencedInstanceVariables
"private" becomeCompact becomeUncompact flushCache format:variable:words:pointers: format:variable:words:pointers:weak: printSubclassesOn:level: basicRemoveSelector: addSelector:withMethod:notifying: addSelectorSilently:withMethod:)
do: [:sel | Dangerous add: sel].
"CompiledMethod"
#(defaultSelector)
do: [:sel | Dangerous add: sel].
"Others "
#("no tangible result" do: associationsDo:
"private" adaptToCollection:andSend: adaptToNumber:andSend: adaptToPoint:andSend: adaptToString:andSend: instVarAt:put: asDigitsToPower:do: combinations:atATimeDo: doWithIndex: pairsDo: permutationsDo: reverseDo: reverseWith:do: with:do: withIndexDo: asDigitsAt:in:do: combinationsAt:in:after:do: errorOutOfBounds permutationsStartingAt:do: fromUser)
do: [:sel | Dangerous add: sel].
#( fileOutPrototype addSpareFields makeFileOutFile )
do: [:sel | Dangerous add: sel].
#(recompile:from: recompileAllFrom: recompileChanges asPrototypeWithFields: asPrototype addInstanceVarNamed:withValue: addInstanceVariable addClassVarName: removeClassVarName: findOrAddClassVarName: tryToDefineVariableAccess: instanceVariableNames: )
do: [:sel | Dangerous add: sel].
!
----- Method: MethodFinder>>organizationFiltered: (in category 'initialize') -----
organizationFiltered: aClass
"Return the organization of the class with all selectors defined in superclasses removed. (except those in Object)"
| org str |
org _ aClass organization deepCopy.
Dangerous do: [:sel |
org removeElement: sel].
Approved do: [:sel |
org removeElement: sel].
AddAndRemove do: [:sel |
org removeElement: sel].
str _ org printString copyWithout: $(.
str _ '(', (str copyWithout: $) ).
str _ str replaceAll: $' with: $".
^ str
!
----- Method: MethodFinder>>permuteArgs (in category 'arg maps') -----
permuteArgs
"Run through ALL the permutations. First one was as presented."
data first size <= 1 ifTrue: [^ false]. "no other way"
mapList ifNil: [self makeAllMaps].
mapStage _ mapStage + 1.
mapStage > mapList size ifTrue: [^ false].
argMap _ mapList at: mapStage.
self mapData.
^ true
!
----- Method: MethodFinder>>search: (in category 'search') -----
search: multi
"if Multi is true, collect all selectors that work."
| old |
selector _ OrderedCollection new. "list of them"
old _ Preferences autoAccessors.
Preferences disableGently: #autoAccessors.
self simpleSearch.
multi not & (selector isEmpty not) ifTrue:
[old ifTrue: [Preferences enableGently: #autoAccessors].
^ selector].
[self permuteArgs] whileTrue:
[self simpleSearch.
multi not & (selector isEmpty not) ifTrue:
[old ifTrue: [Preferences enableGently: #autoAccessors].
^ selector]].
self insertConstants.
old ifTrue: [Preferences enableGently: #autoAccessors].
"(selector isEmpty not) ifTrue: [^ selector]]. expression is the answer, not a selector"
^ #()!
----- Method: MethodFinder>>searchForOne (in category 'search') -----
searchForOne
"Look for and return just one answer"
expressions _ OrderedCollection new.
self search: false. "non-multi"
^ expressions
!
----- Method: MethodFinder>>selectors (in category 'access') -----
selectors
"Note the inst var does not have an S on the end"
^ selector!
----- Method: MethodFinder>>simpleSearch (in category 'search') -----
simpleSearch
"Run through first arg's class' selectors, looking for one that works."
| class supers listOfLists |
self exceptions.
class _ thisData first first class.
"Cache the selectors for the receiver class"
(class == cachedClass and: [cachedArgNum = ((argMap size) - 1)])
ifTrue: [listOfLists _ cachedSelectorLists]
ifFalse: [supers _ class withAllSuperclasses.
listOfLists _ OrderedCollection new.
supers do: [:cls |
listOfLists add: (cls selectorsWithArgs: (argMap size) - 1)].
cachedClass _ class.
cachedArgNum _ (argMap size) - 1.
cachedSelectorLists _ listOfLists].
listOfLists do: [:selectorList |
selectorList do: [:aSel |
(selector includes: aSel) ifFalse: [
((Approved includes: aSel) or: [AddAndRemove includes: aSel]) ifTrue: [
(self testPerfect: aSel) ifTrue: [
selector add: aSel.
expressions add: (String streamContents: [:strm |
strm nextPutAll: 'data', argMap first printString.
aSel keywords doWithIndex: [:key :ind |
strm nextPutAll: ' ',key.
(key last == $:) | (key first isLetter not)
ifTrue: [strm nextPutAll: ' data',
(argMap at: ind+1) printString]]])
]]]]].
!
----- Method: MethodFinder>>test2: (in category 'initialize') -----
test2: anArray
"look for bad association"
anArray do: [:sub |
sub class == Association ifTrue: [
(#('true' '$a' '2' 'false') includes: sub value printString) ifFalse: [
self error: 'bad assn'].
(#('3' '5.6' 'x' '''abcd''') includes: sub key printString) ifFalse: [
self error: 'bad assn'].
].
sub class == Array ifTrue: [
sub do: [:element |
element isString ifTrue: [element first asciiValue < 32 ifTrue: [
self error: 'store into string in data']].
element class == Association ifTrue: [
element value class == Association ifTrue: [
self error: 'bad assn']]]].
sub class == Date ifTrue: [sub year isInteger ifFalse: [
self error: 'stored into input date!!!!']].
sub class == Dictionary ifTrue: [
sub size > 0 ifTrue: [
self error: 'store into dictionary']].
sub class == OrderedCollection ifTrue: [
sub size > 4 ifTrue: [
self error: 'store into OC']].
].!
----- Method: MethodFinder>>test3 (in category 'initialize') -----
test3
"find the modification of the caracter table"
(#x at: 1) asciiValue = 120 ifFalse: [self error: 'Character table mod'].!
----- Method: MethodFinder>>testFromTuple: (in category 'initialize') -----
testFromTuple: nth
"verify that the methods allowed don't crash the system. Try N of each of the fundamental types. up to 4 of each kind."
| objects nonRepeating even other aa cnt |
objects _ #((1 4 17 42) ($a $b $c $d) ('one' 'two' 'three' 'four')
(x + rect: new) ((a b 1 4) (c 1 5) ($a 3 d) ()) (4.5 0.0 3.2 100.3)
).
objects _ objects, {{true. false. true. false}. {Point. SmallInteger. Association. Array}.
{Point class. SmallInteger class. Association class. Array class}.
"{ 4 blocks }."
{Date today. '1 Jan 1950' asDate. '25 Aug 1987' asDate. '1 Jan 2000' asDate}.
{'15:16' asTime. '1:56' asTime. '4:01' asTime. '6:23' asTime}.
{Dictionary new. Dictionary new. Dictionary new. Dictionary new}.
{#(a b 1 4) asOrderedCollection. #(c 1 5) asOrderedCollection.
#($a 3 d) asOrderedCollection. #() asOrderedCollection}.
{3->true. 5.6->$a. #x->2. 'abcd'->false}.
{9 at 3 extent: 5 at 4. 0 at 0 extent: 45 at 9. -3 at -7 extent: 2 at 2. 4 at 4 extent: 16 at 16}.
{Color red. Color blue. Color black. Color gray}}.
self test2: objects.
"rec+0, rec+1, rec+2, rec+3 need to be tested. "
cnt _ 0.
nth to: 4 do: [:take |
nonRepeating _ OrderedCollection new.
objects do: [:each |
nonRepeating addAll: (each copyFrom: 1 to: take)].
"all combinations of take, from nonRepeating"
even _ true.
nonRepeating combinations: take atATimeDo: [:tuple |
even ifTrue: [other _ tuple clone]
ifFalse: [self load: (aa _ Array with: tuple with: 1 with: other with: 7).
(cnt _ cnt+1) \\ 50 = 0 ifTrue: [
Transcript cr; show: aa first printString].
self search: true.
self test2: aa.
self test2: nonRepeating.
"self test2: objects"].
even _ even not].
].!
----- Method: MethodFinder>>testPerfect: (in category 'search') -----
testPerfect: aSelector
"Try this selector!! Return true if it answers every example perfectly. Take the args in the order they are. Do not permute them. Survive errors. later cache arg lists."
| sz argList val rec activeSel perform |
"Transcript cr; show: aSelector. debug"
perform _ aSelector beginsWith: 'perform:'.
sz _ argMap size.
1 to: thisData size do: [:ii | "each example set of args"
argList _ (thisData at: ii) copyFrom: 2 to: sz.
perform
ifFalse: [activeSel _ aSelector]
ifTrue: [activeSel _ argList first. "what will be performed"
((Approved includes: activeSel) or: [AddAndRemove includes: activeSel])
ifFalse: [^ false]. "not approved"
aSelector == #perform:withArguments:
ifTrue: [activeSel numArgs = (argList at: 2) basicSize "avoid error"
ifFalse: [^ false]]
ifFalse: [activeSel numArgs = (aSelector numArgs - 1)
ifFalse: [^ false]]].
1 to: sz do: [:num |
(Blocks includes: (Array with: activeSel with: num)) ifTrue: [
(argList at: num) class == BlockContext ifFalse: [^ false]]].
rec _ (AddAndRemove includes: activeSel)
ifTrue: [(thisData at: ii) first isSymbol ifTrue: [^ false].
"vulnerable to modification"
(thisData at: ii) first copyTwoLevel] "protect from damage"
ifFalse: [(thisData at: ii) first].
val _ [rec perform: aSelector withArguments: argList]
ifError: [:aString :aReceiver |
"self test3."
"self test2: (thisData at: ii)."
^ false].
"self test3."
"self test2: (thisData at: ii)."
((answers at: ii) closeTo: val) ifFalse: [^ false].
].
^ true!
----- Method: MethodFinder>>testRandom (in category 'initialize') -----
testRandom
"verify that the methods allowed don't crash the system. Pick 3 or 4 from a mixed list of the fundamental types."
| objects other aa cnt take tuple fName sss |
objects _ #((1 4 17 42) ($a $b $c $d) ('one' 'two' 'three' 'four')
(x + rect: new) ((a b 1 4) (c 1 5) ($a 3 d) ()) (4.5 0.0 3.2 100.3)
).
objects _ objects, {{true. false. true. false}. {Point. SmallInteger. Association. Array}.
{Point class. SmallInteger class. Association class. Array class}.
"{ 4 blocks }."
{Date today. '1 Jan 1950' asDate. '25 Aug 1987' asDate. '1 Jan 2000' asDate}.
{'15:16' asTime. '1:56' asTime. '4:01' asTime. '6:23' asTime}.
{Dictionary new. Dictionary new. Dictionary new. Dictionary new}.
{#(a b 1 4) asOrderedCollection. #(c 1 5) asOrderedCollection.
#($a 3 d) asOrderedCollection. #() asOrderedCollection}.
{3->true. 5.6->$a. #x->2. 'abcd'->false}.
{9 at 3 extent: 5 at 4. 0 at 0 extent: 45 at 9. -3 at -7 extent: 2 at 2. 4 at 4 extent: 16 at 16}.
{Color red. Color blue. Color black. Color gray}}.
self test2: objects.
"rec+0, rec+1, rec+2, rec+3 need to be tested. "
fName _ (FileDirectory default fileNamesMatching: '*.ran') first.
sss _ fName splitInteger first.
(Collection classPool at: #RandomForPicking) seed: sss.
cnt _ 0.
[take _ #(3 4) atRandom.
tuple _ (1 to: take) collect: [:ind | (objects atRandom) atRandom].
other _ (1 to: take) collect: [:ind | (objects atRandom) atRandom].
self load: (aa _ Array with: tuple with: 1 with: other with: 7).
((cnt _ cnt+1) \\ 10 = 0) " | (cnt > Skip)" ifTrue: [
Transcript cr; show: cnt printString; tab; tab; show: aa first printString].
cnt > (Smalltalk at: #StopHere) ifTrue: [self halt]. "stop just before crash"
cnt > (Smalltalk at: #Skip) ifTrue: ["skip this many at start"
self search: true.
self test2: aa first. self test2: (aa at: 3).
"self test2: objects"
].
true] whileTrue.
!
----- Method: MethodFinder>>thisData (in category 'arg maps') -----
thisData
^ thisData !
----- Method: MethodFinder>>verify (in category 'initialize') -----
verify
"Test a bunch of examples"
" MethodFinder new verify "
Approved ifNil: [self initialize]. "Sets of allowed selectors"
(MethodFinder new load: #( (0) 0 (30) 0.5 (45) 0.707106 (90) 1)
) searchForOne asArray = #('data1 degreeSin') ifFalse: [self error: 'should have found it'].
(MethodFinder new load: { { true. [3]. [4]}. 3. { false. [0]. [6]}. 6}
) searchForOne asArray = #('data1 ifTrue: data2 ifFalse: data3') ifFalse: [
self error: 'should have found it'].
(MethodFinder new load: {#(1). true. #(2). false. #(5). true. #(10). false}
) searchForOne asArray = #('data1 odd') ifFalse: [self error: 'should have found it'].
"will correct the date type of #true, and complain"
(MethodFinder new load: #((4 2) '2r100' (255 16) '16rFF' (14 8) '8r16')
) searchForOne asArray =
#('data1 radix: data2' 'data1 printStringBase: data2' 'data1 storeStringBase: data2')
ifFalse: [self error: 'should have found it'].
(MethodFinder new load: {{Point x: 3 y: 4}. 4. {Point x: 1 y: 5}. 5}
) searchForOne asArray = #('data1 y') ifFalse: [self error: 'should have found it'].
(MethodFinder new load: #(('abcd') $a ('TedK') $T)
) searchForOne asArray = #('data1 asCharacter' 'data1 first' 'data1 anyOne')
ifFalse: [self error: 'should have found it'].
(MethodFinder new load: #(('abcd' 1) $a ('Ted ' 3) $d )
) searchForOne asArray = #('data1 at: data2' 'data1 atPin: data2' 'data1 atWrap: data2')
ifFalse: [self error: 'should have found it'].
(MethodFinder new load: #(((12 4 8)) 24 ((1 3 6)) 10 )
) searchForOne asArray= #('data1 sum') ifFalse: [self error: 'should have found it'].
"note extra () needed for an Array object as an argument"
(MethodFinder new load: #((14 3) 11 (-10 5) -15 (4 -3) 7)
) searchForOne asArray = #('data1 - data2') ifFalse: [self error: 'should have found it'].
(MethodFinder new load: #((4) 4 (-10) 10 (-3) 3 (2) 2 (-6) 6 (612) 612)
) searchForOne asArray = #('data1 abs') ifFalse: [self error: 'should have found it'].
(MethodFinder new load: {#(4 3). true. #(-7 3). false. #(5 1). true. #(5 5). false}
) searchForOne asArray = #('data1 > data2') ifFalse: [self error: 'should have found it'].
(MethodFinder new load: #((5) 0.2 (2) 0.5)
) searchForOne asArray = #('data1 reciprocal') ifFalse: [self error: 'should have found it'].
(MethodFinder new load: #((12 4 8) 2 (1 3 6) 2 (5 2 16) 8)
) searchForOne asArray = #() " '(data3 / data2) ' want to be able to leave out args"
ifFalse: [self error: 'should have found it'].
(MethodFinder new load: #((0.0) 0.0 (1.5) 0.997495 (0.75) 0.681639)
) searchForOne asArray = #('data1 sin') ifFalse: [self error: 'should have found it'].
(MethodFinder new load: #((7 5) 2 (4 5) 4 (-9 4) 3)
) searchForOne asArray = #('data1 \\ data2') ifFalse: [self error: 'should have found it'].
(MethodFinder new load: #((7) 2 (4) 2 )
) searchForOne asArray = #('^ 2') ifFalse: [self error: 'should have found it'].
(MethodFinder new load: {#(7). true. #(4.1). true. #(1.5). false}
) searchForOne asArray = #('data1 >= 4.1') ifFalse: [self error: 'should have found it'].
(MethodFinder new load: #((35) 3 (17) 1 (5) 5)
) searchForOne asArray = #('data1 \\ 8') ifFalse: [self error: 'should have found it'].
(MethodFinder new load: #((36) 7 (50) 10 )
) searchForOne asArray = #('data1 quo: 5' 'data1 // 5') ifFalse: [
self error: 'should have found it'].
(MethodFinder new load: #( ((2 3) 2) 8 ((2 3) 5) 17 )
) searchForOne asArray = #('data1 polynomialEval: data2') ifFalse: [
self error: 'should have found it'].
(MethodFinder new load: #((2) 8 (5) 17 )
) searchForOne asArray = #('#(2 3) polynomialEval: data1') ifFalse: [
self error: 'should have found it'].
!
Object subclass: #Model
instanceVariableNames: 'dependents'
classVariableNames: ''
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!
----- Method: Model>>arrowKey:from: (in category 'keyboard') -----
arrowKey: aChar from: view
"backstop; all the PluggableList* classes actually handle arrow keys, and the models handle other keys."
^false!
----- 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
!
----- 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 isKindOf: SystemWindow orOf: StandardSystemView) or: [d isKindOf: MVCWiWPasteUpMorph]) and: [d model == self]] ifNone: [nil]!
----- 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
!
----- Method: Model>>myDependents (in category 'dependents') -----
myDependents
^ dependents!
----- Method: Model>>myDependents: (in category 'dependents') -----
myDependents: aCollectionOrNil
dependents _ aCollectionOrNil!
----- Method: Model>>perform:orSendTo: (in category 'menus') -----
perform: selector orSendTo: otherTarget
"Selector was just chosen from a menu by a user. If can respond, then perform it on myself. If not, send it to otherTarget, presumably the editPane from which the menu was invoked."
"default is that the editor does all"
^ otherTarget perform: selector.!
----- Method: Model>>selectedClass (in category 'menus') -----
selectedClass
"All owners of TextViews are asked this during a doIt"
^ nil!
----- Method: Model>>step (in category 'menus') -----
step
"Default for morphic models is no-op"!
----- 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].
Smalltalk isMorphic
ifTrue:
[dependents
do: [:v | ((v isSystemWindow) and: [v isInWorld]) ifTrue: [^v]].
^nil].
dependents do: [:v | v superView ifNil: [v model == self ifTrue: [^v]]].
^nil!
----- Method: Model>>trash (in category 'menus') -----
trash
"What should be displayed if a trash pane is restored to initial state"
^ ''!
----- Method: Model>>trash: (in category 'menus') -----
trash: ignored
"Whatever the user submits to the trash, it need not be saved."
^ true!
----- 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 newDependent |
super veryDeepFixupWith: deepCopier.
originalDependents _ dependents.
originalDependents ifNil: [
^self.
].
dependents _ nil.
refs _ deepCopier references.
originalDependents
do: [:originalDependent |
newDependent _ refs
at: originalDependent
ifAbsent: [].
newDependent
ifNotNil: [self addDependent: newDependent]]!
Model subclass: #StringHolder
instanceVariableNames: 'contents'
classVariableNames: ''
poolDictionaries: ''
category: 'Kernel-Models'!
!StringHolder commentStamp: '<historical>' prior: 0!
I am a kind of Model that includes a piece of text. In some cases, the text can be edited, and in some the text is a method.
Categories 'code pane menu' and 'message list menu' are messages that may be called by my menus when the text is a method, and when some pane is a list of methods. Other of my subclasses may ignore these two catagories altogether.!
----- Method: StringHolder class>>initialize (in category 'class initialization') -----
initialize
"The class variables were initialized once, and subsequently filled with
information. Re-executing this method is therefore dangerous."
"workSpace _ StringHolder new"
"StringHolder initialize"!
----- Method: StringHolder class>>open (in category 'instance creation') -----
open
(Smalltalk at: #Workspace) new openLabel: 'Workspace'
"Not to be confused with our own class var 'Workspace'"!
----- Method: StringHolder class>>openLabel: (in category 'instance creation') -----
openLabel: aString
self new openLabel: aString!
----- Method: StringHolder class>>windowColorSpecification (in category 'window color') -----
windowColorSpecification
"Answer a WindowColorSpec object that declares my preference"
^ WindowColorSpec classSymbol: self name wording: 'Workspace' translatedNoop brightColor: #lightYellow pastelColor: #paleYellow helpMessage: 'A place for text in a window.' translatedNoop!
----- Method: StringHolder>>acceptContents: (in category 'accessing') -----
acceptContents: aString
"Set aString to be the contents of the receiver. Return true cuz happy"
self contents: aString.
^ true!
----- Method: StringHolder>>buildMessageBrowser (in category 'message list menu') -----
buildMessageBrowser
"Create and schedule a message browser."
self selectedMessageName ifNil: [^ self].
Browser openMessageBrowserForClass: self selectedClassOrMetaClass
selector: self selectedMessageName editString: nil!
----- Method: StringHolder>>classCommentIndicated (in category 'accessing') -----
classCommentIndicated
"Answer true iff we're viewing the class comment."
^false!
----- Method: StringHolder>>clearUserEditFlag (in category 'user edits') -----
clearUserEditFlag
"Clear the hasUnacceptedEdits flag in all my dependent views."
self changed: #clearUserEdits!
----- Method: StringHolder>>codePaneMenu:shifted: (in category 'code pane menu') -----
codePaneMenu: aMenu shifted: shifted
"Note that unless we override perform:orSendTo:, PluggableTextController will respond to all menu items in a text pane"
| donorMenu |
donorMenu _ shifted
ifTrue:
[ParagraphEditor shiftedYellowButtonMenu]
ifFalse:
[ParagraphEditor yellowButtonMenu].
^ aMenu labels: donorMenu labelString lines: donorMenu lineArray selections: donorMenu selections!
----- Method: StringHolder>>contents (in category 'accessing') -----
contents
"Answer the contents that the receiver is holding--presumably a string."
^contents!
----- Method: StringHolder>>contents: (in category 'accessing') -----
contents: textOrString
"Set textOrString to be the contents of the receiver."
contents _ textOrString "asString"!
----- Method: StringHolder>>contentsSelection (in category 'accessing') -----
contentsSelection
"Return the interval of text in the code pane to select when I set the pane's contents"
^ 1 to: 0 "null selection"!
----- Method: StringHolder>>defaultContents (in category 'initialize-release') -----
defaultContents
^''!
----- Method: StringHolder>>doItContext (in category 'evaluation') -----
doItContext
"Answer the context in which a text selection can be evaluated."
^nil!
----- Method: StringHolder>>doItReceiver (in category 'evaluation') -----
doItReceiver
"Answer the object that should be informed of the result of evaluating a
text selection."
^nil!
----- Method: StringHolder>>embeddedInMorphicWindowLabeled: (in category 'initialize-release') -----
embeddedInMorphicWindowLabeled: labelString
| window |
window _ (SystemWindow labelled: labelString) model: self.
window addMorph: (PluggableTextMorph on: self text: #contents accept: #acceptContents:
readSelection: nil menu: #codePaneMenu:shifted:)
frame: (0 at 0 corner: 1 at 1).
^ window!
----- Method: StringHolder>>fetchDocPane (in category 'message list menu') -----
fetchDocPane
"Look on servers to see if there is documentation pane for the selected message. Take into account the current update number. If not, ask the user if she wants to create one."
DocLibrary external fetchDocSel: self selectedMessageName
class: self selectedClassName!
----- Method: StringHolder>>initialize (in category 'initialize-release') -----
initialize
"Initialize the state of the receiver with its default contents."
contents _ self defaultContents.
!
----- Method: StringHolder>>makeIsolatedCodePane (in category 'message list menu') -----
makeIsolatedCodePane
| msgName |
(msgName _ self selectedMessageName) ifNil: [^ Beeper beep].
MethodHolder makeIsolatedCodePaneForClass: self selectedClassOrMetaClass selector: msgName!
----- Method: StringHolder>>noteAcceptanceOfCodeFor: (in category 'accessing') -----
noteAcceptanceOfCodeFor: aSelector
"A method has possibly been submitted for the receiver with aSelector as its selector; If the receiver wishes to take soem action here is a chance for it to do so"
!
----- Method: StringHolder>>okToChange (in category 'user edits') -----
okToChange
self canDiscardEdits ifTrue: [^ true].
self changed: #wantToChange. "Solicit cancel from view"
^ self canDiscardEdits
!
----- Method: StringHolder>>openAsMorphLabel: (in category 'initialize-release') -----
openAsMorphLabel: labelString
"Workspace new openAsMorphLabel: 'Workspace'"
(self embeddedInMorphicWindowLabeled: labelString) openInWorld!
----- Method: StringHolder>>openAsMorphLabel:inWorld: (in category 'initialize-release') -----
openAsMorphLabel: labelString inWorld: aWorld
"Workspace new openAsMorphLabel: 'Workspace'"
| window |
window _ (SystemWindow labelled: labelString) model: self.
window addMorph: (PluggableTextMorph on: self text: #contents accept: #acceptContents:
readSelection: nil menu: #codePaneMenu:shifted:)
frame: (0 at 0 corner: 1 at 1).
window openInWorld: aWorld!
----- Method: StringHolder>>openLabel: (in category 'initialize-release') -----
openLabel: aString
"Create a standard system view of the model, me, a StringHolder and open it. If in mvc, terminate the active controller so that the new window will immediately be activated."
self openLabel: aString andTerminate: true!
----- Method: StringHolder>>openLabel:andTerminate: (in category 'initialize-release') -----
openLabel: aString andTerminate: terminateBoolean
"Create a standard system view of the model, me, a StringHolder and open it.; do not terminate the active process if in mvc"
| topView codeView |
Smalltalk isMorphic ifTrue: [^ self openAsMorphLabel: aString].
topView _ (StandardSystemView new) model: self.
topView borderWidth: 1.
topView label: aString.
topView minimumSize: 100 @ 50.
codeView _ PluggableTextView on: self
text: #contents accept: #acceptContents:
readSelection: #contentsSelection menu: #codePaneMenu:shifted:.
codeView window: (0 at 0 extent: 200 at 200).
topView addSubView: codeView.
"self contents size > 0 ifTrue: [
codeView hasUnacceptedEdits: true]. Is it already saved or not??"
terminateBoolean
ifTrue:
[topView controller open]
ifFalse:
[topView controller openNoTerminate]!
----- Method: StringHolder>>perform:orSendTo: (in category 'code pane menu') -----
perform: selector orSendTo: otherTarget
"Selector was just chosen from a menu by a user. If can respond, then
perform it on myself. If not, send it to otherTarget, presumably the
editPane from which the menu was invoked."
(self respondsTo: selector)
ifTrue: [^ self perform: selector]
ifFalse: [^ otherTarget perform: selector]!
----- Method: StringHolder>>reformulateList (in category 'accessing') -----
reformulateList
"If the receiver has a way of reformulating its message list, here is a chance for it to do so"!
----- Method: StringHolder>>reformulateListNoting: (in category 'accessing') -----
reformulateListNoting: newSelector
"A method has possibly been submitted for the receiver with newSelector as its selector; If the receiver has a way of reformulating its message list, here is a chance for it to do so"
^ self reformulateList!
----- Method: StringHolder>>selectedClassName (in category 'accessing') -----
selectedClassName
"I may know what class is currently selected"
self selectedClass ifNotNil: [^ self selectedClass name].
^ nil!
----- Method: StringHolder>>selectedClassOrMetaClass (in category 'accessing') -----
selectedClassOrMetaClass
^ self selectedClass "I don't know any better"!
----- Method: StringHolder>>selectedMessageName (in category 'accessing') -----
selectedMessageName
^ nil!
----- Method: StringHolder>>showBytecodes (in category 'code pane menu') -----
showBytecodes
"We don't know how to do this"
^ self changed: #flash!
----- Method: StringHolder>>spawn: (in category 'code pane menu') -----
spawn: contentsString
(Workspace new contents: contentsString) openLabel: 'Workspace'
!
----- Method: StringHolder>>textContents: (in category 'accessing') -----
textContents: aStringOrText
"Set aStringOrText to be the contents of the receiver."
contents _ aStringOrText!
----- Method: StringHolder>>wantsAnnotationPane (in category 'optional panes') -----
wantsAnnotationPane
"Answer whether the receiver, seen in some browser window, would like to have the so-called annotationpane included. By default, various browsers defer to the global preference 'optionalButtons' -- but individual subclasses can insist to the contrary."
^ Preferences annotationPanes!
----- Method: StringHolder>>wantsOptionalButtons (in category 'optional panes') -----
wantsOptionalButtons
"Answer whether the receiver, seen in some browser window, would like to have the so-called optional button pane included. By default, various browsers defer to the global preference 'optionalButtons' -- but individual subclasses can insist to the contrary."
^ Preferences optionalButtons!
Model subclass: #ValueHolder
instanceVariableNames: 'contents'
classVariableNames: ''
poolDictionaries: ''
category: 'Kernel-Models'!
----- Method: ValueHolder>>contents (in category 'accessing') -----
contents
^contents!
----- Method: ValueHolder>>contents: (in category 'accessing') -----
contents: newContents
contents _ newContents.
self contentsChanged!
Object subclass: #Monitor
instanceVariableNames: 'mutex ownerProcess nestingLevel defaultQueue queueDict queuesMutex'
classVariableNames: ''
poolDictionaries: ''
category: 'Kernel-Processes'!
!Monitor commentStamp: 'fbs 3/24/2004 14:41' 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.
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.
Usage examples
See code in class MBoundedCounter and compare it to the clumsy BoundedCounter that is written wihout a monitor.!
----- Method: Monitor>>checkOwnerProcess (in category 'private') -----
checkOwnerProcess
self isOwnerProcess
ifFalse: [self error: 'Monitor access violation'].!
----- Method: Monitor>>cleanup (in category 'accessing') -----
cleanup
self checkOwnerProcess.
self critical: [self privateCleanup].!
----- Method: Monitor>>critical: (in category 'synchronization') -----
critical: aBlock
"Critical section.
Executes aBlock as a critical section. At any time, only one process can be executing code
in a critical section.
NOTE: All the following synchronization operations are only valid inside the critical section
of the monitor!!"
| result |
[self enter.
result _ aBlock value] ensure: [self exit].
^ result.!
----- Method: Monitor>>defaultQueue (in category 'private') -----
defaultQueue
defaultQueue ifNil: [defaultQueue _ OrderedCollection new].
^ defaultQueue!
----- Method: Monitor>>enter (in category 'private') -----
enter
self isOwnerProcess ifTrue: [
nestingLevel _ nestingLevel + 1.
] ifFalse: [
mutex wait.
ownerProcess _ Processor activeProcess.
nestingLevel _ 1.
].!
----- Method: Monitor>>exit (in category 'private') -----
exit
nestingLevel _ nestingLevel - 1.
nestingLevel < 1 ifTrue: [
ownerProcess _ nil.
mutex signal
].!
----- Method: Monitor>>exitAndWaitInQueue:maxMilliseconds: (in category 'private') -----
exitAndWaitInQueue: anOrderedCollection maxMilliseconds: anIntegerOrNil
| lock delay |
queuesMutex
critical: [lock _ anOrderedCollection addLast: Semaphore new].
self exit.
anIntegerOrNil isNil ifTrue: [
lock wait
] ifFalse: [
delay _ MonitorDelay signalLock: lock afterMSecs: anIntegerOrNil inMonitor: self queue: anOrderedCollection.
lock wait.
delay unschedule.
].
self enter.!
----- Method: Monitor>>initialize (in category 'initialize-release') -----
initialize
mutex _ Semaphore forMutualExclusion.
queuesMutex _ Semaphore forMutualExclusion.
nestingLevel _ 0.!
----- Method: Monitor>>isOwnerProcess (in category 'private') -----
isOwnerProcess
^ Processor activeProcess == ownerProcess!
----- 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].
].
].!
----- Method: Monitor>>queueDict (in category 'private') -----
queueDict
queueDict ifNil: [queueDict _ IdentityDictionary new].
^ queueDict.!
----- Method: Monitor>>queueFor: (in category 'private') -----
queueFor: aSymbol
aSymbol ifNil: [^ self defaultQueue].
^ self queueDict at: aSymbol ifAbsentPut: [OrderedCollection new].!
----- Method: Monitor>>signal (in category 'signaling-default') -----
signal
"One process waiting for the default event is woken up."
^ self signal: nil!
----- 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.!
----- Method: Monitor>>signalAll (in category 'signaling-default') -----
signalAll
"All processes waiting for the default event are woken up."
^ self signalAll: nil!
----- 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].!
----- Method: Monitor>>signalAllInQueue: (in category 'private') -----
signalAllInQueue: anOrderedCollection
queuesMutex critical: [
anOrderedCollection do: [:lock | lock signal].
anOrderedCollection removeAllSuchThat: [:each | true].
].!
----- Method: Monitor>>signalLock:inQueue: (in category 'private') -----
signalLock: aSemaphore inQueue: anOrderedCollection
queuesMutex critical: [
aSemaphore signal.
anOrderedCollection remove: aSemaphore ifAbsent: [].
].!
----- Method: Monitor>>signalQueue: (in category 'private') -----
signalQueue: anOrderedCollection
queuesMutex critical: [
anOrderedCollection isEmpty ifTrue: [^ self].
anOrderedCollection removeFirst signal.
].!
----- 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].!
----- 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!
----- 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!
----- 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.!
----- 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!
----- Method: Monitor>>waitInQueue:maxMilliseconds: (in category 'private') -----
waitInQueue: anOrderedCollection maxMilliseconds: anIntegerOrNil
self exitAndWaitInQueue: anOrderedCollection maxMilliseconds: anIntegerOrNil.!
----- 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!
----- 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!
----- Method: Monitor>>waitUntil: (in category 'waiting-basic') -----
waitUntil: aBlock
"Conditional waiting for the default event.
See Monitor>>waitWhile: aBlock."
^ self waitUntil: aBlock for: nil!
----- 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!
----- 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!
----- 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!
----- 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!
----- 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!
----- 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!
----- 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!
----- 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.!
----- 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!
----- Method: Monitor>>waitWhile:inQueue:maxMilliseconds: (in category 'private') -----
waitWhile: aBlock inQueue: anOrderedCollection maxMilliseconds: anIntegerOrNil
[aBlock value] whileTrue: [self exitAndWaitInQueue: anOrderedCollection maxMilliseconds: anIntegerOrNil].!
----- 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!
----- 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!
----- Method: Object class>>categoryForUniclasses (in category 'instance creation') -----
categoryForUniclasses
"Answer the default system category into which to place unique-class instances"
^ 'UserObjects'!
----- Method: Object class>>ccg:emitLoadFor:from:on: (in category 'plugin generation') -----
ccg: cg emitLoadFor: aString from: anInteger on: aStream
cg emitLoad: aString asNakedOopFrom: anInteger on: aStream!
----- Method: Object class>>ccg:generateCoerceToOopFrom:on: (in category 'plugin generation') -----
ccg: cg generateCoerceToOopFrom: aNode on: aStream
cg emitCExpression: aNode on: aStream!
----- Method: Object class>>ccg:generateCoerceToValueFrom:on: (in category 'plugin generation') -----
ccg: cg generateCoerceToValueFrom: aNode on: aStream
cg emitCExpression: aNode on: aStream!
----- Method: Object class>>ccg:prolog:expr:index: (in category 'plugin generation') -----
ccg: cg prolog: aBlock expr: aString index: anInteger
^cg ccgLoad: aBlock expr: aString asKindOf: self from: anInteger!
----- Method: Object class>>ccgCanConvertFrom: (in category 'plugin generation') -----
ccgCanConvertFrom: anObject
^anObject isKindOf: self!
----- Method: Object class>>ccgDeclareCForVar: (in category 'plugin generation') -----
ccgDeclareCForVar: aSymbolOrString
^'int ', aSymbolOrString!
----- 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!
----- 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))]
!
----- Method: Object class>>fileReaderServicesForDirectory: (in category 'file list services') -----
fileReaderServicesForDirectory: aFileDirectory
"Backstop"
^#()!
----- Method: Object class>>fileReaderServicesForFile:suffix: (in category 'file list services') -----
fileReaderServicesForFile: fullName suffix: suffix
"Backstop"
^#()!
----- Method: Object class>>flushDependents (in category 'class initialization') -----
flushDependents
DependentsFields keysAndValuesDo:[:key :dep|
key ifNotNil:[key removeDependent: nil].
].
DependentsFields finalizeValues.!
----- Method: Object class>>flushEvents (in category 'class initialization') -----
flushEvents
"Object flushEvents"
EventManager flushEvents. !
----- 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'!
----- 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!
----- Method: Object class>>initialize (in category 'class initialization') -----
initialize
"Object initialize"
DependentsFields ifNil:[self initializeDependentsFields].!
----- Method: Object class>>initializeDependentsFields (in category 'class initialization') -----
initializeDependentsFields
"Object initialize"
DependentsFields _ WeakIdentityKeyDictionary new.
!
----- Method: Object class>>initializedInstance (in category 'instance creation') -----
initializedInstance
^ self new!
----- Method: Object class>>instanceOfUniqueClass (in category 'instance creation') -----
instanceOfUniqueClass
"Answer an instance of a unique subclass of the receiver"
^ self instanceOfUniqueClassWithInstVarString: '' andClassInstVarString: ''!
----- 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!
----- Method: Object class>>isUniClass (in category 'instance creation') -----
isUniClass
^ false!
----- 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!
----- 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!
----- 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!
----- 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]].
!
----- 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" logged: false.
(object isKindOf: self) ifFalse: [self error: self name, ' expected'].
^object!
----- 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!
----- Method: Object class>>releaseExternalSettings (in category 'private') -----
releaseExternalSettings
"Do nothing as a default"!
----- Method: Object class>>services (in category 'file list services') -----
services
"Answer a list of file-list services provided by the receiver class."
^ #()!
----- 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'!
----- Method: Object class>>windowColorSpecification (in category 'window color') -----
windowColorSpecification
"Answer a WindowColorSpec object that declares my preference.
This is a backstop for classes that don't otherwise define a preference."
^ WindowColorSpec classSymbol: self name
wording: 'Default' translatedNoop brightColor: #white
pastelColor: #white
helpMessage: 'Other windows without color preferences.' translatedNoop!
----- Method: Object>>-> (in category 'associating') -----
-> anObject
"Answer an Association between self and anObject"
^Association new key: self value: anObject!
----- 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!
----- Method: Object>>acceptDroppingMorph:event:inMorph: (in category 'drag and drop') -----
acceptDroppingMorph: transferMorph event: evt inMorph: dstListMorph
^false.!
----- Method: Object>>actAsExecutor (in category 'finalization') -----
actAsExecutor
"Prepare the receiver to act as executor for any resources associated with it"
self breakDependents!
----- Method: Object>>actionForEvent: (in category 'events-accessing') -----
actionForEvent: anEventSelector
"Answer the action to be evaluated when <anEventSelector> has been triggered."
| actions |
actions := self actionMap
at: anEventSelector asSymbol
ifAbsent: [nil].
actions ifNil: [^nil].
^ actions asMinimalRepresentation!
----- Method: Object>>actionForEvent:ifAbsent: (in category 'events-accessing') -----
actionForEvent: anEventSelector
ifAbsent: anExceptionBlock
"Answer the action to be evaluated when <anEventSelector> has been triggered."
| actions |
actions := self actionMap
at: anEventSelector asSymbol
ifAbsent: [nil].
actions ifNil: [^anExceptionBlock value].
^ actions asMinimalRepresentation!
----- Method: Object>>actionMap (in category 'events-accessing') -----
actionMap
^EventManager actionMapFor: self!
----- Method: Object>>actionSequenceForEvent: (in category 'events-accessing') -----
actionSequenceForEvent: anEventSelector
^(self actionMap
at: anEventSelector asSymbol
ifAbsent: [^WeakActionSequence new])
asActionSequence!
----- Method: Object>>actionsDo: (in category 'events-accessing') -----
actionsDo: aBlock
self actionMap do: aBlock!
----- Method: Object>>actionsWithReceiver:forEvent: (in category 'events') -----
actionsWithReceiver: anObject forEvent: anEventSelector
^(self actionSequenceForEvent: anEventSelector)
select: [:anAction | anAction receiver == anObject ]!
----- 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!
----- 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!
----- 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!
----- 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!
----- 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!
----- 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!
----- 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."!
----- 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"
!
----- 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
!
----- Method: Object>>as: (in category 'converting') -----
as: aSimilarClass
"Create an object of class aSimilarClass that has similar contents to the receiver."
^ aSimilarClass newFrom: self!
----- Method: Object>>asActionSequence (in category 'converting') -----
asActionSequence
^WeakActionSequence with: self!
----- Method: Object>>asActionSequenceTrappingErrors (in category 'converting') -----
asActionSequenceTrappingErrors
^WeakActionSequenceTrappingErrors with: self!
----- Method: Object>>asDraggableMorph (in category 'converting') -----
asDraggableMorph
^(StringMorph contents: self printString)
color: Color white;
yourself!
----- Method: Object>>asExplorerString (in category 'user interface') -----
asExplorerString
^ self printString!
----- Method: Object>>asMorph (in category 'creation') -----
asMorph
"Open a morph, as best one can, on the receiver"
^ self asStringMorph
"
234 asMorph
(ScriptingSystem formAtKey: #TinyMenu) asMorph
'fred' asMorph
"
!
----- Method: Object>>asOop (in category 'system primitives') -----
asOop
"Primitive. Answer a SmallInteger whose value is half of the receiver's
object pointer (interpreting object pointers as 16-bit signed quantities).
Fail if the receiver is a SmallInteger. Essential. See Object documentation
whatIsAPrimitive."
<primitive: 75>
self primitiveFailed!
----- Method: Object>>asOrderedCollection (in category 'converting') -----
asOrderedCollection
"Answer an OrderedCollection with the receiver as its only element."
^ OrderedCollection with: self!
----- Method: Object>>asString (in category 'converting') -----
asString
"Answer a string that represents the receiver."
^ self printString !
----- Method: Object>>asStringMorph (in category 'creation') -----
asStringMorph
"Open a StringMorph, as best one can, on the receiver"
^ self asStringOrText asStringMorph
!
----- Method: Object>>asStringOrText (in category 'converting') -----
asStringOrText
"Answer a string that represents the receiver."
^ self printString !
----- Method: Object>>asTextMorph (in category 'creation') -----
asTextMorph
"Open a TextMorph, as best one can, on the receiver"
^ TextMorph new contentsAsIs: self asStringOrText
!
----- 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']!
----- Method: Object>>assert:description: (in category 'error handling') -----
assert: aBlock description: aString
"Throw an assertion error if aBlock does not evaluates to true."
aBlock value ifFalse: [AssertionFailure signal: aString ]!
----- 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 ]!
----- 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]!
----- 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))!
----- 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]!
----- Method: Object>>backwardCompatibilityOnly: (in category 'error handling') -----
backwardCompatibilityOnly: anExplanationString
"Warn that the sending method has been deprecated. Methods that are tagt with #backwardCompatibility:
are kept for compatibility."
Preferences showDeprecationWarnings ifTrue:
[Deprecation signal: thisContext sender printString, ' has been deprecated (but will be kept for compatibility). ', anExplanationString]!
----- 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!
----- 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]!
----- 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]!
----- Method: Object>>basicInspect (in category 'inspecting') -----
basicInspect
"Create and schedule an Inspector in which the user can examine the
receiver's variables. This method should not be overriden."
BasicInspector openOn: self withEvalPane: false!
----- 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 !
----- 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!
----- Method: Object>>becomeForward: (in category 'system primitives') -----
becomeForward: otherObject
"Primitive. All variables in the entire system that used to point
to the receiver now point to the argument.
Fails if either argument is a SmallInteger."
(Array with: self)
elementsForwardIdentityTo:
(Array with: otherObject)!
----- Method: Object>>becomeForward:copyHash: (in category 'system primitives') -----
becomeForward: otherObject copyHash: copyHash
"Primitive. All variables in the entire system that used to point to the receiver now point to the argument.
If copyHash is true, the argument's identity hash bits will be set to those of the receiver.
Fails if either argument is a SmallInteger."
(Array with: self)
elementsForwardIdentityTo:
(Array with: otherObject)
copyHash: copyHash!
----- Method: Object>>beep (in category 'user interface') -----
beep
"Deprecated."
self deprecated: 'Use Beeper class>>beep instead.'.
Beeper beep!
----- Method: Object>>beep: (in category 'deprecated') -----
beep: soundName
"Make the given sound, unless the making of sound is disabled in Preferences."
self deprecated: 'Use SampledSound>>playSoundNamed: instead.'.
Preferences soundsEnabled
ifTrue: [self playSoundNamed: soundName]
!
----- Method: Object>>beepPrimitive (in category 'deprecated') -----
beepPrimitive
"Deprecated. Beep in the absence of sound support."
self deprecated: 'Use Beeper class>>beep or Beeper class>>beepPrimitive instead.'.
Beeper beepPrimitive!
----- 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 name endsWithDigit!
----- Method: Object>>bindWithTemp: (in category 'accessing') -----
bindWithTemp: aBlock
^ aBlock value: self value: nil!
----- Method: Object>>bindingOf: (in category 'binding') -----
bindingOf: aString
^nil!
----- Method: Object>>break (in category 'breakpoint') -----
break
"This is a simple message to use for inserting breakpoints during debugging.
The debugger is opened by sending a signal. This gives a chance to restore
invariants related to multiple processes."
BreakPoint signal.
"nil break."!
----- Method: Object>>breakDependents (in category 'dependents access') -----
breakDependents
"Remove all of the receiver's dependents."
self myDependents: nil!
----- Method: Object>>byteEncode: (in category 'filter streaming') -----
byteEncode:aStream
self flattenOnStream:aStream.
!
----- 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!
----- Method: Object>>capturedState (in category 'undo') -----
capturedState
"May be overridden in subclasses."
^ self shallowCopy
!
----- Method: Object>>caseError (in category 'error handling') -----
caseError
"Report an error from an in-line or explicit case statement."
self error: 'Case not found, and no otherwise clause'!
----- 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]}"!
----- 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]"!
----- 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!
----- 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]!
----- 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]!
----- 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!
----- 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!
----- Method: Object>>clone (in category 'copying') -----
clone
<primitive: 148>
self primitiveFailed!
----- 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."
| ans |
[ans _ self = anObject] ifError: [:aString :aReceiver | ^ false].
^ ans!
----- 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.'!
----- 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!
----- Method: Object>>commandHistory (in category 'undo') -----
commandHistory
"Return the command history for the receiver"
| w |
(w _ self currentWorld) ifNotNil: [^ w commandHistory].
^ CommandHistory new. "won't really record anything but prevent breaking things"!
----- Method: Object>>complexContents (in category 'converting') -----
complexContents
^self!
----- Method: Object>>confirm: (in category 'error handling') -----
confirm: queryString
"Put up a yes/no menu with caption queryString. Answer true if the
response is yes, false if no. This is a modal question--the user must
respond yes or no."
"nil confirm: 'Are you hungry?'"
^ PopUpMenu confirm: queryString!
----- Method: Object>>confirm:orCancel: (in category 'error handling') -----
confirm: aString orCancel: cancelBlock
"Put up a yes/no/cancel menu with caption aString. Answer true if
the response is yes, false if no. If cancel is chosen, evaluate
cancelBlock. This is a modal question--the user must respond yes or no."
^ PopUpMenu confirm: aString orCancel: cancelBlock!
----- Method: Object>>contentsChanged (in category 'macpal') -----
contentsChanged
self changed: #contents!
----- Method: Object>>contentsGetz: (in category 'scripting') -----
contentsGetz: x
self deprecated: 'there is no method named contents in object and in addition only one sender in a method not called'.
self contents: x!
----- 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"!
----- 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!
----- 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)]!
----- 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)]].!
----- 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 match |
myInstVars _ self class allInstVarNames.
otherInstVars _ otherObject class allInstVarNames.
myInstVars doWithIndex: [:each :index |
(match _ otherInstVars indexOf: each) > 0 ifTrue:
[self instVarAt: index put: (otherObject instVarAt: match)]].
1 to: (self basicSize min: otherObject basicSize) do: [:i |
self basicAt: i put: (otherObject basicAt: i)].
!
----- 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!
----- 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!
----- Method: Object>>couldOpenInMorphic (in category 'world hacking') -----
couldOpenInMorphic
"is there an obvious morphic world in which to open a new morph?"
^World notNil or: [ActiveWorld notNil]!
----- Method: Object>>createActionMap (in category 'events-accessing') -----
createActionMap
^IdentityDictionary new!
----- 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>'!
----- Method: Object>>currentEvent (in category 'macpal') -----
currentEvent
"Answer the current Morphic event. This method never returns nil."
^ActiveEvent ifNil:[self currentHand lastEvent]!
----- 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 ]!
----- Method: Object>>currentWorld (in category 'macpal') -----
currentWorld
"Answer a morphic world that is the current UI focus.
If in an embedded world, it's that world.
If in a morphic project, it's that project's world.
If in an mvc project, it is the topmost morphic-mvc-window's worldMorph.
If in an mvc project that has no morphic-mvc-windows, then it's just some existing worldmorph instance.
If in an mvc project in a Squeak that has NO WorldMorph instances, one is created.
This method will never return nil, it will always return its best effort at returning a relevant world morph, but if need be -- if there are no worlds anywhere, it will create a new one."
| aView aSubview |
ActiveWorld ifNotNil:[^ActiveWorld].
World ifNotNil:[^World].
aView _ ScheduledControllers controllerSatisfying:
[:ctrl | (aSubview _ ctrl view firstSubView) notNil and:
[aSubview model isMorph and: [aSubview model isWorldMorph]]].
^aView
ifNotNil:
[aSubview model]
ifNil:
[MVCWiWPasteUpMorph newWorldForProject: nil].!
----- Method: Object>>customizeExplorerContents (in category 'accessing') -----
customizeExplorerContents
^ false.
!
----- 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!
----- 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!
----- 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!
----- 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!
----- 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: [#()]!
----- Method: Object>>deprecated: (in category 'error handling') -----
deprecated: anExplanationString
"Warn that the sending method has been deprecated."
Preferences showDeprecationWarnings ifTrue:
[Deprecation signal: thisContext sender printString, ' has been deprecated. ', anExplanationString]!
----- Method: Object>>deprecated:block: (in category 'error handling') -----
deprecated: anExplanationString block: aBlock
"Warn that the sender has been deprecated. Answer the value of aBlock on resumption. (Note that #deprecated: is usually the preferred method.)"
Preferences showDeprecationWarnings ifTrue:
[Deprecation
signal: thisContext sender printString, ' has been deprecated. ', anExplanationString].
^ aBlock value.
!
----- Method: Object>>deprecated:explanation: (in category 'error handling') -----
deprecated: aBlock explanation: aString
"This method is OBSOLETE. Use #deprecated:block: instead."
self deprecated: 'Use Object>>deprecated:block: instead of deprecated:explanation:.'.
Preferences showDeprecationWarnings ifTrue:
[Deprecation
signal: ('{1} has been deprecated. {2}' translated format: {thisContext sender printString. aString})].
^ aBlock value.
!
----- Method: Object>>deprecatedExplanation: (in category 'error handling') -----
deprecatedExplanation: aString
"This method is OBSOLETE. Use #deprecated: instead."
self deprecated: 'Use Object>>deprecated: instead of deprecatedExplanation:.'.
Preferences showDeprecationWarnings ifTrue:
[Deprecation signal: ('{1} has been deprecated. {2}' translated format: {thisContext sender printString. aString})]!
----- Method: Object>>descriptionForPartsBin (in category 'parts bin') -----
descriptionForPartsBin
"If the receiver is a member of a class that would like to be represented in a parts bin, answer the name by which it should be known, and a documentation string to be provided, for example, as balloon help. When the 'nativitySelector' is sent to the 'globalReceiver', it is expected that some kind of Morph will result. The parameters used in the implementation below are for documentation purposes only!!"
^ DescriptionForPartsBin
formalName: 'PutFormalNameHere' translatedNoop
categoryList: {'PutACategoryHere' translatedNoop. 'MaybePutAnotherCategoryHere' translatedNoop}
documentation: 'Put the balloon help here' translatedNoop
globalReceiverSymbol: #PutAGlobalHere
nativitySelector: #PutASelectorHere!
----- Method: Object>>doIfNotNil: (in category 'accessing') -----
doIfNotNil: aBlock
self deprecated: 'use ifNotNilDo:'.
^ self ifNotNilDo: aBlock
!
----- 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)"
(Preferences autoAccessors and: [self tryToDefineVariableAccess: aMessage])
ifTrue: [^ aMessage sentTo: self].
MessageNotUnderstood new
message: aMessage;
receiver: self;
signal.
^ aMessage sentTo: self.
!
----- Method: Object>>dpsTrace: (in category 'error handling') -----
dpsTrace: reportObject
Transcript myDependents isNil ifTrue: [^self].
self dpsTrace: reportObject levels: 1 withContext: thisContext
" nil dpsTrace: 'sludder'. "!
----- 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.]"!
----- 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"].!
----- Method: Object>>dragAnimationFor:transferMorph: (in category 'drag and drop') -----
dragAnimationFor: item transferMorph: transferMorph
"Default do nothing"!
----- Method: Object>>dragPassengerFor:inMorph: (in category 'drag and drop') -----
dragPassengerFor: item inMorph: dragSource
^item!
----- Method: Object>>dragTransferType (in category 'drag and drop') -----
dragTransferType
^nil!
----- Method: Object>>dragTransferTypeForMorph: (in category 'drag and drop') -----
dragTransferTypeForMorph: dragSource
^nil!
----- Method: Object>>drawOnCanvas: (in category 'filter streaming') -----
drawOnCanvas:aStream
self flattenOnStream:aStream.
!
----- Method: Object>>eToyStreamedRepresentationNotifying: (in category 'user interface') -----
eToyStreamedRepresentationNotifying: aWidget
| outData |
[ outData _ SmartRefStream streamedRepresentationOf: self ]
on: ProgressInitiationException
do: [ :ex |
ex sendNotificationsTo: [ :min :max :curr |
aWidget ifNotNil: [aWidget flashIndicator: #working].
].
].
^outData
!
----- Method: Object>>eToysEQ: (in category 'comparing') -----
eToysEQ: anObject
^self = anObject!
----- Method: Object>>eToysError: (in category 'error handling') -----
eToysError: aString
"Throw a generic Error exception."
^EtoysError new signal: aString!
----- Method: Object>>eToysGE: (in category 'comparing') -----
eToysGE: anObject
^self >= anObject!
----- Method: Object>>eToysGT: (in category 'comparing') -----
eToysGT: anObject
^self > anObject!
----- Method: Object>>eToysLE: (in category 'comparing') -----
eToysLE: anObject
^self <= anObject!
----- Method: Object>>eToysLT: (in category 'comparing') -----
eToysLT: anObject
^self < anObject!
----- Method: Object>>eToysNE: (in category 'comparing') -----
eToysNE: anObject
^self ~= anObject!
----- Method: Object>>elementSeparator (in category 'filter streaming') -----
elementSeparator
^nil.!
----- 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"
!
----- Method: Object>>encodePostscriptOn: (in category 'filter streaming') -----
encodePostscriptOn:aStream
self byteEncode:aStream.
!
----- Method: Object>>error: (in category 'error handling') -----
error: aString
"Throw a generic Error exception."
^Error new signal: aString!
----- Method: Object>>errorImproperStore (in category 'private') -----
errorImproperStore
"Create an error notification that an improper store was attempted."
self error: 'Improper store into indexable object'!
----- 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'!
----- 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})!
----- 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!
----- 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!
----- Method: Object>>evaluateUnloggedForSelf: (in category 'scripting') -----
evaluateUnloggedForSelf: aCodeString
^Compiler evaluate:
aCodeString
for: self
logged: false!
----- Method: Object>>executor (in category 'finalization') -----
executor
"Return an object which can act as executor for finalization of the receiver"
^self shallowCopy actAsExecutor!
----- Method: Object>>explore (in category 'user interface') -----
explore
^ObjectExplorer new openExplorerFor: self!
----- Method: Object>>externalCallFailed (in category 'error handling') -----
externalCallFailed
"A call to an external function has failed."
^(Smalltalk at: #ExternalFunction ifAbsent:[^self error: 'FFI not installed'])
externalCallFailed!
----- Method: Object>>finalizationRegistry (in category 'finalization') -----
finalizationRegistry
"Answer the finalization registry associated with the receiver."
^WeakRegistry default!
----- Method: Object>>finalize (in category 'finalization') -----
finalize
"Finalize the resource associated with the receiver. This message should only be sent during the finalization process. There is NO garantuee that the resource associated with the receiver hasn't been free'd before so take care that you don't run into trouble - this all may happen with interrupt priority."!
----- 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."!
----- Method: Object>>flash (in category 'macpal') -----
flash
"Do nothing."
!
----- Method: Object>>flattenOnStream: (in category 'filter streaming') -----
flattenOnStream:aStream
self writeOnFilterStream:aStream.
!
----- Method: Object>>fullDrawPostscriptOn: (in category 'filter streaming') -----
fullDrawPostscriptOn:aStream
^aStream fullDraw:self.
!
----- Method: Object>>fullPrintString (in category 'printing') -----
fullPrintString
"Answer a String whose characters are a description of the receiver."
^ String streamContents: [:s | self printOn: s]!
----- Method: Object>>fullScreenSize (in category 'user interface') -----
fullScreenSize
"Answer the size to which a window displaying the receiver should be set"
| adj |
adj _ (3 * Preferences scrollBarWidth) @ 0.
^ Rectangle origin: adj extent: (DisplayScreen actualScreenSize - adj)!
----- 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!
----- 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!
----- 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
].!
----- Method: Object>>haltIfNil (in category 'testing') -----
haltIfNil!
----- 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!
----- Method: Object>>handles: (in category 'error handling') -----
handles: exception
"This method exists to break an endless loop in Exception>>findHandlerFrom: if the exception
is invalid"
^false!
----- Method: Object>>hasActionForEvent: (in category 'events-accessing') -----
hasActionForEvent: anEventSelector
"Answer true if there is an action associated with anEventSelector"
^(self actionForEvent: anEventSelector) notNil!
----- Method: Object>>hasModelYellowButtonMenuItems (in category 'graph model') -----
hasModelYellowButtonMenuItems
^Preferences cmdGesturesEnabled!
----- 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!
----- 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 identityHash!
----- Method: Object>>hashMappedBy: (in category 'comparing') -----
hashMappedBy: map
"Answer what my hash would be if oops changed according to map."
^map newHashFor: self!
----- Method: Object>>identityHashMappedBy: (in category 'comparing') -----
identityHashMappedBy: map
"Answer what my hash would be if oops changed according to map."
^map newHashFor: self!
----- Method: Object>>identityHashPrintString (in category 'comparing') -----
identityHashPrintString
"'fred' identityHashPrintString"
^ '(', self identityHash printString, ')'!
----- Method: Object>>ifKindOf:thenDo: (in category 'macpal') -----
ifKindOf: aClass thenDo: aBlock
^ (self isKindOf: aClass) ifTrue: [aBlock value: self]!
----- Method: Object>>ifNil:ifNotNilDo: (in category 'accessing') -----
ifNil: nilBlock ifNotNilDo: aBlock
"Evaluate aBlock with the receiver as its argument."
^ aBlock value: self
!
----- Method: Object>>ifNotNilDo: (in category 'accessing') -----
ifNotNilDo: aBlock
"Evaluate the given block with the receiver as its argument."
^ aBlock value: self
!
----- Method: Object>>ifNotNilDo:ifNil: (in category 'accessing') -----
ifNotNilDo: aBlock ifNil: nilBlock
"Evaluate aBlock with the receiver as its argument."
^ aBlock value: self
!
----- Method: Object>>in: (in category 'accessing') -----
in: aBlock
"Evaluate the given block with the receiver as its argument."
^ aBlock value: self
!
----- Method: Object>>indexIfCompact (in category 'objects from disk') -----
indexIfCompact
^0 "helps avoid a #respondsTo: in publishing"!
----- Method: Object>>inform: (in category 'user interface') -----
inform: aString
"Display a message for the user to read and then dismiss. 6/9/96 sw"
aString isEmptyOrNil ifFalse: [PopUpMenu inform: aString]!
----- 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."
| aClass |
aList do:
[:elem | Symbol hasInterned: elem asString ifTrue:
[:elemSymbol | (((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]]
"!
----- Method: Object>>initialExtent (in category 'user interface') -----
initialExtent
"Answer the desired extent for the receiver when a view on it is first opened on the screen.
5/22/96 sw: in the absence of any override, obtain from RealEstateAgent"
^ RealEstateAgent standardWindowExtent!
----- Method: Object>>inline: (in category 'translation support') -----
inline: inlineFlag
"For translation only; noop when running in Smalltalk."!
----- Method: Object>>inspect (in category 'inspecting') -----
inspect
"Create and schedule an Inspector in which the user can examine the receiver's variables."
^self inspectorClass openOn: self withEvalPane: true!
----- Method: Object>>inspectWithLabel: (in category 'user interface') -----
inspectWithLabel: aLabel
^self inspectorClass openOn: self withEvalPane: true withLabel: aLabel!
----- Method: Object>>inspectorClass (in category 'inspecting') -----
inspectorClass
"Answer the class of the inspector to be used on the receiver. Called by inspect;
use basicInspect to get a normal (less useful) type of inspector."
^ Inspector!
----- 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. 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 !
----- Method: Object>>instVarAt:put: (in category 'system primitives') -----
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!
----- 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 allInstVarNames indexOf: aString asString)
!
----- 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 allInstVarNames indexOf: aString asString) put: aValue
!
----- 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!
----- Method: Object>>is: (in category 'testing') -----
is: aSymbol
^ false.
!
----- Method: Object>>isArray (in category 'testing') -----
isArray
^false!
----- 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!
----- Method: Object>>isBlock (in category 'testing') -----
isBlock
^ false!
----- Method: Object>>isBlockClosure (in category 'testing') -----
isBlockClosure
^ false!
----- Method: Object>>isCharacter (in category 'testing') -----
isCharacter
^ false.
!
----- 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!
----- Method: Object>>isColor (in category 'testing') -----
isColor
"Answer true if receiver is a Color. False by default."
^ false
!
----- Method: Object>>isColorForm (in category 'testing') -----
isColorForm
^false!
----- Method: Object>>isCompiledMethod (in category 'testing') -----
isCompiledMethod
^ false!
----- Method: Object>>isComplex (in category 'testing') -----
isComplex
"Answer true if receiver is a Complex number. False by default."
^ false
!
----- Method: Object>>isFloat (in category 'testing') -----
isFloat
"Overridden to return true in Float, natch"
^ false!
----- Method: Object>>isForm (in category 'testing') -----
isForm
^false!
----- Method: Object>>isFraction (in category 'testing') -----
isFraction
"Answer true if the receiver is a Fraction."
^ false!
----- Method: Object>>isHeap (in category 'testing') -----
isHeap
^ false!
----- Method: Object>>isInteger (in category 'testing') -----
isInteger
"Overridden to return true in Integer."
^ false!
----- Method: Object>>isInterval (in category 'testing') -----
isInterval
^ false!
----- 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
ifTrue: [^true]
ifFalse: [^self class inheritsFrom: aClass]!
----- 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]!
----- Method: Object>>isLiteral (in category 'printing') -----
isLiteral
"Answer whether the receiver has a literal text form recognized by the
compiler."
^false!
----- Method: Object>>isMemberOf: (in category 'class membership') -----
isMemberOf: aClass
"Answer whether the receiver is an instance of the class, aClass."
^self class == aClass!
----- Method: Object>>isMessageSend (in category 'testing') -----
isMessageSend
^false
!
----- Method: Object>>isMethodProperties (in category 'testing') -----
isMethodProperties
^false!
----- Method: Object>>isMorph (in category 'testing') -----
isMorph
^ false!
----- Method: Object>>isMorphicEvent (in category 'testing') -----
isMorphicEvent
^false!
----- Method: Object>>isMorphicModel (in category 'testing') -----
isMorphicModel
"Return true if the receiver is a morphic model"
^false
!
----- Method: Object>>isNumber (in category 'testing') -----
isNumber
"Overridden to return true in Number, natch"
^ false!
----- Method: Object>>isPoint (in category 'testing') -----
isPoint
"Overridden to return true in Point."
^ false!
----- Method: Object>>isPseudoContext (in category 'testing') -----
isPseudoContext
^false!
----- Method: Object>>isReallyString (in category 'testing') -----
isReallyString
^ false!
----- Method: Object>>isRectangle (in category 'testing') -----
isRectangle
^false!
----- Method: Object>>isSketchMorph (in category 'testing') -----
isSketchMorph
^false!
----- Method: Object>>isStream (in category 'testing') -----
isStream
"Return true if the receiver responds to the stream protocol"
^false
!
----- Method: Object>>isString (in category 'testing') -----
isString
"Overridden to return true in String, natch"
^ false!
----- Method: Object>>isSymbol (in category 'testing') -----
isSymbol
^ false !
----- Method: Object>>isSystemWindow (in category 'testing') -----
isSystemWindow
"answer whatever the receiver is a SystemWindow"
^ false!
----- Method: Object>>isText (in category 'testing') -----
isText
^ false!
----- 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!
----- Method: Object>>isThisEverCalled (in category 'flagging') -----
isThisEverCalled
^ self isThisEverCalled: thisContext sender printString!
----- 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!
----- 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!
----- Method: Object>>isTransparent (in category 'testing') -----
isTransparent
^ false!
----- 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!
----- Method: Object>>isVariableBinding (in category 'testing') -----
isVariableBinding
"Return true if I represent a literal variable binding"
^false
!
----- Method: Object>>isWebBrowser (in category 'testing') -----
isWebBrowser
"whether this object is a web browser. See class: Scamper"
^false!
----- Method: Object>>knownName (in category 'testing') -----
knownName
^ nil.
!
----- Method: Object>>launchPartOffsetVia:label: (in category 'user interface') -----
launchPartOffsetVia: 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. This variant makes the morph offset from the hand position by an amount suitable for tile-scripting in some circumstances."
| aMorph |
aMorph _ self perform: aSelector.
aMorph setNameTo: (ActiveWorld unusedMorphNameLike: aString).
aMorph setProperty: #beFullyVisibleAfterDrop toValue: true.
aMorph setProperty: #offsetForAttachingToHand toValue: 10 at -10.
aMorph fullBounds.
aMorph openInHand!
----- 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!
----- 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. The nascent object will be sent the notification #justTornOffFromPartsBin just before appearing in the Hand. Answer the new morph."
| aMorph |
aMorph _ self perform: aSelector.
aMorph setNameTo: (ActiveWorld unusedMorphNameLike: aString).
aMorph setProperty: #beFullyVisibleAfterDrop toValue: true.
aMorph position: ActiveHand position.
aMorph justTornOffFromPartsBin .
ActiveHand grabMorph: aMorph.
^ aMorph!
----- 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!
----- Method: Object>>literalEqual: (in category 'comparing') -----
literalEqual: other
^ self class == other class and: [self = other]!
----- Method: Object>>literalStringsDo: (in category 'translating') -----
literalStringsDo: aBlock
"Assuming the receiver receiver is a literal, evaluate aBlock with all Strings (but not Symbols) within it."
^ self!
----- Method: Object>>localeChanged (in category 'locales') -----
localeChanged
self shouldBeImplemented!
----- Method: Object>>localeChangedGently (in category 'locales') -----
localeChangedGently
self localeChanged.
!
----- Method: Object>>logEntry (in category 'flagging') -----
logEntry
Transcript show: 'Entered ', thisContext sender printString; cr.
!
----- Method: Object>>logExecution (in category 'flagging') -----
logExecution
Transcript show: 'Executing ', thisContext sender printString; cr.
!
----- Method: Object>>logExit (in category 'flagging') -----
logExit
Transcript show: 'Exited ', thisContext sender printString; cr.
!
----- 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]!
----- 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]!
----- 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]!
----- 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]!
----- 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)
!
----- 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!
----- 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!
----- 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" !
----- Method: Object>>modelWakeUp (in category 'user interface') -----
modelWakeUp
"A window with me as model is being entered or expanded. Default response is no-op" !
----- 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!
----- 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."
!
----- 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!
----- 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!
----- Method: Object>>myDependents (in category 'dependents access') -----
myDependents
"Private. Answer a list of all the receiver's dependents."
^ DependentsFields at: self ifAbsent: []!
----- 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]!
----- 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!
----- 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]!
----- 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"
!
----- Method: Object>>notNil (in category 'testing') -----
notNil
"Coerces nil to false and everything else to true."
^true!
----- Method: Object>>notYetImplemented (in category 'user interface') -----
notYetImplemented
self inform: 'Not yet implemented (', thisContext sender printString, ')'!
----- Method: Object>>noteSelectionIndex:for: (in category 'updating') -----
noteSelectionIndex: anInteger for: aSymbol
"backstop"!
----- 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'"!
----- 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"!
----- Method: Object>>notifyWithLabel: (in category 'error handling') -----
notifyWithLabel: aString
"Create and schedule a Notifier with aString as the window label as well as the contents of the window, in order to request confirmation before a process can proceed."
Debugger
openContext: thisContext
label: aString
contents: aString
"nil notifyWithLabel: 'let us see if this works'"!
----- Method: Object>>objectForDataStream: (in category 'objects from disk') -----
objectForDataStream: refStrm
"Return an object to store on an external data stream."
^ self!
----- Method: Object>>objectRepresented (in category 'macpal') -----
objectRepresented
"most objects represent themselves; this provides a hook for aliases to grab on to"
^ self!
----- Method: Object>>okToChange (in category 'updating') -----
okToChange
"Allows a controller to ask this of any model"
^ true!
----- Method: Object>>oopString (in category 'system primitives') -----
oopString
"Answer a string that represents the oop of the receiver"
^ self asOop printString!
----- Method: Object>>openAsMorph (in category 'creation') -----
openAsMorph
"Open a morph, as best one can, on the receiver"
^ self asMorph openInHand
"
234 openAsMorph
(ScriptingSystem formAtKey: #TinyMenu) openAsMorph
'fred' openAsMorph
"!
----- Method: Object>>openInstanceBrowserWithTiles (in category 'testing') -----
openInstanceBrowserWithTiles
"Open up an instance browser on me with tiles as the code type, and with the search level as desired."
| aBrowser |
aBrowser _ InstanceBrowser new.
aBrowser useVocabulary: Vocabulary fullVocabulary.
aBrowser limitClass: self class.
aBrowser contentsSymbol: #tiles. "preset it to make extra buttons (tile menus)"
aBrowser openOnObject: self inWorld: ActiveWorld showingSelector: nil.
aBrowser contentsSymbol: #source.
aBrowser toggleShowingTiles.
"
(2 at 3) openInstanceBrowserWithTiles.
WatchMorph new openInstanceBrowserWithTiles
"!
----- 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)!
----- 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"
^ otherTarget perform: selector!
----- 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)!
----- 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)!
----- 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)!
----- 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!
----- 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!
----- Method: Object>>perform:withEnoughArguments: (in category 'message handling') -----
perform: selector withEnoughArguments: anArray
"Send the selector, aSymbol, to the receiver with arguments in argArray.
Only use enough arguments for the arity of the selector; supply nils for missing ones."
| numArgs args |
numArgs _ selector numArgs.
anArray size == numArgs
ifTrue: [ ^self perform: selector withArguments: anArray asArray ].
args _ Array new: numArgs.
args replaceFrom: 1
to: (anArray size min: args size)
with: anArray
startingAt: 1.
^ self perform: selector withArguments: args!
----- Method: Object>>playSoundNamed: (in category 'macpal') -----
playSoundNamed: soundName
"Deprecated.
Play the sound with the given name."
self deprecated: 'Use "SoundService default playSoundNamed: aName" instead.'.
SoundService default playSoundNamed: soundName!
----- Method: Object>>postCopy (in category 'copying') -----
postCopy
"self is a shallow copy, subclasses should copy fields as necessary to complete the full copy"
^ self!
----- 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!
----- 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!
----- Method: Object>>primitiveError: (in category 'private') -----
primitiveError: aString
"This method is called when the error handling results in a recursion in
calling on error: or halt or halt:."
| context |
(String
streamContents:
[:s |
s nextPutAll: '***System error handling failed***'.
s cr; nextPutAll: aString.
context _ thisContext sender sender.
20 timesRepeat: [context == nil ifFalse: [s cr; print: (context _ context sender)]].
s cr; nextPutAll: '-------------------------------'.
s cr; nextPutAll: 'Type CR to enter an emergency evaluator.'.
s cr; nextPutAll: 'Type any other character to restart.'])
displayAt: 0 @ 0.
[Sensor keyboardPressed] whileFalse.
Sensor keyboard = Character cr ifTrue: [Transcripter emergencyEvaluator].
Smalltalk isMorphic
ifTrue: [World install "init hands and redisplay"]
ifFalse: [ScheduledControllers searchForActiveController]!
----- Method: Object>>primitiveFailed (in category 'error handling') -----
primitiveFailed
"Announce that a primitive has failed and there is no appropriate
Smalltalk code to run."
self error: 'a primitive has failed'!
----- 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"!
----- 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!
----- Method: Object>>printOnStream: (in category 'filter streaming') -----
printOnStream:aStream
self byteEncode:aStream.
!
----- 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!
----- 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...'!
----- Method: Object>>propertyList (in category 'printing') -----
propertyList
"Answer a String whose characters are a property-list description of the receiver."
^ PropertyListEncoder process:self.
!
----- Method: Object>>purgeAllCommands (in category 'undo') -----
purgeAllCommands
"Purge all commands for this object"
Preferences useUndo ifFalse: [^ self]. "get out quickly"
self commandHistory purgeAllCommandsSuchThat: [:cmd | cmd undoTarget == self].
!
----- Method: Object>>putOn: (in category 'filter streaming') -----
putOn:aStream
^aStream nextPut:self.
!
----- 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)"!
----- Method: Object>>readFromString: (in category 'accessing') -----
readFromString: aString
"Create an object based on the contents of aString."
^self readFrom: (ReadStream on: aString)!
----- Method: Object>>redoFromCapturedState: (in category 'undo') -----
redoFromCapturedState: st
"May be overridden in subclasses. See also capturedState"
self undoFromCapturedState: st "Simple cases are symmetric"
!
----- Method: Object>>refineRedoTarget:selector:arguments:in: (in category 'undo') -----
refineRedoTarget: target selector: aSymbol arguments: arguments in: refineBlock
"Any object can override this method to refine its redo specification"
^ refineBlock
value: target
value: aSymbol
value: arguments!
----- Method: Object>>refineUndoTarget:selector:arguments:in: (in category 'undo') -----
refineUndoTarget: target selector: aSymbol arguments: arguments in: refineBlock
"Any object can override this method to refine its undo specification"
^ refineBlock
value: target
value: aSymbol
value: arguments!
----- 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
!
----- 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!
----- Method: Object>>releaseActionMap (in category 'events-removing') -----
releaseActionMap
EventManager releaseActionMapFor: self!
----- Method: Object>>rememberCommand: (in category 'undo') -----
rememberCommand: aCommand
"Remember the given command for undo"
Preferences useUndo ifFalse: [^ self]. "get out quickly"
^ self commandHistory rememberCommand: aCommand!
----- Method: Object>>rememberUndoableAction:named: (in category 'undo') -----
rememberUndoableAction: actionBlock named: caption
| cmd result |
cmd _ Command new cmdWording: caption.
cmd undoTarget: self selector: #undoFromCapturedState: argument: self capturedState.
result _ actionBlock value.
cmd redoTarget: self selector: #redoFromCapturedState: argument: self capturedState.
self rememberCommand: cmd.
^ result!
----- Method: Object>>removeAction:forEvent: (in category 'events-removing') -----
removeAction: anAction
forEvent: anEventSelector
self
removeActionsSatisfying: [:action | action = anAction]
forEvent: anEventSelector!
----- Method: Object>>removeActionsForEvent: (in category 'events-removing') -----
removeActionsForEvent: anEventSelector
| map |
map := self actionMap.
map removeKey: anEventSelector asSymbol ifAbsent: [].
map isEmpty
ifTrue: [self releaseActionMap]!
----- Method: Object>>removeActionsSatisfying: (in category 'events-removing') -----
removeActionsSatisfying: aBlock
self actionMap keys do:
[:eachEventSelector |
self
removeActionsSatisfying: aBlock
forEvent: eachEventSelector
]!
----- Method: Object>>removeActionsSatisfying:forEvent: (in category 'events-removing') -----
removeActionsSatisfying: aOneArgBlock
forEvent: anEventSelector
self
setActionSequence:
((self actionSequenceForEvent: anEventSelector)
reject: [:anAction | aOneArgBlock value: anAction])
forEvent: anEventSelector!
----- Method: Object>>removeActionsWithReceiver: (in category 'events-removing') -----
removeActionsWithReceiver: anObject
self actionMap copy keysDo:
[:eachEventSelector |
self
removeActionsSatisfying: [:anAction | anAction receiver == anObject]
forEvent: eachEventSelector
]!
----- Method: Object>>removeActionsWithReceiver:forEvent: (in category 'events-removing') -----
removeActionsWithReceiver: anObject
forEvent: anEventSelector
self
removeActionsSatisfying:
[:anAction |
anAction receiver == anObject]
forEvent: anEventSelector!
----- 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!
----- Method: Object>>renameActionsWithReceiver:forEvent:toEvent: (in category 'events') -----
renameActionsWithReceiver: anObject forEvent: anEventSelector toEvent: newEvent
| oldActions newActions |
oldActions _ Set new.
newActions _ Set new.
(self actionSequenceForEvent: anEventSelector) do: [ :action |
action receiver == anObject
ifTrue: [ oldActions add: anObject ]
ifFalse: [ newActions add: anObject ]].
self setActionSequence: (ActionSequence withAll: newActions) forEvent: anEventSelector.
oldActions do: [ :act | self when: newEvent evaluate: act ].!
----- 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"!
----- 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"!
----- 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!
----- 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!
----- Method: Object>>retryWithGC:until: (in category 'finalization') -----
retryWithGC: execBlock until: testBlock
"Retry execBlock as long as testBlock returns false. Do an incremental GC after the first try, a full GC after the second try."
| blockValue |
blockValue := execBlock value.
(testBlock value: blockValue) ifTrue:[^blockValue].
Smalltalk garbageCollectMost.
blockValue := execBlock value.
(testBlock value: blockValue) ifTrue:[^blockValue].
Smalltalk garbageCollect.
^execBlock value.!
----- Method: Object>>rootStubInImageSegment: (in category 'system primitives') -----
rootStubInImageSegment: imageSegment
^ ImageSegmentRootStub new
xxSuperclass: nil
format: nil
segment: imageSegment!
----- 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 fileStream |
aFileName _ self class name asFileName. "do better?"
aFileName _ FillInTheBlank request: 'File name?' translated initialAnswer: aFileName.
aFileName size == 0 ifTrue: [^ Beeper beep].
fileStream _ FileStream newFileNamed: aFileName asFileName.
fileStream fileOutClass: nil andObject: self.!
----- Method: Object>>scriptPerformer (in category 'macpal') -----
scriptPerformer
^ self
!
----- Method: Object>>selfWrittenAsIll (in category 'scripting') -----
selfWrittenAsIll
^self!
----- Method: Object>>selfWrittenAsIm (in category 'scripting') -----
selfWrittenAsIm
^self!
----- Method: Object>>selfWrittenAsMe (in category 'scripting') -----
selfWrittenAsMe
^self!
----- Method: Object>>selfWrittenAsMy (in category 'scripting') -----
selfWrittenAsMy
^self!
----- Method: Object>>selfWrittenAsThis (in category 'scripting') -----
selfWrittenAsThis
^self!
----- Method: Object>>setActionSequence:forEvent: (in category 'events-accessing') -----
setActionSequence: actionSequence
forEvent: anEventSelector
| action |
action := actionSequence asMinimalRepresentation.
action == nil
ifTrue:
[self removeActionsForEvent: anEventSelector]
ifFalse:
[self updateableActionMap
at: anEventSelector asSymbol
put: action]!
----- 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>
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!
----- Method: Object>>shouldBeImplemented (in category 'error handling') -----
shouldBeImplemented
"Announce that this message should be implemented"
self error: 'This message should be implemented'!
----- Method: Object>>shouldNotImplement (in category 'error handling') -----
shouldNotImplement
"Announce that, although the receiver inherits this message, it should
not implement it."
self error: 'This message is not appropriate for this object'!
----- 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!
----- 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!
----- Method: Object>>slotInfo (in category 'macpal') -----
slotInfo
"Answer a list of slot-information objects. Initally only provides useful info for players"
^ Dictionary new!
----- Method: Object>>someObject (in category 'system primitives') -----
someObject
"Primitive. Answer the first object in the enumeration of all
objects."
<primitive: 138>
self primitiveFailed.!
----- 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."
^self class!
----- Method: Object>>stepAt:in: (in category 'testing') -----
stepAt: millisecondClockValue in: aWindow
^ self stepIn: aWindow!
----- Method: Object>>stepIn: (in category 'testing') -----
stepIn: aWindow
^ self step!
----- Method: Object>>stepTime (in category 'testing') -----
stepTime
^ 1000 "milliseconds -- default backstop for objects serving as models of system windows"!
----- Method: Object>>stepTimeIn: (in category 'testing') -----
stepTimeIn: aSystemWindow
^ 1000 "milliseconds -- default backstop for objects serving as models of system windows"!
----- 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!
----- 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)]].
!
----- 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)'
!
----- Method: Object>>storeOnStream: (in category 'filter streaming') -----
storeOnStream:aStream
self printOnStream:aStream.
!
----- 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]!
----- Method: Object>>stringForReadout (in category 'printing') -----
stringForReadout
^ self stringRepresentation!
----- 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 !
----- 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."
self error: 'My subclass should have overridden ', thisContext sender methodSelector printString!
----- Method: Object>>toFinalizeSend:to:with: (in category 'finalization') -----
toFinalizeSend: aSelector to: aFinalizer with: aResourceHandle
"When I am finalized (e.g., garbage collected) close the associated resource handle by sending aSelector to the appropriate finalizer (the guy who knows how to get rid of the resource).
WARNING: Neither the finalizer nor the resource handle are allowed to reference me. If they do, then I will NEVER be garbage collected. Since this cannot be validated here, it is up to the client to make sure this invariant is not broken."
self == aFinalizer ifTrue:[self error: 'I cannot finalize myself'].
self == aResourceHandle ifTrue:[self error: 'I cannot finalize myself'].
^self finalizationRegistry add: self executor:
(ObjectFinalizer new
receiver: aFinalizer
selector: aSelector
argument: aResourceHandle)!
----- Method: Object>>translatedNoop (in category 'translating') -----
translatedNoop
"This is correspondence gettext_noop() in gettext."!
----- Method: Object>>triggerEvent: (in category 'events-triggering') -----
triggerEvent: anEventSelector
"Evaluate all actions registered for <anEventSelector>. Return the value of the last registered action."
^(self actionForEvent: anEventSelector) value!
----- Method: Object>>triggerEvent:ifNotHandled: (in category 'events-triggering') -----
triggerEvent: anEventSelector
ifNotHandled: anExceptionBlock
"Evaluate all actions registered for <anEventSelector>. Return the value of the last registered action."
^(self
actionForEvent: anEventSelector
ifAbsent: [^anExceptionBlock value]) value
!
----- Method: Object>>triggerEvent:with: (in category 'events-triggering') -----
triggerEvent: anEventSelector
with: anObject
^self
triggerEvent: anEventSelector
withArguments: (Array with: anObject)!
----- Method: Object>>triggerEvent:with:ifNotHandled: (in category 'events-triggering') -----
triggerEvent: anEventSelector
with: anObject
ifNotHandled: anExceptionBlock
^self
triggerEvent: anEventSelector
withArguments: (Array with: anObject)
ifNotHandled: anExceptionBlock!
----- Method: Object>>triggerEvent:withArguments: (in category 'events-triggering') -----
triggerEvent: anEventSelector
withArguments: anArgumentList
^(self actionForEvent: anEventSelector)
valueWithArguments: anArgumentList!
----- Method: Object>>triggerEvent:withArguments:ifNotHandled: (in category 'events-triggering') -----
triggerEvent: anEventSelector
withArguments: anArgumentList
ifNotHandled: anExceptionBlock
^(self
actionForEvent: anEventSelector
ifAbsent: [^anExceptionBlock value])
valueWithArguments: anArgumentList!
----- Method: Object>>tryToDefineVariableAccess: (in category 'error handling') -----
tryToDefineVariableAccess: aMessage
"See if the message just wants to get at an instance variable of this class. Ask the user if its OK. If so, define the message to read or write that instance or class variable and retry."
| ask newMessage sel canDo classOrSuper |
aMessage arguments size > 1 ifTrue: [^ false].
sel _ aMessage selector asString. "works for 0 args"
aMessage arguments size = 1 ifTrue: [
sel last = $: ifFalse: [^ false].
sel _ sel copyWithout: $:].
canDo _ false. classOrSuper _ self class.
[((classOrSuper instVarNames includes: sel)
ifTrue: [canDo _ true. nil]
ifFalse: [classOrSuper _ classOrSuper superclass]) == nil] whileFalse.
canDo ifFalse: [classOrSuper _ self class.
[((classOrSuper classVarNames includes: sel)
ifTrue: [canDo _ true. nil]
ifFalse: [classOrSuper _ classOrSuper superclass]) == nil] whileFalse].
canDo ifFalse: [^ false].
ask _ self confirm: 'A ', thisContext sender sender receiver
class printString, ' wants to ',
(aMessage arguments size = 1 ifTrue: ['write into'] ifFalse: ['read from']), '
', sel ,' in class ', classOrSuper printString, '.
Define a this access message?'.
ask ifTrue: [
aMessage arguments size = 1
ifTrue: [newMessage _ aMessage selector, ' anObject
', sel, ' _ anObject']
ifFalse: [newMessage _ aMessage selector, '
^', aMessage selector].
classOrSuper compile: newMessage classified: 'accessing' notifying: nil].
^ ask!
----- Method: Object>>undoFromCapturedState: (in category 'undo') -----
undoFromCapturedState: st
"May be overridden in subclasses. See also capturedState"
self copyFrom: st
!
----- 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!
----- 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!
----- Method: Object>>updateListsAndCodeIn: (in category 'updating') -----
updateListsAndCodeIn: aWindow
self canDiscardEdits ifFalse: [^ self].
aWindow updatablePanes do: [:aPane | aPane verifyContents]!
----- Method: Object>>updateableActionMap (in category 'events-accessing') -----
updateableActionMap
^EventManager updateableActionMapFor: self!
----- Method: Object>>value (in category 'evaluating') -----
value
^self!
----- Method: Object>>valueWithArguments: (in category 'evaluating') -----
valueWithArguments: aSequenceOfArguments
^self!
----- Method: Object>>var:declareC: (in category 'translation support') -----
var: varSymbol declareC: declString
"For translation only; noop when running in Smalltalk."!
----- 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: 4096 "self initialDeepCopierSize".
new _ self veryDeepCopyWith: copier.
copier mapUniClasses.
copier references associationsDo: [:assoc |
assoc value veryDeepFixupWith: copier].
copier fixDependents.
^ new!
----- 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: 4096 "self initialDeepCopierSize".
copier newUniClasses: false.
new _ self veryDeepCopyWith: copier.
copier mapUniClasses.
copier references associationsDo: [:assoc |
assoc value veryDeepFixupWith: copier].
copier fixDependents.
^ new!
----- 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 newDep newModel |
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 _ refs at: dep ifAbsent: [nil]) ifNotNil: [
newModel _ refs at: pair key ifAbsent: [pair key].
newModel addDependent: newDep]]].
^ new!
----- 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
!
----- Method: Object>>veryDeepFixupWith: (in category 'copying') -----
veryDeepFixupWith: deepCopier
"I have no fields and no superclass. Catch the super call."
!
----- 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:"
!
----- 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!
----- 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!
----- Method: Object>>wantsDroppedMorph:event:inMorph: (in category 'drag and drop') -----
wantsDroppedMorph: aMorph event: anEvent inMorph: destinationLM
^false!
----- 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!
----- Method: Object>>wantsStepsIn: (in category 'testing') -----
wantsStepsIn: aSystemWindow
^ self wantsSteps!
----- Method: Object>>when:evaluate: (in category 'events-registering') -----
when: anEventSelector evaluate: anAction
| actions |
actions := self actionSequenceForEvent: anEventSelector.
(actions includes: anAction)
ifTrue: [^ self].
self
setActionSequence: (actions copyWith: anAction)
forEvent: anEventSelector!
----- Method: Object>>when:send:to: (in category 'events-registering') -----
when: anEventSelector
send: aMessageSelector
to: anObject
self
when: anEventSelector
evaluate: (WeakMessageSend
receiver: anObject
selector: aMessageSelector)!
----- Method: Object>>when:send:to:with: (in category 'events-registering') -----
when: anEventSelector
send: aMessageSelector
to: anObject
with: anArg
self
when: anEventSelector
evaluate: (WeakMessageSend
receiver: anObject
selector: aMessageSelector
arguments: (Array with: anArg))!
----- Method: Object>>when:send:to:withArguments: (in category 'events-registering') -----
when: anEventSelector
send: aMessageSelector
to: anObject
withArguments: anArgArray
self
when: anEventSelector
evaluate: (WeakMessageSend
receiver: anObject
selector: aMessageSelector
arguments: anArgArray)!
----- Method: Object>>windowActiveOnFirstClick (in category 'user interface') -----
windowActiveOnFirstClick
"Return true if my window should be active on first click."
^ false!
----- 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."
!
----- 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!
----- 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]!
----- Method: Object>>withoutListWrapper (in category 'converting') -----
withoutListWrapper
^self!
----- Method: Object>>writeOnFilterStream: (in category 'filter streaming') -----
writeOnFilterStream:aStream
aStream writeObject:self.
!
----- Method: Object>>xxxClass (in category 'class membership') -----
xxxClass
"For subclasses of nil, such as ObjectOut"
^ self class!
----- Method: Object>>yourself (in category 'accessing') -----
yourself
"Answer self."!
----- Method: Object>>~= (in category 'comparing') -----
~= anObject
"Answer whether the receiver and the argument do not represent the
same object."
^self = anObject == false!
Object subclass: #Pragma
instanceVariableNames: 'method keyword arguments'
classVariableNames: ''
poolDictionaries: ''
category: 'Kernel-Methods'!
!Pragma commentStamp: '<historical>' 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 browsse senders and implementors and perform them. One can query a method for its pragmas by sendng 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]]!
----- 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 ] ] ].!
----- 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) ].!
----- 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.!
----- 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 ] ] ].!
----- 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) ].!
----- 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.!
----- 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!
----- Method: Pragma class>>keyword:arguments: (in category 'private') -----
keyword: aSymbol arguments: anArray
^ self new
setKeyword: aSymbol;
setArguments: anArray;
yourself.!
----- Method: Pragma class>>withPragmasIn:do: (in category 'private') -----
withPragmasIn: aClass do: aBlock
aClass selectorsAndMethodsDo: [ :selector :method | method pragmas do: aBlock ].!
----- Method: Pragma>>analogousCodeTo: (in category 'comparing') -----
analogousCodeTo: anObject
^self class == anObject class
and: [keyword == anObject keyword
and: [arguments = anObject arguments]]!
----- Method: Pragma>>argumentAt: (in category 'accessing-pragma') -----
argumentAt: anInteger
"Answer one of the arguments of the pragma."
^ self arguments at: anInteger.!
----- 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!
----- Method: Pragma>>hasLiteral: (in category 'testing') -----
hasLiteral: aLiteral
^keyword == aLiteral
or: [arguments hasLiteral: aLiteral]!
----- 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]!
----- 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!
----- 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!
----- Method: Pragma>>message (in category 'accessing-pragma') -----
message
"Answer the message of the receiving pragma."
^ Message selector: self keyword arguments: self arguments. !
----- Method: Pragma>>method (in category 'accessing-method') -----
method
"Answer the compiled-method containing the pragma."
^ method!
----- Method: Pragma>>methodClass (in category 'accessing-method') -----
methodClass
"Answer the class of the method containing the pragma."
^ method methodClass!
----- Method: Pragma>>numArgs (in category 'accessing-pragma') -----
numArgs
"Answer the number of arguments in the pragma."
^ self arguments size.!
----- 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: $>.!
----- 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!
----- Method: Pragma>>setArguments: (in category 'initialization') -----
setArguments: anArray
arguments := anArray!
----- Method: Pragma>>setKeyword: (in category 'initialization') -----
setKeyword: aSymbol
keyword := aSymbol!
----- Method: Pragma>>setMethod: (in category 'initialization') -----
setMethod: aCompiledMethod
method := aCompiledMethod!
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.!
----- Method: ProcessorScheduler class>>idleProcess (in category 'background process') -----
idleProcess
"A default background process which is invisible."
[true] whileTrue:
[self relinquishProcessorForMicroseconds: 1000]!
----- 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."!
----- 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'!
----- 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"
!
----- Method: ProcessorScheduler class>>startUp (in category 'background process') -----
startUp
"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 installLowSpaceWatcher.
BackgroundProcess == nil ifFalse: [BackgroundProcess terminate].
BackgroundProcess _ [self idleProcess] newProcess.
BackgroundProcess priority: SystemRockBottomPriority.
BackgroundProcess resume.
!
----- Method: ProcessorScheduler class>>sweepHandIdleProcess (in category 'background process') -----
sweepHandIdleProcess
"A default background process which shows a sweeping circle of XOR-ed bits on the screen."
| sweepHand |
sweepHand _ Pen new.
sweepHand defaultNib: 2.
sweepHand combinationRule: 6.
[true] whileTrue: [
2 timesRepeat: [
sweepHand north.
36 timesRepeat: [
sweepHand place: Display boundingBox topRight + (-25 at 25).
sweepHand go: 20.
sweepHand turn: 10]].
self relinquishProcessorForMicroseconds: 10000].
!
----- Method: ProcessorScheduler>>activePriority (in category 'accessing') -----
activePriority
"Answer the priority level of the currently running Process."
^activeProcess priority!
----- Method: ProcessorScheduler>>activeProcess (in category 'accessing') -----
activeProcess
"Answer the currently running Process."
^activeProcess!
----- Method: ProcessorScheduler>>anyProcessesAbove: (in category 'private') -----
anyProcessesAbove: highestPriority
"Do any instances of Process exist with higher priorities?"
^(Process allInstances "allSubInstances" select: [:aProcess |
aProcess priority > highestPriority]) isEmpty
"If anyone ever makes a subclass of Process, be sure to use allSubInstances."!
----- Method: ProcessorScheduler>>backgroundProcess (in category 'accessing') -----
backgroundProcess
"Answer the background process"
^ BackgroundProcess!
----- 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!
----- Method: ProcessorScheduler>>highestPriority (in category 'accessing') -----
highestPriority
"Answer the number of priority levels currently available for use."
^quiescentProcessLists size!
----- 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!
----- 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!
----- Method: ProcessorScheduler>>lowestPriority (in category 'priority names') -----
lowestPriority
"Return the lowest priority that is allowed with the scheduler"
^SystemRockBottomPriority!
----- Method: ProcessorScheduler>>nextReadyProcess (in category 'CPU usage tally') -----
nextReadyProcess
quiescentProcessLists reverseDo: [ :list |
list isEmpty ifFalse: [ | proc |
proc _ list first.
proc suspendedContext ifNotNil: [ ^proc ]]].
^nil!
----- 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
!
----- 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"!
----- 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!
----- 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']!
----- 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]!
----- 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!
----- 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
!
----- 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 ]!
----- Method: ProcessorScheduler>>terminateActive (in category 'process state change') -----
terminateActive
"Terminate the process that is currently running."
activeProcess terminate!
----- Method: ProcessorScheduler>>timingPriority (in category 'priority names') -----
timingPriority
"Answer the priority at which the system processes keeping track of real
time should run."
^TimingPriority!
----- Method: ProcessorScheduler>>userBackgroundPriority (in category 'priority names') -----
userBackgroundPriority
"Answer the priority at which user background processes should run."
^UserBackgroundPriority!
----- 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!
----- Method: ProcessorScheduler>>userSchedulingPriority (in category 'priority names') -----
userSchedulingPriority
"Answer the priority at which the window scheduler should run."
^UserSchedulingPriority!
----- Method: ProcessorScheduler>>waitingProcessesAt: (in category 'accessing') -----
waitingProcessesAt: aPriority
"Return the list of processes at the given priority level."
^quiescentProcessLists at: aPriority!
----- 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!
Object subclass: #PseudoPoolVariable
instanceVariableNames: 'name getterBlock setterBlock'
classVariableNames: ''
poolDictionaries: ''
category: 'Kernel-Contexts'!
!PseudoPoolVariable commentStamp: '<historical>' prior: 0!
The values of pool and global variables (traditionally Associations) are fetched by sending #poolValue and set by sending #setInPool: which send #poolValue:. These sends are automatically added in by the Compiler (see PoolVarNode {code generation}). So any object can act like a pool variable. This class allows getter and setter blocks for poolValue and poolValue:.!
----- Method: PseudoPoolVariable>>canAssign (in category 'as yet unclassified') -----
canAssign
^ setterBlock notNil!
----- Method: PseudoPoolVariable>>getter: (in category 'as yet unclassified') -----
getter: block
getterBlock _ block!
----- Method: PseudoPoolVariable>>name (in category 'as yet unclassified') -----
name
^ name!
----- Method: PseudoPoolVariable>>name: (in category 'as yet unclassified') -----
name: string
name _ string!
----- Method: PseudoPoolVariable>>setter: (in category 'as yet unclassified') -----
setter: block
setterBlock _ block!
----- Method: PseudoPoolVariable>>value (in category 'as yet unclassified') -----
value
^ getterBlock value!
----- Method: PseudoPoolVariable>>value: (in category 'as yet unclassified') -----
value: obj
setterBlock value: obj!
Object subclass: #Random
instanceVariableNames: 'seed a m q r'
classVariableNames: ''
poolDictionaries: ''
category: 'Kernel-Numbers'!
!Random commentStamp: 'md 4/26/2003 16:32' prior: 0!
This Random Number Generator graciously contributed by David N. Smith. It is an adaptation of the Park-Miller RNG which uses Floats to avoid the need for LargeInteger arithmetic.
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!
----- 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 slot |
nbuckets := 20.
buckets := Array new: nbuckets.
buckets atAllPut: 0.
ntrys := 100.
ntrys*nbuckets timesRepeat: [
slot := (randy next * nbuckets) floor + 1.
buckets at: slot put: (buckets at: slot) + 1 ].
Transcript cr.
1 to: nbuckets do: [ :nb |
Transcript show: (buckets at: nb) printString, ' ' ]!
----- Method: Random class>>seed: (in category 'instance creation') -----
seed: anInteger
^self new seed: anInteger!
----- Method: Random class>>theItsCompletelyBrokenTest (in category 'testing') -----
theItsCompletelyBrokenTest
"Random theItsCompletelyBrokenTest"
"The above should print as...
(0.149243269650845 0.331633021743797 0.75619644800024 0.393701540023881 0.941783181364547 0.549929193942775 0.659962596213428 0.991354559078512 0.696074432551896 0.922987899707159 )
If they are not these values (accounting for precision of printing) then something is horribly wrong: DO NOT USE THIS CODE FOR ANYTHING. "
| rng |
rng := Random new.
rng seed: 2345678901.
^ (1 to: 10) collect: [:i | rng next]!
----- Method: Random>>check: (in category 'die rolling') -----
check: nDice
"Roll some dice, WoD-style."
^ self check: nDice difficulty: 6!
----- Method: Random>>check:against: (in category 'die rolling') -----
check: nAttack against: nDefend
"Roll some dice, WoD-style."
^ self check: nAttack against: nDefend difficulty: 6!
----- 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!
----- Method: Random>>check:difficulty: (in category 'die rolling') -----
check: nDice difficulty: diff
"Roll some dice, WoD-style."
| result die |
result _ 0.
nDice timesRepeat:
[(die _ self nextInt: 10) = 1
ifTrue: [result _ result - 1]
ifFalse: [die >= diff ifTrue: [result _ result + 1]]].
^ result!
----- 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!
----- Method: Random>>initialize (in category 'initialization') -----
initialize
" Set a reasonable Park-Miller starting seed "
[seed := (Time millisecondClockValue bitAnd: 16r3FFFFFFF) bitXor: self hash.
seed = 0] whileTrue: ["Try again if ever get a seed = 0"].
a := 16r000041A7 asFloat. " magic constant = 16807 "
m := 16r7FFFFFFF asFloat. " magic constant = 2147483647 "
q := (m quo: a) asFloat.
r := (m \\ a) asFloat.
!
----- Method: Random>>next (in category 'accessing') -----
next
"Answer a random Float in the interval [0 to 1)."
^ (seed _ self nextValue) / m!
----- Method: Random>>next: (in category 'accessing') -----
next: anInteger
^ self next: anInteger into: (Array new: anInteger)!
----- Method: Random>>next:into: (in category 'accessing') -----
next: anInteger into: anArray
1 to: anInteger do: [:index | anArray at: index put: self next].
^ anArray!
----- Method: Random>>nextInt: (in category 'accessing') -----
nextInt: anInteger
"Answer a random integer in the interval [1, anInteger]."
^ (self next * anInteger) truncated + 1!
----- Method: Random>>nextValue (in category 'private') -----
nextValue
"This method generates random instances of Integer in the interval
0 to 16r7FFFFFFF. This method does NOT update the seed; repeated sends
answer the same value.
The algorithm is described in detail in 'Random Number Generators:
Good Ones Are Hard to Find' by Stephen K. Park and Keith W. Miller
(Comm. Asso. Comp. Mach., 31(10):1192--1201, 1988)."
| lo hi aLoRHi answer |
hi _ (seed quo: q) asFloat.
lo _ seed - (hi * q). " = seed rem: q"
aLoRHi _ (a * lo) - (r * hi).
answer _ (aLoRHi > 0.0)
ifTrue: [aLoRHi]
ifFalse: [aLoRHi + m].
^ answer!
----- 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 dice range res token |
stream _ diceString readStream.
result _ 0.
op _ #+.
[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!
----- Method: Random>>seed (in category 'private') -----
seed
^ seed!
----- Method: Random>>seed: (in category 'initialization') -----
seed: anInteger
seed _ anInteger!
Object subclass: #Stopwatch
instanceVariableNames: 'timespans state'
classVariableNames: ''
poolDictionaries: ''
category: 'Kernel-Chronology'!
!Stopwatch commentStamp: '<historical>' prior: 0!
A Stopwatch maintains a collection of timespans.!
----- Method: Stopwatch>>activate (in category 'squeak protocol') -----
activate
self isSuspended ifTrue:
[self timespans add:
(Timespan starting: DateAndTime now duration: Duration zero).
self state: #active]
!
----- Method: Stopwatch>>duration (in category 'squeak protocol') -----
duration
| ts last |
self isSuspended
ifTrue:
[ (ts _ self timespans) isEmpty ifTrue:
[ ts _ { Timespan starting: DateAndTime now duration: Duration zero } ] ]
ifFalse:
[ last _ self timespans last.
ts _ self timespans allButLast
add: (last duration: (DateAndTime now - last start); yourself);
yourself ].
^ (ts collect: [ :t | t duration ]) sum
!
----- Method: Stopwatch>>end (in category 'squeak protocol') -----
end
^ self timespans last next
!
----- Method: Stopwatch>>isActive (in category 'squeak protocol') -----
isActive
^ self state = #active
!
----- Method: Stopwatch>>isSuspended (in category 'squeak protocol') -----
isSuspended
^ self state = #suspended
!
----- Method: Stopwatch>>printOn: (in category 'squeak protocol') -----
printOn: aStream
super printOn: aStream.
aStream
nextPut: $(;
nextPutAll: self state;
nextPut: $:;
print: self duration;
nextPut: $).
!
----- Method: Stopwatch>>reActivate (in category 'squeak protocol') -----
reActivate
self
suspend;
activate.
!
----- Method: Stopwatch>>reset (in category 'squeak protocol') -----
reset
self suspend.
timespans _ nil.
!
----- Method: Stopwatch>>start (in category 'squeak protocol') -----
start
^ self timespans first start
!
----- Method: Stopwatch>>state (in category 'squeak protocol') -----
state
^ state ifNil: [ state _ #suspended ]
!
----- Method: Stopwatch>>state: (in category 'squeak protocol') -----
state: aSymbol
state _ aSymbol
!
----- Method: Stopwatch>>suspend (in category 'squeak protocol') -----
suspend
| ts |
self isActive ifTrue:
[ ts _ self timespans last.
ts duration: (DateAndTime now - ts start).
self state: #suspended]
!
----- Method: Stopwatch>>timespans (in category 'squeak protocol') -----
timespans
^ timespans ifNil: [ timespans _ OrderedCollection new ]
!
Object subclass: #UndefinedObject
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Kernel-Objects'!
!UndefinedObject commentStamp: '<historical>' prior: 0!
I describe the behavior of my sole instance, nil. nil represents a prior value for variables that have not been initialized, or for results which are meaningless.!
----- Method: UndefinedObject class>>initializedInstance (in category 'instance creation') -----
initializedInstance
^ nil!
----- Method: UndefinedObject class>>new (in category 'instance creation') -----
new
self error: 'You may not create any more undefined objects--use nil'!
----- Method: UndefinedObject>>addDependent: (in category 'dependents access') -----
addDependent: ignored
"Refer to the comment in Object|dependents."
self error: 'Nil should not have dependents'!
----- Method: UndefinedObject>>addSubclass: (in category 'class hierarchy') -----
addSubclass: aClass
"Ignored -- necessary to support disjoint class hierarchies"!
----- Method: UndefinedObject>>canHandleSignal: (in category 'bottom context') -----
canHandleSignal: exception
"When no more handler (on:do:) context left in sender chain this gets called"
^ false!
----- Method: UndefinedObject>>clone (in category 'copying') -----
clone
"Only one instance of UndefinedObject should ever be made, so answer
with self."!
----- Method: UndefinedObject>>deepCopy (in category 'copying') -----
deepCopy
"Only one instance of UndefinedObject should ever be made, so answer
with self."!
----- Method: UndefinedObject>>descriptionForPartsBin (in category 'parts bin') -----
descriptionForPartsBin
"Answer a description of this class for the parts bin."
^ self partName: 'ClipboardText' translatedNoop
categories: #()
documentation: 'This object will always show whatever is on the text clipboard, in a scrollable pane.' translatedNoop!
----- Method: UndefinedObject>>environment (in category 'class hierarchy') -----
environment
"Necessary to support disjoint class hierarchies."
^self class environment!
----- Method: UndefinedObject>>from3DS: (in category '3ds parser support') -----
from3DS: aDictionary
^aDictionary!
----- Method: UndefinedObject>>haltIfNil (in category 'testing') -----
haltIfNil
self halt!
----- Method: UndefinedObject>>handleSignal: (in category 'bottom context') -----
handleSignal: exception
"When no more handler (on:do:) context left in sender chain this gets called. Return from signal with default action."
^ exception resumeUnchecked: exception defaultAction!
----- Method: UndefinedObject>>ifNil: (in category 'testing') -----
ifNil: aBlock
"A convenient test, in conjunction with Object ifNil:"
^ aBlock value!
----- Method: UndefinedObject>>ifNil:ifNotNil: (in category 'testing') -----
ifNil: nilBlock ifNotNil: ifNotNilBlock
"Evaluate the block for nil because I'm == nil"
^ nilBlock value!
----- Method: UndefinedObject>>ifNil:ifNotNilDo: (in category 'testing') -----
ifNil: nilBlock ifNotNilDo: ifNotNilBlock
"Evaluate the block for nil because I'm == nil"
^ nilBlock value!
----- Method: UndefinedObject>>ifNotNil: (in category 'testing') -----
ifNotNil: aBlock
"A convenient test, in conjunction with Object ifNotNil:"
^ self!
----- Method: UndefinedObject>>ifNotNil:ifNil: (in category 'testing') -----
ifNotNil: ifNotNilBlock ifNil: nilBlock
"If I got here, I am nil, so evaluate the block nilBlock"
^ nilBlock value!
----- Method: UndefinedObject>>ifNotNilDo: (in category 'testing') -----
ifNotNilDo: aBlock
"Override to do nothing."
^ self
!
----- Method: UndefinedObject>>ifNotNilDo:ifNil: (in category 'testing') -----
ifNotNilDo: ifNotNilBlock ifNil: nilBlock
"If I got here, I am nil, so evaluate the block nilBlock"
^ nilBlock value!
----- Method: UndefinedObject>>isEmptyOrNil (in category 'testing') -----
isEmptyOrNil
"Answer whether the receiver contains any elements, or is nil. Useful in numerous situations where one wishes the same reaction to an empty collection or to nil"
^ true!
----- Method: UndefinedObject>>isLiteral (in category 'testing') -----
isLiteral
^ true!
----- Method: UndefinedObject>>isNil (in category 'testing') -----
isNil
"Refer to the comment in Object|isNil."
^true!
----- Method: UndefinedObject>>literalScannedAs:notifying: (in category 'class hierarchy') -----
literalScannedAs: scannedLiteral notifying: requestor
^ scannedLiteral!
----- Method: UndefinedObject>>notNil (in category 'testing') -----
notNil
"Refer to the comment in Object|notNil."
^false!
----- Method: UndefinedObject>>printOn: (in category 'printing') -----
printOn: aStream
"Refer to the comment in Object|printOn:."
aStream nextPutAll: 'nil'!
----- Method: UndefinedObject>>release (in category 'dependents access') -----
release
"Nil release is a no-op"!
----- Method: UndefinedObject>>removeSubclass: (in category 'class hierarchy') -----
removeSubclass: aClass
"Ignored -- necessary to support disjoint class hierarchies"!
----- Method: UndefinedObject>>shallowCopy (in category 'copying') -----
shallowCopy
"Only one instance of UndefinedObject should ever be made, so answer
with self."!
----- Method: UndefinedObject>>storeOn: (in category 'printing') -----
storeOn: aStream
"Refer to the comment in Object|storeOn:."
aStream nextPutAll: 'nil'!
----- Method: UndefinedObject>>subclass:instanceVariableNames:classVariableNames:poolDictionaries:category: (in category 'class hierarchy') -----
subclass: nameOfClass
instanceVariableNames: instVarNames
classVariableNames: classVarNames
poolDictionaries: poolDictnames
category: category
"Calling this method is now considered an accident. If you really want to create a class with a nil superclass, then create the class and then set the superclass using #superclass:"
Transcript show: ('Attempt to create ', nameOfClass, ' as a subclass of nil. Possibly a class is being loaded before its superclass.'); cr.
^ProtoObject
subclass: nameOfClass
instanceVariableNames: instVarNames
classVariableNames: classVarNames
poolDictionaries: poolDictnames
category: category
!
----- Method: UndefinedObject>>subclassDefinerClass (in category 'class hierarchy') -----
subclassDefinerClass
"For disjunct class hierarchies -- how should subclasses of nil be evaluated"
^Compiler!
----- Method: UndefinedObject>>subclasses (in category 'class hierarchy') -----
subclasses
"Return all the subclasses of nil"
| classList |
classList _ WriteStream on: Array new.
self subclassesDo:[:class| classList nextPut: class].
^classList contents!
----- Method: UndefinedObject>>subclassesDo: (in category 'class hierarchy') -----
subclassesDo: aBlock
"Evaluate aBlock with all subclasses of nil."
^Class subclassesDo:[:cl|
cl isMeta ifTrue:[aBlock value: cl soleInstance]].!
----- Method: UndefinedObject>>subclassesDoGently: (in category 'class hierarchy') -----
subclassesDoGently: aBlock
"Evaluate aBlock with all subclasses of nil. Others are not direct subclasses of Class."
^ Class subclassesDoGently: [:cl |
cl isMeta ifTrue: [aBlock value: cl soleInstance]].!
----- Method: UndefinedObject>>suspend (in category 'dependents access') -----
suspend
"Kills off processes that didn't terminate properly"
"Display reverse; reverse." "<-- So we can catch the suspend bug"
Processor terminateActive!
----- Method: UndefinedObject>>typeOfClass (in category 'class hierarchy') -----
typeOfClass
"Necessary to support disjoint class hierarchies."
^#normal!
----- Method: UndefinedObject>>veryDeepCopyWith: (in category 'copying') -----
veryDeepCopyWith: deepCopier
"Return self. I can't be copied. Do not record me."!
Object weakSubclass: #WeakMessageSend
instanceVariableNames: 'selector shouldBeNil arguments'
classVariableNames: ''
poolDictionaries: ''
category: 'Kernel-Objects'!
----- Method: WeakMessageSend class>>new (in category 'instance creation') -----
new
^self new: 1
!
----- Method: WeakMessageSend class>>receiver:selector: (in category 'instance creation') -----
receiver: anObject selector: aSymbol
^ self receiver: anObject selector: aSymbol arguments: #()
!
----- Method: WeakMessageSend class>>receiver:selector:argument: (in category 'instance creation') -----
receiver: anObject selector: aSymbol argument: aParameter
^ self receiver: anObject selector: aSymbol arguments: (Array with: aParameter)
!
----- Method: WeakMessageSend class>>receiver:selector:arguments: (in category 'instance creation') -----
receiver: anObject selector: aSymbol arguments: anArray
^ self new
receiver: anObject;
selector: aSymbol;
arguments: anArray
!
----- Method: WeakMessageSend>>= (in category 'comparing') -----
= anObject
"Compare equal to equivalent MessageSend"
^ anObject isMessageSend
and: [self receiver == anObject receiver
and: [selector == anObject selector
and: [(Array withAll: arguments) = (Array withAll: anObject arguments)]]]
!
----- Method: WeakMessageSend>>arguments (in category 'accessing') -----
arguments
^arguments ifNil: [ Array new ]
!
----- Method: WeakMessageSend>>arguments: (in category 'accessing') -----
arguments: anArray
arguments _ WeakArray withAll: anArray.
"no reason this should be a WeakArray"
shouldBeNil _ Array withAll: (anArray collect: [ :ea | ea isNil ]).
!
----- Method: WeakMessageSend>>asMessageSend (in category 'converting') -----
asMessageSend
^MessageSend receiver: self receiver selector: selector arguments: (Array withAll: self arguments)
!
----- Method: WeakMessageSend>>asMinimalRepresentation (in category 'converting') -----
asMinimalRepresentation
self isReceiverOrAnyArgumentGarbage
ifTrue: [^nil]
ifFalse:[^self].!
----- Method: WeakMessageSend>>collectArguments: (in category 'private') -----
collectArguments: anArgArray
"Private"
| staticArgs |
staticArgs := self arguments.
^(anArgArray size = staticArgs size)
ifTrue: [anArgArray]
ifFalse:
[(staticArgs isEmpty
ifTrue: [ staticArgs := Array new: selector numArgs]
ifFalse: [staticArgs copy] )
replaceFrom: 1
to: (anArgArray size min: staticArgs size)
with: anArgArray
startingAt: 1]
!
----- Method: WeakMessageSend>>ensureArguments (in category 'private') -----
ensureArguments
"Return true if my arguments haven't gone away"
arguments ifNotNil: [
arguments with: shouldBeNil do: [ :arg :flag |
arg ifNil: [ flag ifFalse: [ ^false ]]
]
].
^true
!
----- Method: WeakMessageSend>>ensureReceiver (in category 'private') -----
ensureReceiver
"Return true if my receiver hasn't gone away"
^self receiver notNil
!
----- Method: WeakMessageSend>>ensureReceiverAndArguments (in category 'private') -----
ensureReceiverAndArguments
"Return true if my receiver hasn't gone away"
self receiver ifNil: [ ^false ].
"Make sure that my arguments haven't gone away"
arguments ifNotNil: [
arguments with: shouldBeNil do: [ :arg :flag |
arg ifNil: [ flag ifFalse: [ ^false ]]
]
].
^true
!
----- Method: WeakMessageSend>>hash (in category 'comparing') -----
hash
"work like MessageSend>>hash"
^self receiver hash bitXor: selector hash
!
----- Method: WeakMessageSend>>isAnyArgumentGarbage (in category 'private') -----
isAnyArgumentGarbage
"Make sure that my arguments haven't gone away"
arguments ifNotNil: [
arguments with: shouldBeNil do: [ :arg :flag |
(flag not and: [arg isNil])
ifTrue: [^true]
]
].
^false
!
----- Method: WeakMessageSend>>isMessageSend (in category 'testing') -----
isMessageSend
^true
!
----- Method: WeakMessageSend>>isReceiverGarbage (in category 'private') -----
isReceiverGarbage
"Make sure that my receiver hasn't gone away"
^self receiver isNil
!
----- Method: WeakMessageSend>>isReceiverOrAnyArgumentGarbage (in category 'private') -----
isReceiverOrAnyArgumentGarbage
"Make sure that my receiver hasn't gone away"
^self isReceiverGarbage
or: [self isAnyArgumentGarbage]
!
----- Method: WeakMessageSend>>isValid (in category 'testing') -----
isValid
^self isReceiverOrAnyArgumentGarbage not
!
----- Method: WeakMessageSend>>printOn: (in category 'printing') -----
printOn: aStream
aStream
nextPutAll: self class name;
nextPut: $(.
selector printOn: aStream.
aStream nextPutAll: ' -> '.
self receiver printOn: aStream.
aStream nextPut: $)
!
----- Method: WeakMessageSend>>receiver (in category 'accessing') -----
receiver
^self at: 1
!
----- Method: WeakMessageSend>>receiver: (in category 'accessing') -----
receiver: anObject
self at: 1 put: anObject
!
----- Method: WeakMessageSend>>selector (in category 'accessing') -----
selector
^selector
!
----- Method: WeakMessageSend>>selector: (in category 'accessing') -----
selector: aSymbol
selector _ aSymbol
!
----- Method: WeakMessageSend>>value (in category 'evaluating') -----
value
^ arguments isNil
ifTrue: [self ensureReceiver
ifTrue: [self receiver perform: selector] ifFalse: []]
ifFalse: [self ensureReceiverAndArguments
ifTrue: [self receiver
perform: selector
withArguments: (Array withAll: arguments)] ifFalse: []]!
----- Method: WeakMessageSend>>valueWithArguments: (in category 'evaluating') -----
valueWithArguments: anArray
self ensureReceiverAndArguments ifFalse: [ ^nil ].
^ self receiver
perform: selector
withArguments: (self collectArguments: anArray)!
----- Method: WeakMessageSend>>valueWithEnoughArguments: (in category 'evaluating') -----
valueWithEnoughArguments: anArray
"call the selector with enough arguments from arguments and anArray"
| args |
self ensureReceiverAndArguments ifFalse: [ ^nil ].
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.
].
^ self receiver perform: selector withArguments: args
!
ProtoObject subclass: #ObjectOut
instanceVariableNames: 'url page recursionFlag'
classVariableNames: ''
poolDictionaries: ''
category: 'Kernel-Objects'!
!ObjectOut commentStamp: '<historical>' prior: 0!
I am a stand-in for an object that is out on the disk. The object that is out on the disk is the head of a tree of objects that are out. See SqueakPage.
When any message is sent to me, I don't understand it, and bring in my true object. I become myself with the objects and resend the message.
I may not represent the object nil.
The file is represented as a url, and that url may point at any file on the net.
page is a SqueakPage.
If the cache already has an object, widely in use, that claims to be the object for my url, what do I do? I can't become him, since others believe that he is the true object. Run through memory and replace refs to me with refs to him. Be careful not to trigger a fault. Become me to a string, then find pointers and replace?
[[[They don't want to end up holding an ObjectOut. (would oscillate back and forth) This is a problem. A user could bring in two trees that both refer to a 3rd url. (check with cache before installing any new ObjectOut) Two trees could be written to the same url.
Or, I remain an ObjectOut, and keep getting notUnderstood, and keep returning the other guy.
Or I smash the cache, and install MY page and object. Other guy is a copy -- still in, but with no place in the cache. When we both write to the same url, there will be trouble.] No -- search and replace.]]]
!
----- Method: ObjectOut>>comeFullyUpOnReload: (in category 'object storage') -----
comeFullyUpOnReload: smartRefStream
"Normally this read-in object is exactly what we want to store. Try to dock first. If it is here already, use that one."
| sp |
"Transcript show: 'has ref to: ', url; cr."
(sp _ SqueakPageCache pageCache at: page ifAbsent: [nil]) ifNotNil: [
sp isContentsInMemory ifTrue: [^ sp contentsMorph]].
^ self!
----- Method: ObjectOut>>doesNotUnderstand: (in category 'fetch from disk') -----
doesNotUnderstand: aMessage
"Bring in the object, install, then resend aMessage"
| realObject oldFlag response |
oldFlag _ recursionFlag.
recursionFlag _ true.
"fetch the object"
realObject _ self xxxFetch. "watch out for the become!!"
"Now we ARE the realObject"
oldFlag == true ifTrue: [
response _ (PopUpMenu labels: 'proceed normally\debug' withCRs)
startUpWithCaption: 'Object being fetched for a second time.
Should not happen, and needs to be fixed later.'.
response = 2 ifTrue: [self halt]]. "We are already the new object"
"Can't be a super message, since this is the first message sent to this object"
^ realObject perform: aMessage selector withArguments: aMessage arguments!
----- Method: ObjectOut>>isInMemory (in category 'basics') -----
isInMemory
"We are a place holder for an object that is out."
^ false!
----- Method: ObjectOut>>objectForDataStream: (in category 'object storage') -----
objectForDataStream: refStrm
"Return an object to store on a data stream (externalize myself)."
^ self!
----- Method: ObjectOut>>readDataFrom:size: (in category 'object storage') -----
readDataFrom: aDataStream size: varsOnDisk
"Make self be an object based on the contents of aDataStream, which was generated by the object's storeDataOn: method. Return self."
| cntInstVars |
cntInstVars _ self xxxClass instSize.
self xxxClass isVariable
ifTrue: [self xxxClass error: 'needs updating'] "assume no variable subclasses"
ifFalse: [cntInstVars _ varsOnDisk].
aDataStream beginReference: self.
1 to: cntInstVars do:
[:i | self xxxInstVarAt: i put: aDataStream next].
" 1 to: cntIndexedVars do:
[:i | self basicAt: i put: aDataStream next].
"
^ self!
----- Method: ObjectOut>>storeDataOn: (in category 'object storage') -----
storeDataOn: aDataStream
"Store myself on a DataStream. See also objectToStoreOnDataStream.
must send 'aDataStream beginInstance:size:'"
| cntInstVars |
cntInstVars _ self class instSize.
"cntIndexedVars _ self basicSize."
aDataStream
beginInstance: self xxxClass
size: cntInstVars "+ cntIndexedVars".
1 to: cntInstVars do:
[:i | aDataStream nextPut: (self xxxInstVarAt: i)].
" 1 to: cntIndexedVars do:
[:i | aDataStream nextPut: (self basicAt: i)]
"!
----- Method: ObjectOut>>url: (in category 'access') -----
url: aString
url _ aString!
----- Method: ObjectOut>>veryDeepCopyWith: (in category 'object storage') -----
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 absent |
new _ deepCopier references at: self ifAbsent: [absent _ true].
absent ifNil: [^ new]. "already done"
class _ self xxxClass.
class isMeta ifTrue: [^ self]. "a class"
new _ self xxxClone.
"not a uniClass"
deepCopier references at: self put: new. "remember"
"class is not variable"
index _ class instSize.
[index > 0] whileTrue:
[sub _ self xxxInstVarAt: index.
(subAss _ deepCopier references associationAt: sub ifAbsent: [nil])
ifNil: [new xxxInstVarAt: index put: (sub veryDeepCopyWith: deepCopier)]
ifNotNil: [new xxxInstVarAt: index put: subAss value].
index _ index - 1].
new rehash. "force Sets and Dictionaries to rehash"
^ new
!
----- Method: ObjectOut>>xxxClass (in category 'basics') -----
xxxClass
"Primitive. Answer the object which is the receiver's class. Essential. See
Object documentation whatIsAPrimitive."
<primitive: 111>
self primitiveFailed!
----- Method: ObjectOut>>xxxClone (in category 'basics') -----
xxxClone
<primitive: 148>
self primitiveFailed!
----- Method: ObjectOut>>xxxFetch (in category 'fetch from disk') -----
xxxFetch
"Bring in my object and replace all references to me with references to him. First try looking up my url in the pageCache. Then try the page (and install it, under its url). Then start from scratch with the url."
| truePage object existing |
existing _ SqueakPageCache pageCache at: url ifAbsent: [nil].
existing ifNotNil: [existing isContentsInMemory
ifTrue: [page _ truePage _ existing]]. "This url already has an object in this image"
truePage ifNil: [
truePage _ SqueakPageCache atURL: url oldPage: page].
object _ truePage isContentsInMemory
ifTrue: [truePage contentsMorph]
ifFalse: [truePage fetchInformIfError]. "contents, not the page"
"Later, collect pointers to object and fix them up. Not scan memory"
object ifNil: [^ 'Object could not be fetched.'].
"recursionFlag _ false." "while I still have a pointer to myself"
truePage contentsMorph: object.
page _ truePage.
self xxxFixup.
^ object "the final object!!"
!
----- Method: ObjectOut>>xxxFixup (in category 'fetch from disk') -----
xxxFixup
"There is already an object in memory for my url. All pointers to me need to be pointers to him. Can't use become, because other pointers to him must stay valid."
| real temp list |
real _ page contentsMorph.
real == self ifTrue: [page error: 'should be converted by now'].
temp _ self.
list _ (PointerFinder pointersTo: temp) asOrderedCollection.
list add: thisContext. list add: thisContext sender.
list do: [:holder |
1 to: holder class instSize do:
[:i | (holder instVarAt: i) == temp ifTrue: [holder instVarAt: i put: real]].
1 to: holder basicSize do:
[:i | (holder basicAt: i) == temp ifTrue: [holder basicAt: i put: real]].
].
^ real!
----- Method: ObjectOut>>xxxInstVarAt: (in category 'basics') -----
xxxInstVarAt: 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>
self primitiveFailed !
----- Method: ObjectOut>>xxxInstVarAt:put: (in category 'basics') -----
xxxInstVarAt: 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>
self primitiveFailed !
----- Method: ObjectOut>>xxxReset (in category 'access') -----
xxxReset
"mark as never brought in"
recursionFlag _ nil!
----- Method: ObjectOut>>xxxSetUrl:page: (in category 'fetch from disk') -----
xxxSetUrl: aString page: aSqkPage
url _ aString.
page _ aSqkPage.!
----- Method: ProtoObject class>>initializedInstance (in category 'as yet unclassified') -----
initializedInstance
^ nil!
----- 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!
----- 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 a SmallInteger"
(Array with: self)
elementsExchangeIdentityWith:
(Array with: otherObject)!
----- 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!
----- 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]!
----- Method: ProtoObject>>doesNotUnderstand: (in category 'system primitives') -----
doesNotUnderstand: aMessage
^ MessageNotUnderstood new
message: aMessage;
receiver: self;
signal!
----- 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."!
----- 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!
----- Method: ProtoObject>>ifNil: (in category 'testing') -----
ifNil: nilBlock
"Return self, or evaluate the block if I'm == nil (q.v.)"
^ self!
----- Method: ProtoObject>>ifNil:ifNotNil: (in category 'testing') -----
ifNil: nilBlock ifNotNil: ifNotNilBlock
"Evaluate the block, unless I'm == nil (q.v.)"
^ ifNotNilBlock valueWithPossibleArgument: self!
----- Method: ProtoObject>>ifNotNil: (in category 'testing') -----
ifNotNil: ifNotNilBlock
"Evaluate the block, unless I'm == nil (q.v.)"
^ ifNotNilBlock valueWithPossibleArgs: {self}!
----- 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 valueWithPossibleArgument: self!
----- Method: ProtoObject>>initialize (in category 'initialize-release') -----
initialize
"Subclasses should redefine this method to perform initializations on instance creation"!
----- Method: ProtoObject>>isInMemory (in category 'testing') -----
isInMemory
"All normal objects are."
^ true!
----- Method: ProtoObject>>isNil (in category 'testing') -----
isNil
"Coerces nil to true and everything else to false."
^false!
----- 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!
----- 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.!
----- Method: ProtoObject>>pointsTo: (in category 'testing') -----
pointsTo: anObject
"This method returns true if self contains a pointer to anObject,
and returns 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!
----- 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"
!
----- 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:"!
----- 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:''>
^ ContextPart primitiveFailToken!
----- 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:''>
^ ContextPart primitiveFailToken!
----- 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:''>
^ ContextPart primitiveFailToken!
----- 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:''>
^ ContextPart primitiveFailToken!
----- 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:''>
^ ContextPart primitiveFailToken!
----- 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:''>
^ ContextPart primitiveFailToken!
----- 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:''>
^ ContextPart primitiveFailToken!
----- 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:''>
^ ContextPart primitiveFailToken!
----- 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:''>
^ ContextPart primitiveFailToken!
----- 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>
^ ContextPart primitiveFailToken!
----- 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)."
self == anObject
ifTrue: [^ false]
ifFalse: [^ true]!
nil variableSubclass: #PseudoContext
instanceVariableNames: 'fixed fields never accessed from smalltalk'
classVariableNames: ''
poolDictionaries: ''
category: 'Kernel-Methods'!
!PseudoContext commentStamp: '<historical>' prior: 0!
I represent cached context state within the virtual machine. I have the same format as normal method and block contexts, but my fields are never referenced directly from Smalltalk. Whenever a message is sent to me I will magically transform myself into a real context which will respond to all the usual messages.
I rely on the fact that block and method contexts have exactly the same number of fixed fields.!
----- Method: PseudoContext class>>contextCacheDepth (in category 'private') -----
contextCacheDepth
"Answer the number of entries in the context cache. This requires a little insider
knowledge. Not intended for casual use, which is why it's private protocol."
^self contextCacheDepth: thisContext yourself!
----- Method: PseudoContext class>>contextCacheDepth: (in category 'private') -----
contextCacheDepth: b
^b isPseudoContext
ifTrue: [1 + (self contextCacheDepth: b)]
ifFalse: [1]!
----- Method: PseudoContext class>>definition (in category 'filing out') -----
definition
"Our superclass is really nil, but this causes problems when we try to become compact
after filing in for the first time. Fake the superclass as Object, and repair the situation
during class initialisation."
| defn |
defn _ super definition.
^(defn beginsWith: 'nil ')
ifTrue: ['Object' , (defn copyFrom: 4 to: defn size)]
ifFalse: [defn].!
----- Method: PseudoContext class>>initialize (in category 'class initialization') -----
initialize
"It's tricky to do the necessary stuff with the regular file-in machinery."
PseudoContext superclass = nil
ifFalse: [
(Smalltalk confirm: 'Shall I convert PseudoContext into a compact subclass of nil?
("yes" is almost always the correct response)')
ifTrue: [
PseudoContext becomeCompact.
PseudoContext superclass removeSubclass: PseudoContext.
PseudoContext superclass: nil]].
Smalltalk recreateSpecialObjectsArray.
Smalltalk specialObjectsArray size = 41
ifFalse: [self error: 'Please check size of special objects array!!']!
----- Method: PseudoContext>>isPseudoContext (in category 'testing') -----
isPseudoContext
^true!
----- Method: PseudoContext>>nextObject (in category 'system primitives') -----
nextObject
"See Object>>nextObject."
<primitive: 139>
self primitiveFailed.!
SharedPool subclass: #ChronologyConstants
instanceVariableNames: 'seconds offset jdn nanos'
classVariableNames: 'DayNames DaysInMonth MonthNames NanosInMillisecond NanosInSecond SecondsInDay SecondsInHour SecondsInMinute SqueakEpoch'
poolDictionaries: ''
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.!
----- Method: ChronologyConstants class>>initialize (in category 'class initialization') -----
initialize
"ChronologyConstants initialize" SqueakEpoch _ 2415386. "Julian day number of 1 Jan 1901"
SecondsInDay _ 86400.
SecondsInHour _ 3600.
SecondsInMinute _ 60.
NanosInSecond _ 10 raisedTo: 9.
NanosInMillisecond _ 10 raisedTo: 6.
DayNames _ #(Sunday Monday Tuesday Wednesday Thursday Friday Saturday) translatedNoop.
MonthNames _ #(January February March April May June July
August September October November December) translatedNoop.
DaysInMonth _ #(31 28 31 30 31 30 31 31 30 31 30 31).
!
Timespan subclass: #Date
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: 'ChronologyConstants'
category: 'Kernel-Chronology'!
!Date commentStamp: '<historical>' prior: 0!
Instances of Date are Timespans with duration of 1 day.
Their default creation assumes a start of midnight in the local time zone.!
----- Method: Date class>>absoluteDaysToYear: (in category 'deprecated') -----
absoluteDaysToYear: gregorianYear
self deprecated: 'Deprecated'!
----- Method: Date class>>dateAndTimeNow (in category 'smalltalk-80') -----
dateAndTimeNow
"Answer an Array whose with Date today and Time now."
^ Time dateAndTimeNow!
----- Method: Date class>>dayOfWeek: (in category 'smalltalk-80') -----
dayOfWeek: dayName
^ Week indexOfDay: dayName!
----- Method: Date class>>daysInMonth:forYear: (in category 'smalltalk-80') -----
daysInMonth: monthName forYear: yearInteger
^ Month daysInMonth: monthName forYear: yearInteger.
!
----- Method: Date class>>daysInYear: (in category 'smalltalk-80') -----
daysInYear: yearInteger
^ Year daysInYear: yearInteger.!
----- Method: Date class>>firstWeekdayOfMonth:year: (in category 'smalltalk-80') -----
firstWeekdayOfMonth: month year: year
"Answer the weekday index of the first day in <month> in the <year>."
^ (self newDay: 1 month: month year: year) weekdayIndex
!
----- Method: Date class>>fromDays: (in category 'smalltalk-80') -----
fromDays: dayCount
"Days since 1 January 1901"
^ self julianDayNumber: dayCount + SqueakEpoch!
----- Method: Date class>>fromJulianDayNumber: (in category 'deprecated') -----
fromJulianDayNumber: aJulianDayNumber
self
deprecated: 'Deprecated';
julianDayNumber: aJulianDayNumber!
----- Method: Date class>>fromSeconds: (in category 'smalltalk-80') -----
fromSeconds: seconds
"Answer an instance of me which is 'seconds' seconds after January 1, 1901."
^ self fromDays: ((Duration seconds: seconds) days)!
----- Method: Date class>>fromString: (in category 'squeak protocol') -----
fromString: aString
"Answer an instance of created from a string with format dd.mm.yyyy."
^ self readFrom: aString readStream.
!
----- Method: Date class>>indexOfMonth: (in category 'smalltalk-80') -----
indexOfMonth: aMonthName
^ Month indexOfMonth: aMonthName.
!
----- Method: Date class>>julianDayNumber: (in category 'squeak protocol') -----
julianDayNumber: aJulianDayNumber
^ self starting: (DateAndTime julianDayNumber: aJulianDayNumber)!
----- Method: Date class>>leapYear: (in category 'smalltalk-80') -----
leapYear: yearInteger
^ Year leapYear: yearInteger!
----- Method: Date class>>nameOfDay: (in category 'smalltalk-80') -----
nameOfDay: dayIndex
^ Week nameOfDay: dayIndex !
----- Method: Date class>>nameOfMonth: (in category 'smalltalk-80') -----
nameOfMonth: anIndex
^ Month nameOfMonth: anIndex.
!
----- Method: Date class>>newDay:month:year: (in category 'smalltalk-80') -----
newDay: day month: month year: year
^ self year: year month: month day: day!
----- Method: Date class>>newDay:year: (in category 'smalltalk-80') -----
newDay: dayCount year: yearInteger
^ self year: yearInteger day: dayCount!
----- Method: Date class>>readFrom: (in category 'squeak protocol') -----
readFrom: aStream
"Read a Date from the stream in any of the forms:
<day> <monthName> <year> (5 April 1982; 5-APR-82)
<monthName> <day> <year> (April 5, 1982)
<monthNumber> <day> <year> (4/5/82)
<day><monthName><year> (5APR82)"
| day month year |
aStream peek isDigit
ifTrue: [day := Integer readFrom: aStream].
[aStream peek isAlphaNumeric]
whileFalse: [aStream skip: 1].
aStream peek isLetter
ifTrue: ["number/name... or name..."
month := WriteStream
on: (String new: 10).
[aStream peek isLetter]
whileTrue: [month nextPut: aStream next].
month := month contents.
day isNil
ifTrue: ["name/number..."
[aStream peek isAlphaNumeric]
whileFalse: [aStream skip: 1].
day := Integer readFrom: aStream]]
ifFalse: ["number/number..."
month := Month nameOfMonth: day.
day := Integer readFrom: aStream].
[aStream peek isAlphaNumeric]
whileFalse: [aStream skip: 1].
year := Integer readFrom: aStream.
year < 10 ifTrue: [year := 2000 + year]
ifFalse: [ year < 1900 ifTrue: [ year := 1900 + year]].
^ self
year: year
month: month
day: day!
----- Method: Date class>>starting: (in category 'squeak protocol') -----
starting: aDateAndTime
^super starting: (aDateAndTime midnight) duration: (Duration days: 1)
!
----- Method: Date class>>today (in category 'smalltalk-80') -----
today
^ self current!
----- Method: Date class>>tomorrow (in category 'squeak protocol') -----
tomorrow
^ self today next!
----- Method: Date class>>year:day: (in category 'squeak protocol') -----
year: year day: dayOfYear
^ self starting: (DateAndTime year: year day: dayOfYear)
!
----- Method: Date class>>year:month:day: (in category 'squeak protocol') -----
year: year month: month day: day
^ self starting: (DateAndTime year: year month: month day: day)
!
----- Method: Date class>>yearAndDaysFromDays:into: (in category 'deprecated') -----
yearAndDaysFromDays: days into: aTwoArgBlock
self deprecated: 'Deprecated'!
----- Method: Date class>>yesterday (in category 'squeak protocol') -----
yesterday
^ self today previous!
----- Method: Date>>addDays: (in category 'smalltalk-80') -----
addDays: dayCount
^ (self asDateAndTime + (dayCount days)) asDate!
----- Method: Date>>addMonths: (in category 'utils') -----
addMonths: monthCount
|year month maxDaysInMonth day |
year := self year + (monthCount + self monthIndex - 1 // 12).
month := self monthIndex + monthCount - 1 \\ 12 + 1.
maxDaysInMonth := Month daysInMonth: month forYear: year.
day := self dayOfMonth > maxDaysInMonth
ifTrue: [maxDaysInMonth]
ifFalse: [self dayOfMonth].
^ Date
newDay: day
month: month
year: year!
----- Method: Date>>asDate (in category 'squeak protocol') -----
asDate
^ self!
----- Method: Date>>asGregorian (in category 'deprecated') -----
asGregorian
"Return an array of integers #(dd mm yyyy)"
^ self
deprecated: 'Use #dayMonthYearDo:';
dayMonthYearDo: [ :d :m :y | { d. m. y } ]
!
----- Method: Date>>asJulianDayNumber (in category 'deprecated') -----
asJulianDayNumber
"Answer the julian date number of the receiver."
^ self asDateAndTime julianDayNumber!
----- Method: Date>>asSeconds (in category 'smalltalk-80') -----
asSeconds
"Answer the seconds since the Squeak epoch: 1 January 1901"
^ start asSeconds!
----- Method: Date>>day:year: (in category 'deprecated') -----
day: dayInteger year: yearInteger
^ self
deprecated: 'Obsolete'
!
----- Method: Date>>dayMonthYearDo: (in category 'squeak protocol') -----
dayMonthYearDo: aBlock
"Supply integers for day, month and year to aBlock and return the result"
^ start dayMonthYearDo: aBlock!
----- Method: Date>>daylightSavingsInEffect (in category 'deprecated') -----
daylightSavingsInEffect
"Return true if DST is observed at or after 2am on this day"
self deprecated: 'Deprecated'.
self dayMonthYearDo:
[ :day :month :year |
(month < 4 or: [month > 10]) ifTrue: [^ false]. "False November through March"
(month > 4 and: [month < 10]) ifTrue: [^ true]. "True May through September"
month = 4
ifTrue: ["It's April -- true on first Sunday or later"
day >= 7 ifTrue: [^ true]. "Must be after"
^ day > (self weekdayIndex \\ 7)]
ifFalse: ["It's October -- false on last Sunday or later"
day <= 24 ifTrue: [^ true]. "Must be before"
^ day <= (24 + (self weekdayIndex \\ 7))]]!
----- Method: Date>>daylightSavingsInEffectAtStandardHour: (in category 'deprecated') -----
daylightSavingsInEffectAtStandardHour: hour
"Return true if DST is observed at this very hour (standard time)"
"Note: this *should* be the kernel method, and daylightSavingsInEffect
should simply be self daylightSavingsInEffectAtHour: 3"
self deprecated: 'Deprecated'.
self daylightSavingsInEffect
ifTrue: [^ (self addDays: -1) daylightSavingsInEffect or: [hour >= 2]]
ifFalse: [^ (self addDays: -1) daylightSavingsInEffect and: [hour < 1]]!
----- Method: Date>>firstDayOfMonthIndex: (in category 'deprecated') -----
firstDayOfMonthIndex: monthIndex
^ self
deprecated: 'Obsolete'
!
----- Method: Date>>julianDayNumber: (in category 'deprecated') -----
julianDayNumber: anInteger
"Set the number of days elapsed since midnight GMT on January 1st, 4713 B.C."
self deprecated: 'Obsolete'.
!
----- Method: Date>>leap (in category 'smalltalk-80') -----
leap
"Answer whether the receiver's year is a leap year."
^ start isLeapYear ifTrue: [1] ifFalse: [0].!
----- Method: Date>>mmddyy (in category 'deprecated') -----
mmddyy
"Please use mmddyyyy instead, so dates in 2000 will be unambiguous"
^ self
deprecated: 'Use #mmddyyyy';
printFormat: #(2 1 3 $/ 1 2)
!
----- Method: Date>>mmddyyyy (in category 'printing') -----
mmddyyyy
"Answer the receiver rendered in standard U.S.A format mm/dd/yyyy.
Note that the name here is slightly misleading -- the month and day numbers don't show leading zeros,
so that for example February 1 1996 is 2/1/96"
^ self printFormat: #(2 1 3 $/ 1 1)!
----- Method: Date>>month (in category 'squeak protocol') -----
month
^ self asMonth!
----- Method: Date>>monthIndex (in category 'squeak protocol') -----
monthIndex
^ super month!
----- Method: Date>>onNextMonth (in category 'utils') -----
onNextMonth
^ self addMonths: 1
!
----- Method: Date>>onPreviousMonth (in category 'utils') -----
onPreviousMonth
^ self addMonths: -1
!
----- Method: Date>>previous: (in category 'smalltalk-80') -----
previous: dayName
"Answer the previous date whose weekday name is dayName."
| days |
days _ 7 + self weekdayIndex - (self class dayOfWeek: dayName) \\ 7.
days = 0 ifTrue: [ days _ 7 ].
^ self subtractDays: days
!
----- Method: Date>>printFormat: (in category 'printing') -----
printFormat: formatArray
"Answer a String describing the receiver using the argument formatArray."
| aStream |
aStream _ WriteStream on: (String new: 16).
self printOn: aStream format: formatArray.
^ aStream contents!
----- Method: Date>>printOn: (in category 'printing') -----
printOn: aStream
self printOn: aStream format: #(1 2 3 $ 3 1 )!
----- Method: Date>>printOn:format: (in category 'printing') -----
printOn: aStream format: formatArray
"Print a description of the receiver on aStream using the format
denoted the argument, formatArray:
#(item item item sep monthfmt yearfmt twoDigits)
items: 1=day 2=month 3=year will appear in the order given,
separated by sep which is eaither an ascii code or character.
monthFmt: 1=09 2=Sep 3=September
yearFmt: 1=1996 2=96
digits: (missing or)1=9 2=09.
See the examples in printOn: and mmddyy"
| gregorian twoDigits element monthFormat |
gregorian _ self dayMonthYearDo: [ :d :m :y | {d. m. y} ].
twoDigits _ formatArray size > 6 and: [(formatArray at: 7) > 1].
1 to: 3 do:
[ :i |
element := formatArray at: i.
element = 1
ifTrue: [twoDigits
ifTrue: [aStream
nextPutAll: (gregorian first asString
padded: #left
to: 2
with: $0)]
ifFalse: [gregorian first printOn: aStream]].
element = 2
ifTrue: [monthFormat := formatArray at: 5.
monthFormat = 1
ifTrue: [twoDigits
ifTrue: [aStream
nextPutAll: (gregorian middle asString
padded: #left
to: 2
with: $0)]
ifFalse: [gregorian middle printOn: aStream]].
monthFormat = 2
ifTrue: [aStream
nextPutAll: ((Month nameOfMonth: gregorian middle)
copyFrom: 1
to: 3)].
monthFormat = 3
ifTrue: [aStream
nextPutAll: (Month nameOfMonth: gregorian middle)]].
element = 3
ifTrue: [(formatArray at: 6)
= 1
ifTrue: [gregorian last printOn: aStream]
ifFalse: [aStream
nextPutAll: ((gregorian last \\ 100) asString
padded: #left
to: 2
with: $0)]].
i < 3
ifTrue: [(formatArray at: 4)
~= 0
ifTrue: [aStream nextPut: (formatArray at: 4) asCharacter]]]
!
----- Method: Date>>storeOn: (in category 'printing') -----
storeOn: aStream
aStream print: self printString; nextPutAll: ' asDate'!
----- Method: Date>>subtractDate: (in category 'smalltalk-80') -----
subtractDate: aDate
"Answer the number of days between self and aDate"
^ (self start - aDate asDateAndTime) days!
----- Method: Date>>subtractDays: (in category 'smalltalk-80') -----
subtractDays: dayCount
^ (self asDateAndTime - (dayCount days)) asDate!
----- Method: Date>>uniqueDateStringBetween:and: (in category 'deprecated') -----
uniqueDateStringBetween: aStart and: anEnd
"Return a String, with just enough information to distinguish it from other dates in the range."
"later, be more sophisticated"
self deprecated: 'Deprecated'.
aStart year + 1 >= anEnd year ifFalse: [^ self printFormat: #(1 2 3 $ 3 1)]. "full"
aStart week next >= anEnd week ifFalse: [^ self printFormat: #(2 1 9 $ 3 1)]. "May 6"
^ self weekday
!
----- Method: Date>>week (in category 'deprecated') -----
week
^ self
deprecated: 'Use #asWeek';
asWeek!
----- Method: Date>>weekday (in category 'smalltalk-80') -----
weekday
"Answer the name of the day of the week on which the receiver falls."
^ self dayOfWeekName!
----- Method: Date>>weekdayIndex (in category 'smalltalk-80') -----
weekdayIndex
"Sunday=1, ... , Saturday=7"
^ self dayOfWeek!
----- Method: Date>>yyyymmdd (in category 'printing') -----
yyyymmdd
"Format the date in ISO 8601 standard like '2002-10-22'."
^ self printFormat: #(3 2 1 $- 1 1 2)!
Magnitude subclass: #DateAndTime
instanceVariableNames: 'seconds offset jdn nanos'
classVariableNames: 'LocalTimeZone'
poolDictionaries: 'ChronologyConstants'
category: 'Kernel-Chronology'!
!DateAndTime commentStamp: 'brp 5/13/2003 08:07' 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.
The nanosecond attribute is almost always zero but it defined for full ISO compliance and is suitable for timestamping.
!
----- Method: DateAndTime class>>clockPrecision (in category 'ansi protocol') -----
clockPrecision
"One nanosecond precision"
^ Duration nanoSeconds: 1
!
----- Method: DateAndTime class>>current (in category 'squeak protocol') -----
current
^ self now
!
----- Method: DateAndTime class>>date:time: (in category 'squeak protocol') -----
date: aDate time: aTime
^ self
year: aDate year
day: aDate dayOfYear
hour: aTime hour
minute: aTime minute
second: aTime second
!
----- Method: DateAndTime class>>epoch (in category 'squeak protocol') -----
epoch
"Answer a DateAndTime representing the Squeak epoch: 1 January 1901"
^ self julianDayNumber: SqueakEpoch
!
----- Method: DateAndTime class>>fromSeconds: (in category 'smalltalk-80') -----
fromSeconds: seconds
"Answer a DateAndTime since the Squeak epoch: 1 January 1901"
| since |
since _ Duration days: SqueakEpoch hours: 0 minutes: 0 seconds: seconds.
^ self basicNew
ticks: since ticks offset: self localOffset;
yourself.
!
----- Method: DateAndTime class>>fromString: (in category 'squeak protocol') -----
fromString: aString
^ self readFrom: (ReadStream on: aString)
!
----- Method: DateAndTime class>>julianDayNumber: (in category 'squeak protocol') -----
julianDayNumber: aJulianDayNumber
^ self basicNew
ticks: aJulianDayNumber days ticks offset: self localOffset;
yourself
!
----- Method: DateAndTime class>>localOffset (in category 'squeak protocol') -----
localOffset
"Answer the duration we are offset from UTC"
^ self localTimeZone offset
!
----- Method: DateAndTime class>>localTimeZone (in category 'accessing') -----
localTimeZone
"Answer the local time zone"
^ LocalTimeZone ifNil: [ LocalTimeZone _ TimeZone default ]
!
----- Method: DateAndTime class>>localTimeZone: (in category 'accessing') -----
localTimeZone: aTimeZone
"Set the local time zone"
"
DateAndTime localTimeZone: (TimeZone offset: 0 hours name: 'Universal Time' abbreviation: 'UTC').
DateAndTime localTimeZone: (TimeZone offset: -8 hours name: 'Pacific Standard Time' abbreviation: 'PST').
"
LocalTimeZone := aTimeZone
!
----- Method: DateAndTime class>>midnight (in category 'squeak protocol') -----
midnight
^ self now midnight
!
----- Method: DateAndTime class>>millisecondClockValue (in category 'smalltalk-80') -----
millisecondClockValue
^ Time millisecondClockValue!
----- Method: DateAndTime class>>new (in category 'squeak protocol') -----
new
"Answer a DateAndTime representing the Squeak epoch: 1 January 1901"
^ self epoch
!
----- Method: DateAndTime class>>noon (in category 'squeak protocol') -----
noon
^ self now noon!
----- Method: DateAndTime class>>now (in category 'ansi protocol') -----
now
^ self basicNew
ticks: (Duration
days: SqueakEpoch
hours: 0
minutes: 0
seconds: self totalSeconds
nanoSeconds: 0) ticks
offset: self localOffset;
yourself
!
----- Method: DateAndTime class>>readFrom: (in category 'squeak protocol') -----
readFrom: aStream
| bc year month day hour minute second nanos offset buffer ch |
aStream peek = $- ifTrue: [ aStream next. bc _ -1] ifFalse: [bc _ 1].
year _ (aStream upTo: $-) asInteger * bc.
month _ (aStream upTo: $-) asInteger.
day _ (aStream upTo: $T) asInteger.
hour _ (aStream upTo: $:) asInteger.
buffer _ '00:'. ch _ nil.
minute _ WriteStream on: buffer.
[ aStream atEnd | (ch = $:) | (ch = $+) | (ch = $-) ]
whileFalse: [ ch _ minute nextPut: aStream next. ].
(ch isNil or: [ch isDigit]) ifTrue: [ ch _ $: ].
minute _ ((ReadStream on: buffer) upTo: ch) asInteger.
buffer _ '00.'.
second _ WriteStream on: buffer.
[ aStream atEnd | (ch = $.) | (ch = $+) | (ch = $-) ]
whileFalse: [ ch _ second nextPut: aStream next. ].
(ch isNil or: [ch isDigit]) ifTrue: [ ch _ $. ].
second _ ((ReadStream on: buffer) upTo: ch) asInteger.
buffer _ '00000000+'.
nanos _ WriteStream on: buffer.
[ aStream atEnd | (ch = $+) | (ch = $-) ]
whileFalse: [ ch _ nanos nextPut: aStream next. ].
(ch isNil or: [ch isDigit]) ifTrue: [ ch _ $+ ].
nanos _ ((ReadStream on: buffer) upTo: ch) asInteger.
aStream atEnd
ifTrue: [ offset _ self localOffset ]
ifFalse:
[offset _ Duration fromString: (ch asString, '0:', aStream upToEnd).
(offset = self localOffset) ifTrue: [ offset _ self localOffset ]].
^ self
year: year
month: month
day: day
hour: hour
minute: minute
second: second
nanoSecond: nanos
offset: offset.
" '-1199-01-05T20:33:14.321-05:00' asDateAndTime
' 2002-05-16T17:20:45.00000001+01:01' asDateAndTime
' 2002-05-16T17:20:45.00000001' asDateAndTime
' 2002-05-16T17:20' asDateAndTime
' 2002-05-16T17:20:45' asDateAndTime
' 2002-05-16T17:20:45+01:57' asDateAndTime
' 2002-05-16T17:20:45-02:34' asDateAndTime
' 2002-05-16T17:20:45+00:00' asDateAndTime
' 1997-04-26T01:02:03+01:02:3' asDateAndTime
"
!
----- Method: DateAndTime class>>today (in category 'squeak protocol') -----
today
^ self midnight
!
----- Method: DateAndTime class>>tomorrow (in category 'squeak protocol') -----
tomorrow
^ self today asDate next asDateAndTime!
----- Method: DateAndTime class>>totalSeconds (in category 'smalltalk-80') -----
totalSeconds
^ Time totalSeconds!
----- Method: DateAndTime class>>unixEpoch (in category 'squeak protocol') -----
unixEpoch
"Answer a DateAndTime representing the Unix epoch (1 January 1970, midnight UTC)"
^ self basicNew
ticks: #(2440588 0 0) offset: Duration zero;
yourself.
!
----- Method: DateAndTime class>>year:day: (in category 'squeak protocol') -----
year: year day: dayOfYear
"Return a DateAndTime"
^ self
year: year
day: dayOfYear
hour: 0
minute: 0
second: 0!
----- Method: DateAndTime class>>year:day:hour:minute:second: (in category 'ansi protocol') -----
year: year day: dayOfYear hour: hour minute: minute second: second
^ self
year: year
day: dayOfYear
hour: hour
minute: minute
second: second
offset: self localOffset.
!
----- Method: DateAndTime class>>year:day:hour:minute:second:offset: (in category 'ansi protocol') -----
year: year day: dayOfYear hour: hour minute: minute second: second offset: offset
"Return a DataAndTime"
| y d |
y _ self
year: year
month: 1
day: 1
hour: hour
minute: minute
second: second
nanoSecond: 0
offset: offset.
d _ Duration days: (dayOfYear - 1).
^ y + d!
----- Method: DateAndTime class>>year:month:day: (in category 'squeak protocol') -----
year: year month: month day: day
"Return a DateAndTime, midnight local time" ^ self
year: year
month: month
day: day
hour: 0
minute: 0!
----- Method: DateAndTime class>>year:month:day:hour:minute: (in category 'squeak protocol') -----
year: year month: month day: day hour: hour minute: minute
"Return a DateAndTime" ^ self
year: year
month: month
day: day
hour: hour
minute: minute
second: 0!
----- Method: DateAndTime class>>year:month:day:hour:minute:second: (in category 'ansi protocol') -----
year: year month: month day: day hour: hour minute: minute second: second
"Return a DateAndTime"
^ self
year: year
month: month
day: day
hour: hour
minute: minute
second: second
offset: self localOffset
!
----- Method: DateAndTime class>>year:month:day:hour:minute:second:nanoSecond:offset: (in category 'squeak protocol') -----
year: year month: month day: day hour: hour minute: minute second: second nanoSecond: nanoCount offset: offset
"Return a DateAndTime"
| monthIndex daysInMonth p q r s julianDayNumber since |
monthIndex _ month isInteger ifTrue: [month] ifFalse: [Month indexOfMonth: month].
daysInMonth _ Month
daysInMonth: monthIndex
forYear: year.
day < 1 ifTrue: [self error: 'day may not be zero or negative'].
day > daysInMonth ifTrue: [self error: 'day is after month ends'].
p _ (monthIndex - 14) quo: 12.
q _ year + 4800 + p.
r _ monthIndex - 2 - (12 * p).
s _ (year + 4900 + p) quo: 100.
julianDayNumber _
( (1461 * q) quo: 4 ) +
( (367 * r) quo: 12 ) -
( (3 * s) quo: 4 ) +
( day - 32075 ).
since _ Duration days: julianDayNumber hours: hour
minutes: minute seconds: second nanoSeconds: nanoCount.
^ self basicNew
ticks: since ticks offset: offset;
yourself.!
----- Method: DateAndTime class>>year:month:day:hour:minute:second:offset: (in category 'ansi protocol') -----
year: year month: month day: day hour: hour minute: minute second: second offset: offset
^ self
year: year
month: month
day: day
hour: hour
minute: minute
second: second
nanoSecond: 0
offset: offset
!
----- Method: DateAndTime class>>yesterday (in category 'squeak protocol') -----
yesterday
^ self today asDate previous asDateAndTime
!
----- Method: DateAndTime>>+ (in category 'ansi protocol') -----
+ operand
"operand conforms to protocol Duration"
| ticks |
ticks _ self ticks + (operand asDuration ticks) .
^ self class basicNew
ticks: ticks
offset: self offset;
yourself.
!
----- Method: DateAndTime>>- (in category 'ansi protocol') -----
- operand
"operand conforms to protocol DateAndTime or protocol Duration"
^ (operand respondsTo: #asDateAndTime)
ifTrue:
[ | lticks rticks |
lticks _ self asLocal ticks.
rticks _ operand asDateAndTime asLocal ticks.
Duration
seconds: (SecondsInDay *(lticks first - rticks first)) +
(lticks second - rticks second)
nanoSeconds: (lticks third - rticks third) ]
ifFalse:
[ self + (operand negated) ].
!
----- Method: DateAndTime>>< (in category 'ansi protocol') -----
< comparand
"comparand conforms to protocol DateAndTime,
or can be converted into something that conforms."
| lticks rticks comparandAsDateAndTime |
comparandAsDateAndTime := comparand asDateAndTime.
offset = comparandAsDateAndTime offset
ifTrue: [lticks := self ticks.
rticks := comparandAsDateAndTime ticks]
ifFalse: [lticks := self asUTC ticks.
rticks := comparandAsDateAndTime asUTC ticks].
^ lticks first < rticks first
or: [lticks first > rticks first
ifTrue: [false]
ifFalse: [lticks second < rticks second
or: [lticks second > rticks second
ifTrue: [false]
ifFalse: [lticks third < rticks third]]]]
!
----- Method: DateAndTime>>= (in category 'ansi protocol') -----
= comparand
"comparand conforms to protocol DateAndTime,
or can be converted into something that conforms."
| comparandAsDateAndTime |
self == comparand
ifTrue: [^ true].
[comparandAsDateAndTime := comparand asDateAndTime]
on: MessageNotUnderstood
do: [^ false].
^ self offset = comparandAsDateAndTime offset
ifTrue: [self hasEqualTicks: comparandAsDateAndTime ]
ifFalse: [self asUTC ticks = comparandAsDateAndTime asUTC ticks]
!
----- Method: DateAndTime>>asDate (in category 'squeak protocol') -----
asDate
^ Date starting: self
!
----- Method: DateAndTime>>asDateAndTime (in category 'squeak protocol') -----
asDateAndTime
^ self
!
----- Method: DateAndTime>>asDuration (in category 'squeak protocol') -----
asDuration
"Answer the duration since midnight"
^ Duration seconds: seconds nanoSeconds: nanos
!
----- Method: DateAndTime>>asLocal (in category 'ansi protocol') -----
asLocal
^ (self offset = self class localOffset)
ifTrue: [self]
ifFalse: [self utcOffset: self class localOffset]
!
----- Method: DateAndTime>>asMonth (in category 'squeak protocol') -----
asMonth
^ Month starting: self
!
----- Method: DateAndTime>>asNanoSeconds (in category 'squeak protocol') -----
asNanoSeconds
"Answer the number of nanoseconds since midnight"
^ self asDuration asNanoSeconds
!
----- Method: DateAndTime>>asSeconds (in category 'smalltalk-80') -----
asSeconds
"Return the number of seconds since the Squeak epoch"
^ (self - (self class epoch)) asSeconds
!
----- Method: DateAndTime>>asTime (in category 'squeak protocol') -----
asTime
^ Time seconds: seconds nanoSeconds: nanos!
----- Method: DateAndTime>>asTimeStamp (in category 'squeak protocol') -----
asTimeStamp
^ self as: TimeStamp!
----- Method: DateAndTime>>asUTC (in category 'ansi protocol') -----
asUTC
^ self utcOffset: 0!
----- Method: DateAndTime>>asUnixTime (in category 'squeak protocol') -----
asUnixTime
"answer number of seconds since unix epoch (midnight Jan 1, 1970, UTC)"
^(self - self class unixEpoch) asSeconds!
----- Method: DateAndTime>>asWeek (in category 'squeak protocol') -----
asWeek
^ Week starting: self
!
----- Method: DateAndTime>>asYear (in category 'squeak protocol') -----
asYear
^ Year starting: self
!
----- Method: DateAndTime>>day (in category 'smalltalk-80') -----
day
^ self dayOfYear!
----- Method: DateAndTime>>dayMonthYearDo: (in category 'squeak protocol') -----
dayMonthYearDo: aBlock
"Evaluation the block with three arguments: day month, year."
| l n i j dd mm yyyy |
l := jdn + 68569.
n := 4 * l // 146097.
l := l - (146097 * n + 3 // 4).
i := 4000 * (l + 1) // 1461001.
l := l - (1461 * i // 4) + 31.
j := 80 * l // 2447.
dd := l - (2447 * j // 80).
l := j // 11.
mm := j + 2 - (12 * l).
yyyy := 100 * (n - 49) + i + l.
^ aBlock
value: dd
value: mm
value: yyyy.!
----- Method: DateAndTime>>dayOfMonth (in category 'ansi protocol') -----
dayOfMonth
"Answer which day of the month is represented by the receiver."
^ self
dayMonthYearDo: [ :d :m :y | d ]!
----- Method: DateAndTime>>dayOfWeek (in category 'ansi protocol') -----
dayOfWeek
"Sunday=1, ... , Saturday=7"
^ (jdn + 1 rem: 7) + 1!
----- Method: DateAndTime>>dayOfWeekAbbreviation (in category 'ansi protocol') -----
dayOfWeekAbbreviation
^ self dayOfWeekName copyFrom: 1 to: 3!
----- Method: DateAndTime>>dayOfWeekName (in category 'ansi protocol') -----
dayOfWeekName
^ Week nameOfDay: self dayOfWeek
!
----- Method: DateAndTime>>dayOfYear (in category 'ansi protocol') -----
dayOfYear
^ jdn - (Year year: self year) start julianDayNumber + 1
!
----- Method: DateAndTime>>daysInMonth (in category 'smalltalk-80') -----
daysInMonth
"Answer the number of days in the month represented by the receiver."
^ self asMonth daysInMonth
!
----- Method: DateAndTime>>daysInYear (in category 'smalltalk-80') -----
daysInYear
"Answer the number of days in the year represented by the receiver."
^ self asYear daysInYear
!
----- Method: DateAndTime>>daysLeftInYear (in category 'smalltalk-80') -----
daysLeftInYear
"Answer the number of days in the year after the date of the receiver."
^ self daysInYear - self dayOfYear
!
----- Method: DateAndTime>>duration (in category 'squeak protocol') -----
duration
^ Duration zero
!
----- Method: DateAndTime>>firstDayOfMonth (in category 'smalltalk-80') -----
firstDayOfMonth
^ self asMonth start day!
----- Method: DateAndTime>>hasEqualTicks: (in category 'private') -----
hasEqualTicks: aDateAndTime
^ (jdn = aDateAndTime julianDayNumber)
and: [ (seconds = aDateAndTime secondsSinceMidnight)
and: [ nanos = aDateAndTime nanoSecond ] ]
!
----- Method: DateAndTime>>hash (in category 'ansi protocol') -----
hash
^ self asUTC ticks hash
!
----- Method: DateAndTime>>hour (in category 'ansi protocol') -----
hour
^ self hour24
!
----- Method: DateAndTime>>hour12 (in category 'ansi protocol') -----
hour12
"Answer an <integer> between 1 and 12, inclusive, representing the hour
of the day in the 12-hour clock of the local time of the receiver."
^ self hour24 - 1 \\ 12 + 1!
----- Method: DateAndTime>>hour24 (in category 'ansi protocol') -----
hour24
^ (Duration seconds: seconds) hours
!
----- Method: DateAndTime>>hours (in category 'smalltalk-80') -----
hours
^ self hour!
----- Method: DateAndTime>>isLeapYear (in category 'ansi protocol') -----
isLeapYear
^ Year isLeapYear: self year.
!
----- Method: DateAndTime>>julianDayNumber (in category 'squeak protocol') -----
julianDayNumber
^ jdn
!
----- Method: DateAndTime>>meridianAbbreviation (in category 'ansi protocol') -----
meridianAbbreviation
^ self asTime meridianAbbreviation!
----- Method: DateAndTime>>middleOf: (in category 'squeak protocol') -----
middleOf: aDuration
"Return a Timespan where the receiver is the middle of the Duration"
| duration |
duration _ aDuration asDuration.
^ Timespan starting: (self - (duration / 2)) duration: duration.
!
----- Method: DateAndTime>>midnight (in category 'squeak protocol') -----
midnight
"Answer a DateAndTime starting at midnight local time"
^ self
dayMonthYearDo: [ :d :m :y | self class year: y month: m day: d ]!
----- Method: DateAndTime>>minute (in category 'ansi protocol') -----
minute
^ (Duration seconds: seconds) minutes
!
----- Method: DateAndTime>>minutes (in category 'smalltalk-80') -----
minutes
^ self minute!
----- Method: DateAndTime>>month (in category 'ansi protocol') -----
month
^ self
dayMonthYearDo: [ :d :m :y | m ].!
----- Method: DateAndTime>>monthAbbreviation (in category 'ansi protocol') -----
monthAbbreviation
^ self monthName copyFrom: 1 to: 3
!
----- Method: DateAndTime>>monthIndex (in category 'smalltalk-80') -----
monthIndex
^ self month
!
----- Method: DateAndTime>>monthName (in category 'ansi protocol') -----
monthName
^ Month nameOfMonth: self month
!
----- Method: DateAndTime>>nanoSecond (in category 'squeak protocol') -----
nanoSecond
^ nanos
!
----- Method: DateAndTime>>noon (in category 'squeak protocol') -----
noon
"Answer a DateAndTime starting at noon"
^ self dayMonthYearDo:
[ :d :m :y | self class year: y month: m day: d hour: 12 minute: 0 second: 0 ]!
----- Method: DateAndTime>>offset (in category 'ansi protocol') -----
offset
^ offset
!
----- Method: DateAndTime>>offset: (in category 'ansi protocol') -----
offset: anOffset
"Answer a <DateAndTime> equivalent to the receiver but with its local time
being offset from UTC by offset."
^ self class basicNew
ticks: self ticks offset: anOffset asDuration;
yourself
!
----- Method: DateAndTime>>printHMSOn: (in category 'squeak protocol') -----
printHMSOn: aStream
"Print just hh:mm:ss"
aStream
nextPutAll: (self hour asString padded: #left to: 2 with: $0);
nextPut: $:;
nextPutAll: (self minute asString padded: #left to: 2 with: $0);
nextPut: $:;
nextPutAll: (self second asString padded: #left to: 2 with: $0).
!
----- Method: DateAndTime>>printOn: (in category 'squeak protocol') -----
printOn: aStream
"Print as per ISO 8601 sections 5.3.3 and 5.4.1.
Prints either:
'YYYY-MM-DDThh:mm:ss.s+ZZ:zz:z' (for positive years) or '-YYYY-MM-DDThh:mm:ss.s+ZZ:zz:z' (for negative years)"
^self printOn: aStream withLeadingSpace: false
!
----- Method: DateAndTime>>printOn:withLeadingSpace: (in category 'squeak protocol') -----
printOn: aStream withLeadingSpace: printLeadingSpaceToo
"Print as per ISO 8601 sections 5.3.3 and 5.4.1.
If printLeadingSpaceToo is false, prints either:
'YYYY-MM-DDThh:mm:ss.s+ZZ:zz:z' (for positive years) or '-YYYY-MM-DDThh:mm:ss.s+ZZ:zz:z' (for negative years)
If printLeadingSpaceToo is true, prints either:
' YYYY-MM-DDThh:mm:ss.s+ZZ:zz:z' (for positive years) or '-YYYY-MM-DDThh:mm:ss.s+ZZ:zz:z' (for negative years)
"
self printYMDOn: aStream withLeadingSpace: printLeadingSpaceToo.
aStream nextPut: $T.
self printHMSOn: aStream.
self nanoSecond ~= 0 ifTrue:
[ | z ps |
ps := self nanoSecond printString padded: #left to: 9 with: $0.
z := ps findLast: [ :c | c asciiValue > $0 asciiValue ].
(z > 0) ifTrue: [aStream nextPut: $.].
ps from: 1 to: z do: [ :c | aStream nextPut: c ] ].
aStream
nextPut: (offset positive ifTrue: [$+] ifFalse: [$-]);
nextPutAll: (offset hours abs asString padded: #left to: 2 with: $0);
nextPut: $:;
nextPutAll: (offset minutes abs asString padded: #left to: 2 with: $0).
offset seconds = 0 ifFalse:
[ aStream
nextPut: $:;
nextPutAll: (offset seconds abs truncated asString) ].
!
----- Method: DateAndTime>>printYMDOn: (in category 'squeak protocol') -----
printYMDOn: aStream
"Print just YYYY-MM-DD part.
If the year is negative, prints out '-YYYY-MM-DD'."
^self printYMDOn: aStream withLeadingSpace: false.
!
----- Method: DateAndTime>>printYMDOn:withLeadingSpace: (in category 'squeak protocol') -----
printYMDOn: aStream withLeadingSpace: printLeadingSpaceToo
"Print just the year, month, and day on aStream.
If printLeadingSpaceToo is true, then print as:
' YYYY-MM-DD' (if the year is positive) or '-YYYY-MM-DD' (if the year is negative)
otherwise print as:
'YYYY-MM-DD' or '-YYYY-MM-DD' "
| year month day |
self dayMonthYearDo: [ :d :m :y | year := y. month := m. day := d ].
year negative
ifTrue: [ aStream nextPut: $- ]
ifFalse: [ printLeadingSpaceToo ifTrue: [ aStream space ]].
aStream
nextPutAll: (year abs asString padded: #left to: 4 with: $0);
nextPut: $-;
nextPutAll: (month asString padded: #left to: 2 with: $0);
nextPut: $-;
nextPutAll: (day asString padded: #left to: 2 with: $0)
!
----- Method: DateAndTime>>second (in category 'ansi protocol') -----
second
^ (Duration seconds: seconds) seconds
!
----- Method: DateAndTime>>seconds (in category 'smalltalk-80') -----
seconds
^ self second!
----- Method: DateAndTime>>secondsSinceMidnight (in category 'private') -----
secondsSinceMidnight
^ seconds!
----- Method: DateAndTime>>ticks (in category 'private') -----
ticks
"Private - answer an array with our instance variables. Assumed to be UTC "
^ Array with: jdn with: seconds with: nanos
.!
----- Method: DateAndTime>>ticks:offset: (in category 'private') -----
ticks: ticks offset: utcOffset
"ticks is {julianDayNumber. secondCount. nanoSeconds}"
| normalize |
normalize := [ :i :base | | tick div quo rem |
tick := ticks at: i.
div := tick digitDiv: base neg: tick negative.
quo := div first normalize.
rem := div second normalize.
rem < 0 ifTrue: [ quo := quo - 1. rem := base + rem ].
ticks at: (i-1) put: ((ticks at: i-1) + quo).
ticks at: i put: rem ].
normalize value: 3 value: NanosInSecond.
normalize value: 2 value: SecondsInDay.
jdn _ ticks first.
seconds _ ticks second.
nanos := ticks third.
offset := utcOffset.
!
----- Method: DateAndTime>>timeZoneAbbreviation (in category 'ansi protocol') -----
timeZoneAbbreviation
^ self class localTimeZone abbreviation
!
----- Method: DateAndTime>>timeZoneName (in category 'ansi protocol') -----
timeZoneName
^ self class localTimeZone name
!
----- Method: DateAndTime>>to: (in category 'squeak protocol') -----
to: anEnd
"Answer a Timespan. anEnd conforms to protocol DateAndTime or protocol Timespan"
^ Timespan starting: self ending: (anEnd asDateAndTime).
!
----- Method: DateAndTime>>to:by: (in category 'squeak protocol') -----
to: anEnd by: aDuration
"Answer a Timespan. anEnd conforms to protocol DateAndTime or protocol Timespan"
^ (Schedule starting: self ending: (anEnd asDateAndTime))
schedule: (Array with: aDuration asDuration);
yourself.
!
----- Method: DateAndTime>>to:by:do: (in category 'squeak protocol') -----
to: anEnd by: aDuration do: aBlock
"Answer a Timespan. anEnd conforms to protocol DateAndTime or protocol Timespan"
^ (self to: anEnd by: aDuration) scheduleDo: aBlock
!
----- Method: DateAndTime>>utcOffset: (in category 'squeak protocol') -----
utcOffset: anOffset
"Answer a <DateAndTime> equivalent to the receiver but offset from UTC by anOffset"
| equiv |
equiv _ self + (anOffset asDuration - self offset).
^ equiv ticks: (equiv ticks) offset: anOffset asDuration; yourself
!
----- Method: DateAndTime>>year (in category 'ansi protocol') -----
year
^ self
dayMonthYearDo: [ :d :m :y | y ]!
DateAndTime subclass: #TimeStamp
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Kernel-Chronology'!
!TimeStamp commentStamp: '<historical>' prior: 0!
This represents a duration of 0 length that marks a particular point in time.!
----- Method: TimeStamp class>>current (in category 'squeak protocol') -----
current
| ts ticks |
ts _ super now.
ticks _ ts ticks.
ticks at: 3 put: 0.
ts ticks: ticks offset: ts offset.
^ ts
!
----- Method: TimeStamp class>>midnightOn: (in category 'deprecated') -----
midnightOn: aDate
"Answer a new instance that represents aDate at midnight."
^ self
deprecated: 'Deprecated';
date: aDate time: Time midnight!
----- Method: TimeStamp class>>noonOn: (in category 'deprecated') -----
noonOn: aDate
"Answer a new instance that represents aDate at noon."
^ self
deprecated: 'Deprecated';
date: aDate time: Time noon!
----- Method: TimeStamp class>>now (in category 'ansi protocol') -----
now
"Answer the current date and time as a TimeStamp."
^self current!
----- Method: TimeStamp>>asTimeStamp (in category 'squeak protocol') -----
asTimeStamp
"Answer the receiver as an instance of TimeStamp."
^ self!
----- Method: TimeStamp>>date (in category 'squeak protocol') -----
date
"Answer the date of the receiver."
^ self asDate!
----- Method: TimeStamp>>date: (in category 'deprecated') -----
date: aDate
self deprecated: 'Deprecated'!
----- Method: TimeStamp>>dateAndTime (in category 'squeak protocol') -----
dateAndTime
"Answer a two element Array containing the receiver's date and time."
^ Array with: self date with: self time!
----- Method: TimeStamp>>minusDays: (in category 'squeak protocol') -----
minusDays: anInteger
"Answer a TimeStamp which is anInteger days before the receiver."
^ self - (anInteger days)!
----- Method: TimeStamp>>minusSeconds: (in category 'squeak protocol') -----
minusSeconds: anInteger
"Answer a TimeStamp which is anInteger number of seconds before the receiver."
^ self - (anInteger seconds)!
----- Method: TimeStamp>>plusDays: (in category 'squeak protocol') -----
plusDays: anInteger
"Answer a TimeStamp which is anInteger days after the receiver."
^ self + (anInteger days)!
----- Method: TimeStamp>>plusSeconds: (in category 'squeak protocol') -----
plusSeconds: anInteger
"Answer a TimeStamp which is anInteger number of seconds after the receiver."
^ self + (anInteger seconds)!
----- Method: TimeStamp>>printOn: (in category 'squeak protocol') -----
printOn: aStream
"Print receiver's date and time on aStream."
aStream
nextPutAll: self date printString;
space;
nextPutAll: self time printString.!
----- Method: TimeStamp>>storeOn: (in category 'squeak protocol') -----
storeOn: aStream
aStream
print: self printString;
nextPutAll: ' asTimeStamp'!
----- Method: TimeStamp>>time (in category 'squeak protocol') -----
time
"Answer the time of the receiver."
^ self asTime!
----- Method: TimeStamp>>time: (in category 'deprecated') -----
time: aTime
self deprecated: 'Deprecated'!
Magnitude subclass: #Duration
instanceVariableNames: 'nanos seconds'
classVariableNames: ''
poolDictionaries: 'ChronologyConstants'
category: 'Kernel-Chronology'!
!Duration commentStamp: '<historical>' prior: 0!
I represent a duration of time. I have nanosecond precision
!
----- Method: Duration class>>days: (in category 'squeak protocol') -----
days: aNumber
^ self days: aNumber hours: 0 minutes: 0 seconds: 0 nanoSeconds: 0!
----- Method: Duration class>>days:hours:minutes:seconds: (in category 'ansi protocol') -----
days: days hours: hours minutes: minutes seconds: seconds
^ self days: days hours: hours minutes: minutes seconds: seconds nanoSeconds: 0.!
----- Method: Duration class>>days:hours:minutes:seconds:nanoSeconds: (in category 'squeak protocol') -----
days: days hours: hours minutes: minutes seconds: seconds nanoSeconds: nanos
^ self nanoSeconds:
( ( (days * SecondsInDay)
+ (hours * SecondsInHour)
+ (minutes * SecondsInMinute)
+ seconds ) * NanosInSecond )
+ nanos.
!
----- Method: Duration class>>fromString: (in category 'squeak protocol') -----
fromString: aString
^ self readFrom: (ReadStream on: aString)
!
----- Method: Duration class>>hours: (in category 'squeak protocol') -----
hours: aNumber
^ self days: 0 hours: aNumber minutes: 0 seconds: 0 nanoSeconds: 0!
----- Method: Duration class>>milliSeconds: (in category 'squeak protocol') -----
milliSeconds: milliCount
^ self days: 0 hours: 0 minutes: 0 seconds: 0 nanoSeconds:
(milliCount * (10 raisedToInteger: 6))
!
----- Method: Duration class>>minutes: (in category 'squeak protocol') -----
minutes: aNumber
^ self days: 0 hours: 0 minutes: aNumber seconds: 0 nanoSeconds: 0!
----- Method: Duration class>>month: (in category 'squeak protocol') -----
month: aMonth
"aMonth is an Integer or a String"
^ (Month month: aMonth year: Year current year) duration
!
----- Method: Duration class>>nanoSeconds: (in category 'squeak protocol') -----
nanoSeconds: nanos
^ self new
seconds: (nanos quo: NanosInSecond)
nanoSeconds: (nanos rem: NanosInSecond) rounded;
yourself.
!
----- Method: Duration class>>readFrom: (in category 'squeak protocol') -----
readFrom: aStream
"Formatted as per ANSI 5.8.2.16: [-]D:HH:MM:SS[.S]
To assiste DateAndTime>>#readFrom: SS may be unpadded or absent."
| sign days hours minutes seconds nanos ws ch |
sign _ (aStream peekFor: $-) ifTrue: [-1] ifFalse: [1].
days _ (aStream upTo: $:) asInteger sign: sign.
hours _ (aStream upTo: $:) asInteger sign: sign.
minutes _ (aStream upTo: $:) asInteger sign: sign.
aStream atEnd
ifTrue: [seconds _ 0. nanos _ 0]
ifFalse:
[ ws _ String new writeStream.
[ch _ aStream next. (ch isNil) | (ch = $.)]
whileFalse: [ ws nextPut: ch ].
seconds _ ws contents asInteger sign: sign.
ws reset.
9 timesRepeat:
[ ch _ aStream next.
ws nextPut: (ch ifNil: [$0] ifNotNil: [ch]) ].
nanos _ ws contents asInteger sign: sign].
^ self days: days hours: hours minutes: minutes seconds: seconds nanoSeconds: nanos.
" '0:00:00:00' asDuration
'0:00:00:00.000000001' asDuration
'0:00:00:00.999999999' asDuration
'0:00:00:00.100000000' asDuration
'0:00:00:00.10' asDuration
'0:00:00:00.1' asDuration
'0:00:00:01' asDuration
'0:12:45:45' asDuration
'1:00:00:00' asDuration
'365:00:00:00' asDuration
'-7:09:12:06.10' asDuration
'+0:01:02' asDuration
'+0:01:02:3' asDuration
"
!
----- Method: Duration class>>seconds: (in category 'ansi protocol') -----
seconds: aNumber
^ (self basicNew) seconds: aNumber nanoSeconds: 0; yourself.
!
----- Method: Duration class>>seconds:nanoSeconds: (in category 'squeak protocol') -----
seconds: seconds nanoSeconds: nanos
^ self days: 0 hours: 0 minutes: 0 seconds: seconds nanoSeconds: nanos
!
----- Method: Duration class>>weeks: (in category 'squeak protocol') -----
weeks: aNumber
^ self days: (aNumber * 7) hours: 0 minutes: 0 seconds: 0 nanoSeconds: 0
!
----- Method: Duration class>>zero (in category 'ansi protocol') -----
zero
^ (self basicNew) seconds: 0 nanoSeconds: 0; yourself.
!
----- Method: Duration>>* (in category 'ansi protocol') -----
* operand
"operand is a Number" ^ self class nanoSeconds: ( (self asNanoSeconds * operand) asInteger).
!
----- Method: Duration>>+ (in category 'ansi protocol') -----
+ operand
"operand is a Duration" ^ self class nanoSeconds: (self asNanoSeconds + operand asNanoSeconds)
!
----- Method: Duration>>- (in category 'ansi protocol') -----
- operand
"operand is a Duration" ^ self + operand negated
!
----- Method: Duration>>/ (in category 'ansi protocol') -----
/ operand
"operand is a Duration or a Number"
^ operand isNumber
ifTrue: [ self class nanoSeconds: (self asNanoSeconds / operand) asInteger ]
ifFalse: [ self asNanoSeconds / operand asDuration asNanoSeconds ]
.
!
----- Method: Duration>>// (in category 'squeak protocol') -----
// operand
"operand is a Duration or a Number"
^ operand isNumber
ifTrue: [ self class nanoSeconds: (self asNanoSeconds // operand) asInteger ]
ifFalse: [ self asNanoSeconds // operand asDuration asNanoSeconds ]
!
----- Method: Duration>>< (in category 'ansi protocol') -----
< comparand
^ self asNanoSeconds < comparand asNanoSeconds
!
----- Method: Duration>>= (in category 'ansi protocol') -----
= comparand
"Answer whether the argument is a <Duration> representing the same
period of time as the receiver."
^ self == comparand
ifTrue: [true]
ifFalse:
[self species = comparand species
ifTrue: [self asNanoSeconds = comparand asNanoSeconds]
ifFalse: [false] ]!
----- Method: Duration>>\\ (in category 'squeak protocol') -----
\\ operand
"modulo. Remainder defined in terms of //. Answer a Duration with the
same sign as aDuration. operand is a Duration or a Number."
^ operand isNumber
ifTrue: [ self class nanoSeconds: (self asNanoSeconds \\ operand) ]
ifFalse: [ self - (operand * (self // operand)) ]
!
----- Method: Duration>>abs (in category 'ansi protocol') -----
abs
^ self class seconds: seconds abs nanoSeconds: nanos abs
!
----- Method: Duration>>asDelay (in category 'squeak protocol') -----
asDelay
^ Delay forDuration: self!
----- Method: Duration>>asDuration (in category 'ansi protocol') -----
asDuration
^ self
!
----- Method: Duration>>asMilliSeconds (in category 'squeak protocol') -----
asMilliSeconds
^ ((seconds * NanosInSecond) + nanos) // (10 raisedToInteger: 6)
!
----- Method: Duration>>asNanoSeconds (in category 'squeak protocol') -----
asNanoSeconds
^ (seconds * NanosInSecond) + nanos
!
----- Method: Duration>>asSeconds (in category 'ansi protocol') -----
asSeconds
^ seconds
!
----- Method: Duration>>days (in category 'ansi protocol') -----
days
"Answer the number of days the receiver represents."
^ seconds quo: SecondsInDay
!
----- Method: Duration>>hash (in category 'ansi protocol') -----
hash ^seconds bitXor: nanos
!
----- Method: Duration>>hours (in category 'ansi protocol') -----
hours
"Answer the number of hours the receiver represents."
^ (seconds rem: SecondsInDay) quo: SecondsInHour
!
----- Method: Duration>>initialize (in category 'initialize-release') -----
initialize
self seconds: 0 nanoSeconds: 0.
!
----- Method: Duration>>minutes (in category 'ansi protocol') -----
minutes
"Answer the number of minutes the receiver represents."
^ (seconds rem: SecondsInHour) quo: SecondsInMinute
!
----- Method: Duration>>nanoSeconds (in category 'squeak protocol') -----
nanoSeconds
^ nanos
!
----- Method: Duration>>negated (in category 'ansi protocol') -----
negated
^ self class seconds: seconds negated nanoSeconds: nanos negated
!
----- Method: Duration>>negative (in category 'ansi protocol') -----
negative
^ self positive not
!
----- Method: Duration>>positive (in category 'ansi protocol') -----
positive
^ seconds = 0 ifTrue: [ nanos positive ] ifFalse: [ seconds positive ]
!
----- Method: Duration>>printOn: (in category 'squeak protocol') -----
printOn: aStream
"Format as per ANSI 5.8.2.16: [-]D:HH:MM:SS[.S]" | d h m s n |
d _ self days abs.
h _ self hours abs.
m _ self minutes abs.
s _ self seconds abs truncated.
n _ self nanoSeconds abs. self negative ifTrue: [ aStream nextPut: $- ].
d printOn: aStream. aStream nextPut: $:.
h < 10 ifTrue: [ aStream nextPut: $0. ].
h printOn: aStream. aStream nextPut: $:.
m < 10 ifTrue: [ aStream nextPut: $0. ].
m printOn: aStream. aStream nextPut: $:.
s < 10 ifTrue: [ aStream nextPut: $0. ].
s printOn: aStream.
n = 0 ifFalse:
[ | z ps |
aStream nextPut: $..
ps _ n printString padded: #left to: 9 with: $0.
z _ ps findLast: [ :c | c asciiValue > $0 asciiValue ].
ps from: 1 to: z do: [ :c | aStream nextPut: c ] ].
!
----- Method: Duration>>roundTo: (in category 'squeak protocol') -----
roundTo: aDuration
"e.g. if the receiver is 5 minutes, 37 seconds, and aDuration is 2 minutes, answer 6 minutes."
^ self class nanoSeconds: (self asNanoSeconds roundTo: aDuration asNanoSeconds)
!
----- Method: Duration>>seconds (in category 'ansi protocol') -----
seconds
"Answer the number of seconds the receiver represents."
^ (seconds rem: SecondsInMinute) + (nanos / NanosInSecond)!
----- Method: Duration>>seconds:nanoSeconds: (in category 'private') -----
seconds: secondCount nanoSeconds: nanoCount
"Private - only used by Duration class"
seconds _ secondCount.
nanos _ nanoCount!
----- Method: Duration>>storeOn: (in category 'private') -----
storeOn: aStream
aStream
nextPut: $(;
nextPutAll: self className;
nextPutAll: ' seconds: ';
print: seconds;
nextPutAll: ' nanoSeconds: ';
print: nanos;
nextPut: $).
!
----- Method: Duration>>ticks (in category 'private') -----
ticks
"Answer an array {days. seconds. nanoSeconds}. Used by DateAndTime and Time"
^ Array
with: self days
with: (self hours * 3600) + (self minutes * 60 ) + (self seconds truncated)
with: self nanoSeconds!
----- Method: Duration>>truncateTo: (in category 'squeak protocol') -----
truncateTo: aDuration
"e.g. if the receiver is 5 minutes, 37 seconds, and aDuration is 2 minutes, answer 4 minutes."
^ self class
nanoSeconds: (self asNanoSeconds truncateTo: aDuration asNanoSeconds)
!
Timespan subclass: #Month
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: 'ChronologyConstants'
category: 'Kernel-Chronology'!
!Month commentStamp: 'brp 5/13/2003 09:48' prior: 0!
I represent a month.!
----- Method: Month class>>daysInMonth:forYear: (in category 'smalltalk-80') -----
daysInMonth: indexOrName forYear: yearInteger
| index |
index _ indexOrName isInteger
ifTrue: [indexOrName]
ifFalse: [self indexOfMonth: indexOrName].
^ (DaysInMonth at: index)
+ ((index = 2
and: [Year isLeapYear: yearInteger])
ifTrue: [1] ifFalse: [0])!
----- Method: Month class>>indexOfMonth: (in category 'smalltalk-80') -----
indexOfMonth: aMonthName
1 to: 12 do: [ :i | (aMonthName, '*' match: (MonthNames at: i)) ifTrue: [^i] ].
self error: aMonthName , ' is not a recognized month name'.!
----- Method: Month class>>month:year: (in category 'squeak protocol') -----
month: month year: year
"Create a Month for the given <year> and <month>.
<month> may be a number or a String with the
name of the month. <year> should be with 4 digits."
^ self starting: (DateAndTime year: year month: month day: 1)
!
----- Method: Month class>>nameOfMonth: (in category 'smalltalk-80') -----
nameOfMonth: anIndex
^ MonthNames at: anIndex.!
----- Method: Month class>>readFrom: (in category 'squeak protocol') -----
readFrom: aStream
| m y c |
m _ (ReadWriteStream with: '') reset.
[(c _ aStream next) isSeparator] whileFalse: [m nextPut: c].
[(c _ aStream next) isSeparator] whileTrue.
y _ (ReadWriteStream with: '') reset.
y nextPut: c.
[aStream atEnd] whileFalse: [y nextPut: aStream next].
^ self
month: m contents
year: y contents
"Month readFrom: 'July 1998' readStream"
!
----- Method: Month class>>starting:duration: (in category 'squeak protocol') -----
starting: aDateAndTime duration: aDuration
"Override - a each month has a defined duration"
| start adjusted days |
start _ aDateAndTime asDateAndTime.
adjusted _ DateAndTime
year: start year
month: start month
day: 1.
days _ self daysInMonth: adjusted month forYear: adjusted year.
^ super
starting: adjusted
duration: (Duration days: days)!
----- Method: Month>>asMonth (in category 'squeak protocol') -----
asMonth
^ self
!
----- Method: Month>>daysInMonth (in category 'squeak protocol') -----
daysInMonth
^ self duration days.!
----- Method: Month>>eachWeekDo: (in category 'deprecated') -----
eachWeekDo: aBlock
self deprecated: 'Use #weeksDo:'.
self weeksDo: aBlock
!
----- Method: Month>>index (in category 'squeak protocol') -----
index
^ self monthIndex
!
----- Method: Month>>name (in category 'squeak protocol') -----
name
^ self monthName
!
----- Method: Month>>previous (in category 'squeak protocol') -----
previous
^ self class starting: (self start - 1)
!
----- Method: Month>>printOn: (in category 'squeak protocol') -----
printOn: aStream
aStream nextPutAll: self monthName, ' ', self year printString.!
Magnitude subclass: #Time
instanceVariableNames: 'seconds nanos'
classVariableNames: ''
poolDictionaries: 'ChronologyConstants'
category: 'Kernel-Chronology'!
!Time commentStamp: 'dew 10/23/2004 17:58' prior: 0!
This represents a particular point in time during any given day. For example, '5:19:45 pm'.
If you need a point in time on a particular day, use DateAndTime. If you need a duration of time, use Duration.
!
----- Method: Time class>>benchmarkMillisecondClock (in category 'benchmarks') -----
benchmarkMillisecondClock "Time benchmarkMillisecondClock"
"Benchmark the time spent in a call to Time>>millisecondClockValue.
On the VM level this tests the efficiency of calls to ioMSecs()."
"PII/400 Windows 98: 0.725 microseconds per call"
| temp1 temp2 temp3 delayTime nLoops time |
delayTime _ 5000. "Time to run benchmark is approx. 2*delayTime"
"Don't run the benchmark if we have an active delay since
we will measure the additional penalty in the primitive dispatch
mechanism (see #benchmarkPrimitiveResponseDelay)."
Delay anyActive ifTrue:[
^self notify:'Some delay is currently active.
Running this benchmark will not give any useful result.'].
"Flush the cache for this benchmark so we will have
a clear cache hit for each send to #millisecondClockValue below"
Object flushCache.
temp1 _ 0.
temp2 _ self. "e.g., temp1 == Time"
temp3 _ self millisecondClockValue + delayTime.
"Now check how often we can run the following loop in the given time"
[temp2 millisecondClockValue < temp3]
whileTrue:[temp1 _ temp1 + 1].
nLoops _ temp1. "Remember the loops we have run during delayTime"
"Setup the second loop"
temp1 _ 0.
temp3 _ nLoops.
"Now measure how much time we spend without sending #millisecondClockValue"
time _ Time millisecondClockValue.
[temp1 < temp3]
whileTrue:[temp1 _ temp1 + 1].
time _ Time millisecondClockValue - time.
"And compute the number of microseconds spent per call to #millisecondClockValue"
^((delayTime - time * 1000.0 / nLoops) truncateTo: 0.001) printString,
' microseconds per call to Time>>millisecondClockValue'!
----- Method: Time class>>benchmarkPrimitiveResponseDelay (in category 'benchmarks') -----
benchmarkPrimitiveResponseDelay "Time benchmarkPrimitiveResponseDelay"
"Benchmark the overhead for primitive dispatches with an active Delay.
On the VM level, this tests the efficiency of ioLowResMSecs."
"PII/400 Windows98: 0.128 microseconds per prim"
"ar 9/6/1999: This value is *extremely* important for stuff like sockets etc.
I had a bad surprise when Michael pointed this particular problem out:
Using the hardcoded clock() call for ioLowResMSecs on Win32 resulted in an overhead
of 157.4 microseconds per primitive call - meaning you can't get no more than
approx. 6000 primitives per second on my 400Mhz PII system with an active delay!!
BTW, it finally explains why Squeak seemed soooo slow when running PWS or
other socket stuff. The new version (not using clock() but some Windows function)
looks a lot better (see above; approx. 8,000,000 prims per sec with an active delay)."
| nLoops bb index baseTime actualTime delayTime |
delayTime _ 5000. "Time to run this test is approx. 3*delayTime"
Delay anyActive ifTrue:[
^self notify:'Some delay is currently active.
Running this benchmark will not give any useful result.'].
bb _ Array new: 1. "The object we send the prim message to"
"Compute the # of loops we'll run in a decent amount of time"
[(Delay forMilliseconds: delayTime) wait]
forkAt: Processor userInterruptPriority.
nLoops _ 0.
[Delay anyActive] whileTrue:[
bb basicSize; basicSize; basicSize; basicSize; basicSize;
basicSize; basicSize; basicSize; basicSize; basicSize.
nLoops _ nLoops + 1.
].
"Flush the cache and make sure #basicSize is in there"
Object flushCache.
bb basicSize.
"Now run the loop without any active delay
for getting an idea about its actual speed."
baseTime _ self millisecondClockValue.
index _ nLoops.
[index > 0] whileTrue:[
bb basicSize; basicSize; basicSize; basicSize; basicSize;
basicSize; basicSize; basicSize; basicSize; basicSize.
index _ index - 1.
].
baseTime _ self millisecondClockValue - baseTime.
"Setup the active delay but try to never make it active"
[(Delay forMilliseconds: delayTime + delayTime) wait]
forkAt: Processor userInterruptPriority.
"And run the loop"
actualTime _ self millisecondClockValue.
index _ nLoops.
[index > 0] whileTrue:[
bb basicSize; basicSize; basicSize; basicSize; basicSize;
basicSize; basicSize; basicSize; basicSize; basicSize.
index _ index - 1.
].
actualTime _ self millisecondClockValue - actualTime.
"And get us some result"
^((actualTime - baseTime) * 1000 asFloat / (nLoops * 10) truncateTo: 0.001) printString,
' microseconds overhead per primitive call'!
----- Method: Time class>>condenseBunches: (in category 'general inquiries') -----
condenseBunches: aCollectionOfSeconds
| secArray pause now out prev bunchEnd ago |
"Identify the major intervals in a bunch of numbers.
Each number is a seconds since 1901 that represents a date and time.
We want the last event in a bunch. Return array of seconds for:
Every event in the last half hour.
Every bunch separated by 30 min in the last 24 hours.
Every bunch separated by two hours before that."
"Time condenseBunches:
(#(20 400 401 20000 20200 20300 40000 45000 200000 201000 202000)
collect: [ :tt | self totalSeconds - tt])
"
secArray _ aCollectionOfSeconds asSortedCollection.
pause _ 1.
now _ self totalSeconds.
out _ OrderedCollection new.
prev _ 0.
bunchEnd _ nil.
secArray reverseDo: [:secs | "descending"
ago _ now - secs.
ago > (60*30) ifTrue: [pause _ "60*30" 1800].
ago > (60*60*24) ifTrue: [pause _ "60*120" 7200].
ago - prev >= pause ifTrue: [out add: bunchEnd. bunchEnd _ secs].
prev _ ago].
out add: bunchEnd.
out removeFirst.
^ out!
----- Method: Time class>>current (in category 'squeak protocol') -----
current
^ self now!
----- Method: Time class>>dateAndTimeFromSeconds: (in category 'smalltalk-80') -----
dateAndTimeFromSeconds: secondCount
^ Array
with: (Date fromSeconds: secondCount)
with: (Time fromSeconds: secondCount \\ 86400)
!
----- Method: Time class>>dateAndTimeNow (in category 'smalltalk-80') -----
dateAndTimeNow
"Answer a two-element Array of (Date today, Time now)."
^ self dateAndTimeFromSeconds: self totalSeconds!
----- Method: Time class>>fromSeconds: (in category 'smalltalk-80') -----
fromSeconds: secondCount
"Answer an instance of me that is secondCount number of seconds since midnight."
^ self seconds: secondCount
!
----- Method: Time class>>hour:minute:second: (in category 'squeak protocol') -----
hour: hour minute: minute second: second
"Answer a Time"
^ self hour: hour minute: minute second: second nanoSecond: 0!
----- Method: Time class>>hour:minute:second:nanoSecond: (in category 'squeak protocol') -----
hour: hour minute: minute second: second nanoSecond: nanoCount
"Answer a Time - only second precision for now"
^ self
seconds: (hour * SecondsInHour) + (minute * SecondsInMinute) + second
nanoSeconds: nanoCount!
----- Method: Time class>>humanWordsForSecondsAgo: (in category 'general inquiries') -----
humanWordsForSecondsAgo: secs
| date today |
"Return natural language for this date and time in the past."
secs <= 1 ifTrue: [^ 'a second ago'].
secs < 45 ifTrue: [^ secs printString, ' seconds ago'].
secs < 90 ifTrue: [^ 'a minute ago'].
secs < "45*60" 2700 ifTrue: [^ (secs//60) printString, ' minutes ago'].
secs < "90*60" 5400 ifTrue: [^ 'an hour ago'].
secs < "18*60*60" 64800 ifTrue: [^ (secs//3600) printString, ' hours ago'].
date _ Date fromSeconds: self totalSeconds - secs. "now work with dates"
today _ Date today.
date > (today subtractDays: 2) ifTrue: [^ 'yesterday'].
date > (today subtractDays: 8) ifTrue: [^ 'last ', date dayOfWeekName].
date > (today subtractDays: 13) ifTrue: [^ 'a week ago'].
date > (today subtractDays: 28) ifTrue: [
^ ((today subtractDate: date)//7) printString, ' weeks ago'].
date > (today subtractDays: 45) ifTrue: [^ 'a month ago'].
date > (today subtractDays: 300) ifTrue: [^ 'last ', date monthName].
^ date monthName, ', ', date year printString
"Example
#(0.5 30 62 130 4000 10000 60000 90000 345600 864000 1728000 3456000 17280000 34560000 345600000)
collect: [:ss | Time humanWordsForSecondsAgo: ss].
"!
----- Method: Time class>>midnight (in category 'squeak protocol') -----
midnight
^ self seconds: 0
!
----- Method: Time class>>millisecondClockValue (in category 'general inquiries') -----
millisecondClockValue
"Answer the number of milliseconds since the millisecond clock was last reset or rolled over.
Answer 0 if the primitive fails."
<primitive: 135>
^ 0!
----- Method: Time class>>milliseconds:since: (in category 'squeak protocol') -----
milliseconds: currentTime since: lastTime
"Answer the elapsed time since last recorded in milliseconds.
Compensate for rollover."
| delta |
delta _ currentTime - lastTime.
^ delta < 0
ifTrue: [SmallInteger maxVal + delta]
ifFalse: [delta]
!
----- Method: Time class>>millisecondsSince: (in category 'squeak protocol') -----
millisecondsSince: lastTime
"Answer the elapsed time since last recorded in milliseconds.
Compensate for rollover."
^self milliseconds: self millisecondClockValue since: lastTime!
----- Method: Time class>>millisecondsToRun: (in category 'general inquiries') -----
millisecondsToRun: timedBlock
"Answer the number of milliseconds timedBlock takes to return its value."
| initialMilliseconds |
initialMilliseconds _ self millisecondClockValue.
timedBlock value.
^self millisecondsSince: initialMilliseconds!
----- Method: Time class>>namesForTimes: (in category 'general inquiries') -----
namesForTimes: arrayOfSeconds
| simpleEnglish prev final prevPair myPair |
"Return English descriptions of the times in the array. They are each seconds since 1901. If two names are the same, append the date and time to distinguish them."
simpleEnglish _ arrayOfSeconds collect: [:secsAgo |
self humanWordsForSecondsAgo: self totalSeconds - secsAgo].
prev _ ''.
final _ simpleEnglish copy.
simpleEnglish withIndexDo: [:eng :ind |
eng = prev ifFalse: [eng]
ifTrue: ["both say 'a month ago'"
prevPair _ self dateAndTimeFromSeconds:
(arrayOfSeconds at: ind-1).
myPair _ self dateAndTimeFromSeconds:
(arrayOfSeconds at: ind).
(final at: ind-1) = prev ifTrue: ["only has 'a month ago'"
final at: ind-1 put:
(final at: ind-1), ', ', prevPair first mmddyyyy].
final at: ind put:
(final at: ind), ', ', myPair first mmddyyyy.
prevPair first = myPair first
ifTrue: [
(final at: ind-1) last == $m ifFalse: ["date but no time"
final at: ind-1 put:
(final at: ind-1), ', ', prevPair second printMinutes].
final at: ind put:
(final at: ind), ', ', myPair second printMinutes]].
prev _ eng].
^ final!
----- Method: Time class>>new (in category 'smalltalk-80') -----
new
"Answer a Time representing midnight"
^ self midnight!
----- Method: Time class>>noon (in category 'squeak protocol') -----
noon
^ self seconds: (SecondsInDay / 2)
!
----- Method: Time class>>now (in category 'ansi protocol') -----
now
"Answer a Time representing the time right now - this is a 24 hour clock."
^ self seconds: self totalSeconds \\ 86400.
!
----- Method: Time class>>primMillisecondClock (in category 'smalltalk-80') -----
primMillisecondClock
"Primitive. Answer the number of milliseconds since the millisecond clock
was last reset or rolled over. Answer zero if the primitive fails.
Optional. See Object documentation whatIsAPrimitive."
<primitive: 135>
^ 0!
----- Method: Time class>>primSecondsClock (in category 'smalltalk-80') -----
primSecondsClock
"Answer the number of seconds since 00:00 on the morning of
January 1, 1901 (a 32-bit unsigned number).
Essential. See Object documentation whatIsAPrimitive. "
<primitive: 137>
self primitiveFailed!
----- Method: Time class>>readFrom: (in category 'smalltalk-80') -----
readFrom: aStream
"Read a Time from the stream in the form:
<hour>:<minute>:<second> <am/pm>
<minute>, <second> or <am/pm> may be omitted. e.g. 1:59:30 pm; 8AM; 15:30"
| hour minute second ampm |
hour _ Integer readFrom: aStream.
minute _ 0.
second _ 0.
(aStream peekFor: $:) ifTrue:
[ minute _ Integer readFrom: aStream.
(aStream peekFor: $:) ifTrue: [ second _ Integer readFrom: aStream ]].
aStream skipSeparators.
(aStream atEnd not and: [aStream peek isLetter]) ifTrue:
[ampm _ aStream next asLowercase.
(ampm = $p and: [hour < 12]) ifTrue: [hour _ hour + 12].
(ampm = $a and: [hour = 12]) ifTrue: [hour _ 0].
(aStream peekFor: $m) ifFalse: [aStream peekFor: $M ]].
^ self hour: hour minute: minute second: second
"Time readFrom: (ReadStream on: '2:23:09 pm')"
!
----- Method: Time class>>seconds: (in category 'squeak protocol') -----
seconds: seconds
"Answer a Time from midnight"
^ self seconds: seconds nanoSeconds: 0!
----- Method: Time class>>seconds:nanoSeconds: (in category 'squeak protocol') -----
seconds: seconds nanoSeconds: nanoCount
"Answer a Time from midnight"
^ self basicNew
ticks: (Duration seconds: seconds nanoSeconds: nanoCount) ticks;
yourself
!
----- Method: Time class>>totalSeconds (in category 'smalltalk-80') -----
totalSeconds
"Answer the total seconds since the Squeak epoch: 1 January 1901."
^ self primSecondsClock!
----- Method: Time>>< (in category 'ansi protocol') -----
< aTime
^ self asDuration < aTime asDuration!
----- Method: Time>>= (in category 'ansi protocol') -----
= aTime
^ [ self ticks = aTime ticks ]
on: MessageNotUnderstood do: [false]!
----- Method: Time>>addSeconds: (in category 'smalltalk-80') -----
addSeconds: nSeconds
"Answer a Time that is nSeconds after the receiver."
^ self class seconds: self asSeconds + nSeconds!
----- Method: Time>>addTime: (in category 'smalltalk-80') -----
addTime: timeAmount
"Answer a Time that is timeInterval after the receiver. timeInterval is an
instance of Date or Time."
^ self class seconds: self asSeconds + timeAmount asSeconds!
----- Method: Time>>asDate (in category 'squeak protocol') -----
asDate
^ Date today!
----- Method: Time>>asDateAndTime (in category 'squeak protocol') -----
asDateAndTime
^ DateAndTime today + self!
----- Method: Time>>asDuration (in category 'squeak protocol') -----
asDuration
"Answer the duration since midnight"
^ Duration seconds: seconds nanoSeconds: nanos
!
----- Method: Time>>asMonth (in category 'squeak protocol') -----
asMonth
^ self asDateAndTime asMonth!
----- Method: Time>>asNanoSeconds (in category 'squeak protocol') -----
asNanoSeconds
"Answer the number of nanoseconds since midnight"
^ self asDuration asNanoSeconds
!
----- Method: Time>>asSeconds (in category 'smalltalk-80') -----
asSeconds
"Answer the number of seconds since midnight of the receiver."
^ seconds!
----- Method: Time>>asTime (in category 'squeak protocol') -----
asTime
^ self!
----- Method: Time>>asTimeStamp (in category 'squeak protocol') -----
asTimeStamp
^ self asDateAndTime asTimeStamp!
----- Method: Time>>asWeek (in category 'squeak protocol') -----
asWeek
^ self asDateAndTime asWeek!
----- Method: Time>>asYear (in category 'squeak protocol') -----
asYear
^ self asDateAndTime asYear!
----- Method: Time>>duration (in category 'ansi protocol') -----
duration
^ Duration zero
!
----- Method: Time>>hash (in category 'ansi protocol') -----
hash
^ self ticks hash
!
----- Method: Time>>hhmm24 (in category 'printing') -----
hhmm24
"Return a string of the form 1123 (for 11:23 am), 2154 (for 9:54 pm), of exactly 4 digits"
^(String streamContents:
[ :aStream | self print24: true showSeconds: false on: aStream ])
copyWithout: $:!
----- Method: Time>>hour (in category 'ansi protocol') -----
hour
^ self hour24
!
----- Method: Time>>hour12 (in category 'ansi protocol') -----
hour12
"Answer an <integer> between 1 and 12, inclusive, representing the hour
of the day in the 12-hour clock of the local time of the receiver."
^ self hour24 - 1 \\ 12 + 1!
----- Method: Time>>hour24 (in category 'ansi protocol') -----
hour24
^ self asDuration hours
!
----- Method: Time>>hours (in category 'smalltalk-80') -----
hours
^ self hour!
----- Method: Time>>hours: (in category 'deprecated') -----
hours: anInteger
self
deprecated: 'Deprecated';
hours: anInteger minutes: 0 seconds: 0.
!
----- Method: Time>>hours:minutes:seconds: (in category 'deprecated') -----
hours: hourInteger minutes: minInteger seconds: secInteger
self
deprecated: 'Deprecated';
setSeconds: (hourInteger * SecondsInHour) + (minInteger * SecondsInMinute) + secInteger.
!
----- Method: Time>>intervalString (in category 'smalltalk-80') -----
intervalString
"Treat the time as a difference. Give it in hours and minutes with two digits of accuracy."
| d |
d _ self asDuration.
^ String streamContents: [ :s |
d hours > 0 ifTrue: [s print: d hours; nextPutAll: ' hours'].
d minutes > 0 ifTrue: [s space; print: d minutes; nextPutAll: ' minutes'].
d seconds > 0 ifTrue: [s space; print: d seconds; nextPutAll: ' seconds'] ].
!
----- Method: Time>>meridianAbbreviation (in category 'ansi protocol') -----
meridianAbbreviation
^ self hour < 12 ifTrue: ['AM'] ifFalse: ['PM'].
!
----- Method: Time>>minute (in category 'ansi protocol') -----
minute
^ self asDuration minutes!
----- Method: Time>>minutes (in category 'smalltalk-80') -----
minutes
^ self asDuration minutes!
----- Method: Time>>nanoSecond (in category 'squeak protocol') -----
nanoSecond
^ nanos
!
----- Method: Time>>print24 (in category 'printing') -----
print24
"Return as 8-digit string 'hh:mm:ss', with leading zeros if needed"
^String streamContents:
[ :aStream | self print24: true on: aStream ]
!
----- Method: Time>>print24:on: (in category 'printing') -----
print24: hr24 on: aStream
"Format is 'hh:mm:ss' or 'h:mm:ss am' "
self print24: hr24 showSeconds: true on: aStream
!
----- Method: Time>>print24:showSeconds:on: (in category 'printing') -----
print24: hr24 showSeconds: showSeconds on: aStream
"Format is 'hh:mm:ss' or 'h:mm:ss am' or, if showSeconds is false, 'hh:mm' or 'h:mm am'"
| h m s |
h _ self hour. m _ self minute. s _ self second.
hr24
ifTrue:
[ h < 10 ifTrue: [ aStream nextPutAll: '0' ].
h printOn: aStream ]
ifFalse:
[ h > 12
ifTrue: [h - 12 printOn: aStream]
ifFalse:
[h < 1
ifTrue: [ 12 printOn: aStream ]
ifFalse: [ h printOn: aStream ]]].
aStream nextPutAll: (m < 10 ifTrue: [':0'] ifFalse: [':']).
m printOn: aStream.
showSeconds ifTrue:
[ aStream nextPutAll: (s < 10 ifTrue: [':0'] ifFalse: [':']).
s asInteger printOn: aStream ].
hr24 ifFalse:
[ aStream nextPutAll: (h < 12 ifTrue: [' am'] ifFalse: [' pm']) ].
!
----- Method: Time>>printMinutes (in category 'printing') -----
printMinutes
"Return as string 'hh:mm pm' "
^String streamContents:
[ :aStream | self print24: false showSeconds: false on: aStream ]
!
----- Method: Time>>printOn: (in category 'printing') -----
printOn: aStream
self print24: false showSeconds: (self seconds ~= 0) on: aStream!
----- Method: Time>>second (in category 'ansi protocol') -----
second
^ self asDuration seconds!
----- Method: Time>>seconds (in category 'smalltalk-80') -----
seconds
^ self second!
----- Method: Time>>setSeconds: (in category 'deprecated') -----
setSeconds: secondCount
self
deprecated: 'Deprecated'.
self ticks: { 0. secondCount. 0 }
!
----- Method: Time>>storeOn: (in category 'printing') -----
storeOn: aStream
aStream print: self printString; nextPutAll: ' asTime'!
----- Method: Time>>subtractTime: (in category 'smalltalk-80') -----
subtractTime: timeAmount
"Answer a Time that is timeInterval before the receiver. timeInterval is
an instance of Date or Time."
^ self class seconds: self asSeconds - timeAmount asSeconds!
----- Method: Time>>ticks (in category 'private') -----
ticks
"Answer an Array: { seconds. nanoSeconds }"
^ Array with: 0 with: seconds with: nanos.!
----- Method: Time>>ticks: (in category 'private') -----
ticks: anArray
"ticks is an Array: { days. seconds. nanoSeconds }"
seconds _ anArray second.
nanos _ anArray third.!
----- Method: Time>>to: (in category 'squeak protocol') -----
to: anEnd
"Answer a Timespan. anEnd must respond to #asDateAndTime"
^ self asDateAndTime to: anEnd!
Object subclass: #TimeZone
instanceVariableNames: 'offset abbreviation name'
classVariableNames: ''
poolDictionaries: 'ChronologyConstants'
category: 'Kernel-Chronology'!
!TimeZone commentStamp: 'brp 9/4/2003 06:32' prior: 0!
TimeZone is a simple class to colect the information identifying a UTC time zone.
offset - Duration - the time zone's offset from UTC
abbreviation - String - the abbreviated name for the time zone.
name - String - the name of the time zone.
TimeZone class >> #timeZones returns an array of the known time zones
TimeZone class >> #default returns the default time zone (Grenwich Mean Time)!
----- Method: TimeZone class>>default (in category 'accessing') -----
default
"Answer the default time zone - GMT"
^ self timeZones detect: [ :tz | tz offset = Duration zero ]
!
----- Method: TimeZone class>>offset:name:abbreviation: (in category 'instance creation') -----
offset: aDuration name: aName abbreviation: anAbbreviation
^ self new
offset: aDuration;
name: aName;
abbreviation: anAbbreviation;
yourself!
----- Method: TimeZone class>>timeZones (in category 'accessing') -----
timeZones
^ {
self offset: 0 hours name: 'Universal Time' abbreviation: 'UTC'.
self offset: 0 hours name: 'Greenwich Mean Time' abbreviation: 'GMT'.
self offset: 0 hours name: 'British Summer Time' abbreviation: 'BST'.
self offset: 2 hours name: 'South African Standard Time' abbreviation: 'SAST'.
self offset: -8 hours name: 'Pacific Standard Time' abbreviation: 'PST'.
self offset: -7 hours name: 'Pacific Daylight Time' abbreviation: 'PDT'.
}
!
----- Method: TimeZone>>abbreviation (in category 'accessing') -----
abbreviation
^ abbreviation
!
----- Method: TimeZone>>abbreviation: (in category 'accessing') -----
abbreviation: aString
abbreviation _ aString
!
----- Method: TimeZone>>name (in category 'accessing') -----
name
^ name
!
----- Method: TimeZone>>name: (in category 'accessing') -----
name: aString
name _ aString
!
----- Method: TimeZone>>offset (in category 'accessing') -----
offset
^ offset!
----- Method: TimeZone>>offset: (in category 'accessing') -----
offset: aDuration
offset _ aDuration!
----- Method: TimeZone>>printOn: (in category 'private') -----
printOn: aStream
super printOn: aStream.
aStream
nextPut: $(;
nextPutAll: self abbreviation;
nextPut: $).!
Timespan subclass: #Week
instanceVariableNames: ''
classVariableNames: 'StartDay'
poolDictionaries: 'ChronologyConstants'
category: 'Kernel-Chronology'!
!Week commentStamp: 'brp 5/13/2003 09:48' prior: 0!
I represent a week.!
----- Method: Week class>>dayNames (in category 'squeak protocol') -----
dayNames
^ DayNames
!
----- Method: Week class>>indexOfDay: (in category 'squeak protocol') -----
indexOfDay: aSymbol
^ DayNames indexOf: aSymbol
!
----- Method: Week class>>nameOfDay: (in category 'smalltalk-80') -----
nameOfDay: anIndex
^ DayNames at: anIndex
!
----- Method: Week class>>startDay (in category 'squeak protocol') -----
startDay
^ StartDay
ifNil: [ StartDay
_ DayNames first ]!
----- Method: Week class>>startDay: (in category 'squeak protocol') -----
startDay: aSymbol
(DayNames includes: aSymbol)
ifTrue: [ StartDay _ aSymbol ]
ifFalse: [ self error: aSymbol, ' is not a recognised day name' ]
!
----- Method: Week class>>startMonday (in category 'deprecated') -----
startMonday
self deprecated: 'Use #startDay'.
^ self startDay = #Monday!
----- Method: Week class>>starting:duration: (in category 'squeak protocol') -----
starting: aDateAndTime duration: aDuration
"Override - the duration is always one week.
Week will start from the Week class>>startDay"
| midnight delta adjusted |
midnight _ aDateAndTime asDateAndTime midnight.
delta _ ((midnight dayOfWeek + 7 - (DayNames indexOf: self startDay)) rem: 7) abs.
adjusted _ midnight - (Duration days: delta hours: 0 minutes: 0 seconds: 0).
^ super starting: adjusted duration: (Duration weeks: 1).!
----- Method: Week class>>toggleStartMonday (in category 'deprecated') -----
toggleStartMonday
self deprecated: 'Use #startDay:'.
(self startDay = #Monday)
ifTrue: [ self startDay: #Sunday ]
ifFalse: [ self startDay: #Monday ]!
----- Method: Week>>asWeek (in category 'squeak protocol') -----
asWeek
^ self
!
----- Method: Week>>do: (in category 'deprecated') -----
do: aBlock
self deprecated: 'Use #datesDo:'.
self datesDo: aBlock!
----- Method: Week>>index (in category 'squeak protocol') -----
index
self deprecated: 'obsolete'.
^ self indexInMonth: self asMonth
!
----- Method: Week>>indexInMonth: (in category 'deprecated') -----
indexInMonth: aMonth
"1=first week, 2=second week, etc."
self deprecated: 'obsolete'.
^ (Date dayOfWeek: aMonth dayOfWeekName) + self dayOfMonth - 2 // 7 + 1
!
----- Method: Week>>printOn: (in category 'squeak protocol') -----
printOn: aStream
aStream nextPutAll: 'a Week starting: '.
self start printOn: aStream.
!
SharedPool subclass: #EventSensorConstants
instanceVariableNames: ''
classVariableNames: 'BlueButtonBit CommandKeyBit CtrlKeyBit EventKeyChar EventKeyDown EventKeyUp EventTypeDragDropFiles EventTypeKeyboard EventTypeMenu EventTypeMouse EventTypeNone EventTypeWindow OptionKeyBit RedButtonBit ShiftKeyBit YellowButtonBit'
poolDictionaries: ''
category: 'Kernel-Processes'!
InputSensor subclass: #EventSensor
instanceVariableNames: 'mouseButtons mousePosition keyboardBuffer interruptKey interruptSemaphore eventQueue inputSemaphore lastEventPoll hasInputSemaphore'
classVariableNames: 'EventPollPeriod EventTicklerProcess'
poolDictionaries: 'EventSensorConstants'
category: 'Kernel-Processes'!
!EventSensor commentStamp: 'nk 4/13/2004 11:18' prior: 0!
EventSensor is a replacement for InputSensor 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:
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.
!
----- Method: EventSensor class>>eventPollPeriod (in category 'class initialization') -----
eventPollPeriod
^EventPollPeriod ifNil: [ EventPollPeriod _ 500 ].!
----- 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.!
----- 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"!
----- 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 millisecondClockValue;
at: 3 put: pos x;
at: 4 put: pos y;
at: 5 put: mapped;
at: 6 put: modifiers.
^ eventBuffer!
----- Method: EventSensor>>eventQueue (in category 'accessing') -----
eventQueue
"Return the current event queue"
^eventQueue!
----- 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 | ].
true ] whileTrue.!
----- Method: EventSensor>>eventTicklerProcess (in category 'accessing') -----
eventTicklerProcess
"Answer my event tickler process, if any"
^EventTicklerProcess!
----- 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].
!
----- Method: EventSensor>>flushAllButDandDEvents (in category 'accessing') -----
flushAllButDandDEvents
| newQueue oldQueue |
newQueue _ SharedQueue new.
self eventQueue ifNil:
[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]].
eventQueue := newQueue.
!
----- Method: EventSensor>>flushEvents (in category 'accessing') -----
flushEvents
eventQueue ifNotNil:[eventQueue flush].!
----- Method: EventSensor>>flushNonKbdEvents (in category 'private') -----
flushNonKbdEvents
| dndEvents |
eventQueue ifNil: [^ self].
dndEvents := eventQueue flushAllSuchThat:
[:buf | self isDandDEvent: buf].
eventQueue flushAllSuchThat:
[:buf | (self isKbdEvent: buf) not].
dndEvents do:
[:buf | eventQueue nextPut: buf]!
----- Method: EventSensor>>hasDandDEvents (in category 'accessing') -----
hasDandDEvents
| found |
found := false.
eventQueue nextOrNilSuchThat: [:buf |
(self isDandDEvent: buf) ifTrue: [found := true].
false].
^found!
----- 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.!
----- 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.
!
----- Method: EventSensor>>isDandDEvent: (in category 'private') -----
isDandDEvent: buf
^ (buf at: 1) = EventTypeDragDropFiles!
----- Method: EventSensor>>isKbdEvent: (in category 'private') -----
isKbdEvent: buf
^ (buf at: 1) = EventTypeKeyboard and: [(buf at: 4) = EventKeyChar]!
----- Method: EventSensor>>lastEventPoll (in category 'private') -----
lastEventPoll
"Answer the last clock value at which fetchMoreEvents was called."
^lastEventPoll ifNil: [ lastEventPoll _ Time millisecondClockValue ]!
----- 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!
----- Method: EventSensor>>nextEvent (in category 'accessing') -----
nextEvent
"Return the next event from the receiver."
eventQueue == nil
ifTrue:[^self nextEventSynthesized]
ifFalse:[^self nextEventFromQueue]
!
----- Method: EventSensor>>nextEventFromQueue (in category 'private') -----
nextEventFromQueue
"Return the next event from the receiver."
eventQueue isEmpty ifTrue:[self fetchMoreEvents].
eventQueue isEmpty
ifTrue:[^nil]
ifFalse:[^eventQueue next]!
----- 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 millisecondClockValue. "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 millisecondClockValue;
at: 3 put: pos x;
at: 4 put: pos y;
at: 5 put: mapped;
at: 6 put: modifiers.
^ array
!
----- Method: EventSensor>>peekButtons (in category 'accessing') -----
peekButtons
self fetchMoreEvents.
^mouseButtons!
----- Method: EventSensor>>peekEvent (in category 'accessing') -----
peekEvent
"Look ahead at the next event."
eventQueue ifNil:[^nil].
self fetchMoreEvents.
^eventQueue peek!
----- Method: EventSensor>>peekKeyboardEvent (in category 'accessing') -----
peekKeyboardEvent
"Return the next keyboard char event from the receiver or nil if none available"
^eventQueue nextOrNilSuchThat:
[:buf |
buf first = EventTypeKeyboard and: [(buf fourth) = EventKeyChar]]!
----- Method: EventSensor>>peekMousePt (in category 'accessing') -----
peekMousePt
^mousePosition!
----- Method: EventSensor>>peekPosition (in category 'accessing') -----
peekPosition
self fetchMoreEvents.
^mousePosition!
----- 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 _ super primKbdNext.
kbd = nil ifFalse:[
"simulate keyboard event"
array at: 1 put: EventTypeKeyboard. "evt type"
array at: 2 put: Time millisecondClockValue. "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 _ super primMouseButtons.
pos _ super primMousePt.
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 millisecondClockValue;
at: 3 put: pos x;
at: 4 put: pos y;
at: 5 put: mapped;
at: 6 put: modifiers.
!
----- 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"
super primInterruptSemaphore: aSemaphore!
----- 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].
eventQueue ifNotNil:
[evtBuf _ eventQueue nextOrNilSuchThat: [:buf | self isKbdEvent: buf].
self flushNonKbdEvents].
^ evtBuf ifNotNil: [evtBuf at: 3]
!
----- 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.
eventQueue ifNotNil:
[eventQueue 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!
----- Method: EventSensor>>primMouseButtons (in category 'private') -----
primMouseButtons
self fetchMoreEvents.
self flushNonKbdEvents.
^ mouseButtons!
----- Method: EventSensor>>primMousePt (in category 'private') -----
primMousePt
self fetchMoreEvents.
self flushNonKbdEvents.
^ mousePosition!
----- 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!
----- 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"
super primSetInterruptKey: anInteger!
----- Method: EventSensor>>processEvent: (in category 'private-I/O') -----
processEvent: evt
"Process a single event. This method is run at high priority."
| type |
type _ evt at: 1.
"Check if the event is a user interrupt"
(type = EventTypeKeyboard and:[(evt at: 4) = 0 and:[
((evt at: 3) bitOr: ((evt at: 5) bitShift: 8)) = interruptKey]])
ifTrue:["interrupt key is meta - not reported as event"
^interruptSemaphore signal].
"Store the event in the queue if there's any"
type = EventTypeMouse ifTrue:
[evt at: 5 put: (ButtonDecodeTable at: (evt at: 5) + 1)].
(type = EventTypeKeyboard and: [Preferences swapControlAndAltKeys])
ifTrue: [self swapControlAndAltKeys: evt].
self queueEvent: evt.
"Update state for InputSensor."
EventTypeMouse = type ifTrue:[self processMouseEvent: evt].
EventTypeKeyboard = type ifTrue:[self processKeyboardEvent: evt]!
----- Method: EventSensor>>processKeyboardEvent: (in category 'private-I/O') -----
processKeyboardEvent: evt
"process a keyboard event, updating InputSensor state"
| charCode pressCode |
"Never update keyboardBuffer if we have an eventQueue active"
mouseButtons _ (mouseButtons bitAnd: 7) bitOr: ((evt at: 5) bitShift: 3).
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.!
----- Method: EventSensor>>processMouseEvent: (in category 'private-I/O') -----
processMouseEvent: evt
"process a mouse event, updating InputSensor 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).!
----- 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."
eventQueue ifNil:[^self].
eventQueue nextPut: evt clone.!
----- Method: EventSensor>>shutDown (in category 'initialize') -----
shutDown
super shutDown.
EventTicklerProcess ifNotNil: [
EventTicklerProcess terminate.
EventTicklerProcess _ nil. ].
inputSemaphore ifNotNil:[Smalltalk unregisterExternalObject: inputSemaphore].
!
----- Method: EventSensor>>startUp (in category 'initialize') -----
startUp
"Run the I/O process"
self initialize.
self primSetInputSemaphore: (Smalltalk registerExternalObject: inputSemaphore).
super startUp.
self installEventTickler.
Smalltalk isMorphic ifTrue:[self flushAllButDandDEvents].
"Attempt to discover whether the input semaphore is actually being signaled."
hasInputSemaphore := false.
inputSemaphore initSignals.
!
----- Method: EventSensor>>swapControlAndAltKeys: (in category 'private-I/O') -----
swapControlAndAltKeys: evt
| char |
char := evt at: 3.
"Cursor keys and mouse wheel are not switched."
(#(28 29 30 31) includes: char) ifTrue: [^ self].
(evt at: 5) == CtrlKeyBit
ifTrue: ["Ctrl -> Alt (^A -> a)"
char < 32 ifTrue: [#(3 6) do: [:ind | evt at: ind put: (char bitOr: 16r60)]].
evt at: 5 put: 8]
ifFalse: [(evt at: 5) == CommandKeyBit
ifTrue: ["Alt -> Ctrl (a -> ^A)"
(char >= 16r60 and: [char < 16r80]) ifTrue: [#(3 6) do: [:ind | evt at: ind put: (char bitAnd: 16r1F)]].
evt at: 5 put: 2]].!
----- 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.
"Press codes for keyboard events"
EventKeyChar := 0.
EventKeyDown := 1.
EventKeyUp := 2.
!
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.!
----- 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!
----- Method: Semaphore class>>new (in category 'instance creation') -----
new
"Answer a new instance of Semaphore that contains no signals."
^self basicNew initSignals!
----- Method: Semaphore>>= (in category 'comparing') -----
= anObject
^ self == anObject!
----- 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."
| blockValue 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 is not a real send and
therefore not interruptable either)."
caught := false.
[
caught := true.
self wait.
blockValue := mutuallyExcludedBlock value
] ensure: [
caught ifTrue: [self signal].
].
^blockValue
!
----- 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."
| blockValue caught |
caught := false. "See comment in Semaphore>>critical:"
[
caught := true.
self wait.
[blockValue := mutuallyExcludedBlock value] ifCurtailed: terminationBlock
] ensure: [
caught ifTrue:[self signal].
].
^blockValue!
----- 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 caught |
caught := false. "See comment in Semaphore>>critical:"
[
caught := true.
self wait.
hasError := false.
blockValue := [mutuallyExcludedBlock value] ifError:[:msg :rcvr|
hasError := true.
errMsg := msg.
errRcvr := rcvr
].
] ensure: [
caught ifTrue:[self signal].
].
hasError ifTrue:[ ^errorBlock value: errMsg value: errRcvr].
^blockValue!
----- 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, evaluate
alternativeBlock."
| blockValue caught |
"Note: The following is tricky and depends on the fact that the VM will not switch between processes while executing byte codes (process switches happen only in real sends). The following test is written carefully so that it will result in bytecodes only."
excessSignals == 0 ifTrue:[
"If we come here, then the semaphore was locked when the test executed.
Evaluate the alternative block and answer its result."
^alternativeBlock value
].
caught := false. "See comment in Semaphore>>critical:"
[
caught := true.
self wait.
blockValue := mutuallyExcludedBlock value.
] ensure: [
caught ifTrue:[self signal].
].
^blockValue!
----- Method: Semaphore>>hash (in category 'comparing') -----
hash
^ self identityHash!
----- Method: Semaphore>>initSignals (in category 'initialize-release') -----
initSignals
"Consume any excess signals the receiver may have accumulated."
excessSignals _ 0.!
----- Method: Semaphore>>isSignaled (in category 'testing') -----
isSignaled
"Return true if this semaphore is currently signaled"
^excessSignals > 0!
----- 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]"
!
----- Method: Semaphore>>terminateProcess (in category 'initialize-release') -----
terminateProcess
"Terminate the process waiting on this semaphore, if any."
self isEmpty ifFalse: [ self removeFirst terminate ].!
----- 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]"
!
----- Method: Semaphore>>waitTimeoutMSecs: (in category 'communication') -----
waitTimeoutMSecs: anInteger
"Wait on this semaphore for up to the given number of milliseconds, then timeout. It is up to the sender to determine the difference between the expected event and a timeout."
| d |
d _ Delay timeoutSemaphore: self afterMSecs: (anInteger max: 0).
self wait.
d unschedule.
!
----- Method: Semaphore>>waitTimeoutSeconds: (in category 'communication') -----
waitTimeoutSeconds: anInteger
"Wait on this semaphore for up to the given number of seconds, then timeout. It is up to the sender to determine the difference between the expected event and a timeout."
self waitTimeoutMSecs: anInteger * 1000.
!
More information about the Packages
mailing list