--- a/BContext.st Thu Nov 23 12:08:17 1995 +0100
+++ b/BContext.st Thu Nov 23 12:17:00 1995 +0100
@@ -11,10 +11,10 @@
"
Context subclass:#BlockContext
- instanceVariableNames:'' "do not add instvars here"
- classVariableNames:''
- poolDictionaries:''
- category:'Kernel-Methods'
+ instanceVariableNames:''
+ classVariableNames:''
+ poolDictionaries:''
+ category:'Kernel-Methods'
!
!BlockContext class methodsFor:'documentation'!
@@ -33,10 +33,6 @@
"
!
-version
- ^ '$Header: /cvs/stx/stx/libbasic/Attic/BContext.st,v 1.18 1995-11-11 14:26:48 cg Exp $'
-!
-
documentation
"
BlockContexts represent the stack context objects of blocks.
@@ -47,22 +43,42 @@
WARNING: layout and size known by compiler and runtime system -
do not change.
"
+!
+
+version
+ ^ '$Header: /cvs/stx/stx/libbasic/Attic/BContext.st,v 1.19 1995-11-23 11:16:11 cg Exp $'
! !
!BlockContext methodsFor:'accessing'!
+canReturn
+ "return true, if the receiver allows returning through it.
+ For normal method contexts, this normally returns true;
+ for blocks, it (currently) always returns false."
+
+ ^ false
+!
+
+home
+ "return the immediate home of the receiver.
+ normally this is the methodcontext, where the block was created,
+ for nested block contexts, this is the surrounding blocks context."
+
+ home isContext ifFalse:[^ nil]. "copying blocks have no home"
+ ^ home
+!
+
isBlockContext
"return true, iff the receiver is a BlockContext, false otherwise"
^ true
!
-canReturn
- "return true, if the receiver allows returning through it.
- For normal method contexts, this normally returns true;
- for blocks, it (currently) always returns false."
+method
+ "return the method in which the current contexts block was created."
- ^ false
+ home notNil ifTrue:[^ home method].
+ ^ nil
!
methodHome
@@ -82,22 +98,6 @@
^ con
!
-method
- "return the method in which the current contexts block was created."
-
- home notNil ifTrue:[^ home method].
- ^ nil
-!
-
-home
- "return the immediate home of the receiver.
- normally this is the methodcontext, where the block was created,
- for nested block contexts, this is the surrounding blocks context."
-
- home isContext ifFalse:[^ nil]. "copying blocks have no home"
- ^ home
-!
-
selector
"return the selector of the context - which is one of the value
selectors. This selector is not found in the context, but synthesized."
@@ -204,3 +204,4 @@
].
^ '[] in ' , className , '-' , mHome selector printString
! !
+
--- a/Block.st Thu Nov 23 12:08:17 1995 +0100
+++ b/Block.st Thu Nov 23 12:17:00 1995 +0100
@@ -11,10 +11,10 @@
"
CompiledCode subclass:#Block
- instanceVariableNames:'home nargs sourcePos initialPC'
- classVariableNames:'InvalidNewSignal'
- poolDictionaries:''
- category:'Kernel-Methods'
+ instanceVariableNames:'home nargs sourcePos initialPC'
+ classVariableNames:'InvalidNewSignal'
+ poolDictionaries:''
+ category:'Kernel-Methods'
!
!Block class methodsFor:'documentation'!
@@ -33,10 +33,6 @@
"
!
-version
- ^ '$Header: /cvs/stx/stx/libbasic/Block.st,v 1.41 1995-11-15 10:39:54 cg Exp $'
-!
-
documentation
"
Blocks are pieces of executable code which can be evaluated by sending
@@ -82,9 +78,13 @@
NOTICE: layout known by runtime system and compiler - do not change
"
+!
+
+version
+ ^ '$Header: /cvs/stx/stx/libbasic/Block.st,v 1.42 1995-11-23 11:15:56 cg Exp $'
! !
-!Block class methodsFor:'initialization' !
+!Block class methodsFor:'initialization'!
initialize
"setup the signals"
@@ -96,22 +96,6 @@
]
! !
-!Block methodsFor:'copying'!
-
-deepCopy
- "raise an error - deepCopy is not allowed for blocks"
-
- ^ self deepCopyError
-! !
-
-!Block class methodsFor:'queries'!
-
-isBuiltInClass
- "this class is known by the run-time-system"
-
- ^ true
-! !
-
!Block class methodsFor:'instance creation'!
code:codeAddress byteCode:bCode numArgs:numArgs sourcePosition:sourcePos initialPC:initialPC literals:literals dynamic:dynamic
@@ -142,31 +126,36 @@
^ InvalidNewSignal raise.
! !
-!Block methodsFor:'testing'!
+!Block class methodsFor:'queries'!
-isBlock
- "return true, if this is a block - yes I am"
+isBuiltInClass
+ "this class is known by the run-time-system"
^ true
! !
-!Block methodsFor:'accessing'!
+!Block methodsFor:'STV compatibility'!
-numArgs
- "return the number of arguments I expect for evaluation"
-
- ^ nargs
-!
+on:aSignal do:exceptionBlock
+ "added for ST/V compatibility; evaluate the receiver,
+ handling aSignal. The argument, exceptionBlock is evaluated
+ if the signal is raised during evaluation.
+ Warning: no warranty, if the code below mimics ST/V's behavior
+ correctly - give me a note if it does not ."
-methodHome
- "return the receivers method home context (the context where it was
- defined). For cheap blocks, nil is returned"
+ aSignal handle:[:ex |
+ exceptionBlock value.
+ ex return
+ ] do:self
- home notNil ifTrue:[
- ^ home methodHome
- ].
- ^ home
-!
+ "
+ [
+ 1 foo
+ ] on:MessageNotUnderstoodSignal do:[]
+ "
+! !
+
+!Block methodsFor:'accessing'!
home
"return the receivers home context (the context where it was
@@ -183,51 +172,34 @@
^ home method
].
^ nil
-! !
-
-!Block methodsFor:'private accessing'!
-
-code:codeAddress byteCode:bCode numArgs:numArgs sourcePosition:srcPos initialPC:iPC literals:lits dynamic:dynamic
- "set all relevant internals"
+!
- self code:codeAddress.
- byteCode := bCode.
- nargs := numArgs.
- sourcePos := srcPos.
- initialPC := iPC.
- literals := lits.
- self dynamic:dynamic
+methodHome
+ "return the receivers method home context (the context where it was
+ defined). For cheap blocks, nil is returned"
+
+ home notNil ifTrue:[
+ ^ home methodHome
+ ].
+ ^ home
!
-numArgs:numArgs
- "set the number of arguments I expect for evaluation - DANGER ALERT"
+numArgs
+ "return the number of arguments I expect for evaluation"
- nargs := numArgs
-!
+ ^ nargs
+! !
-sourcePosition:position
- "set the position of the source within my method"
+!Block methodsFor:'copying'!
- sourcePos := position
-!
+deepCopy
+ "raise an error - deepCopy is not allowed for blocks"
-initialPC:initial
- "set the initial pc for evaluation - DANGER ALERT"
-
- initialPC := initial
+ ^ self deepCopyError
! !
!Block methodsFor:'error handling'!
-wrongNumberOfArguments:numberGiven
- "report that the number of arguments given does not match the number expected"
-
- ^ ArgumentSignal
- raiseRequestWith:self
- errorString:('block got ' , numberGiven printString ,
- ' args while ' , nargs printString , ' where expected')
-!
-
invalidCodeObject
"this error is triggered by the interpreter when a non-Block object
is about to be executed.
@@ -238,6 +210,15 @@
^ InvalidCodeSignal
raiseRequestWith:self
errorString:'invalid block - not executable'
+!
+
+wrongNumberOfArguments:numberGiven
+ "report that the number of arguments given does not match the number expected"
+
+ ^ ArgumentSignal
+ raiseRequestWith:self
+ errorString:('block got ' , numberGiven printString ,
+ ' args while ' , nargs printString , ' where expected')
! !
!Block methodsFor:'evaluation'!
@@ -616,115 +597,125 @@
errorString:'only blocks with up-to 7 arguments supported'
! !
-!Block methodsFor:'STV compatibility'!
+!Block methodsFor:'looping'!
-on:aSignal do:exceptionBlock
- "added for ST/V compatibility; evaluate the receiver,
- handling aSignal. The argument, exceptionBlock is evaluated
- if the signal is raised during evaluation.
- Warning: no warranty, if the code below mimics ST/V's behavior
- correctly - give me a note if it does not ."
+doUntil:aBlock
+ "repeat the receiver block until aBlock evaluates to true.
+ The receiver is evaluated at least once.
+ This is the same as '... doWhile:[... not]' "
- aSignal handle:[:ex |
- exceptionBlock value.
- ex return
- ] do:self
+ "this implementation is for purists ... :-)"
+
+ self value.
+ aBlock value ifTrue:[^ nil].
+ thisContext restart
"
- [
- 1 foo
- ] on:MessageNotUnderstoodSignal do:[]
- "
-! !
-
-!Block methodsFor:'privileged evaluation'!
-
-valueUninterruptably
- "evaluate the receiver with interrupts blocked.
- This does not prevent preemption by a higher priority processes
- if any becomes runnable due to the evaluation of the receiver
- (i.e. if a semaphore is signalled)."
-
- Processor activeProcess uninterruptablyDo:self
-!
-
-valueUnpreemptively
- "evaluate the receiver without the possiblity of preemption
- (i.e. at a very high priority)"
-
- |oldPrio activeProcess|
-
- activeProcess := Processor activeProcess.
- oldPrio := activeProcess changePriority:(Processor highestPriority).
- self valueNowOrOnUnwindDo:[
- activeProcess priority:oldPrio
- ]
-! !
+ |n|
-!Block methodsFor:'unwinding'!
-
-valueNowOrOnUnwindDo:aBlock
- "evaluate the receiver - after that, or when some method sent within unwinds (i.e. does
- a long return), evaluate the argument, aBlock.
- This is used to make certain that cleanup actions (for example closing files etc.) are
- executed regardless of error actions"
-
- |v|
-
- thisContext markForUnwind.
- v := self value. "the real logic is in Context>>unwind"
- aBlock value.
- ^ v
-
- "
- in the following example, f will be closed even if the block
- returns with 'oops'. There are many more applications of this kind
- found in the system.
- "
- "
- |f|
-
- f := 'Makefile' asFilename readStream.
- [
- l := f nextLine.
- l isNil ifTrue:[^ 'oops']
- ] valueNowOrOnUnwindDo:[
- f close
- ]
+ n := 1.
+ [n printNewline] doUntil:[ (n := n + 1) > 5 ]
"
!
-valueOnUnwindDo:aBlock
- "evaluate the receiver - when some method sent within unwinds (i.e. does
- a long return), evaluate the argument, aBlock.
- This is used to make certain that cleanup actions (for example closing files etc.) are
- executed regardless of error actions"
-
- thisContext markForUnwind.
- ^ self value "the real logic is in Context>>unwind"
-! !
-
-!Block methodsFor:'looping'!
-
-whileTrue:aBlock
- "evaluate the argument, aBlock while the receiver evaluates to true.
- - usually open coded by compilers, but needed here for #perform
- and expression evaluation."
+doWhile:aBlock
+ "repeat the receiver block until aBlock evaluates to false.
+ The receiver is evaluated at least once."
"this implementation is for purists ... :-)"
- self value ifFalse:[^ nil].
- aBlock value.
+ self value.
+ aBlock value ifFalse:[^ nil].
+ thisContext restart
+
+ "
+ |n|
+
+ n := 1.
+ [n printNewline] doWhile:[ (n := n + 1) <= 5 ]
+ "
+!
+
+loop
+ "repeat the receiver forever (should contain a return somewhere).
+ Inspired by a corresponding Self method."
+
+ self value.
thisContext restart
"
|n|
n := 1.
- [n <= 10] whileTrue:[
+ [
n printNewline.
+ n >= 10 ifTrue:[^ nil].
n := n + 1
- ]
+ ] loop
+ "
+!
+
+loopWithExit
+ "the receiver must be a block of one argument. It is evaluated in a loop forever,
+ and is passed a block, which, if sent a value:-message, will exit the receiver block,
+ returning the parameter of the value:-message. Used for loops with exit in the middle.
+ Inspired by a corresponding Self method."
+
+ |exitBlock|
+
+ exitBlock := [:exitValue | ^ exitValue].
+ [true] whileTrue:[self value:exitBlock]
+
+ "
+ |i|
+ i := 1.
+ [:exit |
+ Transcript showCr:i.
+ i == 5 ifTrue:[exit value:'thats it'].
+ i := i + 1
+ ] loopWithExit
+ "
+!
+
+repeat
+ "repeat the receiver forever - same as loop, for ST-80 compatibility"
+
+ self value.
+ thisContext restart
+!
+
+valueWithExit
+ "the receiver must be a block of one argument. It is evaluated, and is passed a block,
+ which, if sent a value:-message, will exit the receiver block, returning the parameter of the
+ value:-message. Used for premature returns to the caller.
+ Taken from a manchester goody (a similar construct also appears in Self)."
+
+ ^ self value: [:exitValue | ^exitValue]
+
+ "
+ [:exit |
+ 1 to:10 do:[:i |
+ Transcript showCr:i.
+ i == 5 ifTrue:[exit value:'thats it']
+ ].
+ 'regular block-value; never returned'
+ ] valueWithExit
+ "
+!
+
+whileFalse
+ "evaluate the receiver while it evaluates to false (ST80 compatibility)"
+
+ "this implementation is for purists ... :-)"
+
+ self value ifTrue:[^ nil].
+ thisContext restart
+
+ "
+ |n|
+
+ n := 1.
+ [n printNewline. (n := n + 1) > 10] whileFalse
"
!
@@ -766,190 +757,28 @@
"
!
-whileFalse
- "evaluate the receiver while it evaluates to false (ST80 compatibility)"
-
- "this implementation is for purists ... :-)"
-
- self value ifTrue:[^ nil].
- thisContext restart
-
- "
- |n|
-
- n := 1.
- [n printNewline. (n := n + 1) > 10] whileFalse
- "
-!
-
-doWhile:aBlock
- "repeat the receiver block until aBlock evaluates to false.
- The receiver is evaluated at least once."
+whileTrue:aBlock
+ "evaluate the argument, aBlock while the receiver evaluates to true.
+ - usually open coded by compilers, but needed here for #perform
+ and expression evaluation."
"this implementation is for purists ... :-)"
- self value.
- aBlock value ifFalse:[^ nil].
- thisContext restart
-
- "
- |n|
-
- n := 1.
- [n printNewline] doWhile:[ (n := n + 1) <= 5 ]
- "
-!
-
-doUntil:aBlock
- "repeat the receiver block until aBlock evaluates to true.
- The receiver is evaluated at least once.
- This is the same as '... doWhile:[... not]' "
-
- "this implementation is for purists ... :-)"
-
- self value.
- aBlock value ifTrue:[^ nil].
- thisContext restart
-
- "
- |n|
-
- n := 1.
- [n printNewline] doUntil:[ (n := n + 1) > 5 ]
- "
-!
-
-repeat
- "repeat the receiver forever - same as loop, for ST-80 compatibility"
-
- self value.
- thisContext restart
-!
-
-loop
- "repeat the receiver forever (should contain a return somewhere).
- Inspired by a corresponding Self method."
-
- self value.
+ self value ifFalse:[^ nil].
+ aBlock value.
thisContext restart
"
|n|
n := 1.
- [
+ [n <= 10] whileTrue:[
n printNewline.
- n >= 10 ifTrue:[^ nil].
n := n + 1
- ] loop
- "
-!
-
-valueWithExit
- "the receiver must be a block of one argument. It is evaluated, and is passed a block,
- which, if sent a value:-message, will exit the receiver block, returning the parameter of the
- value:-message. Used for premature returns to the caller.
- Taken from a manchester goody (a similar construct also appears in Self)."
-
- ^ self value: [:exitValue | ^exitValue]
-
- "
- [:exit |
- 1 to:10 do:[:i |
- Transcript showCr:i.
- i == 5 ifTrue:[exit value:'thats it']
- ].
- 'regular block-value; never returned'
- ] valueWithExit
- "
-!
-
-loopWithExit
- "the receiver must be a block of one argument. It is evaluated in a loop forever,
- and is passed a block, which, if sent a value:-message, will exit the receiver block,
- returning the parameter of the value:-message. Used for loops with exit in the middle.
- Inspired by a corresponding Self method."
-
- |exitBlock|
-
- exitBlock := [:exitValue | ^ exitValue].
- [true] whileTrue:[self value:exitBlock]
-
- "
- |i|
- i := 1.
- [:exit |
- Transcript showCr:i.
- i == 5 ifTrue:[exit value:'thats it'].
- i := i + 1
- ] loopWithExit
+ ]
"
! !
-!Block methodsFor:'process creation'!
-
-newProcess
- "create a new (unscheduled) process executing the receiver"
-
- ^ Process for:self priority:(Processor activePriority)
-!
-
-newProcessWithArguments:argArray
- "create a new (unscheduled) process executing the receiver,
- passing the elements in argArray as arguments to the receiver block."
-
- ^ [self valueWithArguments:argArray] newProcess
-!
-
-fork
- "create a new process executing the receiver at the current priority."
-
- ^ self newProcess resume
-!
-
-forkWith:argArray
- "create a new process executing the receiver,
- passing elements in argArray as arguments to the receiver block."
-
- ^ [self valueWithArguments:argArray] fork.
-!
-
-forkAt:priority
- "create a new process executing the receiver at a different priority."
-
- ^ (self newProcess priority:priority) resume
-!
-
-promise
- "create a promise on the receiver. The promise will evaluate the
- receiver and promise to return the value with the #value message.
- The evaluation will be performed as a separate process.
- Asking the promise for its value will either block the asking process
- (if the evaluation has not yet been finished) or return the value
- immediately."
-
- ^ Promise value:self
-
- "
- |p|
-
- p := [1000 factorial] promise.
- 'do something else ...'.
- p value
- "
-!
-
-promiseAt:prio
- "create a promise on the receiver. The promise will evaluate the
- receiver and promise to return the value with the #value message.
- The evaluation will be performed as a separate process running at prio.
- Asking the promise for its value will either block the asking process
- (if the evaluation has not yet been finished) or return the value
- immediately."
-
- ^ Promise value:self priority:prio
-! !
-
!Block methodsFor:'printing & storing'!
printOn:aStream
@@ -999,3 +828,176 @@
]
"
! !
+
+!Block methodsFor:'private accessing'!
+
+code:codeAddress byteCode:bCode numArgs:numArgs sourcePosition:srcPos initialPC:iPC literals:lits dynamic:dynamic
+ "set all relevant internals"
+
+ self code:codeAddress.
+ byteCode := bCode.
+ nargs := numArgs.
+ sourcePos := srcPos.
+ initialPC := iPC.
+ literals := lits.
+ self dynamic:dynamic
+!
+
+initialPC:initial
+ "set the initial pc for evaluation - DANGER ALERT"
+
+ initialPC := initial
+!
+
+numArgs:numArgs
+ "set the number of arguments I expect for evaluation - DANGER ALERT"
+
+ nargs := numArgs
+!
+
+sourcePosition:position
+ "set the position of the source within my method"
+
+ sourcePos := position
+! !
+
+!Block methodsFor:'privileged evaluation'!
+
+valueUninterruptably
+ "evaluate the receiver with interrupts blocked.
+ This does not prevent preemption by a higher priority processes
+ if any becomes runnable due to the evaluation of the receiver
+ (i.e. if a semaphore is signalled)."
+
+ Processor activeProcess uninterruptablyDo:self
+!
+
+valueUnpreemptively
+ "evaluate the receiver without the possiblity of preemption
+ (i.e. at a very high priority)"
+
+ |oldPrio activeProcess|
+
+ activeProcess := Processor activeProcess.
+ oldPrio := activeProcess changePriority:(Processor highestPriority).
+ self valueNowOrOnUnwindDo:[
+ activeProcess priority:oldPrio
+ ]
+! !
+
+!Block methodsFor:'process creation'!
+
+fork
+ "create a new process executing the receiver at the current priority."
+
+ ^ self newProcess resume
+!
+
+forkAt:priority
+ "create a new process executing the receiver at a different priority."
+
+ ^ (self newProcess priority:priority) resume
+!
+
+forkWith:argArray
+ "create a new process executing the receiver,
+ passing elements in argArray as arguments to the receiver block."
+
+ ^ [self valueWithArguments:argArray] fork.
+!
+
+newProcess
+ "create a new (unscheduled) process executing the receiver"
+
+ ^ Process for:self priority:(Processor activePriority)
+!
+
+newProcessWithArguments:argArray
+ "create a new (unscheduled) process executing the receiver,
+ passing the elements in argArray as arguments to the receiver block."
+
+ ^ [self valueWithArguments:argArray] newProcess
+!
+
+promise
+ "create a promise on the receiver. The promise will evaluate the
+ receiver and promise to return the value with the #value message.
+ The evaluation will be performed as a separate process.
+ Asking the promise for its value will either block the asking process
+ (if the evaluation has not yet been finished) or return the value
+ immediately."
+
+ ^ Promise value:self
+
+ "
+ |p|
+
+ p := [1000 factorial] promise.
+ 'do something else ...'.
+ p value
+ "
+!
+
+promiseAt:prio
+ "create a promise on the receiver. The promise will evaluate the
+ receiver and promise to return the value with the #value message.
+ The evaluation will be performed as a separate process running at prio.
+ Asking the promise for its value will either block the asking process
+ (if the evaluation has not yet been finished) or return the value
+ immediately."
+
+ ^ Promise value:self priority:prio
+! !
+
+!Block methodsFor:'testing'!
+
+isBlock
+ "return true, if this is a block - yes I am"
+
+ ^ true
+! !
+
+!Block methodsFor:'unwinding'!
+
+valueNowOrOnUnwindDo:aBlock
+ "evaluate the receiver - after that, or when some method sent within unwinds (i.e. does
+ a long return), evaluate the argument, aBlock.
+ This is used to make certain that cleanup actions (for example closing files etc.) are
+ executed regardless of error actions"
+
+ |v|
+
+ thisContext markForUnwind.
+ v := self value. "the real logic is in Context>>unwind"
+ aBlock value.
+ ^ v
+
+ "
+ in the following example, f will be closed even if the block
+ returns with 'oops'. There are many more applications of this kind
+ found in the system.
+ "
+ "
+ |f|
+
+ f := 'Makefile' asFilename readStream.
+ [
+ l := f nextLine.
+ l isNil ifTrue:[^ 'oops']
+ ] valueNowOrOnUnwindDo:[
+ f close
+ ]
+ "
+!
+
+valueOnUnwindDo:aBlock
+ "evaluate the receiver - when some method sent within unwinds (i.e. does
+ a long return), evaluate the argument, aBlock.
+ This is used to make certain that cleanup actions (for example closing files etc.) are
+ executed regardless of error actions"
+
+ thisContext markForUnwind.
+ ^ self value "the real logic is in Context>>unwind"
+! !
+
+Block initialize!
--- a/BlockContext.st Thu Nov 23 12:08:17 1995 +0100
+++ b/BlockContext.st Thu Nov 23 12:17:00 1995 +0100
@@ -11,10 +11,10 @@
"
Context subclass:#BlockContext
- instanceVariableNames:'' "do not add instvars here"
- classVariableNames:''
- poolDictionaries:''
- category:'Kernel-Methods'
+ instanceVariableNames:''
+ classVariableNames:''
+ poolDictionaries:''
+ category:'Kernel-Methods'
!
!BlockContext class methodsFor:'documentation'!
@@ -33,10 +33,6 @@
"
!
-version
- ^ '$Header: /cvs/stx/stx/libbasic/BlockContext.st,v 1.18 1995-11-11 14:26:48 cg Exp $'
-!
-
documentation
"
BlockContexts represent the stack context objects of blocks.
@@ -47,22 +43,42 @@
WARNING: layout and size known by compiler and runtime system -
do not change.
"
+!
+
+version
+ ^ '$Header: /cvs/stx/stx/libbasic/BlockContext.st,v 1.19 1995-11-23 11:16:11 cg Exp $'
! !
!BlockContext methodsFor:'accessing'!
+canReturn
+ "return true, if the receiver allows returning through it.
+ For normal method contexts, this normally returns true;
+ for blocks, it (currently) always returns false."
+
+ ^ false
+!
+
+home
+ "return the immediate home of the receiver.
+ normally this is the methodcontext, where the block was created,
+ for nested block contexts, this is the surrounding blocks context."
+
+ home isContext ifFalse:[^ nil]. "copying blocks have no home"
+ ^ home
+!
+
isBlockContext
"return true, iff the receiver is a BlockContext, false otherwise"
^ true
!
-canReturn
- "return true, if the receiver allows returning through it.
- For normal method contexts, this normally returns true;
- for blocks, it (currently) always returns false."
+method
+ "return the method in which the current contexts block was created."
- ^ false
+ home notNil ifTrue:[^ home method].
+ ^ nil
!
methodHome
@@ -82,22 +98,6 @@
^ con
!
-method
- "return the method in which the current contexts block was created."
-
- home notNil ifTrue:[^ home method].
- ^ nil
-!
-
-home
- "return the immediate home of the receiver.
- normally this is the methodcontext, where the block was created,
- for nested block contexts, this is the surrounding blocks context."
-
- home isContext ifFalse:[^ nil]. "copying blocks have no home"
- ^ home
-!
-
selector
"return the selector of the context - which is one of the value
selectors. This selector is not found in the context, but synthesized."
@@ -204,3 +204,4 @@
].
^ '[] in ' , className , '-' , mHome selector printString
! !
+
--- a/CheapBlk.st Thu Nov 23 12:08:17 1995 +0100
+++ b/CheapBlk.st Thu Nov 23 12:17:00 1995 +0100
@@ -11,10 +11,10 @@
"
Block subclass:#CheapBlock
- instanceVariableNames:'selfValue method'
- classVariableNames:''
- poolDictionaries:''
- category:'Kernel-Methods'
+ instanceVariableNames:'selfValue method'
+ classVariableNames:''
+ poolDictionaries:''
+ category:'Kernel-Methods'
!
!CheapBlock class methodsFor:'documentation'!
@@ -33,10 +33,6 @@
"
!
-version
- ^ '$Header: /cvs/stx/stx/libbasic/Attic/CheapBlk.st,v 1.8 1995-11-11 14:27:49 cg Exp $'
-!
-
documentation
"
CheapBlocks are blocks which do not need their home-context
@@ -53,21 +49,25 @@
NOTICE: layout known by runtime system and compiler - do not change
"
+!
+
+version
+ ^ '$Header: /cvs/stx/stx/libbasic/Attic/CheapBlk.st,v 1.9 1995-11-23 11:16:21 cg Exp $'
! !
!CheapBlock methodsFor:'accessing'!
-selfValue
- "return the copied self"
-
- ^ selfValue
-!
-
method
"return the receivers home method.
Thats the method where the block was created."
^ method
+!
+
+selfValue
+ "return the copied self"
+
+ ^ selfValue
! !
!CheapBlock methodsFor:'printing & storing'!
--- a/CheapBlock.st Thu Nov 23 12:08:17 1995 +0100
+++ b/CheapBlock.st Thu Nov 23 12:17:00 1995 +0100
@@ -11,10 +11,10 @@
"
Block subclass:#CheapBlock
- instanceVariableNames:'selfValue method'
- classVariableNames:''
- poolDictionaries:''
- category:'Kernel-Methods'
+ instanceVariableNames:'selfValue method'
+ classVariableNames:''
+ poolDictionaries:''
+ category:'Kernel-Methods'
!
!CheapBlock class methodsFor:'documentation'!
@@ -33,10 +33,6 @@
"
!
-version
- ^ '$Header: /cvs/stx/stx/libbasic/CheapBlock.st,v 1.8 1995-11-11 14:27:49 cg Exp $'
-!
-
documentation
"
CheapBlocks are blocks which do not need their home-context
@@ -53,21 +49,25 @@
NOTICE: layout known by runtime system and compiler - do not change
"
+!
+
+version
+ ^ '$Header: /cvs/stx/stx/libbasic/CheapBlock.st,v 1.9 1995-11-23 11:16:21 cg Exp $'
! !
!CheapBlock methodsFor:'accessing'!
-selfValue
- "return the copied self"
-
- ^ selfValue
-!
-
method
"return the receivers home method.
Thats the method where the block was created."
^ method
+!
+
+selfValue
+ "return the copied self"
+
+ ^ selfValue
! !
!CheapBlock methodsFor:'printing & storing'!
--- a/CompCode.st Thu Nov 23 12:08:17 1995 +0100
+++ b/CompCode.st Thu Nov 23 12:17:00 1995 +0100
@@ -11,12 +11,11 @@
"
ExecutableFunction subclass:#CompiledCode
- instanceVariableNames:'flags byteCode literals'
- classVariableNames:'NoByteCodeSignal InvalidByteCodeSignal
- InvalidInstructionSignal BadLiteralsSignal
- NonBooleanReceiverSignal ArgumentSignal'
- poolDictionaries:''
- category:'Kernel-Methods'
+ instanceVariableNames:'flags byteCode literals'
+ classVariableNames:'NoByteCodeSignal InvalidByteCodeSignal InvalidInstructionSignal
+ BadLiteralsSignal NonBooleanReceiverSignal ArgumentSignal'
+ poolDictionaries:''
+ category:'Kernel-Methods'
!
!CompiledCode class methodsFor:'documentation'!
@@ -35,10 +34,6 @@
"
!
-version
- ^ '$Header: /cvs/stx/stx/libbasic/Attic/CompCode.st,v 1.20 1995-11-11 14:27:59 cg Exp $'
-!
-
documentation
"
This is an abstract class, to merge common attributes of Blocks and
@@ -66,6 +61,10 @@
NOTICE: layout known by runtime system and compiler - do not change
"
+!
+
+version
+ ^ '$Header: /cvs/stx/stx/libbasic/Attic/CompCode.st,v 1.21 1995-11-23 11:16:31 cg Exp $'
! !
!CompiledCode class methodsFor:'initialization'!
@@ -100,17 +99,17 @@
!CompiledCode class methodsFor:'Signal constants'!
-executionErrorSignal
- "return the parent-signal of all execution errors"
-
- ^ ExecutionErrorSignal
-!
-
argumentSignal
"return the signal raised when something's wrong with the
arguments"
^ ArgumentSignal
+!
+
+executionErrorSignal
+ "return the parent-signal of all execution errors"
+
+ ^ ExecutionErrorSignal
! !
!CompiledCode class methodsFor:'queries'!
@@ -135,6 +134,154 @@
^ literals
! !
+!CompiledCode methodsFor:'error handling'!
+
+badArgumentArray
+ "this error is triggered, if a non array is passed to
+ #valueWithReceiver:.. methods"
+
+ ^ ArgumentSignal
+ raiseRequestWith:self
+ errorString:'argumentArray must be an Array'
+!
+
+badLiteralTable
+ "this error is triggered, when a block/method is called with a bad literal
+ array (i.e. non-array) - this can only happen, if the
+ compiler is broken or someone played around with a block/methods
+ literal table or the GC is broken and corrupted it."
+
+ ^ BadLiteralsSignal raise.
+!
+
+invalidByteCode
+ "this error is triggered when the interpreter tries to execute a
+ code object, where the byteCode is nonNil, but not a ByteArray.
+ Can only happen when Compiler/runtime system is broken or
+ someone played around with a block/method."
+
+ ^ InvalidByteCodeSignal raise.
+!
+
+invalidInstruction
+ "this error is triggered when the bytecode-interpreter tries to
+ execute an invalid bytecode instruction.
+ Can only happen when Compiler/runtime system is broken or
+ someone played around with the block/methods code."
+
+ ^ InvalidInstructionSignal raise.
+!
+
+noByteCode
+ "this error is triggered when the interpreter tries to execute a
+ code object, where both the code and byteCode instances are nil.
+ This can happen if:
+ the Compiler/runtime system is broken,
+ someone played around with a block/method,
+ compilation of a lazy method failed
+ (i.e. the lazy method contains an error or
+ it contains primitive code and there is no stc compiler available)
+ an unloaded object modules method is called for.
+ Only the first case is to be considered serious - it should not happen
+ if the system is used correctly."
+
+ ^ NoByteCodeSignal raise.
+!
+
+receiverNotBoolean:anObject
+ "this error is triggered when the bytecode-interpreter tries to
+ execute ifTrue:/ifFalse or whileTrue: type of expressions where the
+ receiver is neither true nor false."
+
+ ^ NonBooleanReceiverSignal raise.
+!
+
+tooManyArguments
+ "this error is triggered, when a method/block tries to perform a send with
+ more arguments than supported by the interpreter. This can only happen,
+ if the compiler has been changed without updating the VM."
+
+ ^ ArgumentSignal
+ raiseRequestWith:self
+ errorString:'too many args in send'
+! !
+
+!CompiledCode methodsFor:'private accessing'!
+
+byteCode:aByteArray
+ "set the bytecode field - DANGER ALERT"
+
+ byteCode := aByteArray
+!
+
+dynamic
+ "return the flag stating that the machine code was created
+ dynamically (from bytecode)."
+
+%{ /* NOCONTEXT */
+
+ /* made this a primitive to get define in stc.h */
+
+ RETURN ((__intVal(_INST(flags)) & F_DYNAMIC) ? true : false);
+%}
+!
+
+dynamic:aBoolean
+ "set/clear the flag bit stating that the machine code was created
+ dynamically and should be flushed on image-restart.
+ Obsolete - now done in VM"
+
+%{ /* NOCONTEXT */
+
+ int newFlags = _intVal(_INST(flags));
+
+ /* made this a primitive to get define in stc.h */
+ if (aBoolean == true)
+ newFlags |= F_DYNAMIC;
+ else
+ newFlags &= ~F_DYNAMIC;
+
+ _INST(flags) = _MKSMALLINT(newFlags);
+%}
+!
+
+literals:aLiteralArray
+ "set the literal array for evaluation - DANGER ALERT"
+
+ literals := aLiteralArray
+!
+
+markFlag
+ "return the mark bits value as a boolean"
+
+%{ /* NOCONTEXT */
+
+ /* made this a primitive to get define in stc.h */
+
+ RETURN ((__intVal(_INST(flags)) & F_MARKBIT) ? true : false);
+%}
+!
+
+markFlag:aBoolean
+ "set/clear the mark flag bit.
+ This bit is not used by the VM, but instead free to mark codeObjects
+ for any (debugging/tracing) use. For example, the coverage test uses
+ these to mark reached methods. (inspired by a note in c.l.s)"
+
+%{ /* NOCONTEXT */
+
+ int newFlags = _intVal(_INST(flags));
+
+ /* made this a primitive to get define in stc.h */
+ if (aBoolean == true)
+ newFlags |= F_MARKBIT;
+ else
+ newFlags &= ~F_MARKBIT;
+
+ _INST(flags) = _MKSMALLINT(newFlags);
+%}
+! !
+
!CompiledCode methodsFor:'queries'!
messages
@@ -165,150 +312,4 @@
"
! !
-!CompiledCode methodsFor:'private accessing'!
-
-byteCode:aByteArray
- "set the bytecode field - DANGER ALERT"
-
- byteCode := aByteArray
-!
-
-literals:aLiteralArray
- "set the literal array for evaluation - DANGER ALERT"
-
- literals := aLiteralArray
-!
-
-dynamic:aBoolean
- "set/clear the flag bit stating that the machine code was created
- dynamically and should be flushed on image-restart.
- Obsolete - now done in VM"
-
-%{ /* NOCONTEXT */
-
- int newFlags = _intVal(_INST(flags));
-
- /* made this a primitive to get define in stc.h */
- if (aBoolean == true)
- newFlags |= F_DYNAMIC;
- else
- newFlags &= ~F_DYNAMIC;
-
- _INST(flags) = _MKSMALLINT(newFlags);
-%}
-!
-
-dynamic
- "return the flag stating that the machine code was created
- dynamically (from bytecode)."
-
-%{ /* NOCONTEXT */
-
- /* made this a primitive to get define in stc.h */
-
- RETURN ((__intVal(_INST(flags)) & F_DYNAMIC) ? true : false);
-%}
-!
-
-markFlag:aBoolean
- "set/clear the mark flag bit.
- This bit is not used by the VM, but instead free to mark codeObjects
- for any (debugging/tracing) use. For example, the coverage test uses
- these to mark reached methods. (inspired by a note in c.l.s)"
-
-%{ /* NOCONTEXT */
-
- int newFlags = _intVal(_INST(flags));
-
- /* made this a primitive to get define in stc.h */
- if (aBoolean == true)
- newFlags |= F_MARKBIT;
- else
- newFlags &= ~F_MARKBIT;
-
- _INST(flags) = _MKSMALLINT(newFlags);
-%}
-!
-
-markFlag
- "return the mark bits value as a boolean"
-
-%{ /* NOCONTEXT */
-
- /* made this a primitive to get define in stc.h */
-
- RETURN ((__intVal(_INST(flags)) & F_MARKBIT) ? true : false);
-%}
-! !
-
-!CompiledCode methodsFor:'error handling'!
-
-noByteCode
- "this error is triggered when the interpreter tries to execute a
- code object, where both the code and byteCode instances are nil.
- This can happen if:
- the Compiler/runtime system is broken,
- someone played around with a block/method,
- compilation of a lazy method failed
- (i.e. the lazy method contains an error or
- it contains primitive code and there is no stc compiler available)
- an unloaded object modules method is called for.
- Only the first case is to be considered serious - it should not happen
- if the system is used correctly."
-
- ^ NoByteCodeSignal raise.
-!
-
-invalidByteCode
- "this error is triggered when the interpreter tries to execute a
- code object, where the byteCode is nonNil, but not a ByteArray.
- Can only happen when Compiler/runtime system is broken or
- someone played around with a block/method."
-
- ^ InvalidByteCodeSignal raise.
-!
-
-invalidInstruction
- "this error is triggered when the bytecode-interpreter tries to
- execute an invalid bytecode instruction.
- Can only happen when Compiler/runtime system is broken or
- someone played around with the block/methods code."
-
- ^ InvalidInstructionSignal raise.
-!
-
-badLiteralTable
- "this error is triggered, when a block/method is called with a bad literal
- array (i.e. non-array) - this can only happen, if the
- compiler is broken or someone played around with a block/methods
- literal table or the GC is broken and corrupted it."
-
- ^ BadLiteralsSignal raise.
-!
-
-receiverNotBoolean:anObject
- "this error is triggered when the bytecode-interpreter tries to
- execute ifTrue:/ifFalse or whileTrue: type of expressions where the
- receiver is neither true nor false."
-
- ^ NonBooleanReceiverSignal raise.
-!
-
-tooManyArguments
- "this error is triggered, when a method/block tries to perform a send with
- more arguments than supported by the interpreter. This can only happen,
- if the compiler has been changed without updating the VM."
-
- ^ ArgumentSignal
- raiseRequestWith:self
- errorString:'too many args in send'
-!
-
-badArgumentArray
- "this error is triggered, if a non array is passed to
- #valueWithReceiver:.. methods"
-
- ^ ArgumentSignal
- raiseRequestWith:self
- errorString:'argumentArray must be an Array'
-! !
+CompiledCode initialize!
--- a/CompiledCode.st Thu Nov 23 12:08:17 1995 +0100
+++ b/CompiledCode.st Thu Nov 23 12:17:00 1995 +0100
@@ -11,12 +11,11 @@
"
ExecutableFunction subclass:#CompiledCode
- instanceVariableNames:'flags byteCode literals'
- classVariableNames:'NoByteCodeSignal InvalidByteCodeSignal
- InvalidInstructionSignal BadLiteralsSignal
- NonBooleanReceiverSignal ArgumentSignal'
- poolDictionaries:''
- category:'Kernel-Methods'
+ instanceVariableNames:'flags byteCode literals'
+ classVariableNames:'NoByteCodeSignal InvalidByteCodeSignal InvalidInstructionSignal
+ BadLiteralsSignal NonBooleanReceiverSignal ArgumentSignal'
+ poolDictionaries:''
+ category:'Kernel-Methods'
!
!CompiledCode class methodsFor:'documentation'!
@@ -35,10 +34,6 @@
"
!
-version
- ^ '$Header: /cvs/stx/stx/libbasic/CompiledCode.st,v 1.20 1995-11-11 14:27:59 cg Exp $'
-!
-
documentation
"
This is an abstract class, to merge common attributes of Blocks and
@@ -66,6 +61,10 @@
NOTICE: layout known by runtime system and compiler - do not change
"
+!
+
+version
+ ^ '$Header: /cvs/stx/stx/libbasic/CompiledCode.st,v 1.21 1995-11-23 11:16:31 cg Exp $'
! !
!CompiledCode class methodsFor:'initialization'!
@@ -100,17 +99,17 @@
!CompiledCode class methodsFor:'Signal constants'!
-executionErrorSignal
- "return the parent-signal of all execution errors"
-
- ^ ExecutionErrorSignal
-!
-
argumentSignal
"return the signal raised when something's wrong with the
arguments"
^ ArgumentSignal
+!
+
+executionErrorSignal
+ "return the parent-signal of all execution errors"
+
+ ^ ExecutionErrorSignal
! !
!CompiledCode class methodsFor:'queries'!
@@ -135,6 +134,154 @@
^ literals
! !
+!CompiledCode methodsFor:'error handling'!
+
+badArgumentArray
+ "this error is triggered, if a non array is passed to
+ #valueWithReceiver:.. methods"
+
+ ^ ArgumentSignal
+ raiseRequestWith:self
+ errorString:'argumentArray must be an Array'
+!
+
+badLiteralTable
+ "this error is triggered, when a block/method is called with a bad literal
+ array (i.e. non-array) - this can only happen, if the
+ compiler is broken or someone played around with a block/methods
+ literal table or the GC is broken and corrupted it."
+
+ ^ BadLiteralsSignal raise.
+!
+
+invalidByteCode
+ "this error is triggered when the interpreter tries to execute a
+ code object, where the byteCode is nonNil, but not a ByteArray.
+ Can only happen when Compiler/runtime system is broken or
+ someone played around with a block/method."
+
+ ^ InvalidByteCodeSignal raise.
+!
+
+invalidInstruction
+ "this error is triggered when the bytecode-interpreter tries to
+ execute an invalid bytecode instruction.
+ Can only happen when Compiler/runtime system is broken or
+ someone played around with the block/methods code."
+
+ ^ InvalidInstructionSignal raise.
+!
+
+noByteCode
+ "this error is triggered when the interpreter tries to execute a
+ code object, where both the code and byteCode instances are nil.
+ This can happen if:
+ the Compiler/runtime system is broken,
+ someone played around with a block/method,
+ compilation of a lazy method failed
+ (i.e. the lazy method contains an error or
+ it contains primitive code and there is no stc compiler available)
+ an unloaded object modules method is called for.
+ Only the first case is to be considered serious - it should not happen
+ if the system is used correctly."
+
+ ^ NoByteCodeSignal raise.
+!
+
+receiverNotBoolean:anObject
+ "this error is triggered when the bytecode-interpreter tries to
+ execute ifTrue:/ifFalse or whileTrue: type of expressions where the
+ receiver is neither true nor false."
+
+ ^ NonBooleanReceiverSignal raise.
+!
+
+tooManyArguments
+ "this error is triggered, when a method/block tries to perform a send with
+ more arguments than supported by the interpreter. This can only happen,
+ if the compiler has been changed without updating the VM."
+
+ ^ ArgumentSignal
+ raiseRequestWith:self
+ errorString:'too many args in send'
+! !
+
+!CompiledCode methodsFor:'private accessing'!
+
+byteCode:aByteArray
+ "set the bytecode field - DANGER ALERT"
+
+ byteCode := aByteArray
+!
+
+dynamic
+ "return the flag stating that the machine code was created
+ dynamically (from bytecode)."
+
+%{ /* NOCONTEXT */
+
+ /* made this a primitive to get define in stc.h */
+
+ RETURN ((__intVal(_INST(flags)) & F_DYNAMIC) ? true : false);
+%}
+!
+
+dynamic:aBoolean
+ "set/clear the flag bit stating that the machine code was created
+ dynamically and should be flushed on image-restart.
+ Obsolete - now done in VM"
+
+%{ /* NOCONTEXT */
+
+ int newFlags = _intVal(_INST(flags));
+
+ /* made this a primitive to get define in stc.h */
+ if (aBoolean == true)
+ newFlags |= F_DYNAMIC;
+ else
+ newFlags &= ~F_DYNAMIC;
+
+ _INST(flags) = _MKSMALLINT(newFlags);
+%}
+!
+
+literals:aLiteralArray
+ "set the literal array for evaluation - DANGER ALERT"
+
+ literals := aLiteralArray
+!
+
+markFlag
+ "return the mark bits value as a boolean"
+
+%{ /* NOCONTEXT */
+
+ /* made this a primitive to get define in stc.h */
+
+ RETURN ((__intVal(_INST(flags)) & F_MARKBIT) ? true : false);
+%}
+!
+
+markFlag:aBoolean
+ "set/clear the mark flag bit.
+ This bit is not used by the VM, but instead free to mark codeObjects
+ for any (debugging/tracing) use. For example, the coverage test uses
+ these to mark reached methods. (inspired by a note in c.l.s)"
+
+%{ /* NOCONTEXT */
+
+ int newFlags = _intVal(_INST(flags));
+
+ /* made this a primitive to get define in stc.h */
+ if (aBoolean == true)
+ newFlags |= F_MARKBIT;
+ else
+ newFlags &= ~F_MARKBIT;
+
+ _INST(flags) = _MKSMALLINT(newFlags);
+%}
+! !
+
!CompiledCode methodsFor:'queries'!
messages
@@ -165,150 +312,4 @@
"
! !
-!CompiledCode methodsFor:'private accessing'!
-
-byteCode:aByteArray
- "set the bytecode field - DANGER ALERT"
-
- byteCode := aByteArray
-!
-
-literals:aLiteralArray
- "set the literal array for evaluation - DANGER ALERT"
-
- literals := aLiteralArray
-!
-
-dynamic:aBoolean
- "set/clear the flag bit stating that the machine code was created
- dynamically and should be flushed on image-restart.
- Obsolete - now done in VM"
-
-%{ /* NOCONTEXT */
-
- int newFlags = _intVal(_INST(flags));
-
- /* made this a primitive to get define in stc.h */
- if (aBoolean == true)
- newFlags |= F_DYNAMIC;
- else
- newFlags &= ~F_DYNAMIC;
-
- _INST(flags) = _MKSMALLINT(newFlags);
-%}
-!
-
-dynamic
- "return the flag stating that the machine code was created
- dynamically (from bytecode)."
-
-%{ /* NOCONTEXT */
-
- /* made this a primitive to get define in stc.h */
-
- RETURN ((__intVal(_INST(flags)) & F_DYNAMIC) ? true : false);
-%}
-!
-
-markFlag:aBoolean
- "set/clear the mark flag bit.
- This bit is not used by the VM, but instead free to mark codeObjects
- for any (debugging/tracing) use. For example, the coverage test uses
- these to mark reached methods. (inspired by a note in c.l.s)"
-
-%{ /* NOCONTEXT */
-
- int newFlags = _intVal(_INST(flags));
-
- /* made this a primitive to get define in stc.h */
- if (aBoolean == true)
- newFlags |= F_MARKBIT;
- else
- newFlags &= ~F_MARKBIT;
-
- _INST(flags) = _MKSMALLINT(newFlags);
-%}
-!
-
-markFlag
- "return the mark bits value as a boolean"
-
-%{ /* NOCONTEXT */
-
- /* made this a primitive to get define in stc.h */
-
- RETURN ((__intVal(_INST(flags)) & F_MARKBIT) ? true : false);
-%}
-! !
-
-!CompiledCode methodsFor:'error handling'!
-
-noByteCode
- "this error is triggered when the interpreter tries to execute a
- code object, where both the code and byteCode instances are nil.
- This can happen if:
- the Compiler/runtime system is broken,
- someone played around with a block/method,
- compilation of a lazy method failed
- (i.e. the lazy method contains an error or
- it contains primitive code and there is no stc compiler available)
- an unloaded object modules method is called for.
- Only the first case is to be considered serious - it should not happen
- if the system is used correctly."
-
- ^ NoByteCodeSignal raise.
-!
-
-invalidByteCode
- "this error is triggered when the interpreter tries to execute a
- code object, where the byteCode is nonNil, but not a ByteArray.
- Can only happen when Compiler/runtime system is broken or
- someone played around with a block/method."
-
- ^ InvalidByteCodeSignal raise.
-!
-
-invalidInstruction
- "this error is triggered when the bytecode-interpreter tries to
- execute an invalid bytecode instruction.
- Can only happen when Compiler/runtime system is broken or
- someone played around with the block/methods code."
-
- ^ InvalidInstructionSignal raise.
-!
-
-badLiteralTable
- "this error is triggered, when a block/method is called with a bad literal
- array (i.e. non-array) - this can only happen, if the
- compiler is broken or someone played around with a block/methods
- literal table or the GC is broken and corrupted it."
-
- ^ BadLiteralsSignal raise.
-!
-
-receiverNotBoolean:anObject
- "this error is triggered when the bytecode-interpreter tries to
- execute ifTrue:/ifFalse or whileTrue: type of expressions where the
- receiver is neither true nor false."
-
- ^ NonBooleanReceiverSignal raise.
-!
-
-tooManyArguments
- "this error is triggered, when a method/block tries to perform a send with
- more arguments than supported by the interpreter. This can only happen,
- if the compiler has been changed without updating the VM."
-
- ^ ArgumentSignal
- raiseRequestWith:self
- errorString:'too many args in send'
-!
-
-badArgumentArray
- "this error is triggered, if a non array is passed to
- #valueWithReceiver:.. methods"
-
- ^ ArgumentSignal
- raiseRequestWith:self
- errorString:'argumentArray must be an Array'
-! !
+CompiledCode initialize!
--- a/Context.st Thu Nov 23 12:08:17 1995 +0100
+++ b/Context.st Thu Nov 23 12:17:00 1995 +0100
@@ -11,11 +11,11 @@
"
Object variableSubclass:#Context
- instanceVariableNames:'flags sender home receiver selector searchClass
- lineNr retvalTemp handle*'
- classVariableNames:'InvalidReturnSignal'
- poolDictionaries:''
- category:'Kernel-Methods'
+ instanceVariableNames:'flags sender home receiver selector searchClass lineNr retvalTemp
+ handle*'
+ classVariableNames:'InvalidReturnSignal'
+ poolDictionaries:''
+ category:'Kernel-Methods'
!
!Context class methodsFor:'documentation'!
@@ -34,10 +34,6 @@
"
!
-version
- ^ '$Header: /cvs/stx/stx/libbasic/Context.st,v 1.46 1995-11-21 12:48:41 cg Exp $'
-!
-
documentation
"
Contexts represent the stack frame objects, which keep the processing
@@ -151,6 +147,10 @@
WARNING: layout and size known by the compiler and runtime system - do not change.
"
+!
+
+version
+ ^ '$Header: /cvs/stx/stx/libbasic/Context.st,v 1.47 1995-11-23 11:16:45 cg Exp $'
! !
!Context class methodsFor:'initialization'!
@@ -180,86 +180,66 @@
^ true
! !
-!Context methodsFor:'copying'!
+!Context methodsFor:'accessing'!
+
+argAt:n
+ "return the n'th argument"
+
+ ^ self at:n
+!
+
+argAt:n put:value
+ "set the n'th argument - useful when the receiver should be restarted"
-deepCopy
- "raise an error - deepCopy is not allowed for contexts"
+ ^ self at:n put:value
+!
+
+args
+ "return an array filled with the arguments of this context"
+
+ |n|
+
+ n := self numArgs.
+ ^ (Array new:n) replaceFrom:1 to:n with:self.
+!
- ^ self deepCopyError
-! !
+argsAndVars
+ "return an array filled with the arguments and variables of this context"
+
+ |n|
+
+ n := self numArgs + self nvars.
+ ^ (Array new:n) replaceFrom:1 to:n with:self.
+!
-!Context methodsFor:'private accessing'!
+canReturn
+ "return true, if the receiver allows returning through it.
+ For normal method contexts, this returns true;
+ for blocks, it (currently) always returns false.
-markForUnwind
+ However, the system can be compiled (for production code), to create
+ contexts which cannot be returned or restarted
+ (except, if the method contains a returning block).
+ This saves some administrative work in every method
+ invocation and makes overall execution faster. However, it limits
+ the debugger, in that it cannot return from or restart those contexts.
+ (unwinding and termination is not affected by this optimization)
+ Currently, the system as delivered has this optimization disabled."
+
%{ /* NOCONTEXT */
- _INST(flags) = (OBJ)((INT)_INST(flags) | __MASKSMALLINT(__UNWIND_MARK));
+
+ RETURN ( (_intVal(_INST(flags)) & __CANNOT_RETURN) ? false : true );
%}
!
-unmarkForUnwind
-%{ /* NOCONTEXT */
- _INST(flags) = (OBJ)((INT)_INST(flags) & ~__MASKSMALLINT(__UNWIND_MARK));
-%}
-! !
-
-!Context methodsFor:'testing'!
-
-isContext
- "return true, iff the receiver is a Context, false otherwise"
-
- ^ true
-!
-
-isBlockContext
- "return true, iff the receiver is a BlockContext, false otherwise"
-
- ^ false
-!
-
-isRecursive
- "return true, if this context is one of a recursive send of the same
- selector and same arguments to the same receiver before.
- Used to detect recursive errors or recursive printing - for example."
-
- |c rec "numArgs" "{Class: SmallInteger }"|
+home
+ "return the immediate home of the receiver.
+ for block contexts, this is the methodcontext, where the block was created,
+ for nested block contexts, its the surrounding blocks context.
+ for method-contexts this is nil."
- rec := 0.
- c := self sender.
- [c notNil] whileTrue:[
- ((c selector == selector)
- and:[(c receiver == receiver)]) ifTrue:[
- "
- stupid: the current ST/X context does not include
- the method, but the class, in which the search started ...
- "
-"/ (c searchClass whichClassIncludesSelector:selector) == (self searchClass whichClassIncludesSelector:selector) ifTrue:[
- c methodClass == self methodClass ifTrue:[
-"/ "
-"/ finally, look for different arguments
-"/ "
-"/ numArgs := self numArgs.
-"/ 1 to:numArgs do:[:argIndex |
-"/ (self argAt:argIndex) == (c argAt:argIndex) ifFalse:[^ false]
-"/ ].
- ^ true
- ]
- ].
- c := c sender.
- "
- this special test was added to get out after a while
- if the sender chain is corrupt - this gives us at least
- a chance to find those errors.
- "
- rec := rec + 1.
- rec >= 100000 ifTrue:[
- 'bad context chain' errorPrintNL.
- ^ true
- ]
- ].
- ^ false
-! !
-
-!Context methodsFor:'accessing'!
+ ^ nil "home"
+!
instVarAt:index
"have to catch instVar access to retVal and handle - they are invalid.
@@ -281,19 +261,21 @@
^ super instVarAt:index put:value
!
-methodHome
- "return the method-home - for method contexts this is the receiver"
+isUnwindContext
+ "return true, if this is an unwindContext"
- ^ self
+%{ /* NOCONTEXT */
+ RETURN ( ((INT)_INST(flags) & __MASKSMALLINT(__UNWIND_MARK)) ? true : false );
+%}
!
-home
- "return the immediate home of the receiver.
- for block contexts, this is the methodcontext, where the block was created,
- for nested block contexts, its the surrounding blocks context.
- for method-contexts this is nil."
+lineNumber
+ "this returns the lineNumber within the methods source, where the context was
+ interrupted or called another method. (currently, sometimes this information
+ is not available - in this case 0 is returned)"
- ^ nil "home"
+ lineNr isNil ifTrue:[^ nil].
+ ^ lineNr bitAnd:16rFFFF
!
method
@@ -340,10 +322,57 @@
^ self searchClass whichClassIncludesSelector:selector.
!
-unsafeSender
- "temporary: for debugging only"
+methodHome
+ "return the method-home - for method contexts this is the receiver"
+
+ ^ self
+!
+
+ntemp
+ "return the number of temporary variables of the Block/Method.
+ (for debugging only)"
+
+ ^ self size - self numArgs - self nvars
+!
+
+numArgs
+ "return the number of arguments to the Block/Method"
+
+%{ /* NOCONTEXT */
+
+ RETURN ( _MKSMALLINT( (_intVal(_INST(flags)) >> __NARG_SHIFT) & __NARG_MASK) );
+%}
+!
+
+nvars
+ "return the number of local variables of the Block/Method"
- ^ sender
+%{ /* NOCONTEXT */
+
+ RETURN ( _MKSMALLINT( (_intVal(_INST(flags)) >> __NVAR_SHIFT) & __NVAR_MASK) );
+%}
+!
+
+receiver
+ "return the receiver of the context"
+
+ ^ receiver
+!
+
+searchClass
+ "this is the class where the method-lookup started;
+ for normal sends, it is nil (or sometimes the receivers class).
+ For supersends, its the superclass of the one, in which the
+ caller was defined."
+
+ searchClass notNil ifTrue:[^ searchClass].
+ ^ receiver class
+!
+
+selector
+ "return the selector of the method for which the context was created"
+
+ ^ selector
!
sender
@@ -375,87 +404,10 @@
^ sender
!
-receiver
- "return the receiver of the context"
-
- ^ receiver
-!
-
-searchClass
- "this is the class where the method-lookup started;
- for normal sends, it is nil (or sometimes the receivers class).
- For supersends, its the superclass of the one, in which the
- caller was defined."
-
- searchClass notNil ifTrue:[^ searchClass].
- ^ receiver class
-!
-
-selector
- "return the selector of the method for which the context was created"
-
- ^ selector
-!
-
-isUnwindContext
- "return true, if this is an unwindContext"
-
-%{ /* NOCONTEXT */
- RETURN ( ((INT)_INST(flags) & __MASKSMALLINT(__UNWIND_MARK)) ? true : false );
-%}
-!
-
-numArgs
- "return the number of arguments to the Block/Method"
-
-%{ /* NOCONTEXT */
-
- RETURN ( _MKSMALLINT( (_intVal(_INST(flags)) >> __NARG_SHIFT) & __NARG_MASK) );
-%}
-!
+setLineNumber:aNumber
+ "private entry for uncompiledCodeObject ..."
-nvars
- "return the number of local variables of the Block/Method"
-
-%{ /* NOCONTEXT */
-
- RETURN ( _MKSMALLINT( (_intVal(_INST(flags)) >> __NVAR_SHIFT) & __NVAR_MASK) );
-%}
-!
-
-ntemp
- "return the number of temporary variables of the Block/Method.
- (for debugging only)"
-
- ^ self size - self numArgs - self nvars
-!
-
-args
- "return an array filled with the arguments of this context"
-
- |n|
-
- n := self numArgs.
- ^ (Array new:n) replaceFrom:1 to:n with:self.
-!
-
-argsAndVars
- "return an array filled with the arguments and variables of this context"
-
- |n|
-
- n := self numArgs + self nvars.
- ^ (Array new:n) replaceFrom:1 to:n with:self.
-!
-
-vars
- "return an array filled with the local variables of this context"
-
- |nonVars mySize|
-
- nonVars := self numArgs.
- mySize := self nvars.
- ^ (Array new:mySize) replaceFrom:1 to:mySize with:self startingAt:nonVars+1
+ lineNr := aNumber
!
temporaries
@@ -468,16 +420,10 @@
^ (Array new:mySize) replaceFrom:1 to:mySize with:self startingAt:nonTemps+1
!
-argAt:n
- "return the n'th argument"
+unsafeSender
+ "temporary: for debugging only"
- ^ self at:n
-!
-
-argAt:n put:value
- "set the n'th argument - useful when the receiver should be restarted"
-
- ^ self at:n put:value
+ ^ sender
!
varAt:n
@@ -493,190 +439,22 @@
self at:(n + self numArgs) put:value
!
-lineNumber
- "this returns the lineNumber within the methods source, where the context was
- interrupted or called another method. (currently, sometimes this information
- is not available - in this case 0 is returned)"
-
- lineNr isNil ifTrue:[^ nil].
- ^ lineNr bitAnd:16rFFFF
-!
-
-setLineNumber:aNumber
- "private entry for uncompiledCodeObject ..."
-
- lineNr := aNumber
-!
+vars
+ "return an array filled with the local variables of this context"
-canReturn
- "return true, if the receiver allows returning through it.
- For normal method contexts, this returns true;
- for blocks, it (currently) always returns false.
+ |nonVars mySize|
- However, the system can be compiled (for production code), to create
- contexts which cannot be returned or restarted
- (except, if the method contains a returning block).
- This saves some administrative work in every method
- invocation and makes overall execution faster. However, it limits
- the debugger, in that it cannot return from or restart those contexts.
- (unwinding and termination is not affected by this optimization)
- Currently, the system as delivered has this optimization disabled."
-
-%{ /* NOCONTEXT */
-
- RETURN ( (_intVal(_INST(flags)) & __CANNOT_RETURN) ? false : true );
-%}
+ nonVars := self numArgs.
+ mySize := self nvars.
+ ^ (Array new:mySize) replaceFrom:1 to:mySize with:self startingAt:nonVars+1
! !
-!Context methodsFor:'printing & storing'!
-
-argsDisplayString
- |fullString n "{ Class: SmallInteger }" |
-
- fullString := ''.
- n := self numArgs.
- 1 to:n do:[:index |
- fullString := fullString , (' ' , (self at:index) displayString)
- ].
- ^ fullString
-!
-
-receiverPrintString
- "return a string describing the receiver of the context"
-
- |receiverClass receiverClassName newString implementorClass|
-
- receiverClass := receiver class.
- receiverClassName := receiverClass name.
- (receiverClass == SmallInteger) ifTrue:[
- newString := '(' , receiver printString , ') ' , receiverClassName
- ] ifFalse:[
- newString := receiverClassName
- ].
-
- selector notNil ifTrue:[
-"/ implementorClass := self searchClass whichClassIncludesSelector:selector.
-
- "
- kludge to avoid slow search for containing class
- "
- selector ~~ #doIt ifTrue:[
- implementorClass := self methodClass.
- ].
- implementorClass notNil ifTrue: [
- (implementorClass ~~ receiverClass) ifTrue: [
- newString := newString , '>>>',
- implementorClass name printString
- ]
- ] ifFalse:[
- self searchClass ~~ receiverClass ifTrue:[
- newString := newString , '>>>' , self searchClass name
- ].
- "
- kludge for doIt - these unbound methods are not
- found in the classes methodDictionary
- "
- selector ~~ #doIt ifTrue:[
- newString := newString , '>>>**NONE**'
- ]
- ]
- ].
-
- ^ newString
-!
-
-printString
- "return a string describing the context"
-
- ^ self receiverPrintString , ' ' , self selector printString
-!
-
-displayString
- "return a string describing the context - for display in Inspector"
-
- ^ self class name , '(' , self printString , ')'
-!
-
-fullPrintString
- "return a string describing the context - this includes the linenumber,
- receiver printString and argument printString"
-
- |s|
+!Context methodsFor:'copying'!
- s := WriteStream on:String new.
- s nextPutAll:self receiverPrintString; space; nextPutAll:selector.
- self size ~~ 0 ifTrue: [
- s space.
- s nextPutAll:self argsDisplayString
- ].
- s nextPutAll:' ['; nextPutAll:self lineNumber printString; nextPutAll:']' .
- ^ s contents
-
- "
- thisContext fullPrintString
- "
-!
-
-methodPrintString
- "return a string describing the contexts method as 'implementorClass>>selector'"
-
- |mthd w|
-
- mthd := self method.
- mthd notNil ifTrue:[
- w := mthd who.
- w notNil ifTrue:[
- ^ (w at:1) name , '>>' , (w at:2)
- ]
- ].
- ^ mthd displayString.
-
- "
- thisContext methodPrintString
- thisContext sender methodPrintString
- "
-!
-
-printOn:aStream
- "append a printed description of the receiver onto aStream"
+deepCopy
+ "raise an error - deepCopy is not allowed for contexts"
- aStream nextPutAll:(self receiverPrintString).
- aStream space.
- self selector printOn:aStream
-! !
-
-!Context methodsFor:'minidebugger printing'!
-
-fullPrint
- "print the receiver, selector and args of the context
- - used only for MiniDebuggers walkback print"
-
- self receiverPrintString print. ' ' print. selector print.
- self size ~~ 0 ifTrue: [
- ' ' print. self argsDisplayString print
- ].
- ' [' print. self lineNumber print. ']' printNewline
-
- "
- thisContext fullPrint
- "
-!
-
-fullPrintAll
- "print a full walkback starting at the receiver
- - used only for MiniDebuggers walkback print"
-
- |context|
-
- context := self.
- [context notNil] whileTrue: [
- context fullPrint.
- context := context sender
- ]
-
- "
- thisContext fullPrintAll
- "
+ ^ self deepCopyError
! !
!Context methodsFor:'error handling'!
@@ -736,6 +514,40 @@
errorString:(how , ': context cannot be restarted/returned from')
! !
+!Context methodsFor:'minidebugger printing'!
+
+fullPrint
+ "print the receiver, selector and args of the context
+ - used only for MiniDebuggers walkback print"
+
+ self receiverPrintString print. ' ' print. selector print.
+ self size ~~ 0 ifTrue: [
+ ' ' print. self argsDisplayString print
+ ].
+ ' [' print. self lineNumber print. ']' printNewline
+
+ "
+ thisContext fullPrint
+ "
+!
+
+fullPrintAll
+ "print a full walkback starting at the receiver
+ - used only for MiniDebuggers walkback print"
+
+ |context|
+
+ context := self.
+ [context notNil] whileTrue: [
+ context fullPrint.
+ context := context sender
+ ]
+
+ "
+ thisContext fullPrintAll
+ "
+! !
+
!Context methodsFor:'non local control flow'!
restart
@@ -762,6 +574,57 @@
^ self invalidReturnOrRestartError:#restart with:nil
!
+resume
+ "resume execution in this context. I.e. as if the method called
+ last by the receiver did a ^ nil.
+ If the context has already returned, report an error.
+
+ NOTICE:
+ NO unwind actions are performed (see Context>>unwind).
+
+ LIMITATION:
+ currently a context can only be resumed by
+ the owning process - not from outside."
+
+ ^ self resume:nil
+!
+
+resume:value
+ "resume the receiver - as if it got 'value' from whatever
+ it called. This continues execution in the receivers method
+ after the point where it did its last send.
+ If the context has already returned - report an error.
+
+ NOTICE:
+ NO unwind actions are performed (see Context>>unwind:).
+
+ LIMITATION:
+ currently a context can only be resumed by
+ the owning process - not from outside."
+
+ |con|
+
+ "
+ starting with this context, find the one below (i.e. the one that I
+ have called) and return from it.
+ "
+ con := thisContext.
+%{
+ while ((con != nil) && (_ContextInstPtr(con)->c_sender != self)) {
+ con = _ContextInstPtr(con)->c_sender;
+ }
+%}.
+
+ con isNil ifTrue:[
+ "
+ tried to resume in context which is already dead
+ (i.e. the method/block has already executed a return)
+ "
+ ^ con invalidReturnOrRestartError:#resume with:value
+ ].
+ ^ con return:value
+!
+
return
"return from this context with nil. I.e. as if it did a ^ nil.
NOTICE:
@@ -823,57 +686,6 @@
^ self invalidReturnOrRestartError:#return with:aBlock
!
-resume
- "resume execution in this context. I.e. as if the method called
- last by the receiver did a ^ nil.
- If the context has already returned, report an error.
-
- NOTICE:
- NO unwind actions are performed (see Context>>unwind).
-
- LIMITATION:
- currently a context can only be resumed by
- the owning process - not from outside."
-
- ^ self resume:nil
-!
-
-resume:value
- "resume the receiver - as if it got 'value' from whatever
- it called. This continues execution in the receivers method
- after the point where it did its last send.
- If the context has already returned - report an error.
-
- NOTICE:
- NO unwind actions are performed (see Context>>unwind:).
-
- LIMITATION:
- currently a context can only be resumed by
- the owning process - not from outside."
-
- |con|
-
- "
- starting with this context, find the one below (i.e. the one that I
- have called) and return from it.
- "
- con := thisContext.
-%{
- while ((con != nil) && (_ContextInstPtr(con)->c_sender != self)) {
- con = _ContextInstPtr(con)->c_sender;
- }
-%}.
-
- con isNil ifTrue:[
- "
- tried to resume in context which is already dead
- (i.e. the method/block has already executed a return)
- "
- ^ con invalidReturnOrRestartError:#resume with:value
- ].
- ^ con return:value
-!
-
unwind
"return nil from the receiver - i.e. simulate a '^ nil'.
If the context has already retruned, report an error.
@@ -1044,3 +856,193 @@
"
^ self returnDoing:aBlock
! !
+
+!Context methodsFor:'printing & storing'!
+
+argsDisplayString
+ |fullString n "{ Class: SmallInteger }" |
+
+ fullString := ''.
+ n := self numArgs.
+ 1 to:n do:[:index |
+ fullString := fullString , (' ' , (self at:index) displayString)
+ ].
+ ^ fullString
+!
+
+displayString
+ "return a string describing the context - for display in Inspector"
+
+ ^ self class name , '(' , self printString , ')'
+!
+
+fullPrintString
+ "return a string describing the context - this includes the linenumber,
+ receiver printString and argument printString"
+
+ |s|
+
+ s := WriteStream on:String new.
+ s nextPutAll:self receiverPrintString; space; nextPutAll:selector.
+ self size ~~ 0 ifTrue: [
+ s space.
+ s nextPutAll:self argsDisplayString
+ ].
+ s nextPutAll:' ['; nextPutAll:self lineNumber printString; nextPutAll:']' .
+ ^ s contents
+
+ "
+ thisContext fullPrintString
+ "
+!
+
+methodPrintString
+ "return a string describing the contexts method as 'implementorClass>>selector'"
+
+ |mthd w|
+
+ mthd := self method.
+ mthd notNil ifTrue:[
+ w := mthd who.
+ w notNil ifTrue:[
+ ^ (w at:1) name , '>>' , (w at:2)
+ ]
+ ].
+ ^ mthd displayString.
+
+ "
+ thisContext methodPrintString
+ thisContext sender methodPrintString
+ "
+!
+
+printOn:aStream
+ "append a printed description of the receiver onto aStream"
+
+ aStream nextPutAll:(self receiverPrintString).
+ aStream space.
+ self selector printOn:aStream
+!
+
+printString
+ "return a string describing the context"
+
+ ^ self receiverPrintString , ' ' , self selector printString
+!
+
+receiverPrintString
+ "return a string describing the receiver of the context"
+
+ |receiverClass receiverClassName newString implementorClass|
+
+ receiverClass := receiver class.
+ receiverClassName := receiverClass name.
+ (receiverClass == SmallInteger) ifTrue:[
+ newString := '(' , receiver printString , ') ' , receiverClassName
+ ] ifFalse:[
+ newString := receiverClassName
+ ].
+
+ selector notNil ifTrue:[
+"/ implementorClass := self searchClass whichClassIncludesSelector:selector.
+
+ "
+ kludge to avoid slow search for containing class
+ "
+ selector ~~ #doIt ifTrue:[
+ implementorClass := self methodClass.
+ ].
+ implementorClass notNil ifTrue: [
+ (implementorClass ~~ receiverClass) ifTrue: [
+ newString := newString , '>>>',
+ implementorClass name printString
+ ]
+ ] ifFalse:[
+ self searchClass ~~ receiverClass ifTrue:[
+ newString := newString , '>>>' , self searchClass name
+ ].
+ "
+ kludge for doIt - these unbound methods are not
+ found in the classes methodDictionary
+ "
+ selector ~~ #doIt ifTrue:[
+ newString := newString , '>>>**NONE**'
+ ]
+ ]
+ ].
+
+ ^ newString
+! !
+
+!Context methodsFor:'private accessing'!
+
+markForUnwind
+%{ /* NOCONTEXT */
+ _INST(flags) = (OBJ)((INT)_INST(flags) | __MASKSMALLINT(__UNWIND_MARK));
+%}
+!
+
+unmarkForUnwind
+%{ /* NOCONTEXT */
+ _INST(flags) = (OBJ)((INT)_INST(flags) & ~__MASKSMALLINT(__UNWIND_MARK));
+%}
+! !
+
+!Context methodsFor:'testing'!
+
+isBlockContext
+ "return true, iff the receiver is a BlockContext, false otherwise"
+
+ ^ false
+!
+
+isContext
+ "return true, iff the receiver is a Context, false otherwise"
+
+ ^ true
+!
+
+isRecursive
+ "return true, if this context is one of a recursive send of the same
+ selector and same arguments to the same receiver before.
+ Used to detect recursive errors or recursive printing - for example."
+
+ |c rec "numArgs" "{Class: SmallInteger }"|
+
+ rec := 0.
+ c := self sender.
+ [c notNil] whileTrue:[
+ ((c selector == selector)
+ and:[(c receiver == receiver)]) ifTrue:[
+ "
+ stupid: the current ST/X context does not include
+ the method, but the class, in which the search started ...
+ "
+"/ (c searchClass whichClassIncludesSelector:selector) == (self searchClass whichClassIncludesSelector:selector) ifTrue:[
+ c methodClass == self methodClass ifTrue:[
+"/ "
+"/ finally, look for different arguments
+"/ "
+"/ numArgs := self numArgs.
+"/ 1 to:numArgs do:[:argIndex |
+"/ (self argAt:argIndex) == (c argAt:argIndex) ifFalse:[^ false]
+"/ ].
+ ^ true
+ ]
+ ].
+ c := c sender.
+ "
+ this special test was added to get out after a while
+ if the sender chain is corrupt - this gives us at least
+ a chance to find those errors.
+ "
+ rec := rec + 1.
+ rec >= 100000 ifTrue:[
+ 'bad context chain' errorPrintNL.
+ ^ true
+ ]
+ ].
+ ^ false
+! !
+
+Context initialize!
--- a/ExecFunc.st Thu Nov 23 12:08:17 1995 +0100
+++ b/ExecFunc.st Thu Nov 23 12:17:00 1995 +0100
@@ -11,10 +11,10 @@
"
Object subclass:#ExecutableFunction
- instanceVariableNames:'code*'
- classVariableNames:'ExecutionErrorSignal InvalidCodeSignal'
- poolDictionaries:''
- category:'Kernel-Methods'
+ instanceVariableNames:'code*'
+ classVariableNames:'ExecutionErrorSignal InvalidCodeSignal'
+ poolDictionaries:''
+ category:'Kernel-Methods'
!
!ExecutableFunction class methodsFor:'documentation'!
@@ -33,10 +33,6 @@
"
!
-version
- ^ '$Header: /cvs/stx/stx/libbasic/Attic/ExecFunc.st,v 1.17 1995-11-11 15:22:25 cg Exp $'
-!
-
documentation
"
This is an abstract class, to merge common attributes of all kinds of
@@ -60,14 +56,10 @@
NOTICE: layout known by runtime system and compiler - do not change
"
-! !
-
-!ExecutableFunction class methodsFor:'queries'!
+!
-isBuiltInClass
- "this class is known by the run-time-system"
-
- ^ true
+version
+ ^ '$Header: /cvs/stx/stx/libbasic/Attic/ExecFunc.st,v 1.18 1995-11-23 11:17:00 cg Exp $'
! !
!ExecutableFunction class methodsFor:'initialization'!
@@ -92,21 +84,15 @@
^ ExecutionErrorSignal
! !
-!ExecutableFunction methodsFor:'accessing'!
+!ExecutableFunction class methodsFor:'queries'!
-instVarAt:index
- "have to catch instVar access to code - since its no object"
+isBuiltInClass
+ "this class is known by the run-time-system"
- (index == 1) ifTrue:[^ self code].
- ^ super instVarAt:index
-!
+ ^ true
+! !
-instVarAt:index put:value
- "have to catch instVar access to code - since its no object"
-
- (index == 1) ifTrue:[^ self code:value].
- ^ super instVarAt:index put:value
-!
+!ExecutableFunction methodsFor:'accessing'!
code
"return the code field. This is not an object but the address of the machine instructions.
@@ -125,26 +111,29 @@
}
%}.
^ nil
+!
+
+instVarAt:index
+ "have to catch instVar access to code - since its no object"
+
+ (index == 1) ifTrue:[^ self code].
+ ^ super instVarAt:index
+!
+
+instVarAt:index put:value
+ "have to catch instVar access to code - since its no object"
+
+ (index == 1) ifTrue:[^ self code:value].
+ ^ super instVarAt:index put:value
! !
-!ExecutableFunction methodsFor:'private accessing'!
+!ExecutableFunction methodsFor:'binary storage'!
-code:anAddress
- "set the code field - DANGER ALERT.
- This is not an object but the address of the machine instructions.
- Therefore the argument must be an integer representing this address.
- You can crash Smalltalk very badly when playing around here ...
- This method is for compiler support and very special cases (debugging) only
- - do not use"
+readBinaryContentsFrom: stream manager: manager
+ "make certain, that no invalid function addresses are created."
-%{ /* NOCONTEXT */
-
- if (__isSmallInteger(anAddress))
- _INST(code_) = (OBJ)(_intVal(anAddress));
- else {
- _INST(code_) = (OBJ)(__longIntVal(anAddress));
- }
-%}
+ super readBinaryContentsFrom: stream manager: manager.
+ self code:nil.
! !
!ExecutableFunction methodsFor:'error handling'!
@@ -171,11 +160,24 @@
nextPutAll:(addr printStringRadix:16); nextPutAll:')'
! !
-!ExecutableFunction methodsFor:'binary storage'!
+!ExecutableFunction methodsFor:'private accessing'!
+
+code:anAddress
+ "set the code field - DANGER ALERT.
+ This is not an object but the address of the machine instructions.
+ Therefore the argument must be an integer representing this address.
+ You can crash Smalltalk very badly when playing around here ...
+ This method is for compiler support and very special cases (debugging) only
+ - do not use"
-readBinaryContentsFrom: stream manager: manager
- "make certain, that no invalid function addresses are created."
+%{ /* NOCONTEXT */
- super readBinaryContentsFrom: stream manager: manager.
- self code:nil.
+ if (__isSmallInteger(anAddress))
+ _INST(code_) = (OBJ)(_intVal(anAddress));
+ else {
+ _INST(code_) = (OBJ)(__longIntVal(anAddress));
+ }
+%}
! !
+
+ExecutableFunction initialize!
--- a/ExecutableFunction.st Thu Nov 23 12:08:17 1995 +0100
+++ b/ExecutableFunction.st Thu Nov 23 12:17:00 1995 +0100
@@ -11,10 +11,10 @@
"
Object subclass:#ExecutableFunction
- instanceVariableNames:'code*'
- classVariableNames:'ExecutionErrorSignal InvalidCodeSignal'
- poolDictionaries:''
- category:'Kernel-Methods'
+ instanceVariableNames:'code*'
+ classVariableNames:'ExecutionErrorSignal InvalidCodeSignal'
+ poolDictionaries:''
+ category:'Kernel-Methods'
!
!ExecutableFunction class methodsFor:'documentation'!
@@ -33,10 +33,6 @@
"
!
-version
- ^ '$Header: /cvs/stx/stx/libbasic/ExecutableFunction.st,v 1.17 1995-11-11 15:22:25 cg Exp $'
-!
-
documentation
"
This is an abstract class, to merge common attributes of all kinds of
@@ -60,14 +56,10 @@
NOTICE: layout known by runtime system and compiler - do not change
"
-! !
-
-!ExecutableFunction class methodsFor:'queries'!
+!
-isBuiltInClass
- "this class is known by the run-time-system"
-
- ^ true
+version
+ ^ '$Header: /cvs/stx/stx/libbasic/ExecutableFunction.st,v 1.18 1995-11-23 11:17:00 cg Exp $'
! !
!ExecutableFunction class methodsFor:'initialization'!
@@ -92,21 +84,15 @@
^ ExecutionErrorSignal
! !
-!ExecutableFunction methodsFor:'accessing'!
+!ExecutableFunction class methodsFor:'queries'!
-instVarAt:index
- "have to catch instVar access to code - since its no object"
+isBuiltInClass
+ "this class is known by the run-time-system"
- (index == 1) ifTrue:[^ self code].
- ^ super instVarAt:index
-!
+ ^ true
+! !
-instVarAt:index put:value
- "have to catch instVar access to code - since its no object"
-
- (index == 1) ifTrue:[^ self code:value].
- ^ super instVarAt:index put:value
-!
+!ExecutableFunction methodsFor:'accessing'!
code
"return the code field. This is not an object but the address of the machine instructions.
@@ -125,26 +111,29 @@
}
%}.
^ nil
+!
+
+instVarAt:index
+ "have to catch instVar access to code - since its no object"
+
+ (index == 1) ifTrue:[^ self code].
+ ^ super instVarAt:index
+!
+
+instVarAt:index put:value
+ "have to catch instVar access to code - since its no object"
+
+ (index == 1) ifTrue:[^ self code:value].
+ ^ super instVarAt:index put:value
! !
-!ExecutableFunction methodsFor:'private accessing'!
+!ExecutableFunction methodsFor:'binary storage'!
-code:anAddress
- "set the code field - DANGER ALERT.
- This is not an object but the address of the machine instructions.
- Therefore the argument must be an integer representing this address.
- You can crash Smalltalk very badly when playing around here ...
- This method is for compiler support and very special cases (debugging) only
- - do not use"
+readBinaryContentsFrom: stream manager: manager
+ "make certain, that no invalid function addresses are created."
-%{ /* NOCONTEXT */
-
- if (__isSmallInteger(anAddress))
- _INST(code_) = (OBJ)(_intVal(anAddress));
- else {
- _INST(code_) = (OBJ)(__longIntVal(anAddress));
- }
-%}
+ super readBinaryContentsFrom: stream manager: manager.
+ self code:nil.
! !
!ExecutableFunction methodsFor:'error handling'!
@@ -171,11 +160,24 @@
nextPutAll:(addr printStringRadix:16); nextPutAll:')'
! !
-!ExecutableFunction methodsFor:'binary storage'!
+!ExecutableFunction methodsFor:'private accessing'!
+
+code:anAddress
+ "set the code field - DANGER ALERT.
+ This is not an object but the address of the machine instructions.
+ Therefore the argument must be an integer representing this address.
+ You can crash Smalltalk very badly when playing around here ...
+ This method is for compiler support and very special cases (debugging) only
+ - do not use"
-readBinaryContentsFrom: stream manager: manager
- "make certain, that no invalid function addresses are created."
+%{ /* NOCONTEXT */
- super readBinaryContentsFrom: stream manager: manager.
- self code:nil.
+ if (__isSmallInteger(anAddress))
+ _INST(code_) = (OBJ)(_intVal(anAddress));
+ else {
+ _INST(code_) = (OBJ)(__longIntVal(anAddress));
+ }
+%}
! !
+
+ExecutableFunction initialize!