# HG changeset patch # User Claus Gittinger # Date 817092959 -3600 # Node ID 1ef1d13951465b366f35604250b34412ba52ed3c # Parent 65eaf1a009f50f2b68455e98df84bfec3fc72978 checkin from browser diff -r 65eaf1a009f5 -r 1ef1d1395146 AssignNd.st --- a/AssignNd.st Sat Nov 18 17:59:14 1995 +0100 +++ b/AssignNd.st Thu Nov 23 03:15:59 1995 +0100 @@ -11,10 +11,10 @@ " ParseNode subclass:#AssignmentNode - instanceVariableNames:'variable expression' - classVariableNames:'' - poolDictionaries:'' - category:'System-Compiler-Support' + instanceVariableNames:'variable expression' + classVariableNames:'' + poolDictionaries:'' + category:'System-Compiler-Support' ! !AssignmentNode class methodsFor:'documentation'! @@ -33,14 +33,14 @@ " ! -version - ^ '$Header: /cvs/stx/stx/libcomp/Attic/AssignNd.st,v 1.13 1995-11-11 15:29:49 cg Exp $' -! - documentation " node for parse-trees, representing assignments " +! + +version + ^ '$Header: /cvs/stx/stx/libcomp/Attic/AssignNd.st,v 1.14 1995-11-23 02:12:04 cg Exp $' ! ! !AssignmentNode class methodsFor:'instance creation'! @@ -49,32 +49,15 @@ ^ (self basicNew) variable:v expression:e ! ! -!AssignmentNode methodsFor:'evaluating'! - -evaluate - |value| - value := expression evaluate. - variable store:value. - ^ value -! ! +!AssignmentNode methodsFor:'accessing'! -!AssignmentNode methodsFor:'queries'! - -isAssignment - "return true, if this is a node for an assignment" - - ^ true -! ! - -!AssignmentNode methodsFor:'accessing'! +expression + ^ expression +! variable:v expression:e variable := v. expression := e -! - -expression - ^ expression ! ! !AssignmentNode methodsFor:'code generation'! @@ -126,6 +109,15 @@ variable codeStoreOn:aStream inBlock:b valueNeeded:true for:aCompiler ! ! +!AssignmentNode methodsFor:'evaluating'! + +evaluate + |value| + value := expression evaluate. + variable store:value. + ^ value +! ! + !AssignmentNode methodsFor:'printing'! printOn:aStream indent:i @@ -133,3 +125,12 @@ aStream nextPutAll:' := '. expression printOn:aStream ! ! + +!AssignmentNode methodsFor:'queries'! + +isAssignment + "return true, if this is a node for an assignment" + + ^ true +! ! + diff -r 65eaf1a009f5 -r 1ef1d1395146 AssignmentNode.st --- a/AssignmentNode.st Sat Nov 18 17:59:14 1995 +0100 +++ b/AssignmentNode.st Thu Nov 23 03:15:59 1995 +0100 @@ -11,10 +11,10 @@ " ParseNode subclass:#AssignmentNode - instanceVariableNames:'variable expression' - classVariableNames:'' - poolDictionaries:'' - category:'System-Compiler-Support' + instanceVariableNames:'variable expression' + classVariableNames:'' + poolDictionaries:'' + category:'System-Compiler-Support' ! !AssignmentNode class methodsFor:'documentation'! @@ -33,14 +33,14 @@ " ! -version - ^ '$Header: /cvs/stx/stx/libcomp/AssignmentNode.st,v 1.13 1995-11-11 15:29:49 cg Exp $' -! - documentation " node for parse-trees, representing assignments " +! + +version + ^ '$Header: /cvs/stx/stx/libcomp/AssignmentNode.st,v 1.14 1995-11-23 02:12:04 cg Exp $' ! ! !AssignmentNode class methodsFor:'instance creation'! @@ -49,32 +49,15 @@ ^ (self basicNew) variable:v expression:e ! ! -!AssignmentNode methodsFor:'evaluating'! - -evaluate - |value| - value := expression evaluate. - variable store:value. - ^ value -! ! +!AssignmentNode methodsFor:'accessing'! -!AssignmentNode methodsFor:'queries'! - -isAssignment - "return true, if this is a node for an assignment" - - ^ true -! ! - -!AssignmentNode methodsFor:'accessing'! +expression + ^ expression +! variable:v expression:e variable := v. expression := e -! - -expression - ^ expression ! ! !AssignmentNode methodsFor:'code generation'! @@ -126,6 +109,15 @@ variable codeStoreOn:aStream inBlock:b valueNeeded:true for:aCompiler ! ! +!AssignmentNode methodsFor:'evaluating'! + +evaluate + |value| + value := expression evaluate. + variable store:value. + ^ value +! ! + !AssignmentNode methodsFor:'printing'! printOn:aStream indent:i @@ -133,3 +125,12 @@ aStream nextPutAll:' := '. expression printOn:aStream ! ! + +!AssignmentNode methodsFor:'queries'! + +isAssignment + "return true, if this is a node for an assignment" + + ^ true +! ! + diff -r 65eaf1a009f5 -r 1ef1d1395146 BinaryNd.st --- a/BinaryNd.st Sat Nov 18 17:59:14 1995 +0100 +++ b/BinaryNd.st Thu Nov 23 03:15:59 1995 +0100 @@ -11,10 +11,10 @@ " MessageNode subclass:#BinaryNode - instanceVariableNames:'' - classVariableNames:'' - poolDictionaries:'' - category:'System-Compiler-Support' + instanceVariableNames:'' + classVariableNames:'' + poolDictionaries:'' + category:'System-Compiler-Support' ! !BinaryNode class methodsFor:'documentation'! @@ -33,14 +33,14 @@ " ! -version - ^ '$Header: /cvs/stx/stx/libcomp/Attic/BinaryNd.st,v 1.17 1995-11-11 15:30:10 cg Exp $' -! - documentation " node for parse-trees, representing binary message sends " +! + +version + ^ '$Header: /cvs/stx/stx/libcomp/Attic/BinaryNd.st,v 1.18 1995-11-23 02:12:23 cg Exp $' ! ! !BinaryNode class methodsFor:'queries'! @@ -62,27 +62,12 @@ ^ false ! ! -!BinaryNode methodsFor:'queries'! - -isBinaryMessage - ^ true -! ! - !BinaryNode methodsFor:'accessing'! arg ^ argArray at:1 ! ! -!BinaryNode methodsFor:'evaluating'! - -evaluate - receiver isSuper ifTrue:[ - ^ super evaluate - ]. - ^ (receiver evaluate) perform:selector with:(argArray at:1) evaluate -! ! - !BinaryNode methodsFor:'code generation'! codeOn:aStream inBlock:b for:aCompiler @@ -188,6 +173,15 @@ ^ super codeOn:aStream inBlock:b for:aCompiler ! ! +!BinaryNode methodsFor:'evaluating'! + +evaluate + receiver isSuper ifTrue:[ + ^ super evaluate + ]. + ^ (receiver evaluate) perform:selector with:(argArray at:1) evaluate +! ! + !BinaryNode methodsFor:'printing'! printOn:aStream indent:i @@ -225,3 +219,10 @@ aStream nextPutAll:') ' ]. ! ! + +!BinaryNode methodsFor:'queries'! + +isBinaryMessage + ^ true +! ! + diff -r 65eaf1a009f5 -r 1ef1d1395146 BinaryNode.st --- a/BinaryNode.st Sat Nov 18 17:59:14 1995 +0100 +++ b/BinaryNode.st Thu Nov 23 03:15:59 1995 +0100 @@ -11,10 +11,10 @@ " MessageNode subclass:#BinaryNode - instanceVariableNames:'' - classVariableNames:'' - poolDictionaries:'' - category:'System-Compiler-Support' + instanceVariableNames:'' + classVariableNames:'' + poolDictionaries:'' + category:'System-Compiler-Support' ! !BinaryNode class methodsFor:'documentation'! @@ -33,14 +33,14 @@ " ! -version - ^ '$Header: /cvs/stx/stx/libcomp/BinaryNode.st,v 1.17 1995-11-11 15:30:10 cg Exp $' -! - documentation " node for parse-trees, representing binary message sends " +! + +version + ^ '$Header: /cvs/stx/stx/libcomp/BinaryNode.st,v 1.18 1995-11-23 02:12:23 cg Exp $' ! ! !BinaryNode class methodsFor:'queries'! @@ -62,27 +62,12 @@ ^ false ! ! -!BinaryNode methodsFor:'queries'! - -isBinaryMessage - ^ true -! ! - !BinaryNode methodsFor:'accessing'! arg ^ argArray at:1 ! ! -!BinaryNode methodsFor:'evaluating'! - -evaluate - receiver isSuper ifTrue:[ - ^ super evaluate - ]. - ^ (receiver evaluate) perform:selector with:(argArray at:1) evaluate -! ! - !BinaryNode methodsFor:'code generation'! codeOn:aStream inBlock:b for:aCompiler @@ -188,6 +173,15 @@ ^ super codeOn:aStream inBlock:b for:aCompiler ! ! +!BinaryNode methodsFor:'evaluating'! + +evaluate + receiver isSuper ifTrue:[ + ^ super evaluate + ]. + ^ (receiver evaluate) perform:selector with:(argArray at:1) evaluate +! ! + !BinaryNode methodsFor:'printing'! printOn:aStream indent:i @@ -225,3 +219,10 @@ aStream nextPutAll:') ' ]. ! ! + +!BinaryNode methodsFor:'queries'! + +isBinaryMessage + ^ true +! ! + diff -r 65eaf1a009f5 -r 1ef1d1395146 BlockNode.st --- a/BlockNode.st Sat Nov 18 17:59:14 1995 +0100 +++ b/BlockNode.st Thu Nov 23 03:15:59 1995 +0100 @@ -11,12 +11,11 @@ " ParseNode subclass:#BlockNode - instanceVariableNames:'blockArgs statements home inlineBlock exitBlock - blockVars - needsHome lineNr' - classVariableNames:'' - poolDictionaries:'' - category:'System-Compiler-Support' + instanceVariableNames:'blockArgs statements home inlineBlock exitBlock blockVars + needsHome lineNr' + classVariableNames:'' + poolDictionaries:'' + category:'System-Compiler-Support' ! !BlockNode class methodsFor:'documentation'! @@ -35,14 +34,14 @@ " ! -version - ^ '$Header: /cvs/stx/stx/libcomp/BlockNode.st,v 1.18 1995-11-11 15:30:12 cg Exp $' -! - documentation " node for parse-trees, representing blocks " +! + +version + ^ '$Header: /cvs/stx/stx/libcomp/BlockNode.st,v 1.19 1995-11-23 02:12:33 cg Exp $' ! ! !BlockNode class methodsFor:'instance creation'! @@ -51,16 +50,6 @@ ^ (self basicNew) setArguments:argList home:h variables:vars ! ! -!BlockNode methodsFor:'private accessing'! - -setArguments:argList home:h variables:vars - inlineBlock := false. - needsHome := false. - blockArgs := argList. - home := h. - blockVars := vars -! ! - !BlockNode methodsFor:'accessing'! arguments @@ -71,30 +60,14 @@ blockArgs := argList ! -variables - ^ blockVars -! - -variables:varList - blockVars := varList -! - -statements - ^ statements -! - -statements:s - statements := s +home + ^ home ! home:aBlock home := aBlock ! -home - ^ home -! - inlineBlock ^ inlineBlock ! @@ -103,6 +76,10 @@ inlineBlock := aBoolean ! +lineNumber:aNumber + lineNr := aNumber +! + needsHome ^ needsHome ! @@ -111,20 +88,238 @@ needsHome := aBoolean ! -lineNumber:aNumber - lineNr := aNumber +statements + ^ statements +! + +statements:s + statements := s +! + +variables + ^ blockVars +! + +variables:varList + blockVars := varList +! ! + +!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:'queries'! +!BlockNode methodsFor:'code generation'! + +checkForSimpleBlock + "simple things can be made cheap blocks right now - + resulting in a simple pushLit instruction ..." + + |cheapy e val code| + + statements isNil ifTrue:[ + "a []-block" + + val := nil + ] ifFalse:[ + statements nextStatement notNil ifTrue:[^ nil]. + (statements isMemberOf:StatementNode) ifFalse:[^ nil]. + + e := statements expression. + e isConstant ifFalse:[^ nil]. + + val := e value. + ]. + + val == 0 ifTrue:[ + "a [0]-block" + + code := ByteArray with:(ByteCodeCompiler byteCodeFor:#ret0). + ]. + val == 1 ifTrue:[ + "a [1]-block" + + code := ByteArray with:(ByteCodeCompiler byteCodeFor:#push1) + with:(ByteCodeCompiler byteCodeFor:#retTop). + ]. + + val == true ifTrue:[ + "a [true]-block" + + code := ByteArray with:(ByteCodeCompiler byteCodeFor:#retTrue). + ]. + + val == false ifTrue:[ + "a [false]-block" + + code := ByteArray with:(ByteCodeCompiler byteCodeFor:#retFalse). + ]. + + val == nil ifTrue:[ + "a [nil]-block" + + code := ByteArray with:(ByteCodeCompiler byteCodeFor:#retNil). + ]. + + code notNil ifTrue:[ + cheapy := Block code:nil + byteCode:code + numArgs:(blockArgs size) + sourcePosition:nil + initialPC:nil + literals:nil + dynamic:false. + ^ ConstantNode type:#Block value:cheapy + ]. + + ^ nil +! + +codeForSideEffectOn:aStream inBlock:b for:aCompiler + "generate code for this statement - value not needed. + For blocks, no code is generated at all." + + ^ self +! + +codeInlineOn:aStream inBlock:b for:aCompiler + self codeInlineOn:aStream inBlock:b valueNeeded:true for:aCompiler +! + +codeInlineOn:aStream inBlock:b valueNeeded:valueNeeded for:aCompiler + |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" -isBlock - "a kludge, to have blocknodes mimic blocks" +"/ Transcript showCr:'cannot (yet) compile block with blockvars inline'. + self codeOn:aStream inBlock:b for:aCompiler. + aStream nextPut:#value. + (MessageNode hasLineNumber:#value) ifTrue:[ + aStream nextPut:lineNr. + ]. + 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 for:aCompiler + ] ifFalse:[ + thisStatement codeOn:aStream inBlock:b for:aCompiler + ]. + thisStatement := nextStatement + ] + ] +! + +codeOn:aStream inBlock:b for:aCompiler + |thisStatement nextStatement pos code cheapy| + + cheapy := self checkForSimpleBlock. + cheapy notNil ifTrue:[ + cheapy codeOn:aStream inBlock:b for:aCompiler. + ^ self + ]. + + pos := aStream position. - ^ true + 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 for:aCompiler + ] ifFalse:[ + thisStatement codeOn:aStream inBlock:self for:aCompiler + ]. + thisStatement := nextStatement + ] + ]. + aStream nextPut:#retTop. + + "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) == #retTop 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) == #retTop ifTrue:[ + aStream position:pos. + code grow:pos. + aStream nextPut:#mkNilBlock. + ^ self + ] + ]. + + (aStream contents) at:pos+1 put:(aStream position) ! ! !BlockNode methodsFor:'evaluating'! +evaluate + ^ self +! + exitWith:something "return via return-statement" @@ -135,17 +330,6 @@ ^ something ! -evaluate - ^ self -! - -wrongNumberOfArguments:numberGiven - Block argumentSignal - raiseRequestWith:self - errorString:('block got ' , numberGiven printString , - ' args while ' , blockArgs size printString , ' where expected') -! - value (blockArgs size ~~ 0) ifTrue:[ ^ self wrongNumberOfArguments:0 @@ -265,7 +449,7 @@ (blockArgs at:3) value:oldValue3. (blockArgs at:4) value:oldValue4. ^ val -! +! valueWithArguments:argArray |oldValues val| @@ -293,230 +477,27 @@ (blockArgs at:i) value:(oldValues at:i) ]. ^ val +! + +wrongNumberOfArguments:numberGiven + Block argumentSignal + raiseRequestWith:self + errorString:('block got ' , numberGiven printString , + ' args while ' , blockArgs size printString , ' where expected') ! ! !BlockNode methodsFor:'looping'! -whileTrue:aBlock - self value ifFalse:[^ nil]. - aBlock value. - thisContext restart -! - whileFalse:aBlock self value ifTrue:[^ nil]. aBlock value. thisContext restart -! ! - -!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 for:aCompiler - |thisStatement nextStatement pos code cheapy| - - cheapy := self checkForSimpleBlock. - cheapy notNil ifTrue:[ - cheapy codeOn:aStream inBlock:b for:aCompiler. - ^ 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 for:aCompiler - ] ifFalse:[ - thisStatement codeOn:aStream inBlock:self for:aCompiler - ]. - thisStatement := nextStatement - ] - ]. - aStream nextPut:#retTop. - - "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) == #retTop 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) == #retTop ifTrue:[ - aStream position:pos. - code grow:pos. - aStream nextPut:#mkNilBlock. - ^ self - ] - ]. - - (aStream contents) at:pos+1 put:(aStream position) ! -codeForSideEffectOn:aStream inBlock:b for:aCompiler - "generate code for this statement - value not needed. - For blocks, no code is generated at all." - - ^ self -! - -codeInlineOn:aStream inBlock:b valueNeeded:valueNeeded for:aCompiler - |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 for:aCompiler. - aStream nextPut:#value. - (MessageNode hasLineNumber:#value) ifTrue:[ - aStream nextPut:lineNr. - ]. - 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 for:aCompiler - ] ifFalse:[ - thisStatement codeOn:aStream inBlock:b for:aCompiler - ]. - thisStatement := nextStatement - ] - ] -! - -codeInlineOn:aStream inBlock:b for:aCompiler - self codeInlineOn:aStream inBlock:b valueNeeded:true for:aCompiler -! - -checkForSimpleBlock - "simple things can be made cheap blocks right now - - resulting in a simple pushLit instruction ..." - - |cheapy e val code| - - statements isNil ifTrue:[ - "a []-block" - - val := nil - ] ifFalse:[ - statements nextStatement notNil ifTrue:[^ nil]. - (statements isMemberOf:StatementNode) ifFalse:[^ nil]. - - e := statements expression. - e isConstant ifFalse:[^ nil]. - - val := e value. - ]. - - val == 0 ifTrue:[ - "a [0]-block" - - code := ByteArray with:(ByteCodeCompiler byteCodeFor:#ret0). - ]. - val == 1 ifTrue:[ - "a [1]-block" - - code := ByteArray with:(ByteCodeCompiler byteCodeFor:#push1) - with:(ByteCodeCompiler byteCodeFor:#retTop). - ]. - - val == true ifTrue:[ - "a [true]-block" - - code := ByteArray with:(ByteCodeCompiler byteCodeFor:#retTrue). - ]. - - val == false ifTrue:[ - "a [false]-block" - - code := ByteArray with:(ByteCodeCompiler byteCodeFor:#retFalse). - ]. - - val == nil ifTrue:[ - "a [nil]-block" - - code := ByteArray with:(ByteCodeCompiler byteCodeFor:#retNil). - ]. - - code notNil ifTrue:[ - cheapy := Block code:nil - byteCode:code - numArgs:(blockArgs size) - sourcePosition:nil - initialPC:nil - literals:nil - dynamic:false. - ^ ConstantNode type:#Block value:cheapy - ]. - - ^ nil +whileTrue:aBlock + self value ifFalse:[^ nil]. + aBlock value. + thisContext restart ! ! !BlockNode methodsFor:'printing'! @@ -550,3 +531,22 @@ ]. aStream nextPut:$] ! ! + +!BlockNode methodsFor:'private accessing'! + +setArguments:argList home:h variables:vars + inlineBlock := false. + needsHome := false. + blockArgs := argList. + home := h. + blockVars := vars +! ! + +!BlockNode methodsFor:'queries'! + +isBlock + "a kludge, to have blocknodes mimic blocks" + + ^ true +! ! + diff -r 65eaf1a009f5 -r 1ef1d1395146 CascadeNd.st --- a/CascadeNd.st Sat Nov 18 17:59:14 1995 +0100 +++ b/CascadeNd.st Thu Nov 23 03:15:59 1995 +0100 @@ -11,10 +11,10 @@ " MessageNode subclass:#CascadeNode - instanceVariableNames:'' - classVariableNames:'' - poolDictionaries:'' - category:'System-Compiler-Support' + instanceVariableNames:'' + classVariableNames:'' + poolDictionaries:'' + category:'System-Compiler-Support' ! !CascadeNode class methodsFor:'documentation'! @@ -33,30 +33,65 @@ " ! -version - ^ '$Header: /cvs/stx/stx/libcomp/Attic/CascadeNd.st,v 1.11 1995-11-11 15:30:15 cg Exp $' -! - documentation " node for parse-trees, representing cascade message sends " +! + +version + ^ '$Header: /cvs/stx/stx/libcomp/Attic/CascadeNd.st,v 1.12 1995-11-23 02:12:44 cg Exp $' ! ! -!CascadeNode methodsFor: 'code generation'! - -codeOn:aStream inBlock:b valueNeeded:valueNeeded for:aCompiler - receiver codeForCascadeOn:aStream inBlock:b for:aCompiler. - self codeSendOn:aStream inBlock:b valueNeeded:valueNeeded for:aCompiler -! +!CascadeNode methodsFor:'code generation'! codeForCascadeOn:aStream inBlock:b for:aCompiler receiver codeForCascadeOn:aStream inBlock:b for:aCompiler. aStream nextPut:#dup. self codeSendOn:aStream inBlock:b valueNeeded:false for:aCompiler +! + +codeOn:aStream inBlock:b valueNeeded:valueNeeded for:aCompiler + receiver codeForCascadeOn:aStream inBlock:b for:aCompiler. + self codeSendOn:aStream inBlock:b valueNeeded:valueNeeded for:aCompiler ! ! -!CascadeNode methodsFor: 'printing'! +!CascadeNode methodsFor:'evaluating'! + +evaluate + |t argValueArray| + + receiver isSuper ifTrue:[ + ^ super evaluate + ]. + + t := receiver evaluateForCascade. + argArray isNil ifTrue:[ + t perform:selector. + ^ t + ]. + argValueArray := argArray collect:[:arg | arg evaluate]. + ^ t perform:selector withArguments:argValueArray +! + +evaluateForCascade + |t argValueArray| + + receiver isSuper ifTrue:[ + ^ super evaluateForCascade + ]. + + t := receiver evaluateForCascade. + argArray isNil ifTrue:[ + t perform:selector. + ^ t + ]. + argValueArray := argArray collect:[:arg | arg evaluate]. + t perform:selector withArguments:argValueArray. + ^ t +! ! + +!CascadeNode methodsFor:'printing'! printOn:aStream indent:i |needParen selectorParts index index2 arg nargs| @@ -103,37 +138,3 @@ ] ! ! -!CascadeNode methodsFor: 'evaluating'! - -evaluate - |t argValueArray| - - receiver isSuper ifTrue:[ - ^ super evaluate - ]. - - t := receiver evaluateForCascade. - argArray isNil ifTrue:[ - t perform:selector. - ^ t - ]. - argValueArray := argArray collect:[:arg | arg evaluate]. - ^ t perform:selector withArguments:argValueArray -! - -evaluateForCascade - |t argValueArray| - - receiver isSuper ifTrue:[ - ^ super evaluateForCascade - ]. - - t := receiver evaluateForCascade. - argArray isNil ifTrue:[ - t perform:selector. - ^ t - ]. - argValueArray := argArray collect:[:arg | arg evaluate]. - t perform:selector withArguments:argValueArray. - ^ t -! ! diff -r 65eaf1a009f5 -r 1ef1d1395146 CascadeNode.st --- a/CascadeNode.st Sat Nov 18 17:59:14 1995 +0100 +++ b/CascadeNode.st Thu Nov 23 03:15:59 1995 +0100 @@ -11,10 +11,10 @@ " MessageNode subclass:#CascadeNode - instanceVariableNames:'' - classVariableNames:'' - poolDictionaries:'' - category:'System-Compiler-Support' + instanceVariableNames:'' + classVariableNames:'' + poolDictionaries:'' + category:'System-Compiler-Support' ! !CascadeNode class methodsFor:'documentation'! @@ -33,30 +33,65 @@ " ! -version - ^ '$Header: /cvs/stx/stx/libcomp/CascadeNode.st,v 1.11 1995-11-11 15:30:15 cg Exp $' -! - documentation " node for parse-trees, representing cascade message sends " +! + +version + ^ '$Header: /cvs/stx/stx/libcomp/CascadeNode.st,v 1.12 1995-11-23 02:12:44 cg Exp $' ! ! -!CascadeNode methodsFor: 'code generation'! - -codeOn:aStream inBlock:b valueNeeded:valueNeeded for:aCompiler - receiver codeForCascadeOn:aStream inBlock:b for:aCompiler. - self codeSendOn:aStream inBlock:b valueNeeded:valueNeeded for:aCompiler -! +!CascadeNode methodsFor:'code generation'! codeForCascadeOn:aStream inBlock:b for:aCompiler receiver codeForCascadeOn:aStream inBlock:b for:aCompiler. aStream nextPut:#dup. self codeSendOn:aStream inBlock:b valueNeeded:false for:aCompiler +! + +codeOn:aStream inBlock:b valueNeeded:valueNeeded for:aCompiler + receiver codeForCascadeOn:aStream inBlock:b for:aCompiler. + self codeSendOn:aStream inBlock:b valueNeeded:valueNeeded for:aCompiler ! ! -!CascadeNode methodsFor: 'printing'! +!CascadeNode methodsFor:'evaluating'! + +evaluate + |t argValueArray| + + receiver isSuper ifTrue:[ + ^ super evaluate + ]. + + t := receiver evaluateForCascade. + argArray isNil ifTrue:[ + t perform:selector. + ^ t + ]. + argValueArray := argArray collect:[:arg | arg evaluate]. + ^ t perform:selector withArguments:argValueArray +! + +evaluateForCascade + |t argValueArray| + + receiver isSuper ifTrue:[ + ^ super evaluateForCascade + ]. + + t := receiver evaluateForCascade. + argArray isNil ifTrue:[ + t perform:selector. + ^ t + ]. + argValueArray := argArray collect:[:arg | arg evaluate]. + t perform:selector withArguments:argValueArray. + ^ t +! ! + +!CascadeNode methodsFor:'printing'! printOn:aStream indent:i |needParen selectorParts index index2 arg nargs| @@ -103,37 +138,3 @@ ] ! ! -!CascadeNode methodsFor: 'evaluating'! - -evaluate - |t argValueArray| - - receiver isSuper ifTrue:[ - ^ super evaluate - ]. - - t := receiver evaluateForCascade. - argArray isNil ifTrue:[ - t perform:selector. - ^ t - ]. - argValueArray := argArray collect:[:arg | arg evaluate]. - ^ t perform:selector withArguments:argValueArray -! - -evaluateForCascade - |t argValueArray| - - receiver isSuper ifTrue:[ - ^ super evaluateForCascade - ]. - - t := receiver evaluateForCascade. - argArray isNil ifTrue:[ - t perform:selector. - ^ t - ]. - argValueArray := argArray collect:[:arg | arg evaluate]. - t perform:selector withArguments:argValueArray. - ^ t -! ! diff -r 65eaf1a009f5 -r 1ef1d1395146 ConstNode.st --- a/ConstNode.st Sat Nov 18 17:59:14 1995 +0100 +++ b/ConstNode.st Thu Nov 23 03:15:59 1995 +0100 @@ -11,11 +11,10 @@ " PrimaryNode subclass:#ConstantNode - instanceVariableNames:'' - classVariableNames:'TrueNode FalseNode NilNode Const0Node Const1Node - Float0Node' - poolDictionaries:'' - category:'System-Compiler-Support' + instanceVariableNames:'' + classVariableNames:'TrueNode FalseNode NilNode Const0Node Const1Node Float0Node' + poolDictionaries:'' + category:'System-Compiler-Support' ! !ConstantNode class methodsFor:'documentation'! @@ -34,55 +33,18 @@ " ! -version - ^ '$Header: /cvs/stx/stx/libcomp/Attic/ConstNode.st,v 1.17 1995-11-11 15:30:17 cg Exp $' -! - documentation " node for parse-trees, representing literal constants " -! ! - -!ConstantNode class methodsFor:'queries'! - -typeOfConstant:anObject - "return the constantNode type for an object" - - "the most common case first ..." - - (anObject isMemberOf:SmallInteger) ifTrue:[ - ^ #Integer - ]. - - anObject isNil ifTrue:[ - ^ #Nil - ]. +! - anObject isNumber ifTrue:[ - "the most common case first ..." - (anObject isMemberOf:Float) ifTrue:[ - ^ #Float - ]. - anObject isInteger ifTrue:[ - ^ #Integer - ]. - ]. - (anObject == true) ifTrue:[ - ^ #True - ]. - (anObject == false) ifTrue:[ - ^ #False - ]. - ^ #Literal +version + ^ '$Header: /cvs/stx/stx/libcomp/Attic/ConstNode.st,v 1.18 1995-11-23 02:12:53 cg Exp $' ! ! !ConstantNode class methodsFor:'instance creation'! -value:val - ^ self type:(self typeOfConstant:val) value:val -! - type:t value:val "some constant nodes are used so often, its worth caching them" (t == #True) ifTrue:[ @@ -126,6 +88,43 @@ ] ]. ^ (self basicNew) type:t value:val +! + +value:val + ^ self type:(self typeOfConstant:val) value:val +! ! + +!ConstantNode class methodsFor:'queries'! + +typeOfConstant:anObject + "return the constantNode type for an object" + + "the most common case first ..." + + (anObject isMemberOf:SmallInteger) ifTrue:[ + ^ #Integer + ]. + + anObject isNil ifTrue:[ + ^ #Nil + ]. + + anObject isNumber ifTrue:[ + "the most common case first ..." + (anObject isMemberOf:Float) ifTrue:[ + ^ #Float + ]. + anObject isInteger ifTrue:[ + ^ #Integer + ]. + ]. + (anObject == true) ifTrue:[ + ^ #True + ]. + (anObject == false) ifTrue:[ + ^ #False + ]. + ^ #Literal ! ! !ConstantNode methodsFor:'accessing'! @@ -135,25 +134,6 @@ value := val ! ! -!ConstantNode methodsFor:'queries'! - -isConstant - ^ true -! ! - -!ConstantNode methodsFor:'evaluating'! - -evaluate - ^ value -! - -store:aValue - "not reached - parser checks for this" - - self error:'store not allowed'. - ^ aValue -! ! - !ConstantNode methodsFor:'code generation'! codeOn:aStream inBlock:b for:aCompiler @@ -225,6 +205,19 @@ ^ self error:'assignment to literals not allowed' ! ! +!ConstantNode methodsFor:'evaluating'! + +evaluate + ^ value +! + +store:aValue + "not reached - parser checks for this" + + self error:'store not allowed'. + ^ aValue +! ! + !ConstantNode methodsFor:'printing'! displayString @@ -234,3 +227,10 @@ printOn:aStream indent:i value storeOn:aStream ! ! + +!ConstantNode methodsFor:'queries'! + +isConstant + ^ true +! ! + diff -r 65eaf1a009f5 -r 1ef1d1395146 ConstantNode.st --- a/ConstantNode.st Sat Nov 18 17:59:14 1995 +0100 +++ b/ConstantNode.st Thu Nov 23 03:15:59 1995 +0100 @@ -11,11 +11,10 @@ " PrimaryNode subclass:#ConstantNode - instanceVariableNames:'' - classVariableNames:'TrueNode FalseNode NilNode Const0Node Const1Node - Float0Node' - poolDictionaries:'' - category:'System-Compiler-Support' + instanceVariableNames:'' + classVariableNames:'TrueNode FalseNode NilNode Const0Node Const1Node Float0Node' + poolDictionaries:'' + category:'System-Compiler-Support' ! !ConstantNode class methodsFor:'documentation'! @@ -34,55 +33,18 @@ " ! -version - ^ '$Header: /cvs/stx/stx/libcomp/ConstantNode.st,v 1.17 1995-11-11 15:30:17 cg Exp $' -! - documentation " node for parse-trees, representing literal constants " -! ! - -!ConstantNode class methodsFor:'queries'! - -typeOfConstant:anObject - "return the constantNode type for an object" - - "the most common case first ..." - - (anObject isMemberOf:SmallInteger) ifTrue:[ - ^ #Integer - ]. - - anObject isNil ifTrue:[ - ^ #Nil - ]. +! - anObject isNumber ifTrue:[ - "the most common case first ..." - (anObject isMemberOf:Float) ifTrue:[ - ^ #Float - ]. - anObject isInteger ifTrue:[ - ^ #Integer - ]. - ]. - (anObject == true) ifTrue:[ - ^ #True - ]. - (anObject == false) ifTrue:[ - ^ #False - ]. - ^ #Literal +version + ^ '$Header: /cvs/stx/stx/libcomp/ConstantNode.st,v 1.18 1995-11-23 02:12:53 cg Exp $' ! ! !ConstantNode class methodsFor:'instance creation'! -value:val - ^ self type:(self typeOfConstant:val) value:val -! - type:t value:val "some constant nodes are used so often, its worth caching them" (t == #True) ifTrue:[ @@ -126,6 +88,43 @@ ] ]. ^ (self basicNew) type:t value:val +! + +value:val + ^ self type:(self typeOfConstant:val) value:val +! ! + +!ConstantNode class methodsFor:'queries'! + +typeOfConstant:anObject + "return the constantNode type for an object" + + "the most common case first ..." + + (anObject isMemberOf:SmallInteger) ifTrue:[ + ^ #Integer + ]. + + anObject isNil ifTrue:[ + ^ #Nil + ]. + + anObject isNumber ifTrue:[ + "the most common case first ..." + (anObject isMemberOf:Float) ifTrue:[ + ^ #Float + ]. + anObject isInteger ifTrue:[ + ^ #Integer + ]. + ]. + (anObject == true) ifTrue:[ + ^ #True + ]. + (anObject == false) ifTrue:[ + ^ #False + ]. + ^ #Literal ! ! !ConstantNode methodsFor:'accessing'! @@ -135,25 +134,6 @@ value := val ! ! -!ConstantNode methodsFor:'queries'! - -isConstant - ^ true -! ! - -!ConstantNode methodsFor:'evaluating'! - -evaluate - ^ value -! - -store:aValue - "not reached - parser checks for this" - - self error:'store not allowed'. - ^ aValue -! ! - !ConstantNode methodsFor:'code generation'! codeOn:aStream inBlock:b for:aCompiler @@ -225,6 +205,19 @@ ^ self error:'assignment to literals not allowed' ! ! +!ConstantNode methodsFor:'evaluating'! + +evaluate + ^ value +! + +store:aValue + "not reached - parser checks for this" + + self error:'store not allowed'. + ^ aValue +! ! + !ConstantNode methodsFor:'printing'! displayString @@ -234,3 +227,10 @@ printOn:aStream indent:i value storeOn:aStream ! ! + +!ConstantNode methodsFor:'queries'! + +isConstant + ^ true +! ! + diff -r 65eaf1a009f5 -r 1ef1d1395146 ImmArray.st --- a/ImmArray.st Sat Nov 18 17:59:14 1995 +0100 +++ b/ImmArray.st Thu Nov 23 03:15:59 1995 +0100 @@ -10,8 +10,6 @@ hereby transferred. " -'From Smalltalk/X, Version:2.10.4 on 20-feb-1995 at 6:26:23 am'! - Array subclass:#ImmutableArray instanceVariableNames:'' classVariableNames:'' @@ -35,10 +33,6 @@ " ! -version - ^ '$Header: /cvs/stx/stx/libcomp/Attic/ImmArray.st,v 1.10 1995-11-11 15:30:26 cg Exp $' -! - documentation " By default, array literals in smalltalk are mutable objects. That @@ -60,6 +54,60 @@ Turn the ImmutableArray feature on by setting the Parsers class variable 'ArraysAreImmutable' to true or use the new launchers settings menu. " +! + +version + ^ '$Header: /cvs/stx/stx/libcomp/Attic/ImmArray.st,v 1.11 1995-11-23 02:13:03 cg Exp $' +! ! + +!ImmutableArray methodsFor:'accessing'! + +at: index put: value + "Trigger an error if an immutable array is stored into. + The store will be performed (for compatibility reasons) if you continue + in the debugger." + + self notifyStoreError. + ^ super at: index put: value +! + +basicAt: index put: value + "Trigger an error if an immutable array is stored into. + The store will be performed (for compatibility reasons) if you continue + in the debugger." + + self notifyStoreError. + ^ super basicAt: index put: value +! ! + +!ImmutableArray methodsFor:'copying'! + +copyEmpty + "when copying, return a real (mutable) Array" + + ^ Array new:self size +! + +copyEmptyAndGrow:size + "when copying, return a real (mutable) Array" + + ^ Array new:size +! + +postCopy + "when copied, make it me a real (mutable) Array" + + self changeClassTo:Array. +! + +shallowCopy + "when copying, return a real (mutable) Array" + + |sz| + + sz := self size. + ^ (Array new:sz) + replaceFrom:1 to:sz with:self startingAt:1 ! ! !ImmutableArray methodsFor:'error handling'! @@ -99,24 +147,23 @@ self error:msg ! ! -!ImmutableArray methodsFor:'accessing'! +!ImmutableArray methodsFor:'private'! -at: index put: value - "Trigger an error if an immutable array is stored into. - The store will be performed (for compatibility reasons) if you continue - in the debugger." +species + "Copies should be mutable" + + ^Array +! ! - self notifyStoreError. - ^ super at: index put: value -! +!ImmutableArray methodsFor:'queries'! -basicAt: index put: value - "Trigger an error if an immutable array is stored into. - The store will be performed (for compatibility reasons) if you continue - in the debugger." +isLiteral + "return true, if the receiver can be used as a literal + (i.e. can be used in constant arrays)" - self notifyStoreError. - ^ super basicAt: index put: value + "yes, I must be" + ^ true + ! ! !ImmutableArray methodsFor:'specials'! @@ -137,51 +184,3 @@ ^ super becomeNil ! ! -!ImmutableArray methodsFor:'private'! - -species - "Copies should be mutable" - - ^Array -! ! - -!ImmutableArray methodsFor:'queries'! - -isLiteral - "return true, if the receiver can be used as a literal - (i.e. can be used in constant arrays)" - - "yes, I must be" - ^ true - -! ! - -!ImmutableArray methodsFor:'copying'! - -copyEmptyAndGrow:size - "when copying, return a real (mutable) Array" - - ^ Array new:size -! - -copyEmpty - "when copying, return a real (mutable) Array" - - ^ Array new:self size -! - -shallowCopy - "when copying, return a real (mutable) Array" - - |sz| - - sz := self size. - ^ (Array new:sz) - replaceFrom:1 to:sz with:self startingAt:1 -! - -postCopy - "when copied, make it me a real (mutable) Array" - - self changeClassTo:Array. -! ! diff -r 65eaf1a009f5 -r 1ef1d1395146 ImmutableArray.st --- a/ImmutableArray.st Sat Nov 18 17:59:14 1995 +0100 +++ b/ImmutableArray.st Thu Nov 23 03:15:59 1995 +0100 @@ -10,8 +10,6 @@ hereby transferred. " -'From Smalltalk/X, Version:2.10.4 on 20-feb-1995 at 6:26:23 am'! - Array subclass:#ImmutableArray instanceVariableNames:'' classVariableNames:'' @@ -35,10 +33,6 @@ " ! -version - ^ '$Header: /cvs/stx/stx/libcomp/Attic/ImmutableArray.st,v 1.10 1995-11-11 15:30:26 cg Exp $' -! - documentation " By default, array literals in smalltalk are mutable objects. That @@ -60,6 +54,60 @@ Turn the ImmutableArray feature on by setting the Parsers class variable 'ArraysAreImmutable' to true or use the new launchers settings menu. " +! + +version + ^ '$Header: /cvs/stx/stx/libcomp/Attic/ImmutableArray.st,v 1.11 1995-11-23 02:13:03 cg Exp $' +! ! + +!ImmutableArray methodsFor:'accessing'! + +at: index put: value + "Trigger an error if an immutable array is stored into. + The store will be performed (for compatibility reasons) if you continue + in the debugger." + + self notifyStoreError. + ^ super at: index put: value +! + +basicAt: index put: value + "Trigger an error if an immutable array is stored into. + The store will be performed (for compatibility reasons) if you continue + in the debugger." + + self notifyStoreError. + ^ super basicAt: index put: value +! ! + +!ImmutableArray methodsFor:'copying'! + +copyEmpty + "when copying, return a real (mutable) Array" + + ^ Array new:self size +! + +copyEmptyAndGrow:size + "when copying, return a real (mutable) Array" + + ^ Array new:size +! + +postCopy + "when copied, make it me a real (mutable) Array" + + self changeClassTo:Array. +! + +shallowCopy + "when copying, return a real (mutable) Array" + + |sz| + + sz := self size. + ^ (Array new:sz) + replaceFrom:1 to:sz with:self startingAt:1 ! ! !ImmutableArray methodsFor:'error handling'! @@ -99,24 +147,23 @@ self error:msg ! ! -!ImmutableArray methodsFor:'accessing'! +!ImmutableArray methodsFor:'private'! -at: index put: value - "Trigger an error if an immutable array is stored into. - The store will be performed (for compatibility reasons) if you continue - in the debugger." +species + "Copies should be mutable" + + ^Array +! ! - self notifyStoreError. - ^ super at: index put: value -! +!ImmutableArray methodsFor:'queries'! -basicAt: index put: value - "Trigger an error if an immutable array is stored into. - The store will be performed (for compatibility reasons) if you continue - in the debugger." +isLiteral + "return true, if the receiver can be used as a literal + (i.e. can be used in constant arrays)" - self notifyStoreError. - ^ super basicAt: index put: value + "yes, I must be" + ^ true + ! ! !ImmutableArray methodsFor:'specials'! @@ -137,51 +184,3 @@ ^ super becomeNil ! ! -!ImmutableArray methodsFor:'private'! - -species - "Copies should be mutable" - - ^Array -! ! - -!ImmutableArray methodsFor:'queries'! - -isLiteral - "return true, if the receiver can be used as a literal - (i.e. can be used in constant arrays)" - - "yes, I must be" - ^ true - -! ! - -!ImmutableArray methodsFor:'copying'! - -copyEmptyAndGrow:size - "when copying, return a real (mutable) Array" - - ^ Array new:size -! - -copyEmpty - "when copying, return a real (mutable) Array" - - ^ Array new:self size -! - -shallowCopy - "when copying, return a real (mutable) Array" - - |sz| - - sz := self size. - ^ (Array new:sz) - replaceFrom:1 to:sz with:self startingAt:1 -! - -postCopy - "when copied, make it me a real (mutable) Array" - - self changeClassTo:Array. -! ! diff -r 65eaf1a009f5 -r 1ef1d1395146 MessageNd.st --- a/MessageNd.st Sat Nov 18 17:59:14 1995 +0100 +++ b/MessageNd.st Thu Nov 23 03:15:59 1995 +0100 @@ -11,10 +11,10 @@ " ParseNode subclass:#MessageNode - instanceVariableNames:'receiver selector argArray lineNr' - classVariableNames:'' - poolDictionaries:'' - category:'System-Compiler-Support' + instanceVariableNames:'receiver selector argArray lineNr' + classVariableNames:'' + poolDictionaries:'' + category:'System-Compiler-Support' ! !MessageNode class methodsFor:'documentation'! @@ -33,14 +33,14 @@ " ! -version - ^ '$Header: /cvs/stx/stx/libcomp/Attic/MessageNd.st,v 1.31 1995-11-11 15:30:33 cg Exp $' -! - documentation " node for parse-trees, representing message sends " +! + +version + ^ '$Header: /cvs/stx/stx/libcomp/Attic/MessageNd.st,v 1.32 1995-11-23 02:13:47 cg Exp $' ! ! !MessageNode class methodsFor:'instance creation'! @@ -49,6 +49,52 @@ ^ (self basicNew) receiver:recNode selector:selectorString args:nil lineno:0 ! +receiver:recNode selector:selectorString arg1:argNode1 arg2:argNode2 fold:folding + |result recVal argVal selector| + + " + This is just a demonstration - of how complex constants can be folded. + This was inspired by some discussion in c.l.s about enhancing the language - I prefer + enhancing the compiler .... + The following optimization will convert '#(...) with:#(...) collect:[...]' into an array constant, + allowing a constant arrays of complex objects. + + Notice: this method is normally disabled - its just a demo after all. + " + folding ifTrue:[ + "do constant folding ..." + (recNode isConstant and:[argNode1 isConstant]) ifTrue:[ + "check if we can do it ..." + selector := selectorString asSymbolIfInterned. + selector notNil ifTrue:[ + recVal := recNode evaluate. + (recVal respondsTo:selector) ifTrue:[ + " + we could do much more here - but then, we need a dependency from + the folded selectors method to the method we generate code for ... + limit optimizations to those that will never change + (or - if you change them - you will crash so bad ...) + " + argVal := argNode1 evaluate. + ((recVal isMemberOf:Array) and:[argVal isMemberOf:Array]) ifTrue:[ + (selector == #with:collect:) ifTrue:[ + (argNode2 isMemberOf:BlockNode) ifTrue:[ + (SignalSet anySignal catch:[ + result := recVal perform:selector with:argVal with:(argNode2 evaluate). + ]) ifTrue:[ + ^ 'error in constant expression' + ]. + ^ ConstantNode type:(ConstantNode typeOfConstant:result) value:result + ] + ] + ] + ] + ] + ] + ]. + ^ (self basicNew) receiver:recNode selector:selectorString args:(Array with:argNode1 with:argNode2) lineno:0 +! + receiver:recNode selector:selectorString arg:argNode ^ self receiver:recNode selector:selectorString arg:argNode fold:true ! @@ -132,52 +178,6 @@ ^ (self basicNew) receiver:recNode selector:selectorString args:(Array with:argNode) lineno:0 ! -receiver:recNode selector:selectorString arg1:argNode1 arg2:argNode2 fold:folding - |result recVal argVal selector| - - " - This is just a demonstration - of how complex constants can be folded. - This was inspired by some discussion in c.l.s about enhancing the language - I prefer - enhancing the compiler .... - The following optimization will convert '#(...) with:#(...) collect:[...]' into an array constant, - allowing a constant arrays of complex objects. - - Notice: this method is normally disabled - its just a demo after all. - " - folding ifTrue:[ - "do constant folding ..." - (recNode isConstant and:[argNode1 isConstant]) ifTrue:[ - "check if we can do it ..." - selector := selectorString asSymbolIfInterned. - selector notNil ifTrue:[ - recVal := recNode evaluate. - (recVal respondsTo:selector) ifTrue:[ - " - we could do much more here - but then, we need a dependency from - the folded selectors method to the method we generate code for ... - limit optimizations to those that will never change - (or - if you change them - you will crash so bad ...) - " - argVal := argNode1 evaluate. - ((recVal isMemberOf:Array) and:[argVal isMemberOf:Array]) ifTrue:[ - (selector == #with:collect:) ifTrue:[ - (argNode2 isMemberOf:BlockNode) ifTrue:[ - (SignalSet anySignal catch:[ - result := recVal perform:selector with:argVal with:(argNode2 evaluate). - ]) ifTrue:[ - ^ 'error in constant expression' - ]. - ^ ConstantNode type:(ConstantNode typeOfConstant:result) value:result - ] - ] - ] - ] - ] - ] - ]. - ^ (self basicNew) receiver:recNode selector:selectorString args:(Array with:argNode1 with:argNode2) lineno:0 -! - receiver:recNode selector:selectorString args:anArray ^ self receiver:recNode selector:selectorString args:anArray fold:true ! @@ -205,45 +205,6 @@ "Modified: 3.9.1995 / 16:41:39 / claus" ! ! -!MessageNode methodsFor:'accessing'! - -receiver:r selector:s args:a lineno:l - receiver := r. - selector := s asSymbol. - argArray := a. - lineNr := l -! - -receiver - ^ receiver -! - -selector - ^ selector -! - -args - ^ argArray -! - -arg1 - ^ argArray at:1 -! - -lineNumber - ^ lineNr -! - -lineNumber:num - lineNr := num -! ! - -!MessageNode methodsFor:'queries'! - -isMessage - ^ true -! ! - !MessageNode class methodsFor:'queries'! hasLineNumber:sel @@ -257,6 +218,27 @@ ^ true ! +isBuiltIn1ArgSelector:sel + "return true, if selector sel is built-in. + (i.e. there is a single bytecode for it)" + + (sel == #at:) ifTrue:[^ true]. + (sel == #value:) ifTrue:[^ true]. + (sel == #bitAnd:) ifTrue:[^ true]. + (sel == #bitOr:) ifTrue:[^ true]. + (sel == #new:) ifTrue:[^ true]. + (sel == #basicNew:) ifTrue:[^ true]. + ^ false +! + +isBuiltIn2ArgSelector:sel + "return true, if selector sel is built-in. + (i.e. there is a single bytecode for it)" + + (sel == #at:put:) ifTrue:[^ true]. + ^ false +! + isBuiltInUnarySelector:sel "return true, if unary selector sel is built-in. (i.e. there is a single bytecode for it)" @@ -280,115 +262,39 @@ (sel == #new) ifTrue:[^ true]. (sel == #basicNew) ifTrue:[^ true]. ^ false -! - -isBuiltIn1ArgSelector:sel - "return true, if selector sel is built-in. - (i.e. there is a single bytecode for it)" - - (sel == #at:) ifTrue:[^ true]. - (sel == #value:) ifTrue:[^ true]. - (sel == #bitAnd:) ifTrue:[^ true]. - (sel == #bitOr:) ifTrue:[^ true]. - (sel == #new:) ifTrue:[^ true]. - (sel == #basicNew:) ifTrue:[^ true]. - ^ false -! - -isBuiltIn2ArgSelector:sel - "return true, if selector sel is built-in. - (i.e. there is a single bytecode for it)" - - (sel == #at:put:) ifTrue:[^ true]. - ^ false ! ! -!MessageNode methodsFor:'printing'! - -printOn:aStream indent:i - |needParen selectorParts index index2 arg| - - (#(whileTrue: whileFalse:) includes:selector) ifTrue:[ - receiver isBlock ifTrue:[ - ^ self printWhileOn:aStream indent:i - ]. - ]. +!MessageNode methodsFor:'accessing'! - index := 1. - selectorParts := OrderedCollection new. - [index == 0] whileFalse:[ - index2 := selector indexOf:$: startingAt:index. - index2 ~~ 0 ifTrue:[ - selectorParts add:(selector copyFrom:index to:index2). - index2 := index2 + 1 - ]. - index := index2 - ]. +arg1 + ^ argArray at:1 +! - needParen := false. - receiver isMessage ifTrue:[ - receiver isUnaryMessage ifFalse:[ - receiver isBinaryMessage ifFalse:[ - needParen := true - ]. - ]. - ]. - needParen ifTrue:[ - aStream nextPutAll:'(' - ]. - receiver printOn:aStream indent:i. - needParen ifTrue:[ - aStream nextPutAll:')' - ]. +args + ^ argArray +! - 1 to:(argArray size) do:[:argIndex | - aStream space. - (selectorParts at:argIndex) printOn:aStream. - aStream space. - arg := argArray at:argIndex. - needParen := false. - arg isMessage ifTrue:[ - arg isBinaryMessage ifFalse:[ - arg isUnaryMessage ifFalse:[ - needParen := true - ] - ]. - ]. - needParen ifTrue:[ - aStream nextPutAll:'(' - ]. - arg printOn:aStream indent:i. - needParen ifTrue:[ - aStream nextPutAll:') ' - ]. - ] +lineNumber + ^ lineNr ! -printWhileOn:aStream indent:i - |needParen arg| +lineNumber:num + lineNr := num +! - "special handling of whileTrue/whileFalse" - - aStream nextPutAll:'['. - receiver statements printOn:aStream indent:i. - aStream nextPutAll:'] whileTrue: '. +receiver + ^ receiver +! - arg := argArray at:1. - needParen := false. - arg isMessage ifTrue:[ - arg isBinaryMessage ifFalse:[ - arg isUnaryMessage ifFalse:[ - needParen := true - ] - ]. - ]. - needParen ifTrue:[ - aStream nextPutAll:'(' - ]. - arg printOn:aStream indent:i. - needParen ifTrue:[ - aStream nextPutAll:') ' - ]. +receiver:r selector:s args:a lineno:l + receiver := r. + selector := s asSymbol. + argArray := a. + lineNr := l +! + +selector + ^ selector ! ! !MessageNode methodsFor:'checks'! @@ -481,238 +387,8 @@ ^ nil ! ! -!MessageNode methodsFor:'evaluating'! - -evaluate - |r nargs argValueArray class| - - receiver isSuper ifTrue:[ - r := receiver value. - receiver isHere ifTrue:[ - class := receiver definingClass. - ] ifFalse:[ - class := receiver definingClass superclass. - ]. - argArray notNil ifTrue:[ - argValueArray := argArray collect:[:arg | arg evaluate]. - ] ifFalse:[ - argValueArray := #() - ]. - ^ r perform:selector inClass:class withArguments:argValueArray - ]. - - - argArray isNil ifTrue:[ - ^ (receiver evaluate) perform:selector - ]. - nargs := argArray size. - (nargs == 1) ifTrue:[ - ^ (receiver evaluate) perform:selector with:(argArray at:1) evaluate - ]. - (nargs == 2) ifTrue:[ - ^ (receiver evaluate) perform:selector - with:(argArray at:1) evaluate - with:(argArray at:2) evaluate - ]. - (nargs == 3) ifTrue:[ - ^ (receiver evaluate) perform:selector - with:(argArray at:1) evaluate - with:(argArray at:2) evaluate - with:(argArray at:3) evaluate - ]. - r := receiver evaluate. - argValueArray := argArray collect:[:arg | arg evaluate]. - ^ r perform:selector withArguments:argValueArray -! - -evaluateForCascade - |r nargs argValueArray class| - - receiver isSuper ifTrue:[ - r := receiver value. - class := receiver definingClass. - receiver isHere ifFalse:[ - class := class superclass. - ]. - argArray notNil ifTrue:[ - argValueArray := argArray collect:[:arg | arg evaluate]. - ] ifFalse:[ - argValueArray := #() - ]. - r perform:selector inClass:class withArguments:argValueArray. - ^ r - ]. - - r := receiver evaluate. - argArray isNil ifTrue:[ - r perform:selector. - ^ r - ]. - nargs := argArray size. - (nargs == 1) ifTrue:[ - r perform:selector with:(argArray at:1) evaluate. - ^ r - ]. - (nargs == 2) ifTrue:[ - r perform:selector with:(argArray at:1) evaluate - with:(argArray at:2) evaluate. - ^ r - ]. - (nargs == 3) ifTrue:[ - r perform:selector with:(argArray at:1) evaluate - with:(argArray at:2) evaluate - with:(argArray at:3) evaluate. - ^ r - ]. - argValueArray := argArray collect:[:arg | arg evaluate]. - r perform:selector withArguments:argValueArray. - ^ r -! ! - !MessageNode methodsFor:'code generation'! -codeForSideEffectOn:aStream inBlock:b for:aCompiler - self codeOn:aStream inBlock:b valueNeeded:false for:aCompiler -! - -codeOn:aStream inBlock:b for:aCompiler - self codeOn:aStream inBlock:b valueNeeded:true for:aCompiler -! - -optimizedConditionFor:aReceiver with:aByteCode - |rec sel| - - rec := aReceiver. - (rec isBlock) ifTrue:[ - rec statements nextStatement isNil ifTrue:[ - rec := rec statements expression - ] - ]. - (rec isUnaryMessage) ifTrue:[ - sel := rec selector. - (sel == #isNil) ifTrue:[ - "/ - "/ isNil trueJmp -> nilJump - "/ isNil falseJmp -> notNilJump - "/ - (aByteCode == #trueJump) ifTrue:[^ #nilJump]. - (aByteCode == #falseJump) ifTrue:[^ #notNilJump] - ]. - (sel == #notNil) ifTrue:[ - "/ - "/ notNil trueJmp -> notNilJump - "/ notNil falseJmp -> nilJump - "/ - (aByteCode == #trueJump) ifTrue:[^ #notNilJump]. - (aByteCode == #falseJump) ifTrue:[^ #nilJump] - ]. - (sel == #not) ifTrue:[ - "/ - "/ not trueJmp -> falseJump - "/ not falseJmp -> trueJump - "/ - (aByteCode == #trueJump) ifTrue:[^ #falseJump]. - (aByteCode == #falseJump) ifTrue:[^ #trueJump] - ]. - ^ nil - ]. - (rec isBinaryMessage) ifTrue:[ - sel := rec selector. - rec arg1 isConstant ifTrue:[ - (rec arg1 value == 0) ifTrue:[ - "/ - "/ ==0 trueJmp -> zeroJump - "/ ==0 falseJmp -> notZeroJump - "/ - (sel == #==) ifTrue:[ - (aByteCode == #trueJump) ifTrue:[^ #zeroJump]. - (aByteCode == #falseJump) ifTrue:[^ #notZeroJump] - ]. - "/ - "/ ~~0 trueJmp -> notZeroJump - "/ ~~0 falseJmp -> zeroJump - "/ - (sel == #~~) ifTrue:[ - (aByteCode == #falseJump) ifTrue:[^ #zeroJump]. - (aByteCode == #trueJump) ifTrue:[^ #notZeroJump] - ]. - ^ nil - ] - ]. - (sel == #==) ifTrue:[ - "/ - "/ == trueJmp -> eqJump - "/ == falseJmp -> notEqJump - "/ - (aByteCode == #trueJump) ifTrue:[^ #eqJump]. - (aByteCode == #falseJump) ifTrue:[^ #notEqJump] - ]. - (sel == #~~) ifTrue:[ - "/ - "/ ~~ trueJmp -> notEqJump - "/ ~~ falseJmp -> eqJump - "/ - (aByteCode == #falseJump) ifTrue:[^ #eqJump]. - (aByteCode == #trueJump) ifTrue:[^ #notEqJump] - ] - ]. - ^ nil -! - -codeWhileOn:aStream inBlock:b valueNeeded:valueNeeded for:aCompiler - "generate code for [...] whilexxx:[ ... ]" - - |pos pos2 theReceiver theArg theByteCode optByteCode| - - (selector == #whileTrue:) ifTrue:[ - theByteCode := #falseJump - ] ifFalse:[ - theByteCode := #trueJump - ]. - - theReceiver := receiver. - optByteCode := self optimizedConditionFor:theReceiver with:theByteCode. - optByteCode notNil ifTrue:[ - ((optByteCode == #eqJump) or:[optByteCode == #notEqJump]) ifTrue:[ - theArg := receiver statements expression arg1 - ]. - theReceiver := receiver statements expression receiver. - theByteCode := optByteCode - ]. - -"/ OLD: -"/ valueNeeded ifTrue:[aStream nextPut:#pushNil]. -"/ - pos := aStream position. - optByteCode notNil ifTrue:[ - theReceiver codeOn:aStream inBlock:b for:aCompiler. - theArg notNil ifTrue:[ - theArg codeOn:aStream inBlock:b for:aCompiler - ] - ] ifFalse:[ - theReceiver codeInlineOn:aStream inBlock:b for:aCompiler - ]. - - (lineNr between:1 and:255) ifTrue:[ - aStream nextPut:#lineno; nextPut:lineNr. - ]. - - aStream nextPut:theByteCode. - pos2 := aStream position. - aStream nextPut:0. -"/ OLD: -"/ valueNeeded ifTrue:[aStream nextPut:#drop]. -"/ -"/ OLD: -"/ (argArray at:1) codeInlineOn:aStream inBlock:b valueNeeded:valueNeeded for:aCompiler. -"/ NEW: - (argArray at:1) codeInlineOn:aStream inBlock:b valueNeeded:false for:aCompiler. - aStream nextPut:#jump; nextPut:pos. - (aStream contents) at:pos2 put:(aStream position). -"/ NEW: - valueNeeded ifTrue:[aStream nextPut:#pushNil]. -! - XXcodeWhileOn:aStream inBlock:b valueNeeded:valueNeeded for:aCompiler "generate code for [...] whilexxx:[ ... ]" @@ -758,27 +434,182 @@ (aStream contents) at:pos2 put:(aStream position). ! -codeTimesRepeatOn:aStream inBlock:b valueNeeded:valueNeeded for:aCompiler - "generate code for n timesRepeat:[ ... ]" +codeAndIfOn:aStream inBlock:b valueNeeded:valueNeeded for:aCompiler + "generate code for (x and:[y]) ifxxx:[ ... ]" + + |theByteCode optByteCode theReceiver theArg pos1 pos2 pos3 code here jmp| + + + theByteCode := #falseJump. + theReceiver := receiver receiver. - |pos pos2 theReceiver| - - theReceiver := receiver. + optByteCode := self optimizedConditionFor:theReceiver + with:theByteCode. + optByteCode notNil ifTrue:[ + ((optByteCode == #eqJump) or:[optByteCode == #notEqJump]) ifTrue:[ + theArg := theReceiver arg1 + ]. + theReceiver := theReceiver receiver. + theByteCode := optByteCode + ]. theReceiver codeOn:aStream inBlock:b for:aCompiler. - valueNeeded ifTrue:[aStream nextPut:#dup]. + theArg notNil ifTrue:[ + theArg codeOn:aStream inBlock:b for:aCompiler + ]. + aStream nextPut:theByteCode. + pos1 := aStream position. + aStream nextPut:0. - pos := aStream position. -"/ aStream nextPut:#dup; nextPut:#push0; nextPut:#>; nextPut:lineNr; nextPut:#falseJump. -"/ aStream nextPut:#dup; nextPut:#gt0; nextPut:lineNr; nextPut:#falseJump. - aStream nextPut:#pushgt0; nextPut:lineNr; nextPut:#falseJump. + theReceiver := receiver arg1. + theReceiver codeInlineOn:aStream inBlock:b for:aCompiler. + (selector == #ifTrue:) ifTrue:[ + jmp := #falseJump + ] ifFalse:[ + jmp := #trueJump + ]. + aStream nextPut:jmp. pos2 := aStream position. aStream nextPut:0. - (argArray at:1) codeInlineOn:aStream inBlock:b valueNeeded:false for:aCompiler. - aStream nextPut:#minus1; nextPut:lineNr; nextPut:#jump; nextPut:pos. + code := aStream contents. + (selector == #ifFalse:) ifTrue:[ + code at:pos1 put:(aStream position) + ]. + (argArray at: 1) codeInlineOn:aStream inBlock:b valueNeeded:valueNeeded for:aCompiler. + + valueNeeded ifTrue:[ + aStream nextPut:#jump. + pos3 := aStream position. + aStream nextPut:0. + here := aStream position. + (selector == #ifTrue:) ifTrue:[ + code at:pos1 put:here + ]. + code at:pos2 put:here. + aStream nextPut:#pushNil. + code at:pos3 put:(aStream position) + ] ifFalse:[ + here := aStream position. + (selector == #ifTrue:) ifTrue:[ + code at:pos1 put:here + ]. + code at:pos2 put:here + ] +! + +codeAndOrOn:aStream inBlock:b valueNeeded:valueNeeded for:aCompiler + "generate code for x and/or:[y] - but not in an if" + + |pos theReceiver theByteCode| + +self halt. + theReceiver := receiver. + (selector == #and:) ifTrue:[ + theByteCode := #falseJump + ] ifFalse:[ + theByteCode := #trueJump + ]. +" + (self canOptimizeConditionFor:receiver) ifTrue:[ + theByteCode := self optimizedConditionFor:theReceiver + with:theByteCode. + theReceiver := theReceiver receiver + ]. +" + theReceiver codeOn:aStream inBlock:b for:aCompiler. + aStream nextPut:theByteCode. + pos := aStream position. + aStream nextPut:0. + (argArray at: 1) codeInlineOn:aStream inBlock:b for:aCompiler. + (aStream contents) at:pos put:(aStream position). + valueNeeded ifFalse:[aStream nextPut:#drop] +! + +codeForCascadeOn:aStream inBlock:b for:aCompiler + "like codeOn, but always leave the receiver instead of the result" + + |nargs isBuiltIn code litIndex| + + argArray isNil ifTrue:[ + nargs := 0 + ] ifFalse:[ + nargs := argArray size + ]. + + isBuiltIn := false. - (aStream contents) at:pos2 put:(aStream position). - aStream nextPut:#drop. + (nargs == 0) ifTrue:[ + isBuiltIn := self class isBuiltInUnarySelector:selector + ]. + (nargs == 1) ifTrue:[ + isBuiltIn := self class isBuiltIn1ArgSelector:selector + ]. + (nargs == 2) ifTrue:[ + isBuiltIn := self class isBuiltIn2ArgSelector:selector + ]. + + receiver codeOn:aStream inBlock:b for:aCompiler. + aStream nextPut:#dup. + + "can we use a send-bytecode ?" + isBuiltIn ifTrue:[ + receiver isSuper ifFalse:[ + (nargs > 0) ifTrue:[ + (argArray at:1) codeOn:aStream inBlock:b for:aCompiler. + (nargs > 1) ifTrue:[ + (argArray at:2) codeOn:aStream inBlock:b for:aCompiler + ] + ]. + aStream nextPut:selector. + (self class hasLineNumber:selector) ifTrue:[ + aStream nextPut:lineNr. + ]. + aStream nextPut:#drop. + ^ self + ] + ]. + + "no - generate a send" + argArray notNil ifTrue:[ + argArray do:[:arg | + arg codeOn:aStream inBlock:b for:aCompiler + ] + ]. + litIndex := aCompiler addLiteral:selector. + litIndex <= 255 ifTrue:[ + receiver isSuper ifTrue:[ + receiver isHere ifTrue:[ + code := #hereSend + ] ifFalse:[ + code := #superSend. + ]. + aStream nextPut:code; nextPut:lineNr; nextPut:litIndex; nextPut:nargs; nextPut:nil; nextPut:#drop. + ^ self + ]. + (nargs <= 3) ifTrue:[ + code := #(sendDrop0 sendDrop1 sendDrop2 sendDrop3) at:(nargs+1). + aStream nextPut:code; nextPut:lineNr; nextPut:litIndex. + ^ self + ]. + + aStream nextPut:#sendDrop; nextPut:lineNr; nextPut:litIndex; nextPut:nargs. + ^ self + ]. + "need 16bit litIndex" + receiver isSuper ifTrue:[ + receiver isHere ifTrue:[ + code := #hereSendL + ] ifFalse:[ + code := #superSendL. + ]. + aStream nextPut:code; nextPut:lineNr; nextPut:litIndex; nextPut:0; nextPut:nargs; nextPut:nil; nextPut:#drop. + ^ self + ]. + aStream nextPut:#sendDropL; nextPut:lineNr; nextPut:litIndex; nextPut:0; nextPut:nargs +! + +codeForSideEffectOn:aStream inBlock:b for:aCompiler + self codeOn:aStream inBlock:b valueNeeded:false for:aCompiler ! codeIfElseOn:aStream inBlock:b valueNeeded:valueNeeded for:aCompiler @@ -915,183 +746,8 @@ ] ! -codeAndIfOn:aStream inBlock:b valueNeeded:valueNeeded for:aCompiler - "generate code for (x and:[y]) ifxxx:[ ... ]" - - |theByteCode optByteCode theReceiver theArg pos1 pos2 pos3 code here jmp| - - - theByteCode := #falseJump. - theReceiver := receiver receiver. - - optByteCode := self optimizedConditionFor:theReceiver - with:theByteCode. - optByteCode notNil ifTrue:[ - ((optByteCode == #eqJump) or:[optByteCode == #notEqJump]) ifTrue:[ - theArg := theReceiver arg1 - ]. - theReceiver := theReceiver receiver. - theByteCode := optByteCode - ]. - theReceiver codeOn:aStream inBlock:b for:aCompiler. - theArg notNil ifTrue:[ - theArg codeOn:aStream inBlock:b for:aCompiler - ]. - aStream nextPut:theByteCode. - pos1 := aStream position. - aStream nextPut:0. - - theReceiver := receiver arg1. - theReceiver codeInlineOn:aStream inBlock:b for:aCompiler. - (selector == #ifTrue:) ifTrue:[ - jmp := #falseJump - ] ifFalse:[ - jmp := #trueJump - ]. - aStream nextPut:jmp. - pos2 := aStream position. - aStream nextPut:0. - - code := aStream contents. - (selector == #ifFalse:) ifTrue:[ - code at:pos1 put:(aStream position) - ]. - (argArray at: 1) codeInlineOn:aStream inBlock:b valueNeeded:valueNeeded for:aCompiler. - - valueNeeded ifTrue:[ - aStream nextPut:#jump. - pos3 := aStream position. - aStream nextPut:0. - here := aStream position. - (selector == #ifTrue:) ifTrue:[ - code at:pos1 put:here - ]. - code at:pos2 put:here. - aStream nextPut:#pushNil. - code at:pos3 put:(aStream position) - ] ifFalse:[ - here := aStream position. - (selector == #ifTrue:) ifTrue:[ - code at:pos1 put:here - ]. - code at:pos2 put:here - ] -! - -codeOrIfOn:aStream inBlock:b valueNeeded:valueNeeded for:aCompiler - "generate code for (x or:[y]) ifxxx:[ ... ]" - - |theByteCode optByteCode theReceiver theArg pos1 pos2 pos3 code here jmp| - - theByteCode := #trueJump. - theReceiver := receiver receiver. - - optByteCode := self optimizedConditionFor:theReceiver with:theByteCode. - optByteCode notNil ifTrue:[ - ((optByteCode == #eqJump) or:[optByteCode == #notEqJump]) ifTrue:[ - theArg := theReceiver arg1 - ]. - theReceiver := theReceiver receiver. - theByteCode := optByteCode - ]. - theReceiver codeOn:aStream inBlock:b for:aCompiler. - theArg notNil ifTrue:[ - theArg codeOn:aStream inBlock:b for:aCompiler - ]. - aStream nextPut:theByteCode. - pos1 := aStream position. - aStream nextPut:0. - - - theReceiver := receiver arg1. - -"new:" - (selector == #ifTrue:) ifTrue:[ - theByteCode := #falseJump - ] ifFalse:[ - theByteCode := #trueJump - ]. - optByteCode := self optimizedConditionFor:theReceiver with:theByteCode. - optByteCode notNil ifTrue:[ - theReceiver isBlock ifTrue:[ - theReceiver := theReceiver statements expression - ]. - ((optByteCode == #eqJump) or:[optByteCode == #notEqJump]) ifTrue:[ - theArg := theReceiver arg1 - ]. - theReceiver := theReceiver receiver. - theByteCode := optByteCode. - - theReceiver codeOn:aStream inBlock:b for:aCompiler. - theArg notNil ifTrue:[ - theArg codeOn:aStream inBlock:b for:aCompiler - ]. - aStream nextPut:theByteCode. - - ] ifFalse:[ -"org" - theReceiver codeInlineOn:aStream inBlock:b for:aCompiler. - (selector == #ifTrue:) ifTrue:[ - jmp := #falseJump - ] ifFalse:[ - jmp := #trueJump - ]. - aStream nextPut:jmp - ]. - pos2 := aStream position. - aStream nextPut:0. - (selector == #ifTrue:) ifTrue:[ - (aStream contents) at:pos1 put:(aStream position) - ]. - (argArray at: 1) codeInlineOn:aStream inBlock:b valueNeeded:valueNeeded for:aCompiler. - - code := aStream contents. - valueNeeded ifTrue:[ - aStream nextPut:#jump. - pos3 := aStream position. - aStream nextPut:0. - here := aStream position. - (selector == #ifFalse:) ifTrue:[ - code at:pos1 put:here - ]. - code at:pos2 put:here. - aStream nextPut:#pushNil. - code at:pos3 put:(aStream position) - ] ifFalse:[ - here := aStream position. - (selector == #ifFalse:) ifTrue:[ - code at:pos1 put:here - ]. - code at:pos2 put:here - ] -! - -codeAndOrOn:aStream inBlock:b valueNeeded:valueNeeded for:aCompiler - "generate code for x and/or:[y] - but not in an if" - - |pos theReceiver theByteCode| - -self halt. - theReceiver := receiver. - (selector == #and:) ifTrue:[ - theByteCode := #falseJump - ] ifFalse:[ - theByteCode := #trueJump - ]. -" - (self canOptimizeConditionFor:receiver) ifTrue:[ - theByteCode := self optimizedConditionFor:theReceiver - with:theByteCode. - theReceiver := theReceiver receiver - ]. -" - theReceiver codeOn:aStream inBlock:b for:aCompiler. - aStream nextPut:theByteCode. - pos := aStream position. - aStream nextPut:0. - (argArray at: 1) codeInlineOn:aStream inBlock:b for:aCompiler. - (aStream contents) at:pos put:(aStream position). - valueNeeded ifFalse:[aStream nextPut:#drop] +codeOn:aStream inBlock:b for:aCompiler + self codeOn:aStream inBlock:b valueNeeded:true for:aCompiler ! codeOn:aStream inBlock:b valueNeeded:valueNeeded for:aCompiler @@ -1328,6 +984,94 @@ "Modified: 3.9.1995 / 12:55:42 / claus" ! +codeOrIfOn:aStream inBlock:b valueNeeded:valueNeeded for:aCompiler + "generate code for (x or:[y]) ifxxx:[ ... ]" + + |theByteCode optByteCode theReceiver theArg pos1 pos2 pos3 code here jmp| + + theByteCode := #trueJump. + theReceiver := receiver receiver. + + optByteCode := self optimizedConditionFor:theReceiver with:theByteCode. + optByteCode notNil ifTrue:[ + ((optByteCode == #eqJump) or:[optByteCode == #notEqJump]) ifTrue:[ + theArg := theReceiver arg1 + ]. + theReceiver := theReceiver receiver. + theByteCode := optByteCode + ]. + theReceiver codeOn:aStream inBlock:b for:aCompiler. + theArg notNil ifTrue:[ + theArg codeOn:aStream inBlock:b for:aCompiler + ]. + aStream nextPut:theByteCode. + pos1 := aStream position. + aStream nextPut:0. + + + theReceiver := receiver arg1. + +"new:" + (selector == #ifTrue:) ifTrue:[ + theByteCode := #falseJump + ] ifFalse:[ + theByteCode := #trueJump + ]. + optByteCode := self optimizedConditionFor:theReceiver with:theByteCode. + optByteCode notNil ifTrue:[ + theReceiver isBlock ifTrue:[ + theReceiver := theReceiver statements expression + ]. + ((optByteCode == #eqJump) or:[optByteCode == #notEqJump]) ifTrue:[ + theArg := theReceiver arg1 + ]. + theReceiver := theReceiver receiver. + theByteCode := optByteCode. + + theReceiver codeOn:aStream inBlock:b for:aCompiler. + theArg notNil ifTrue:[ + theArg codeOn:aStream inBlock:b for:aCompiler + ]. + aStream nextPut:theByteCode. + + ] ifFalse:[ +"org" + theReceiver codeInlineOn:aStream inBlock:b for:aCompiler. + (selector == #ifTrue:) ifTrue:[ + jmp := #falseJump + ] ifFalse:[ + jmp := #trueJump + ]. + aStream nextPut:jmp + ]. + pos2 := aStream position. + aStream nextPut:0. + (selector == #ifTrue:) ifTrue:[ + (aStream contents) at:pos1 put:(aStream position) + ]. + (argArray at: 1) codeInlineOn:aStream inBlock:b valueNeeded:valueNeeded for:aCompiler. + + code := aStream contents. + valueNeeded ifTrue:[ + aStream nextPut:#jump. + pos3 := aStream position. + aStream nextPut:0. + here := aStream position. + (selector == #ifFalse:) ifTrue:[ + code at:pos1 put:here + ]. + code at:pos2 put:here. + aStream nextPut:#pushNil. + code at:pos3 put:(aStream position) + ] ifFalse:[ + here := aStream position. + (selector == #ifFalse:) ifTrue:[ + code at:pos1 put:here + ]. + code at:pos2 put:here + ] +! + codeSendOn:aStream inBlock:b valueNeeded:valueNeeded for:aCompiler "like code on, but assumes that receiver has already been coded onto stack - needed for cascade" @@ -1441,85 +1185,342 @@ aStream nextPut:code; nextPut:lineNr; nextPut:litIndex; nextPut:0; nextPut:nargs ! -codeForCascadeOn:aStream inBlock:b for:aCompiler - "like codeOn, but always leave the receiver instead of the result" +codeTimesRepeatOn:aStream inBlock:b valueNeeded:valueNeeded for:aCompiler + "generate code for n timesRepeat:[ ... ]" + + |pos pos2 theReceiver| + + theReceiver := receiver. + theReceiver codeOn:aStream inBlock:b for:aCompiler. + valueNeeded ifTrue:[aStream nextPut:#dup]. - |nargs isBuiltIn code litIndex| + pos := aStream position. +"/ aStream nextPut:#dup; nextPut:#push0; nextPut:#>; nextPut:lineNr; nextPut:#falseJump. +"/ aStream nextPut:#dup; nextPut:#gt0; nextPut:lineNr; nextPut:#falseJump. + aStream nextPut:#pushgt0; nextPut:lineNr; nextPut:#falseJump. + pos2 := aStream position. + aStream nextPut:0. + + (argArray at:1) codeInlineOn:aStream inBlock:b valueNeeded:false for:aCompiler. + aStream nextPut:#minus1; nextPut:lineNr; nextPut:#jump; nextPut:pos. + + (aStream contents) at:pos2 put:(aStream position). + aStream nextPut:#drop. +! + +codeWhileOn:aStream inBlock:b valueNeeded:valueNeeded for:aCompiler + "generate code for [...] whilexxx:[ ... ]" + + |pos pos2 theReceiver theArg theByteCode optByteCode| - argArray isNil ifTrue:[ - nargs := 0 + (selector == #whileTrue:) ifTrue:[ + theByteCode := #falseJump ] ifFalse:[ - nargs := argArray size + theByteCode := #trueJump + ]. + + theReceiver := receiver. + optByteCode := self optimizedConditionFor:theReceiver with:theByteCode. + optByteCode notNil ifTrue:[ + ((optByteCode == #eqJump) or:[optByteCode == #notEqJump]) ifTrue:[ + theArg := receiver statements expression arg1 + ]. + theReceiver := receiver statements expression receiver. + theByteCode := optByteCode + ]. + +"/ OLD: +"/ valueNeeded ifTrue:[aStream nextPut:#pushNil]. +"/ + pos := aStream position. + optByteCode notNil ifTrue:[ + theReceiver codeOn:aStream inBlock:b for:aCompiler. + theArg notNil ifTrue:[ + theArg codeOn:aStream inBlock:b for:aCompiler + ] + ] ifFalse:[ + theReceiver codeInlineOn:aStream inBlock:b for:aCompiler + ]. + + (lineNr between:1 and:255) ifTrue:[ + aStream nextPut:#lineno; nextPut:lineNr. ]. - isBuiltIn := false. + aStream nextPut:theByteCode. + pos2 := aStream position. + aStream nextPut:0. +"/ OLD: +"/ valueNeeded ifTrue:[aStream nextPut:#drop]. +"/ +"/ OLD: +"/ (argArray at:1) codeInlineOn:aStream inBlock:b valueNeeded:valueNeeded for:aCompiler. +"/ NEW: + (argArray at:1) codeInlineOn:aStream inBlock:b valueNeeded:false for:aCompiler. + aStream nextPut:#jump; nextPut:pos. + (aStream contents) at:pos2 put:(aStream position). +"/ NEW: + valueNeeded ifTrue:[aStream nextPut:#pushNil]. +! + +optimizedConditionFor:aReceiver with:aByteCode + |rec sel| - (nargs == 0) ifTrue:[ - isBuiltIn := self class isBuiltInUnarySelector:selector + rec := aReceiver. + (rec isBlock) ifTrue:[ + rec statements nextStatement isNil ifTrue:[ + rec := rec statements expression + ] + ]. + (rec isUnaryMessage) ifTrue:[ + sel := rec selector. + (sel == #isNil) ifTrue:[ + "/ + "/ isNil trueJmp -> nilJump + "/ isNil falseJmp -> notNilJump + "/ + (aByteCode == #trueJump) ifTrue:[^ #nilJump]. + (aByteCode == #falseJump) ifTrue:[^ #notNilJump] + ]. + (sel == #notNil) ifTrue:[ + "/ + "/ notNil trueJmp -> notNilJump + "/ notNil falseJmp -> nilJump + "/ + (aByteCode == #trueJump) ifTrue:[^ #notNilJump]. + (aByteCode == #falseJump) ifTrue:[^ #nilJump] + ]. + (sel == #not) ifTrue:[ + "/ + "/ not trueJmp -> falseJump + "/ not falseJmp -> trueJump + "/ + (aByteCode == #trueJump) ifTrue:[^ #falseJump]. + (aByteCode == #falseJump) ifTrue:[^ #trueJump] + ]. + ^ nil ]. + (rec isBinaryMessage) ifTrue:[ + sel := rec selector. + rec arg1 isConstant ifTrue:[ + (rec arg1 value == 0) ifTrue:[ + "/ + "/ ==0 trueJmp -> zeroJump + "/ ==0 falseJmp -> notZeroJump + "/ + (sel == #==) ifTrue:[ + (aByteCode == #trueJump) ifTrue:[^ #zeroJump]. + (aByteCode == #falseJump) ifTrue:[^ #notZeroJump] + ]. + "/ + "/ ~~0 trueJmp -> notZeroJump + "/ ~~0 falseJmp -> zeroJump + "/ + (sel == #~~) ifTrue:[ + (aByteCode == #falseJump) ifTrue:[^ #zeroJump]. + (aByteCode == #trueJump) ifTrue:[^ #notZeroJump] + ]. + ^ nil + ] + ]. + (sel == #==) ifTrue:[ + "/ + "/ == trueJmp -> eqJump + "/ == falseJmp -> notEqJump + "/ + (aByteCode == #trueJump) ifTrue:[^ #eqJump]. + (aByteCode == #falseJump) ifTrue:[^ #notEqJump] + ]. + (sel == #~~) ifTrue:[ + "/ + "/ ~~ trueJmp -> notEqJump + "/ ~~ falseJmp -> eqJump + "/ + (aByteCode == #falseJump) ifTrue:[^ #eqJump]. + (aByteCode == #trueJump) ifTrue:[^ #notEqJump] + ] + ]. + ^ nil +! ! + +!MessageNode methodsFor:'evaluating'! + +evaluate + |r nargs argValueArray class| + + receiver isSuper ifTrue:[ + r := receiver value. + receiver isHere ifTrue:[ + class := receiver definingClass. + ] ifFalse:[ + class := receiver definingClass superclass. + ]. + argArray notNil ifTrue:[ + argValueArray := argArray collect:[:arg | arg evaluate]. + ] ifFalse:[ + argValueArray := #() + ]. + ^ r perform:selector inClass:class withArguments:argValueArray + ]. + + + argArray isNil ifTrue:[ + ^ (receiver evaluate) perform:selector + ]. + nargs := argArray size. (nargs == 1) ifTrue:[ - isBuiltIn := self class isBuiltIn1ArgSelector:selector + ^ (receiver evaluate) perform:selector with:(argArray at:1) evaluate ]. (nargs == 2) ifTrue:[ - isBuiltIn := self class isBuiltIn2ArgSelector:selector + ^ (receiver evaluate) perform:selector + with:(argArray at:1) evaluate + with:(argArray at:2) evaluate + ]. + (nargs == 3) ifTrue:[ + ^ (receiver evaluate) perform:selector + with:(argArray at:1) evaluate + with:(argArray at:2) evaluate + with:(argArray at:3) evaluate + ]. + r := receiver evaluate. + argValueArray := argArray collect:[:arg | arg evaluate]. + ^ r perform:selector withArguments:argValueArray +! + +evaluateForCascade + |r nargs argValueArray class| + + receiver isSuper ifTrue:[ + r := receiver value. + class := receiver definingClass. + receiver isHere ifFalse:[ + class := class superclass. + ]. + argArray notNil ifTrue:[ + argValueArray := argArray collect:[:arg | arg evaluate]. + ] ifFalse:[ + argValueArray := #() + ]. + r perform:selector inClass:class withArguments:argValueArray. + ^ r ]. - receiver codeOn:aStream inBlock:b for:aCompiler. - aStream nextPut:#dup. + r := receiver evaluate. + argArray isNil ifTrue:[ + r perform:selector. + ^ r + ]. + nargs := argArray size. + (nargs == 1) ifTrue:[ + r perform:selector with:(argArray at:1) evaluate. + ^ r + ]. + (nargs == 2) ifTrue:[ + r perform:selector with:(argArray at:1) evaluate + with:(argArray at:2) evaluate. + ^ r + ]. + (nargs == 3) ifTrue:[ + r perform:selector with:(argArray at:1) evaluate + with:(argArray at:2) evaluate + with:(argArray at:3) evaluate. + ^ r + ]. + argValueArray := argArray collect:[:arg | arg evaluate]. + r perform:selector withArguments:argValueArray. + ^ r +! ! + +!MessageNode methodsFor:'printing'! + +printOn:aStream indent:i + |needParen selectorParts index index2 arg| + + (#(whileTrue: whileFalse:) includes:selector) ifTrue:[ + receiver isBlock ifTrue:[ + ^ self printWhileOn:aStream indent:i + ]. + ]. - "can we use a send-bytecode ?" - isBuiltIn ifTrue:[ - receiver isSuper ifFalse:[ - (nargs > 0) ifTrue:[ - (argArray at:1) codeOn:aStream inBlock:b for:aCompiler. - (nargs > 1) ifTrue:[ - (argArray at:2) codeOn:aStream inBlock:b for:aCompiler + index := 1. + selectorParts := OrderedCollection new. + [index == 0] whileFalse:[ + index2 := selector indexOf:$: startingAt:index. + index2 ~~ 0 ifTrue:[ + selectorParts add:(selector copyFrom:index to:index2). + index2 := index2 + 1 + ]. + index := index2 + ]. + + needParen := false. + receiver isMessage ifTrue:[ + receiver isUnaryMessage ifFalse:[ + receiver isBinaryMessage ifFalse:[ + needParen := true + ]. + ]. + ]. + needParen ifTrue:[ + aStream nextPutAll:'(' + ]. + receiver printOn:aStream indent:i. + needParen ifTrue:[ + aStream nextPutAll:')' + ]. + + 1 to:(argArray size) do:[:argIndex | + aStream space. + (selectorParts at:argIndex) printOn:aStream. + aStream space. + arg := argArray at:argIndex. + needParen := false. + arg isMessage ifTrue:[ + arg isBinaryMessage ifFalse:[ + arg isUnaryMessage ifFalse:[ + needParen := true ] ]. - aStream nextPut:selector. - (self class hasLineNumber:selector) ifTrue:[ - aStream nextPut:lineNr. - ]. - aStream nextPut:#drop. - ^ self - ] - ]. + ]. + needParen ifTrue:[ + aStream nextPutAll:'(' + ]. + arg printOn:aStream indent:i. + needParen ifTrue:[ + aStream nextPutAll:') ' + ]. + ] +! + +printWhileOn:aStream indent:i + |needParen arg| - "no - generate a send" - argArray notNil ifTrue:[ - argArray do:[:arg | - arg codeOn:aStream inBlock:b for:aCompiler - ] + "special handling of whileTrue/whileFalse" + + aStream nextPutAll:'['. + receiver statements printOn:aStream indent:i. + aStream nextPutAll:'] whileTrue: '. + + arg := argArray at:1. + needParen := false. + arg isMessage ifTrue:[ + arg isBinaryMessage ifFalse:[ + arg isUnaryMessage ifFalse:[ + needParen := true + ] + ]. ]. - litIndex := aCompiler addLiteral:selector. - litIndex <= 255 ifTrue:[ - receiver isSuper ifTrue:[ - receiver isHere ifTrue:[ - code := #hereSend - ] ifFalse:[ - code := #superSend. - ]. - aStream nextPut:code; nextPut:lineNr; nextPut:litIndex; nextPut:nargs; nextPut:nil; nextPut:#drop. - ^ self - ]. - (nargs <= 3) ifTrue:[ - code := #(sendDrop0 sendDrop1 sendDrop2 sendDrop3) at:(nargs+1). - aStream nextPut:code; nextPut:lineNr; nextPut:litIndex. - ^ self - ]. + needParen ifTrue:[ + aStream nextPutAll:'(' + ]. + arg printOn:aStream indent:i. + needParen ifTrue:[ + aStream nextPutAll:') ' + ]. +! ! - aStream nextPut:#sendDrop; nextPut:lineNr; nextPut:litIndex; nextPut:nargs. - ^ self - ]. - "need 16bit litIndex" - receiver isSuper ifTrue:[ - receiver isHere ifTrue:[ - code := #hereSendL - ] ifFalse:[ - code := #superSendL. - ]. - aStream nextPut:code; nextPut:lineNr; nextPut:litIndex; nextPut:0; nextPut:nargs; nextPut:nil; nextPut:#drop. - ^ self - ]. - aStream nextPut:#sendDropL; nextPut:lineNr; nextPut:litIndex; nextPut:0; nextPut:nargs +!MessageNode methodsFor:'queries'! + +isMessage + ^ true ! ! + diff -r 65eaf1a009f5 -r 1ef1d1395146 MessageNode.st --- a/MessageNode.st Sat Nov 18 17:59:14 1995 +0100 +++ b/MessageNode.st Thu Nov 23 03:15:59 1995 +0100 @@ -11,10 +11,10 @@ " ParseNode subclass:#MessageNode - instanceVariableNames:'receiver selector argArray lineNr' - classVariableNames:'' - poolDictionaries:'' - category:'System-Compiler-Support' + instanceVariableNames:'receiver selector argArray lineNr' + classVariableNames:'' + poolDictionaries:'' + category:'System-Compiler-Support' ! !MessageNode class methodsFor:'documentation'! @@ -33,14 +33,14 @@ " ! -version - ^ '$Header: /cvs/stx/stx/libcomp/MessageNode.st,v 1.31 1995-11-11 15:30:33 cg Exp $' -! - documentation " node for parse-trees, representing message sends " +! + +version + ^ '$Header: /cvs/stx/stx/libcomp/MessageNode.st,v 1.32 1995-11-23 02:13:47 cg Exp $' ! ! !MessageNode class methodsFor:'instance creation'! @@ -49,6 +49,52 @@ ^ (self basicNew) receiver:recNode selector:selectorString args:nil lineno:0 ! +receiver:recNode selector:selectorString arg1:argNode1 arg2:argNode2 fold:folding + |result recVal argVal selector| + + " + This is just a demonstration - of how complex constants can be folded. + This was inspired by some discussion in c.l.s about enhancing the language - I prefer + enhancing the compiler .... + The following optimization will convert '#(...) with:#(...) collect:[...]' into an array constant, + allowing a constant arrays of complex objects. + + Notice: this method is normally disabled - its just a demo after all. + " + folding ifTrue:[ + "do constant folding ..." + (recNode isConstant and:[argNode1 isConstant]) ifTrue:[ + "check if we can do it ..." + selector := selectorString asSymbolIfInterned. + selector notNil ifTrue:[ + recVal := recNode evaluate. + (recVal respondsTo:selector) ifTrue:[ + " + we could do much more here - but then, we need a dependency from + the folded selectors method to the method we generate code for ... + limit optimizations to those that will never change + (or - if you change them - you will crash so bad ...) + " + argVal := argNode1 evaluate. + ((recVal isMemberOf:Array) and:[argVal isMemberOf:Array]) ifTrue:[ + (selector == #with:collect:) ifTrue:[ + (argNode2 isMemberOf:BlockNode) ifTrue:[ + (SignalSet anySignal catch:[ + result := recVal perform:selector with:argVal with:(argNode2 evaluate). + ]) ifTrue:[ + ^ 'error in constant expression' + ]. + ^ ConstantNode type:(ConstantNode typeOfConstant:result) value:result + ] + ] + ] + ] + ] + ] + ]. + ^ (self basicNew) receiver:recNode selector:selectorString args:(Array with:argNode1 with:argNode2) lineno:0 +! + receiver:recNode selector:selectorString arg:argNode ^ self receiver:recNode selector:selectorString arg:argNode fold:true ! @@ -132,52 +178,6 @@ ^ (self basicNew) receiver:recNode selector:selectorString args:(Array with:argNode) lineno:0 ! -receiver:recNode selector:selectorString arg1:argNode1 arg2:argNode2 fold:folding - |result recVal argVal selector| - - " - This is just a demonstration - of how complex constants can be folded. - This was inspired by some discussion in c.l.s about enhancing the language - I prefer - enhancing the compiler .... - The following optimization will convert '#(...) with:#(...) collect:[...]' into an array constant, - allowing a constant arrays of complex objects. - - Notice: this method is normally disabled - its just a demo after all. - " - folding ifTrue:[ - "do constant folding ..." - (recNode isConstant and:[argNode1 isConstant]) ifTrue:[ - "check if we can do it ..." - selector := selectorString asSymbolIfInterned. - selector notNil ifTrue:[ - recVal := recNode evaluate. - (recVal respondsTo:selector) ifTrue:[ - " - we could do much more here - but then, we need a dependency from - the folded selectors method to the method we generate code for ... - limit optimizations to those that will never change - (or - if you change them - you will crash so bad ...) - " - argVal := argNode1 evaluate. - ((recVal isMemberOf:Array) and:[argVal isMemberOf:Array]) ifTrue:[ - (selector == #with:collect:) ifTrue:[ - (argNode2 isMemberOf:BlockNode) ifTrue:[ - (SignalSet anySignal catch:[ - result := recVal perform:selector with:argVal with:(argNode2 evaluate). - ]) ifTrue:[ - ^ 'error in constant expression' - ]. - ^ ConstantNode type:(ConstantNode typeOfConstant:result) value:result - ] - ] - ] - ] - ] - ] - ]. - ^ (self basicNew) receiver:recNode selector:selectorString args:(Array with:argNode1 with:argNode2) lineno:0 -! - receiver:recNode selector:selectorString args:anArray ^ self receiver:recNode selector:selectorString args:anArray fold:true ! @@ -205,45 +205,6 @@ "Modified: 3.9.1995 / 16:41:39 / claus" ! ! -!MessageNode methodsFor:'accessing'! - -receiver:r selector:s args:a lineno:l - receiver := r. - selector := s asSymbol. - argArray := a. - lineNr := l -! - -receiver - ^ receiver -! - -selector - ^ selector -! - -args - ^ argArray -! - -arg1 - ^ argArray at:1 -! - -lineNumber - ^ lineNr -! - -lineNumber:num - lineNr := num -! ! - -!MessageNode methodsFor:'queries'! - -isMessage - ^ true -! ! - !MessageNode class methodsFor:'queries'! hasLineNumber:sel @@ -257,6 +218,27 @@ ^ true ! +isBuiltIn1ArgSelector:sel + "return true, if selector sel is built-in. + (i.e. there is a single bytecode for it)" + + (sel == #at:) ifTrue:[^ true]. + (sel == #value:) ifTrue:[^ true]. + (sel == #bitAnd:) ifTrue:[^ true]. + (sel == #bitOr:) ifTrue:[^ true]. + (sel == #new:) ifTrue:[^ true]. + (sel == #basicNew:) ifTrue:[^ true]. + ^ false +! + +isBuiltIn2ArgSelector:sel + "return true, if selector sel is built-in. + (i.e. there is a single bytecode for it)" + + (sel == #at:put:) ifTrue:[^ true]. + ^ false +! + isBuiltInUnarySelector:sel "return true, if unary selector sel is built-in. (i.e. there is a single bytecode for it)" @@ -280,115 +262,39 @@ (sel == #new) ifTrue:[^ true]. (sel == #basicNew) ifTrue:[^ true]. ^ false -! - -isBuiltIn1ArgSelector:sel - "return true, if selector sel is built-in. - (i.e. there is a single bytecode for it)" - - (sel == #at:) ifTrue:[^ true]. - (sel == #value:) ifTrue:[^ true]. - (sel == #bitAnd:) ifTrue:[^ true]. - (sel == #bitOr:) ifTrue:[^ true]. - (sel == #new:) ifTrue:[^ true]. - (sel == #basicNew:) ifTrue:[^ true]. - ^ false -! - -isBuiltIn2ArgSelector:sel - "return true, if selector sel is built-in. - (i.e. there is a single bytecode for it)" - - (sel == #at:put:) ifTrue:[^ true]. - ^ false ! ! -!MessageNode methodsFor:'printing'! - -printOn:aStream indent:i - |needParen selectorParts index index2 arg| - - (#(whileTrue: whileFalse:) includes:selector) ifTrue:[ - receiver isBlock ifTrue:[ - ^ self printWhileOn:aStream indent:i - ]. - ]. +!MessageNode methodsFor:'accessing'! - index := 1. - selectorParts := OrderedCollection new. - [index == 0] whileFalse:[ - index2 := selector indexOf:$: startingAt:index. - index2 ~~ 0 ifTrue:[ - selectorParts add:(selector copyFrom:index to:index2). - index2 := index2 + 1 - ]. - index := index2 - ]. +arg1 + ^ argArray at:1 +! - needParen := false. - receiver isMessage ifTrue:[ - receiver isUnaryMessage ifFalse:[ - receiver isBinaryMessage ifFalse:[ - needParen := true - ]. - ]. - ]. - needParen ifTrue:[ - aStream nextPutAll:'(' - ]. - receiver printOn:aStream indent:i. - needParen ifTrue:[ - aStream nextPutAll:')' - ]. +args + ^ argArray +! - 1 to:(argArray size) do:[:argIndex | - aStream space. - (selectorParts at:argIndex) printOn:aStream. - aStream space. - arg := argArray at:argIndex. - needParen := false. - arg isMessage ifTrue:[ - arg isBinaryMessage ifFalse:[ - arg isUnaryMessage ifFalse:[ - needParen := true - ] - ]. - ]. - needParen ifTrue:[ - aStream nextPutAll:'(' - ]. - arg printOn:aStream indent:i. - needParen ifTrue:[ - aStream nextPutAll:') ' - ]. - ] +lineNumber + ^ lineNr ! -printWhileOn:aStream indent:i - |needParen arg| +lineNumber:num + lineNr := num +! - "special handling of whileTrue/whileFalse" - - aStream nextPutAll:'['. - receiver statements printOn:aStream indent:i. - aStream nextPutAll:'] whileTrue: '. +receiver + ^ receiver +! - arg := argArray at:1. - needParen := false. - arg isMessage ifTrue:[ - arg isBinaryMessage ifFalse:[ - arg isUnaryMessage ifFalse:[ - needParen := true - ] - ]. - ]. - needParen ifTrue:[ - aStream nextPutAll:'(' - ]. - arg printOn:aStream indent:i. - needParen ifTrue:[ - aStream nextPutAll:') ' - ]. +receiver:r selector:s args:a lineno:l + receiver := r. + selector := s asSymbol. + argArray := a. + lineNr := l +! + +selector + ^ selector ! ! !MessageNode methodsFor:'checks'! @@ -481,238 +387,8 @@ ^ nil ! ! -!MessageNode methodsFor:'evaluating'! - -evaluate - |r nargs argValueArray class| - - receiver isSuper ifTrue:[ - r := receiver value. - receiver isHere ifTrue:[ - class := receiver definingClass. - ] ifFalse:[ - class := receiver definingClass superclass. - ]. - argArray notNil ifTrue:[ - argValueArray := argArray collect:[:arg | arg evaluate]. - ] ifFalse:[ - argValueArray := #() - ]. - ^ r perform:selector inClass:class withArguments:argValueArray - ]. - - - argArray isNil ifTrue:[ - ^ (receiver evaluate) perform:selector - ]. - nargs := argArray size. - (nargs == 1) ifTrue:[ - ^ (receiver evaluate) perform:selector with:(argArray at:1) evaluate - ]. - (nargs == 2) ifTrue:[ - ^ (receiver evaluate) perform:selector - with:(argArray at:1) evaluate - with:(argArray at:2) evaluate - ]. - (nargs == 3) ifTrue:[ - ^ (receiver evaluate) perform:selector - with:(argArray at:1) evaluate - with:(argArray at:2) evaluate - with:(argArray at:3) evaluate - ]. - r := receiver evaluate. - argValueArray := argArray collect:[:arg | arg evaluate]. - ^ r perform:selector withArguments:argValueArray -! - -evaluateForCascade - |r nargs argValueArray class| - - receiver isSuper ifTrue:[ - r := receiver value. - class := receiver definingClass. - receiver isHere ifFalse:[ - class := class superclass. - ]. - argArray notNil ifTrue:[ - argValueArray := argArray collect:[:arg | arg evaluate]. - ] ifFalse:[ - argValueArray := #() - ]. - r perform:selector inClass:class withArguments:argValueArray. - ^ r - ]. - - r := receiver evaluate. - argArray isNil ifTrue:[ - r perform:selector. - ^ r - ]. - nargs := argArray size. - (nargs == 1) ifTrue:[ - r perform:selector with:(argArray at:1) evaluate. - ^ r - ]. - (nargs == 2) ifTrue:[ - r perform:selector with:(argArray at:1) evaluate - with:(argArray at:2) evaluate. - ^ r - ]. - (nargs == 3) ifTrue:[ - r perform:selector with:(argArray at:1) evaluate - with:(argArray at:2) evaluate - with:(argArray at:3) evaluate. - ^ r - ]. - argValueArray := argArray collect:[:arg | arg evaluate]. - r perform:selector withArguments:argValueArray. - ^ r -! ! - !MessageNode methodsFor:'code generation'! -codeForSideEffectOn:aStream inBlock:b for:aCompiler - self codeOn:aStream inBlock:b valueNeeded:false for:aCompiler -! - -codeOn:aStream inBlock:b for:aCompiler - self codeOn:aStream inBlock:b valueNeeded:true for:aCompiler -! - -optimizedConditionFor:aReceiver with:aByteCode - |rec sel| - - rec := aReceiver. - (rec isBlock) ifTrue:[ - rec statements nextStatement isNil ifTrue:[ - rec := rec statements expression - ] - ]. - (rec isUnaryMessage) ifTrue:[ - sel := rec selector. - (sel == #isNil) ifTrue:[ - "/ - "/ isNil trueJmp -> nilJump - "/ isNil falseJmp -> notNilJump - "/ - (aByteCode == #trueJump) ifTrue:[^ #nilJump]. - (aByteCode == #falseJump) ifTrue:[^ #notNilJump] - ]. - (sel == #notNil) ifTrue:[ - "/ - "/ notNil trueJmp -> notNilJump - "/ notNil falseJmp -> nilJump - "/ - (aByteCode == #trueJump) ifTrue:[^ #notNilJump]. - (aByteCode == #falseJump) ifTrue:[^ #nilJump] - ]. - (sel == #not) ifTrue:[ - "/ - "/ not trueJmp -> falseJump - "/ not falseJmp -> trueJump - "/ - (aByteCode == #trueJump) ifTrue:[^ #falseJump]. - (aByteCode == #falseJump) ifTrue:[^ #trueJump] - ]. - ^ nil - ]. - (rec isBinaryMessage) ifTrue:[ - sel := rec selector. - rec arg1 isConstant ifTrue:[ - (rec arg1 value == 0) ifTrue:[ - "/ - "/ ==0 trueJmp -> zeroJump - "/ ==0 falseJmp -> notZeroJump - "/ - (sel == #==) ifTrue:[ - (aByteCode == #trueJump) ifTrue:[^ #zeroJump]. - (aByteCode == #falseJump) ifTrue:[^ #notZeroJump] - ]. - "/ - "/ ~~0 trueJmp -> notZeroJump - "/ ~~0 falseJmp -> zeroJump - "/ - (sel == #~~) ifTrue:[ - (aByteCode == #falseJump) ifTrue:[^ #zeroJump]. - (aByteCode == #trueJump) ifTrue:[^ #notZeroJump] - ]. - ^ nil - ] - ]. - (sel == #==) ifTrue:[ - "/ - "/ == trueJmp -> eqJump - "/ == falseJmp -> notEqJump - "/ - (aByteCode == #trueJump) ifTrue:[^ #eqJump]. - (aByteCode == #falseJump) ifTrue:[^ #notEqJump] - ]. - (sel == #~~) ifTrue:[ - "/ - "/ ~~ trueJmp -> notEqJump - "/ ~~ falseJmp -> eqJump - "/ - (aByteCode == #falseJump) ifTrue:[^ #eqJump]. - (aByteCode == #trueJump) ifTrue:[^ #notEqJump] - ] - ]. - ^ nil -! - -codeWhileOn:aStream inBlock:b valueNeeded:valueNeeded for:aCompiler - "generate code for [...] whilexxx:[ ... ]" - - |pos pos2 theReceiver theArg theByteCode optByteCode| - - (selector == #whileTrue:) ifTrue:[ - theByteCode := #falseJump - ] ifFalse:[ - theByteCode := #trueJump - ]. - - theReceiver := receiver. - optByteCode := self optimizedConditionFor:theReceiver with:theByteCode. - optByteCode notNil ifTrue:[ - ((optByteCode == #eqJump) or:[optByteCode == #notEqJump]) ifTrue:[ - theArg := receiver statements expression arg1 - ]. - theReceiver := receiver statements expression receiver. - theByteCode := optByteCode - ]. - -"/ OLD: -"/ valueNeeded ifTrue:[aStream nextPut:#pushNil]. -"/ - pos := aStream position. - optByteCode notNil ifTrue:[ - theReceiver codeOn:aStream inBlock:b for:aCompiler. - theArg notNil ifTrue:[ - theArg codeOn:aStream inBlock:b for:aCompiler - ] - ] ifFalse:[ - theReceiver codeInlineOn:aStream inBlock:b for:aCompiler - ]. - - (lineNr between:1 and:255) ifTrue:[ - aStream nextPut:#lineno; nextPut:lineNr. - ]. - - aStream nextPut:theByteCode. - pos2 := aStream position. - aStream nextPut:0. -"/ OLD: -"/ valueNeeded ifTrue:[aStream nextPut:#drop]. -"/ -"/ OLD: -"/ (argArray at:1) codeInlineOn:aStream inBlock:b valueNeeded:valueNeeded for:aCompiler. -"/ NEW: - (argArray at:1) codeInlineOn:aStream inBlock:b valueNeeded:false for:aCompiler. - aStream nextPut:#jump; nextPut:pos. - (aStream contents) at:pos2 put:(aStream position). -"/ NEW: - valueNeeded ifTrue:[aStream nextPut:#pushNil]. -! - XXcodeWhileOn:aStream inBlock:b valueNeeded:valueNeeded for:aCompiler "generate code for [...] whilexxx:[ ... ]" @@ -758,27 +434,182 @@ (aStream contents) at:pos2 put:(aStream position). ! -codeTimesRepeatOn:aStream inBlock:b valueNeeded:valueNeeded for:aCompiler - "generate code for n timesRepeat:[ ... ]" +codeAndIfOn:aStream inBlock:b valueNeeded:valueNeeded for:aCompiler + "generate code for (x and:[y]) ifxxx:[ ... ]" + + |theByteCode optByteCode theReceiver theArg pos1 pos2 pos3 code here jmp| + + + theByteCode := #falseJump. + theReceiver := receiver receiver. - |pos pos2 theReceiver| - - theReceiver := receiver. + optByteCode := self optimizedConditionFor:theReceiver + with:theByteCode. + optByteCode notNil ifTrue:[ + ((optByteCode == #eqJump) or:[optByteCode == #notEqJump]) ifTrue:[ + theArg := theReceiver arg1 + ]. + theReceiver := theReceiver receiver. + theByteCode := optByteCode + ]. theReceiver codeOn:aStream inBlock:b for:aCompiler. - valueNeeded ifTrue:[aStream nextPut:#dup]. + theArg notNil ifTrue:[ + theArg codeOn:aStream inBlock:b for:aCompiler + ]. + aStream nextPut:theByteCode. + pos1 := aStream position. + aStream nextPut:0. - pos := aStream position. -"/ aStream nextPut:#dup; nextPut:#push0; nextPut:#>; nextPut:lineNr; nextPut:#falseJump. -"/ aStream nextPut:#dup; nextPut:#gt0; nextPut:lineNr; nextPut:#falseJump. - aStream nextPut:#pushgt0; nextPut:lineNr; nextPut:#falseJump. + theReceiver := receiver arg1. + theReceiver codeInlineOn:aStream inBlock:b for:aCompiler. + (selector == #ifTrue:) ifTrue:[ + jmp := #falseJump + ] ifFalse:[ + jmp := #trueJump + ]. + aStream nextPut:jmp. pos2 := aStream position. aStream nextPut:0. - (argArray at:1) codeInlineOn:aStream inBlock:b valueNeeded:false for:aCompiler. - aStream nextPut:#minus1; nextPut:lineNr; nextPut:#jump; nextPut:pos. + code := aStream contents. + (selector == #ifFalse:) ifTrue:[ + code at:pos1 put:(aStream position) + ]. + (argArray at: 1) codeInlineOn:aStream inBlock:b valueNeeded:valueNeeded for:aCompiler. + + valueNeeded ifTrue:[ + aStream nextPut:#jump. + pos3 := aStream position. + aStream nextPut:0. + here := aStream position. + (selector == #ifTrue:) ifTrue:[ + code at:pos1 put:here + ]. + code at:pos2 put:here. + aStream nextPut:#pushNil. + code at:pos3 put:(aStream position) + ] ifFalse:[ + here := aStream position. + (selector == #ifTrue:) ifTrue:[ + code at:pos1 put:here + ]. + code at:pos2 put:here + ] +! + +codeAndOrOn:aStream inBlock:b valueNeeded:valueNeeded for:aCompiler + "generate code for x and/or:[y] - but not in an if" + + |pos theReceiver theByteCode| + +self halt. + theReceiver := receiver. + (selector == #and:) ifTrue:[ + theByteCode := #falseJump + ] ifFalse:[ + theByteCode := #trueJump + ]. +" + (self canOptimizeConditionFor:receiver) ifTrue:[ + theByteCode := self optimizedConditionFor:theReceiver + with:theByteCode. + theReceiver := theReceiver receiver + ]. +" + theReceiver codeOn:aStream inBlock:b for:aCompiler. + aStream nextPut:theByteCode. + pos := aStream position. + aStream nextPut:0. + (argArray at: 1) codeInlineOn:aStream inBlock:b for:aCompiler. + (aStream contents) at:pos put:(aStream position). + valueNeeded ifFalse:[aStream nextPut:#drop] +! + +codeForCascadeOn:aStream inBlock:b for:aCompiler + "like codeOn, but always leave the receiver instead of the result" + + |nargs isBuiltIn code litIndex| + + argArray isNil ifTrue:[ + nargs := 0 + ] ifFalse:[ + nargs := argArray size + ]. + + isBuiltIn := false. - (aStream contents) at:pos2 put:(aStream position). - aStream nextPut:#drop. + (nargs == 0) ifTrue:[ + isBuiltIn := self class isBuiltInUnarySelector:selector + ]. + (nargs == 1) ifTrue:[ + isBuiltIn := self class isBuiltIn1ArgSelector:selector + ]. + (nargs == 2) ifTrue:[ + isBuiltIn := self class isBuiltIn2ArgSelector:selector + ]. + + receiver codeOn:aStream inBlock:b for:aCompiler. + aStream nextPut:#dup. + + "can we use a send-bytecode ?" + isBuiltIn ifTrue:[ + receiver isSuper ifFalse:[ + (nargs > 0) ifTrue:[ + (argArray at:1) codeOn:aStream inBlock:b for:aCompiler. + (nargs > 1) ifTrue:[ + (argArray at:2) codeOn:aStream inBlock:b for:aCompiler + ] + ]. + aStream nextPut:selector. + (self class hasLineNumber:selector) ifTrue:[ + aStream nextPut:lineNr. + ]. + aStream nextPut:#drop. + ^ self + ] + ]. + + "no - generate a send" + argArray notNil ifTrue:[ + argArray do:[:arg | + arg codeOn:aStream inBlock:b for:aCompiler + ] + ]. + litIndex := aCompiler addLiteral:selector. + litIndex <= 255 ifTrue:[ + receiver isSuper ifTrue:[ + receiver isHere ifTrue:[ + code := #hereSend + ] ifFalse:[ + code := #superSend. + ]. + aStream nextPut:code; nextPut:lineNr; nextPut:litIndex; nextPut:nargs; nextPut:nil; nextPut:#drop. + ^ self + ]. + (nargs <= 3) ifTrue:[ + code := #(sendDrop0 sendDrop1 sendDrop2 sendDrop3) at:(nargs+1). + aStream nextPut:code; nextPut:lineNr; nextPut:litIndex. + ^ self + ]. + + aStream nextPut:#sendDrop; nextPut:lineNr; nextPut:litIndex; nextPut:nargs. + ^ self + ]. + "need 16bit litIndex" + receiver isSuper ifTrue:[ + receiver isHere ifTrue:[ + code := #hereSendL + ] ifFalse:[ + code := #superSendL. + ]. + aStream nextPut:code; nextPut:lineNr; nextPut:litIndex; nextPut:0; nextPut:nargs; nextPut:nil; nextPut:#drop. + ^ self + ]. + aStream nextPut:#sendDropL; nextPut:lineNr; nextPut:litIndex; nextPut:0; nextPut:nargs +! + +codeForSideEffectOn:aStream inBlock:b for:aCompiler + self codeOn:aStream inBlock:b valueNeeded:false for:aCompiler ! codeIfElseOn:aStream inBlock:b valueNeeded:valueNeeded for:aCompiler @@ -915,183 +746,8 @@ ] ! -codeAndIfOn:aStream inBlock:b valueNeeded:valueNeeded for:aCompiler - "generate code for (x and:[y]) ifxxx:[ ... ]" - - |theByteCode optByteCode theReceiver theArg pos1 pos2 pos3 code here jmp| - - - theByteCode := #falseJump. - theReceiver := receiver receiver. - - optByteCode := self optimizedConditionFor:theReceiver - with:theByteCode. - optByteCode notNil ifTrue:[ - ((optByteCode == #eqJump) or:[optByteCode == #notEqJump]) ifTrue:[ - theArg := theReceiver arg1 - ]. - theReceiver := theReceiver receiver. - theByteCode := optByteCode - ]. - theReceiver codeOn:aStream inBlock:b for:aCompiler. - theArg notNil ifTrue:[ - theArg codeOn:aStream inBlock:b for:aCompiler - ]. - aStream nextPut:theByteCode. - pos1 := aStream position. - aStream nextPut:0. - - theReceiver := receiver arg1. - theReceiver codeInlineOn:aStream inBlock:b for:aCompiler. - (selector == #ifTrue:) ifTrue:[ - jmp := #falseJump - ] ifFalse:[ - jmp := #trueJump - ]. - aStream nextPut:jmp. - pos2 := aStream position. - aStream nextPut:0. - - code := aStream contents. - (selector == #ifFalse:) ifTrue:[ - code at:pos1 put:(aStream position) - ]. - (argArray at: 1) codeInlineOn:aStream inBlock:b valueNeeded:valueNeeded for:aCompiler. - - valueNeeded ifTrue:[ - aStream nextPut:#jump. - pos3 := aStream position. - aStream nextPut:0. - here := aStream position. - (selector == #ifTrue:) ifTrue:[ - code at:pos1 put:here - ]. - code at:pos2 put:here. - aStream nextPut:#pushNil. - code at:pos3 put:(aStream position) - ] ifFalse:[ - here := aStream position. - (selector == #ifTrue:) ifTrue:[ - code at:pos1 put:here - ]. - code at:pos2 put:here - ] -! - -codeOrIfOn:aStream inBlock:b valueNeeded:valueNeeded for:aCompiler - "generate code for (x or:[y]) ifxxx:[ ... ]" - - |theByteCode optByteCode theReceiver theArg pos1 pos2 pos3 code here jmp| - - theByteCode := #trueJump. - theReceiver := receiver receiver. - - optByteCode := self optimizedConditionFor:theReceiver with:theByteCode. - optByteCode notNil ifTrue:[ - ((optByteCode == #eqJump) or:[optByteCode == #notEqJump]) ifTrue:[ - theArg := theReceiver arg1 - ]. - theReceiver := theReceiver receiver. - theByteCode := optByteCode - ]. - theReceiver codeOn:aStream inBlock:b for:aCompiler. - theArg notNil ifTrue:[ - theArg codeOn:aStream inBlock:b for:aCompiler - ]. - aStream nextPut:theByteCode. - pos1 := aStream position. - aStream nextPut:0. - - - theReceiver := receiver arg1. - -"new:" - (selector == #ifTrue:) ifTrue:[ - theByteCode := #falseJump - ] ifFalse:[ - theByteCode := #trueJump - ]. - optByteCode := self optimizedConditionFor:theReceiver with:theByteCode. - optByteCode notNil ifTrue:[ - theReceiver isBlock ifTrue:[ - theReceiver := theReceiver statements expression - ]. - ((optByteCode == #eqJump) or:[optByteCode == #notEqJump]) ifTrue:[ - theArg := theReceiver arg1 - ]. - theReceiver := theReceiver receiver. - theByteCode := optByteCode. - - theReceiver codeOn:aStream inBlock:b for:aCompiler. - theArg notNil ifTrue:[ - theArg codeOn:aStream inBlock:b for:aCompiler - ]. - aStream nextPut:theByteCode. - - ] ifFalse:[ -"org" - theReceiver codeInlineOn:aStream inBlock:b for:aCompiler. - (selector == #ifTrue:) ifTrue:[ - jmp := #falseJump - ] ifFalse:[ - jmp := #trueJump - ]. - aStream nextPut:jmp - ]. - pos2 := aStream position. - aStream nextPut:0. - (selector == #ifTrue:) ifTrue:[ - (aStream contents) at:pos1 put:(aStream position) - ]. - (argArray at: 1) codeInlineOn:aStream inBlock:b valueNeeded:valueNeeded for:aCompiler. - - code := aStream contents. - valueNeeded ifTrue:[ - aStream nextPut:#jump. - pos3 := aStream position. - aStream nextPut:0. - here := aStream position. - (selector == #ifFalse:) ifTrue:[ - code at:pos1 put:here - ]. - code at:pos2 put:here. - aStream nextPut:#pushNil. - code at:pos3 put:(aStream position) - ] ifFalse:[ - here := aStream position. - (selector == #ifFalse:) ifTrue:[ - code at:pos1 put:here - ]. - code at:pos2 put:here - ] -! - -codeAndOrOn:aStream inBlock:b valueNeeded:valueNeeded for:aCompiler - "generate code for x and/or:[y] - but not in an if" - - |pos theReceiver theByteCode| - -self halt. - theReceiver := receiver. - (selector == #and:) ifTrue:[ - theByteCode := #falseJump - ] ifFalse:[ - theByteCode := #trueJump - ]. -" - (self canOptimizeConditionFor:receiver) ifTrue:[ - theByteCode := self optimizedConditionFor:theReceiver - with:theByteCode. - theReceiver := theReceiver receiver - ]. -" - theReceiver codeOn:aStream inBlock:b for:aCompiler. - aStream nextPut:theByteCode. - pos := aStream position. - aStream nextPut:0. - (argArray at: 1) codeInlineOn:aStream inBlock:b for:aCompiler. - (aStream contents) at:pos put:(aStream position). - valueNeeded ifFalse:[aStream nextPut:#drop] +codeOn:aStream inBlock:b for:aCompiler + self codeOn:aStream inBlock:b valueNeeded:true for:aCompiler ! codeOn:aStream inBlock:b valueNeeded:valueNeeded for:aCompiler @@ -1328,6 +984,94 @@ "Modified: 3.9.1995 / 12:55:42 / claus" ! +codeOrIfOn:aStream inBlock:b valueNeeded:valueNeeded for:aCompiler + "generate code for (x or:[y]) ifxxx:[ ... ]" + + |theByteCode optByteCode theReceiver theArg pos1 pos2 pos3 code here jmp| + + theByteCode := #trueJump. + theReceiver := receiver receiver. + + optByteCode := self optimizedConditionFor:theReceiver with:theByteCode. + optByteCode notNil ifTrue:[ + ((optByteCode == #eqJump) or:[optByteCode == #notEqJump]) ifTrue:[ + theArg := theReceiver arg1 + ]. + theReceiver := theReceiver receiver. + theByteCode := optByteCode + ]. + theReceiver codeOn:aStream inBlock:b for:aCompiler. + theArg notNil ifTrue:[ + theArg codeOn:aStream inBlock:b for:aCompiler + ]. + aStream nextPut:theByteCode. + pos1 := aStream position. + aStream nextPut:0. + + + theReceiver := receiver arg1. + +"new:" + (selector == #ifTrue:) ifTrue:[ + theByteCode := #falseJump + ] ifFalse:[ + theByteCode := #trueJump + ]. + optByteCode := self optimizedConditionFor:theReceiver with:theByteCode. + optByteCode notNil ifTrue:[ + theReceiver isBlock ifTrue:[ + theReceiver := theReceiver statements expression + ]. + ((optByteCode == #eqJump) or:[optByteCode == #notEqJump]) ifTrue:[ + theArg := theReceiver arg1 + ]. + theReceiver := theReceiver receiver. + theByteCode := optByteCode. + + theReceiver codeOn:aStream inBlock:b for:aCompiler. + theArg notNil ifTrue:[ + theArg codeOn:aStream inBlock:b for:aCompiler + ]. + aStream nextPut:theByteCode. + + ] ifFalse:[ +"org" + theReceiver codeInlineOn:aStream inBlock:b for:aCompiler. + (selector == #ifTrue:) ifTrue:[ + jmp := #falseJump + ] ifFalse:[ + jmp := #trueJump + ]. + aStream nextPut:jmp + ]. + pos2 := aStream position. + aStream nextPut:0. + (selector == #ifTrue:) ifTrue:[ + (aStream contents) at:pos1 put:(aStream position) + ]. + (argArray at: 1) codeInlineOn:aStream inBlock:b valueNeeded:valueNeeded for:aCompiler. + + code := aStream contents. + valueNeeded ifTrue:[ + aStream nextPut:#jump. + pos3 := aStream position. + aStream nextPut:0. + here := aStream position. + (selector == #ifFalse:) ifTrue:[ + code at:pos1 put:here + ]. + code at:pos2 put:here. + aStream nextPut:#pushNil. + code at:pos3 put:(aStream position) + ] ifFalse:[ + here := aStream position. + (selector == #ifFalse:) ifTrue:[ + code at:pos1 put:here + ]. + code at:pos2 put:here + ] +! + codeSendOn:aStream inBlock:b valueNeeded:valueNeeded for:aCompiler "like code on, but assumes that receiver has already been coded onto stack - needed for cascade" @@ -1441,85 +1185,342 @@ aStream nextPut:code; nextPut:lineNr; nextPut:litIndex; nextPut:0; nextPut:nargs ! -codeForCascadeOn:aStream inBlock:b for:aCompiler - "like codeOn, but always leave the receiver instead of the result" +codeTimesRepeatOn:aStream inBlock:b valueNeeded:valueNeeded for:aCompiler + "generate code for n timesRepeat:[ ... ]" + + |pos pos2 theReceiver| + + theReceiver := receiver. + theReceiver codeOn:aStream inBlock:b for:aCompiler. + valueNeeded ifTrue:[aStream nextPut:#dup]. - |nargs isBuiltIn code litIndex| + pos := aStream position. +"/ aStream nextPut:#dup; nextPut:#push0; nextPut:#>; nextPut:lineNr; nextPut:#falseJump. +"/ aStream nextPut:#dup; nextPut:#gt0; nextPut:lineNr; nextPut:#falseJump. + aStream nextPut:#pushgt0; nextPut:lineNr; nextPut:#falseJump. + pos2 := aStream position. + aStream nextPut:0. + + (argArray at:1) codeInlineOn:aStream inBlock:b valueNeeded:false for:aCompiler. + aStream nextPut:#minus1; nextPut:lineNr; nextPut:#jump; nextPut:pos. + + (aStream contents) at:pos2 put:(aStream position). + aStream nextPut:#drop. +! + +codeWhileOn:aStream inBlock:b valueNeeded:valueNeeded for:aCompiler + "generate code for [...] whilexxx:[ ... ]" + + |pos pos2 theReceiver theArg theByteCode optByteCode| - argArray isNil ifTrue:[ - nargs := 0 + (selector == #whileTrue:) ifTrue:[ + theByteCode := #falseJump ] ifFalse:[ - nargs := argArray size + theByteCode := #trueJump + ]. + + theReceiver := receiver. + optByteCode := self optimizedConditionFor:theReceiver with:theByteCode. + optByteCode notNil ifTrue:[ + ((optByteCode == #eqJump) or:[optByteCode == #notEqJump]) ifTrue:[ + theArg := receiver statements expression arg1 + ]. + theReceiver := receiver statements expression receiver. + theByteCode := optByteCode + ]. + +"/ OLD: +"/ valueNeeded ifTrue:[aStream nextPut:#pushNil]. +"/ + pos := aStream position. + optByteCode notNil ifTrue:[ + theReceiver codeOn:aStream inBlock:b for:aCompiler. + theArg notNil ifTrue:[ + theArg codeOn:aStream inBlock:b for:aCompiler + ] + ] ifFalse:[ + theReceiver codeInlineOn:aStream inBlock:b for:aCompiler + ]. + + (lineNr between:1 and:255) ifTrue:[ + aStream nextPut:#lineno; nextPut:lineNr. ]. - isBuiltIn := false. + aStream nextPut:theByteCode. + pos2 := aStream position. + aStream nextPut:0. +"/ OLD: +"/ valueNeeded ifTrue:[aStream nextPut:#drop]. +"/ +"/ OLD: +"/ (argArray at:1) codeInlineOn:aStream inBlock:b valueNeeded:valueNeeded for:aCompiler. +"/ NEW: + (argArray at:1) codeInlineOn:aStream inBlock:b valueNeeded:false for:aCompiler. + aStream nextPut:#jump; nextPut:pos. + (aStream contents) at:pos2 put:(aStream position). +"/ NEW: + valueNeeded ifTrue:[aStream nextPut:#pushNil]. +! + +optimizedConditionFor:aReceiver with:aByteCode + |rec sel| - (nargs == 0) ifTrue:[ - isBuiltIn := self class isBuiltInUnarySelector:selector + rec := aReceiver. + (rec isBlock) ifTrue:[ + rec statements nextStatement isNil ifTrue:[ + rec := rec statements expression + ] + ]. + (rec isUnaryMessage) ifTrue:[ + sel := rec selector. + (sel == #isNil) ifTrue:[ + "/ + "/ isNil trueJmp -> nilJump + "/ isNil falseJmp -> notNilJump + "/ + (aByteCode == #trueJump) ifTrue:[^ #nilJump]. + (aByteCode == #falseJump) ifTrue:[^ #notNilJump] + ]. + (sel == #notNil) ifTrue:[ + "/ + "/ notNil trueJmp -> notNilJump + "/ notNil falseJmp -> nilJump + "/ + (aByteCode == #trueJump) ifTrue:[^ #notNilJump]. + (aByteCode == #falseJump) ifTrue:[^ #nilJump] + ]. + (sel == #not) ifTrue:[ + "/ + "/ not trueJmp -> falseJump + "/ not falseJmp -> trueJump + "/ + (aByteCode == #trueJump) ifTrue:[^ #falseJump]. + (aByteCode == #falseJump) ifTrue:[^ #trueJump] + ]. + ^ nil ]. + (rec isBinaryMessage) ifTrue:[ + sel := rec selector. + rec arg1 isConstant ifTrue:[ + (rec arg1 value == 0) ifTrue:[ + "/ + "/ ==0 trueJmp -> zeroJump + "/ ==0 falseJmp -> notZeroJump + "/ + (sel == #==) ifTrue:[ + (aByteCode == #trueJump) ifTrue:[^ #zeroJump]. + (aByteCode == #falseJump) ifTrue:[^ #notZeroJump] + ]. + "/ + "/ ~~0 trueJmp -> notZeroJump + "/ ~~0 falseJmp -> zeroJump + "/ + (sel == #~~) ifTrue:[ + (aByteCode == #falseJump) ifTrue:[^ #zeroJump]. + (aByteCode == #trueJump) ifTrue:[^ #notZeroJump] + ]. + ^ nil + ] + ]. + (sel == #==) ifTrue:[ + "/ + "/ == trueJmp -> eqJump + "/ == falseJmp -> notEqJump + "/ + (aByteCode == #trueJump) ifTrue:[^ #eqJump]. + (aByteCode == #falseJump) ifTrue:[^ #notEqJump] + ]. + (sel == #~~) ifTrue:[ + "/ + "/ ~~ trueJmp -> notEqJump + "/ ~~ falseJmp -> eqJump + "/ + (aByteCode == #falseJump) ifTrue:[^ #eqJump]. + (aByteCode == #trueJump) ifTrue:[^ #notEqJump] + ] + ]. + ^ nil +! ! + +!MessageNode methodsFor:'evaluating'! + +evaluate + |r nargs argValueArray class| + + receiver isSuper ifTrue:[ + r := receiver value. + receiver isHere ifTrue:[ + class := receiver definingClass. + ] ifFalse:[ + class := receiver definingClass superclass. + ]. + argArray notNil ifTrue:[ + argValueArray := argArray collect:[:arg | arg evaluate]. + ] ifFalse:[ + argValueArray := #() + ]. + ^ r perform:selector inClass:class withArguments:argValueArray + ]. + + + argArray isNil ifTrue:[ + ^ (receiver evaluate) perform:selector + ]. + nargs := argArray size. (nargs == 1) ifTrue:[ - isBuiltIn := self class isBuiltIn1ArgSelector:selector + ^ (receiver evaluate) perform:selector with:(argArray at:1) evaluate ]. (nargs == 2) ifTrue:[ - isBuiltIn := self class isBuiltIn2ArgSelector:selector + ^ (receiver evaluate) perform:selector + with:(argArray at:1) evaluate + with:(argArray at:2) evaluate + ]. + (nargs == 3) ifTrue:[ + ^ (receiver evaluate) perform:selector + with:(argArray at:1) evaluate + with:(argArray at:2) evaluate + with:(argArray at:3) evaluate + ]. + r := receiver evaluate. + argValueArray := argArray collect:[:arg | arg evaluate]. + ^ r perform:selector withArguments:argValueArray +! + +evaluateForCascade + |r nargs argValueArray class| + + receiver isSuper ifTrue:[ + r := receiver value. + class := receiver definingClass. + receiver isHere ifFalse:[ + class := class superclass. + ]. + argArray notNil ifTrue:[ + argValueArray := argArray collect:[:arg | arg evaluate]. + ] ifFalse:[ + argValueArray := #() + ]. + r perform:selector inClass:class withArguments:argValueArray. + ^ r ]. - receiver codeOn:aStream inBlock:b for:aCompiler. - aStream nextPut:#dup. + r := receiver evaluate. + argArray isNil ifTrue:[ + r perform:selector. + ^ r + ]. + nargs := argArray size. + (nargs == 1) ifTrue:[ + r perform:selector with:(argArray at:1) evaluate. + ^ r + ]. + (nargs == 2) ifTrue:[ + r perform:selector with:(argArray at:1) evaluate + with:(argArray at:2) evaluate. + ^ r + ]. + (nargs == 3) ifTrue:[ + r perform:selector with:(argArray at:1) evaluate + with:(argArray at:2) evaluate + with:(argArray at:3) evaluate. + ^ r + ]. + argValueArray := argArray collect:[:arg | arg evaluate]. + r perform:selector withArguments:argValueArray. + ^ r +! ! + +!MessageNode methodsFor:'printing'! + +printOn:aStream indent:i + |needParen selectorParts index index2 arg| + + (#(whileTrue: whileFalse:) includes:selector) ifTrue:[ + receiver isBlock ifTrue:[ + ^ self printWhileOn:aStream indent:i + ]. + ]. - "can we use a send-bytecode ?" - isBuiltIn ifTrue:[ - receiver isSuper ifFalse:[ - (nargs > 0) ifTrue:[ - (argArray at:1) codeOn:aStream inBlock:b for:aCompiler. - (nargs > 1) ifTrue:[ - (argArray at:2) codeOn:aStream inBlock:b for:aCompiler + index := 1. + selectorParts := OrderedCollection new. + [index == 0] whileFalse:[ + index2 := selector indexOf:$: startingAt:index. + index2 ~~ 0 ifTrue:[ + selectorParts add:(selector copyFrom:index to:index2). + index2 := index2 + 1 + ]. + index := index2 + ]. + + needParen := false. + receiver isMessage ifTrue:[ + receiver isUnaryMessage ifFalse:[ + receiver isBinaryMessage ifFalse:[ + needParen := true + ]. + ]. + ]. + needParen ifTrue:[ + aStream nextPutAll:'(' + ]. + receiver printOn:aStream indent:i. + needParen ifTrue:[ + aStream nextPutAll:')' + ]. + + 1 to:(argArray size) do:[:argIndex | + aStream space. + (selectorParts at:argIndex) printOn:aStream. + aStream space. + arg := argArray at:argIndex. + needParen := false. + arg isMessage ifTrue:[ + arg isBinaryMessage ifFalse:[ + arg isUnaryMessage ifFalse:[ + needParen := true ] ]. - aStream nextPut:selector. - (self class hasLineNumber:selector) ifTrue:[ - aStream nextPut:lineNr. - ]. - aStream nextPut:#drop. - ^ self - ] - ]. + ]. + needParen ifTrue:[ + aStream nextPutAll:'(' + ]. + arg printOn:aStream indent:i. + needParen ifTrue:[ + aStream nextPutAll:') ' + ]. + ] +! + +printWhileOn:aStream indent:i + |needParen arg| - "no - generate a send" - argArray notNil ifTrue:[ - argArray do:[:arg | - arg codeOn:aStream inBlock:b for:aCompiler - ] + "special handling of whileTrue/whileFalse" + + aStream nextPutAll:'['. + receiver statements printOn:aStream indent:i. + aStream nextPutAll:'] whileTrue: '. + + arg := argArray at:1. + needParen := false. + arg isMessage ifTrue:[ + arg isBinaryMessage ifFalse:[ + arg isUnaryMessage ifFalse:[ + needParen := true + ] + ]. ]. - litIndex := aCompiler addLiteral:selector. - litIndex <= 255 ifTrue:[ - receiver isSuper ifTrue:[ - receiver isHere ifTrue:[ - code := #hereSend - ] ifFalse:[ - code := #superSend. - ]. - aStream nextPut:code; nextPut:lineNr; nextPut:litIndex; nextPut:nargs; nextPut:nil; nextPut:#drop. - ^ self - ]. - (nargs <= 3) ifTrue:[ - code := #(sendDrop0 sendDrop1 sendDrop2 sendDrop3) at:(nargs+1). - aStream nextPut:code; nextPut:lineNr; nextPut:litIndex. - ^ self - ]. + needParen ifTrue:[ + aStream nextPutAll:'(' + ]. + arg printOn:aStream indent:i. + needParen ifTrue:[ + aStream nextPutAll:') ' + ]. +! ! - aStream nextPut:#sendDrop; nextPut:lineNr; nextPut:litIndex; nextPut:nargs. - ^ self - ]. - "need 16bit litIndex" - receiver isSuper ifTrue:[ - receiver isHere ifTrue:[ - code := #hereSendL - ] ifFalse:[ - code := #superSendL. - ]. - aStream nextPut:code; nextPut:lineNr; nextPut:litIndex; nextPut:0; nextPut:nargs; nextPut:nil; nextPut:#drop. - ^ self - ]. - aStream nextPut:#sendDropL; nextPut:lineNr; nextPut:litIndex; nextPut:0; nextPut:nargs +!MessageNode methodsFor:'queries'! + +isMessage + ^ true ! ! + diff -r 65eaf1a009f5 -r 1ef1d1395146 ParseNode.st --- a/ParseNode.st Sat Nov 18 17:59:14 1995 +0100 +++ b/ParseNode.st Thu Nov 23 03:15:59 1995 +0100 @@ -11,10 +11,10 @@ " Object subclass:#ParseNode - instanceVariableNames:'type comments parenthized' - classVariableNames:'' - poolDictionaries:'' - category:'System-Compiler-Support' + instanceVariableNames:'type comments parenthized' + classVariableNames:'' + poolDictionaries:'' + category:'System-Compiler-Support' ! !ParseNode class methodsFor:'documentation'! @@ -33,14 +33,14 @@ " ! -version - ^ '$Header: /cvs/stx/stx/libcomp/ParseNode.st,v 1.13 1995-11-11 15:31:02 cg Exp $' -! - documentation " node for parse-trees; abstract class " +! + +version + ^ '$Header: /cvs/stx/stx/libcomp/ParseNode.st,v 1.14 1995-11-23 02:14:03 cg Exp $' ! ! !ParseNode class methodsFor:'instance creation'! @@ -49,8 +49,91 @@ ^ (self basicNew) type:t ! ! +!ParseNode methodsFor:'accessing'! + +lineNumber:dummy + "set linenumber - ignored here" + + ^ self +! + +parenthized + ^ parenthized +! + +parenthized:aBoolean + parenthized := aBoolean +! + +type + "return the nodes type" + + ^ type +! ! + +!ParseNode methodsFor:'checks'! + +plausibilityCheck + ^ nil +! ! + +!ParseNode methodsFor:'code generation'! + +codeForSideEffectOn:aStream inBlock:b for:aCompiler + "generate code for this statement - value not needed" + + self codeOn:aStream inBlock:b for:aCompiler. + aStream nextPut:#drop +! ! + +!ParseNode methodsFor:'evaluation'! + +evaluateForCascade + ^ self evaluate +! ! + +!ParseNode methodsFor:'printing'! + +printOn:aStream + self printOn:aStream indent:0 +! + +printString + |stream| + + stream := WriteStream on:String new. + self printOn:stream indent:0. + ^ stream contents +! ! + +!ParseNode methodsFor:'private'! + +type:t + "set the nodes type" + + type := t +! ! + !ParseNode methodsFor:'queries'! +isAssignment + "return true, if this is a node for an assignment" + + ^ false +! + +isBinaryMessage + "return true, if this is a node for a binary send" + + ^ false +! + +isBlockNode + "return true, if this is a node for a block" + + ^ false +! + isConstant "return true, if this is a node for a constant" @@ -63,14 +146,14 @@ ^ false ! -isPrimary - "return true, if this is a node for a primary (i.e. non-send)" +isMessage + "return true, if this is a node for a message expression" ^ false ! -isSuper - "return true, if this is a super-node" +isPrimary + "return true, if this is a node for a primary (i.e. non-send)" ^ false ! @@ -81,26 +164,8 @@ ^ false ! -isBlockNode - "return true, if this is a node for a block" - - ^ false -! - -isAssignment - "return true, if this is a node for an assignment" - - ^ false -! - -isMessage - "return true, if this is a node for a message expression" - - ^ false -! - -isBinaryMessage - "return true, if this is a node for a binary send" +isSuper + "return true, if this is a super-node" ^ false ! @@ -111,67 +176,3 @@ ^ false ! ! -!ParseNode methodsFor:'accessing'! - -type - "return the nodes type" - - ^ type -! - -lineNumber:dummy - "set linenumber - ignored here" - - ^ self -! - -parenthized:aBoolean - parenthized := aBoolean -! - -parenthized - ^ parenthized -! ! - -!ParseNode methodsFor:'private'! - -type:t - "set the nodes type" - - type := t -! ! - -!ParseNode methodsFor:'printing'! - -printString - |stream| - - stream := WriteStream on:String new. - self printOn:stream indent:0. - ^ stream contents -! - -printOn:aStream - self printOn:aStream indent:0 -! ! - -!ParseNode methodsFor:'checks'! - -plausibilityCheck - ^ nil -! ! - -!ParseNode methodsFor:'evaluation'! - -evaluateForCascade - ^ self evaluate -! ! - -!ParseNode methodsFor:'code generation'! - -codeForSideEffectOn:aStream inBlock:b for:aCompiler - "generate code for this statement - value not needed" - - self codeOn:aStream inBlock:b for:aCompiler. - aStream nextPut:#drop -! ! diff -r 65eaf1a009f5 -r 1ef1d1395146 PrimNd.st --- a/PrimNd.st Sat Nov 18 17:59:14 1995 +0100 +++ b/PrimNd.st Thu Nov 23 03:15:59 1995 +0100 @@ -11,10 +11,10 @@ " StatementNode subclass:#PrimitiveNode - instanceVariableNames:'code primNumber optional' - classVariableNames:'' - poolDictionaries:'' - category:'System-Compiler-Support' + instanceVariableNames:'code primNumber optional' + classVariableNames:'' + poolDictionaries:'' + category:'System-Compiler-Support' ! !PrimitiveNode class methodsFor:'documentation'! @@ -33,10 +33,6 @@ " ! -version - ^ '$Header: /cvs/stx/stx/libcomp/Attic/PrimNd.st,v 1.11 1995-11-11 15:31:26 cg Exp $' -! - documentation " node for parse-trees, representing primitive code @@ -55,6 +51,10 @@ optional primitive; these are compiled on systems which do support binary code loading, and ignored completely on others. " +! + +version + ^ '$Header: /cvs/stx/stx/libcomp/Attic/PrimNd.st,v 1.12 1995-11-23 02:14:23 cg Exp $' ! ! !PrimitiveNode class methodsFor:'instance creation'! @@ -67,16 +67,6 @@ ^ self basicNew primitiveNumber:anInteger ! ! -!PrimitiveNode methodsFor:'queries'! - -isConstant - ^ false -! - -isOptional - ^ optional -! ! - !PrimitiveNode methodsFor:'accessing'! code:aString @@ -104,22 +94,6 @@ primNumber := anInteger ! ! -!PrimitiveNode methodsFor:'evaluating'! - -evaluateExpression - "catch evaluation" - - optional ifTrue:[^ nil]. - self error:'cannot evaluate primitives' -! - -evaluate - "catch evaluation" - - optional ifTrue:[^ nil]. - self error:'cannot evaluate primitives' -! ! - !PrimitiveNode methodsFor:'code generation'! codeForSideEffectOn:aStream inBlock:b for:aCompiler @@ -135,3 +109,30 @@ optional ifTrue:[^ self]. self error:'cannot compile primitives (as yet)' ! ! + +!PrimitiveNode methodsFor:'evaluating'! + +evaluate + "catch evaluation" + + optional ifTrue:[^ nil]. + self error:'cannot evaluate primitives' +! + +evaluateExpression + "catch evaluation" + + optional ifTrue:[^ nil]. + self error:'cannot evaluate primitives' +! ! + +!PrimitiveNode methodsFor:'queries'! + +isConstant + ^ false +! + +isOptional + ^ optional +! ! + diff -r 65eaf1a009f5 -r 1ef1d1395146 PrimaryNd.st --- a/PrimaryNd.st Sat Nov 18 17:59:14 1995 +0100 +++ b/PrimaryNd.st Thu Nov 23 03:15:59 1995 +0100 @@ -11,10 +11,10 @@ " ParseNode subclass:#PrimaryNode - instanceVariableNames:'value' - classVariableNames:'' - poolDictionaries:'' - category:'System-Compiler-Support' + instanceVariableNames:'value' + classVariableNames:'' + poolDictionaries:'' + category:'System-Compiler-Support' ! !PrimaryNode class methodsFor:'documentation'! @@ -33,14 +33,14 @@ " ! -version - ^ '$Header: /cvs/stx/stx/libcomp/Attic/PrimaryNd.st,v 1.12 1995-11-11 15:31:27 cg Exp $' -! - documentation " node for parse-trees, representing primaries (variables & literals) " +! + +version + ^ '$Header: /cvs/stx/stx/libcomp/Attic/PrimaryNd.st,v 1.13 1995-11-23 02:14:13 cg Exp $' ! ! !PrimaryNode methodsFor:'accessing'! @@ -49,24 +49,6 @@ ^ value ! ! -!PrimaryNode methodsFor:'queries'! - -isPrimary - "return true, if this is a node for a primary (i.e. non-send)" - - ^ true -! ! - -!PrimaryNode methodsFor:'evaluating'! - -evaluate - ^ self subclassResponsibility -! - -store:aValue - ^ self subclassResponsibility -! ! - !PrimaryNode methodsFor:'code generation'! codeForSideEffectOn:aStream inBlock:b for:aCompiler @@ -82,6 +64,16 @@ ^ self subclassResponsibility ! ! +!PrimaryNode methodsFor:'evaluating'! + +evaluate + ^ self subclassResponsibility +! + +store:aValue + ^ self subclassResponsibility +! ! + !PrimaryNode methodsFor:'printing'! displayString @@ -91,3 +83,12 @@ printOn:aStream indent:i ^ self subclassResponsibility ! ! + +!PrimaryNode methodsFor:'queries'! + +isPrimary + "return true, if this is a node for a primary (i.e. non-send)" + + ^ true +! ! + diff -r 65eaf1a009f5 -r 1ef1d1395146 PrimaryNode.st --- a/PrimaryNode.st Sat Nov 18 17:59:14 1995 +0100 +++ b/PrimaryNode.st Thu Nov 23 03:15:59 1995 +0100 @@ -11,10 +11,10 @@ " ParseNode subclass:#PrimaryNode - instanceVariableNames:'value' - classVariableNames:'' - poolDictionaries:'' - category:'System-Compiler-Support' + instanceVariableNames:'value' + classVariableNames:'' + poolDictionaries:'' + category:'System-Compiler-Support' ! !PrimaryNode class methodsFor:'documentation'! @@ -33,14 +33,14 @@ " ! -version - ^ '$Header: /cvs/stx/stx/libcomp/PrimaryNode.st,v 1.12 1995-11-11 15:31:27 cg Exp $' -! - documentation " node for parse-trees, representing primaries (variables & literals) " +! + +version + ^ '$Header: /cvs/stx/stx/libcomp/PrimaryNode.st,v 1.13 1995-11-23 02:14:13 cg Exp $' ! ! !PrimaryNode methodsFor:'accessing'! @@ -49,24 +49,6 @@ ^ value ! ! -!PrimaryNode methodsFor:'queries'! - -isPrimary - "return true, if this is a node for a primary (i.e. non-send)" - - ^ true -! ! - -!PrimaryNode methodsFor:'evaluating'! - -evaluate - ^ self subclassResponsibility -! - -store:aValue - ^ self subclassResponsibility -! ! - !PrimaryNode methodsFor:'code generation'! codeForSideEffectOn:aStream inBlock:b for:aCompiler @@ -82,6 +64,16 @@ ^ self subclassResponsibility ! ! +!PrimaryNode methodsFor:'evaluating'! + +evaluate + ^ self subclassResponsibility +! + +store:aValue + ^ self subclassResponsibility +! ! + !PrimaryNode methodsFor:'printing'! displayString @@ -91,3 +83,12 @@ printOn:aStream indent:i ^ self subclassResponsibility ! ! + +!PrimaryNode methodsFor:'queries'! + +isPrimary + "return true, if this is a node for a primary (i.e. non-send)" + + ^ true +! ! + diff -r 65eaf1a009f5 -r 1ef1d1395146 PrimitiveNode.st --- a/PrimitiveNode.st Sat Nov 18 17:59:14 1995 +0100 +++ b/PrimitiveNode.st Thu Nov 23 03:15:59 1995 +0100 @@ -11,10 +11,10 @@ " StatementNode subclass:#PrimitiveNode - instanceVariableNames:'code primNumber optional' - classVariableNames:'' - poolDictionaries:'' - category:'System-Compiler-Support' + instanceVariableNames:'code primNumber optional' + classVariableNames:'' + poolDictionaries:'' + category:'System-Compiler-Support' ! !PrimitiveNode class methodsFor:'documentation'! @@ -33,10 +33,6 @@ " ! -version - ^ '$Header: /cvs/stx/stx/libcomp/PrimitiveNode.st,v 1.11 1995-11-11 15:31:26 cg Exp $' -! - documentation " node for parse-trees, representing primitive code @@ -55,6 +51,10 @@ optional primitive; these are compiled on systems which do support binary code loading, and ignored completely on others. " +! + +version + ^ '$Header: /cvs/stx/stx/libcomp/PrimitiveNode.st,v 1.12 1995-11-23 02:14:23 cg Exp $' ! ! !PrimitiveNode class methodsFor:'instance creation'! @@ -67,16 +67,6 @@ ^ self basicNew primitiveNumber:anInteger ! ! -!PrimitiveNode methodsFor:'queries'! - -isConstant - ^ false -! - -isOptional - ^ optional -! ! - !PrimitiveNode methodsFor:'accessing'! code:aString @@ -104,22 +94,6 @@ primNumber := anInteger ! ! -!PrimitiveNode methodsFor:'evaluating'! - -evaluateExpression - "catch evaluation" - - optional ifTrue:[^ nil]. - self error:'cannot evaluate primitives' -! - -evaluate - "catch evaluation" - - optional ifTrue:[^ nil]. - self error:'cannot evaluate primitives' -! ! - !PrimitiveNode methodsFor:'code generation'! codeForSideEffectOn:aStream inBlock:b for:aCompiler @@ -135,3 +109,30 @@ optional ifTrue:[^ self]. self error:'cannot compile primitives (as yet)' ! ! + +!PrimitiveNode methodsFor:'evaluating'! + +evaluate + "catch evaluation" + + optional ifTrue:[^ nil]. + self error:'cannot evaluate primitives' +! + +evaluateExpression + "catch evaluation" + + optional ifTrue:[^ nil]. + self error:'cannot evaluate primitives' +! ! + +!PrimitiveNode methodsFor:'queries'! + +isConstant + ^ false +! + +isOptional + ^ optional +! ! + diff -r 65eaf1a009f5 -r 1ef1d1395146 RetNode.st --- a/RetNode.st Sat Nov 18 17:59:14 1995 +0100 +++ b/RetNode.st Thu Nov 23 03:15:59 1995 +0100 @@ -11,10 +11,10 @@ " StatementNode subclass:#ReturnNode - instanceVariableNames:'myHome blockHome' - classVariableNames:'' - poolDictionaries:'' - category:'System-Compiler-Support' + instanceVariableNames:'myHome blockHome' + classVariableNames:'' + poolDictionaries:'' + category:'System-Compiler-Support' ! !ReturnNode class methodsFor:'documentation'! @@ -33,14 +33,14 @@ " ! -version - ^ '$Header: /cvs/stx/stx/libcomp/Attic/RetNode.st,v 1.12 1995-11-11 15:31:30 cg Exp $' -! - documentation " node for parse-trees, representing return expressions " +! + +version + ^ '$Header: /cvs/stx/stx/libcomp/Attic/RetNode.st,v 1.13 1995-11-23 02:14:34 cg Exp $' ! ! !ReturnNode methodsFor:'accessing'! @@ -50,30 +50,6 @@ blockHome := aBlockNode ! ! -!ReturnNode methodsFor:'queries'! - -isConstant - ^ false -! - -isReturnNode - ^ true -! ! - -!ReturnNode methodsFor:'evaluating'! - -evaluateExpression - |val| - - val := expression evaluate. - myHome exitWith:val. - "when we arrive here, the parser context is already gone - - try block-return" - blockHome notNil ifTrue:[blockHome exitWith:val]. - "well - what else can be done" - ^ val -! ! - !ReturnNode methodsFor:'code generation'! codeForSideEffectOn:aStream inBlock:b for:aCompiler @@ -152,9 +128,34 @@ aStream nextPut:#retTop ! ! +!ReturnNode methodsFor:'evaluating'! + +evaluateExpression + |val| + + val := expression evaluate. + myHome exitWith:val. + "when we arrive here, the parser context is already gone + - try block-return" + blockHome notNil ifTrue:[blockHome exitWith:val]. + "well - what else can be done" + ^ val +! ! + !ReturnNode methodsFor:'printing'! printOn:aStream indent:i aStream nextPutAll:'^ '. expression printOn:aStream ! ! + +!ReturnNode methodsFor:'queries'! + +isConstant + ^ false +! + +isReturnNode + ^ true +! ! + diff -r 65eaf1a009f5 -r 1ef1d1395146 ReturnNode.st --- a/ReturnNode.st Sat Nov 18 17:59:14 1995 +0100 +++ b/ReturnNode.st Thu Nov 23 03:15:59 1995 +0100 @@ -11,10 +11,10 @@ " StatementNode subclass:#ReturnNode - instanceVariableNames:'myHome blockHome' - classVariableNames:'' - poolDictionaries:'' - category:'System-Compiler-Support' + instanceVariableNames:'myHome blockHome' + classVariableNames:'' + poolDictionaries:'' + category:'System-Compiler-Support' ! !ReturnNode class methodsFor:'documentation'! @@ -33,14 +33,14 @@ " ! -version - ^ '$Header: /cvs/stx/stx/libcomp/ReturnNode.st,v 1.12 1995-11-11 15:31:30 cg Exp $' -! - documentation " node for parse-trees, representing return expressions " +! + +version + ^ '$Header: /cvs/stx/stx/libcomp/ReturnNode.st,v 1.13 1995-11-23 02:14:34 cg Exp $' ! ! !ReturnNode methodsFor:'accessing'! @@ -50,30 +50,6 @@ blockHome := aBlockNode ! ! -!ReturnNode methodsFor:'queries'! - -isConstant - ^ false -! - -isReturnNode - ^ true -! ! - -!ReturnNode methodsFor:'evaluating'! - -evaluateExpression - |val| - - val := expression evaluate. - myHome exitWith:val. - "when we arrive here, the parser context is already gone - - try block-return" - blockHome notNil ifTrue:[blockHome exitWith:val]. - "well - what else can be done" - ^ val -! ! - !ReturnNode methodsFor:'code generation'! codeForSideEffectOn:aStream inBlock:b for:aCompiler @@ -152,9 +128,34 @@ aStream nextPut:#retTop ! ! +!ReturnNode methodsFor:'evaluating'! + +evaluateExpression + |val| + + val := expression evaluate. + myHome exitWith:val. + "when we arrive here, the parser context is already gone + - try block-return" + blockHome notNil ifTrue:[blockHome exitWith:val]. + "well - what else can be done" + ^ val +! ! + !ReturnNode methodsFor:'printing'! printOn:aStream indent:i aStream nextPutAll:'^ '. expression printOn:aStream ! ! + +!ReturnNode methodsFor:'queries'! + +isConstant + ^ false +! + +isReturnNode + ^ true +! ! + diff -r 65eaf1a009f5 -r 1ef1d1395146 SelfNode.st --- a/SelfNode.st Sat Nov 18 17:59:14 1995 +0100 +++ b/SelfNode.st Thu Nov 23 03:15:59 1995 +0100 @@ -11,10 +11,10 @@ " PrimaryNode subclass:#SelfNode - instanceVariableNames:'' - classVariableNames:'' - poolDictionaries:'' - category:'System-Compiler-Support' + instanceVariableNames:'' + classVariableNames:'' + poolDictionaries:'' + category:'System-Compiler-Support' ! !SelfNode class methodsFor:'documentation'! @@ -33,14 +33,14 @@ " ! -version - ^ '$Header: /cvs/stx/stx/libcomp/SelfNode.st,v 1.7 1995-11-11 15:31:37 cg Exp $' -! - documentation " node for parse-trees, representing self " +! + +version + ^ '$Header: /cvs/stx/stx/libcomp/SelfNode.st,v 1.8 1995-11-23 02:14:45 cg Exp $' ! ! !SelfNode class methodsFor:'instance creation'! @@ -56,6 +56,18 @@ value := val. ! ! +!SelfNode methodsFor:'code generation'! + +codeOn:aStream inBlock:codeBlock for:aCompiler + aStream nextPut:#pushSelf +! + +codeStoreOn:aStream inBlock:codeBlock valueNeeded:valueNeeded for:aCompiler + "not reached - parser has already checked this" + + ^ self error:'store into self - cannot happen' +! ! + !SelfNode methodsFor:'evaluating'! evaluate @@ -68,18 +80,6 @@ self error:'store into self - cannot happen' ! ! -!SelfNode methodsFor:'code generation'! - -codeOn:aStream inBlock:codeBlock for:aCompiler - aStream nextPut:#pushSelf -! - -codeStoreOn:aStream inBlock:codeBlock valueNeeded:valueNeeded for:aCompiler - "not reached - parser has already checked this" - - ^ self error:'store into self - cannot happen' -! ! - !SelfNode methodsFor:'printing'! displayString @@ -89,3 +89,4 @@ printOn:aStream indent:i aStream nextPutAll:'self' ! ! + diff -r 65eaf1a009f5 -r 1ef1d1395146 StatNode.st --- a/StatNode.st Sat Nov 18 17:59:14 1995 +0100 +++ b/StatNode.st Thu Nov 23 03:15:59 1995 +0100 @@ -11,10 +11,10 @@ " ParseNode subclass:#StatementNode - instanceVariableNames:'expression nextStatement' - classVariableNames:'' - poolDictionaries:'' - category:'System-Compiler-Support' + instanceVariableNames:'expression nextStatement' + classVariableNames:'' + poolDictionaries:'' + category:'System-Compiler-Support' ! !StatementNode class methodsFor:'documentation'! @@ -33,14 +33,14 @@ " ! -version - ^ '$Header: /cvs/stx/stx/libcomp/Attic/StatNode.st,v 1.11 1995-11-11 15:31:39 cg Exp $' -! - documentation " node for parse-trees, representing statements " +! + +version + ^ '$Header: /cvs/stx/stx/libcomp/Attic/StatNode.st,v 1.12 1995-11-23 02:14:55 cg Exp $' ! ! !StatementNode class methodsFor:'instance creation'! @@ -49,40 +49,16 @@ ^ (self basicNew) expression:e ! ! -!StatementNode methodsFor:'evaluating'! +!StatementNode methodsFor:'accessing'! -evaluateExpression - ^ expression evaluate +expression + ^ expression ! -evaluate - |lastValue thisStatement| - - "this could be done more elegant - but with lots of recursion" - thisStatement := self. - [thisStatement notNil] whileTrue:[ - lastValue := thisStatement evaluateExpression. - thisStatement := thisStatement nextStatement - ]. - ^ lastValue -! ! - -!StatementNode methodsFor:'code generation'! - -codeOn:aStream inBlock:b for:aCompiler - "generate code for this statement" - - expression codeOn:aStream inBlock:b for:aCompiler +expression:e + expression := e ! -codeForSideEffectOn:aStream inBlock:b for:aCompiler - "generate code for this statement - value not needed" - - expression codeForSideEffectOn:aStream inBlock:b for:aCompiler -! ! - -!StatementNode methodsFor:'accessing'! - last "return the last statement in a list" @@ -98,35 +74,48 @@ ^ last ! -nextStatement:s - nextStatement := s -! - nextStatement ^ nextStatement ! -expression:e - expression := e +nextStatement:s + nextStatement := s +! ! + +!StatementNode methodsFor:'code generation'! + +codeForSideEffectOn:aStream inBlock:b for:aCompiler + "generate code for this statement - value not needed" + + expression codeForSideEffectOn:aStream inBlock:b for:aCompiler ! -expression - ^ expression +codeOn:aStream inBlock:b for:aCompiler + "generate code for this statement" + + expression codeOn:aStream inBlock:b for:aCompiler ! ! -!StatementNode methodsFor:'queries'! +!StatementNode methodsFor:'evaluating'! + +evaluate + |lastValue thisStatement| -isConstant - nextStatement notNil ifTrue:[^ false]. - ^ expression isConstant + "this could be done more elegant - but with lots of recursion" + thisStatement := self. + [thisStatement notNil] whileTrue:[ + lastValue := thisStatement evaluateExpression. + thisStatement := thisStatement nextStatement + ]. + ^ lastValue +! + +evaluateExpression + ^ expression evaluate ! ! !StatementNode methodsFor:'printing'! -printOn:aStream indent:i - expression printOn:aStream indent:i. -! - printAllOn:aStream self printAllOn:aStream indent:4 ! @@ -144,4 +133,16 @@ ]. thisStatement := thisStatement nextStatement ] +! + +printOn:aStream indent:i + expression printOn:aStream indent:i. ! ! + +!StatementNode methodsFor:'queries'! + +isConstant + nextStatement notNil ifTrue:[^ false]. + ^ expression isConstant +! ! + diff -r 65eaf1a009f5 -r 1ef1d1395146 StatementNode.st --- a/StatementNode.st Sat Nov 18 17:59:14 1995 +0100 +++ b/StatementNode.st Thu Nov 23 03:15:59 1995 +0100 @@ -11,10 +11,10 @@ " ParseNode subclass:#StatementNode - instanceVariableNames:'expression nextStatement' - classVariableNames:'' - poolDictionaries:'' - category:'System-Compiler-Support' + instanceVariableNames:'expression nextStatement' + classVariableNames:'' + poolDictionaries:'' + category:'System-Compiler-Support' ! !StatementNode class methodsFor:'documentation'! @@ -33,14 +33,14 @@ " ! -version - ^ '$Header: /cvs/stx/stx/libcomp/StatementNode.st,v 1.11 1995-11-11 15:31:39 cg Exp $' -! - documentation " node for parse-trees, representing statements " +! + +version + ^ '$Header: /cvs/stx/stx/libcomp/StatementNode.st,v 1.12 1995-11-23 02:14:55 cg Exp $' ! ! !StatementNode class methodsFor:'instance creation'! @@ -49,40 +49,16 @@ ^ (self basicNew) expression:e ! ! -!StatementNode methodsFor:'evaluating'! +!StatementNode methodsFor:'accessing'! -evaluateExpression - ^ expression evaluate +expression + ^ expression ! -evaluate - |lastValue thisStatement| - - "this could be done more elegant - but with lots of recursion" - thisStatement := self. - [thisStatement notNil] whileTrue:[ - lastValue := thisStatement evaluateExpression. - thisStatement := thisStatement nextStatement - ]. - ^ lastValue -! ! - -!StatementNode methodsFor:'code generation'! - -codeOn:aStream inBlock:b for:aCompiler - "generate code for this statement" - - expression codeOn:aStream inBlock:b for:aCompiler +expression:e + expression := e ! -codeForSideEffectOn:aStream inBlock:b for:aCompiler - "generate code for this statement - value not needed" - - expression codeForSideEffectOn:aStream inBlock:b for:aCompiler -! ! - -!StatementNode methodsFor:'accessing'! - last "return the last statement in a list" @@ -98,35 +74,48 @@ ^ last ! -nextStatement:s - nextStatement := s -! - nextStatement ^ nextStatement ! -expression:e - expression := e +nextStatement:s + nextStatement := s +! ! + +!StatementNode methodsFor:'code generation'! + +codeForSideEffectOn:aStream inBlock:b for:aCompiler + "generate code for this statement - value not needed" + + expression codeForSideEffectOn:aStream inBlock:b for:aCompiler ! -expression - ^ expression +codeOn:aStream inBlock:b for:aCompiler + "generate code for this statement" + + expression codeOn:aStream inBlock:b for:aCompiler ! ! -!StatementNode methodsFor:'queries'! +!StatementNode methodsFor:'evaluating'! + +evaluate + |lastValue thisStatement| -isConstant - nextStatement notNil ifTrue:[^ false]. - ^ expression isConstant + "this could be done more elegant - but with lots of recursion" + thisStatement := self. + [thisStatement notNil] whileTrue:[ + lastValue := thisStatement evaluateExpression. + thisStatement := thisStatement nextStatement + ]. + ^ lastValue +! + +evaluateExpression + ^ expression evaluate ! ! !StatementNode methodsFor:'printing'! -printOn:aStream indent:i - expression printOn:aStream indent:i. -! - printAllOn:aStream self printAllOn:aStream indent:4 ! @@ -144,4 +133,16 @@ ]. thisStatement := thisStatement nextStatement ] +! + +printOn:aStream indent:i + expression printOn:aStream indent:i. ! ! + +!StatementNode methodsFor:'queries'! + +isConstant + nextStatement notNil ifTrue:[^ false]. + ^ expression isConstant +! ! + diff -r 65eaf1a009f5 -r 1ef1d1395146 SuperNode.st --- a/SuperNode.st Sat Nov 18 17:59:14 1995 +0100 +++ b/SuperNode.st Thu Nov 23 03:15:59 1995 +0100 @@ -11,10 +11,10 @@ " SelfNode subclass:#SuperNode - instanceVariableNames:'class isHere' - classVariableNames:'' - poolDictionaries:'' - category:'System-Compiler-Support' + instanceVariableNames:'class isHere' + classVariableNames:'' + poolDictionaries:'' + category:'System-Compiler-Support' ! !SuperNode class methodsFor:'documentation'! @@ -33,14 +33,14 @@ " ! -version - ^ '$Header: /cvs/stx/stx/libcomp/SuperNode.st,v 1.7 1995-11-11 15:31:40 cg Exp $' -! - documentation " node for parse-trees, representing super " +! + +version + ^ '$Header: /cvs/stx/stx/libcomp/SuperNode.st,v 1.8 1995-11-23 02:15:05 cg Exp $' ! ! !SuperNode class methodsFor:'instance creation'! @@ -55,27 +55,15 @@ !SuperNode methodsFor:'accessing'! +definingClass + ^ class +! + value:val inClass:cls here:h type := #Super. value := val. class := cls. isHere := h -! - -definingClass - ^ class -! ! - -!SuperNode methodsFor:'queries'! - -isSuper - "return true, if this is a super-node" - - ^ true -! - -isHere - ^ isHere ! ! !SuperNode methodsFor:'printing'! @@ -87,3 +75,16 @@ aStream nextPutAll:'super' ] ! ! + +!SuperNode methodsFor:'queries'! + +isHere + ^ isHere +! + +isSuper + "return true, if this is a super-node" + + ^ true +! ! + diff -r 65eaf1a009f5 -r 1ef1d1395146 UnaryNd.st --- a/UnaryNd.st Sat Nov 18 17:59:14 1995 +0100 +++ b/UnaryNd.st Thu Nov 23 03:15:59 1995 +0100 @@ -11,10 +11,10 @@ " MessageNode subclass:#UnaryNode - instanceVariableNames:'' - classVariableNames:'' - poolDictionaries:'' - category:'System-Compiler-Support' + instanceVariableNames:'' + classVariableNames:'' + poolDictionaries:'' + category:'System-Compiler-Support' ! !UnaryNode class methodsFor:'documentation'! @@ -33,14 +33,14 @@ " ! -version - ^ '$Header: /cvs/stx/stx/libcomp/Attic/UnaryNd.st,v 1.17 1995-11-11 15:31:42 cg Exp $' -! - documentation " node for parse-trees, representing unary messages " +! + +version + ^ '$Header: /cvs/stx/stx/libcomp/Attic/UnaryNd.st,v 1.18 1995-11-23 02:15:16 cg Exp $' ! ! !UnaryNode class methodsFor:'instance creation'! @@ -139,13 +139,6 @@ ^ (self basicNew) receiver:r selector:selectorString args:nil lineno:0 ! ! -!UnaryNode methodsFor:'queries'! - -isUnaryMessage - "return true, if this node is one for a unary message" - ^ true -! ! - !UnaryNode methodsFor:'checks'! plausibilityCheck @@ -167,17 +160,6 @@ ^ nil ! ! -!UnaryNode methodsFor:'evaluating'! - -evaluate - "evaluate the expression represented by the receiver" - - receiver isSuper ifTrue:[ - ^ super evaluate - ]. - ^ (receiver evaluate) perform:selector -! ! - !UnaryNode methodsFor:'code generation'! codeOn:aStream inBlock:b for:aCompiler @@ -223,6 +205,17 @@ ^ super codeOn:aStream inBlock:b for:aCompiler ! ! +!UnaryNode methodsFor:'evaluating'! + +evaluate + "evaluate the expression represented by the receiver" + + receiver isSuper ifTrue:[ + ^ super evaluate + ]. + ^ (receiver evaluate) perform:selector +! ! + !UnaryNode methodsFor:'printing'! printOn:aStream indent:i @@ -247,3 +240,11 @@ selector printString printOn:aStream. " aStream space. " ! ! + +!UnaryNode methodsFor:'queries'! + +isUnaryMessage + "return true, if this node is one for a unary message" + ^ true +! ! + diff -r 65eaf1a009f5 -r 1ef1d1395146 UnaryNode.st --- a/UnaryNode.st Sat Nov 18 17:59:14 1995 +0100 +++ b/UnaryNode.st Thu Nov 23 03:15:59 1995 +0100 @@ -11,10 +11,10 @@ " MessageNode subclass:#UnaryNode - instanceVariableNames:'' - classVariableNames:'' - poolDictionaries:'' - category:'System-Compiler-Support' + instanceVariableNames:'' + classVariableNames:'' + poolDictionaries:'' + category:'System-Compiler-Support' ! !UnaryNode class methodsFor:'documentation'! @@ -33,14 +33,14 @@ " ! -version - ^ '$Header: /cvs/stx/stx/libcomp/UnaryNode.st,v 1.17 1995-11-11 15:31:42 cg Exp $' -! - documentation " node for parse-trees, representing unary messages " +! + +version + ^ '$Header: /cvs/stx/stx/libcomp/UnaryNode.st,v 1.18 1995-11-23 02:15:16 cg Exp $' ! ! !UnaryNode class methodsFor:'instance creation'! @@ -139,13 +139,6 @@ ^ (self basicNew) receiver:r selector:selectorString args:nil lineno:0 ! ! -!UnaryNode methodsFor:'queries'! - -isUnaryMessage - "return true, if this node is one for a unary message" - ^ true -! ! - !UnaryNode methodsFor:'checks'! plausibilityCheck @@ -167,17 +160,6 @@ ^ nil ! ! -!UnaryNode methodsFor:'evaluating'! - -evaluate - "evaluate the expression represented by the receiver" - - receiver isSuper ifTrue:[ - ^ super evaluate - ]. - ^ (receiver evaluate) perform:selector -! ! - !UnaryNode methodsFor:'code generation'! codeOn:aStream inBlock:b for:aCompiler @@ -223,6 +205,17 @@ ^ super codeOn:aStream inBlock:b for:aCompiler ! ! +!UnaryNode methodsFor:'evaluating'! + +evaluate + "evaluate the expression represented by the receiver" + + receiver isSuper ifTrue:[ + ^ super evaluate + ]. + ^ (receiver evaluate) perform:selector +! ! + !UnaryNode methodsFor:'printing'! printOn:aStream indent:i @@ -247,3 +240,11 @@ selector printString printOn:aStream. " aStream space. " ! ! + +!UnaryNode methodsFor:'queries'! + +isUnaryMessage + "return true, if this node is one for a unary message" + ^ true +! ! + diff -r 65eaf1a009f5 -r 1ef1d1395146 UndefVar.st --- a/UndefVar.st Sat Nov 18 17:59:14 1995 +0100 +++ b/UndefVar.st Thu Nov 23 03:15:59 1995 +0100 @@ -11,10 +11,10 @@ " Object subclass:#UndefinedVariable - instanceVariableNames:'name' - classVariableNames:'' - poolDictionaries:'' - category:'System-Compiler-Support' + instanceVariableNames:'name' + classVariableNames:'' + poolDictionaries:'' + category:'System-Compiler-Support' ! !UndefinedVariable class methodsFor:'documentation'! @@ -33,10 +33,6 @@ " ! -version - ^ '$Header: /cvs/stx/stx/libcomp/Attic/UndefVar.st,v 1.8 1995-11-11 15:31:44 cg Exp $' -! - documentation " node for parse-trees, representing undefined variables @@ -47,6 +43,10 @@ The error message will then be 'UndefinedVariable ...' instead of 'UndefineObject ...', which is somewhat more informative. " +! + +version + ^ '$Header: /cvs/stx/stx/libcomp/Attic/UndefVar.st,v 1.9 1995-11-23 02:15:29 cg Exp $' ! ! !UndefinedVariable class methodsFor:'instance creation'! @@ -55,38 +55,6 @@ ^ (self basicNew) setName:aString ! ! -!UndefinedVariable methodsFor:'error reporting'! - -methodError - self error:('trying to define methods for undefined class: ', name) -! - -subclassingError - self error:('trying to create subclass of undefined class: ', name) -! ! - -!UndefinedVariable methodsFor:'file skipping'! - -fileInFrom:aStream notifying:someOne passChunk:passChunk - "this is sent, if you continue after a warning about - methods for undefined class. - It simply skips chunks and sends a warning to the Transcript." - - |aString done| - - done := false. - [done] whileFalse:[ - done := aStream atEnd. - done ifFalse:[ - aString := aStream nextChunk. - done := aString isNil or:[aString isEmpty]. - done ifFalse:[ - Transcript showCr:'*** skipping method for undefined class: ' , name - ] - ] - ]. -! ! - !UndefinedVariable methodsFor:'catching messages'! class @@ -124,10 +92,36 @@ self subclassingError ! ! -!UndefinedVariable methodsFor:'private accessing'! +!UndefinedVariable methodsFor:'error reporting'! + +methodError + self error:('trying to define methods for undefined class: ', name) +! + +subclassingError + self error:('trying to create subclass of undefined class: ', name) +! ! + +!UndefinedVariable methodsFor:'file skipping'! -setName:aString - name := aString +fileInFrom:aStream notifying:someOne passChunk:passChunk + "this is sent, if you continue after a warning about + methods for undefined class. + It simply skips chunks and sends a warning to the Transcript." + + |aString done| + + done := false. + [done] whileFalse:[ + done := aStream atEnd. + done ifFalse:[ + aString := aStream nextChunk. + done := aString isNil or:[aString isEmpty]. + done ifFalse:[ + Transcript showCr:'*** skipping method for undefined class: ' , name + ] + ] + ]. ! ! !UndefinedVariable methodsFor:'printing & storing'! @@ -137,3 +131,10 @@ ^ 'UndefinedVariable(' , name , ')' ! ! + +!UndefinedVariable methodsFor:'private accessing'! + +setName:aString + name := aString +! ! + diff -r 65eaf1a009f5 -r 1ef1d1395146 UndefinedVariable.st --- a/UndefinedVariable.st Sat Nov 18 17:59:14 1995 +0100 +++ b/UndefinedVariable.st Thu Nov 23 03:15:59 1995 +0100 @@ -11,10 +11,10 @@ " Object subclass:#UndefinedVariable - instanceVariableNames:'name' - classVariableNames:'' - poolDictionaries:'' - category:'System-Compiler-Support' + instanceVariableNames:'name' + classVariableNames:'' + poolDictionaries:'' + category:'System-Compiler-Support' ! !UndefinedVariable class methodsFor:'documentation'! @@ -33,10 +33,6 @@ " ! -version - ^ '$Header: /cvs/stx/stx/libcomp/UndefinedVariable.st,v 1.8 1995-11-11 15:31:44 cg Exp $' -! - documentation " node for parse-trees, representing undefined variables @@ -47,6 +43,10 @@ The error message will then be 'UndefinedVariable ...' instead of 'UndefineObject ...', which is somewhat more informative. " +! + +version + ^ '$Header: /cvs/stx/stx/libcomp/UndefinedVariable.st,v 1.9 1995-11-23 02:15:29 cg Exp $' ! ! !UndefinedVariable class methodsFor:'instance creation'! @@ -55,38 +55,6 @@ ^ (self basicNew) setName:aString ! ! -!UndefinedVariable methodsFor:'error reporting'! - -methodError - self error:('trying to define methods for undefined class: ', name) -! - -subclassingError - self error:('trying to create subclass of undefined class: ', name) -! ! - -!UndefinedVariable methodsFor:'file skipping'! - -fileInFrom:aStream notifying:someOne passChunk:passChunk - "this is sent, if you continue after a warning about - methods for undefined class. - It simply skips chunks and sends a warning to the Transcript." - - |aString done| - - done := false. - [done] whileFalse:[ - done := aStream atEnd. - done ifFalse:[ - aString := aStream nextChunk. - done := aString isNil or:[aString isEmpty]. - done ifFalse:[ - Transcript showCr:'*** skipping method for undefined class: ' , name - ] - ] - ]. -! ! - !UndefinedVariable methodsFor:'catching messages'! class @@ -124,10 +92,36 @@ self subclassingError ! ! -!UndefinedVariable methodsFor:'private accessing'! +!UndefinedVariable methodsFor:'error reporting'! + +methodError + self error:('trying to define methods for undefined class: ', name) +! + +subclassingError + self error:('trying to create subclass of undefined class: ', name) +! ! + +!UndefinedVariable methodsFor:'file skipping'! -setName:aString - name := aString +fileInFrom:aStream notifying:someOne passChunk:passChunk + "this is sent, if you continue after a warning about + methods for undefined class. + It simply skips chunks and sends a warning to the Transcript." + + |aString done| + + done := false. + [done] whileFalse:[ + done := aStream atEnd. + done ifFalse:[ + aString := aStream nextChunk. + done := aString isNil or:[aString isEmpty]. + done ifFalse:[ + Transcript showCr:'*** skipping method for undefined class: ' , name + ] + ] + ]. ! ! !UndefinedVariable methodsFor:'printing & storing'! @@ -137,3 +131,10 @@ ^ 'UndefinedVariable(' , name , ')' ! ! + +!UndefinedVariable methodsFor:'private accessing'! + +setName:aString + name := aString +! ! + diff -r 65eaf1a009f5 -r 1ef1d1395146 VarNode.st --- a/VarNode.st Sat Nov 18 17:59:14 1995 +0100 +++ b/VarNode.st Thu Nov 23 03:15:59 1995 +0100 @@ -11,10 +11,10 @@ " PrimaryNode subclass:#VariableNode - instanceVariableNames:'name token selfValue selfClass index block' - classVariableNames:'' - poolDictionaries:'' - category:'System-Compiler-Support' + instanceVariableNames:'name token selfValue selfClass index block' + classVariableNames:'' + poolDictionaries:'' + category:'System-Compiler-Support' ! !VariableNode class methodsFor:'documentation'! @@ -33,26 +33,18 @@ " ! -version - ^ '$Header: /cvs/stx/stx/libcomp/Attic/VarNode.st,v 1.12 1995-11-11 15:31:46 cg Exp $' -! - documentation " node for parse-trees, representing variables " +! + +version + ^ '$Header: /cvs/stx/stx/libcomp/Attic/VarNode.st,v 1.13 1995-11-23 02:15:59 cg Exp $' ! ! !VariableNode class methodsFor:'instance creation'! -type:t token:tok - ^ (self basicNew) type:t token:tok -! - -type:t name:n - ^ (self basicNew) type:t name:n -! - type:t class:class name:n ^ (self basicNew) type:t class:class name:n ! @@ -61,24 +53,32 @@ ^ (self basicNew) type:t index:i selfValue:s ! -type:t name:n value:val - ^ (self basicNew) type:t name:n value:val +type:t name:n + ^ (self basicNew) type:t name:n +! + +type:t name:n index:i selfClass:s + ^ (self basicNew) type:t name:n index:i selfClass:s +! + +type:t name:n index:i selfValue:s + ^ (self basicNew) type:t name:n index:i selfValue:s ! type:t name:n token:tok index:i ^ (self basicNew) type:t name:n token:tok index:i ! -type:t name:n index:i selfValue:s - ^ (self basicNew) type:t name:n index:i selfValue:s +type:t name:n token:tok index:i block:b + ^ (self basicNew) type:t name:n token:tok index:i block:b ! -type:t name:n index:i selfClass:s - ^ (self basicNew) type:t name:n index:i selfClass:s +type:t name:n value:val + ^ (self basicNew) type:t name:n value:val ! -type:t name:n token:tok index:i block:b - ^ (self basicNew) type:t name:n token:tok index:i block:b +type:t token:tok + ^ (self basicNew) type:t token:tok ! type:t token:tok index:i @@ -89,38 +89,21 @@ ^ (self basicNew) type:t token:tok index:i block:b ! ! -!VariableNode methodsFor:'queries'! - -isGlobal - "return true, if this is a node for a global variable" - - ^ (type == #GlobalVariable) and:[Smalltalk includesKey:name] -! ! - !VariableNode methodsFor:'accessing'! -type:t token:tok - type := t. - token := tok +index + ^ index ! -type:t token:tok index:i - type := t. - index := i. - token := tok +name + ^ name ! -type:t token:tok index:i block:b - type := t. - index := i. - block := b. - token := tok -! - -type:t name:n +type:t class:class name:n type := t. value := nil. - name := n + name := n. + selfClass := class ! type:t index:i selfValue:s @@ -130,24 +113,9 @@ selfValue := s ! -type:t class:class name:n +type:t name:n type := t. value := nil. - name := n. - selfClass := class -! - -type:t name:n value:val - type := t. - name := n. - value := val -! - -type:t name:n index:i selfValue:s - type := t. - value := nil. - index := i. - selfValue := s. name := n ! @@ -159,6 +127,14 @@ name := n ! +type:t name:n index:i selfValue:s + type := t. + value := nil. + index := i. + selfValue := s. + name := n +! + type:t name:n token:tok index:i type := t. index := i. @@ -174,70 +150,28 @@ name := n ! -name - ^ name +type:t name:n value:val + type := t. + name := n. + value := val +! + +type:t token:tok + type := t. + token := tok ! -index - ^ index -! ! - -!VariableNode methodsFor:'evaluating'! - -evaluate - (type == #MethodVariable - or:[type == #BlockArg - or:[type == #BlockVariable]]) ifTrue:[ - ^ token variableValue - ]. - (type == #InstanceVariable) ifTrue:[ - ^ selfValue instVarAt:index - ]. - (type == #GlobalVariable) ifTrue:[ - (Smalltalk includesKey:name) ifTrue:[ - ^ Smalltalk at:name - ]. -" - self error:('global ' , name , ' is undefined'). -" - - ^ UndefinedVariable name:name. - ^ nil - ]. - (type == #ClassVariable) ifTrue:[ - ^ Smalltalk at:(selfClass name , ':' , name) asSymbol - ]. - (type == #ClassInstanceVariable) ifTrue:[ - ^ selfClass instVarAt:index - ]. - (type == #ThisContext) ifTrue:[ - ^ thisContext - ]. - "not reached" - self halt:'bad type'. - ^ value +type:t token:tok index:i + type := t. + index := i. + token := tok ! -store:aValue - (type == #MethodVariable - or:[type == #BlockVariable]) ifTrue:[ - token value:aValue. ^ aValue - ]. - (type == #InstanceVariable) ifTrue:[ - ^ selfValue instVarAt:index put:aValue - ]. - (type == #GlobalVariable) ifTrue:[ - ^ Smalltalk at:name put:aValue - ]. - (type == #ClassVariable) ifTrue:[ - ^ Smalltalk at:(selfClass name , ':' , name) asSymbol put:aValue - ]. - (type == #ClassInstanceVariable) ifTrue:[ - ^ selfClass instVarAt:index put:aValue - ]. - "not reached" - self halt:'bad type'. - ^ aValue +type:t token:tok index:i block:b + type := t. + index := i. + block := b. + token := tok ! ! !VariableNode methodsFor:'code generation'! @@ -454,6 +388,64 @@ ^ self error:'bad assignment' ! ! +!VariableNode methodsFor:'evaluating'! + +evaluate + (type == #MethodVariable + or:[type == #BlockArg + or:[type == #BlockVariable]]) ifTrue:[ + ^ token variableValue + ]. + (type == #InstanceVariable) ifTrue:[ + ^ selfValue instVarAt:index + ]. + (type == #GlobalVariable) ifTrue:[ + (Smalltalk includesKey:name) ifTrue:[ + ^ Smalltalk at:name + ]. +" + self error:('global ' , name , ' is undefined'). +" + + ^ UndefinedVariable name:name. + ^ nil + ]. + (type == #ClassVariable) ifTrue:[ + ^ Smalltalk at:(selfClass name , ':' , name) asSymbol + ]. + (type == #ClassInstanceVariable) ifTrue:[ + ^ selfClass instVarAt:index + ]. + (type == #ThisContext) ifTrue:[ + ^ thisContext + ]. + "not reached" + self halt:'bad type'. + ^ value +! + +store:aValue + (type == #MethodVariable + or:[type == #BlockVariable]) ifTrue:[ + token value:aValue. ^ aValue + ]. + (type == #InstanceVariable) ifTrue:[ + ^ selfValue instVarAt:index put:aValue + ]. + (type == #GlobalVariable) ifTrue:[ + ^ Smalltalk at:name put:aValue + ]. + (type == #ClassVariable) ifTrue:[ + ^ Smalltalk at:(selfClass name , ':' , name) asSymbol put:aValue + ]. + (type == #ClassInstanceVariable) ifTrue:[ + ^ selfClass instVarAt:index put:aValue + ]. + "not reached" + self halt:'bad type'. + ^ aValue +! ! + !VariableNode methodsFor:'printing'! displayString @@ -478,3 +470,12 @@ "not reached" self halt:'bad type'. ! ! + +!VariableNode methodsFor:'queries'! + +isGlobal + "return true, if this is a node for a global variable" + + ^ (type == #GlobalVariable) and:[Smalltalk includesKey:name] +! ! + diff -r 65eaf1a009f5 -r 1ef1d1395146 Variable.st --- a/Variable.st Sat Nov 18 17:59:14 1995 +0100 +++ b/Variable.st Thu Nov 23 03:15:59 1995 +0100 @@ -11,10 +11,10 @@ " Object subclass:#Variable - instanceVariableNames:'value name used' - classVariableNames: '' - poolDictionaries:'' - category:'System-Compiler-Support' + instanceVariableNames:'value name used' + classVariableNames:'' + poolDictionaries:'' + category:'System-Compiler-Support' ! !Variable class methodsFor:'documentation'! @@ -33,14 +33,14 @@ " ! -version - ^ '$Header: /cvs/stx/stx/libcomp/Variable.st,v 1.9 1995-11-11 15:31:47 cg Exp $' -! - documentation " node for parse-trees, representing variables " +! + +version + ^ '$Header: /cvs/stx/stx/libcomp/Variable.st,v 1.10 1995-11-23 02:15:47 cg Exp $' ! ! !Variable class methodsFor:'instance creation'! @@ -52,10 +52,10 @@ !Variable methodsFor:'accessing'! -value:v - "set the value of the (simulated) variable" +name + "return the name of the variable" - value := v + ^ name ! name:aString @@ -64,10 +64,16 @@ name := aString ! -name - "return the name of the variable" +used + "return the flag marking that this variable has been used" - ^ name + ^ used +! + +used:aBoolean + "set/clear the flag marking that this variable has been used" + + used := aBoolean ! value @@ -76,20 +82,15 @@ ^ value ! +value:v + "set the value of the (simulated) variable" + + value := v +! + variableValue "return the value of the variable" ^ value -! - -used:aBoolean - "set/clear the flag marking that this variable has been used" +! ! - used := aBoolean -! - -used - "return the flag marking that this variable has been used" - - ^ used -! ! diff -r 65eaf1a009f5 -r 1ef1d1395146 VariableNode.st --- a/VariableNode.st Sat Nov 18 17:59:14 1995 +0100 +++ b/VariableNode.st Thu Nov 23 03:15:59 1995 +0100 @@ -11,10 +11,10 @@ " PrimaryNode subclass:#VariableNode - instanceVariableNames:'name token selfValue selfClass index block' - classVariableNames:'' - poolDictionaries:'' - category:'System-Compiler-Support' + instanceVariableNames:'name token selfValue selfClass index block' + classVariableNames:'' + poolDictionaries:'' + category:'System-Compiler-Support' ! !VariableNode class methodsFor:'documentation'! @@ -33,26 +33,18 @@ " ! -version - ^ '$Header: /cvs/stx/stx/libcomp/VariableNode.st,v 1.12 1995-11-11 15:31:46 cg Exp $' -! - documentation " node for parse-trees, representing variables " +! + +version + ^ '$Header: /cvs/stx/stx/libcomp/VariableNode.st,v 1.13 1995-11-23 02:15:59 cg Exp $' ! ! !VariableNode class methodsFor:'instance creation'! -type:t token:tok - ^ (self basicNew) type:t token:tok -! - -type:t name:n - ^ (self basicNew) type:t name:n -! - type:t class:class name:n ^ (self basicNew) type:t class:class name:n ! @@ -61,24 +53,32 @@ ^ (self basicNew) type:t index:i selfValue:s ! -type:t name:n value:val - ^ (self basicNew) type:t name:n value:val +type:t name:n + ^ (self basicNew) type:t name:n +! + +type:t name:n index:i selfClass:s + ^ (self basicNew) type:t name:n index:i selfClass:s +! + +type:t name:n index:i selfValue:s + ^ (self basicNew) type:t name:n index:i selfValue:s ! type:t name:n token:tok index:i ^ (self basicNew) type:t name:n token:tok index:i ! -type:t name:n index:i selfValue:s - ^ (self basicNew) type:t name:n index:i selfValue:s +type:t name:n token:tok index:i block:b + ^ (self basicNew) type:t name:n token:tok index:i block:b ! -type:t name:n index:i selfClass:s - ^ (self basicNew) type:t name:n index:i selfClass:s +type:t name:n value:val + ^ (self basicNew) type:t name:n value:val ! -type:t name:n token:tok index:i block:b - ^ (self basicNew) type:t name:n token:tok index:i block:b +type:t token:tok + ^ (self basicNew) type:t token:tok ! type:t token:tok index:i @@ -89,38 +89,21 @@ ^ (self basicNew) type:t token:tok index:i block:b ! ! -!VariableNode methodsFor:'queries'! - -isGlobal - "return true, if this is a node for a global variable" - - ^ (type == #GlobalVariable) and:[Smalltalk includesKey:name] -! ! - !VariableNode methodsFor:'accessing'! -type:t token:tok - type := t. - token := tok +index + ^ index ! -type:t token:tok index:i - type := t. - index := i. - token := tok +name + ^ name ! -type:t token:tok index:i block:b - type := t. - index := i. - block := b. - token := tok -! - -type:t name:n +type:t class:class name:n type := t. value := nil. - name := n + name := n. + selfClass := class ! type:t index:i selfValue:s @@ -130,24 +113,9 @@ selfValue := s ! -type:t class:class name:n +type:t name:n type := t. value := nil. - name := n. - selfClass := class -! - -type:t name:n value:val - type := t. - name := n. - value := val -! - -type:t name:n index:i selfValue:s - type := t. - value := nil. - index := i. - selfValue := s. name := n ! @@ -159,6 +127,14 @@ name := n ! +type:t name:n index:i selfValue:s + type := t. + value := nil. + index := i. + selfValue := s. + name := n +! + type:t name:n token:tok index:i type := t. index := i. @@ -174,70 +150,28 @@ name := n ! -name - ^ name +type:t name:n value:val + type := t. + name := n. + value := val +! + +type:t token:tok + type := t. + token := tok ! -index - ^ index -! ! - -!VariableNode methodsFor:'evaluating'! - -evaluate - (type == #MethodVariable - or:[type == #BlockArg - or:[type == #BlockVariable]]) ifTrue:[ - ^ token variableValue - ]. - (type == #InstanceVariable) ifTrue:[ - ^ selfValue instVarAt:index - ]. - (type == #GlobalVariable) ifTrue:[ - (Smalltalk includesKey:name) ifTrue:[ - ^ Smalltalk at:name - ]. -" - self error:('global ' , name , ' is undefined'). -" - - ^ UndefinedVariable name:name. - ^ nil - ]. - (type == #ClassVariable) ifTrue:[ - ^ Smalltalk at:(selfClass name , ':' , name) asSymbol - ]. - (type == #ClassInstanceVariable) ifTrue:[ - ^ selfClass instVarAt:index - ]. - (type == #ThisContext) ifTrue:[ - ^ thisContext - ]. - "not reached" - self halt:'bad type'. - ^ value +type:t token:tok index:i + type := t. + index := i. + token := tok ! -store:aValue - (type == #MethodVariable - or:[type == #BlockVariable]) ifTrue:[ - token value:aValue. ^ aValue - ]. - (type == #InstanceVariable) ifTrue:[ - ^ selfValue instVarAt:index put:aValue - ]. - (type == #GlobalVariable) ifTrue:[ - ^ Smalltalk at:name put:aValue - ]. - (type == #ClassVariable) ifTrue:[ - ^ Smalltalk at:(selfClass name , ':' , name) asSymbol put:aValue - ]. - (type == #ClassInstanceVariable) ifTrue:[ - ^ selfClass instVarAt:index put:aValue - ]. - "not reached" - self halt:'bad type'. - ^ aValue +type:t token:tok index:i block:b + type := t. + index := i. + block := b. + token := tok ! ! !VariableNode methodsFor:'code generation'! @@ -454,6 +388,64 @@ ^ self error:'bad assignment' ! ! +!VariableNode methodsFor:'evaluating'! + +evaluate + (type == #MethodVariable + or:[type == #BlockArg + or:[type == #BlockVariable]]) ifTrue:[ + ^ token variableValue + ]. + (type == #InstanceVariable) ifTrue:[ + ^ selfValue instVarAt:index + ]. + (type == #GlobalVariable) ifTrue:[ + (Smalltalk includesKey:name) ifTrue:[ + ^ Smalltalk at:name + ]. +" + self error:('global ' , name , ' is undefined'). +" + + ^ UndefinedVariable name:name. + ^ nil + ]. + (type == #ClassVariable) ifTrue:[ + ^ Smalltalk at:(selfClass name , ':' , name) asSymbol + ]. + (type == #ClassInstanceVariable) ifTrue:[ + ^ selfClass instVarAt:index + ]. + (type == #ThisContext) ifTrue:[ + ^ thisContext + ]. + "not reached" + self halt:'bad type'. + ^ value +! + +store:aValue + (type == #MethodVariable + or:[type == #BlockVariable]) ifTrue:[ + token value:aValue. ^ aValue + ]. + (type == #InstanceVariable) ifTrue:[ + ^ selfValue instVarAt:index put:aValue + ]. + (type == #GlobalVariable) ifTrue:[ + ^ Smalltalk at:name put:aValue + ]. + (type == #ClassVariable) ifTrue:[ + ^ Smalltalk at:(selfClass name , ':' , name) asSymbol put:aValue + ]. + (type == #ClassInstanceVariable) ifTrue:[ + ^ selfClass instVarAt:index put:aValue + ]. + "not reached" + self halt:'bad type'. + ^ aValue +! ! + !VariableNode methodsFor:'printing'! displayString @@ -478,3 +470,12 @@ "not reached" self halt:'bad type'. ! ! + +!VariableNode methodsFor:'queries'! + +isGlobal + "return true, if this is a node for a global variable" + + ^ (type == #GlobalVariable) and:[Smalltalk includesKey:name] +! ! +