"
COPYRIGHT (c) 1989 by Claus Gittinger
All Rights Reserved
This software is furnished under a license and may be used
only in accordance with the terms of that license and with the
inclusion of the above copyright notice. This software may not
be provided or otherwise made available to, or used by, any
other person. No title to or ownership of the software is
hereby transferred.
"
ParseNode subclass:#BlockNode
instanceVariableNames:'blockArgs statements home inlineBlock exitBlock
blockVars
needsHome'
classVariableNames:''
poolDictionaries:''
category:'System-Compiler-Support'
!
BlockNode comment:'
COPYRIGHT (c) 1989 by Claus Gittinger
All Rights Reserved
implement interpreted blocks
$Header: /cvs/stx/stx/libcomp/BlockNode.st,v 1.3 1993-10-13 02:41:10 claus Exp $
'!
!BlockNode class methodsFor:'instance creation'!
arguments:argList home:h variables:vars
^ (self basicNew) setArguments:argList home:h variables:vars
! !
!BlockNode methodsFor:'private accessing'!
setArguments:argList home:h variables:vars
needsHome := false.
blockArgs := argList.
home := h.
blockVars := vars
! !
!BlockNode methodsFor:'accessing'!
arguments
^ blockArgs
!
variables
^ blockVars
!
variables:varList
blockVars := varList
!
statements
^ statements
!
statements:s
statements := s
!
home:aBlock
home := aBlock
!
home
^ home
!
inlineBlock
^ inlineBlock
!
inlineBlock:aBoolean
inlineBlock := aBoolean
!
needsHome
^ needsHome
!
needsHome:aBoolean
needsHome := aBoolean
! !
!BlockNode methodsFor:'queries'!
isBlock
^ true
! !
!BlockNode methodsFor:'evaluating'!
exitWith:something
"return via return-statement"
home notNil ifTrue:[
home exitWith:something
].
exitBlock value:something.
^ something
!
evaluate
^ self
!
argumentCountError:numberGiven
^ self error:('Block got '
, numberGiven printString
, ' args while '
, (blockArgs size) printString
, ' where expected')
!
value
(blockArgs size ~~ 0) ifTrue:[
^ self argumentCountError:0
].
statements isNil ifTrue:[^ nil].
exitBlock := [:val | ^ val].
^ statements evaluate
!
value:anArg
|oldValue val|
(blockArgs size ~~ 1) ifTrue:[
^ self argumentCountError:1
].
statements isNil ifTrue:[^ nil].
oldValue := (blockArgs at:1) value.
(blockArgs at:1) value:anArg.
exitBlock := [:val |
(blockArgs at:1) value:oldValue.
^ val
].
val := statements evaluate.
(blockArgs at:1) value:oldValue.
^ val
!
value:arg1 value:arg2
|oldValue1 oldValue2 val|
(blockArgs size ~~ 2) ifTrue:[
^ self argumentCountError:2
].
statements isNil ifTrue:[^ nil].
oldValue1 := (blockArgs at:1) value.
oldValue2 := (blockArgs at:2) value.
(blockArgs at:1) value:arg1.
(blockArgs at:2) value:arg2.
exitBlock := [:val |
(blockArgs at:1) value:oldValue1.
(blockArgs at:2) value:oldValue2.
^ val
].
val := statements evaluate.
(blockArgs at:1) value:oldValue1.
(blockArgs at:2) value:oldValue2.
^ val
!
value:arg1 value:arg2 value:arg3
|oldValue1 oldValue2 oldValue3 val|
(blockArgs size ~~ 3) ifTrue:[
^ self argumentCountError:3
].
statements isNil ifTrue:[^ nil].
oldValue1 := (blockArgs at:1) value.
oldValue2 := (blockArgs at:2) value.
oldValue3 := (blockArgs at:3) value.
(blockArgs at:1) value:arg1.
(blockArgs at:2) value:arg2.
(blockArgs at:3) value:arg3.
exitBlock := [:val |
(blockArgs at:1) value:oldValue1.
(blockArgs at:2) value:oldValue2.
(blockArgs at:3) value:oldValue3.
^ val
].
val := statements evaluate.
(blockArgs at:1) value:oldValue1.
(blockArgs at:2) value:oldValue2.
(blockArgs at:3) value:oldValue3.
^ val
!
value:arg1 value:arg2 value:arg3 value:arg4
|oldValue1 oldValue2 oldValue3 oldValue4 val|
(blockArgs size ~~ 4) ifTrue:[
^ self argumentCountError:4
].
statements isNil ifTrue:[^ nil].
oldValue1 := (blockArgs at:1) value.
oldValue2 := (blockArgs at:2) value.
oldValue3 := (blockArgs at:3) value.
oldValue4 := (blockArgs at:4) value.
(blockArgs at:1) value:arg1.
(blockArgs at:2) value:arg2.
(blockArgs at:3) value:arg3.
(blockArgs at:4) value:arg4.
exitBlock := [:val |
(blockArgs at:1) value:oldValue1.
(blockArgs at:2) value:oldValue2.
(blockArgs at:3) value:oldValue3.
(blockArgs at:4) value:oldValue4.
^ val
].
val := statements evaluate.
(blockArgs at:1) value:oldValue1.
(blockArgs at:2) value:oldValue2.
(blockArgs at:3) value:oldValue3.
(blockArgs at:4) value:oldValue4.
^ val
!
valueWithArguments:argArray
|oldValues val|
(blockArgs size ~~ argArray size) ifTrue:[
^ self argumentCountError:argArray size
].
statements isNil ifTrue:[^ nil].
oldValues := Array new:(argArray size).
1 to:argArray size do:[:i |
oldValues at:i put:(blockArgs at:i) value.
(blockArgs at:i) value:(argArray at:i).
].
exitBlock := [:val |
1 to:argArray size do:[:i |
( blockArgs at:i) value:(oldValues at:i)
].
^ val
].
val := statements evaluate.
1 to:argArray size do:[:i |
(blockArgs at:i) value:(oldValues at:i)
].
^ val
! !
!BlockNode methodsFor:'looping'!
whileTrue:aBlock
[self value] whileTrue:[
aBlock value
].
^ nil
!
whileFalse:aBlock
[self value] whileFalse:[
aBlock value
].
^ nil
! !
!BlockNode methodsFor:'block messages'!
doesNotUnderstand:aMessage
|numArgs kludgeBlock|
(Block implements:(aMessage selector)) ifTrue:[
"mhmh - a message which I dont understand, but Block implements
send it to a kludgeblock, which will evaluate me again ..."
numArgs := blockArgs size.
numArgs == 0 ifTrue:[
kludgeBlock := [self value]
] ifFalse:[
numArgs == 1 ifTrue:[
kludgeBlock := [:a1 | self value:a1].
] ifFalse:[
numArgs == 2 ifTrue:[
kludgeBlock := [:a1 :a2 | self value:a1 value:a2].
] ifFalse:[
numArgs == 3 ifTrue:[
kludgeBlock := [:a1 :a2 :a3| self value:a1 value:a2 value:a3].
] ifFalse:[
numArgs == 4 ifTrue:[
kludgeBlock := [:a1 :a2 :a3 :a4| self value:a1 value:a2 value:a3 value:a4].
] ifFalse:[
^ self error:'only support blocks with up-to 4 args'
]
]
]
]
].
^ kludgeBlock perform:aMessage selector withArguments:aMessage arguments
].
super doesNotUnderstand:aMessage
! !
!BlockNode methodsFor:'code generation'!
codeOn:aStream inBlock:b
|thisStatement nextStatement pos code cheapy|
cheapy := self checkForSimpleBlock.
cheapy notNil ifTrue:[
cheapy codeOn:aStream inBlock:b.
^ self
].
pos := aStream position.
aStream nextPut:#makeBlock. "+0"
aStream nextPut:0. "+1"
aStream nextPut:(blockVars size). "+2"
aStream nextPut:(blockArgs size). "+3"
statements isNil ifTrue:[
aStream nextPut:#pushNil "+4"
] ifFalse:[
thisStatement := statements.
[thisStatement notNil] whileTrue:[
nextStatement := thisStatement nextStatement.
nextStatement notNil ifTrue:[
thisStatement codeForSideEffectOn:aStream inBlock:self
] ifFalse:[
thisStatement codeOn:aStream inBlock:self
].
thisStatement := nextStatement
]
].
aStream nextPut:#blockRetTop.
"check for [0]-block;
these are sometimes used as in ... ifAbsent:[0]
"
code := (aStream contents).
(code at:pos+4) == #push0 ifTrue:[
(code at:pos+5) == #blockRetTop ifTrue:[
aStream position:pos.
code grow:pos.
aStream nextPut:#mk0Block.
^ self
]
].
"check for [nil]-block;
these come to play when code in blocks is commented
out, or as dummy exception blocks
"
code := (aStream contents).
(code at:pos+4) == #pushNil ifTrue:[
(code at:pos+5) == #blockRetTop ifTrue:[
aStream position:pos.
code grow:pos.
aStream nextPut:#mkNilBlock.
^ self
]
].
(aStream contents) at:pos+1 put:(aStream position)
!
codeInlineOn:aStream inBlock:b valueNeeded:valueNeeded
|thisStatement nextStatement|
blockVars notNil ifTrue:[
"cannot currently compile this block inline (have to move blockvars into
surrounding method. generate a make-block and send it value"
Transcript showCr:'cannot (yet) compile block with blockvars inline'.
self codeOn:aStream inBlock:b.
aStream nextPut:#value.
valueNeeded ifFalse:[
aStream nextPut:#drop
].
^ self
].
inlineBlock := true.
statements isNil ifTrue:[
valueNeeded ifTrue:[
aStream nextPut:#pushNil
]
] ifFalse:[
thisStatement := statements.
[thisStatement notNil] whileTrue:[
nextStatement := thisStatement nextStatement.
(nextStatement notNil or:[valueNeeded not]) ifTrue:[
thisStatement codeForSideEffectOn:aStream inBlock:b
] ifFalse:[
thisStatement codeOn:aStream inBlock:b
].
thisStatement := nextStatement
]
]
!
codeInlineOn:aStream inBlock:b
self codeInlineOn:aStream inBlock:b valueNeeded:true
!
checkForSimpleBlock
"simple things can be made cheap blocks right now -
resulting in a simple pushLit instruction ..."
|cheapy e val|
statements isNil ifTrue:[
"a []-block"
cheapy := Block code:(ByteCodeCompiler sharedCodeFunctionFor:#blockRetNil)
byteCode:nil
nargs:(blockArgs size)
sourcePosition:nil
initialPC:nil
literals:nil.
^ ConstantNode type:#Block value:cheapy
].
statements nextStatement isNil ifTrue:[
(statements isMemberOf:StatementNode) ifTrue:[
e := statements expression.
e isConstant ifTrue:[
val := e value.
val == 0 ifTrue:[
"a [0]-block"
cheapy := Block code:(ByteCodeCompiler sharedCodeFunctionFor:#blockRet0)
byteCode:nil
nargs:(blockArgs size)
sourcePosition:nil
initialPC:nil
literals:nil.
^ ConstantNode type:#Block value:cheapy
].
val == true ifTrue:[
"a [true]-block"
cheapy := Block code:(ByteCodeCompiler sharedCodeFunctionFor:#blockRetTrue)
byteCode:nil
nargs:(blockArgs size)
sourcePosition:nil
initialPC:nil
literals:nil.
^ ConstantNode type:#Block value:cheapy
].
val == false ifTrue:[
"a [false]-block"
cheapy := Block code:(ByteCodeCompiler sharedCodeFunctionFor:#blockRetFalse)
byteCode:nil
nargs:(blockArgs size)
sourcePosition:nil
initialPC:nil
literals:nil.
^ ConstantNode type:#Block value:cheapy
].
val == nil ifTrue:[
"a [nil]-block"
cheapy := Block code:(ByteCodeCompiler sharedCodeFunctionFor:#blockRetNil)
byteCode:nil
nargs:(blockArgs size)
sourcePosition:nil
initialPC:nil
literals:nil.
^ ConstantNode type:#Block value:cheapy
]
]
]
].
"
statements printOn:Transcript.
"
^ nil
! !
!BlockNode methodsFor:'printing'!
printOn:aStream indent:i
aStream nextPut:$[.
1 to:blockArgs size do:[:index |
aStream nextPut:$:.
aStream nextPutAll:(blockArgs at:index) name.
aStream space.
aStream nextPut:$|
].
statements notNil ifTrue:[
aStream cr.
statements printAllOn:aStream indent:i + 4.
aStream cr.
aStream spaces:i.
].
aStream nextPut:$]
! !