--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/AssignNd.st Fri Jul 16 11:38:57 1993 +0200
@@ -0,0 +1,93 @@
+"
+ COPYRIGHT (c) 1989-93 by Claus Gittinger
+ All Rights Reserved
+
+ This software is furnished under a license and may be used
+ only in accordance with the terms of that license and with the
+ inclusion of the above copyright notice. This software may not
+ be provided or otherwise made available to, or used by, any
+ other person. No title to or ownership of the software is
+ hereby transferred.
+"
+
+ParseNode subclass:#AssignmentNode
+ instanceVariableNames:'variable expression'
+ classVariableNames:''
+ poolDictionaries:''
+ category:'System-Compiler-Support'
+!
+
+AssignmentNode comment:'
+
+COPYRIGHT (c) 1989-93 by Claus Gittinger
+ All Rights Reserved
+
+%W% %E%
+'!
+
+!AssignmentNode class methodsFor:'instance creation'!
+
+variable:v expression:e
+ ^ (self basicNew) variable:v expression:e
+! !
+
+!AssignmentNode methodsFor:'evaluating'!
+
+evaluate
+ |value|
+ value := expression evaluate.
+ variable store:value.
+ ^ value
+! !
+
+!AssignmentNode methodsFor:'accessing'!
+
+variable:v expression:e
+ variable := v.
+ expression := e
+! !
+
+!AssignmentNode methodsFor:'code generation'!
+
+codeForSideEffectOn:aStream inBlock:b
+ |sel arg|
+
+ (variable type == #MethodVariable) ifTrue:[
+ expression isBinaryMessage ifTrue:[
+ sel := expression selector.
+ ((sel == #+) or:[sel == #-]) ifTrue:[
+ (expression receiver type == #MethodVariable) ifTrue:[
+ (expression receiver index == variable index) ifTrue:[
+ arg := expression arg1.
+ arg isConstant ifTrue:[
+ (arg value == 1) ifTrue:[
+ (sel == #+) ifTrue:[
+ aStream nextPut:#incMethodVar
+ ] ifFalse:[
+ aStream nextPut:#decMethodVar
+ ].
+ aStream nextPut:(variable index).
+ ^ self
+ ]
+ ]
+ ]
+ ]
+ ]
+ ]
+ ].
+ expression codeOn:aStream inBlock:b.
+ variable codeStoreOn:aStream inBlock:b valueNeeded:false
+!
+
+codeOn:aStream inBlock:b
+ expression codeOn:aStream inBlock:b.
+ variable codeStoreOn:aStream inBlock:b valueNeeded:true
+! !
+
+!AssignmentNode methodsFor:'printing'!
+
+printOn:aStream indent:i
+ variable printOn:aStream.
+ aStream nextPutAll:' := '.
+ expression printOn:aStream
+! !
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/AssignmentNode.st Fri Jul 16 11:38:57 1993 +0200
@@ -0,0 +1,93 @@
+"
+ COPYRIGHT (c) 1989-93 by Claus Gittinger
+ All Rights Reserved
+
+ This software is furnished under a license and may be used
+ only in accordance with the terms of that license and with the
+ inclusion of the above copyright notice. This software may not
+ be provided or otherwise made available to, or used by, any
+ other person. No title to or ownership of the software is
+ hereby transferred.
+"
+
+ParseNode subclass:#AssignmentNode
+ instanceVariableNames:'variable expression'
+ classVariableNames:''
+ poolDictionaries:''
+ category:'System-Compiler-Support'
+!
+
+AssignmentNode comment:'
+
+COPYRIGHT (c) 1989-93 by Claus Gittinger
+ All Rights Reserved
+
+%W% %E%
+'!
+
+!AssignmentNode class methodsFor:'instance creation'!
+
+variable:v expression:e
+ ^ (self basicNew) variable:v expression:e
+! !
+
+!AssignmentNode methodsFor:'evaluating'!
+
+evaluate
+ |value|
+ value := expression evaluate.
+ variable store:value.
+ ^ value
+! !
+
+!AssignmentNode methodsFor:'accessing'!
+
+variable:v expression:e
+ variable := v.
+ expression := e
+! !
+
+!AssignmentNode methodsFor:'code generation'!
+
+codeForSideEffectOn:aStream inBlock:b
+ |sel arg|
+
+ (variable type == #MethodVariable) ifTrue:[
+ expression isBinaryMessage ifTrue:[
+ sel := expression selector.
+ ((sel == #+) or:[sel == #-]) ifTrue:[
+ (expression receiver type == #MethodVariable) ifTrue:[
+ (expression receiver index == variable index) ifTrue:[
+ arg := expression arg1.
+ arg isConstant ifTrue:[
+ (arg value == 1) ifTrue:[
+ (sel == #+) ifTrue:[
+ aStream nextPut:#incMethodVar
+ ] ifFalse:[
+ aStream nextPut:#decMethodVar
+ ].
+ aStream nextPut:(variable index).
+ ^ self
+ ]
+ ]
+ ]
+ ]
+ ]
+ ]
+ ].
+ expression codeOn:aStream inBlock:b.
+ variable codeStoreOn:aStream inBlock:b valueNeeded:false
+!
+
+codeOn:aStream inBlock:b
+ expression codeOn:aStream inBlock:b.
+ variable codeStoreOn:aStream inBlock:b valueNeeded:true
+! !
+
+!AssignmentNode methodsFor:'printing'!
+
+printOn:aStream indent:i
+ variable printOn:aStream.
+ aStream nextPutAll:' := '.
+ expression printOn:aStream
+! !
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/BCompiler.st Fri Jul 16 11:38:57 1993 +0200
@@ -0,0 +1,1447 @@
+"
+ COPYRIGHT (c) 1989-93 by Claus Gittinger
+ All Rights Reserved
+
+ This software is furnished under a license and may be used
+ only in accordance with the terms of that license and with the
+ inclusion of the above copyright notice. This software may not
+ be provided or otherwise made available to, or used by, any
+ other person. No title to or ownership of the software is
+ hereby transferred.
+"
+
+Parser subclass:#ByteCodeCompiler
+ instanceVariableNames:'code codeIndex
+ litArray
+ stackDelta extra lineno
+ maxStackDepth
+ relocList'
+ classVariableNames:''
+ poolDictionaries:''
+ category:'System-Compiler'
+!
+
+ByteCodeCompiler comment:'
+
+COPYRIGHT (c) 1989-93 by Claus Gittinger
+ All Rights Reserved
+
+This class defines how compilation into ByteCodes is done.
+First, parsing is done using superclass methods,
+then the parse-tree is converted into an array of symbolic codes
+and a relocation table;
+these two are finally combined into a byteArray of the codes.
+
+There are many dependancies to the run-time-system (especially the
+interpreter) in here - be careful when playing around ...
+
+Instance variables:
+
+code <ByteArry> bytecodes
+codeIndex <SmallInteger> next index to put into code array
+litArray <OrderedCollection> literals
+stackDelta <SmallInteger> return value of byteCodeFor:
+extra <Symbol> return value of byteCodeFor:
+maxStackDepth <SmallInteger> stack need of method
+relocList <Array> used temporary for relocation
+
+%W% %E%
+'!
+
+!ByteCodeCompiler class methodsFor:'compiling methods'!
+
+compile:methodText forClass:classToCompileFor
+ "compile a source-string for a method in classToCompileFor"
+
+ ^ self compile:methodText
+ forClass:classToCompileFor
+ inCategory:'others'
+ notifying:nil
+ install:true
+ skipIfSame:false
+!
+
+compile:aString forClass:aClass inCategory:cat
+ "compile a source-string for a method in classToCompileFor.
+ The method will get cat as category"
+
+ ^ self compile:aString
+ forClass:aClass
+ inCategory:cat
+ notifying:nil
+ install:true
+ skipIfSame:false
+!
+
+compile:methodText forClass:classToCompileFor notifying:someOne
+ "compile a source-string for a method in classToCompileFor.
+ errors are forwarded to someOne."
+
+ ^ self compile:methodText
+ forClass:classToCompileFor
+ inCategory:'others'
+ notifying:someOne
+ install:true
+ skipIfSame:false
+!
+
+compile:aString forClass:aClass inCategory:cat notifying:someOne
+ "compile a source-string for a method in classToCompileFor.
+ errors are forwarded to someOne.
+ The method will get cat as category"
+
+ ^ self compile:aString
+ forClass:aClass
+ inCategory:cat
+ notifying:someOne
+ install:true
+ skipIfSame:false
+!
+
+compile:aString forClass:aClass inCategory:cat notifying:someOne
+ install:install
+ ^ self compile:aString
+ forClass:aClass
+ inCategory:cat
+ notifying:someOne
+ install:true
+ skipIfSame:false
+!
+
+compile:aString forClass:aClass inCategory:cat notifying:someOne
+ install:install skipIfSame:skipIfSame
+
+ "the basic workhorse method for compiling.
+ compile a source-string for a method in classToCompileFor.
+ errors are forwarded to someOne (report on Transcript and return
+ #Error, if someOne is nil).
+
+ The new method will get cat as category. If install is true, the method
+ will go into the classes method-table, otherwise the method is simply
+ returned (for anonymous methods).
+ If skipIsSame is true, and the source is the same as an existing
+ methods source, this is a noop (for fast fileIn)."
+
+ |compiler newMethod tree lits machineCode
+ symbolicCodeArray sharedCode sharedCodeSymbol oldMethod|
+
+ aString isNil ifTrue:[^ nil].
+
+ "create a compiler, let it parse and create the parsetree"
+
+ compiler := self for:(ReadStream on:aString).
+ compiler setClassToCompileFor:aClass.
+ compiler notifying:someOne.
+
+ compiler nextToken.
+ (compiler parseMethodSpec == #Error) ifTrue:[
+ tree := #Error
+ ] ifFalse:[
+ "check if same source"
+ (skipIfSame and:[compiler selector notNil]) ifTrue:[
+ oldMethod := aClass compiledMethodAt:(compiler selector).
+ oldMethod notNil ifTrue:[
+ oldMethod source = aString ifTrue:[
+ SilentLoading ifFalse:[
+ Transcript showCr:('unchanged: ',aClass name,' ',compiler selector)
+ ].
+ ^ oldMethod
+ ]
+ ]
+ ].
+ tree := compiler parseMethodBody.
+ compiler tree:tree.
+ ].
+
+ (compiler errorFlag or:[tree == #Error]) ifTrue:[
+ compiler selector notNil ifTrue:[
+ Transcript show:(compiler selector,' ')
+ ].
+ Transcript showCr:'syntax error'.
+ ^ #Error
+ ].
+
+ compiler selector isNil ifTrue:[
+ "it was just a comment or other empty stuff"
+ ^ nil
+ ].
+
+ "let it produce symbolic code first"
+
+ symbolicCodeArray := compiler genSymbolicCode.
+ (symbolicCodeArray == #Error) ifTrue:[
+ compiler selector notNil ifTrue:[
+ Transcript show:(compiler selector,' ')
+ ].
+ Transcript showCr:'translation error'.
+ ^ #Error
+ ].
+
+ ((compiler genByteCodeFrom:symbolicCodeArray) == #Error) ifTrue:[
+ compiler selector notNil ifTrue:[
+ Transcript show:(compiler selector,' ')
+ ].
+ Transcript showCr:'relocation error - must be simplified'.
+ ^ #Error
+ ].
+
+ "check for primitive code"
+ compiler primitiveNumber notNil ifTrue:[
+ machineCode := compiler checkForPrimitiveCode:compiler primitiveNumber.
+ machineCode isNil ifTrue:[
+ Transcript showCr:'primitive ', compiler primitiveNumber printString , ' is not supported'.
+ ^ #Error
+ ]
+ ].
+
+ machineCode isNil ifTrue:[
+ "check for shared-code (only trivial methods)"
+
+ sharedCodeSymbol := compiler checkForSharedCode:symbolicCodeArray.
+ sharedCodeSymbol notNil ifTrue:[
+ sharedCode := self sharedCodeFunctionFor:sharedCodeSymbol
+ ].
+
+ "try to make it machine code"
+
+ machineCode := compiler checkForMachineCode:symbolicCodeArray
+ ].
+
+ "finally create the new method-object"
+
+ newMethod := Method new.
+ lits := compiler literalArray.
+ lits notNil ifTrue:[
+ "literals MUST be an array - not just any Collection"
+ lits := Array withAll:lits.
+ newMethod literals:lits
+ ].
+ newMethod byteCode:(compiler code).
+ sharedCode notNil ifTrue:[
+ newMethod code:sharedCode
+ ] ifFalse:[
+ machineCode notNil ifTrue:[
+ newMethod code:machineCode
+ ]
+ ].
+ newMethod source:aString.
+ newMethod category:cat.
+ newMethod numberOfMethodVars:(compiler numberOfMethodVars).
+ newMethod stackSize:(compiler maxStackDepth).
+
+ install ifTrue:[
+ aClass addSelector:(compiler selector) withMethod:newMethod
+ ].
+
+ SilentLoading ifFalse:[
+ Transcript showCr:('compiled: ',aClass name,' ',compiler selector)
+ ].
+
+ ^ newMethod
+! !
+
+!ByteCodeCompiler methodsFor:'accessing'!
+
+literalArray
+ "return the literal array - only valid after parsing"
+
+ ^ litArray
+!
+
+code
+ "return the literal array - only valid after code-generation"
+
+ ^ code
+!
+
+maxStackDepth
+ "return the stack-need of the method - only valid after code-generation"
+
+ ^ maxStackDepth
+! !
+
+!ByteCodeCompiler methodsFor:'code generation'!
+
+genSymbolicCode
+ "traverse the parse-tree producing symbolicCode - return the codeArray"
+
+ |codeStream thisStatement lastStatement|
+
+ codeStream := WriteStream on:(Array new:100).
+ thisStatement := tree.
+ [thisStatement notNil] whileTrue:[
+ lastStatement := thisStatement.
+ thisStatement codeForSideEffectOn:codeStream inBlock:nil.
+ thisStatement := thisStatement nextStatement
+ ].
+ (lastStatement isNil or:[(lastStatement isMemberOf:ReturnNode) not])
+ ifTrue:[
+ "not a return - add retSelf"
+ codeStream nextPut:#retSelf
+ ].
+ ^ codeStream contents
+!
+
+checkForPrimitiveCode:primNr
+ "this was added to allow emulation of (some) ST-80
+ primitives (to fileIn Remote-Package)"
+
+ (primNr == 75) ifTrue:[ ^ (Object compiledMethodAt:#identityHash) code ].
+ (primNr == 110) ifTrue:[ ^ (Object compiledMethodAt:#==) code ].
+ (primNr == 111) ifTrue:[ ^ (Object compiledMethodAt:#class) code ].
+ ^ nil
+!
+
+genByteCodeFrom:symbolicCodeArray
+ "convert symbolicCode into bytecodes"
+
+ |symIndex "<SmallInteger>"
+ codeSize "<SmallInteger>"
+ symCodeSize "<SmallInteger>"
+ index addr
+ codeSymbol nargs done
+ stackDepth relocInfo level nvars|
+
+ symbolicCodeArray isNil ifTrue:[^ self].
+
+ done := false.
+ symCodeSize := symbolicCodeArray size.
+ codeSize := symCodeSize.
+
+ [done] whileFalse:[
+ litArray := nil.
+ stackDepth := 0.
+ maxStackDepth := 0.
+
+ code := ByteArray new:codeSize.
+ relocInfo := Array new:(codeSize + 1).
+ symIndex := 1.
+ codeIndex := 1.
+
+ [symIndex <= symCodeSize] whileTrue:[
+ relocInfo at:symIndex put:codeIndex.
+
+ codeSymbol := symbolicCodeArray at:symIndex.
+ symIndex := symIndex + 1.
+ stackDelta := 0.
+ extra := nil.
+ lineno := false.
+ self appendByteCodeFor:codeSymbol.
+ lineno ifTrue:[
+ self appendByte:((symbolicCodeArray at:symIndex) min:255).
+ symIndex := symIndex + 1
+ ].
+ extra notNil ifTrue:[
+ (extra == #number) ifTrue:[
+ index := symbolicCodeArray at:symIndex.
+ symIndex := symIndex + 1.
+ self appendSignedByte:index
+ ] ifFalse:[
+ (extra == #index) ifTrue:[
+ index := symbolicCodeArray at:symIndex.
+ symIndex := symIndex + 1.
+ self appendByte:index
+ ] ifFalse:[
+ (extra == #lit) ifTrue:[
+ index := self addLiteral:(symbolicCodeArray at:symIndex).
+ symIndex := symIndex + 1.
+ self appendByte:index
+ ] ifFalse:[
+ (extra == #speciallit) ifTrue:[
+ index := self addLiteral:(symbolicCodeArray at:symIndex).
+ symIndex := symIndex + 1.
+ self appendByte:index.
+ self appendByte:0. "space for inline-generation"
+ self appendByte:0. "space for inline-address"
+ self appendByte:0.
+ self appendByte:0.
+ self appendByte:0.
+ symIndex := symIndex + 5
+ ] ifFalse:[
+ (extra == #offset) ifTrue:[
+ relocInfo at:symIndex put:codeIndex.
+ self addReloc:symIndex.
+ symIndex := symIndex + 1.
+ self appendByte:0
+ ] ifFalse:[
+ (extra == #indexLevel) ifTrue:[
+ index := symbolicCodeArray at:symIndex.
+ symIndex := symIndex + 1.
+ self appendByte:index.
+ level := symbolicCodeArray at:symIndex.
+ symIndex := symIndex + 1.
+ self appendByte:level
+ ] ifFalse:[
+ (extra == #offsetNvarNarg) ifTrue:[
+ relocInfo at:symIndex put:codeIndex.
+ self addReloc:symIndex.
+ symIndex := symIndex + 1.
+ self appendByte:0.
+ nvars := symbolicCodeArray at:symIndex.
+ symIndex := symIndex + 1.
+ self appendByte:nvars.
+ level := symbolicCodeArray at:symIndex.
+ symIndex := symIndex + 1.
+ self appendByte:level
+ ] ifFalse:[
+ (extra == #absoffset) ifTrue:[
+ addr := symbolicCodeArray at:symIndex.
+ symIndex := symIndex + 1.
+ self appendByte:(addr bitAnd:16rFF).
+ self appendByte:((addr bitShift:-8) bitAnd:16rFF).
+ ] ifFalse:[
+ self error:'compiler botch'
+ ]
+ ]
+ ]
+ ]
+ ]
+ ]
+ ]
+ ]
+ ].
+ ((codeSymbol == #send) or:[codeSymbol == #superSend]) ifTrue:[
+ index := self addLiteral:(symbolicCodeArray at:symIndex).
+ symIndex := symIndex + 1.
+ nargs := symbolicCodeArray at:symIndex.
+ symIndex := symIndex + 1.
+ self appendByte:nargs.
+ self appendByte:index.
+ (codeSymbol == #superSend) ifTrue:[
+ symIndex := symIndex + 1.
+ index := self addLiteral:(classToCompileFor superclass).
+ self appendByte:index
+ ].
+ stackDelta := nargs negated
+ ] ifFalse:[
+ (codeSymbol == #sendDrop) ifTrue:[
+ index := self addLiteral:(symbolicCodeArray at:symIndex).
+ symIndex := symIndex + 1.
+ nargs := symbolicCodeArray at:symIndex.
+ symIndex := symIndex + 1.
+ self appendByte:nargs.
+ self appendByte:index.
+ stackDelta := (nargs + 1) negated
+ ]
+ ].
+ stackDepth := stackDepth + stackDelta.
+ (stackDepth > maxStackDepth) ifTrue:[
+ maxStackDepth := stackDepth
+ ]
+ ].
+ relocInfo at:symIndex put:codeIndex.
+
+ "relocate - returns true if ok, false if we have to rerun"
+ done := true.
+ relocList notNil ifTrue:[
+ done := self relocateWith:symbolicCodeArray relocInfo:relocInfo.
+ "if returned with false, a relative jump was made into
+ an absolute jump - need to start over with one more byte space"
+ codeSize := codeSize + 1.
+ ].
+ ].
+ "code printNewline."
+ ^ errorFlag
+!
+
+relocateWith:symbolicCodeArray relocInfo:relocInfo
+ "helper for genByteCodeFrom - relocate code using relocInfo.
+ if relocation fails badly (due to long relative jumps) patch
+ symbolicCode to use absolute jumps instead and return false
+ (genByteCodeFrom will then try again). Otherwise return true."
+
+ |delta "<SmallInteger>"
+ codePos "<SmallInteger>"
+ prevCodePos "<SmallInteger>"
+ codeOffset "<SmallInteger>"
+ symOffset opcode dstOpcode jumpTarget
+ jumpCode|
+
+ relocList do:[:sIndex |
+ "have to relocate symCode at index ..."
+ symOffset := symbolicCodeArray at:sIndex.
+ codePos := relocInfo at:sIndex.
+ codeOffset := relocInfo at:symOffset.
+ prevCodePos := codePos - 1.
+ delta := codeOffset - codePos - 1.
+ opcode := code at:prevCodePos.
+
+ "optimize jump to return and jump to jump"
+ (opcode == 54) ifTrue:[
+ "a jump"
+ dstOpcode := symbolicCodeArray at:codeOffset.
+ (#(retSelf retTop retNil retTrue retFalse ret0) includes:dstOpcode) ifTrue:[
+ "a jump to a return - put in the return instead jump"
+ code at:prevCodePos put:(self byteCodeFor:dstOpcode).
+ delta := 0
+ ] ifFalse:[
+ (dstOpcode == #jump) ifTrue:[
+ "jump to jump to be done soon"
+ jumpTarget := symbolicCodeArray at:(codeOffset + 1)
+"
+ .
+ 'jump to jump: ' print. dstOpcode printNewline
+"
+ ]
+ ]
+ ].
+ (delta >= 0) ifTrue:[
+ (delta > 127) ifTrue:[
+ (opcode between:50 and:59) ifFalse:[
+ self error:'invalid code to relocate'
+ ].
+ (delta > 255) ifTrue:[
+ "change jmp into vljmp ..."
+ code at:prevCodePos put:(opcode + 20).
+ delta := delta - 256
+ ] ifFalse:[
+ "change jmp into ljmp ..."
+ code at:prevCodePos put:(opcode + 10).
+ delta := delta - 128
+ ].
+ (delta > 127) ifTrue:[
+ "change symbolic into a jump absolute and fail"
+ jumpCode := symbolicCodeArray at:(sIndex - 1).
+ jumpCode == #jump ifTrue:[
+ symbolicCodeArray at:(sIndex - 1) put:#jumpabs.
+ symbolicCodeArray at:sIndex put:codeOffset.
+ ^ false
+ ].
+ jumpCode == #trueJump ifTrue:[
+ symbolicCodeArray at:(sIndex - 1) put:#trueJumpabs.
+ symbolicCodeArray at:sIndex put:codeOffset.
+ ^ false
+ ].
+ jumpCode == #falseJump ifTrue:[
+ symbolicCodeArray at:(sIndex - 1) put:#falseJumpabs.
+ symbolicCodeArray at:sIndex put:codeOffset.
+ ^ false
+ ].
+ jumpCode == #nilJump ifTrue:[
+ symbolicCodeArray at:(sIndex - 1) put:#nilJumpabs.
+ symbolicCodeArray at:sIndex put:codeOffset.
+ ^ false
+ ].
+ jumpCode == #notNilJump ifTrue:[
+ symbolicCodeArray at:(sIndex - 1) put:#notNilJumpabs.
+ symbolicCodeArray at:sIndex put:codeOffset.
+ ^ false
+ ].
+ jumpCode == #eqJump ifTrue:[
+ symbolicCodeArray at:(sIndex - 1) put:#eqJumpabs.
+ symbolicCodeArray at:sIndex put:codeOffset.
+ ^ false
+ ].
+ jumpCode == #notEqJump ifTrue:[
+ symbolicCodeArray at:(sIndex - 1) put:#notEqJumpabs.
+ symbolicCodeArray at:sIndex put:codeOffset.
+ ^ false
+ ].
+ jumpCode == #zeroJump ifTrue:[
+ symbolicCodeArray at:(sIndex - 1) put:#zeroJumpabs.
+ symbolicCodeArray at:sIndex put:codeOffset.
+ ^ false
+ ].
+ jumpCode == #notZeroJump ifTrue:[
+ symbolicCodeArray at:(sIndex - 1) put:#notZeroJumpabs.
+ symbolicCodeArray at:sIndex put:codeOffset.
+ ^ false
+ ].
+ errorFlag := #Error
+ ]
+ ].
+ code at:codePos put:delta
+ ] ifFalse:[
+ (delta < -128) ifTrue:[
+ (opcode between:50 and:59) ifFalse:[
+ self error:'invalid code to relocate'
+ ].
+ (delta < -256) ifTrue:[
+ "change jmp into vljmp ..."
+ code at:prevCodePos put:(opcode + 20).
+ delta := delta + 256
+ ] ifFalse:[
+ "change jmp into ljmp ..."
+ code at:prevCodePos put:(opcode + 10).
+ delta := delta + 128
+ ].
+ (delta < -128) ifTrue:[
+ jumpCode := symbolicCodeArray at:(sIndex - 1).
+self halt.
+ errorFlag := #Error
+ ]
+ ].
+ code at:codePos put:(256 + delta)
+ ]
+ ].
+ (errorFlag == #Error) ifTrue:[
+ self error:'relocation range error'
+ ].
+ ^ true
+!
+
+addLiteral:anObject
+ "add a literal to the literalArray - watch for and eliminate
+ duplicates. return the index of the literal in the Array"
+
+ |index|
+
+ litArray isNil ifTrue:[
+ litArray := Array with:anObject.
+ ^ 1
+ ].
+ index := litArray identityIndexOf:anObject.
+ (index == 0) ifTrue:[
+ litArray := litArray copyWith:anObject.
+ ^ litArray size
+ ].
+ ^ index
+!
+
+appendByteCodeFor:codeSymbol
+ "append the byteCode for an instructionSymbol to the code-Array"
+
+ code at:codeIndex put:(self byteCodeFor:codeSymbol).
+ codeIndex := codeIndex + 1
+!
+
+appendByte:aByte
+ "append a byte to the code-Array, checking for byte-range (debug-only)"
+
+ (aByte between:0 and:255) ifTrue:[
+ code at:codeIndex put:aByte.
+ codeIndex := codeIndex + 1
+ ] ifFalse:[
+ self error:'byte range error'.
+ errorFlag := #Error
+ ]
+!
+
+appendSignedByte:aByte
+ "append a signedbyte (as in jump-offsets) to the code-Array,
+ check range and report an error if invalid"
+
+ |b "<SmallInteger>" |
+
+ b := aByte.
+ (b >= 0) ifTrue:[
+ (b > 127) ifTrue:[
+ self error:'jump-range error'.
+ errorFlag := #Error
+ ].
+ code at:codeIndex put:b
+ ] ifFalse:[
+ (b < -128) ifTrue:[
+ self error:'jump-range error'.
+ errorFlag := #Error
+ ].
+ code at:codeIndex put:(256 + b)
+ ].
+ codeIndex := codeIndex + 1
+!
+
+addReloc:symIndex
+ "remember to relocate offset at symIndex later ..."
+
+ relocList isNil ifTrue:[
+ relocList := OrderedCollection new.
+ ].
+ relocList add:symIndex
+!
+
+byteCodeFor:aSymbol
+ "given a symbolic instruction, return the corresponding bytecode.
+ as a side-effect, leave number of bytes pushed/popped by this instr.
+ in stackDelta, and, if the instruction needs extra arguments, leave
+ this info in extra"
+
+ "standard bytecodes"
+
+ (aSymbol == #pushNil) ifTrue:[stackDelta := 1. ^ 10].
+ (aSymbol == #pushTrue) ifTrue:[stackDelta := 1. ^ 11].
+ (aSymbol == #pushFalse) ifTrue:[stackDelta := 1. ^ 12].
+ (aSymbol == #pushLit) ifTrue:[stackDelta := 1. extra := #lit. ^ 14].
+ (aSymbol == #pushSelf) ifTrue:[stackDelta := 1. ^ 15].
+ (aSymbol == #pushNum) ifTrue:[stackDelta := 1. extra := #number. ^ 16].
+
+ (aSymbol == #pushMethodArg) ifTrue:[stackDelta := 1. extra := #index. ^ 30].
+ (aSymbol == #pushMethodVar) ifTrue:[stackDelta := 1. extra := #index. ^ 31].
+ (aSymbol == #pushBlockArg) ifTrue:[stackDelta := 1. extra := #index. ^ 32].
+ (aSymbol == #pushBlockVar) ifTrue:[stackDelta := 1. extra := #index. ^ 33].
+ (aSymbol == #pushInstVar) ifTrue:[stackDelta := 1. extra := #index. ^ 34].
+ (aSymbol == #pushOuterBlockArg) ifTrue:[stackDelta := 1.
+ extra := #indexLevel. ^ 42].
+ (aSymbol == #pushOuterBlockVar) ifTrue:[stackDelta := 1.
+ extra := #indexLevel. ^ 128].
+
+ (aSymbol == #storeMethodVar) ifTrue:[extra := #index.
+ stackDelta := -1. ^ 37].
+ (aSymbol == #storeBlockVar) ifTrue:[extra := #index.
+ stackDelta := -1. ^ 38].
+ (aSymbol == #storeInstVar) ifTrue:[extra := #index.
+ stackDelta := -1. ^ 39].
+
+ (aSymbol == #retTop) ifTrue:[stackDelta := -1. ^ 0].
+ (aSymbol == #blockRetTop) ifTrue:[stackDelta := -1. ^ 6].
+
+ (aSymbol == #retSelf) ifTrue:[^5].
+
+ (aSymbol == #==) ifTrue:[stackDelta := -1. self addLiteral:aSymbol. ^ 45].
+ (aSymbol == #~~) ifTrue:[stackDelta := -1. self addLiteral:aSymbol. ^ 46].
+
+ (aSymbol == #falseJump) ifTrue:[stackDelta := -1. extra := #offset. ^ 50].
+ (aSymbol == #trueJump) ifTrue:[stackDelta := -1. extra := #offset. ^ 51].
+ (aSymbol == #nilJump) ifTrue:[stackDelta := -1. extra := #offset. ^ 52].
+ (aSymbol == #notNilJump) ifTrue:[stackDelta := -1. extra := #offset. ^ 53].
+ (aSymbol == #jump) ifTrue:[extra := #offset. ^ 54].
+ (aSymbol == #makeBlock) ifTrue:[stackDelta := 1.
+ extra := #offsetNvarNarg. ^ 55].
+ (aSymbol == #zeroJump) ifTrue:[stackDelta := -1. extra := #offset. ^ 56].
+ (aSymbol == #notZeroJump) ifTrue:[stackDelta := -1. extra := #offset. ^ 57].
+ (aSymbol == #eqJump) ifTrue:[stackDelta := -2. extra := #offset. ^ 58].
+ (aSymbol == #notEqJump) ifTrue:[stackDelta := -2. extra := #offset. ^ 59].
+
+ (aSymbol == #send) ifTrue:[lineno := true. ^ 19].
+ (aSymbol == #superSend) ifTrue:[lineno := true. ^ 20].
+
+ (aSymbol == #drop) ifTrue:[stackDelta := -1. ^ 18].
+ (aSymbol == #dup) ifTrue:[stackDelta := 1. ^ 47].
+
+ (aSymbol == #pushClassVar) ifTrue:[stackDelta := 1. extra := #speciallit. ^ 35].
+ (aSymbol == #pushClassInstVar) ifTrue:[stackDelta := 1. extra := #index. ^ 176].
+ (aSymbol == #pushGlobal) ifTrue:[stackDelta := 1. extra := #speciallit. ^ 36].
+
+ (aSymbol == #storeClassVar) ifTrue:[extra := #speciallit.stackDelta := -1. ^ 40].
+ (aSymbol == #storeClassInstVar) ifTrue:[extra := #index.stackDelta := -1. ^ 177].
+ (aSymbol == #storeGlobal) ifTrue:[extra := #speciallit. stackDelta := -1. ^ 41].
+ (aSymbol == #storeOuterBlockVar) ifTrue:[stackDelta := -1.
+ extra := #indexLevel. ^ 129].
+
+ "optimized bytecodes"
+
+ (aSymbol == #retNil) ifTrue:[^ 1].
+ (aSymbol == #retTrue) ifTrue:[^ 2].
+ (aSymbol == #retFalse) ifTrue:[^ 3].
+ (aSymbol == #ret0) ifTrue:[^ 4].
+ (aSymbol == #retNum) ifTrue:[extra := #number. ^ 127].
+
+ (aSymbol == #pushChar) ifTrue:[stackDelta := 1. ^17].
+ (aSymbol == #push0) ifTrue:[stackDelta := 1. ^120].
+ (aSymbol == #push1) ifTrue:[stackDelta := 1. ^121].
+ (aSymbol == #pushMinus1) ifTrue:[stackDelta := 1. ^122].
+
+ (aSymbol == #send0) ifTrue:[lineno := true. extra := #lit. ^21].
+ (aSymbol == #send1) ifTrue:[lineno := true. extra := #lit. stackDelta := -1. ^22].
+ (aSymbol == #send2) ifTrue:[lineno := true. extra := #lit. stackDelta := -2. ^23].
+ (aSymbol == #send3) ifTrue:[lineno := true. extra := #lit. stackDelta := -3. ^24].
+
+ (aSymbol == #sendSelf0) ifTrue:[lineno := true. extra := #lit. stackDelta := 1. ^180].
+ (aSymbol == #sendSelf1) ifTrue:[lineno := true. extra := #lit. ^181].
+ (aSymbol == #sendSelf2) ifTrue:[lineno := true. extra := #lit. stackDelta := -1. ^182].
+ (aSymbol == #sendSelf3) ifTrue:[lineno := true. extra := #lit. stackDelta := -2. ^183].
+ (aSymbol == #sendSelfDrop0) ifTrue:[lineno := true. extra := #lit. ^184].
+ (aSymbol == #sendSelfDrop1) ifTrue:[lineno := true. extra := #lit. stackDelta := -1. ^185].
+ (aSymbol == #sendSelfDrop2) ifTrue:[lineno := true. extra := #lit. stackDelta := -2. ^186].
+ (aSymbol == #sendSelfDrop3) ifTrue:[lineno := true. extra := #lit. stackDelta := -3. ^187].
+
+ (aSymbol == #sendDrop) ifTrue:[lineno := true. ^25].
+ (aSymbol == #sendDrop0) ifTrue:[lineno := true. extra := #lit. stackDelta := -1. ^26].
+ (aSymbol == #sendDrop1) ifTrue:[lineno := true. extra := #lit. stackDelta := -2. ^27].
+ (aSymbol == #sendDrop2) ifTrue:[lineno := true. extra := #lit. stackDelta := -3. ^28].
+ (aSymbol == #sendDrop3) ifTrue:[lineno := true. extra := #lit. stackDelta := -4. ^29].
+
+ (aSymbol == #pushMethodVar1) ifTrue:[stackDelta := 1. ^80].
+ (aSymbol == #pushMethodVar2) ifTrue:[stackDelta := 1. ^81].
+ (aSymbol == #pushMethodVar3) ifTrue:[stackDelta := 1. ^82].
+ (aSymbol == #pushMethodVar4) ifTrue:[stackDelta := 1. ^83].
+ (aSymbol == #pushMethodVar5) ifTrue:[stackDelta := 1. ^84].
+ (aSymbol == #pushMethodVar6) ifTrue:[stackDelta := 1. ^85].
+
+ (aSymbol == #pushMethodArg1) ifTrue:[stackDelta := 1. ^86].
+ (aSymbol == #pushMethodArg2) ifTrue:[stackDelta := 1. ^87].
+ (aSymbol == #pushMethodArg3) ifTrue:[stackDelta := 1. ^88].
+ (aSymbol == #pushMethodArg4) ifTrue:[stackDelta := 1. ^89].
+
+ (aSymbol == #pushInstVar1) ifTrue:[stackDelta := 1. ^90].
+ (aSymbol == #pushInstVar2) ifTrue:[stackDelta := 1. ^91].
+ (aSymbol == #pushInstVar3) ifTrue:[stackDelta := 1. ^92].
+ (aSymbol == #pushInstVar4) ifTrue:[stackDelta := 1. ^93].
+ (aSymbol == #pushInstVar5) ifTrue:[stackDelta := 1. ^94].
+ (aSymbol == #pushInstVar6) ifTrue:[stackDelta := 1. ^95].
+ (aSymbol == #pushInstVar7) ifTrue:[stackDelta := 1. ^96].
+ (aSymbol == #pushInstVar8) ifTrue:[stackDelta := 1. ^97].
+ (aSymbol == #pushInstVar9) ifTrue:[stackDelta := 1. ^98].
+ (aSymbol == #pushInstVar10) ifTrue:[stackDelta := 1. ^99].
+
+ (aSymbol == #storeMethodVar1) ifTrue:[stackDelta := -1. ^100].
+ (aSymbol == #storeMethodVar2) ifTrue:[stackDelta := -1. ^101].
+ (aSymbol == #storeMethodVar3) ifTrue:[stackDelta := -1. ^102].
+ (aSymbol == #storeMethodVar4) ifTrue:[stackDelta := -1. ^103].
+ (aSymbol == #storeMethodVar5) ifTrue:[stackDelta := -1. ^104].
+ (aSymbol == #storeMethodVar6) ifTrue:[stackDelta := -1. ^105].
+
+ (aSymbol == #storeInstVar1) ifTrue:[stackDelta := -1. ^110].
+ (aSymbol == #storeInstVar2) ifTrue:[stackDelta := -1. ^111].
+ (aSymbol == #storeInstVar3) ifTrue:[stackDelta := -1. ^112].
+ (aSymbol == #storeInstVar4) ifTrue:[stackDelta := -1. ^113].
+ (aSymbol == #storeInstVar5) ifTrue:[stackDelta := -1. ^114].
+ (aSymbol == #storeInstVar6) ifTrue:[stackDelta := -1. ^115].
+ (aSymbol == #storeInstVar7) ifTrue:[stackDelta := -1. ^116].
+ (aSymbol == #storeInstVar8) ifTrue:[stackDelta := -1. ^117].
+ (aSymbol == #storeInstVar9) ifTrue:[stackDelta := -1. ^118].
+ (aSymbol == #storeInstVar10) ifTrue:[stackDelta := -1. ^119].
+
+ (aSymbol == #retMethodVar1) ifTrue:[^160].
+ (aSymbol == #retMethodVar2) ifTrue:[^161].
+ (aSymbol == #retMethodVar3) ifTrue:[^162].
+ (aSymbol == #retMethodVar4) ifTrue:[^163].
+ (aSymbol == #retMethodVar5) ifTrue:[^164].
+ (aSymbol == #retMethodVar6) ifTrue:[^165].
+
+ (aSymbol == #retInstVar1) ifTrue:[^166].
+ (aSymbol == #retInstVar2) ifTrue:[^167].
+ (aSymbol == #retInstVar3) ifTrue:[^168].
+ (aSymbol == #retInstVar4) ifTrue:[^169].
+ (aSymbol == #retInstVar5) ifTrue:[^170].
+ (aSymbol == #retInstVar6) ifTrue:[^171].
+ (aSymbol == #retInstVar7) ifTrue:[^172].
+ (aSymbol == #retInstVar8) ifTrue:[^173].
+
+ (aSymbol == #retMethodArg1) ifTrue:[^174].
+ (aSymbol == #retMethodArg2) ifTrue:[^175].
+
+ (aSymbol == #pushBlockArg1) ifTrue:[stackDelta := 1. ^140].
+ (aSymbol == #pushBlockArg2) ifTrue:[stackDelta := 1. ^141].
+ (aSymbol == #pushBlockArg3) ifTrue:[stackDelta := 1. ^142].
+ (aSymbol == #pushBlockArg4) ifTrue:[stackDelta := 1. ^143].
+
+ (aSymbol == #pushOuter1BlockArg) ifTrue:[
+ stackDelta := 1. extra := #index. ^ 43].
+ (aSymbol == #pushOuter2BlockArg) ifTrue:[
+ stackDelta := 1. extra := #index. ^ 44].
+
+ (aSymbol == #=) ifTrue:[stackDelta := -1. self addLiteral:aSymbol. ^130].
+ (aSymbol == #+) ifTrue:[stackDelta := -1. self addLiteral:aSymbol. ^131].
+ (aSymbol == #~=) ifTrue:[stackDelta := -1. self addLiteral:aSymbol. ^132].
+ (aSymbol == #-) ifTrue:[stackDelta := -1. self addLiteral:aSymbol. ^133].
+ (aSymbol == #class) ifTrue:[self addLiteral:aSymbol. ^134].
+ (aSymbol == #x) ifTrue:[self addLiteral:aSymbol. ^106].
+ (aSymbol == #y) ifTrue:[self addLiteral:aSymbol. ^107].
+ (aSymbol == #width) ifTrue:[self addLiteral:aSymbol. ^108].
+ (aSymbol == #height) ifTrue:[self addLiteral:aSymbol. ^109].
+ (aSymbol == #origin) ifTrue:[self addLiteral:aSymbol. ^154].
+ (aSymbol == #extent) ifTrue:[self addLiteral:aSymbol. ^155].
+ (aSymbol == #at:) ifTrue:[stackDelta := -1. self addLiteral:aSymbol. ^135].
+ (aSymbol == #at:put:)ifTrue:[stackDelta := -2. self addLiteral:aSymbol. ^136].
+ (aSymbol == #bitAnd:) ifTrue:[stackDelta := -1. self addLiteral:aSymbol. ^137].
+ (aSymbol == #bitOr:) ifTrue:[stackDelta := -1. self addLiteral:aSymbol. ^138].
+ (aSymbol == #plus1) ifTrue:[self addLiteral:#+. ^123].
+ (aSymbol == #minus1) ifTrue:[self addLiteral:#-. ^124].
+
+ (aSymbol == #incMethodVar) ifTrue:[self addLiteral:#+. extra := #index. ^125].
+ (aSymbol == #decMethodVar) ifTrue:[self addLiteral:#-. extra := #index. ^126].
+
+ (aSymbol == #eq0) ifTrue:[self addLiteral:#==. ^48].
+ (aSymbol == #ne0) ifTrue:[self addLiteral:#~~. ^49].
+
+ (aSymbol == #>) ifTrue:[self addLiteral:aSymbol. stackDelta := -1. ^ 145].
+ (aSymbol == #>=) ifTrue:[self addLiteral:aSymbol. stackDelta := -1. ^ 146].
+ (aSymbol == #<) ifTrue:[self addLiteral:aSymbol. stackDelta := -1. ^ 147].
+ (aSymbol == #<=) ifTrue:[self addLiteral:aSymbol. stackDelta := -1. ^ 148].
+ (aSymbol == #next) ifTrue:[self addLiteral:aSymbol. ^ 149].
+ (aSymbol == #peek) ifTrue:[self addLiteral:aSymbol. ^ 150].
+ (aSymbol == #value) ifTrue:[self addLiteral:aSymbol. ^ 151].
+ (aSymbol == #value:) ifTrue:[self addLiteral:aSymbol.
+ stackDelta := -1. ^ 152].
+ (aSymbol == #size) ifTrue:[self addLiteral:aSymbol. ^ 153].
+ (aSymbol == #mk0Block) ifTrue:[^ 156].
+ (aSymbol == #mkNilBlock) ifTrue:[^ 157].
+
+ (aSymbol == #falseJumpabs) ifTrue:[stackDelta := -1. extra := #absoffset. ^ 190].
+ (aSymbol == #trueJumpabs) ifTrue:[stackDelta := -1. extra := #absoffset. ^ 191].
+ (aSymbol == #nilJumpabs) ifTrue:[stackDelta := -1. extra := #absoffset. ^ 192].
+ (aSymbol == #notNilJumpabs) ifTrue:[stackDelta := -1. extra := #absoffset. ^ 193].
+ (aSymbol == #jumpabs) ifTrue:[extra := #absoffset. ^ 194].
+ (aSymbol == #zeroJumpabs) ifTrue:[stackDelta := -1. extra := #absoffset. ^ 196].
+ (aSymbol == #notZeroJumpabs) ifTrue:[stackDelta := -1. extra := #absoffset. ^ 197].
+ (aSymbol == #eqJumpabs) ifTrue:[stackDelta := -1. extra := #absoffset. ^ 198].
+ (aSymbol == #notEqJumpabs) ifTrue:[stackDelta := -1. extra := #absoffset. ^ 199].
+
+ (aSymbol == #pushThisContext) ifTrue:[stackDelta := 1. ^ 144].
+
+ self error:'invalid code symbol'.
+ errorFlag := #Error
+! !
+
+!ByteCodeCompiler class methodsFor:'machine code constants'!
+
+sharedCodeFunctionFor:aSymbol
+ "return the address of a shared code-function"
+
+ |codeSymbol|
+
+ (aSymbol == #retSelf) ifTrue:[
+%{
+ extern OBJ __retSelf();
+#if defined(SYSV4) && defined(i386)
+ OBJ (*dummy)() = __retSelf;
+#endif
+ RETURN ( _MKSMALLINT((int)__retSelf) );
+%}
+ ].
+ (aSymbol == #retNil) ifTrue:[
+%{
+ extern OBJ __retNil();
+#if defined(SYSV4) && defined(i386)
+ OBJ (*dummy)() = __retNil;
+#endif
+ RETURN ( _MKSMALLINT((int)__retNil) );
+%}
+ ].
+ (aSymbol == #retTrue) ifTrue:[
+%{
+ extern OBJ __retTrue();
+#if defined(SYSV4) && defined(i386)
+ OBJ (*dummy)() = __retTrue;
+#endif
+ RETURN ( _MKSMALLINT((int)__retTrue) );
+%}
+ ].
+ (aSymbol == #retFalse) ifTrue:[
+%{
+ extern OBJ __retFalse();
+#if defined(SYSV4) && defined(i386)
+ OBJ (*dummy)() = __retFalse;
+#endif
+ RETURN ( _MKSMALLINT((int)__retFalse) );
+%}
+ ].
+ (aSymbol == #ret0) ifTrue:[
+%{
+ extern OBJ __ret0();
+#if defined(SYSV4) && defined(i386)
+ OBJ (*dummy)() = __ret0;
+#endif
+ RETURN ( _MKSMALLINT((int)__ret0) );
+%}
+ ].
+ (aSymbol == #blockRet0) ifTrue:[
+%{
+ extern OBJ __bRet0();
+#if defined(SYSV4) && defined(i386)
+ OBJ (*dummy)() = __bRet0;
+#endif
+ RETURN ( _MKSMALLINT((int)__bRet0) );
+%}
+ ].
+ (aSymbol == #blockRetNil) ifTrue:[
+%{
+ extern OBJ __bRetNil();
+#if defined(SYSV4) && defined(i386)
+ OBJ (*dummy)() = __bRetNil;
+#endif
+ RETURN ( _MKSMALLINT((int)__bRetNil) );
+%}
+ ].
+ (aSymbol == #blockRetTrue) ifTrue:[
+%{
+ extern OBJ __bRetTrue();
+#if defined(SYSV4) && defined(i386)
+ OBJ (*dummy)() = __bRetTrue;
+#endif
+ RETURN ( _MKSMALLINT((int)__bRetTrue) );
+%}
+ ].
+ (aSymbol == #blockRetFalse) ifTrue:[
+%{
+ extern OBJ __bRetFalse();
+#if defined(SYSV4) && defined(i386)
+ OBJ (*dummy)() = __bRetFalse;
+#endif
+ RETURN ( _MKSMALLINT((int)__bRetFalse) );
+%}
+ ].
+ (aSymbol == #retInstVar1) ifTrue:[
+%{
+ extern OBJ __retInst0();
+#if defined(SYSV4) && defined(i386)
+ OBJ (*dummy)() = __retInst0;
+#endif
+ RETURN ( _MKSMALLINT((int)__retInst0) );
+%}
+ ].
+ (aSymbol == #retInstVar2) ifTrue:[
+%{
+ extern OBJ __retInst1();
+#if defined(SYSV4) && defined(i386)
+ OBJ (*dummy)() = __retInst1;
+#endif
+ RETURN ( _MKSMALLINT((int)__retInst1) );
+%}
+ ].
+ (aSymbol == #retInstVar3) ifTrue:[
+%{
+ extern OBJ __retInst2();
+#if defined(SYSV4) && defined(i386)
+ OBJ (*dummy)() = __retInst2;
+#endif
+ RETURN ( _MKSMALLINT((int)__retInst2) );
+%}
+ ].
+ (aSymbol == #retInstVar4) ifTrue:[
+%{
+ extern OBJ __retInst3();
+#if defined(SYSV4) && defined(i386)
+ OBJ (*dummy)() = __retInst3;
+#endif
+ RETURN ( _MKSMALLINT((int)__retInst3) );
+%}
+ ].
+ (aSymbol == #retInstVar5) ifTrue:[
+%{
+ extern OBJ __retInst4();
+#if defined(SYSV4) && defined(i386)
+ OBJ (*dummy)() = __retInst4;
+#endif
+ RETURN ( _MKSMALLINT((int)__retInst4) );
+%}
+ ].
+ (aSymbol == #retInstVar6) ifTrue:[
+%{
+ extern OBJ __retInst5();
+#if defined(SYSV4) && defined(i386)
+ OBJ (*dummy)() = __retInst5;
+#endif
+ RETURN ( _MKSMALLINT((int)__retInst5) );
+%}
+ ].
+ (aSymbol == #retInstVar7) ifTrue:[
+%{
+ extern OBJ __retInst6();
+#if defined(SYSV4) && defined(i386)
+ OBJ (*dummy)() = __retInst6;
+#endif
+ RETURN ( _MKSMALLINT((int)__retInst6) );
+%}
+ ].
+ (aSymbol == #retInstVar8) ifTrue:[
+%{
+ extern OBJ __retInst7();
+#if defined(SYSV4) && defined(i386)
+ OBJ (*dummy)() = __retInst7;
+#endif
+ RETURN ( _MKSMALLINT((int)__retInst7) );
+%}
+ ].
+ (aSymbol == #storeInstVar1) ifTrue:[
+%{
+ extern OBJ __setInst0();
+#if defined(SYSV4) && defined(i386)
+ OBJ (*dummy)() = __setInst0;
+#endif
+ RETURN ( _MKSMALLINT((int)__setInst0) );
+%}
+ ].
+ (aSymbol == #storeInstVar2) ifTrue:[
+%{
+ extern OBJ __setInst1();
+#if defined(SYSV4) && defined(i386)
+ OBJ (*dummy)() = __setInst1;
+#endif
+ RETURN ( _MKSMALLINT((int)__setInst1) );
+%}
+ ].
+ (aSymbol == #storeInstVar3) ifTrue:[
+%{
+ extern OBJ __setInst2();
+#if defined(SYSV4) && defined(i386)
+ OBJ (*dummy)() = __setInst2;
+#endif
+ RETURN ( _MKSMALLINT((int)__setInst2) );
+%}
+ ].
+ (aSymbol == #storeInstVar4) ifTrue:[
+%{
+ extern OBJ __setInst3();
+#if defined(SYSV4) && defined(i386)
+ OBJ (*dummy)() = __setInst3;
+#endif
+ RETURN ( _MKSMALLINT((int)__setInst3) );
+%}
+ ].
+ (aSymbol == #storeInstVar5) ifTrue:[
+%{
+ extern OBJ __setInst4();
+#if defined(SYSV4) && defined(i386)
+ OBJ (*dummy)() = __setInst4;
+#endif
+ RETURN ( _MKSMALLINT((int)__setInst4) );
+%}
+ ].
+ (aSymbol == #storeInstVar6) ifTrue:[
+%{
+ extern OBJ __setInst5();
+#if defined(SYSV4) && defined(i386)
+ OBJ (*dummy)() = __setInst5;
+#endif
+ RETURN ( _MKSMALLINT((int)__setInst5) );
+%}
+ ].
+ (aSymbol == #storeInstVar7) ifTrue:[
+%{
+ extern OBJ __setInst6();
+#if defined(SYSV4) && defined(i386)
+ OBJ (*dummy)() = __setInst6;
+#endif
+ RETURN ( _MKSMALLINT((int)__setInst6) );
+%}
+ ].
+ (aSymbol == #storeInstVar8) ifTrue:[
+%{
+ extern OBJ __setInst7();
+#if defined(SYSV4) && defined(i386)
+ OBJ (*dummy)() = __setInst7;
+#endif
+ RETURN ( _MKSMALLINT((int)__setInst7) );
+%}
+ ].
+ (aSymbol == #storeInstVar9) ifTrue:[
+%{
+ extern OBJ __setInst8();
+#if defined(SYSV4) && defined(i386)
+ OBJ (*dummy)() = __setInst8;
+#endif
+ RETURN ( _MKSMALLINT((int)__setInst8) );
+%}
+ ].
+ (aSymbol == #storeInstVar10) ifTrue:[
+%{
+ extern OBJ __setInst9();
+#if defined(SYSV4) && defined(i386)
+ OBJ (*dummy)() = __setInst9;
+#endif
+ RETURN ( _MKSMALLINT((int)__setInst9) );
+%}
+ ].
+ ^ nil
+! !
+
+!ByteCodeCompiler methodsFor:'machine code generation'!
+
+checkForSharedCode:symbolicCodeArray
+ "if this method is a very simple one,
+ we can use the shared compiled code"
+
+ |codeSymbol nArgs|
+
+ symbolicCodeArray isNil ifTrue:[^ nil].
+ codeSymbol := symbolicCodeArray at:1.
+ nArgs := methodArgs size.
+ (nArgs == 0) ifTrue:[
+ (codeSymbol == #retSelf) ifTrue:[^ codeSymbol].
+ (codeSymbol == #retTrue) ifTrue:[^ codeSymbol].
+ (codeSymbol == #retFalse) ifTrue:[^ codeSymbol].
+ (codeSymbol == #retNil) ifTrue:[^ codeSymbol].
+ (codeSymbol == #ret0) ifTrue:[^ codeSymbol].
+ ('retInstVar*' match:codeSymbol) ifTrue:[^ codeSymbol]
+ ].
+ (nArgs == 0) ifTrue:[
+ (codeSymbol == #pushMethodArg1) ifTrue:[
+ ('storeInstVar*' match:(symbolicCodeArray at:2)) ifTrue:[
+ ((symbolicCodeArray at:3) == #retSelf) ifTrue:[^ symbolicCodeArray at:2]
+ ].
+ ^ nil
+ ]
+ ].
+ ^ nil
+!
+
+checkForMachineCode:symbolicCodeArray
+ "if this method is a simple one,
+ we can compile it into machine code"
+
+ |code1 code2 code3 name|
+
+ symbolicCodeArray isNil ifTrue:[^ nil].
+ code1 := symbolicCodeArray at:1.
+ (code1 == #retNum) ifTrue:[
+ ^ self codeForRetNum:(symbolicCodeArray at:2)
+ ].
+ (code1 == #pushNum) ifTrue:[
+ code2 := symbolicCodeArray at:3.
+ (code2 == #retTop) ifTrue:[
+ ^ self codeForRetNum:(symbolicCodeArray at:2)
+ ].
+ ^ nil
+ ].
+ (code1 == #pushMethodArg1) ifTrue:[
+ code2 := symbolicCodeArray at:2.
+ ((code2 == #storeGlobal)
+ or:[code2 == #storeClassVar]) ifTrue:[
+ code3 := symbolicCodeArray at:4.
+ (code3 == #retSelf) ifTrue:[
+ name := symbolicCodeArray at:3.
+ ^ self codeForSetCell:name
+ ]
+ ].
+ ^ nil
+ ].
+
+ (code1 == #pushGlobal) ifTrue:[
+ code2 := symbolicCodeArray at:8.
+ (code2 == #retTop) ifTrue:[
+ name := symbolicCodeArray at:2.
+ ^ self codeForRetCell:name
+ ].
+ ^ nil
+ ].
+ (code1 == #pushClassVar) ifTrue:[
+ code2 := symbolicCodeArray at:8.
+ (code2 == #retTop) ifTrue:[
+ name := symbolicCodeArray at:2.
+ ^ self codeForRetCell:name
+ ].
+ ^ nil
+ ].
+ (code1 == #pushLit) ifTrue:[
+ code2 := symbolicCodeArray at:3.
+ (code2 == #retTop) ifTrue:[
+ ^ nil
+ ].
+ ^ nil
+ ].
+ ^ nil
+!
+
+codeForRetNum:value
+ "^ number will be coded into machine code"
+
+ |count b conIndex tagHi newCode|
+
+ count := self codeProtoForRetNumEnd - self codeProtoForRetNum.
+
+ b := ExternalBytes address:(self codeProtoForRetNum).
+
+ "search for sequence 0x92345678"
+
+ tagHi := false.
+ 1 to:count-3 do:[:index |
+ (b at:index) == 16r92 ifTrue:[
+ (b at:index+1) == 16r34 ifTrue:[
+ (b at:index+2) == 16r56 ifTrue:[
+ (b at:index+3) == 16r78 ifTrue:[
+ conIndex := index.
+ tagHi := true
+ ]
+ ]
+ ]
+ ]
+ ].
+
+ conIndex isNil ifTrue:["'search failed' printNewline. "^ nil].
+ tagHi ifFalse:['low tag unsupported' printNewline. ^ nil].
+
+ "allocate code ..."
+
+ newCode := ExternalBytes newForText:count.
+ newCode isNil ifTrue:[
+ 'alloc of text (size ' print. count print. ') failed' printNewline.
+ ^ nil
+ ].
+
+ "copy from proto"
+ 1 to:count do:[:index |
+ newCode at:index put:(b at:index)
+ ].
+ "put in ret-value"
+ newCode at:conIndex put:((value bitShift:-24) bitAnd:16rFF).
+ newCode at:conIndex+1 put:((value bitShift:-16) bitAnd:16rFF).
+ newCode at:conIndex+2 put:((value bitShift:-8) bitAnd:16rFF).
+ newCode at:conIndex+3 put:(value bitAnd:16rFF).
+ tagHi ifTrue:[
+ newCode at:conIndex
+ put:((newCode at:conIndex) bitOr:16r80)
+ ] ifFalse:[
+ ].
+'address is:' print. newCode address printNewline.
+ ^ newCode address
+
+ "ByteCodeCompiler new codeForRetNum:15"
+!
+
+codeForRetCell:aGlobalOrClassVariableSymbol
+ "^ global will be coded into machine code"
+
+ |cell count b conIndex newCode msbFirst|
+
+ cell := Smalltalk cellAt:aGlobalOrClassVariableSymbol.
+ cell isNil ifTrue:[^ nil].
+
+ count := self codeProtoForRetCellEnd - self codeProtoForRetCell.
+
+ b := ExternalBytes address:(self codeProtoForRetCell).
+
+ msbFirst := true.
+
+ "search for sequence 0x12345678 // 78563412"
+ 1 to:count - 3 do:[:index |
+ (b at:index) == 16r12 ifTrue:[
+ (b at:index+1) == 16r34 ifTrue:[
+ (b at:index+2) == 16r56 ifTrue:[
+ (b at:index+3) == 16r78 ifTrue:[
+ conIndex := index
+ ]
+ ]
+ ]
+ ].
+ conIndex isNil ifTrue:[
+ (b at:index) == 16r78 ifTrue:[
+ (b at:index+1) == 16r56 ifTrue:[
+ (b at:index+2) == 16r34 ifTrue:[
+ (b at:index+3) == 16r12 ifTrue:[
+ conIndex := index.
+ msbFirst := false
+ ]
+ ]
+ ]
+ ]
+ ]
+ ].
+
+ conIndex isNil ifTrue:["'search failed' printNewline. " ^ nil].
+
+ "allocate code ..."
+
+ newCode := ExternalBytes newForText:count.
+ newCode isNil ifTrue:['alloc of text (size ' print. count print. ') failed' printNewline.^ nil].
+
+ "copy from proto"
+ 1 to:count do:[:index |
+ newCode at:index put:(b at:index)
+ ].
+ "put in cell address"
+ msbFirst ifTrue:[
+ newCode at:conIndex put:((cell bitShift:-24) bitAnd:16rFF).
+ newCode at:conIndex+1 put:((cell bitShift:-16) bitAnd:16rFF).
+ newCode at:conIndex+2 put:((cell bitShift:-8) bitAnd:16rFF).
+ newCode at:conIndex+3 put:(cell bitAnd:16rFF).
+ ] ifFalse:[
+ newCode at:conIndex+3 put:((cell bitShift:-24) bitAnd:16rFF).
+ newCode at:conIndex+2 put:((cell bitShift:-16) bitAnd:16rFF).
+ newCode at:conIndex+1 put:((cell bitShift:-8) bitAnd:16rFF).
+ newCode at:conIndex put:(cell bitAnd:16rFF).
+ ].
+
+'address is:' print. newCode address printNewline.
+ ^ newCode address
+
+ "ByteCodeCompiler new codeForRetCell:#Transcript"
+!
+
+codeForSetCell:aGlobalOrClassVariableSymbol
+ "global := arg will be coded into machine code"
+
+ |cell count b conIndex newCode|
+
+ cell := Smalltalk cellAt:aGlobalOrClassVariableSymbol.
+ cell isNil ifTrue:[^ nil].
+
+ count := self codeProtoForSetCellEnd - self codeProtoForSetCell.
+
+ b := ExternalBytes address:(self codeProtoForSetCell).
+
+ "search for sequence 0x12345678"
+ 1 to:count - 3 do:[:index |
+ (b at:index) == 16r12 ifTrue:[
+ (b at:index+1) == 16r34 ifTrue:[
+ (b at:index+2) == 16r56 ifTrue:[
+ (b at:index+3) == 16r78 ifTrue:[
+ conIndex := index
+ ]
+ ]
+ ]
+ ]
+ ].
+
+ conIndex isNil ifTrue:["'search failed' printNewline." ^ nil].
+
+ "allocate code ..."
+
+ newCode := ExternalBytes newForData:count.
+ newCode isNil ifTrue:['alloc of data (size ' print. count print. ') failed' printNewline.^ nil].
+
+ "copy from proto"
+ 1 to:count do:[:index |
+ newCode at:index put:(b at:index)
+ ].
+ "put in cell address"
+ newCode at:conIndex put:((cell bitShift:-24) bitAnd:16rFF).
+ newCode at:conIndex+1 put:((cell bitShift:-16) bitAnd:16rFF).
+ newCode at:conIndex+2 put:((cell bitShift:-8) bitAnd:16rFF).
+ newCode at:conIndex+3 put:(cell bitAnd:16rFF).
+
+'address is:' print. newCode address printNewline.
+ ^ newCode address
+
+ "ByteCodeCompiler new codeForSetCell:#xyz"
+!
+
+codeProtoForRetNum
+%{ /* NOCONTEXT */
+ extern OBJ __retNumProto();
+#if defined(SYSV4) && defined(i386)
+ OBJ (*dummy)() = __retNumProto;
+#endif
+ RETURN ( _MKSMALLINT((int)__retNumProto) );
+%}
+!
+
+codeProtoForRetNumEnd
+%{ /* NOCONTEXT */
+ extern OBJ __retNumProtoEnd();
+#if defined(SYSV4) && defined(i386)
+ OBJ (*dummy)() = __retNumProtoEnd;
+#endif
+ RETURN ( _MKSMALLINT((int)__retNumProtoEnd) );
+%}
+!
+
+codeProtoForRetCell
+%{ /* NOCONTEXT */
+ extern OBJ __retCellProto();
+#if defined(SYSV4) && defined(i386)
+ OBJ (*dummy)() = __retCellProto;
+#endif
+ RETURN ( _MKSMALLINT((int)__retCellProto) );
+%}
+!
+
+codeProtoForRetCellEnd
+%{ /* NOCONTEXT */
+ extern OBJ __retCellProtoEnd();
+#if defined(SYSV4) && defined(i386)
+ OBJ (*dummy)() = __retCellProtoEnd;
+#endif
+ RETURN ( _MKSMALLINT((int)__retCellProtoEnd) );
+%}
+!
+
+codeProtoForSetCell
+%{ /* NOCONTEXT */
+ extern OBJ __setCellProto();
+#if defined(SYSV4) && defined(i386)
+ OBJ (*dummy)() = __setCellProto;
+#endif
+ RETURN ( _MKSMALLINT((int)__setCellProto) );
+%}
+!
+
+codeProtoForSetCellEnd
+%{ /* NOCONTEXT */
+ extern OBJ __setCellProtoEnd();
+#if defined(SYSV4) && defined(i386)
+ OBJ (*dummy)() = __setCellProtoEnd;
+#endif
+ RETURN ( _MKSMALLINT((int)__setCellProtoEnd) );
+%}
+! !
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/BinaryNd.st Fri Jul 16 11:38:57 1993 +0200
@@ -0,0 +1,122 @@
+"
+ COPYRIGHT (c) 1989-93 by Claus Gittinger
+ All Rights Reserved
+
+ This software is furnished under a license and may be used
+ only in accordance with the terms of that license and with the
+ inclusion of the above copyright notice. This software may not
+ be provided or otherwise made available to, or used by, any
+ other person. No title to or ownership of the software is
+ hereby transferred.
+"
+
+MessageNode subclass:#BinaryNode
+ instanceVariableNames:''
+ classVariableNames:''
+ poolDictionaries:''
+ category:'System-Compiler-Support'
+!
+
+BinaryNode comment:'
+COPYRIGHT (c) 1989-93 by Claus Gittinger
+ All Rights Reserved
+
+%W% %E%
+'!
+
+!BinaryNode methodsFor:'queries'!
+
+isBinaryMessage
+ ^ true
+! !
+
+!BinaryNode methodsFor:'accessing'!
+
+arg
+ ^ argArray at:1
+! !
+
+!BinaryNode methodsFor:'evaluating'!
+
+evaluate
+ ^ (receiver evaluate) perform:selector with:(argArray at:1) evaluate
+! !
+
+!BinaryNode methodsFor:'code generation'!
+
+codeOn:aStream inBlock:b
+ |arg1|
+
+ (receiver type == #Super) ifFalse:[
+ ( #(== ~~ = ~= + - < <= > >=) includes:selector) ifTrue:[
+ receiver codeOn:aStream inBlock:b.
+ arg1 := argArray at:1.
+ arg1 isConstant ifTrue:[
+ (arg1 type == #Integer) ifTrue:[
+ ((selector == #==) or:[selector == #~~]) ifTrue:[
+ (arg1 value == 0) ifTrue:[
+ (selector == #==) ifTrue:[
+ aStream nextPut:#eq0
+ ] ifFalse:[
+ aStream nextPut:#ne0
+ ].
+ ^ self
+ ]
+ ].
+ ((selector == #+) or:[selector == #-]) ifTrue:[
+ (arg1 value == 1) ifTrue:[
+ (selector == #+) ifTrue:[
+ aStream nextPut:#plus1
+ ] ifFalse:[
+ aStream nextPut:#minus1
+ ].
+ ^ self
+ ]
+ ]
+ ]
+ ].
+ arg1 codeOn:aStream inBlock:b.
+ aStream nextPut:selector.
+ ^ self
+ ]
+ ].
+ ^ super codeOn:aStream inBlock:b
+! !
+
+!BinaryNode methodsFor:'printing'!
+
+printOn:aStream indent:i
+ |needParen|
+
+ needParen := false.
+ receiver isMessage ifTrue:[
+ receiver isUnaryMessage ifFalse:[
+ needParen := true
+ ].
+ ].
+ needParen ifTrue:[
+ aStream nextPutAll:'('
+ ].
+ receiver printOn:aStream.
+ needParen ifTrue:[
+ aStream nextPutAll:') '
+ ].
+
+ aStream space.
+ selector printString printOn:aStream.
+ aStream space.
+
+ needParen := false.
+ self arg isMessage ifTrue:[
+ self arg isUnaryMessage ifFalse:[
+ needParen := true
+ ].
+ ].
+ needParen ifTrue:[
+ aStream nextPutAll:'('
+ ].
+ self arg printOn:aStream.
+ needParen ifTrue:[
+ aStream nextPutAll:') '
+ ].
+! !
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/BinaryNode.st Fri Jul 16 11:38:57 1993 +0200
@@ -0,0 +1,122 @@
+"
+ COPYRIGHT (c) 1989-93 by Claus Gittinger
+ All Rights Reserved
+
+ This software is furnished under a license and may be used
+ only in accordance with the terms of that license and with the
+ inclusion of the above copyright notice. This software may not
+ be provided or otherwise made available to, or used by, any
+ other person. No title to or ownership of the software is
+ hereby transferred.
+"
+
+MessageNode subclass:#BinaryNode
+ instanceVariableNames:''
+ classVariableNames:''
+ poolDictionaries:''
+ category:'System-Compiler-Support'
+!
+
+BinaryNode comment:'
+COPYRIGHT (c) 1989-93 by Claus Gittinger
+ All Rights Reserved
+
+%W% %E%
+'!
+
+!BinaryNode methodsFor:'queries'!
+
+isBinaryMessage
+ ^ true
+! !
+
+!BinaryNode methodsFor:'accessing'!
+
+arg
+ ^ argArray at:1
+! !
+
+!BinaryNode methodsFor:'evaluating'!
+
+evaluate
+ ^ (receiver evaluate) perform:selector with:(argArray at:1) evaluate
+! !
+
+!BinaryNode methodsFor:'code generation'!
+
+codeOn:aStream inBlock:b
+ |arg1|
+
+ (receiver type == #Super) ifFalse:[
+ ( #(== ~~ = ~= + - < <= > >=) includes:selector) ifTrue:[
+ receiver codeOn:aStream inBlock:b.
+ arg1 := argArray at:1.
+ arg1 isConstant ifTrue:[
+ (arg1 type == #Integer) ifTrue:[
+ ((selector == #==) or:[selector == #~~]) ifTrue:[
+ (arg1 value == 0) ifTrue:[
+ (selector == #==) ifTrue:[
+ aStream nextPut:#eq0
+ ] ifFalse:[
+ aStream nextPut:#ne0
+ ].
+ ^ self
+ ]
+ ].
+ ((selector == #+) or:[selector == #-]) ifTrue:[
+ (arg1 value == 1) ifTrue:[
+ (selector == #+) ifTrue:[
+ aStream nextPut:#plus1
+ ] ifFalse:[
+ aStream nextPut:#minus1
+ ].
+ ^ self
+ ]
+ ]
+ ]
+ ].
+ arg1 codeOn:aStream inBlock:b.
+ aStream nextPut:selector.
+ ^ self
+ ]
+ ].
+ ^ super codeOn:aStream inBlock:b
+! !
+
+!BinaryNode methodsFor:'printing'!
+
+printOn:aStream indent:i
+ |needParen|
+
+ needParen := false.
+ receiver isMessage ifTrue:[
+ receiver isUnaryMessage ifFalse:[
+ needParen := true
+ ].
+ ].
+ needParen ifTrue:[
+ aStream nextPutAll:'('
+ ].
+ receiver printOn:aStream.
+ needParen ifTrue:[
+ aStream nextPutAll:') '
+ ].
+
+ aStream space.
+ selector printString printOn:aStream.
+ aStream space.
+
+ needParen := false.
+ self arg isMessage ifTrue:[
+ self arg isUnaryMessage ifFalse:[
+ needParen := true
+ ].
+ ].
+ needParen ifTrue:[
+ aStream nextPutAll:'('
+ ].
+ self arg printOn:aStream.
+ needParen ifTrue:[
+ aStream nextPutAll:') '
+ ].
+! !
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/BlockNode.st Fri Jul 16 11:38:57 1993 +0200
@@ -0,0 +1,483 @@
+"
+ COPYRIGHT (c) 1989-93 by Claus Gittinger
+ All Rights Reserved
+
+ This software is furnished under a license and may be used
+ only in accordance with the terms of that license and with the
+ inclusion of the above copyright notice. This software may not
+ be provided or otherwise made available to, or used by, any
+ other person. No title to or ownership of the software is
+ hereby transferred.
+"
+
+ParseNode subclass:#BlockNode
+ instanceVariableNames:'blockArgs statements home inlineBlock exitBlock
+ blockVars
+ needsHome'
+ classVariableNames:''
+ poolDictionaries:''
+ category:'System-Compiler-Support'
+!
+
+BlockNode comment:'
+
+COPYRIGHT (c) 1989-93 by Claus Gittinger
+ All Rights Reserved
+
+implement interpreted blocks
+
+%W% %E%
+'!
+
+!BlockNode class methodsFor:'instance creation'!
+
+arguments:argList
+ ^ (self basicNew) setArguments:argList
+! !
+
+!BlockNode methodsFor:'private accessing'!
+
+setArguments:argList
+ needsHome := false.
+ blockArgs := argList
+! !
+
+!BlockNode methodsFor:'accessing'!
+
+arguments
+ ^ blockArgs
+!
+
+variables
+ ^ blockVars
+!
+
+variables:varList
+ blockVars := varList
+!
+
+statements
+ ^ statements
+!
+
+statements:s
+ statements := s
+!
+
+home:aBlock
+ home := aBlock
+!
+
+home
+ ^ home
+!
+
+inlineBlock
+ ^ inlineBlock
+!
+
+inlineBlock:aBoolean
+ inlineBlock := aBoolean
+!
+
+needsHome
+ ^ needsHome
+!
+
+needsHome:aBoolean
+ needsHome := aBoolean
+! !
+
+!BlockNode methodsFor:'queries'!
+
+isBlock
+ ^ true
+! !
+
+!BlockNode methodsFor:'evaluating'!
+
+exitWith:something
+ "return via return-statement"
+
+ home notNil ifTrue:[
+ home exitWith:something
+ ].
+ exitBlock value:something.
+ ^ something
+!
+
+evaluate
+ ^ self
+!
+
+argumentCountError:numberGiven
+ ^ self error:('Block got '
+ , numberGiven printString
+ , ' args while '
+ , (blockArgs size) printString
+ , ' where expected')
+!
+
+value
+ (blockArgs size ~~ 0) ifTrue:[
+ ^ self argumentCountError:0
+ ].
+ statements isNil ifTrue:[^ nil].
+ exitBlock := [:val | ^ val].
+ ^ statements evaluate
+!
+
+value:anArg
+ |oldValue val|
+
+ (blockArgs size ~~ 1) ifTrue:[
+ ^ self argumentCountError:1
+ ].
+ statements isNil ifTrue:[^ nil].
+
+ oldValue := (blockArgs at:1) value.
+ (blockArgs at:1) value:anArg.
+
+ exitBlock := [:val |
+ (blockArgs at:1) value:oldValue.
+ ^ val
+ ].
+
+ val := statements evaluate.
+
+ (blockArgs at:1) value:oldValue.
+ ^ val
+!
+
+value:arg1 value:arg2
+ |oldValue1 oldValue2 val|
+
+ (blockArgs size ~~ 2) ifTrue:[
+ ^ self argumentCountError:2
+ ].
+ statements isNil ifTrue:[^ nil].
+
+ oldValue1 := (blockArgs at:1) value.
+ oldValue2 := (blockArgs at:2) value.
+ (blockArgs at:1) value:arg1.
+ (blockArgs at:2) value:arg2.
+
+ exitBlock := [:val |
+ (blockArgs at:1) value:oldValue1.
+ (blockArgs at:2) value:oldValue2.
+ ^ val
+ ].
+
+ val := statements evaluate.
+
+ (blockArgs at:1) value:oldValue1.
+ (blockArgs at:2) value:oldValue2.
+ ^ val
+!
+
+value:arg1 value:arg2 value:arg3
+ |oldValue1 oldValue2 oldValue3 val|
+
+ (blockArgs size ~~ 3) ifTrue:[
+ ^ self argumentCountError:3
+ ].
+ statements isNil ifTrue:[^ nil].
+
+ oldValue1 := (blockArgs at:1) value.
+ oldValue2 := (blockArgs at:2) value.
+ oldValue3 := (blockArgs at:3) value.
+ (blockArgs at:1) value:arg1.
+ (blockArgs at:2) value:arg2.
+ (blockArgs at:3) value:arg3.
+
+ exitBlock := [:val |
+ (blockArgs at:1) value:oldValue1.
+ (blockArgs at:2) value:oldValue2.
+ (blockArgs at:3) value:oldValue3.
+ ^ val
+ ].
+
+ val := statements evaluate.
+
+ (blockArgs at:1) value:oldValue1.
+ (blockArgs at:2) value:oldValue2.
+ (blockArgs at:3) value:oldValue3.
+ ^ val
+!
+
+value:arg1 value:arg2 value:arg3 value:arg4
+ |oldValue1 oldValue2 oldValue3 oldValue4 val|
+
+ (blockArgs size ~~ 4) ifTrue:[
+ ^ self argumentCountError:4
+ ].
+ statements isNil ifTrue:[^ nil].
+
+ oldValue1 := (blockArgs at:1) value.
+ oldValue2 := (blockArgs at:2) value.
+ oldValue3 := (blockArgs at:3) value.
+ oldValue4 := (blockArgs at:4) value.
+ (blockArgs at:1) value:arg1.
+ (blockArgs at:2) value:arg2.
+ (blockArgs at:3) value:arg3.
+ (blockArgs at:4) value:arg4.
+
+ exitBlock := [:val |
+ (blockArgs at:1) value:oldValue1.
+ (blockArgs at:2) value:oldValue2.
+ (blockArgs at:3) value:oldValue3.
+ (blockArgs at:4) value:oldValue4.
+ ^ val
+ ].
+
+ val := statements evaluate.
+
+ (blockArgs at:1) value:oldValue1.
+ (blockArgs at:2) value:oldValue2.
+ (blockArgs at:3) value:oldValue3.
+ (blockArgs at:4) value:oldValue4.
+ ^ val
+! !
+
+!BlockNode methodsFor:'looping'!
+
+whileTrue:aBlock
+ [self value] whileTrue:[
+ aBlock value
+ ].
+ ^ nil
+!
+
+whileFalse:aBlock
+ [self value] whileFalse:[
+ aBlock value
+ ].
+ ^ nil
+! !
+
+!BlockNode methodsFor:'block messages'!
+
+doesNotUnderstand:aMessage
+ |numArgs kludgeBlock|
+
+ (Block implements:(aMessage selector)) ifTrue:[
+ "mhmh - a message which I dont understand, but Block implements
+ send it to a kludgeblock, which will evaluate me again ..."
+ numArgs := blockArgs size.
+ numArgs == 0 ifTrue:[
+ kludgeBlock := [self value]
+ ] ifFalse:[
+ numArgs == 1 ifTrue:[
+ kludgeBlock := [:a1 | self value:a1].
+ ] ifFalse:[
+ numArgs == 2 ifTrue:[
+ kludgeBlock := [:a1 :a2 | self value:a1 value:a2].
+ ] ifFalse:[
+ numArgs == 3 ifTrue:[
+ kludgeBlock := [:a1 :a2 :a3| self value:a1 value:a2 value:a3].
+ ] ifFalse:[
+ ^ self error:'only support blocks with up-to 3 args'
+ ]
+ ]
+ ]
+ ].
+ ^ kludgeBlock perform:aMessage selector withArguments:aMessage arguments
+ ].
+ super doesNotUnderstand:aMessage
+! !
+
+!BlockNode methodsFor:'code generation'!
+
+codeOn:aStream inBlock:b
+ |thisStatement nextStatement pos code cheapy|
+
+ cheapy := self checkForSimpleBlock.
+ cheapy notNil ifTrue:[
+ cheapy codeOn:aStream inBlock:b.
+ ^ self
+ ].
+
+ pos := aStream position.
+
+ aStream nextPut:#makeBlock. "+0"
+ aStream nextPut:0. "+1"
+ aStream nextPut:(blockVars size). "+2"
+ aStream nextPut:(blockArgs size). "+3"
+ statements isNil ifTrue:[
+ aStream nextPut:#pushNil "+4"
+ ] ifFalse:[
+ thisStatement := statements.
+ [thisStatement notNil] whileTrue:[
+ nextStatement := thisStatement nextStatement.
+ nextStatement notNil ifTrue:[
+ thisStatement codeForSideEffectOn:aStream inBlock:self
+ ] ifFalse:[
+ thisStatement codeOn:aStream inBlock:self
+ ].
+ thisStatement := nextStatement
+ ]
+ ].
+ aStream nextPut:#blockRetTop.
+
+ "check for [0]-block;
+ these are sometimes used as in ... ifAbsent:[0]
+ "
+ code := (aStream contents).
+ (code at:pos+4) == #push0 ifTrue:[
+ (code at:pos+5) == #blockRetTop ifTrue:[
+ aStream position:pos.
+ code grow:pos.
+ aStream nextPut:#mk0Block.
+ ^ self
+ ]
+ ].
+
+ "check for [nil]-block;
+ these come to play when code in blocks is commented
+ out, or as dummy exception blocks
+ "
+ code := (aStream contents).
+ (code at:pos+4) == #pushNil ifTrue:[
+ (code at:pos+5) == #blockRetTop ifTrue:[
+ aStream position:pos.
+ code grow:pos.
+ aStream nextPut:#mkNilBlock.
+ ^ self
+ ]
+ ].
+
+ (aStream contents) at:pos+1 put:(aStream position)
+!
+
+codeInlineOn:aStream inBlock:b valueNeeded:valueNeeded
+ |thisStatement nextStatement|
+
+ blockVars notNil ifTrue:[
+ "cannot currently compile this block inline (have to move blockvars into
+ surrounding method. generate a make-block and send it value"
+
+ Transcript showCr:'cannot (yet) compile block with blockvars inline'.
+ self codeOn:aStream inBlock:b.
+ aStream nextPut:#value.
+ valueNeeded ifFalse:[
+ aStream nextPut:#drop
+ ].
+ ^ self
+ ].
+ inlineBlock := true.
+ statements isNil ifTrue:[
+ valueNeeded ifTrue:[
+ aStream nextPut:#pushNil
+ ]
+ ] ifFalse:[
+ thisStatement := statements.
+ [thisStatement notNil] whileTrue:[
+ nextStatement := thisStatement nextStatement.
+ (nextStatement notNil or:[valueNeeded not]) ifTrue:[
+ thisStatement codeForSideEffectOn:aStream inBlock:b
+ ] ifFalse:[
+ thisStatement codeOn:aStream inBlock:b
+ ].
+ thisStatement := nextStatement
+ ]
+ ]
+!
+
+codeInlineOn:aStream inBlock:b
+ self codeInlineOn:aStream inBlock:b valueNeeded:true
+!
+
+checkForSimpleBlock
+ "simple things can be made cheap blocks right now -
+ resulting in a simple pushLit instruction ..."
+
+ |cheapy e val|
+
+ statements isNil ifTrue:[
+ "a []-block"
+
+ cheapy := Block code:(ByteCodeCompiler sharedCodeFunctionFor:#blockRetNil)
+ byteCode:nil
+ nargs:(blockArgs size)
+ sourcePosition:nil
+ initialPC:nil
+ literals:nil.
+ ^ ConstantNode type:#Block value:cheapy
+ ].
+ statements nextStatement isNil ifTrue:[
+ (statements isMemberOf:StatementNode) ifTrue:[
+ e := statements expression.
+ e isConstant ifTrue:[
+ val := e value.
+ val == 0 ifTrue:[
+ "a [0]-block"
+
+ cheapy := Block code:(ByteCodeCompiler sharedCodeFunctionFor:#blockRet0)
+ byteCode:nil
+ nargs:(blockArgs size)
+ sourcePosition:nil
+ initialPC:nil
+ literals:nil.
+ ^ ConstantNode type:#Block value:cheapy
+ ].
+ val == true ifTrue:[
+ "a [true]-block"
+
+ cheapy := Block code:(ByteCodeCompiler sharedCodeFunctionFor:#blockRetTrue)
+ byteCode:nil
+ nargs:(blockArgs size)
+ sourcePosition:nil
+ initialPC:nil
+ literals:nil.
+ ^ ConstantNode type:#Block value:cheapy
+ ].
+ val == false ifTrue:[
+ "a [false]-block"
+
+ cheapy := Block code:(ByteCodeCompiler sharedCodeFunctionFor:#blockRetFalse)
+ byteCode:nil
+ nargs:(blockArgs size)
+ sourcePosition:nil
+ initialPC:nil
+ literals:nil.
+ ^ ConstantNode type:#Block value:cheapy
+ ].
+ val == nil ifTrue:[
+ "a [nil]-block"
+
+ cheapy := Block code:(ByteCodeCompiler sharedCodeFunctionFor:#blockRetNil)
+ byteCode:nil
+ nargs:(blockArgs size)
+ sourcePosition:nil
+ initialPC:nil
+ literals:nil.
+ ^ ConstantNode type:#Block value:cheapy
+ ]
+ ]
+ ]
+ ].
+
+"
+ statements printOn:Transcript.
+"
+ ^ nil
+! !
+
+!BlockNode methodsFor:'printing'!
+
+printOn:aStream indent:i
+ aStream nextPut:$[.
+ 1 to:blockArgs size do:[:index |
+ aStream nextPut:$:.
+ aStream nextPutAll:(blockArgs at:index) name.
+ aStream space.
+ aStream nextPut:$|
+ ].
+ statements notNil ifTrue:[
+ aStream cr.
+ statements printAllOn:aStream indent:i + 4.
+ aStream cr.
+ aStream spaces:i.
+ ].
+ aStream nextPut:$]
+! !
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/ByteCodeCompiler.st Fri Jul 16 11:38:57 1993 +0200
@@ -0,0 +1,1447 @@
+"
+ COPYRIGHT (c) 1989-93 by Claus Gittinger
+ All Rights Reserved
+
+ This software is furnished under a license and may be used
+ only in accordance with the terms of that license and with the
+ inclusion of the above copyright notice. This software may not
+ be provided or otherwise made available to, or used by, any
+ other person. No title to or ownership of the software is
+ hereby transferred.
+"
+
+Parser subclass:#ByteCodeCompiler
+ instanceVariableNames:'code codeIndex
+ litArray
+ stackDelta extra lineno
+ maxStackDepth
+ relocList'
+ classVariableNames:''
+ poolDictionaries:''
+ category:'System-Compiler'
+!
+
+ByteCodeCompiler comment:'
+
+COPYRIGHT (c) 1989-93 by Claus Gittinger
+ All Rights Reserved
+
+This class defines how compilation into ByteCodes is done.
+First, parsing is done using superclass methods,
+then the parse-tree is converted into an array of symbolic codes
+and a relocation table;
+these two are finally combined into a byteArray of the codes.
+
+There are many dependancies to the run-time-system (especially the
+interpreter) in here - be careful when playing around ...
+
+Instance variables:
+
+code <ByteArry> bytecodes
+codeIndex <SmallInteger> next index to put into code array
+litArray <OrderedCollection> literals
+stackDelta <SmallInteger> return value of byteCodeFor:
+extra <Symbol> return value of byteCodeFor:
+maxStackDepth <SmallInteger> stack need of method
+relocList <Array> used temporary for relocation
+
+%W% %E%
+'!
+
+!ByteCodeCompiler class methodsFor:'compiling methods'!
+
+compile:methodText forClass:classToCompileFor
+ "compile a source-string for a method in classToCompileFor"
+
+ ^ self compile:methodText
+ forClass:classToCompileFor
+ inCategory:'others'
+ notifying:nil
+ install:true
+ skipIfSame:false
+!
+
+compile:aString forClass:aClass inCategory:cat
+ "compile a source-string for a method in classToCompileFor.
+ The method will get cat as category"
+
+ ^ self compile:aString
+ forClass:aClass
+ inCategory:cat
+ notifying:nil
+ install:true
+ skipIfSame:false
+!
+
+compile:methodText forClass:classToCompileFor notifying:someOne
+ "compile a source-string for a method in classToCompileFor.
+ errors are forwarded to someOne."
+
+ ^ self compile:methodText
+ forClass:classToCompileFor
+ inCategory:'others'
+ notifying:someOne
+ install:true
+ skipIfSame:false
+!
+
+compile:aString forClass:aClass inCategory:cat notifying:someOne
+ "compile a source-string for a method in classToCompileFor.
+ errors are forwarded to someOne.
+ The method will get cat as category"
+
+ ^ self compile:aString
+ forClass:aClass
+ inCategory:cat
+ notifying:someOne
+ install:true
+ skipIfSame:false
+!
+
+compile:aString forClass:aClass inCategory:cat notifying:someOne
+ install:install
+ ^ self compile:aString
+ forClass:aClass
+ inCategory:cat
+ notifying:someOne
+ install:true
+ skipIfSame:false
+!
+
+compile:aString forClass:aClass inCategory:cat notifying:someOne
+ install:install skipIfSame:skipIfSame
+
+ "the basic workhorse method for compiling.
+ compile a source-string for a method in classToCompileFor.
+ errors are forwarded to someOne (report on Transcript and return
+ #Error, if someOne is nil).
+
+ The new method will get cat as category. If install is true, the method
+ will go into the classes method-table, otherwise the method is simply
+ returned (for anonymous methods).
+ If skipIsSame is true, and the source is the same as an existing
+ methods source, this is a noop (for fast fileIn)."
+
+ |compiler newMethod tree lits machineCode
+ symbolicCodeArray sharedCode sharedCodeSymbol oldMethod|
+
+ aString isNil ifTrue:[^ nil].
+
+ "create a compiler, let it parse and create the parsetree"
+
+ compiler := self for:(ReadStream on:aString).
+ compiler setClassToCompileFor:aClass.
+ compiler notifying:someOne.
+
+ compiler nextToken.
+ (compiler parseMethodSpec == #Error) ifTrue:[
+ tree := #Error
+ ] ifFalse:[
+ "check if same source"
+ (skipIfSame and:[compiler selector notNil]) ifTrue:[
+ oldMethod := aClass compiledMethodAt:(compiler selector).
+ oldMethod notNil ifTrue:[
+ oldMethod source = aString ifTrue:[
+ SilentLoading ifFalse:[
+ Transcript showCr:('unchanged: ',aClass name,' ',compiler selector)
+ ].
+ ^ oldMethod
+ ]
+ ]
+ ].
+ tree := compiler parseMethodBody.
+ compiler tree:tree.
+ ].
+
+ (compiler errorFlag or:[tree == #Error]) ifTrue:[
+ compiler selector notNil ifTrue:[
+ Transcript show:(compiler selector,' ')
+ ].
+ Transcript showCr:'syntax error'.
+ ^ #Error
+ ].
+
+ compiler selector isNil ifTrue:[
+ "it was just a comment or other empty stuff"
+ ^ nil
+ ].
+
+ "let it produce symbolic code first"
+
+ symbolicCodeArray := compiler genSymbolicCode.
+ (symbolicCodeArray == #Error) ifTrue:[
+ compiler selector notNil ifTrue:[
+ Transcript show:(compiler selector,' ')
+ ].
+ Transcript showCr:'translation error'.
+ ^ #Error
+ ].
+
+ ((compiler genByteCodeFrom:symbolicCodeArray) == #Error) ifTrue:[
+ compiler selector notNil ifTrue:[
+ Transcript show:(compiler selector,' ')
+ ].
+ Transcript showCr:'relocation error - must be simplified'.
+ ^ #Error
+ ].
+
+ "check for primitive code"
+ compiler primitiveNumber notNil ifTrue:[
+ machineCode := compiler checkForPrimitiveCode:compiler primitiveNumber.
+ machineCode isNil ifTrue:[
+ Transcript showCr:'primitive ', compiler primitiveNumber printString , ' is not supported'.
+ ^ #Error
+ ]
+ ].
+
+ machineCode isNil ifTrue:[
+ "check for shared-code (only trivial methods)"
+
+ sharedCodeSymbol := compiler checkForSharedCode:symbolicCodeArray.
+ sharedCodeSymbol notNil ifTrue:[
+ sharedCode := self sharedCodeFunctionFor:sharedCodeSymbol
+ ].
+
+ "try to make it machine code"
+
+ machineCode := compiler checkForMachineCode:symbolicCodeArray
+ ].
+
+ "finally create the new method-object"
+
+ newMethod := Method new.
+ lits := compiler literalArray.
+ lits notNil ifTrue:[
+ "literals MUST be an array - not just any Collection"
+ lits := Array withAll:lits.
+ newMethod literals:lits
+ ].
+ newMethod byteCode:(compiler code).
+ sharedCode notNil ifTrue:[
+ newMethod code:sharedCode
+ ] ifFalse:[
+ machineCode notNil ifTrue:[
+ newMethod code:machineCode
+ ]
+ ].
+ newMethod source:aString.
+ newMethod category:cat.
+ newMethod numberOfMethodVars:(compiler numberOfMethodVars).
+ newMethod stackSize:(compiler maxStackDepth).
+
+ install ifTrue:[
+ aClass addSelector:(compiler selector) withMethod:newMethod
+ ].
+
+ SilentLoading ifFalse:[
+ Transcript showCr:('compiled: ',aClass name,' ',compiler selector)
+ ].
+
+ ^ newMethod
+! !
+
+!ByteCodeCompiler methodsFor:'accessing'!
+
+literalArray
+ "return the literal array - only valid after parsing"
+
+ ^ litArray
+!
+
+code
+ "return the literal array - only valid after code-generation"
+
+ ^ code
+!
+
+maxStackDepth
+ "return the stack-need of the method - only valid after code-generation"
+
+ ^ maxStackDepth
+! !
+
+!ByteCodeCompiler methodsFor:'code generation'!
+
+genSymbolicCode
+ "traverse the parse-tree producing symbolicCode - return the codeArray"
+
+ |codeStream thisStatement lastStatement|
+
+ codeStream := WriteStream on:(Array new:100).
+ thisStatement := tree.
+ [thisStatement notNil] whileTrue:[
+ lastStatement := thisStatement.
+ thisStatement codeForSideEffectOn:codeStream inBlock:nil.
+ thisStatement := thisStatement nextStatement
+ ].
+ (lastStatement isNil or:[(lastStatement isMemberOf:ReturnNode) not])
+ ifTrue:[
+ "not a return - add retSelf"
+ codeStream nextPut:#retSelf
+ ].
+ ^ codeStream contents
+!
+
+checkForPrimitiveCode:primNr
+ "this was added to allow emulation of (some) ST-80
+ primitives (to fileIn Remote-Package)"
+
+ (primNr == 75) ifTrue:[ ^ (Object compiledMethodAt:#identityHash) code ].
+ (primNr == 110) ifTrue:[ ^ (Object compiledMethodAt:#==) code ].
+ (primNr == 111) ifTrue:[ ^ (Object compiledMethodAt:#class) code ].
+ ^ nil
+!
+
+genByteCodeFrom:symbolicCodeArray
+ "convert symbolicCode into bytecodes"
+
+ |symIndex "<SmallInteger>"
+ codeSize "<SmallInteger>"
+ symCodeSize "<SmallInteger>"
+ index addr
+ codeSymbol nargs done
+ stackDepth relocInfo level nvars|
+
+ symbolicCodeArray isNil ifTrue:[^ self].
+
+ done := false.
+ symCodeSize := symbolicCodeArray size.
+ codeSize := symCodeSize.
+
+ [done] whileFalse:[
+ litArray := nil.
+ stackDepth := 0.
+ maxStackDepth := 0.
+
+ code := ByteArray new:codeSize.
+ relocInfo := Array new:(codeSize + 1).
+ symIndex := 1.
+ codeIndex := 1.
+
+ [symIndex <= symCodeSize] whileTrue:[
+ relocInfo at:symIndex put:codeIndex.
+
+ codeSymbol := symbolicCodeArray at:symIndex.
+ symIndex := symIndex + 1.
+ stackDelta := 0.
+ extra := nil.
+ lineno := false.
+ self appendByteCodeFor:codeSymbol.
+ lineno ifTrue:[
+ self appendByte:((symbolicCodeArray at:symIndex) min:255).
+ symIndex := symIndex + 1
+ ].
+ extra notNil ifTrue:[
+ (extra == #number) ifTrue:[
+ index := symbolicCodeArray at:symIndex.
+ symIndex := symIndex + 1.
+ self appendSignedByte:index
+ ] ifFalse:[
+ (extra == #index) ifTrue:[
+ index := symbolicCodeArray at:symIndex.
+ symIndex := symIndex + 1.
+ self appendByte:index
+ ] ifFalse:[
+ (extra == #lit) ifTrue:[
+ index := self addLiteral:(symbolicCodeArray at:symIndex).
+ symIndex := symIndex + 1.
+ self appendByte:index
+ ] ifFalse:[
+ (extra == #speciallit) ifTrue:[
+ index := self addLiteral:(symbolicCodeArray at:symIndex).
+ symIndex := symIndex + 1.
+ self appendByte:index.
+ self appendByte:0. "space for inline-generation"
+ self appendByte:0. "space for inline-address"
+ self appendByte:0.
+ self appendByte:0.
+ self appendByte:0.
+ symIndex := symIndex + 5
+ ] ifFalse:[
+ (extra == #offset) ifTrue:[
+ relocInfo at:symIndex put:codeIndex.
+ self addReloc:symIndex.
+ symIndex := symIndex + 1.
+ self appendByte:0
+ ] ifFalse:[
+ (extra == #indexLevel) ifTrue:[
+ index := symbolicCodeArray at:symIndex.
+ symIndex := symIndex + 1.
+ self appendByte:index.
+ level := symbolicCodeArray at:symIndex.
+ symIndex := symIndex + 1.
+ self appendByte:level
+ ] ifFalse:[
+ (extra == #offsetNvarNarg) ifTrue:[
+ relocInfo at:symIndex put:codeIndex.
+ self addReloc:symIndex.
+ symIndex := symIndex + 1.
+ self appendByte:0.
+ nvars := symbolicCodeArray at:symIndex.
+ symIndex := symIndex + 1.
+ self appendByte:nvars.
+ level := symbolicCodeArray at:symIndex.
+ symIndex := symIndex + 1.
+ self appendByte:level
+ ] ifFalse:[
+ (extra == #absoffset) ifTrue:[
+ addr := symbolicCodeArray at:symIndex.
+ symIndex := symIndex + 1.
+ self appendByte:(addr bitAnd:16rFF).
+ self appendByte:((addr bitShift:-8) bitAnd:16rFF).
+ ] ifFalse:[
+ self error:'compiler botch'
+ ]
+ ]
+ ]
+ ]
+ ]
+ ]
+ ]
+ ]
+ ].
+ ((codeSymbol == #send) or:[codeSymbol == #superSend]) ifTrue:[
+ index := self addLiteral:(symbolicCodeArray at:symIndex).
+ symIndex := symIndex + 1.
+ nargs := symbolicCodeArray at:symIndex.
+ symIndex := symIndex + 1.
+ self appendByte:nargs.
+ self appendByte:index.
+ (codeSymbol == #superSend) ifTrue:[
+ symIndex := symIndex + 1.
+ index := self addLiteral:(classToCompileFor superclass).
+ self appendByte:index
+ ].
+ stackDelta := nargs negated
+ ] ifFalse:[
+ (codeSymbol == #sendDrop) ifTrue:[
+ index := self addLiteral:(symbolicCodeArray at:symIndex).
+ symIndex := symIndex + 1.
+ nargs := symbolicCodeArray at:symIndex.
+ symIndex := symIndex + 1.
+ self appendByte:nargs.
+ self appendByte:index.
+ stackDelta := (nargs + 1) negated
+ ]
+ ].
+ stackDepth := stackDepth + stackDelta.
+ (stackDepth > maxStackDepth) ifTrue:[
+ maxStackDepth := stackDepth
+ ]
+ ].
+ relocInfo at:symIndex put:codeIndex.
+
+ "relocate - returns true if ok, false if we have to rerun"
+ done := true.
+ relocList notNil ifTrue:[
+ done := self relocateWith:symbolicCodeArray relocInfo:relocInfo.
+ "if returned with false, a relative jump was made into
+ an absolute jump - need to start over with one more byte space"
+ codeSize := codeSize + 1.
+ ].
+ ].
+ "code printNewline."
+ ^ errorFlag
+!
+
+relocateWith:symbolicCodeArray relocInfo:relocInfo
+ "helper for genByteCodeFrom - relocate code using relocInfo.
+ if relocation fails badly (due to long relative jumps) patch
+ symbolicCode to use absolute jumps instead and return false
+ (genByteCodeFrom will then try again). Otherwise return true."
+
+ |delta "<SmallInteger>"
+ codePos "<SmallInteger>"
+ prevCodePos "<SmallInteger>"
+ codeOffset "<SmallInteger>"
+ symOffset opcode dstOpcode jumpTarget
+ jumpCode|
+
+ relocList do:[:sIndex |
+ "have to relocate symCode at index ..."
+ symOffset := symbolicCodeArray at:sIndex.
+ codePos := relocInfo at:sIndex.
+ codeOffset := relocInfo at:symOffset.
+ prevCodePos := codePos - 1.
+ delta := codeOffset - codePos - 1.
+ opcode := code at:prevCodePos.
+
+ "optimize jump to return and jump to jump"
+ (opcode == 54) ifTrue:[
+ "a jump"
+ dstOpcode := symbolicCodeArray at:codeOffset.
+ (#(retSelf retTop retNil retTrue retFalse ret0) includes:dstOpcode) ifTrue:[
+ "a jump to a return - put in the return instead jump"
+ code at:prevCodePos put:(self byteCodeFor:dstOpcode).
+ delta := 0
+ ] ifFalse:[
+ (dstOpcode == #jump) ifTrue:[
+ "jump to jump to be done soon"
+ jumpTarget := symbolicCodeArray at:(codeOffset + 1)
+"
+ .
+ 'jump to jump: ' print. dstOpcode printNewline
+"
+ ]
+ ]
+ ].
+ (delta >= 0) ifTrue:[
+ (delta > 127) ifTrue:[
+ (opcode between:50 and:59) ifFalse:[
+ self error:'invalid code to relocate'
+ ].
+ (delta > 255) ifTrue:[
+ "change jmp into vljmp ..."
+ code at:prevCodePos put:(opcode + 20).
+ delta := delta - 256
+ ] ifFalse:[
+ "change jmp into ljmp ..."
+ code at:prevCodePos put:(opcode + 10).
+ delta := delta - 128
+ ].
+ (delta > 127) ifTrue:[
+ "change symbolic into a jump absolute and fail"
+ jumpCode := symbolicCodeArray at:(sIndex - 1).
+ jumpCode == #jump ifTrue:[
+ symbolicCodeArray at:(sIndex - 1) put:#jumpabs.
+ symbolicCodeArray at:sIndex put:codeOffset.
+ ^ false
+ ].
+ jumpCode == #trueJump ifTrue:[
+ symbolicCodeArray at:(sIndex - 1) put:#trueJumpabs.
+ symbolicCodeArray at:sIndex put:codeOffset.
+ ^ false
+ ].
+ jumpCode == #falseJump ifTrue:[
+ symbolicCodeArray at:(sIndex - 1) put:#falseJumpabs.
+ symbolicCodeArray at:sIndex put:codeOffset.
+ ^ false
+ ].
+ jumpCode == #nilJump ifTrue:[
+ symbolicCodeArray at:(sIndex - 1) put:#nilJumpabs.
+ symbolicCodeArray at:sIndex put:codeOffset.
+ ^ false
+ ].
+ jumpCode == #notNilJump ifTrue:[
+ symbolicCodeArray at:(sIndex - 1) put:#notNilJumpabs.
+ symbolicCodeArray at:sIndex put:codeOffset.
+ ^ false
+ ].
+ jumpCode == #eqJump ifTrue:[
+ symbolicCodeArray at:(sIndex - 1) put:#eqJumpabs.
+ symbolicCodeArray at:sIndex put:codeOffset.
+ ^ false
+ ].
+ jumpCode == #notEqJump ifTrue:[
+ symbolicCodeArray at:(sIndex - 1) put:#notEqJumpabs.
+ symbolicCodeArray at:sIndex put:codeOffset.
+ ^ false
+ ].
+ jumpCode == #zeroJump ifTrue:[
+ symbolicCodeArray at:(sIndex - 1) put:#zeroJumpabs.
+ symbolicCodeArray at:sIndex put:codeOffset.
+ ^ false
+ ].
+ jumpCode == #notZeroJump ifTrue:[
+ symbolicCodeArray at:(sIndex - 1) put:#notZeroJumpabs.
+ symbolicCodeArray at:sIndex put:codeOffset.
+ ^ false
+ ].
+ errorFlag := #Error
+ ]
+ ].
+ code at:codePos put:delta
+ ] ifFalse:[
+ (delta < -128) ifTrue:[
+ (opcode between:50 and:59) ifFalse:[
+ self error:'invalid code to relocate'
+ ].
+ (delta < -256) ifTrue:[
+ "change jmp into vljmp ..."
+ code at:prevCodePos put:(opcode + 20).
+ delta := delta + 256
+ ] ifFalse:[
+ "change jmp into ljmp ..."
+ code at:prevCodePos put:(opcode + 10).
+ delta := delta + 128
+ ].
+ (delta < -128) ifTrue:[
+ jumpCode := symbolicCodeArray at:(sIndex - 1).
+self halt.
+ errorFlag := #Error
+ ]
+ ].
+ code at:codePos put:(256 + delta)
+ ]
+ ].
+ (errorFlag == #Error) ifTrue:[
+ self error:'relocation range error'
+ ].
+ ^ true
+!
+
+addLiteral:anObject
+ "add a literal to the literalArray - watch for and eliminate
+ duplicates. return the index of the literal in the Array"
+
+ |index|
+
+ litArray isNil ifTrue:[
+ litArray := Array with:anObject.
+ ^ 1
+ ].
+ index := litArray identityIndexOf:anObject.
+ (index == 0) ifTrue:[
+ litArray := litArray copyWith:anObject.
+ ^ litArray size
+ ].
+ ^ index
+!
+
+appendByteCodeFor:codeSymbol
+ "append the byteCode for an instructionSymbol to the code-Array"
+
+ code at:codeIndex put:(self byteCodeFor:codeSymbol).
+ codeIndex := codeIndex + 1
+!
+
+appendByte:aByte
+ "append a byte to the code-Array, checking for byte-range (debug-only)"
+
+ (aByte between:0 and:255) ifTrue:[
+ code at:codeIndex put:aByte.
+ codeIndex := codeIndex + 1
+ ] ifFalse:[
+ self error:'byte range error'.
+ errorFlag := #Error
+ ]
+!
+
+appendSignedByte:aByte
+ "append a signedbyte (as in jump-offsets) to the code-Array,
+ check range and report an error if invalid"
+
+ |b "<SmallInteger>" |
+
+ b := aByte.
+ (b >= 0) ifTrue:[
+ (b > 127) ifTrue:[
+ self error:'jump-range error'.
+ errorFlag := #Error
+ ].
+ code at:codeIndex put:b
+ ] ifFalse:[
+ (b < -128) ifTrue:[
+ self error:'jump-range error'.
+ errorFlag := #Error
+ ].
+ code at:codeIndex put:(256 + b)
+ ].
+ codeIndex := codeIndex + 1
+!
+
+addReloc:symIndex
+ "remember to relocate offset at symIndex later ..."
+
+ relocList isNil ifTrue:[
+ relocList := OrderedCollection new.
+ ].
+ relocList add:symIndex
+!
+
+byteCodeFor:aSymbol
+ "given a symbolic instruction, return the corresponding bytecode.
+ as a side-effect, leave number of bytes pushed/popped by this instr.
+ in stackDelta, and, if the instruction needs extra arguments, leave
+ this info in extra"
+
+ "standard bytecodes"
+
+ (aSymbol == #pushNil) ifTrue:[stackDelta := 1. ^ 10].
+ (aSymbol == #pushTrue) ifTrue:[stackDelta := 1. ^ 11].
+ (aSymbol == #pushFalse) ifTrue:[stackDelta := 1. ^ 12].
+ (aSymbol == #pushLit) ifTrue:[stackDelta := 1. extra := #lit. ^ 14].
+ (aSymbol == #pushSelf) ifTrue:[stackDelta := 1. ^ 15].
+ (aSymbol == #pushNum) ifTrue:[stackDelta := 1. extra := #number. ^ 16].
+
+ (aSymbol == #pushMethodArg) ifTrue:[stackDelta := 1. extra := #index. ^ 30].
+ (aSymbol == #pushMethodVar) ifTrue:[stackDelta := 1. extra := #index. ^ 31].
+ (aSymbol == #pushBlockArg) ifTrue:[stackDelta := 1. extra := #index. ^ 32].
+ (aSymbol == #pushBlockVar) ifTrue:[stackDelta := 1. extra := #index. ^ 33].
+ (aSymbol == #pushInstVar) ifTrue:[stackDelta := 1. extra := #index. ^ 34].
+ (aSymbol == #pushOuterBlockArg) ifTrue:[stackDelta := 1.
+ extra := #indexLevel. ^ 42].
+ (aSymbol == #pushOuterBlockVar) ifTrue:[stackDelta := 1.
+ extra := #indexLevel. ^ 128].
+
+ (aSymbol == #storeMethodVar) ifTrue:[extra := #index.
+ stackDelta := -1. ^ 37].
+ (aSymbol == #storeBlockVar) ifTrue:[extra := #index.
+ stackDelta := -1. ^ 38].
+ (aSymbol == #storeInstVar) ifTrue:[extra := #index.
+ stackDelta := -1. ^ 39].
+
+ (aSymbol == #retTop) ifTrue:[stackDelta := -1. ^ 0].
+ (aSymbol == #blockRetTop) ifTrue:[stackDelta := -1. ^ 6].
+
+ (aSymbol == #retSelf) ifTrue:[^5].
+
+ (aSymbol == #==) ifTrue:[stackDelta := -1. self addLiteral:aSymbol. ^ 45].
+ (aSymbol == #~~) ifTrue:[stackDelta := -1. self addLiteral:aSymbol. ^ 46].
+
+ (aSymbol == #falseJump) ifTrue:[stackDelta := -1. extra := #offset. ^ 50].
+ (aSymbol == #trueJump) ifTrue:[stackDelta := -1. extra := #offset. ^ 51].
+ (aSymbol == #nilJump) ifTrue:[stackDelta := -1. extra := #offset. ^ 52].
+ (aSymbol == #notNilJump) ifTrue:[stackDelta := -1. extra := #offset. ^ 53].
+ (aSymbol == #jump) ifTrue:[extra := #offset. ^ 54].
+ (aSymbol == #makeBlock) ifTrue:[stackDelta := 1.
+ extra := #offsetNvarNarg. ^ 55].
+ (aSymbol == #zeroJump) ifTrue:[stackDelta := -1. extra := #offset. ^ 56].
+ (aSymbol == #notZeroJump) ifTrue:[stackDelta := -1. extra := #offset. ^ 57].
+ (aSymbol == #eqJump) ifTrue:[stackDelta := -2. extra := #offset. ^ 58].
+ (aSymbol == #notEqJump) ifTrue:[stackDelta := -2. extra := #offset. ^ 59].
+
+ (aSymbol == #send) ifTrue:[lineno := true. ^ 19].
+ (aSymbol == #superSend) ifTrue:[lineno := true. ^ 20].
+
+ (aSymbol == #drop) ifTrue:[stackDelta := -1. ^ 18].
+ (aSymbol == #dup) ifTrue:[stackDelta := 1. ^ 47].
+
+ (aSymbol == #pushClassVar) ifTrue:[stackDelta := 1. extra := #speciallit. ^ 35].
+ (aSymbol == #pushClassInstVar) ifTrue:[stackDelta := 1. extra := #index. ^ 176].
+ (aSymbol == #pushGlobal) ifTrue:[stackDelta := 1. extra := #speciallit. ^ 36].
+
+ (aSymbol == #storeClassVar) ifTrue:[extra := #speciallit.stackDelta := -1. ^ 40].
+ (aSymbol == #storeClassInstVar) ifTrue:[extra := #index.stackDelta := -1. ^ 177].
+ (aSymbol == #storeGlobal) ifTrue:[extra := #speciallit. stackDelta := -1. ^ 41].
+ (aSymbol == #storeOuterBlockVar) ifTrue:[stackDelta := -1.
+ extra := #indexLevel. ^ 129].
+
+ "optimized bytecodes"
+
+ (aSymbol == #retNil) ifTrue:[^ 1].
+ (aSymbol == #retTrue) ifTrue:[^ 2].
+ (aSymbol == #retFalse) ifTrue:[^ 3].
+ (aSymbol == #ret0) ifTrue:[^ 4].
+ (aSymbol == #retNum) ifTrue:[extra := #number. ^ 127].
+
+ (aSymbol == #pushChar) ifTrue:[stackDelta := 1. ^17].
+ (aSymbol == #push0) ifTrue:[stackDelta := 1. ^120].
+ (aSymbol == #push1) ifTrue:[stackDelta := 1. ^121].
+ (aSymbol == #pushMinus1) ifTrue:[stackDelta := 1. ^122].
+
+ (aSymbol == #send0) ifTrue:[lineno := true. extra := #lit. ^21].
+ (aSymbol == #send1) ifTrue:[lineno := true. extra := #lit. stackDelta := -1. ^22].
+ (aSymbol == #send2) ifTrue:[lineno := true. extra := #lit. stackDelta := -2. ^23].
+ (aSymbol == #send3) ifTrue:[lineno := true. extra := #lit. stackDelta := -3. ^24].
+
+ (aSymbol == #sendSelf0) ifTrue:[lineno := true. extra := #lit. stackDelta := 1. ^180].
+ (aSymbol == #sendSelf1) ifTrue:[lineno := true. extra := #lit. ^181].
+ (aSymbol == #sendSelf2) ifTrue:[lineno := true. extra := #lit. stackDelta := -1. ^182].
+ (aSymbol == #sendSelf3) ifTrue:[lineno := true. extra := #lit. stackDelta := -2. ^183].
+ (aSymbol == #sendSelfDrop0) ifTrue:[lineno := true. extra := #lit. ^184].
+ (aSymbol == #sendSelfDrop1) ifTrue:[lineno := true. extra := #lit. stackDelta := -1. ^185].
+ (aSymbol == #sendSelfDrop2) ifTrue:[lineno := true. extra := #lit. stackDelta := -2. ^186].
+ (aSymbol == #sendSelfDrop3) ifTrue:[lineno := true. extra := #lit. stackDelta := -3. ^187].
+
+ (aSymbol == #sendDrop) ifTrue:[lineno := true. ^25].
+ (aSymbol == #sendDrop0) ifTrue:[lineno := true. extra := #lit. stackDelta := -1. ^26].
+ (aSymbol == #sendDrop1) ifTrue:[lineno := true. extra := #lit. stackDelta := -2. ^27].
+ (aSymbol == #sendDrop2) ifTrue:[lineno := true. extra := #lit. stackDelta := -3. ^28].
+ (aSymbol == #sendDrop3) ifTrue:[lineno := true. extra := #lit. stackDelta := -4. ^29].
+
+ (aSymbol == #pushMethodVar1) ifTrue:[stackDelta := 1. ^80].
+ (aSymbol == #pushMethodVar2) ifTrue:[stackDelta := 1. ^81].
+ (aSymbol == #pushMethodVar3) ifTrue:[stackDelta := 1. ^82].
+ (aSymbol == #pushMethodVar4) ifTrue:[stackDelta := 1. ^83].
+ (aSymbol == #pushMethodVar5) ifTrue:[stackDelta := 1. ^84].
+ (aSymbol == #pushMethodVar6) ifTrue:[stackDelta := 1. ^85].
+
+ (aSymbol == #pushMethodArg1) ifTrue:[stackDelta := 1. ^86].
+ (aSymbol == #pushMethodArg2) ifTrue:[stackDelta := 1. ^87].
+ (aSymbol == #pushMethodArg3) ifTrue:[stackDelta := 1. ^88].
+ (aSymbol == #pushMethodArg4) ifTrue:[stackDelta := 1. ^89].
+
+ (aSymbol == #pushInstVar1) ifTrue:[stackDelta := 1. ^90].
+ (aSymbol == #pushInstVar2) ifTrue:[stackDelta := 1. ^91].
+ (aSymbol == #pushInstVar3) ifTrue:[stackDelta := 1. ^92].
+ (aSymbol == #pushInstVar4) ifTrue:[stackDelta := 1. ^93].
+ (aSymbol == #pushInstVar5) ifTrue:[stackDelta := 1. ^94].
+ (aSymbol == #pushInstVar6) ifTrue:[stackDelta := 1. ^95].
+ (aSymbol == #pushInstVar7) ifTrue:[stackDelta := 1. ^96].
+ (aSymbol == #pushInstVar8) ifTrue:[stackDelta := 1. ^97].
+ (aSymbol == #pushInstVar9) ifTrue:[stackDelta := 1. ^98].
+ (aSymbol == #pushInstVar10) ifTrue:[stackDelta := 1. ^99].
+
+ (aSymbol == #storeMethodVar1) ifTrue:[stackDelta := -1. ^100].
+ (aSymbol == #storeMethodVar2) ifTrue:[stackDelta := -1. ^101].
+ (aSymbol == #storeMethodVar3) ifTrue:[stackDelta := -1. ^102].
+ (aSymbol == #storeMethodVar4) ifTrue:[stackDelta := -1. ^103].
+ (aSymbol == #storeMethodVar5) ifTrue:[stackDelta := -1. ^104].
+ (aSymbol == #storeMethodVar6) ifTrue:[stackDelta := -1. ^105].
+
+ (aSymbol == #storeInstVar1) ifTrue:[stackDelta := -1. ^110].
+ (aSymbol == #storeInstVar2) ifTrue:[stackDelta := -1. ^111].
+ (aSymbol == #storeInstVar3) ifTrue:[stackDelta := -1. ^112].
+ (aSymbol == #storeInstVar4) ifTrue:[stackDelta := -1. ^113].
+ (aSymbol == #storeInstVar5) ifTrue:[stackDelta := -1. ^114].
+ (aSymbol == #storeInstVar6) ifTrue:[stackDelta := -1. ^115].
+ (aSymbol == #storeInstVar7) ifTrue:[stackDelta := -1. ^116].
+ (aSymbol == #storeInstVar8) ifTrue:[stackDelta := -1. ^117].
+ (aSymbol == #storeInstVar9) ifTrue:[stackDelta := -1. ^118].
+ (aSymbol == #storeInstVar10) ifTrue:[stackDelta := -1. ^119].
+
+ (aSymbol == #retMethodVar1) ifTrue:[^160].
+ (aSymbol == #retMethodVar2) ifTrue:[^161].
+ (aSymbol == #retMethodVar3) ifTrue:[^162].
+ (aSymbol == #retMethodVar4) ifTrue:[^163].
+ (aSymbol == #retMethodVar5) ifTrue:[^164].
+ (aSymbol == #retMethodVar6) ifTrue:[^165].
+
+ (aSymbol == #retInstVar1) ifTrue:[^166].
+ (aSymbol == #retInstVar2) ifTrue:[^167].
+ (aSymbol == #retInstVar3) ifTrue:[^168].
+ (aSymbol == #retInstVar4) ifTrue:[^169].
+ (aSymbol == #retInstVar5) ifTrue:[^170].
+ (aSymbol == #retInstVar6) ifTrue:[^171].
+ (aSymbol == #retInstVar7) ifTrue:[^172].
+ (aSymbol == #retInstVar8) ifTrue:[^173].
+
+ (aSymbol == #retMethodArg1) ifTrue:[^174].
+ (aSymbol == #retMethodArg2) ifTrue:[^175].
+
+ (aSymbol == #pushBlockArg1) ifTrue:[stackDelta := 1. ^140].
+ (aSymbol == #pushBlockArg2) ifTrue:[stackDelta := 1. ^141].
+ (aSymbol == #pushBlockArg3) ifTrue:[stackDelta := 1. ^142].
+ (aSymbol == #pushBlockArg4) ifTrue:[stackDelta := 1. ^143].
+
+ (aSymbol == #pushOuter1BlockArg) ifTrue:[
+ stackDelta := 1. extra := #index. ^ 43].
+ (aSymbol == #pushOuter2BlockArg) ifTrue:[
+ stackDelta := 1. extra := #index. ^ 44].
+
+ (aSymbol == #=) ifTrue:[stackDelta := -1. self addLiteral:aSymbol. ^130].
+ (aSymbol == #+) ifTrue:[stackDelta := -1. self addLiteral:aSymbol. ^131].
+ (aSymbol == #~=) ifTrue:[stackDelta := -1. self addLiteral:aSymbol. ^132].
+ (aSymbol == #-) ifTrue:[stackDelta := -1. self addLiteral:aSymbol. ^133].
+ (aSymbol == #class) ifTrue:[self addLiteral:aSymbol. ^134].
+ (aSymbol == #x) ifTrue:[self addLiteral:aSymbol. ^106].
+ (aSymbol == #y) ifTrue:[self addLiteral:aSymbol. ^107].
+ (aSymbol == #width) ifTrue:[self addLiteral:aSymbol. ^108].
+ (aSymbol == #height) ifTrue:[self addLiteral:aSymbol. ^109].
+ (aSymbol == #origin) ifTrue:[self addLiteral:aSymbol. ^154].
+ (aSymbol == #extent) ifTrue:[self addLiteral:aSymbol. ^155].
+ (aSymbol == #at:) ifTrue:[stackDelta := -1. self addLiteral:aSymbol. ^135].
+ (aSymbol == #at:put:)ifTrue:[stackDelta := -2. self addLiteral:aSymbol. ^136].
+ (aSymbol == #bitAnd:) ifTrue:[stackDelta := -1. self addLiteral:aSymbol. ^137].
+ (aSymbol == #bitOr:) ifTrue:[stackDelta := -1. self addLiteral:aSymbol. ^138].
+ (aSymbol == #plus1) ifTrue:[self addLiteral:#+. ^123].
+ (aSymbol == #minus1) ifTrue:[self addLiteral:#-. ^124].
+
+ (aSymbol == #incMethodVar) ifTrue:[self addLiteral:#+. extra := #index. ^125].
+ (aSymbol == #decMethodVar) ifTrue:[self addLiteral:#-. extra := #index. ^126].
+
+ (aSymbol == #eq0) ifTrue:[self addLiteral:#==. ^48].
+ (aSymbol == #ne0) ifTrue:[self addLiteral:#~~. ^49].
+
+ (aSymbol == #>) ifTrue:[self addLiteral:aSymbol. stackDelta := -1. ^ 145].
+ (aSymbol == #>=) ifTrue:[self addLiteral:aSymbol. stackDelta := -1. ^ 146].
+ (aSymbol == #<) ifTrue:[self addLiteral:aSymbol. stackDelta := -1. ^ 147].
+ (aSymbol == #<=) ifTrue:[self addLiteral:aSymbol. stackDelta := -1. ^ 148].
+ (aSymbol == #next) ifTrue:[self addLiteral:aSymbol. ^ 149].
+ (aSymbol == #peek) ifTrue:[self addLiteral:aSymbol. ^ 150].
+ (aSymbol == #value) ifTrue:[self addLiteral:aSymbol. ^ 151].
+ (aSymbol == #value:) ifTrue:[self addLiteral:aSymbol.
+ stackDelta := -1. ^ 152].
+ (aSymbol == #size) ifTrue:[self addLiteral:aSymbol. ^ 153].
+ (aSymbol == #mk0Block) ifTrue:[^ 156].
+ (aSymbol == #mkNilBlock) ifTrue:[^ 157].
+
+ (aSymbol == #falseJumpabs) ifTrue:[stackDelta := -1. extra := #absoffset. ^ 190].
+ (aSymbol == #trueJumpabs) ifTrue:[stackDelta := -1. extra := #absoffset. ^ 191].
+ (aSymbol == #nilJumpabs) ifTrue:[stackDelta := -1. extra := #absoffset. ^ 192].
+ (aSymbol == #notNilJumpabs) ifTrue:[stackDelta := -1. extra := #absoffset. ^ 193].
+ (aSymbol == #jumpabs) ifTrue:[extra := #absoffset. ^ 194].
+ (aSymbol == #zeroJumpabs) ifTrue:[stackDelta := -1. extra := #absoffset. ^ 196].
+ (aSymbol == #notZeroJumpabs) ifTrue:[stackDelta := -1. extra := #absoffset. ^ 197].
+ (aSymbol == #eqJumpabs) ifTrue:[stackDelta := -1. extra := #absoffset. ^ 198].
+ (aSymbol == #notEqJumpabs) ifTrue:[stackDelta := -1. extra := #absoffset. ^ 199].
+
+ (aSymbol == #pushThisContext) ifTrue:[stackDelta := 1. ^ 144].
+
+ self error:'invalid code symbol'.
+ errorFlag := #Error
+! !
+
+!ByteCodeCompiler class methodsFor:'machine code constants'!
+
+sharedCodeFunctionFor:aSymbol
+ "return the address of a shared code-function"
+
+ |codeSymbol|
+
+ (aSymbol == #retSelf) ifTrue:[
+%{
+ extern OBJ __retSelf();
+#if defined(SYSV4) && defined(i386)
+ OBJ (*dummy)() = __retSelf;
+#endif
+ RETURN ( _MKSMALLINT((int)__retSelf) );
+%}
+ ].
+ (aSymbol == #retNil) ifTrue:[
+%{
+ extern OBJ __retNil();
+#if defined(SYSV4) && defined(i386)
+ OBJ (*dummy)() = __retNil;
+#endif
+ RETURN ( _MKSMALLINT((int)__retNil) );
+%}
+ ].
+ (aSymbol == #retTrue) ifTrue:[
+%{
+ extern OBJ __retTrue();
+#if defined(SYSV4) && defined(i386)
+ OBJ (*dummy)() = __retTrue;
+#endif
+ RETURN ( _MKSMALLINT((int)__retTrue) );
+%}
+ ].
+ (aSymbol == #retFalse) ifTrue:[
+%{
+ extern OBJ __retFalse();
+#if defined(SYSV4) && defined(i386)
+ OBJ (*dummy)() = __retFalse;
+#endif
+ RETURN ( _MKSMALLINT((int)__retFalse) );
+%}
+ ].
+ (aSymbol == #ret0) ifTrue:[
+%{
+ extern OBJ __ret0();
+#if defined(SYSV4) && defined(i386)
+ OBJ (*dummy)() = __ret0;
+#endif
+ RETURN ( _MKSMALLINT((int)__ret0) );
+%}
+ ].
+ (aSymbol == #blockRet0) ifTrue:[
+%{
+ extern OBJ __bRet0();
+#if defined(SYSV4) && defined(i386)
+ OBJ (*dummy)() = __bRet0;
+#endif
+ RETURN ( _MKSMALLINT((int)__bRet0) );
+%}
+ ].
+ (aSymbol == #blockRetNil) ifTrue:[
+%{
+ extern OBJ __bRetNil();
+#if defined(SYSV4) && defined(i386)
+ OBJ (*dummy)() = __bRetNil;
+#endif
+ RETURN ( _MKSMALLINT((int)__bRetNil) );
+%}
+ ].
+ (aSymbol == #blockRetTrue) ifTrue:[
+%{
+ extern OBJ __bRetTrue();
+#if defined(SYSV4) && defined(i386)
+ OBJ (*dummy)() = __bRetTrue;
+#endif
+ RETURN ( _MKSMALLINT((int)__bRetTrue) );
+%}
+ ].
+ (aSymbol == #blockRetFalse) ifTrue:[
+%{
+ extern OBJ __bRetFalse();
+#if defined(SYSV4) && defined(i386)
+ OBJ (*dummy)() = __bRetFalse;
+#endif
+ RETURN ( _MKSMALLINT((int)__bRetFalse) );
+%}
+ ].
+ (aSymbol == #retInstVar1) ifTrue:[
+%{
+ extern OBJ __retInst0();
+#if defined(SYSV4) && defined(i386)
+ OBJ (*dummy)() = __retInst0;
+#endif
+ RETURN ( _MKSMALLINT((int)__retInst0) );
+%}
+ ].
+ (aSymbol == #retInstVar2) ifTrue:[
+%{
+ extern OBJ __retInst1();
+#if defined(SYSV4) && defined(i386)
+ OBJ (*dummy)() = __retInst1;
+#endif
+ RETURN ( _MKSMALLINT((int)__retInst1) );
+%}
+ ].
+ (aSymbol == #retInstVar3) ifTrue:[
+%{
+ extern OBJ __retInst2();
+#if defined(SYSV4) && defined(i386)
+ OBJ (*dummy)() = __retInst2;
+#endif
+ RETURN ( _MKSMALLINT((int)__retInst2) );
+%}
+ ].
+ (aSymbol == #retInstVar4) ifTrue:[
+%{
+ extern OBJ __retInst3();
+#if defined(SYSV4) && defined(i386)
+ OBJ (*dummy)() = __retInst3;
+#endif
+ RETURN ( _MKSMALLINT((int)__retInst3) );
+%}
+ ].
+ (aSymbol == #retInstVar5) ifTrue:[
+%{
+ extern OBJ __retInst4();
+#if defined(SYSV4) && defined(i386)
+ OBJ (*dummy)() = __retInst4;
+#endif
+ RETURN ( _MKSMALLINT((int)__retInst4) );
+%}
+ ].
+ (aSymbol == #retInstVar6) ifTrue:[
+%{
+ extern OBJ __retInst5();
+#if defined(SYSV4) && defined(i386)
+ OBJ (*dummy)() = __retInst5;
+#endif
+ RETURN ( _MKSMALLINT((int)__retInst5) );
+%}
+ ].
+ (aSymbol == #retInstVar7) ifTrue:[
+%{
+ extern OBJ __retInst6();
+#if defined(SYSV4) && defined(i386)
+ OBJ (*dummy)() = __retInst6;
+#endif
+ RETURN ( _MKSMALLINT((int)__retInst6) );
+%}
+ ].
+ (aSymbol == #retInstVar8) ifTrue:[
+%{
+ extern OBJ __retInst7();
+#if defined(SYSV4) && defined(i386)
+ OBJ (*dummy)() = __retInst7;
+#endif
+ RETURN ( _MKSMALLINT((int)__retInst7) );
+%}
+ ].
+ (aSymbol == #storeInstVar1) ifTrue:[
+%{
+ extern OBJ __setInst0();
+#if defined(SYSV4) && defined(i386)
+ OBJ (*dummy)() = __setInst0;
+#endif
+ RETURN ( _MKSMALLINT((int)__setInst0) );
+%}
+ ].
+ (aSymbol == #storeInstVar2) ifTrue:[
+%{
+ extern OBJ __setInst1();
+#if defined(SYSV4) && defined(i386)
+ OBJ (*dummy)() = __setInst1;
+#endif
+ RETURN ( _MKSMALLINT((int)__setInst1) );
+%}
+ ].
+ (aSymbol == #storeInstVar3) ifTrue:[
+%{
+ extern OBJ __setInst2();
+#if defined(SYSV4) && defined(i386)
+ OBJ (*dummy)() = __setInst2;
+#endif
+ RETURN ( _MKSMALLINT((int)__setInst2) );
+%}
+ ].
+ (aSymbol == #storeInstVar4) ifTrue:[
+%{
+ extern OBJ __setInst3();
+#if defined(SYSV4) && defined(i386)
+ OBJ (*dummy)() = __setInst3;
+#endif
+ RETURN ( _MKSMALLINT((int)__setInst3) );
+%}
+ ].
+ (aSymbol == #storeInstVar5) ifTrue:[
+%{
+ extern OBJ __setInst4();
+#if defined(SYSV4) && defined(i386)
+ OBJ (*dummy)() = __setInst4;
+#endif
+ RETURN ( _MKSMALLINT((int)__setInst4) );
+%}
+ ].
+ (aSymbol == #storeInstVar6) ifTrue:[
+%{
+ extern OBJ __setInst5();
+#if defined(SYSV4) && defined(i386)
+ OBJ (*dummy)() = __setInst5;
+#endif
+ RETURN ( _MKSMALLINT((int)__setInst5) );
+%}
+ ].
+ (aSymbol == #storeInstVar7) ifTrue:[
+%{
+ extern OBJ __setInst6();
+#if defined(SYSV4) && defined(i386)
+ OBJ (*dummy)() = __setInst6;
+#endif
+ RETURN ( _MKSMALLINT((int)__setInst6) );
+%}
+ ].
+ (aSymbol == #storeInstVar8) ifTrue:[
+%{
+ extern OBJ __setInst7();
+#if defined(SYSV4) && defined(i386)
+ OBJ (*dummy)() = __setInst7;
+#endif
+ RETURN ( _MKSMALLINT((int)__setInst7) );
+%}
+ ].
+ (aSymbol == #storeInstVar9) ifTrue:[
+%{
+ extern OBJ __setInst8();
+#if defined(SYSV4) && defined(i386)
+ OBJ (*dummy)() = __setInst8;
+#endif
+ RETURN ( _MKSMALLINT((int)__setInst8) );
+%}
+ ].
+ (aSymbol == #storeInstVar10) ifTrue:[
+%{
+ extern OBJ __setInst9();
+#if defined(SYSV4) && defined(i386)
+ OBJ (*dummy)() = __setInst9;
+#endif
+ RETURN ( _MKSMALLINT((int)__setInst9) );
+%}
+ ].
+ ^ nil
+! !
+
+!ByteCodeCompiler methodsFor:'machine code generation'!
+
+checkForSharedCode:symbolicCodeArray
+ "if this method is a very simple one,
+ we can use the shared compiled code"
+
+ |codeSymbol nArgs|
+
+ symbolicCodeArray isNil ifTrue:[^ nil].
+ codeSymbol := symbolicCodeArray at:1.
+ nArgs := methodArgs size.
+ (nArgs == 0) ifTrue:[
+ (codeSymbol == #retSelf) ifTrue:[^ codeSymbol].
+ (codeSymbol == #retTrue) ifTrue:[^ codeSymbol].
+ (codeSymbol == #retFalse) ifTrue:[^ codeSymbol].
+ (codeSymbol == #retNil) ifTrue:[^ codeSymbol].
+ (codeSymbol == #ret0) ifTrue:[^ codeSymbol].
+ ('retInstVar*' match:codeSymbol) ifTrue:[^ codeSymbol]
+ ].
+ (nArgs == 0) ifTrue:[
+ (codeSymbol == #pushMethodArg1) ifTrue:[
+ ('storeInstVar*' match:(symbolicCodeArray at:2)) ifTrue:[
+ ((symbolicCodeArray at:3) == #retSelf) ifTrue:[^ symbolicCodeArray at:2]
+ ].
+ ^ nil
+ ]
+ ].
+ ^ nil
+!
+
+checkForMachineCode:symbolicCodeArray
+ "if this method is a simple one,
+ we can compile it into machine code"
+
+ |code1 code2 code3 name|
+
+ symbolicCodeArray isNil ifTrue:[^ nil].
+ code1 := symbolicCodeArray at:1.
+ (code1 == #retNum) ifTrue:[
+ ^ self codeForRetNum:(symbolicCodeArray at:2)
+ ].
+ (code1 == #pushNum) ifTrue:[
+ code2 := symbolicCodeArray at:3.
+ (code2 == #retTop) ifTrue:[
+ ^ self codeForRetNum:(symbolicCodeArray at:2)
+ ].
+ ^ nil
+ ].
+ (code1 == #pushMethodArg1) ifTrue:[
+ code2 := symbolicCodeArray at:2.
+ ((code2 == #storeGlobal)
+ or:[code2 == #storeClassVar]) ifTrue:[
+ code3 := symbolicCodeArray at:4.
+ (code3 == #retSelf) ifTrue:[
+ name := symbolicCodeArray at:3.
+ ^ self codeForSetCell:name
+ ]
+ ].
+ ^ nil
+ ].
+
+ (code1 == #pushGlobal) ifTrue:[
+ code2 := symbolicCodeArray at:8.
+ (code2 == #retTop) ifTrue:[
+ name := symbolicCodeArray at:2.
+ ^ self codeForRetCell:name
+ ].
+ ^ nil
+ ].
+ (code1 == #pushClassVar) ifTrue:[
+ code2 := symbolicCodeArray at:8.
+ (code2 == #retTop) ifTrue:[
+ name := symbolicCodeArray at:2.
+ ^ self codeForRetCell:name
+ ].
+ ^ nil
+ ].
+ (code1 == #pushLit) ifTrue:[
+ code2 := symbolicCodeArray at:3.
+ (code2 == #retTop) ifTrue:[
+ ^ nil
+ ].
+ ^ nil
+ ].
+ ^ nil
+!
+
+codeForRetNum:value
+ "^ number will be coded into machine code"
+
+ |count b conIndex tagHi newCode|
+
+ count := self codeProtoForRetNumEnd - self codeProtoForRetNum.
+
+ b := ExternalBytes address:(self codeProtoForRetNum).
+
+ "search for sequence 0x92345678"
+
+ tagHi := false.
+ 1 to:count-3 do:[:index |
+ (b at:index) == 16r92 ifTrue:[
+ (b at:index+1) == 16r34 ifTrue:[
+ (b at:index+2) == 16r56 ifTrue:[
+ (b at:index+3) == 16r78 ifTrue:[
+ conIndex := index.
+ tagHi := true
+ ]
+ ]
+ ]
+ ]
+ ].
+
+ conIndex isNil ifTrue:["'search failed' printNewline. "^ nil].
+ tagHi ifFalse:['low tag unsupported' printNewline. ^ nil].
+
+ "allocate code ..."
+
+ newCode := ExternalBytes newForText:count.
+ newCode isNil ifTrue:[
+ 'alloc of text (size ' print. count print. ') failed' printNewline.
+ ^ nil
+ ].
+
+ "copy from proto"
+ 1 to:count do:[:index |
+ newCode at:index put:(b at:index)
+ ].
+ "put in ret-value"
+ newCode at:conIndex put:((value bitShift:-24) bitAnd:16rFF).
+ newCode at:conIndex+1 put:((value bitShift:-16) bitAnd:16rFF).
+ newCode at:conIndex+2 put:((value bitShift:-8) bitAnd:16rFF).
+ newCode at:conIndex+3 put:(value bitAnd:16rFF).
+ tagHi ifTrue:[
+ newCode at:conIndex
+ put:((newCode at:conIndex) bitOr:16r80)
+ ] ifFalse:[
+ ].
+'address is:' print. newCode address printNewline.
+ ^ newCode address
+
+ "ByteCodeCompiler new codeForRetNum:15"
+!
+
+codeForRetCell:aGlobalOrClassVariableSymbol
+ "^ global will be coded into machine code"
+
+ |cell count b conIndex newCode msbFirst|
+
+ cell := Smalltalk cellAt:aGlobalOrClassVariableSymbol.
+ cell isNil ifTrue:[^ nil].
+
+ count := self codeProtoForRetCellEnd - self codeProtoForRetCell.
+
+ b := ExternalBytes address:(self codeProtoForRetCell).
+
+ msbFirst := true.
+
+ "search for sequence 0x12345678 // 78563412"
+ 1 to:count - 3 do:[:index |
+ (b at:index) == 16r12 ifTrue:[
+ (b at:index+1) == 16r34 ifTrue:[
+ (b at:index+2) == 16r56 ifTrue:[
+ (b at:index+3) == 16r78 ifTrue:[
+ conIndex := index
+ ]
+ ]
+ ]
+ ].
+ conIndex isNil ifTrue:[
+ (b at:index) == 16r78 ifTrue:[
+ (b at:index+1) == 16r56 ifTrue:[
+ (b at:index+2) == 16r34 ifTrue:[
+ (b at:index+3) == 16r12 ifTrue:[
+ conIndex := index.
+ msbFirst := false
+ ]
+ ]
+ ]
+ ]
+ ]
+ ].
+
+ conIndex isNil ifTrue:["'search failed' printNewline. " ^ nil].
+
+ "allocate code ..."
+
+ newCode := ExternalBytes newForText:count.
+ newCode isNil ifTrue:['alloc of text (size ' print. count print. ') failed' printNewline.^ nil].
+
+ "copy from proto"
+ 1 to:count do:[:index |
+ newCode at:index put:(b at:index)
+ ].
+ "put in cell address"
+ msbFirst ifTrue:[
+ newCode at:conIndex put:((cell bitShift:-24) bitAnd:16rFF).
+ newCode at:conIndex+1 put:((cell bitShift:-16) bitAnd:16rFF).
+ newCode at:conIndex+2 put:((cell bitShift:-8) bitAnd:16rFF).
+ newCode at:conIndex+3 put:(cell bitAnd:16rFF).
+ ] ifFalse:[
+ newCode at:conIndex+3 put:((cell bitShift:-24) bitAnd:16rFF).
+ newCode at:conIndex+2 put:((cell bitShift:-16) bitAnd:16rFF).
+ newCode at:conIndex+1 put:((cell bitShift:-8) bitAnd:16rFF).
+ newCode at:conIndex put:(cell bitAnd:16rFF).
+ ].
+
+'address is:' print. newCode address printNewline.
+ ^ newCode address
+
+ "ByteCodeCompiler new codeForRetCell:#Transcript"
+!
+
+codeForSetCell:aGlobalOrClassVariableSymbol
+ "global := arg will be coded into machine code"
+
+ |cell count b conIndex newCode|
+
+ cell := Smalltalk cellAt:aGlobalOrClassVariableSymbol.
+ cell isNil ifTrue:[^ nil].
+
+ count := self codeProtoForSetCellEnd - self codeProtoForSetCell.
+
+ b := ExternalBytes address:(self codeProtoForSetCell).
+
+ "search for sequence 0x12345678"
+ 1 to:count - 3 do:[:index |
+ (b at:index) == 16r12 ifTrue:[
+ (b at:index+1) == 16r34 ifTrue:[
+ (b at:index+2) == 16r56 ifTrue:[
+ (b at:index+3) == 16r78 ifTrue:[
+ conIndex := index
+ ]
+ ]
+ ]
+ ]
+ ].
+
+ conIndex isNil ifTrue:["'search failed' printNewline." ^ nil].
+
+ "allocate code ..."
+
+ newCode := ExternalBytes newForData:count.
+ newCode isNil ifTrue:['alloc of data (size ' print. count print. ') failed' printNewline.^ nil].
+
+ "copy from proto"
+ 1 to:count do:[:index |
+ newCode at:index put:(b at:index)
+ ].
+ "put in cell address"
+ newCode at:conIndex put:((cell bitShift:-24) bitAnd:16rFF).
+ newCode at:conIndex+1 put:((cell bitShift:-16) bitAnd:16rFF).
+ newCode at:conIndex+2 put:((cell bitShift:-8) bitAnd:16rFF).
+ newCode at:conIndex+3 put:(cell bitAnd:16rFF).
+
+'address is:' print. newCode address printNewline.
+ ^ newCode address
+
+ "ByteCodeCompiler new codeForSetCell:#xyz"
+!
+
+codeProtoForRetNum
+%{ /* NOCONTEXT */
+ extern OBJ __retNumProto();
+#if defined(SYSV4) && defined(i386)
+ OBJ (*dummy)() = __retNumProto;
+#endif
+ RETURN ( _MKSMALLINT((int)__retNumProto) );
+%}
+!
+
+codeProtoForRetNumEnd
+%{ /* NOCONTEXT */
+ extern OBJ __retNumProtoEnd();
+#if defined(SYSV4) && defined(i386)
+ OBJ (*dummy)() = __retNumProtoEnd;
+#endif
+ RETURN ( _MKSMALLINT((int)__retNumProtoEnd) );
+%}
+!
+
+codeProtoForRetCell
+%{ /* NOCONTEXT */
+ extern OBJ __retCellProto();
+#if defined(SYSV4) && defined(i386)
+ OBJ (*dummy)() = __retCellProto;
+#endif
+ RETURN ( _MKSMALLINT((int)__retCellProto) );
+%}
+!
+
+codeProtoForRetCellEnd
+%{ /* NOCONTEXT */
+ extern OBJ __retCellProtoEnd();
+#if defined(SYSV4) && defined(i386)
+ OBJ (*dummy)() = __retCellProtoEnd;
+#endif
+ RETURN ( _MKSMALLINT((int)__retCellProtoEnd) );
+%}
+!
+
+codeProtoForSetCell
+%{ /* NOCONTEXT */
+ extern OBJ __setCellProto();
+#if defined(SYSV4) && defined(i386)
+ OBJ (*dummy)() = __setCellProto;
+#endif
+ RETURN ( _MKSMALLINT((int)__setCellProto) );
+%}
+!
+
+codeProtoForSetCellEnd
+%{ /* NOCONTEXT */
+ extern OBJ __setCellProtoEnd();
+#if defined(SYSV4) && defined(i386)
+ OBJ (*dummy)() = __setCellProtoEnd;
+#endif
+ RETURN ( _MKSMALLINT((int)__setCellProtoEnd) );
+%}
+! !
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/CascadeNd.st Fri Jul 16 11:38:57 1993 +0200
@@ -0,0 +1,76 @@
+"
+ COPYRIGHT (c) 1989-93 by Claus Gittinger
+ All Rights Reserved
+
+ This software is furnished under a license and may be used
+ only in accordance with the terms of that license and with the
+ inclusion of the above copyright notice. This software may not
+ be provided or otherwise made available to, or used by, any
+ other person. No title to or ownership of the software is
+ hereby transferred.
+"
+
+MessageNode subclass:#CascadeNode
+ instanceVariableNames:''
+ classVariableNames:''
+ poolDictionaries:''
+ category:'System-Compiler-Support'
+!
+
+CascadeNode comment:'
+
+COPYRIGHT (c) 1989-93 by Claus Gittinger
+ All Rights Reserved
+
+%W% %E%
+'!
+
+!CascadeNode methodsFor: 'code generation'!
+
+codeOn:aStream inBlock:b valueNeeded:valueNeeded
+ receiver codeForCascadeOn:aStream inBlock:b.
+ self codeSendOn:aStream inBlock:b valueNeeded:valueNeeded
+!
+
+codeForCascadeOn:aStream inBlock:b
+ receiver codeForCascadeOn:aStream inBlock:b.
+ aStream nextPut:#dup.
+ self codeSendOn:aStream inBlock:b valueNeeded:false
+! !
+
+!CascadeNode methodsFor: 'evaluating'!
+
+evaluate
+ |t argValueArray index|
+
+ t := receiver evaluateForCascade.
+ argArray isNil ifTrue:[
+ t perform:selector.
+ ^ t
+ ].
+ argValueArray := Array new:(argArray size).
+ index := 1.
+ argArray do:[:arg |
+ argValueArray at:index put:(arg evaluate).
+ index := index + 1
+ ].
+ ^ t perform:selector withArguments:argValueArray
+!
+
+evaluateForCascade
+ |t argValueArray index|
+
+ t := receiver evaluateForCascade.
+ argArray isNil ifTrue:[
+ t perform:selector.
+ ^ t
+ ].
+ argValueArray := Array new:(argArray size).
+ index := 1.
+ argArray do:[:arg |
+ argValueArray at:index put:(arg evaluate).
+ index := index + 1
+ ].
+ t perform:selector withArguments:argValueArray.
+ ^ t
+! !
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/CascadeNode.st Fri Jul 16 11:38:57 1993 +0200
@@ -0,0 +1,76 @@
+"
+ COPYRIGHT (c) 1989-93 by Claus Gittinger
+ All Rights Reserved
+
+ This software is furnished under a license and may be used
+ only in accordance with the terms of that license and with the
+ inclusion of the above copyright notice. This software may not
+ be provided or otherwise made available to, or used by, any
+ other person. No title to or ownership of the software is
+ hereby transferred.
+"
+
+MessageNode subclass:#CascadeNode
+ instanceVariableNames:''
+ classVariableNames:''
+ poolDictionaries:''
+ category:'System-Compiler-Support'
+!
+
+CascadeNode comment:'
+
+COPYRIGHT (c) 1989-93 by Claus Gittinger
+ All Rights Reserved
+
+%W% %E%
+'!
+
+!CascadeNode methodsFor: 'code generation'!
+
+codeOn:aStream inBlock:b valueNeeded:valueNeeded
+ receiver codeForCascadeOn:aStream inBlock:b.
+ self codeSendOn:aStream inBlock:b valueNeeded:valueNeeded
+!
+
+codeForCascadeOn:aStream inBlock:b
+ receiver codeForCascadeOn:aStream inBlock:b.
+ aStream nextPut:#dup.
+ self codeSendOn:aStream inBlock:b valueNeeded:false
+! !
+
+!CascadeNode methodsFor: 'evaluating'!
+
+evaluate
+ |t argValueArray index|
+
+ t := receiver evaluateForCascade.
+ argArray isNil ifTrue:[
+ t perform:selector.
+ ^ t
+ ].
+ argValueArray := Array new:(argArray size).
+ index := 1.
+ argArray do:[:arg |
+ argValueArray at:index put:(arg evaluate).
+ index := index + 1
+ ].
+ ^ t perform:selector withArguments:argValueArray
+!
+
+evaluateForCascade
+ |t argValueArray index|
+
+ t := receiver evaluateForCascade.
+ argArray isNil ifTrue:[
+ t perform:selector.
+ ^ t
+ ].
+ argValueArray := Array new:(argArray size).
+ index := 1.
+ argArray do:[:arg |
+ argValueArray at:index put:(arg evaluate).
+ index := index + 1
+ ].
+ t perform:selector withArguments:argValueArray.
+ ^ t
+! !
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/ConstNode.st Fri Jul 16 11:38:57 1993 +0200
@@ -0,0 +1,158 @@
+"
+ COPYRIGHT (c) 1989-93 by Claus Gittinger
+ All Rights Reserved
+
+ This software is furnished under a license and may be used
+ only in accordance with the terms of that license and with the
+ inclusion of the above copyright notice. This software may not
+ be provided or otherwise made available to, or used by, any
+ other person. No title to or ownership of the software is
+ hereby transferred.
+"
+
+PrimaryNode subclass:#ConstantNode
+ instanceVariableNames:''
+ classVariableNames:'trueNode falseNode nilNode const0Node const1Node
+ float0Node'
+ poolDictionaries:''
+ category:'System-Compiler-Support'
+!
+
+ConstantNode comment:'
+
+COPYRIGHT (c) 1989-93 by Claus Gittinger
+ All Rights Reserved
+
+%W% %E%
+'!
+
+!ConstantNode class methodsFor:'queries'!
+
+typeOfConstant:anObject
+ (anObject isKindOf:SmallInteger) ifTrue:[
+ ^ #Integer
+ ].
+ (anObject isKindOf:Float) ifTrue:[
+ ^ #Float
+ ].
+ anObject isNil ifTrue:[
+ ^ #Nil
+ ].
+ (anObject == true) ifTrue:[
+ ^ #True
+ ].
+ (anObject == false) ifTrue:[
+ ^ #False
+ ].
+ ^ #Literal
+! !
+
+!ConstantNode class methodsFor:'instance creation'!
+
+type:t value:val
+ "some constant nodes are use so often, its worth caching them"
+ (t == #True) ifTrue:[
+ trueNode isNil ifTrue:[
+ trueNode := super type:t value:val
+ ].
+ ^ trueNode
+ ].
+ (t == #False) ifTrue:[
+ falseNode isNil ifTrue:[
+ falseNode := super type:t value:val
+ ].
+ ^ falseNode
+ ].
+ (t == #Nil) ifTrue:[
+ nilNode isNil ifTrue:[
+ nilNode := super type:t value:val
+ ].
+ ^ nilNode
+ ].
+ (t == #Integer) ifTrue:[
+ (val == 0) ifTrue:[
+ const0Node isNil ifTrue:[
+ const0Node := super type:t value:val
+ ].
+ ^ const0Node
+ ].
+ (val == 1) ifTrue:[
+ const1Node isNil ifTrue:[
+ const1Node := super type:t value:val
+ ].
+ ^ const1Node
+ ]
+ ].
+ (t == #Float) ifTrue:[
+ (val = 0.0) ifTrue:[
+ float0Node isNil ifTrue:[
+ float0Node := super type:t value:val
+ ].
+ ^ float0Node
+ ]
+ ].
+ ^ (self basicNew) type:t value:val
+! !
+
+!ConstantNode methodsFor:'queries'!
+
+isConstant
+ ^ true
+! !
+
+!ConstantNode methodsFor:'evaluating'!
+
+evaluate
+ ^ value
+!
+
+store:aValue
+ self error:'store not allowed'.
+ ^ aValue
+! !
+
+!ConstantNode methodsFor:'code generation'!
+
+codeOn:aStream inBlock:b
+ "generated code for the constant"
+
+ (type == #Integer) ifTrue:[
+ (value between: -128 and:127) ifTrue:[
+ (value == 0) ifTrue:[
+ aStream nextPut:#push0. ^ self
+ ].
+ (value == 1) ifTrue:[
+ aStream nextPut:#push1. ^ self
+ ].
+ (value == -1) ifTrue:[
+ aStream nextPut:#pushMinus1. ^ self
+ ].
+ aStream nextPut:#pushNum.
+ aStream nextPut:value.
+ ^ self
+ ]
+ ].
+ (type == #Nil) ifTrue:[
+ aStream nextPut:#pushNil. ^ self
+ ].
+ (type == #True) ifTrue:[
+ aStream nextPut:#pushTrue. ^ self
+ ].
+ (type == #False) ifTrue:[
+ aStream nextPut:#pushFalse. ^ self
+ ].
+ aStream nextPut:#pushLit.
+ aStream nextPut:value
+!
+
+codeStoreOn:aStream
+ "should never be sent"
+
+ ^ self error:'assignment to literals not allowed'
+! !
+
+!ConstantNode methodsFor:'printing'!
+
+printOn:aStream indent:i
+ value storeOn:aStream
+! !
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/ConstantNode.st Fri Jul 16 11:38:57 1993 +0200
@@ -0,0 +1,158 @@
+"
+ COPYRIGHT (c) 1989-93 by Claus Gittinger
+ All Rights Reserved
+
+ This software is furnished under a license and may be used
+ only in accordance with the terms of that license and with the
+ inclusion of the above copyright notice. This software may not
+ be provided or otherwise made available to, or used by, any
+ other person. No title to or ownership of the software is
+ hereby transferred.
+"
+
+PrimaryNode subclass:#ConstantNode
+ instanceVariableNames:''
+ classVariableNames:'trueNode falseNode nilNode const0Node const1Node
+ float0Node'
+ poolDictionaries:''
+ category:'System-Compiler-Support'
+!
+
+ConstantNode comment:'
+
+COPYRIGHT (c) 1989-93 by Claus Gittinger
+ All Rights Reserved
+
+%W% %E%
+'!
+
+!ConstantNode class methodsFor:'queries'!
+
+typeOfConstant:anObject
+ (anObject isKindOf:SmallInteger) ifTrue:[
+ ^ #Integer
+ ].
+ (anObject isKindOf:Float) ifTrue:[
+ ^ #Float
+ ].
+ anObject isNil ifTrue:[
+ ^ #Nil
+ ].
+ (anObject == true) ifTrue:[
+ ^ #True
+ ].
+ (anObject == false) ifTrue:[
+ ^ #False
+ ].
+ ^ #Literal
+! !
+
+!ConstantNode class methodsFor:'instance creation'!
+
+type:t value:val
+ "some constant nodes are use so often, its worth caching them"
+ (t == #True) ifTrue:[
+ trueNode isNil ifTrue:[
+ trueNode := super type:t value:val
+ ].
+ ^ trueNode
+ ].
+ (t == #False) ifTrue:[
+ falseNode isNil ifTrue:[
+ falseNode := super type:t value:val
+ ].
+ ^ falseNode
+ ].
+ (t == #Nil) ifTrue:[
+ nilNode isNil ifTrue:[
+ nilNode := super type:t value:val
+ ].
+ ^ nilNode
+ ].
+ (t == #Integer) ifTrue:[
+ (val == 0) ifTrue:[
+ const0Node isNil ifTrue:[
+ const0Node := super type:t value:val
+ ].
+ ^ const0Node
+ ].
+ (val == 1) ifTrue:[
+ const1Node isNil ifTrue:[
+ const1Node := super type:t value:val
+ ].
+ ^ const1Node
+ ]
+ ].
+ (t == #Float) ifTrue:[
+ (val = 0.0) ifTrue:[
+ float0Node isNil ifTrue:[
+ float0Node := super type:t value:val
+ ].
+ ^ float0Node
+ ]
+ ].
+ ^ (self basicNew) type:t value:val
+! !
+
+!ConstantNode methodsFor:'queries'!
+
+isConstant
+ ^ true
+! !
+
+!ConstantNode methodsFor:'evaluating'!
+
+evaluate
+ ^ value
+!
+
+store:aValue
+ self error:'store not allowed'.
+ ^ aValue
+! !
+
+!ConstantNode methodsFor:'code generation'!
+
+codeOn:aStream inBlock:b
+ "generated code for the constant"
+
+ (type == #Integer) ifTrue:[
+ (value between: -128 and:127) ifTrue:[
+ (value == 0) ifTrue:[
+ aStream nextPut:#push0. ^ self
+ ].
+ (value == 1) ifTrue:[
+ aStream nextPut:#push1. ^ self
+ ].
+ (value == -1) ifTrue:[
+ aStream nextPut:#pushMinus1. ^ self
+ ].
+ aStream nextPut:#pushNum.
+ aStream nextPut:value.
+ ^ self
+ ]
+ ].
+ (type == #Nil) ifTrue:[
+ aStream nextPut:#pushNil. ^ self
+ ].
+ (type == #True) ifTrue:[
+ aStream nextPut:#pushTrue. ^ self
+ ].
+ (type == #False) ifTrue:[
+ aStream nextPut:#pushFalse. ^ self
+ ].
+ aStream nextPut:#pushLit.
+ aStream nextPut:value
+!
+
+codeStoreOn:aStream
+ "should never be sent"
+
+ ^ self error:'assignment to literals not allowed'
+! !
+
+!ConstantNode methodsFor:'printing'!
+
+printOn:aStream indent:i
+ value storeOn:aStream
+! !
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/Decomp.st Fri Jul 16 11:38:57 1993 +0200
@@ -0,0 +1,782 @@
+"
+ COPYRIGHT (c) 1991-93 by Claus Gittinger
+ All Rights Reserved
+
+ This software is furnished under a license and may be used
+ only in accordance with the terms of that license and with the
+ inclusion of the above copyright notice. This software may not
+ be provided or otherwise made available to, or used by, any
+ other person. No title to or ownership of the software is
+ hereby transferred.
+"
+
+ByteCodeCompiler subclass:#Decompiler
+ instanceVariableNames:'extra hasLineNo bytes literals index '
+ classVariableNames:''
+ poolDictionaries:''
+ category:'System-Compiler'
+!
+
+Decompiler comment:'
+
+COPYRIGHT (c) 1991-92 by Claus Gittinger
+ All Rights Reserved
+
+additional methods for decompilation
+
+%W% %E%
+'!
+
+!Decompiler class methodsFor:'decompiling'!
+
+decompile:aMethod
+ ^ (self new) decompile:aMethod
+
+ "Decompiler decompile:(FileBrowser compiledMethodAt:#initialize)"
+! !
+
+!Decompiler methodsFor:'decompiling'!
+
+showOffset:byte
+ |offs|
+
+ index := index + 1.
+ (byte > 127) ifTrue:[
+ offs := byte - 256
+ ] ifFalse:[
+ offs := byte
+ ].
+ Transcript show:(offs printString).
+ Transcript show:' ('.
+ Transcript show:(index + offs) printString.
+ Transcript show:')'
+!
+
+showLongOffset:byte
+ |offs|
+
+ index := index + 1.
+ (byte > 127) ifTrue:[
+ offs := byte - 256 - 128
+ ] ifFalse:[
+ offs := byte + 128
+ ].
+ Transcript show:offs printString.
+ Transcript show:' ('.
+ Transcript show:(index + offs) printString.
+ Transcript show:')'
+!
+
+showVeryLongOffset:byte
+ |offs|
+
+ index := index + 1.
+ (byte > 127) ifTrue:[
+ offs := byte - 256 - 256
+ ] ifFalse:[
+ offs := byte + 256
+ ].
+ Transcript show:offs printString.
+ Transcript show:' ('.
+ Transcript show:(index + offs) printString.
+ Transcript show:')'
+!
+
+showNvarNargsAt:index
+ Transcript show:' nv='.
+ Transcript show:(bytes at:index) printString.
+ Transcript show:' na='.
+ Transcript show:(bytes at:(index + 1)) printString
+!
+
+showLiteralAt:index
+ |offs|
+
+ offs := bytes at:index.
+ Transcript show:(literals at:offs) printString
+!
+
+showLiteral:byte
+ index := index + 1.
+ Transcript show:(literals at:byte) printString.
+!
+
+showLiteralSkip5:byte
+ index := index + 1.
+ Transcript show:(literals at:byte) printString.
+ index := index + 5
+!
+
+showOffsetLevel:byte
+ self showOffset:byte.
+ self showNvarNargsAt:index.
+ index := index + 2
+!
+
+showLongOffsetLevel:byte
+ self showLongOffset:byte.
+ self showNvarNargsAt:index.
+ index := index + 2
+!
+
+showVeryLongOffsetLevel:byte
+ self showVeryLongOffset:byte.
+ self showNvarNargsAt:index.
+ index := index + 2
+!
+
+showSendArgs:byte
+ Transcript show:byte printString.
+ Transcript show:' '.
+ index := index + 1.
+ self showLiteralAt:index
+!
+
+showSuperSendArgs:byte
+ Transcript show:byte printString.
+ Transcript show:' '.
+ index := index + 1.
+ self showLiteralAt:index.
+ index := index + 1
+!
+
+showLineNo:byte
+ Transcript show:' line:' , byte printString.
+ index := index + 1
+!
+
+showIndex:byte
+ Transcript show:byte printString.
+ index := index + 1
+!
+
+showNumber:byte
+ Transcript show:byte printString.
+ index := index + 1
+!
+
+showPC
+ Transcript show:(index printStringRadix:10 size:3 fill:(Character space)).
+ Transcript show:': '.
+ Transcript show:((bytes at:index) printStringRadix:16 size:2 fill:$0).
+ Transcript show:' '.
+!
+
+decompile:aMethod
+ |nBytes offs byte sym sel|
+
+ aMethod isNil ifTrue:[
+ Transcript showCr:'nil method'.
+ ^ self
+ ].
+
+ bytes := aMethod byteCode.
+ bytes isNil ifTrue:[
+ Transcript showCr:'no bytecode'.
+ ^ self
+ ].
+ literals := aMethod literals.
+ index := 1.
+ nBytes := bytes size.
+ [index <= nBytes] whileTrue:[
+ self showPC.
+ sym := self symbolicCodeFor:(bytes at:index).
+ Transcript show:sym.
+"
+ extra notNil ifTrue:[Transcript show:(extra printString)].
+"
+ hasLineNo ifTrue:[
+ index := index + 1
+ ].
+ index := index + 1.
+ extra notNil ifTrue:[
+ Transcript show:' '.
+ byte := bytes at:index.
+
+ "compute argument showXXX selector from extra ..."
+
+ sel := 'show' , extra , ':'.
+ sel at:5 put:(sel at:5) asUppercase.
+ self perform:sel asSymbol with:byte
+ ].
+ Transcript showCr:''
+ ]
+!
+
+symbolicCodeFor:aByte
+ |syms extras lnos|
+
+ syms := #( retTop " 0 "
+ retNil
+ retTrue
+ retFalse
+ ret0
+ retSelf " 5 "
+ blockRetTop
+ nil
+ nil
+ nil
+ pushNil " 10 "
+ pushTrue
+ pushFalse
+ pushInt
+ pushLit
+ pushSelf " 15 "
+ pushNum
+ pushChar
+ drop
+ send
+ superSend " 20 "
+ send0
+ send1
+ send2
+ send3
+ sendDrop " 25 "
+ sendDrop0
+ sendDrop1
+ sendDrop2
+ sendDrop3
+ pushMethodArg " 30 "
+ pushMethodVar
+ pushBlockArg
+ pushBlockVar
+ pushInstVar
+ pushClassVar " 35 "
+ pushGlobal
+ storeMethodVar
+ storeBlockVar
+ storeInstVar
+ storeClassVar " 40 "
+ storeGlobal
+ pushOuterBlockArg
+ pushOuter1BlockArg
+ pushOuter2BlockArg
+ equal " 45 "
+ notEqual
+ dup
+ equal0
+ notEqual0
+ falseJump " 50 "
+ trueJump
+ nilJump
+ notNilJump
+ jump
+ makeBlock " 55 "
+ zeroJump
+ notZeroJump
+ eqJump
+ notEqJump
+ falseJump " 60 "
+ trueJump
+ nilJump
+ notNilJump
+ jump
+ makeBlock " 65 "
+ zeroJump
+ notZeroJump
+ eqJump
+ notEqJump
+ falseJump " 70 "
+ trueJump
+ nilJump
+ notNilJump
+ jump
+ makeBlock " 75 "
+ zeroJump
+ notZeroJump
+ eqJump
+ notEqJump
+ pushMethodVar1 " 80 "
+ pushMethodVar2
+ pushMethodVar3
+ pushMethodVar4
+ pushMethodVar5
+ pushMethodVar6 " 85 "
+ pushMethodArg1
+ pushMethodArg2
+ pushMethodArg3
+ pushMethodArg4
+ pushInstVar1 " 90 "
+ pushInstVar2
+ pushInstVar3
+ pushInstVar4
+ pushInstVar5
+ pushInstVar6 " 95 "
+ pushInstVar7
+ pushInstVar8
+ pushInstVar9
+ pushInstVar10
+ storeMethodVar1 " 100 "
+ storeMethodVar2
+ storeMethodVar3
+ storeMethodVar4
+ storeMethodVar5
+ storeMethodVar6 " 105 "
+ nil
+ nil
+ nil
+ nil
+ storeInstVar1 " 110 "
+ storeInstVar2
+ storeInstVar3
+ storeInstVar4
+ storeInstVar5
+ storeInstVar6 " 115 "
+ storeInstVar7
+ storeInstVar8
+ storeInstVar9
+ storeInstVar10
+ push0 " 120 "
+ push1
+ pushMinus1
+ sendPlus1
+ sendMinus1
+ incMethodVar " 125 "
+ decMethodVar
+ retNum
+ pushOuterBlockVar
+ storeOuterBlockVar
+ sendEQ " 130 "
+ sendPLUS
+ sendNE
+ sendMINUS
+ sendCLASS
+ sendAT " 135 "
+ sendATPUT
+ sendBitAnd
+ sendBitOr
+ nil
+ pushBlockArg1 " 140 "
+ pushBlockArg2
+ pushBlockArg3
+ pushBlockArg4
+ pushContext
+ sendGT " 145 "
+ sendGE
+ sendLT
+ sendLE
+ sendNEXT
+ sendPEEK " 150 "
+ sendVALUE
+ sendVALUE1
+ sendSIZE
+ sendORIGIN
+ sendEXTENT " 155 "
+ make0Block
+ makeNILBlock
+ nil
+ nil
+ retMvar1 " 160 "
+ retMvar2
+ retMvar3
+ retMvar4
+ retMvar5
+ retMvar6 " 165 "
+ retIvar1
+ retIvar2
+ retIvar3
+ retIvar4
+ retIvar5 " 170 "
+ retIvar6
+ retIvar7
+ retIvar8
+ retMarg1
+ retMarg2 " 175 "
+ pushClassInstVar
+ storeClassInstVar
+ nil
+ nil
+ sendSelf0 " 180 "
+ sendSelf1
+ sendSelf2
+ sendSelf3
+ sendSelfDrop0
+ sendSelfDrop1 " 185 "
+ sendSelfDrop2
+ sendSelfDrop3
+ ).
+
+ lnos := #( false " 0 "
+ false
+ false
+ false
+ false
+ false " 5 "
+ false
+ false
+ false
+ false
+ false " 10 "
+ false
+ false
+ false
+ false
+ false " 15 "
+ false
+ false
+ false
+ true
+ true " 20 "
+ true
+ true
+ true
+ true
+ true " 25 "
+ true
+ true
+ true
+ true
+ false " 30 "
+ false
+ false
+ false
+ false
+ false " 35 "
+ false
+ false
+ false
+ false
+ false " 40 "
+ false
+ false
+ false
+ false
+ false " 45 "
+ false
+ false
+ false
+ false
+ false " 50 "
+ false
+ false
+ false
+ false
+ false " 55 "
+ false
+ false
+ false
+ false
+ false " 60 "
+ false
+ false
+ false
+ false
+ false " 65 "
+ false
+ false
+ false
+ false
+ false " 70 "
+ false
+ false
+ false
+ false
+ false " 75 "
+ false
+ false
+ false
+ false
+ false " 80 "
+ false
+ false
+ false
+ false
+ false " 85 "
+ false
+ false
+ false
+ false
+ false " 90 "
+ false
+ false
+ false
+ false
+ false " 95 "
+ false
+ false
+ false
+ false
+ false " 100 "
+ false
+ false
+ false
+ false
+ false " 105 "
+ false
+ false
+ false
+ false
+ false " 110 "
+ false
+ false
+ false
+ false
+ false " 115 "
+ false
+ false
+ false
+ false
+ false " 120 "
+ false
+ false
+ false
+ false
+ false " 125 "
+ false
+ false
+ false
+ false
+ false " 130 "
+ false
+ false
+ false
+ false
+ false " 135 "
+ false
+ false
+ false
+ false
+ false " 140 "
+ false
+ false
+ false
+ false
+ false " 145 "
+ false
+ false
+ false
+ false
+ false " 150 "
+ false
+ false
+ false
+ false
+ false " 155 "
+ false
+ false
+ false
+ false
+ false " 160 "
+ false
+ false
+ false
+ false
+ false " 165 "
+ false
+ false
+ false
+ false
+ false " 170 "
+ false
+ false
+ false
+ false
+ false " 175 "
+ false
+ false
+ false
+ false
+ true " 180 "
+ true
+ true
+ true
+ true
+ true " 185 "
+ true
+ true
+ ).
+
+ extras := #(nil " 0 "
+ nil
+ nil
+ nil
+ nil
+ nil " 5 "
+ nil
+ nil
+ nil
+ nil
+ nil " 10 "
+ nil
+ nil
+ nil
+ literal
+ nil " 15 "
+ number
+ nil
+ nil
+ sendArgs
+ superSendArgs " 20 "
+ literal
+ literal
+ literal
+ literal
+ sendArgs " 25 "
+ literal
+ literal
+ literal
+ literal
+ index " 30 "
+ index
+ index
+ index
+ index
+ literalSkip5 " 35 "
+ literalSkip5
+ index
+ index
+ index
+ literalSkip5 " 40 "
+ literalSkip5
+ indexLevel
+ index
+ index
+ nil " 45 "
+ nil
+ nil
+ nil
+ nil
+ offset " 50 "
+ offset
+ offset
+ offset
+ offset
+ offsetLevel " 55 "
+ offset
+ offset
+ offset
+ offset
+ longOffset " 60 "
+ longOffset
+ longOffset
+ longOffset
+ longOffset
+ longOffsetLevel " 65 "
+ longOffset
+ longOffset
+ longOffset
+ longOffset
+ veryLongOffset " 70 "
+ veryLongOffset
+ veryLongOffset
+ veryLongOffset
+ veryLongOffset
+ veryLongOffsetLevel " 75 "
+ veryLongOffset
+ veryLongOffset
+ veryLongOffset
+ veryLongOffset
+ nil " 80 "
+ nil
+ nil
+ nil
+ nil
+ nil " 85 "
+ nil
+ nil
+ nil
+ nil
+ nil " 90 "
+ nil
+ nil
+ nil
+ nil
+ nil " 95 "
+ nil
+ nil
+ nil
+ nil
+ nil " 100 "
+ nil
+ nil
+ nil
+ nil
+ nil " 105 "
+ nil
+ nil
+ nil
+ nil
+ nil " 110 "
+ nil
+ nil
+ nil
+ nil
+ nil " 115 "
+ nil
+ nil
+ nil
+ nil
+ nil " 120 "
+ nil
+ nil
+ nil
+ nil
+ index " 125 "
+ index
+ number
+ indexLevel
+ indexLevel
+ nil " 130 "
+ nil
+ nil
+ nil
+ nil
+ nil " 135 "
+ nil
+ nil
+ nil
+ nil
+ nil " 140 "
+ nil
+ nil
+ nil
+ nil
+ nil " 145 "
+ nil
+ nil
+ nil
+ nil
+ nil " 150 "
+ nil
+ nil
+ nil
+ nil
+ nil " 155 "
+ nil
+ nil
+ nil
+ nil
+ nil " 160 "
+ nil
+ nil
+ nil
+ nil
+ nil " 165 "
+ nil
+ nil
+ nil
+ nil
+ nil " 170 "
+ nil
+ nil
+ nil
+ nil
+ nil " 175 "
+ index
+ index
+ nil
+ nil
+ literal " 180 "
+ literal
+ literal
+ literal
+ literal
+ literal " 185 "
+ literal
+ literal
+ ).
+
+ extra := extras at:(aByte + 1).
+ hasLineNo := lnos at:(aByte + 1).
+ ^ syms at:(aByte + 1)
+! !
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/Decompiler.st Fri Jul 16 11:38:57 1993 +0200
@@ -0,0 +1,782 @@
+"
+ COPYRIGHT (c) 1991-93 by Claus Gittinger
+ All Rights Reserved
+
+ This software is furnished under a license and may be used
+ only in accordance with the terms of that license and with the
+ inclusion of the above copyright notice. This software may not
+ be provided or otherwise made available to, or used by, any
+ other person. No title to or ownership of the software is
+ hereby transferred.
+"
+
+ByteCodeCompiler subclass:#Decompiler
+ instanceVariableNames:'extra hasLineNo bytes literals index '
+ classVariableNames:''
+ poolDictionaries:''
+ category:'System-Compiler'
+!
+
+Decompiler comment:'
+
+COPYRIGHT (c) 1991-92 by Claus Gittinger
+ All Rights Reserved
+
+additional methods for decompilation
+
+%W% %E%
+'!
+
+!Decompiler class methodsFor:'decompiling'!
+
+decompile:aMethod
+ ^ (self new) decompile:aMethod
+
+ "Decompiler decompile:(FileBrowser compiledMethodAt:#initialize)"
+! !
+
+!Decompiler methodsFor:'decompiling'!
+
+showOffset:byte
+ |offs|
+
+ index := index + 1.
+ (byte > 127) ifTrue:[
+ offs := byte - 256
+ ] ifFalse:[
+ offs := byte
+ ].
+ Transcript show:(offs printString).
+ Transcript show:' ('.
+ Transcript show:(index + offs) printString.
+ Transcript show:')'
+!
+
+showLongOffset:byte
+ |offs|
+
+ index := index + 1.
+ (byte > 127) ifTrue:[
+ offs := byte - 256 - 128
+ ] ifFalse:[
+ offs := byte + 128
+ ].
+ Transcript show:offs printString.
+ Transcript show:' ('.
+ Transcript show:(index + offs) printString.
+ Transcript show:')'
+!
+
+showVeryLongOffset:byte
+ |offs|
+
+ index := index + 1.
+ (byte > 127) ifTrue:[
+ offs := byte - 256 - 256
+ ] ifFalse:[
+ offs := byte + 256
+ ].
+ Transcript show:offs printString.
+ Transcript show:' ('.
+ Transcript show:(index + offs) printString.
+ Transcript show:')'
+!
+
+showNvarNargsAt:index
+ Transcript show:' nv='.
+ Transcript show:(bytes at:index) printString.
+ Transcript show:' na='.
+ Transcript show:(bytes at:(index + 1)) printString
+!
+
+showLiteralAt:index
+ |offs|
+
+ offs := bytes at:index.
+ Transcript show:(literals at:offs) printString
+!
+
+showLiteral:byte
+ index := index + 1.
+ Transcript show:(literals at:byte) printString.
+!
+
+showLiteralSkip5:byte
+ index := index + 1.
+ Transcript show:(literals at:byte) printString.
+ index := index + 5
+!
+
+showOffsetLevel:byte
+ self showOffset:byte.
+ self showNvarNargsAt:index.
+ index := index + 2
+!
+
+showLongOffsetLevel:byte
+ self showLongOffset:byte.
+ self showNvarNargsAt:index.
+ index := index + 2
+!
+
+showVeryLongOffsetLevel:byte
+ self showVeryLongOffset:byte.
+ self showNvarNargsAt:index.
+ index := index + 2
+!
+
+showSendArgs:byte
+ Transcript show:byte printString.
+ Transcript show:' '.
+ index := index + 1.
+ self showLiteralAt:index
+!
+
+showSuperSendArgs:byte
+ Transcript show:byte printString.
+ Transcript show:' '.
+ index := index + 1.
+ self showLiteralAt:index.
+ index := index + 1
+!
+
+showLineNo:byte
+ Transcript show:' line:' , byte printString.
+ index := index + 1
+!
+
+showIndex:byte
+ Transcript show:byte printString.
+ index := index + 1
+!
+
+showNumber:byte
+ Transcript show:byte printString.
+ index := index + 1
+!
+
+showPC
+ Transcript show:(index printStringRadix:10 size:3 fill:(Character space)).
+ Transcript show:': '.
+ Transcript show:((bytes at:index) printStringRadix:16 size:2 fill:$0).
+ Transcript show:' '.
+!
+
+decompile:aMethod
+ |nBytes offs byte sym sel|
+
+ aMethod isNil ifTrue:[
+ Transcript showCr:'nil method'.
+ ^ self
+ ].
+
+ bytes := aMethod byteCode.
+ bytes isNil ifTrue:[
+ Transcript showCr:'no bytecode'.
+ ^ self
+ ].
+ literals := aMethod literals.
+ index := 1.
+ nBytes := bytes size.
+ [index <= nBytes] whileTrue:[
+ self showPC.
+ sym := self symbolicCodeFor:(bytes at:index).
+ Transcript show:sym.
+"
+ extra notNil ifTrue:[Transcript show:(extra printString)].
+"
+ hasLineNo ifTrue:[
+ index := index + 1
+ ].
+ index := index + 1.
+ extra notNil ifTrue:[
+ Transcript show:' '.
+ byte := bytes at:index.
+
+ "compute argument showXXX selector from extra ..."
+
+ sel := 'show' , extra , ':'.
+ sel at:5 put:(sel at:5) asUppercase.
+ self perform:sel asSymbol with:byte
+ ].
+ Transcript showCr:''
+ ]
+!
+
+symbolicCodeFor:aByte
+ |syms extras lnos|
+
+ syms := #( retTop " 0 "
+ retNil
+ retTrue
+ retFalse
+ ret0
+ retSelf " 5 "
+ blockRetTop
+ nil
+ nil
+ nil
+ pushNil " 10 "
+ pushTrue
+ pushFalse
+ pushInt
+ pushLit
+ pushSelf " 15 "
+ pushNum
+ pushChar
+ drop
+ send
+ superSend " 20 "
+ send0
+ send1
+ send2
+ send3
+ sendDrop " 25 "
+ sendDrop0
+ sendDrop1
+ sendDrop2
+ sendDrop3
+ pushMethodArg " 30 "
+ pushMethodVar
+ pushBlockArg
+ pushBlockVar
+ pushInstVar
+ pushClassVar " 35 "
+ pushGlobal
+ storeMethodVar
+ storeBlockVar
+ storeInstVar
+ storeClassVar " 40 "
+ storeGlobal
+ pushOuterBlockArg
+ pushOuter1BlockArg
+ pushOuter2BlockArg
+ equal " 45 "
+ notEqual
+ dup
+ equal0
+ notEqual0
+ falseJump " 50 "
+ trueJump
+ nilJump
+ notNilJump
+ jump
+ makeBlock " 55 "
+ zeroJump
+ notZeroJump
+ eqJump
+ notEqJump
+ falseJump " 60 "
+ trueJump
+ nilJump
+ notNilJump
+ jump
+ makeBlock " 65 "
+ zeroJump
+ notZeroJump
+ eqJump
+ notEqJump
+ falseJump " 70 "
+ trueJump
+ nilJump
+ notNilJump
+ jump
+ makeBlock " 75 "
+ zeroJump
+ notZeroJump
+ eqJump
+ notEqJump
+ pushMethodVar1 " 80 "
+ pushMethodVar2
+ pushMethodVar3
+ pushMethodVar4
+ pushMethodVar5
+ pushMethodVar6 " 85 "
+ pushMethodArg1
+ pushMethodArg2
+ pushMethodArg3
+ pushMethodArg4
+ pushInstVar1 " 90 "
+ pushInstVar2
+ pushInstVar3
+ pushInstVar4
+ pushInstVar5
+ pushInstVar6 " 95 "
+ pushInstVar7
+ pushInstVar8
+ pushInstVar9
+ pushInstVar10
+ storeMethodVar1 " 100 "
+ storeMethodVar2
+ storeMethodVar3
+ storeMethodVar4
+ storeMethodVar5
+ storeMethodVar6 " 105 "
+ nil
+ nil
+ nil
+ nil
+ storeInstVar1 " 110 "
+ storeInstVar2
+ storeInstVar3
+ storeInstVar4
+ storeInstVar5
+ storeInstVar6 " 115 "
+ storeInstVar7
+ storeInstVar8
+ storeInstVar9
+ storeInstVar10
+ push0 " 120 "
+ push1
+ pushMinus1
+ sendPlus1
+ sendMinus1
+ incMethodVar " 125 "
+ decMethodVar
+ retNum
+ pushOuterBlockVar
+ storeOuterBlockVar
+ sendEQ " 130 "
+ sendPLUS
+ sendNE
+ sendMINUS
+ sendCLASS
+ sendAT " 135 "
+ sendATPUT
+ sendBitAnd
+ sendBitOr
+ nil
+ pushBlockArg1 " 140 "
+ pushBlockArg2
+ pushBlockArg3
+ pushBlockArg4
+ pushContext
+ sendGT " 145 "
+ sendGE
+ sendLT
+ sendLE
+ sendNEXT
+ sendPEEK " 150 "
+ sendVALUE
+ sendVALUE1
+ sendSIZE
+ sendORIGIN
+ sendEXTENT " 155 "
+ make0Block
+ makeNILBlock
+ nil
+ nil
+ retMvar1 " 160 "
+ retMvar2
+ retMvar3
+ retMvar4
+ retMvar5
+ retMvar6 " 165 "
+ retIvar1
+ retIvar2
+ retIvar3
+ retIvar4
+ retIvar5 " 170 "
+ retIvar6
+ retIvar7
+ retIvar8
+ retMarg1
+ retMarg2 " 175 "
+ pushClassInstVar
+ storeClassInstVar
+ nil
+ nil
+ sendSelf0 " 180 "
+ sendSelf1
+ sendSelf2
+ sendSelf3
+ sendSelfDrop0
+ sendSelfDrop1 " 185 "
+ sendSelfDrop2
+ sendSelfDrop3
+ ).
+
+ lnos := #( false " 0 "
+ false
+ false
+ false
+ false
+ false " 5 "
+ false
+ false
+ false
+ false
+ false " 10 "
+ false
+ false
+ false
+ false
+ false " 15 "
+ false
+ false
+ false
+ true
+ true " 20 "
+ true
+ true
+ true
+ true
+ true " 25 "
+ true
+ true
+ true
+ true
+ false " 30 "
+ false
+ false
+ false
+ false
+ false " 35 "
+ false
+ false
+ false
+ false
+ false " 40 "
+ false
+ false
+ false
+ false
+ false " 45 "
+ false
+ false
+ false
+ false
+ false " 50 "
+ false
+ false
+ false
+ false
+ false " 55 "
+ false
+ false
+ false
+ false
+ false " 60 "
+ false
+ false
+ false
+ false
+ false " 65 "
+ false
+ false
+ false
+ false
+ false " 70 "
+ false
+ false
+ false
+ false
+ false " 75 "
+ false
+ false
+ false
+ false
+ false " 80 "
+ false
+ false
+ false
+ false
+ false " 85 "
+ false
+ false
+ false
+ false
+ false " 90 "
+ false
+ false
+ false
+ false
+ false " 95 "
+ false
+ false
+ false
+ false
+ false " 100 "
+ false
+ false
+ false
+ false
+ false " 105 "
+ false
+ false
+ false
+ false
+ false " 110 "
+ false
+ false
+ false
+ false
+ false " 115 "
+ false
+ false
+ false
+ false
+ false " 120 "
+ false
+ false
+ false
+ false
+ false " 125 "
+ false
+ false
+ false
+ false
+ false " 130 "
+ false
+ false
+ false
+ false
+ false " 135 "
+ false
+ false
+ false
+ false
+ false " 140 "
+ false
+ false
+ false
+ false
+ false " 145 "
+ false
+ false
+ false
+ false
+ false " 150 "
+ false
+ false
+ false
+ false
+ false " 155 "
+ false
+ false
+ false
+ false
+ false " 160 "
+ false
+ false
+ false
+ false
+ false " 165 "
+ false
+ false
+ false
+ false
+ false " 170 "
+ false
+ false
+ false
+ false
+ false " 175 "
+ false
+ false
+ false
+ false
+ true " 180 "
+ true
+ true
+ true
+ true
+ true " 185 "
+ true
+ true
+ ).
+
+ extras := #(nil " 0 "
+ nil
+ nil
+ nil
+ nil
+ nil " 5 "
+ nil
+ nil
+ nil
+ nil
+ nil " 10 "
+ nil
+ nil
+ nil
+ literal
+ nil " 15 "
+ number
+ nil
+ nil
+ sendArgs
+ superSendArgs " 20 "
+ literal
+ literal
+ literal
+ literal
+ sendArgs " 25 "
+ literal
+ literal
+ literal
+ literal
+ index " 30 "
+ index
+ index
+ index
+ index
+ literalSkip5 " 35 "
+ literalSkip5
+ index
+ index
+ index
+ literalSkip5 " 40 "
+ literalSkip5
+ indexLevel
+ index
+ index
+ nil " 45 "
+ nil
+ nil
+ nil
+ nil
+ offset " 50 "
+ offset
+ offset
+ offset
+ offset
+ offsetLevel " 55 "
+ offset
+ offset
+ offset
+ offset
+ longOffset " 60 "
+ longOffset
+ longOffset
+ longOffset
+ longOffset
+ longOffsetLevel " 65 "
+ longOffset
+ longOffset
+ longOffset
+ longOffset
+ veryLongOffset " 70 "
+ veryLongOffset
+ veryLongOffset
+ veryLongOffset
+ veryLongOffset
+ veryLongOffsetLevel " 75 "
+ veryLongOffset
+ veryLongOffset
+ veryLongOffset
+ veryLongOffset
+ nil " 80 "
+ nil
+ nil
+ nil
+ nil
+ nil " 85 "
+ nil
+ nil
+ nil
+ nil
+ nil " 90 "
+ nil
+ nil
+ nil
+ nil
+ nil " 95 "
+ nil
+ nil
+ nil
+ nil
+ nil " 100 "
+ nil
+ nil
+ nil
+ nil
+ nil " 105 "
+ nil
+ nil
+ nil
+ nil
+ nil " 110 "
+ nil
+ nil
+ nil
+ nil
+ nil " 115 "
+ nil
+ nil
+ nil
+ nil
+ nil " 120 "
+ nil
+ nil
+ nil
+ nil
+ index " 125 "
+ index
+ number
+ indexLevel
+ indexLevel
+ nil " 130 "
+ nil
+ nil
+ nil
+ nil
+ nil " 135 "
+ nil
+ nil
+ nil
+ nil
+ nil " 140 "
+ nil
+ nil
+ nil
+ nil
+ nil " 145 "
+ nil
+ nil
+ nil
+ nil
+ nil " 150 "
+ nil
+ nil
+ nil
+ nil
+ nil " 155 "
+ nil
+ nil
+ nil
+ nil
+ nil " 160 "
+ nil
+ nil
+ nil
+ nil
+ nil " 165 "
+ nil
+ nil
+ nil
+ nil
+ nil " 170 "
+ nil
+ nil
+ nil
+ nil
+ nil " 175 "
+ index
+ index
+ nil
+ nil
+ literal " 180 "
+ literal
+ literal
+ literal
+ literal
+ literal " 185 "
+ literal
+ literal
+ ).
+
+ extra := extras at:(aByte + 1).
+ hasLineNo := lnos at:(aByte + 1).
+ ^ syms at:(aByte + 1)
+! !
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/Make.proto Fri Jul 16 11:38:57 1993 +0200
@@ -0,0 +1,140 @@
+# %W% %E%
+
+# -------------- no need to change anything below ----------
+
+LIBNAME=libcomp
+LIB=libcomp.$(A)
+SUBDIRS=
+
+TOP=..
+I = $(INCLUDE)
+
+STCFLAGS= -H../include -warnGlobalAssign $(STCOPT)
+
+OBJS= Scanner.$(O) Variable.$(O) ParseNode.$(O) Parser.$(O) \
+ PrimaryNd.$(O) \
+ StatNode.$(O) AssignNd.$(O) BlockNode.$(O) MessageNd.$(O) \
+ BCompiler.$(O) RetNode.$(O) UnaryNd.$(O) BinaryNd.$(O) \
+ PrimNd.$(O) CascadeNd.$(O) ConstNode.$(O) \
+ ObjectFile.$(O) ObjFLoader.$(O) UndefVar.$(O)
+
+AUXOBJS= PermBench.$(O) HanoiBench.$(O) HanoiDisk.$(O) \
+ Benchmarks.$(O) Slopstones.$(O) Smopstones.$(O)
+
+all:: $(OBJTARGET)
+
+objs:: level0 \
+ level1 \
+ level2 \
+ level4
+
+#
+# you may want to remove these ...
+#
+auxobjs:: $(AUXOBJS)
+
+level0:$(P) \
+ Scanner.o \
+ Variable.o \
+ ParseNode.o \
+ UndefVar.o \
+ ObjectFile.o \
+ ObjFLoader.o
+
+level1:$(P) \
+ Parser.o \
+ PrimaryNd.o \
+ StatNode.o \
+ AssignNd.o \
+ BlockNode.o \
+ MessageNd.o
+
+level2:$(P) \
+ BCompiler.o \
+ RetNode.o \
+ UnaryNd.o \
+ BinaryNd.o \
+ CascadeNd.o \
+ PrimNd.o \
+ ConstNode.o
+
+# currently not implemented
+
+level3:$(P) \
+ CMethod.o \
+ MCompiler.o
+
+level4:$(P) \
+ HanoiBench.o \
+ HanoiDisk.o \
+ PermBench.o \
+ Benchmarks.o \
+ Slopstones.o \
+ Smopstones.o
+
+install::
+ -mkdir $(DESTLIBDIR)
+ -$(INSTALL) $(LIBNAME)$(OBJNAME) $(DESTLIBDIR)
+
+libe: $(LIB)
+
+objs:: $(INCLUDE)/stc.h $(INCLUDE)/stcIntern.h
+
+cleanjunk::
+ -rm -f *.c *.H
+
+clean::
+ -rm -f *.c *.H
+
+clobber::
+ -rm -f *.c *.H
+
+tar:
+ rm -f $(TOP)/DISTRIB/libcomp.tar*
+ (cd $(TOP); tar cvf DISTRIB/libcomp.tar \
+ libcomp/*.st \
+ libcomp/Make.proto \
+ libcomp/*.stc)
+ compress $(TOP)/DISTRIB/libcomp.tar
+
+#
+# next thing I'll build into stc is a makedepend feature for this ...
+#
+
+STCHDR=$(I)/stc.h $(I)/stcIntern.h
+OBJECT=$(I)/Object.H $(STCHDR)
+SCANNER=$(I)/Scanner.H $(OBJECT)
+PARSER=$(I)/Parser.H $(SCANNER)
+PARSENODE=$(I)/ParseNode.H $(OBJECT)
+PRIMARYNODE=$(I)/PrimaryNd.H $(PARSENODE)
+MESSAGENODE=$(I)/MessageNd.H $(PARSENODE)
+
+Scanner.o: Scanner.st $(OBJECT)
+ObjectFile.o: ObjectFile.st $(OBJECT)
+ObjFLoader.o: ObjFLoader.st $(OBJECT)
+UndefVar.o: UndefVar.st $(OBJECT)
+Parser.o: Parser.st $(SCANNER)
+BCompiler.o: BCompiler.st $(PARSER)
+Variable.o: Variable.st $(OBJECT)
+ParseNode.o: ParseNode.st $(OBJECT)
+StatNode.o: StatNode.st $(PARSENODE)
+AssignNd.o: AssignNd.st $(PARSENODE)
+BlockNode.o: BlockNode.st $(PARSENODE)
+PrimaryNd.o: PrimaryNd.st $(PARSENODE)
+ConstNode.o: ConstNode.st $(PRIMARYNODE)
+MessageNd.o: MessageNd.st $(PARSENODE)
+CascadeNd.o: CascadeNd.st $(MESSAGENODE)
+PrimNd.o: PrimNd.st $(MESSAGENODE)
+BinaryNd.o: BinaryNd.st $(MESSAGENODE)
+UnaryNd.o: UnaryNd.st $(MESSAGENODE)
+RetNode.o: RetNode.st $(MESSAGENODE)
+
+CMethod.o: CMethod.st $(I)/Method.H $(OBJECT)
+MCompiler.o: MCompiler.st $(PARSER)
+
+Benchmarks.o: Benchmarks.st $(OBJECT)
+PermBench.o: PermBench.st $(OBJECT)
+HanoiBench.o: HanoiBench.st $(OBJECT)
+HanoiDisk.o: HanoiDisk.st $(OBJECT)
+Slopstones.o: Slopstones.st $(OBJECT)
+Smopstones.o: Smopstones.st $(OBJECT)
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/MessageNd.st Fri Jul 16 11:38:57 1993 +0200
@@ -0,0 +1,1120 @@
+"
+ COPYRIGHT (c) 1989-93 by Claus Gittinger
+ All Rights Reserved
+
+ This software is furnished under a license and may be used
+ only in accordance with the terms of that license and with the
+ inclusion of the above copyright notice. This software may not
+ be provided or otherwise made available to, or used by, any
+ other person. No title to or ownership of the software is
+ hereby transferred.
+"
+
+ParseNode subclass:#MessageNode
+ instanceVariableNames:'receiver selector argArray lineNr'
+ classVariableNames:''
+ poolDictionaries:''
+ category:'System-Compiler-Support'
+!
+
+MessageNode comment:'
+COPYRIGHT (c) 1989-93 by Claus Gittinger
+ All Rights Reserved
+
+%W% %E%
+'!
+
+!MessageNode class methodsFor:'instance creation'!
+
+receiver:recNode selector:selectorString
+ ^ (self basicNew) receiver:recNode selector:selectorString args:nil lineno:0
+!
+
+receiver:recNode selector:selectorString arg:argNode
+ ^ self receiver:recNode selector:selectorString arg:argNode fold:true
+!
+
+receiver:recNode selector:selectorString arg:argNode fold:folding
+ |result recVal argVal selector|
+
+"
+ The constant folding code can usually not optimize things - this may change
+ when some kind of constant declaration is added to smalltalk.
+"
+ folding ifTrue:[
+ "do constant folding ..."
+ (recNode isConstant and:[argNode isConstant]) ifTrue:[
+ "check if we can do it ..."
+ selectorString knownAsSymbol ifTrue:[
+ (recNode respondsTo:selectorString asSymbol) 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 ...)
+ "
+ selector := selectorString asSymbol.
+ recVal := recNode evaluate.
+ argVal := argNode evaluate.
+ (recVal respondsToArithmetic and:[argVal respondsToArithmetic]) ifTrue:[
+ (#( @ + - * / // \\ min: max:) includes:selector) ifTrue:[
+ (#( / // \\ ) includes:selector) ifTrue:[
+ argVal = 0 ifTrue:[
+ ^ 'division by zero'
+ ].
+ ].
+ result := recVal perform:selector with:argVal.
+ ^ ConstantNode type:(ConstantNode typeOfConstant:result)
+ value:result
+ ]
+ ].
+ (recVal isMemberOf:String) ifTrue:[
+ argVal respondsToArithmetic ifTrue:[
+ (selector == #at:) ifTrue:[
+ result := recVal perform:selector with:argVal.
+ ^ ConstantNode type:(ConstantNode typeOfConstant:result)
+ value:result
+ ]
+ ].
+ (argVal isMemberOf:String) ifTrue:[
+ (selector == #',') ifTrue:[
+ result := recVal perform:selector with:argVal.
+ ^ ConstantNode type:(ConstantNode typeOfConstant:result)
+ value:result
+ ]
+ ]
+ ]
+ ]
+ ]
+ ]
+ ].
+ ^ (self basicNew) receiver:recNode selector:selectorString args:(Array with:argNode) lineno:0
+!
+
+receiver:recNode selector:selectorString args:anArray
+ ^ self receiver:recNode selector:selectorString args:anArray fold:true
+!
+
+receiver:recNode selector:selectorString args:argArray fold:folding
+ (argArray size == 1) ifTrue:[
+ ^ self receiver:recNode selector:selectorString arg:(argArray at:1) fold:folding
+ ].
+ ^ (self basicNew) receiver:recNode selector:selectorString args:argArray lineno:0
+! !
+
+!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:num
+ lineNr := num
+! !
+
+!MessageNode class methodsFor:'queries'!
+
+isMessage
+ ^ true
+!
+
+isBuiltInUnarySelector:sel
+ "return true, if unary selector sel is built in"
+
+ (sel == #peek) ifTrue:[^ true].
+ (sel == #value) ifTrue:[^ true].
+ (sel == #next) ifTrue:[^ true].
+ (sel == #class) ifTrue:[^ true].
+ (sel == #size) ifTrue:[^ true].
+ (sel == #x) ifTrue:[^ true].
+ (sel == #y) ifTrue:[^ true].
+ (sel == #width) ifTrue:[^ true].
+ (sel == #height) ifTrue:[^ true].
+ (sel == #origin) ifTrue:[^ true].
+ (sel == #extent) ifTrue:[^ true].
+ ^ false
+!
+
+isBuiltIn1ArgSelector:sel
+ "return true, if selector sel is built in"
+
+ (sel == #at:) ifTrue:[^ true].
+ (sel == #value:) ifTrue:[^ true].
+ (sel == #bitAnd:) ifTrue:[^ true].
+ (sel == #bitOr:) ifTrue:[^ true].
+ ^ false
+!
+
+isBuiltIn2ArgSelector:sel
+ "return true, if selector sel is built in"
+
+ (sel == #at:put:) ifTrue:[^ true].
+ ^ false
+! !
+
+!MessageNode methodsFor:'printing'!
+
+printOn:aStream indent:i
+ |needParen selectorParts index index2 arg|
+
+ (#(whileTrue: whileFalse:) includes:selector) ifTrue:[
+ (receiver isKindOf:BlockNode) ifTrue:[
+ ^ self printWhileOn:aStream indent:i
+ ].
+ ].
+
+ 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
+ ]
+ ].
+ ].
+ needParen ifTrue:[
+ aStream nextPutAll:'('
+ ].
+ arg printOn:aStream indent:i.
+ needParen ifTrue:[
+ aStream nextPutAll:') '
+ ].
+ ]
+!
+
+printWhileOn:aStream indent:i
+ |needParen selectorParts index index2 arg|
+
+ "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
+ ]
+ ].
+ ].
+ needParen ifTrue:[
+ aStream nextPutAll:'('
+ ].
+ arg printOn:aStream indent:i.
+ needParen ifTrue:[
+ aStream nextPutAll:') '
+ ].
+! !
+
+!MessageNode methodsFor:'checks'!
+
+plausibilityCheck
+ |rec arg operand|
+
+ "it once costed me 1h, to find a '==' which
+ should have been an '=' (well, I saw it 50 times but
+ didn't think about it ...).
+ reason enough to add this check here.
+ "
+ ((selector == #==) or:[selector == #~~]) ifTrue:[
+ receiver isConstant ifTrue:[
+ rec := receiver evaluate.
+ ((rec isMemberOf:String) or:[
+ (rec isMemberOf:Float) or:[
+ (rec isMemberOf:Fraction)]]) ifTrue:[
+ operand := rec
+ ].
+ ].
+ (argArray at:1) isConstant ifTrue:[
+ arg := (argArray at:1) evaluate.
+ ((arg isMemberOf:String) or:[
+ (arg isMemberOf:Float) or:[
+ (arg isMemberOf:Fraction)]]) ifTrue:[
+ operand := arg
+ ].
+ ].
+ operand notNil ifTrue:[
+ (selector == #==) ifTrue:[
+ ^ 'identity compare is unsafe here'
+ ].
+ ^ 'identity compare will usually return true here'
+ ]
+ ].
+ ^ nil
+! !
+
+!MessageNode methodsFor:'evaluating'!
+
+evaluate
+ |r nargs argValueArray index|
+
+ 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 := Array new:nargs.
+ index := 1.
+ [index <= nargs] whileTrue:[
+ argValueArray at:index put:((argArray at:index) evaluate).
+ index := index + 1
+ ].
+ ^ r perform:selector withArguments:argValueArray
+!
+
+evaluateForCascade
+ |r nargs argValueArray index|
+
+ 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 := Array new:nargs.
+ index := 1.
+ [index <= nargs] whileTrue:[
+ argValueArray at:index put:((argArray at:index) evaluate).
+ index := index + 1
+ ].
+ r perform:selector withArguments:argValueArray.
+ ^ r
+! !
+
+!MessageNode methodsFor:'code generation'!
+
+codeForSideEffectOn:aStream inBlock:b
+ self codeOn:aStream inBlock:b valueNeeded:false
+!
+
+codeOn:aStream inBlock:b
+ self codeOn:aStream inBlock:b valueNeeded:true
+!
+
+optimizedConditionFor:aReceiver with:aByteCode
+ |rec sel|
+
+ rec := aReceiver.
+ (rec class == BlockNode) ifTrue:[
+ rec statements nextStatement isNil ifTrue:[
+ rec := rec statements expression
+ ]
+ ].
+ (rec class == UnaryNode) ifTrue:[
+ sel := rec selector.
+ (sel == #isNil) ifTrue:[
+ (aByteCode == #trueJump) ifTrue:[^ #nilJump].
+ (aByteCode == #falseJump) ifTrue:[^ #notNilJump]
+ ].
+ (sel == #notNil) ifTrue:[
+ (aByteCode == #trueJump) ifTrue:[^ #notNilJump].
+ (aByteCode == #falseJump) ifTrue:[^ #nilJump]
+ ].
+ (sel == #not) ifTrue:[
+ (aByteCode == #trueJump) ifTrue:[^ #falseJump].
+ (aByteCode == #falseJump) ifTrue:[^ #trueJump]
+ ].
+ ^ nil
+ ].
+ (rec class == BinaryNode) ifTrue:[
+ sel := rec selector.
+ rec arg1 isConstant ifTrue:[
+ (rec arg1 value == 0) ifTrue:[
+ (sel == #==) ifTrue:[
+ (aByteCode == #trueJump) ifTrue:[^ #zeroJump].
+ (aByteCode == #falseJump) ifTrue:[^ #notZeroJump]
+ ].
+ (sel == #~~) ifTrue:[
+ (aByteCode == #falseJump) ifTrue:[^ #zeroJump].
+ (aByteCode == #trueJump) ifTrue:[^ #notZeroJump]
+ ].
+ ^ nil
+ ]
+ ].
+ (sel == #==) ifTrue:[
+ (aByteCode == #trueJump) ifTrue:[^ #eqJump].
+ (aByteCode == #falseJump) ifTrue:[^ #notEqJump]
+ ].
+ (sel == #~~) ifTrue:[
+ (aByteCode == #falseJump) ifTrue:[^ #eqJump].
+ (aByteCode == #trueJump) ifTrue:[^ #notEqJump]
+ ]
+ ].
+ ^ nil
+!
+
+codeWhileOn:aStream inBlock:b valueNeeded:valueNeeded
+ "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
+ ].
+
+ valueNeeded ifTrue:[aStream nextPut:#pushNil].
+ pos := aStream position.
+ optByteCode notNil ifTrue:[
+ theReceiver codeOn:aStream inBlock:b.
+ theArg notNil ifTrue:[
+ theArg codeOn:aStream inBlock:b
+ ]
+ ] ifFalse:[
+ theReceiver codeInlineOn:aStream inBlock:b
+ ].
+ aStream nextPut:theByteCode.
+ pos2 := aStream position.
+ aStream nextPut:0.
+ valueNeeded ifTrue:[aStream nextPut:#drop].
+ (argArray at:1) codeInlineOn:aStream inBlock:b valueNeeded:valueNeeded.
+ aStream nextPut:#jump.
+ aStream nextPut:pos.
+ (aStream contents) at:pos2 put:(aStream position)
+!
+
+codeTimesRepeatOn:aStream inBlock:b valueNeeded:valueNeeded
+ "generate code for n timesRepeat:[ ... ]"
+
+ |pos pos2 theReceiver theArg theByteCode optByteCode|
+
+ theReceiver := receiver.
+ theReceiver codeOn:aStream inBlock:b.
+ valueNeeded ifTrue:[aStream nextPut:#dup].
+
+ pos := aStream position.
+ aStream nextPut:#dup.
+ aStream nextPut:#push0.
+ aStream nextPut:#>.
+ aStream nextPut:#falseJump.
+ pos2 := aStream position.
+ aStream nextPut:0.
+
+ (argArray at:1) codeInlineOn:aStream inBlock:b valueNeeded:false.
+ aStream nextPut:#minus1.
+ aStream nextPut:#jump.
+ aStream nextPut:pos.
+
+ (aStream contents) at:pos2 put:(aStream position)
+!
+
+codeIfElseOn:aStream inBlock:b valueNeeded:valueNeeded
+ "generate code for x ifxxx:[ ... ] yyy:[ ...]"
+
+ |pos pos2 theReceiver theArg theByteCode optByteCode|
+
+ theReceiver := receiver.
+ (selector == #ifTrue:ifFalse:) ifTrue:[
+ theByteCode := #falseJump
+ ] ifFalse:[
+ (selector == #ifFalse:ifTrue:) ifTrue:[
+ theByteCode := #trueJump
+ ]
+ ].
+ optByteCode := self optimizedConditionFor:theReceiver
+ with:theByteCode.
+ optByteCode notNil ifTrue:[
+ ((optByteCode == #eqJump) or:[optByteCode == #notEqJump]) ifTrue:[
+ theArg := theReceiver arg1
+ ].
+ theReceiver := theReceiver receiver.
+ theByteCode := optByteCode
+ ].
+ theByteCode notNil ifTrue:[
+ theReceiver codeOn:aStream inBlock:b.
+ theArg notNil ifTrue:[
+ theArg codeOn:aStream inBlock:b
+ ].
+ aStream nextPut:theByteCode.
+ pos := aStream position.
+ aStream nextPut:0.
+ (argArray at:1) codeInlineOn:aStream inBlock:b valueNeeded:valueNeeded.
+ aStream nextPut:#jump.
+ pos2 := aStream position.
+ aStream nextPut:0.
+ (aStream contents) at:pos put:(aStream position).
+ (argArray at:2) codeInlineOn:aStream inBlock:b valueNeeded:valueNeeded.
+ (aStream contents) at:pos2 put:(aStream position)
+ ]
+!
+
+codeIfOn:aStream inBlock:b valueNeeded:valueNeeded
+ "generate code for x ifxxx:[ ... ]"
+
+ |pos pos2 theReceiver theArg theByteCode optByteCode subsel|
+
+ theReceiver := receiver.
+
+ (theReceiver class == MessageNode) ifTrue:[
+ subsel := theReceiver selector.
+ (subsel == #and:) ifTrue:[
+ self codeAndIfOn:aStream inBlock:b valueNeeded:valueNeeded.
+ ^ self
+ ].
+ (subsel == #or:) ifTrue:[
+ self codeOrIfOn:aStream inBlock:b valueNeeded:valueNeeded.
+ ^ self
+ ]
+ ].
+ (selector == #ifTrue:) ifTrue:[
+ theByteCode := #falseJump
+ ] ifFalse:[
+ theByteCode := #trueJump
+ ].
+ 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.
+ theArg notNil ifTrue:[
+ theArg codeOn:aStream inBlock:b
+ ].
+ aStream nextPut:theByteCode.
+ pos := aStream position.
+ aStream nextPut:0.
+ (argArray at: 1) codeInlineOn:aStream inBlock:b valueNeeded:valueNeeded.
+ valueNeeded ifTrue:[
+ aStream nextPut:#jump.
+ pos2 := aStream position.
+ aStream nextPut:0.
+ (aStream contents) at:pos put:(aStream position).
+ aStream nextPut:#pushNil.
+ (aStream contents) at:pos2 put:(aStream position)
+ ] ifFalse:[
+ (aStream contents) at:pos put:(aStream position)
+ ]
+!
+
+codeAndIfOn:aStream inBlock:b valueNeeded:valueNeeded
+ "generate code for (x and:[y]) ifxxx:[ ... ]"
+
+ |theByteCode optByteCode theReceiver theArg pos1 pos2 pos3|
+
+
+ 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.
+ theArg notNil ifTrue:[
+ theArg codeOn:aStream inBlock:b
+ ].
+ aStream nextPut:theByteCode.
+ pos1 := aStream position.
+ aStream nextPut:0.
+
+ theReceiver := receiver arg1.
+ theReceiver codeInlineOn:aStream inBlock:b.
+ (selector == #ifTrue:) ifTrue:[
+ aStream nextPut:#falseJump
+ ] ifFalse:[
+ aStream nextPut:#trueJump
+ ].
+ pos2 := aStream position.
+ aStream nextPut:0.
+ (selector == #ifFalse:) ifTrue:[
+ (aStream contents) at:pos1 put:(aStream position)
+ ].
+ (argArray at: 1) codeInlineOn:aStream inBlock:b valueNeeded:valueNeeded.
+ valueNeeded ifTrue:[
+ aStream nextPut:#jump.
+ pos3 := aStream position.
+ aStream nextPut:0.
+ (selector == #ifTrue:) ifTrue:[
+ (aStream contents) at:pos1 put:(aStream position)
+ ].
+ (aStream contents) at:pos2 put:(aStream position).
+ aStream nextPut:#pushNil.
+ (aStream contents) at:pos3 put:(aStream position)
+ ] ifFalse:[
+ (selector == #ifTrue:) ifTrue:[
+ (aStream contents) at:pos1 put:(aStream position)
+ ].
+ (aStream contents) at:pos2 put:(aStream position)
+ ]
+!
+
+codeOrIfOn:aStream inBlock:b valueNeeded:valueNeeded
+ "generate code for (x or:[y]) ifxxx:[ ... ]"
+
+ |theByteCode optByteCode theReceiver theArg pos1 pos2 pos3|
+
+
+ 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.
+ theArg notNil ifTrue:[
+ theArg codeOn:aStream inBlock:b
+ ].
+ aStream nextPut:theByteCode.
+ pos1 := aStream position.
+ aStream nextPut:0.
+
+ theReceiver := receiver arg1.
+ theReceiver codeInlineOn:aStream inBlock:b.
+ (selector == #ifTrue:) ifTrue:[
+ aStream nextPut:#falseJump
+ ] ifFalse:[
+ aStream nextPut:#trueJump
+ ].
+ 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.
+ valueNeeded ifTrue:[
+ aStream nextPut:#jump.
+ pos3 := aStream position.
+ aStream nextPut:0.
+ (selector == #ifFalse:) ifTrue:[
+ (aStream contents) at:pos1 put:(aStream position)
+ ].
+ (aStream contents) at:pos2 put:(aStream position).
+ aStream nextPut:#pushNil.
+ (aStream contents) at:pos3 put:(aStream position)
+ ] ifFalse:[
+ (selector == #ifFalse:) ifTrue:[
+ (aStream contents) at:pos1 put:(aStream position)
+ ].
+ (aStream contents) at:pos2 put:(aStream position)
+ ]
+!
+
+codeAndOrOn:aStream inBlock:b valueNeeded:valueNeeded
+ "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.
+ aStream nextPut:theByteCode.
+ pos := aStream position.
+ aStream nextPut:0.
+ (argArray at: 1) codeInlineOn:aStream inBlock:b.
+ (aStream contents) at:pos put:(aStream position).
+ valueNeeded ifFalse:[aStream nextPut:#drop]
+!
+
+codeOn:aStream inBlock:b valueNeeded:valueNeeded
+ |nargs isBuiltIn|
+
+ argArray isNil ifTrue:[
+ nargs := 0
+ ] ifFalse:[
+ nargs := argArray size
+ ].
+
+ isBuiltIn := false.
+
+ (nargs == 0) ifTrue:[
+ isBuiltIn := self class isBuiltInUnarySelector:selector
+ ].
+
+ (nargs == 1) ifTrue:[
+ ((argArray at:1) class == BlockNode) ifTrue:[
+ ((selector == #ifTrue:) or:[selector == #ifFalse:]) ifTrue:[
+ self codeIfOn:aStream inBlock:b valueNeeded:valueNeeded.
+ ^ self
+ ].
+"
+ ((selector == #and:) or:[selector == #or:]) ifTrue:[
+ self codeAndOrOn:aStream inBlock:b valueNeeded:valueNeeded.
+ ^ self
+ ].
+"
+ receiver isConstant ifTrue:[
+ (receiver evaluate isKindOf:Number) ifTrue:[
+ self codeTimesRepeatOn:aStream inBlock:b valueNeeded:valueNeeded.
+ ^ self
+ ]
+ ].
+
+ (receiver class == BlockNode) ifTrue:[
+ ((selector == #whileTrue:)
+ or:[selector == #whileFalse:]) ifTrue:[
+ self codeWhileOn:aStream inBlock:b
+ valueNeeded:valueNeeded.
+ ^ self
+ ]
+ ]
+ ].
+ isBuiltIn := self class isBuiltIn1ArgSelector:selector
+ ].
+
+ (nargs == 2) ifTrue:[
+ ((argArray at:1) class == BlockNode) ifTrue:[
+ ((argArray at:2) class == BlockNode) ifTrue:[
+ ((selector == #ifTrue:ifFalse:)
+ or:[selector == #ifFalse:ifTrue:]) ifTrue:[
+ self codeIfElseOn:aStream inBlock:b
+ valueNeeded:valueNeeded.
+ ^ self
+ ]
+ ]
+ ].
+ isBuiltIn := self class isBuiltIn2ArgSelector:selector
+ ].
+
+ "can we use a send-bytecode ?"
+ isBuiltIn ifTrue:[
+ (receiver type == #Super) ifFalse:[
+ receiver codeOn:aStream inBlock:b.
+ (nargs > 0) ifTrue:[
+ (argArray at:1) codeOn:aStream inBlock:b.
+ (nargs > 1) ifTrue:[
+ (argArray at:2) codeOn:aStream inBlock:b
+ ]
+ ].
+ aStream nextPut:selector.
+ valueNeeded ifFalse:[
+ aStream nextPut:#drop
+ ].
+ ^ self
+ ]
+ ].
+
+ ((nargs == 0) and:[selector == #yourself]) ifTrue:[
+ "yourself is often added to get the receiver -
+ we get it without the yourself-message"
+
+ valueNeeded ifTrue:[
+ receiver codeOn:aStream inBlock:b
+ ].
+ ^ self
+ ].
+
+ "no - generate a send"
+ ((receiver type ~~ #Self)
+ or:[nargs > 3]) ifTrue:[
+ receiver codeOn:aStream inBlock:b
+ ].
+ argArray notNil ifTrue:[
+ argArray do:[:arg |
+ arg codeOn:aStream inBlock:b
+ ]
+ ].
+ (receiver type == #Super) ifTrue:[
+ aStream nextPut:#superSend.
+ aStream nextPut:lineNr.
+ aStream nextPut:selector.
+ aStream nextPut:nargs.
+ aStream nextPut:nil.
+ valueNeeded ifFalse:[
+ aStream nextPut:#drop
+ ].
+ ^ self
+ ].
+ (nargs == 0) ifTrue:[
+ valueNeeded ifTrue:[
+ (receiver type == #Self) ifTrue:[
+ aStream nextPut:#sendSelf0
+ ] ifFalse:[
+ aStream nextPut:#send0
+ ]
+ ] ifFalse:[
+ (receiver type == #Self) ifTrue:[
+ aStream nextPut:#sendSelfDrop0
+ ] ifFalse:[
+ aStream nextPut:#sendDrop0
+ ]
+ ].
+ aStream nextPut:lineNr.
+ aStream nextPut:selector.
+ ^ self
+ ].
+ (nargs == 1) ifTrue:[
+ valueNeeded ifTrue:[
+ (receiver type == #Self) ifTrue:[
+ aStream nextPut:#sendSelf1
+ ] ifFalse:[
+ aStream nextPut:#send1
+ ]
+ ] ifFalse:[
+ (receiver type == #Self) ifTrue:[
+ aStream nextPut:#sendSelfDrop1
+ ] ifFalse:[
+ aStream nextPut:#sendDrop1
+ ]
+ ].
+ aStream nextPut:lineNr.
+ aStream nextPut:selector.
+ ^ self
+ ].
+ (nargs == 2) ifTrue:[
+ valueNeeded ifTrue:[
+ (receiver type == #Self) ifTrue:[
+ aStream nextPut:#sendSelf2
+ ] ifFalse:[
+ aStream nextPut:#send2
+ ]
+ ] ifFalse:[
+ (receiver type == #Self) ifTrue:[
+ aStream nextPut:#sendSelfDrop2
+ ] ifFalse:[
+ aStream nextPut:#sendDrop2
+ ]
+ ].
+ aStream nextPut:lineNr.
+ aStream nextPut:selector.
+ ^ self
+ ].
+ (nargs == 3) ifTrue:[
+ valueNeeded ifTrue:[
+ (receiver type == #Self) ifTrue:[
+ aStream nextPut:#sendSelf3
+ ] ifFalse:[
+ aStream nextPut:#send3
+ ]
+ ] ifFalse:[
+ (receiver type == #Self) ifTrue:[
+ aStream nextPut:#sendSelfDrop3
+ ] ifFalse:[
+ aStream nextPut:#sendDrop3
+ ]
+ ].
+ aStream nextPut:lineNr.
+ aStream nextPut:selector.
+ ^ self
+ ].
+ valueNeeded ifTrue:[
+ aStream nextPut:#send
+ ] ifFalse:[
+ aStream nextPut:#sendDrop
+ ].
+ aStream nextPut:lineNr.
+ aStream nextPut:selector.
+ aStream nextPut:nargs
+!
+
+codeSendOn:aStream inBlock:b valueNeeded:valueNeeded
+ "like code on, but assumes that receiver has already been
+ coded onto stack - needed for cascade"
+
+ |nargs isBuiltIn|
+
+ argArray isNil ifTrue:[
+ nargs := 0
+ ] ifFalse:[
+ nargs := argArray size
+ ].
+
+ isBuiltIn := false.
+
+ (nargs == 0) ifTrue:[
+ isBuiltIn := self class isBuiltInUnarySelector:selector
+ ].
+ (nargs == 1) ifTrue:[
+ isBuiltIn := self class isBuiltIn1ArgSelector:selector
+ ].
+ (nargs == 2) ifTrue:[
+ isBuiltIn := self class isBuiltIn2ArgSelector:selector
+ ].
+
+ "can we use a send-bytecode ?"
+ isBuiltIn ifTrue:[
+ (receiver type == #Super) ifFalse:[
+ (nargs > 0) ifTrue:[
+ (argArray at:1) codeOn:aStream inBlock:b.
+ (nargs > 1) ifTrue:[
+ (argArray at:2) codeOn:aStream inBlock:b
+ ]
+ ].
+ aStream nextPut:selector.
+ valueNeeded ifFalse:[
+ aStream nextPut:#drop
+ ].
+ ^ self
+ ]
+ ].
+
+ argArray notNil ifTrue:[
+ argArray do:[:arg |
+ arg codeOn:aStream inBlock:b
+ ]
+ ].
+
+ (receiver type == #Super) ifTrue:[
+ aStream nextPut:#superSend.
+ aStream nextPut:lineNr.
+ aStream nextPut:selector.
+ aStream nextPut:nargs.
+ aStream nextPut:nil.
+ valueNeeded ifFalse:[
+ aStream nextPut:#drop
+ ].
+ ^ self
+ ].
+ (nargs == 0) ifTrue:[
+ (selector == #yourself) ifTrue:[
+ "yourself is often added to get the receiver -
+ we get it without the yourself-message"
+
+ valueNeeded ifFalse:[
+ aStream nextPut:#drop
+ ].
+ ^ self
+ ].
+
+ valueNeeded ifTrue:[
+ aStream nextPut:#send0
+ ] ifFalse:[
+ aStream nextPut:#sendDrop0
+ ].
+ aStream nextPut:lineNr.
+ aStream nextPut:selector.
+ ^ self
+ ].
+ (nargs == 1) ifTrue:[
+ valueNeeded ifTrue:[
+ aStream nextPut:#send1
+ ] ifFalse:[
+ aStream nextPut:#sendDrop1
+ ].
+ aStream nextPut:lineNr.
+ aStream nextPut:selector.
+ ^ self
+ ].
+ (nargs == 2) ifTrue:[
+ valueNeeded ifTrue:[
+ aStream nextPut:#send2
+ ] ifFalse:[
+ aStream nextPut:#sendDrop2
+ ].
+ aStream nextPut:lineNr.
+ aStream nextPut:selector.
+ ^ self
+ ].
+ (nargs == 3) ifTrue:[
+ valueNeeded ifTrue:[
+ aStream nextPut:#send3
+ ] ifFalse:[
+ aStream nextPut:#sendDrop3
+ ].
+ aStream nextPut:lineNr.
+ aStream nextPut:selector.
+ ^ self
+ ].
+ valueNeeded ifTrue:[
+ aStream nextPut:#send
+ ] ifFalse:[
+ aStream nextPut:#sendDrop
+ ].
+ aStream nextPut:lineNr.
+ aStream nextPut:selector.
+ aStream nextPut:nargs
+!
+
+codeForCascadeOn:aStream inBlock:b
+ "like codeOn, but always leave the receiver instead of the result"
+ |nargs isBuiltIn|
+
+ argArray isNil ifTrue:[
+ nargs := 0
+ ] ifFalse:[
+ nargs := argArray size
+ ].
+
+ isBuiltIn := false.
+
+ (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.
+ aStream nextPut:#dup.
+
+ "can we use a send-bytecode ?"
+ isBuiltIn ifTrue:[
+ (receiver type == #Super) ifFalse:[
+ (nargs > 0) ifTrue:[
+ (argArray at:1) codeOn:aStream inBlock:b.
+ (nargs > 1) ifTrue:[
+ (argArray at:2) codeOn:aStream inBlock:b
+ ]
+ ].
+ aStream nextPut:selector.
+ aStream nextPut:#drop.
+ ^ self
+ ]
+ ].
+
+ "no - generate a send"
+ argArray notNil ifTrue:[
+ argArray do:[:arg |
+ arg codeOn:aStream inBlock:b
+ ]
+ ].
+ (receiver type == #Super) ifTrue:[
+ aStream nextPut:#superSend.
+ aStream nextPut:lineNr.
+ aStream nextPut:selector.
+ aStream nextPut:nargs.
+ aStream nextPut:nil.
+ aStream nextPut:#drop.
+ ^ self
+ ].
+ (nargs == 0) ifTrue:[
+ aStream nextPut:#sendDrop0.
+ aStream nextPut:lineNr.
+ aStream nextPut:selector.
+ ^ self
+ ].
+ (nargs == 1) ifTrue:[
+ aStream nextPut:#sendDrop1.
+ aStream nextPut:lineNr.
+ aStream nextPut:selector.
+ ^ self
+ ].
+ (nargs == 2) ifTrue:[
+ aStream nextPut:#sendDrop2.
+ aStream nextPut:lineNr.
+ aStream nextPut:selector.
+ ^ self
+ ].
+ (nargs == 3) ifTrue:[
+ aStream nextPut:#sendDrop3.
+ aStream nextPut:lineNr.
+ aStream nextPut:selector.
+ ^ self
+ ].
+ aStream nextPut:#sendDrop.
+ aStream nextPut:lineNr.
+ aStream nextPut:selector.
+ aStream nextPut:nargs
+! !
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/MessageNode.st Fri Jul 16 11:38:57 1993 +0200
@@ -0,0 +1,1120 @@
+"
+ COPYRIGHT (c) 1989-93 by Claus Gittinger
+ All Rights Reserved
+
+ This software is furnished under a license and may be used
+ only in accordance with the terms of that license and with the
+ inclusion of the above copyright notice. This software may not
+ be provided or otherwise made available to, or used by, any
+ other person. No title to or ownership of the software is
+ hereby transferred.
+"
+
+ParseNode subclass:#MessageNode
+ instanceVariableNames:'receiver selector argArray lineNr'
+ classVariableNames:''
+ poolDictionaries:''
+ category:'System-Compiler-Support'
+!
+
+MessageNode comment:'
+COPYRIGHT (c) 1989-93 by Claus Gittinger
+ All Rights Reserved
+
+%W% %E%
+'!
+
+!MessageNode class methodsFor:'instance creation'!
+
+receiver:recNode selector:selectorString
+ ^ (self basicNew) receiver:recNode selector:selectorString args:nil lineno:0
+!
+
+receiver:recNode selector:selectorString arg:argNode
+ ^ self receiver:recNode selector:selectorString arg:argNode fold:true
+!
+
+receiver:recNode selector:selectorString arg:argNode fold:folding
+ |result recVal argVal selector|
+
+"
+ The constant folding code can usually not optimize things - this may change
+ when some kind of constant declaration is added to smalltalk.
+"
+ folding ifTrue:[
+ "do constant folding ..."
+ (recNode isConstant and:[argNode isConstant]) ifTrue:[
+ "check if we can do it ..."
+ selectorString knownAsSymbol ifTrue:[
+ (recNode respondsTo:selectorString asSymbol) 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 ...)
+ "
+ selector := selectorString asSymbol.
+ recVal := recNode evaluate.
+ argVal := argNode evaluate.
+ (recVal respondsToArithmetic and:[argVal respondsToArithmetic]) ifTrue:[
+ (#( @ + - * / // \\ min: max:) includes:selector) ifTrue:[
+ (#( / // \\ ) includes:selector) ifTrue:[
+ argVal = 0 ifTrue:[
+ ^ 'division by zero'
+ ].
+ ].
+ result := recVal perform:selector with:argVal.
+ ^ ConstantNode type:(ConstantNode typeOfConstant:result)
+ value:result
+ ]
+ ].
+ (recVal isMemberOf:String) ifTrue:[
+ argVal respondsToArithmetic ifTrue:[
+ (selector == #at:) ifTrue:[
+ result := recVal perform:selector with:argVal.
+ ^ ConstantNode type:(ConstantNode typeOfConstant:result)
+ value:result
+ ]
+ ].
+ (argVal isMemberOf:String) ifTrue:[
+ (selector == #',') ifTrue:[
+ result := recVal perform:selector with:argVal.
+ ^ ConstantNode type:(ConstantNode typeOfConstant:result)
+ value:result
+ ]
+ ]
+ ]
+ ]
+ ]
+ ]
+ ].
+ ^ (self basicNew) receiver:recNode selector:selectorString args:(Array with:argNode) lineno:0
+!
+
+receiver:recNode selector:selectorString args:anArray
+ ^ self receiver:recNode selector:selectorString args:anArray fold:true
+!
+
+receiver:recNode selector:selectorString args:argArray fold:folding
+ (argArray size == 1) ifTrue:[
+ ^ self receiver:recNode selector:selectorString arg:(argArray at:1) fold:folding
+ ].
+ ^ (self basicNew) receiver:recNode selector:selectorString args:argArray lineno:0
+! !
+
+!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:num
+ lineNr := num
+! !
+
+!MessageNode class methodsFor:'queries'!
+
+isMessage
+ ^ true
+!
+
+isBuiltInUnarySelector:sel
+ "return true, if unary selector sel is built in"
+
+ (sel == #peek) ifTrue:[^ true].
+ (sel == #value) ifTrue:[^ true].
+ (sel == #next) ifTrue:[^ true].
+ (sel == #class) ifTrue:[^ true].
+ (sel == #size) ifTrue:[^ true].
+ (sel == #x) ifTrue:[^ true].
+ (sel == #y) ifTrue:[^ true].
+ (sel == #width) ifTrue:[^ true].
+ (sel == #height) ifTrue:[^ true].
+ (sel == #origin) ifTrue:[^ true].
+ (sel == #extent) ifTrue:[^ true].
+ ^ false
+!
+
+isBuiltIn1ArgSelector:sel
+ "return true, if selector sel is built in"
+
+ (sel == #at:) ifTrue:[^ true].
+ (sel == #value:) ifTrue:[^ true].
+ (sel == #bitAnd:) ifTrue:[^ true].
+ (sel == #bitOr:) ifTrue:[^ true].
+ ^ false
+!
+
+isBuiltIn2ArgSelector:sel
+ "return true, if selector sel is built in"
+
+ (sel == #at:put:) ifTrue:[^ true].
+ ^ false
+! !
+
+!MessageNode methodsFor:'printing'!
+
+printOn:aStream indent:i
+ |needParen selectorParts index index2 arg|
+
+ (#(whileTrue: whileFalse:) includes:selector) ifTrue:[
+ (receiver isKindOf:BlockNode) ifTrue:[
+ ^ self printWhileOn:aStream indent:i
+ ].
+ ].
+
+ 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
+ ]
+ ].
+ ].
+ needParen ifTrue:[
+ aStream nextPutAll:'('
+ ].
+ arg printOn:aStream indent:i.
+ needParen ifTrue:[
+ aStream nextPutAll:') '
+ ].
+ ]
+!
+
+printWhileOn:aStream indent:i
+ |needParen selectorParts index index2 arg|
+
+ "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
+ ]
+ ].
+ ].
+ needParen ifTrue:[
+ aStream nextPutAll:'('
+ ].
+ arg printOn:aStream indent:i.
+ needParen ifTrue:[
+ aStream nextPutAll:') '
+ ].
+! !
+
+!MessageNode methodsFor:'checks'!
+
+plausibilityCheck
+ |rec arg operand|
+
+ "it once costed me 1h, to find a '==' which
+ should have been an '=' (well, I saw it 50 times but
+ didn't think about it ...).
+ reason enough to add this check here.
+ "
+ ((selector == #==) or:[selector == #~~]) ifTrue:[
+ receiver isConstant ifTrue:[
+ rec := receiver evaluate.
+ ((rec isMemberOf:String) or:[
+ (rec isMemberOf:Float) or:[
+ (rec isMemberOf:Fraction)]]) ifTrue:[
+ operand := rec
+ ].
+ ].
+ (argArray at:1) isConstant ifTrue:[
+ arg := (argArray at:1) evaluate.
+ ((arg isMemberOf:String) or:[
+ (arg isMemberOf:Float) or:[
+ (arg isMemberOf:Fraction)]]) ifTrue:[
+ operand := arg
+ ].
+ ].
+ operand notNil ifTrue:[
+ (selector == #==) ifTrue:[
+ ^ 'identity compare is unsafe here'
+ ].
+ ^ 'identity compare will usually return true here'
+ ]
+ ].
+ ^ nil
+! !
+
+!MessageNode methodsFor:'evaluating'!
+
+evaluate
+ |r nargs argValueArray index|
+
+ 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 := Array new:nargs.
+ index := 1.
+ [index <= nargs] whileTrue:[
+ argValueArray at:index put:((argArray at:index) evaluate).
+ index := index + 1
+ ].
+ ^ r perform:selector withArguments:argValueArray
+!
+
+evaluateForCascade
+ |r nargs argValueArray index|
+
+ 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 := Array new:nargs.
+ index := 1.
+ [index <= nargs] whileTrue:[
+ argValueArray at:index put:((argArray at:index) evaluate).
+ index := index + 1
+ ].
+ r perform:selector withArguments:argValueArray.
+ ^ r
+! !
+
+!MessageNode methodsFor:'code generation'!
+
+codeForSideEffectOn:aStream inBlock:b
+ self codeOn:aStream inBlock:b valueNeeded:false
+!
+
+codeOn:aStream inBlock:b
+ self codeOn:aStream inBlock:b valueNeeded:true
+!
+
+optimizedConditionFor:aReceiver with:aByteCode
+ |rec sel|
+
+ rec := aReceiver.
+ (rec class == BlockNode) ifTrue:[
+ rec statements nextStatement isNil ifTrue:[
+ rec := rec statements expression
+ ]
+ ].
+ (rec class == UnaryNode) ifTrue:[
+ sel := rec selector.
+ (sel == #isNil) ifTrue:[
+ (aByteCode == #trueJump) ifTrue:[^ #nilJump].
+ (aByteCode == #falseJump) ifTrue:[^ #notNilJump]
+ ].
+ (sel == #notNil) ifTrue:[
+ (aByteCode == #trueJump) ifTrue:[^ #notNilJump].
+ (aByteCode == #falseJump) ifTrue:[^ #nilJump]
+ ].
+ (sel == #not) ifTrue:[
+ (aByteCode == #trueJump) ifTrue:[^ #falseJump].
+ (aByteCode == #falseJump) ifTrue:[^ #trueJump]
+ ].
+ ^ nil
+ ].
+ (rec class == BinaryNode) ifTrue:[
+ sel := rec selector.
+ rec arg1 isConstant ifTrue:[
+ (rec arg1 value == 0) ifTrue:[
+ (sel == #==) ifTrue:[
+ (aByteCode == #trueJump) ifTrue:[^ #zeroJump].
+ (aByteCode == #falseJump) ifTrue:[^ #notZeroJump]
+ ].
+ (sel == #~~) ifTrue:[
+ (aByteCode == #falseJump) ifTrue:[^ #zeroJump].
+ (aByteCode == #trueJump) ifTrue:[^ #notZeroJump]
+ ].
+ ^ nil
+ ]
+ ].
+ (sel == #==) ifTrue:[
+ (aByteCode == #trueJump) ifTrue:[^ #eqJump].
+ (aByteCode == #falseJump) ifTrue:[^ #notEqJump]
+ ].
+ (sel == #~~) ifTrue:[
+ (aByteCode == #falseJump) ifTrue:[^ #eqJump].
+ (aByteCode == #trueJump) ifTrue:[^ #notEqJump]
+ ]
+ ].
+ ^ nil
+!
+
+codeWhileOn:aStream inBlock:b valueNeeded:valueNeeded
+ "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
+ ].
+
+ valueNeeded ifTrue:[aStream nextPut:#pushNil].
+ pos := aStream position.
+ optByteCode notNil ifTrue:[
+ theReceiver codeOn:aStream inBlock:b.
+ theArg notNil ifTrue:[
+ theArg codeOn:aStream inBlock:b
+ ]
+ ] ifFalse:[
+ theReceiver codeInlineOn:aStream inBlock:b
+ ].
+ aStream nextPut:theByteCode.
+ pos2 := aStream position.
+ aStream nextPut:0.
+ valueNeeded ifTrue:[aStream nextPut:#drop].
+ (argArray at:1) codeInlineOn:aStream inBlock:b valueNeeded:valueNeeded.
+ aStream nextPut:#jump.
+ aStream nextPut:pos.
+ (aStream contents) at:pos2 put:(aStream position)
+!
+
+codeTimesRepeatOn:aStream inBlock:b valueNeeded:valueNeeded
+ "generate code for n timesRepeat:[ ... ]"
+
+ |pos pos2 theReceiver theArg theByteCode optByteCode|
+
+ theReceiver := receiver.
+ theReceiver codeOn:aStream inBlock:b.
+ valueNeeded ifTrue:[aStream nextPut:#dup].
+
+ pos := aStream position.
+ aStream nextPut:#dup.
+ aStream nextPut:#push0.
+ aStream nextPut:#>.
+ aStream nextPut:#falseJump.
+ pos2 := aStream position.
+ aStream nextPut:0.
+
+ (argArray at:1) codeInlineOn:aStream inBlock:b valueNeeded:false.
+ aStream nextPut:#minus1.
+ aStream nextPut:#jump.
+ aStream nextPut:pos.
+
+ (aStream contents) at:pos2 put:(aStream position)
+!
+
+codeIfElseOn:aStream inBlock:b valueNeeded:valueNeeded
+ "generate code for x ifxxx:[ ... ] yyy:[ ...]"
+
+ |pos pos2 theReceiver theArg theByteCode optByteCode|
+
+ theReceiver := receiver.
+ (selector == #ifTrue:ifFalse:) ifTrue:[
+ theByteCode := #falseJump
+ ] ifFalse:[
+ (selector == #ifFalse:ifTrue:) ifTrue:[
+ theByteCode := #trueJump
+ ]
+ ].
+ optByteCode := self optimizedConditionFor:theReceiver
+ with:theByteCode.
+ optByteCode notNil ifTrue:[
+ ((optByteCode == #eqJump) or:[optByteCode == #notEqJump]) ifTrue:[
+ theArg := theReceiver arg1
+ ].
+ theReceiver := theReceiver receiver.
+ theByteCode := optByteCode
+ ].
+ theByteCode notNil ifTrue:[
+ theReceiver codeOn:aStream inBlock:b.
+ theArg notNil ifTrue:[
+ theArg codeOn:aStream inBlock:b
+ ].
+ aStream nextPut:theByteCode.
+ pos := aStream position.
+ aStream nextPut:0.
+ (argArray at:1) codeInlineOn:aStream inBlock:b valueNeeded:valueNeeded.
+ aStream nextPut:#jump.
+ pos2 := aStream position.
+ aStream nextPut:0.
+ (aStream contents) at:pos put:(aStream position).
+ (argArray at:2) codeInlineOn:aStream inBlock:b valueNeeded:valueNeeded.
+ (aStream contents) at:pos2 put:(aStream position)
+ ]
+!
+
+codeIfOn:aStream inBlock:b valueNeeded:valueNeeded
+ "generate code for x ifxxx:[ ... ]"
+
+ |pos pos2 theReceiver theArg theByteCode optByteCode subsel|
+
+ theReceiver := receiver.
+
+ (theReceiver class == MessageNode) ifTrue:[
+ subsel := theReceiver selector.
+ (subsel == #and:) ifTrue:[
+ self codeAndIfOn:aStream inBlock:b valueNeeded:valueNeeded.
+ ^ self
+ ].
+ (subsel == #or:) ifTrue:[
+ self codeOrIfOn:aStream inBlock:b valueNeeded:valueNeeded.
+ ^ self
+ ]
+ ].
+ (selector == #ifTrue:) ifTrue:[
+ theByteCode := #falseJump
+ ] ifFalse:[
+ theByteCode := #trueJump
+ ].
+ 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.
+ theArg notNil ifTrue:[
+ theArg codeOn:aStream inBlock:b
+ ].
+ aStream nextPut:theByteCode.
+ pos := aStream position.
+ aStream nextPut:0.
+ (argArray at: 1) codeInlineOn:aStream inBlock:b valueNeeded:valueNeeded.
+ valueNeeded ifTrue:[
+ aStream nextPut:#jump.
+ pos2 := aStream position.
+ aStream nextPut:0.
+ (aStream contents) at:pos put:(aStream position).
+ aStream nextPut:#pushNil.
+ (aStream contents) at:pos2 put:(aStream position)
+ ] ifFalse:[
+ (aStream contents) at:pos put:(aStream position)
+ ]
+!
+
+codeAndIfOn:aStream inBlock:b valueNeeded:valueNeeded
+ "generate code for (x and:[y]) ifxxx:[ ... ]"
+
+ |theByteCode optByteCode theReceiver theArg pos1 pos2 pos3|
+
+
+ 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.
+ theArg notNil ifTrue:[
+ theArg codeOn:aStream inBlock:b
+ ].
+ aStream nextPut:theByteCode.
+ pos1 := aStream position.
+ aStream nextPut:0.
+
+ theReceiver := receiver arg1.
+ theReceiver codeInlineOn:aStream inBlock:b.
+ (selector == #ifTrue:) ifTrue:[
+ aStream nextPut:#falseJump
+ ] ifFalse:[
+ aStream nextPut:#trueJump
+ ].
+ pos2 := aStream position.
+ aStream nextPut:0.
+ (selector == #ifFalse:) ifTrue:[
+ (aStream contents) at:pos1 put:(aStream position)
+ ].
+ (argArray at: 1) codeInlineOn:aStream inBlock:b valueNeeded:valueNeeded.
+ valueNeeded ifTrue:[
+ aStream nextPut:#jump.
+ pos3 := aStream position.
+ aStream nextPut:0.
+ (selector == #ifTrue:) ifTrue:[
+ (aStream contents) at:pos1 put:(aStream position)
+ ].
+ (aStream contents) at:pos2 put:(aStream position).
+ aStream nextPut:#pushNil.
+ (aStream contents) at:pos3 put:(aStream position)
+ ] ifFalse:[
+ (selector == #ifTrue:) ifTrue:[
+ (aStream contents) at:pos1 put:(aStream position)
+ ].
+ (aStream contents) at:pos2 put:(aStream position)
+ ]
+!
+
+codeOrIfOn:aStream inBlock:b valueNeeded:valueNeeded
+ "generate code for (x or:[y]) ifxxx:[ ... ]"
+
+ |theByteCode optByteCode theReceiver theArg pos1 pos2 pos3|
+
+
+ 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.
+ theArg notNil ifTrue:[
+ theArg codeOn:aStream inBlock:b
+ ].
+ aStream nextPut:theByteCode.
+ pos1 := aStream position.
+ aStream nextPut:0.
+
+ theReceiver := receiver arg1.
+ theReceiver codeInlineOn:aStream inBlock:b.
+ (selector == #ifTrue:) ifTrue:[
+ aStream nextPut:#falseJump
+ ] ifFalse:[
+ aStream nextPut:#trueJump
+ ].
+ 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.
+ valueNeeded ifTrue:[
+ aStream nextPut:#jump.
+ pos3 := aStream position.
+ aStream nextPut:0.
+ (selector == #ifFalse:) ifTrue:[
+ (aStream contents) at:pos1 put:(aStream position)
+ ].
+ (aStream contents) at:pos2 put:(aStream position).
+ aStream nextPut:#pushNil.
+ (aStream contents) at:pos3 put:(aStream position)
+ ] ifFalse:[
+ (selector == #ifFalse:) ifTrue:[
+ (aStream contents) at:pos1 put:(aStream position)
+ ].
+ (aStream contents) at:pos2 put:(aStream position)
+ ]
+!
+
+codeAndOrOn:aStream inBlock:b valueNeeded:valueNeeded
+ "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.
+ aStream nextPut:theByteCode.
+ pos := aStream position.
+ aStream nextPut:0.
+ (argArray at: 1) codeInlineOn:aStream inBlock:b.
+ (aStream contents) at:pos put:(aStream position).
+ valueNeeded ifFalse:[aStream nextPut:#drop]
+!
+
+codeOn:aStream inBlock:b valueNeeded:valueNeeded
+ |nargs isBuiltIn|
+
+ argArray isNil ifTrue:[
+ nargs := 0
+ ] ifFalse:[
+ nargs := argArray size
+ ].
+
+ isBuiltIn := false.
+
+ (nargs == 0) ifTrue:[
+ isBuiltIn := self class isBuiltInUnarySelector:selector
+ ].
+
+ (nargs == 1) ifTrue:[
+ ((argArray at:1) class == BlockNode) ifTrue:[
+ ((selector == #ifTrue:) or:[selector == #ifFalse:]) ifTrue:[
+ self codeIfOn:aStream inBlock:b valueNeeded:valueNeeded.
+ ^ self
+ ].
+"
+ ((selector == #and:) or:[selector == #or:]) ifTrue:[
+ self codeAndOrOn:aStream inBlock:b valueNeeded:valueNeeded.
+ ^ self
+ ].
+"
+ receiver isConstant ifTrue:[
+ (receiver evaluate isKindOf:Number) ifTrue:[
+ self codeTimesRepeatOn:aStream inBlock:b valueNeeded:valueNeeded.
+ ^ self
+ ]
+ ].
+
+ (receiver class == BlockNode) ifTrue:[
+ ((selector == #whileTrue:)
+ or:[selector == #whileFalse:]) ifTrue:[
+ self codeWhileOn:aStream inBlock:b
+ valueNeeded:valueNeeded.
+ ^ self
+ ]
+ ]
+ ].
+ isBuiltIn := self class isBuiltIn1ArgSelector:selector
+ ].
+
+ (nargs == 2) ifTrue:[
+ ((argArray at:1) class == BlockNode) ifTrue:[
+ ((argArray at:2) class == BlockNode) ifTrue:[
+ ((selector == #ifTrue:ifFalse:)
+ or:[selector == #ifFalse:ifTrue:]) ifTrue:[
+ self codeIfElseOn:aStream inBlock:b
+ valueNeeded:valueNeeded.
+ ^ self
+ ]
+ ]
+ ].
+ isBuiltIn := self class isBuiltIn2ArgSelector:selector
+ ].
+
+ "can we use a send-bytecode ?"
+ isBuiltIn ifTrue:[
+ (receiver type == #Super) ifFalse:[
+ receiver codeOn:aStream inBlock:b.
+ (nargs > 0) ifTrue:[
+ (argArray at:1) codeOn:aStream inBlock:b.
+ (nargs > 1) ifTrue:[
+ (argArray at:2) codeOn:aStream inBlock:b
+ ]
+ ].
+ aStream nextPut:selector.
+ valueNeeded ifFalse:[
+ aStream nextPut:#drop
+ ].
+ ^ self
+ ]
+ ].
+
+ ((nargs == 0) and:[selector == #yourself]) ifTrue:[
+ "yourself is often added to get the receiver -
+ we get it without the yourself-message"
+
+ valueNeeded ifTrue:[
+ receiver codeOn:aStream inBlock:b
+ ].
+ ^ self
+ ].
+
+ "no - generate a send"
+ ((receiver type ~~ #Self)
+ or:[nargs > 3]) ifTrue:[
+ receiver codeOn:aStream inBlock:b
+ ].
+ argArray notNil ifTrue:[
+ argArray do:[:arg |
+ arg codeOn:aStream inBlock:b
+ ]
+ ].
+ (receiver type == #Super) ifTrue:[
+ aStream nextPut:#superSend.
+ aStream nextPut:lineNr.
+ aStream nextPut:selector.
+ aStream nextPut:nargs.
+ aStream nextPut:nil.
+ valueNeeded ifFalse:[
+ aStream nextPut:#drop
+ ].
+ ^ self
+ ].
+ (nargs == 0) ifTrue:[
+ valueNeeded ifTrue:[
+ (receiver type == #Self) ifTrue:[
+ aStream nextPut:#sendSelf0
+ ] ifFalse:[
+ aStream nextPut:#send0
+ ]
+ ] ifFalse:[
+ (receiver type == #Self) ifTrue:[
+ aStream nextPut:#sendSelfDrop0
+ ] ifFalse:[
+ aStream nextPut:#sendDrop0
+ ]
+ ].
+ aStream nextPut:lineNr.
+ aStream nextPut:selector.
+ ^ self
+ ].
+ (nargs == 1) ifTrue:[
+ valueNeeded ifTrue:[
+ (receiver type == #Self) ifTrue:[
+ aStream nextPut:#sendSelf1
+ ] ifFalse:[
+ aStream nextPut:#send1
+ ]
+ ] ifFalse:[
+ (receiver type == #Self) ifTrue:[
+ aStream nextPut:#sendSelfDrop1
+ ] ifFalse:[
+ aStream nextPut:#sendDrop1
+ ]
+ ].
+ aStream nextPut:lineNr.
+ aStream nextPut:selector.
+ ^ self
+ ].
+ (nargs == 2) ifTrue:[
+ valueNeeded ifTrue:[
+ (receiver type == #Self) ifTrue:[
+ aStream nextPut:#sendSelf2
+ ] ifFalse:[
+ aStream nextPut:#send2
+ ]
+ ] ifFalse:[
+ (receiver type == #Self) ifTrue:[
+ aStream nextPut:#sendSelfDrop2
+ ] ifFalse:[
+ aStream nextPut:#sendDrop2
+ ]
+ ].
+ aStream nextPut:lineNr.
+ aStream nextPut:selector.
+ ^ self
+ ].
+ (nargs == 3) ifTrue:[
+ valueNeeded ifTrue:[
+ (receiver type == #Self) ifTrue:[
+ aStream nextPut:#sendSelf3
+ ] ifFalse:[
+ aStream nextPut:#send3
+ ]
+ ] ifFalse:[
+ (receiver type == #Self) ifTrue:[
+ aStream nextPut:#sendSelfDrop3
+ ] ifFalse:[
+ aStream nextPut:#sendDrop3
+ ]
+ ].
+ aStream nextPut:lineNr.
+ aStream nextPut:selector.
+ ^ self
+ ].
+ valueNeeded ifTrue:[
+ aStream nextPut:#send
+ ] ifFalse:[
+ aStream nextPut:#sendDrop
+ ].
+ aStream nextPut:lineNr.
+ aStream nextPut:selector.
+ aStream nextPut:nargs
+!
+
+codeSendOn:aStream inBlock:b valueNeeded:valueNeeded
+ "like code on, but assumes that receiver has already been
+ coded onto stack - needed for cascade"
+
+ |nargs isBuiltIn|
+
+ argArray isNil ifTrue:[
+ nargs := 0
+ ] ifFalse:[
+ nargs := argArray size
+ ].
+
+ isBuiltIn := false.
+
+ (nargs == 0) ifTrue:[
+ isBuiltIn := self class isBuiltInUnarySelector:selector
+ ].
+ (nargs == 1) ifTrue:[
+ isBuiltIn := self class isBuiltIn1ArgSelector:selector
+ ].
+ (nargs == 2) ifTrue:[
+ isBuiltIn := self class isBuiltIn2ArgSelector:selector
+ ].
+
+ "can we use a send-bytecode ?"
+ isBuiltIn ifTrue:[
+ (receiver type == #Super) ifFalse:[
+ (nargs > 0) ifTrue:[
+ (argArray at:1) codeOn:aStream inBlock:b.
+ (nargs > 1) ifTrue:[
+ (argArray at:2) codeOn:aStream inBlock:b
+ ]
+ ].
+ aStream nextPut:selector.
+ valueNeeded ifFalse:[
+ aStream nextPut:#drop
+ ].
+ ^ self
+ ]
+ ].
+
+ argArray notNil ifTrue:[
+ argArray do:[:arg |
+ arg codeOn:aStream inBlock:b
+ ]
+ ].
+
+ (receiver type == #Super) ifTrue:[
+ aStream nextPut:#superSend.
+ aStream nextPut:lineNr.
+ aStream nextPut:selector.
+ aStream nextPut:nargs.
+ aStream nextPut:nil.
+ valueNeeded ifFalse:[
+ aStream nextPut:#drop
+ ].
+ ^ self
+ ].
+ (nargs == 0) ifTrue:[
+ (selector == #yourself) ifTrue:[
+ "yourself is often added to get the receiver -
+ we get it without the yourself-message"
+
+ valueNeeded ifFalse:[
+ aStream nextPut:#drop
+ ].
+ ^ self
+ ].
+
+ valueNeeded ifTrue:[
+ aStream nextPut:#send0
+ ] ifFalse:[
+ aStream nextPut:#sendDrop0
+ ].
+ aStream nextPut:lineNr.
+ aStream nextPut:selector.
+ ^ self
+ ].
+ (nargs == 1) ifTrue:[
+ valueNeeded ifTrue:[
+ aStream nextPut:#send1
+ ] ifFalse:[
+ aStream nextPut:#sendDrop1
+ ].
+ aStream nextPut:lineNr.
+ aStream nextPut:selector.
+ ^ self
+ ].
+ (nargs == 2) ifTrue:[
+ valueNeeded ifTrue:[
+ aStream nextPut:#send2
+ ] ifFalse:[
+ aStream nextPut:#sendDrop2
+ ].
+ aStream nextPut:lineNr.
+ aStream nextPut:selector.
+ ^ self
+ ].
+ (nargs == 3) ifTrue:[
+ valueNeeded ifTrue:[
+ aStream nextPut:#send3
+ ] ifFalse:[
+ aStream nextPut:#sendDrop3
+ ].
+ aStream nextPut:lineNr.
+ aStream nextPut:selector.
+ ^ self
+ ].
+ valueNeeded ifTrue:[
+ aStream nextPut:#send
+ ] ifFalse:[
+ aStream nextPut:#sendDrop
+ ].
+ aStream nextPut:lineNr.
+ aStream nextPut:selector.
+ aStream nextPut:nargs
+!
+
+codeForCascadeOn:aStream inBlock:b
+ "like codeOn, but always leave the receiver instead of the result"
+ |nargs isBuiltIn|
+
+ argArray isNil ifTrue:[
+ nargs := 0
+ ] ifFalse:[
+ nargs := argArray size
+ ].
+
+ isBuiltIn := false.
+
+ (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.
+ aStream nextPut:#dup.
+
+ "can we use a send-bytecode ?"
+ isBuiltIn ifTrue:[
+ (receiver type == #Super) ifFalse:[
+ (nargs > 0) ifTrue:[
+ (argArray at:1) codeOn:aStream inBlock:b.
+ (nargs > 1) ifTrue:[
+ (argArray at:2) codeOn:aStream inBlock:b
+ ]
+ ].
+ aStream nextPut:selector.
+ aStream nextPut:#drop.
+ ^ self
+ ]
+ ].
+
+ "no - generate a send"
+ argArray notNil ifTrue:[
+ argArray do:[:arg |
+ arg codeOn:aStream inBlock:b
+ ]
+ ].
+ (receiver type == #Super) ifTrue:[
+ aStream nextPut:#superSend.
+ aStream nextPut:lineNr.
+ aStream nextPut:selector.
+ aStream nextPut:nargs.
+ aStream nextPut:nil.
+ aStream nextPut:#drop.
+ ^ self
+ ].
+ (nargs == 0) ifTrue:[
+ aStream nextPut:#sendDrop0.
+ aStream nextPut:lineNr.
+ aStream nextPut:selector.
+ ^ self
+ ].
+ (nargs == 1) ifTrue:[
+ aStream nextPut:#sendDrop1.
+ aStream nextPut:lineNr.
+ aStream nextPut:selector.
+ ^ self
+ ].
+ (nargs == 2) ifTrue:[
+ aStream nextPut:#sendDrop2.
+ aStream nextPut:lineNr.
+ aStream nextPut:selector.
+ ^ self
+ ].
+ (nargs == 3) ifTrue:[
+ aStream nextPut:#sendDrop3.
+ aStream nextPut:lineNr.
+ aStream nextPut:selector.
+ ^ self
+ ].
+ aStream nextPut:#sendDrop.
+ aStream nextPut:lineNr.
+ aStream nextPut:selector.
+ aStream nextPut:nargs
+! !
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/ObjFLoader.st Fri Jul 16 11:38:57 1993 +0200
@@ -0,0 +1,897 @@
+"
+ COPYRIGHT (c) 1993 by Claus Gittinger
+ All Rights Reserved
+
+ This software is furnished under a license and may be used
+ only in accordance with the terms of that license and with the
+ inclusion of the above copyright notice. This software may not
+ be provided or otherwise made available to, or used by, any
+ other person. No title to or ownership of the software is
+ hereby transferred.
+"
+
+Object subclass:#ObjectFileLoader
+ instanceVariableNames:''
+ classVariableNames:'mySymbolTable stubNr verbose'
+ poolDictionaries:''
+ category:'System-Compiler'
+!
+
+ObjectFileLoader comment:'
+
+COPYRIGHT (c) 1993 by Claus Gittinger
+ All Rights Reserved
+
+this one knowns how to load in external (c)-modules
+(see fileIn/cExample.c) it is all experimental and
+WILL DEFINITELY change soon ...
+
+(goal is to allow loading of binary classes)
+
+%W% %E%
+'!
+
+%{
+#ifdef NeXT
+# ifndef _RLD_H_
+# define _RLD_H_
+# include <rld.h>
+# endif
+#endif /* NeXT */
+%}
+
+!ObjectFileLoader class methodsFor:'initialization'!
+
+initialize
+ "name of object file, where initial symbol table is found"
+
+ mySymbolTable := 'smalltalk'.
+ stubNr := 1.
+ verbose := false
+!
+
+verbose:aBoolean
+ "turn on/off debug traces"
+
+ verbose := aBoolean
+
+ "ObjectFileLoader verbose:true"
+! !
+
+!ObjectFileLoader class methodsFor:'command defaults'!
+
+needSeparateIDSpaces
+ "return true, if we need separate I and D spaces"
+
+ |os cpu|
+
+ os := OperatingSystem getSystemType.
+ cpu := OperatingSystem getCPUType.
+
+ (os = 'sunos') ifTrue:[
+ (cpu = 'sparc') ifTrue:[ ^ true ]
+ ].
+ self error:'dont know if we need sepId'
+!
+
+absLd:file text:textAddr data:dataAddr
+ "this should return a string to link file.o to absolute address"
+
+ |os cpu|
+
+ os := OperatingSystem getSystemType.
+ cpu := OperatingSystem getCPUType.
+ (os = 'sunos') ifTrue:[
+ (cpu = 'sparc') ifTrue:[
+"
+ ^ ('ld -A ' , mySymbolTable , ' -x -Bstatic -Ttext '
+ , (textAddr printStringRadix:16) , ' -Tdata '
+ , (dataAddr printStringRadix:16) , ' ' , file)
+"
+ ^ ('ld -A ' , mySymbolTable , ' -T ',
+ (textAddr printStringRadix:16),
+ ' -N -x ' , file)
+
+ ]
+ ].
+"
+ (os = 'ultrix') ifTrue:[
+ (cpu = 'mips') ifTrue:[
+ ^ ('ld -A ' , mySymbolTable , ' -x -N -T ' , (textAddr printStringRadix:16) , ' ' , file)
+ ]
+ ].
+"
+ self error:'do not know how to link absolute'
+! !
+
+!ObjectFileLoader class methodsFor:'dynamic loading'!
+
+loadFile:aFileName library:librariesString withBindings:bindings in:aClass
+ "first, load the file itself"
+
+ (self loadFile:aFileName with:librariesString) ifFalse:[^ false].
+
+ "then, create stubs"
+ self bindExternalFunctions:bindings in:aClass
+!
+
+loadFile:aFileName withBindings:bindings in:aClass
+ "load an object file containing external functions, and bind the functions as described
+ in bindings, which is an Array of
+ (selector functionName argTypes returnType)
+ entries, example:
+ #(
+ (sel1:and: 'f1' (SmallInteger SmallInteger) nil) -> bind 'aClass sel1:and:' to: 'void f1(int, int)'
+ (sel2:and: 'f2' (String SmallInteger) String) -> bind 'aClass sel2:and:' to: 'char *f2(char *, int)'
+ )
+ "
+
+ "first, load the file itself"
+
+ (self loadFile:aFileName) ifFalse:[^ false].
+
+ "then, create stubs"
+ self bindExternalFunctions:bindings in:aClass
+!
+
+bindExternalFunctions:bindings in:aClass
+ | selector functionName argTypes returnType allOk |
+
+ allOk := true.
+ bindings do:[:aBinding |
+ selector := aBinding at:1.
+ functionName := aBinding at:2.
+ argTypes := aBinding at:3.
+ returnType := aBinding at:4.
+ (self createStubFor:selector calling:functionName args:argTypes returning:returnType in:aClass)
+ isNil ifTrue:[
+ Transcript showCr:'binding of ' , functionName , ' failed.'.
+ allOk := false
+ ]
+ ].
+ ^ allOk
+! !
+
+!ObjectFileLoader class methodsFor:'creating stubs'!
+
+storeGlobalAddressesOn:aStream
+
+ Smalltalk allKeysDo:[:key |
+ self storeGlobalAddressOf:key on:aStream
+ ]
+
+ "ObjectFileLoader storeGlobalAddressesOn:Transcript"
+ "|f|
+ f := FileStream newFileNamed:'syms.c'.
+ ObjectFileLoader storeGlobalAddressesOn:f.
+ f close"
+!
+
+storeGlobalAddressOf:aSymbol on:aStream
+ |globalName|
+
+ globalName := aSymbol asString.
+ (globalName includes:$:) ifTrue:[
+ globalName replaceAll:$: by:$_
+ ].
+
+ aStream nextPutAll:'#define ',globalName,'_addr '.
+ aStream nextPutAll:(Smalltalk cellAt:aSymbol) printString.
+ aStream cr.
+
+ aStream nextPutAll:'#define ',globalName,' ( *( (OBJ *) ',globalName,'_addr))'.
+ aStream cr
+
+ "ObjectFileLoader storeGlobalAddressOf:#String on:Transcript"
+ "ObjectFileLoader storeGlobalAddressOf:#Symbol on:Transcript"
+!
+
+createStubFor:aSelector calling:functionName args:argTypes returning:returnType in:aClass
+ "create a method calling a stub function"
+
+ |address newMethod|
+
+ address := self createStubCalling:functionName args:argTypes returning:returnType.
+ address isNil ifTrue:[^ nil].
+
+ newMethod := Method new.
+ newMethod code:address.
+ newMethod category:'external functions'.
+ newMethod numberOfMethodVars:0.
+ newMethod stackSize:0.
+
+ aClass class addSelector:aSelector withMethod:newMethod.
+
+ SilentLoading ifFalse:[
+ Transcript showCr:('created stub: ',aClass class name,' ', aSelector)
+ ].
+
+ ^ newMethod
+
+ "ObjectFileLoader createStubFor:#printf: calling:'printf' args:#(String) returning:nil in:TestClass"
+ "ObjectFileLoader createStubFor:#printf:with: calling:'printf'
+ args:#(String SmallInteger) returning:nil in:TestClass"
+!
+
+createStubCalling:functionName args:argTypes returning:returnType
+ "create a stub function for calling functionName - return the address of the
+ function in core or nil on error"
+
+ |baseName p t l handle address stubName|
+
+ stubName := 'stub000' , (stubNr printStringRadix:16).
+ stubName := stubName copyFrom:(stubName size - 7) to:(stubName size).
+
+ baseName := self createStubSource:stubName calling:functionName args:argTypes returning:returnType.
+ baseName isNil ifTrue:[^ nil].
+
+ "compile it ..."
+ verbose ifTrue:[
+ Transcript showCr:'compiling stub ...', baseName. Transcript endEntry
+ ].
+
+ (OperatingSystem executeCommand:('make /tmp/' , baseName , '.o')) ifFalse:[
+ Transcript showCr:'compilation error.'.
+ ^ nil
+ ].
+ OperatingSystem executeCommand:('mv ' , baseName , '.o /tmp/' , baseName , '.o').
+ verbose ifFalse:[
+ OperatingSystem executeCommand:('rm /tmp/' , baseName , '.c').
+ ].
+
+ (OperatingSystem getOSType = 'sys5.4') ifTrue:[
+ "make it a sharable object"
+
+ verbose ifTrue:[
+ Transcript showCr:'makeing shared object stub ...', baseName. Transcript endEntry.
+ ].
+ OperatingSystem executeCommand:('ld -G -o /tmp/',baseName,'.so /tmp/',baseName,'.o').
+
+ "attach to it"
+ handle := self openDynamicObject:('/tmp/',baseName,'.so').
+ handle isNil ifTrue:[
+ Transcript showCr:('dlopen error:', '/tmp/',baseName,'.so').
+ ^ nil
+ ].
+ "find the stubs address"
+ address := self getSymbol:stubName from:handle.
+ address isNil ifTrue:[
+ Transcript showCr:'dlsym failed'.
+ ^ nil
+ ]
+ ].
+
+ (OperatingSystem getOSType = 'sunos') ifTrue:[
+ "load it"
+ (self loadFile:('/tmp/' , baseName , '.o')) ifFalse:[
+ Transcript showCr:'load error.'.
+ ^ nil
+ ].
+
+ "find the stubs address (use nm to get the address)"
+ t := Text new.
+ p := PipeStream readingFrom:('nm SymbolTable|grep ' , stubName , ' |grep T').
+ [p atEnd] whileFalse:[
+ l := p nextLine.
+ l notNil ifTrue:[
+ t add:l
+ ]
+ ].
+ p close.
+ (t size == 1) ifFalse:[
+ Transcript showCr:('oops, ' , stubName , ' not in name-list.').
+ ^ nil
+ ].
+ address := Integer readFrom:(ReadStream on:(t at:1)) radix:16
+ ].
+
+ address isNil ifTrue:[
+ Transcript showCr:'no way to dynamically load objects'.
+ ^ nil
+ ].
+
+ verbose ifTrue:[
+ Transcript show:'stub ' , stubName , ' address:'.
+ Transcript showCr:(address printStringRadix:16).
+ ].
+
+ stubNr := stubNr + 1.
+ ^ address
+
+ "ObjectFileLoader createStubCalling:'printf'
+ args:#(String)
+ returning:nil"
+!
+
+createStubSource:stubName calling:functionName args:argTypes returning:returnType
+ "create a temp file with stub-code - return base-filename or nil"
+
+ |pid baseName index aStream argName|
+
+ pid := OperatingSystem getProcessId printString.
+ baseName := 'stc' , pid.
+ aStream := FileStream newFileNamed:('/tmp/' , baseName , '.c').
+ aStream nextPutAll:'
+#include <stc.h>
+'.
+
+ OperatingSystem getOSType = 'sys5.4' ifTrue:[
+ self storeGlobalAddressesOn:aStream.
+ ].
+
+ aStream nextPutAll:'
+' , stubName , '(self, __sel,
+#ifndef THIS_CONTEXT
+ __sender,
+#else
+# define __sender __thisContext
+#endif
+ __srch, __pI,
+#ifdef PASS_ARG_REF
+ __args)
+ OBJ __args[];
+# define __a1 __args[0]
+# define __a2 __args[1]
+# define __a3 __args[2]
+# define __a4 __args[3]
+# define __a5 __args[4]
+# define __a6 __args[5]
+# define __a7 __args[6]
+# define __a8 __args[7]
+
+#else
+ __a1, __a2, __a3, __a4, __a5, __a6, __a7, __a8)
+ OBJ __a1, __a2, __a3, __a4, __a5, __a6, __a7, __a8;
+#endif
+ OBJ __sel, __srch;
+{
+ extern OBJ ByteArray, ExternalStream;
+ extern OBJ _ISKINDOF_();
+'.
+
+ returnType notNil ifTrue:[
+ ((returnType == #SmallInteger) or:[returnType == #Boolean]) ifTrue:[
+ aStream nextPutAll:' int __ret;'
+ ] ifFalse:[
+ (returnType == #Float) ifTrue:[
+ aStream nextPutAll:' double __ret;'
+ ] ifFalse:[
+ (returnType == #String) ifTrue:[
+ aStream nextPutAll:' char *__ret;'
+ ] ifFalse:[
+ self error:'returnType ' , returnType, ' not supported'.
+ ^ nil
+ ]
+ ]
+ ].
+ aStream cr
+ ].
+
+ "gen type checking code"
+ argTypes notNil ifTrue:[
+ index := 0.
+ argTypes do:[:argType |
+ (index + 1) timesRepeat:[ aStream nextPutAll:' '].
+ argName := '__a' , (index + 1) printString.
+
+ (argType == #SmallInteger) ifTrue:[
+ aStream nextPutAll:'if (_isSmallInteger(' , argName , ')) {'
+ ] ifFalse:[
+ (argType == #Float) ifTrue:[
+ aStream nextPutAll:'if (_isFloat(' , argName , ')) {'
+ ] ifFalse:[
+ (argType == #String) ifTrue:[
+ aStream nextPutAll:'if (_isString(' , argName , ')) {'
+ ] ifFalse:[
+ (argType == #Boolean) ifTrue:[
+ aStream nextPutAll:'if ((' , argName , '==true)'.
+ aStream nextPutAll:'||(' , argName , '==false)) {'
+ ] ifFalse:[
+ (argType == #ByteArray) ifTrue:[
+ aStream nextPutAll:'if (_Class(' , argName , ')==ByteArray) {'
+ ] ifFalse:[
+ (argType == #ExternalStream) ifTrue:[
+ aStream nextPutAll:'if (_ISKINDOF_(' , argName , ',
+#ifndef THIS_CONTEXT
+__sender,
+#endif
+#ifdef PASS_ARG_REF
+ &ExternalStream
+#else
+ ExternalStream
+#endif
+)==true) {'
+ ] ifFalse:[
+ self error:'argType ' , argType, ' not supported'.
+ ^ nil
+ ]
+ ]
+ ]
+ ]
+ ]
+ ].
+ aStream cr.
+ index := index + 1
+ ]
+ ].
+ "call the function"
+
+ (index + 1) timesRepeat:[ aStream nextPutAll:' '].
+ returnType notNil ifTrue:[
+ aStream nextPutAll:'__ret = '
+ ].
+ aStream nextPutAll:functionName , '('.
+ argTypes notNil ifTrue:[
+ index := 0.
+ argTypes do:[:argType |
+ argName := '__a' , (index + 1) printString.
+ (argType == #SmallInteger) ifTrue:[
+ aStream nextPutAll:'_intVal(' , argName , ')'
+ ] ifFalse:[
+ (argType == #Float) ifTrue:[
+ aStream nextPutAll:'_floatVal(' , argName , ')'
+ ] ifFalse:[
+ (argType == #String) ifTrue:[
+ aStream nextPutAll:'_stringVal(' , argName , ')'
+ ] ifFalse:[
+ (argType == #Boolean) ifTrue:[
+ aStream nextPutAll:'((' , argName , '==true) ? 1 : 0)'
+ ] ifFalse:[
+ (argType == #ByteArray) ifTrue:[
+ aStream nextPutAll:'(_ByteArrayInstPtr(' , argName , ')->ba_element)'
+ ] ifFalse:[
+ (argType == #ExternalStream) ifTrue:[
+ aStream nextPutAll:'_intVal(_InstPtr(' , argName , ')->i_instvars[',
+ ((ExternalStream allInstVarNames indexOf:'filePointer') - 1) printString, '])'
+ ]
+ ]
+ ]
+ ]
+ ]
+ ].
+ index := index + 1.
+ (index == argTypes size) ifFalse:[
+ aStream nextPutAll:','
+ ]
+ ]
+ ].
+ aStream nextPutAll:');'. aStream cr.
+
+ argTypes notNil ifTrue:[
+ argTypes size timesRepeat:[
+ index timesRepeat:[ aStream nextPutAll:' '].
+ aStream nextPutAll:'}'. aStream cr.
+ index := index - 1
+ ]
+ ].
+
+ returnType notNil ifTrue:[
+ (returnType == #SmallInteger) ifTrue:[
+ aStream nextPutAll:' return _MKSMALLINT(__ret);'
+ ] ifFalse:[
+ (returnType == #Float) ifTrue:[
+ aStream nextPutAll:' return _MKFLOAT(__ret, __s);'
+ ] ifFalse:[
+ (returnType == #String) ifTrue:[
+ aStream nextPutAll:' return (__ret ? _MKSTRING(__ret, __s) : nil);'
+ ] ifFalse:[
+ (returnType == #Boolean) ifTrue:[
+ aStream nextPutAll:' return (__ret ? true : false);'
+ ]
+ ]
+ ]
+ ]
+ ] ifFalse:[
+ aStream nextPutAll:' return self;'
+ ].
+ aStream cr.
+
+ aStream nextPutAll:'}'. aStream cr.
+ aStream close.
+ ^ baseName
+
+ "ObjectFileLoader createStubSource:'stub1' calling:'printMessage' args:#(String) returning:nil"
+ "ObjectFileLoader createStubSource:'stub2' calling:'printMessage2' args:#(String SmallInteger) returning:#String"
+ "ObjectFileLoader createStubSource:'stub3' calling:'sqrt' args:#(Float) returning:#Float"
+ "ObjectFileLoader createStubSource:'stub4' calling:'checking' args:#(SmallInteger SmallInteger) returning:#Boolean"
+ "ObjectFileLoader createStubSource:'stub5' calling:'fprintf' args:#(ExternalStream String) returning:#SmallInteger"
+
+! !
+
+!ObjectFileLoader class methodsFor:'loading objects'!
+
+loadFile:oFile with:librariesString
+ "load in an object files code, linking in libraries"
+
+ |tmpOfile errStream errors errText ok pid|
+
+ pid := OperatingSystem getProcessId printString.
+ tmpOfile := '/tmp/stc_ld' , pid.
+ verbose ifTrue:[
+ Transcript showCr:'executing: ' , ('ld -o ',tmpOfile,' -r ' , oFile , ' ' , librariesString , '>/tmp/out 2>/tmp/err')
+ ].
+ (OperatingSystem executeCommand:'ld -o ',tmpOfile,' -r ' , oFile , ' ' , librariesString , '>/tmp/out 2>/tmp/err')
+ ifFalse:[
+ errStream := FileStream oldFileNamed:'/tmp/err'.
+ errStream isNil ifTrue:[
+ self notify:'errors during link.'
+ ] ifFalse:[
+ errors := errStream contents.
+ errText := errors asText.
+ (errText size > 20) ifTrue:[
+ errText grow:20.
+ errText add:'... '.
+ errors := errText
+ ].
+ OperatingSystem executeCommand:'rm /tmp/err /tmp/out'.
+ self notify:('link errors:\\' , errors asString) withCRs
+ ].
+ ^ false
+ ].
+ ok := self loadFile:tmpOfile.
+ OperatingSystem executeCommand:('rm ' , tmpOfile).
+ ^ ok
+!
+
+loadFile:oFile
+ "load in an object files code"
+
+ | unixCommand errStream errors errText
+ text data textSize dataSize |
+
+ "find out, how much memory we need"
+
+ textSize := ObjectFile textSizeOf:oFile.
+ textSize isNil ifTrue:[
+ Transcript showCr:'bad text-size in object file'.
+ ^ false
+ ].
+ verbose ifTrue:[
+ Transcript showCr:'text-size: ' , (textSize printStringRadix:16)
+ ].
+
+ dataSize := ObjectFile dataSizeOf:oFile.
+ dataSize isNil ifTrue:[
+ Transcript showCr:'bad data-size in object file'.
+ ^ false
+ ].
+
+ verbose ifTrue:[
+ Transcript showCr:'data-size: ' , (dataSize printStringRadix:16)
+ ].
+
+ "allocate some memory for text and some for data;
+ then call linker to link the file to those addresses"
+
+ self needSeparateIDSpaces ifTrue:[
+ text := ExternalBytes newForText:textSize.
+ (dataSize ~~ 0) ifTrue:[
+ data := ExternalBytes newForData:dataSize
+ ].
+
+ text isNil ifTrue:[
+ Transcript showCr:'cannot allocate memory for text'.
+ ^ false
+ ].
+
+ verbose ifTrue:[
+ Transcript showCr:'text: ' , (text address printStringRadix:16)
+ ].
+
+ (dataSize ~~ 0) ifTrue:[
+ (data isNil) ifTrue:[
+ Transcript showCr:'cannot allocate memory for data'.
+ text notNil ifTrue:[text free].
+ ^ false
+ ].
+ verbose ifTrue:[
+ Transcript showCr:'data: ' , (data address printStringRadix:16)
+ ]
+ ]
+
+ ] ifFalse:[
+ text := ExternalBytes newForText:(textSize + dataSize).
+ text isNil ifTrue:[
+ Transcript showCr:'cannot allocate memory for text'.
+ ^ false
+ ].
+ verbose ifTrue:[
+ Transcript showCr:'addr: ' , (text address printStringRadix:16)
+ ]
+ ].
+
+ unixCommand := (self absLd:oFile text:text address data:data address) , ' >/tmp/out 2>/tmp/err'.
+
+ verbose ifTrue:[
+ Transcript showCr:'executing: ' , unixCommand
+ ].
+
+ Transcript showCr:'linking ...'.
+ (OperatingSystem executeCommand:unixCommand) ifFalse: [
+ errStream := FileStream oldFileNamed:'/tmp/err'.
+ errStream notNil ifTrue:[
+ errors := errStream contents.
+ errText := errors asText.
+ (errText size > 20) ifTrue:[
+ errText grow:20.
+ errText add:'... '.
+ errors := errText
+ ].
+ OperatingSystem executeCommand:'rm /tmp/err /tmp/out'.
+ self notify:('link errors:\\' , errors asString) withCRs
+ ].
+ Transcript showCr:'link unsuccessful.'.
+ text notNil ifTrue:[text free].
+ data notNil ifTrue:[data free].
+ ^ false
+ ].
+
+ Transcript showCr:'link successful'.
+
+ OperatingSystem executeCommand:'rm /tmp/err /tmp/out'.
+
+ "only thing left to do is to load in text at textAddr and
+ data at dataAddr ... "
+
+ (ObjectFile loadObjectFile:'a.out'
+ textAddr:text address textSize:textSize
+ dataAddr:data address dataSize:dataSize) isNil ifTrue: [
+ Transcript showCr:'load in error'.
+ text notNil ifTrue:[text free].
+ data notNil ifTrue:[data free].
+ ^ false
+ ].
+
+ Transcript showCr:'load in successful'.
+
+ OperatingSystem executeCommand:'mv a.out SymbolTable'.
+ mySymbolTable := 'SymbolTable'.
+ ^ true
+! !
+
+!ObjectFileLoader class methodsFor:'dynamic class loading'!
+
+loadClass:aClassName fromObjectFile:aFileName
+ "load a compiled class (.o-file) into the image"
+
+ |handle initAddr symName|
+
+ handle := self openDynamicObject:aFileName.
+ handle isNil ifTrue:[
+ Transcript showCr:('openDynamic: ',aFileName,' failed.').
+ ^ nil
+ ].
+ OperatingSystem getOSType = 'sys5.4' ifTrue:[
+ symName := '_' , aClassName , '_Init'
+ ] ifFalse:[
+ symName := '__' , aClassName , '_Init'
+ ].
+ initAddr := self getSymbol:symName from:handle.
+ initAddr isNil ifTrue:[
+ Transcript showCr:('no symbol: ',symName,' in ',aFileName).
+ ^ nil
+ ].
+ self callFunctionAt:initAddr.
+ ^ Smalltalk at:aClassName asSymbol
+
+ "ObjectFileLoader loadClass:'Tetris' fromObjectFile:'../clients/Tetris/Tetris.o'"
+ "ObjectFileLoader loadClass:'TetrisBlock' fromObjectFile:'../clients/Tetris/TBlock.o'"
+!
+
+loadObjectFile:aFileName
+ "load a compiled class (.o-file) into the image; the class name
+ is not needed (multiple definitions may be in the file)"
+
+ |handle initAddr symName className|
+
+ handle := self openDynamicObject:aFileName.
+ handle isNil ifTrue:[
+ Transcript showCr:('openDynamic: ',aFileName,' failed.').
+ ^ nil
+ ].
+ className := OperatingSystem baseNameOf:aFileName.
+ (className endsWith:'.o') ifTrue:[
+ className := className copyFrom:1 to:(className size - 2)
+ ].
+ OperatingSystem getOSType = 'sys5.4' ifTrue:[
+ symName := '_' , className , '_Init'
+ ] ifFalse:[
+ symName := '__' , className , '_Init'
+ ].
+ initAddr := self getSymbol:symName from:handle.
+ initAddr isNil ifTrue:[
+ Transcript showCr:('no symbol: ',symName,' in ',aFileName).
+ ^ nil
+ ].
+ self callFunctionAt:initAddr.
+ ^ self
+! !
+
+!ObjectFileLoader class methodsFor:'dynamic object access'!
+
+openDynamicObject:pathName
+ "open an object-file (map into my address space).
+ Return a non-nil handle if ok, nil otherwise.
+ This function is not supported on all architectures."
+
+ |low hi|
+%{
+#ifdef SYSV4
+# include <dlfcn.h>
+ void *handle;
+
+ if ((pathName == nil) || _isString(pathName)) {
+ if (pathName == nil)
+ handle = dlopen((char *)0, RTLD_NOW);
+ else
+ handle = dlopen(_stringVal(pathName), RTLD_NOW);
+ if (handle) {
+ printf("open %s handle = %x\n", _stringVal(pathName), handle);
+ low = _MKSMALLINT( (int)handle & 0xFFFF );
+ hi = _MKSMALLINT( ((int)handle >> 16) & 0xFFFF );
+ } else {
+ printf("dlopen %s error: <%s>\n", _stringVal(pathName), dlerror());
+ }
+ }
+#endif
+#ifdef NeXT
+ long result;
+ char *files[2];
+ NXStream *errOut;
+
+ if (_isString(pathName)) {
+ files[0] = _stringVal(pathName);
+ files[1] = (char *)0;
+ errOut = NXOpenFile(2, 2);
+ result = rld_load(errOut,
+ (struct mach_header **)0,
+ files,
+ (char *)0);
+ NXClose(errOut);
+ if (result) {
+ printf("rld_load %s ok\n", _stringVal(pathName));
+ RETURN ( _MKSMALLINT(1) ); /* a dummy handle */
+ }
+ }
+ RETURN ( nil );
+#endif
+%}
+.
+ low notNil ifTrue:[
+ ^ (hi * 16r10000) + low
+ ].
+
+ ^ nil
+
+ "sys5.4:
+ |handle|
+ handle := ObjectFileLoader openDynamicObject:'../stc/mod1.so'.
+ ObjectFileLoader getSymbol:'module1' from:handle"
+ "next:
+ |handle|
+ handle := ObjectFileLoader openDynamicObject:'../goodies/Path/AbstrPath.o'.
+ ObjectFileLoader getSymbol:'__AbstractPath_Init' from:handle"
+!
+
+closeDynamicObject:handle
+ "close an object-file (unmap from my address space)."
+
+ |low hi|
+
+ hi := handle // 16r10000.
+ low := handle \\ 16r10000.
+%{
+#ifdef SYSV4
+# include <dlfcn.h>
+ void *h;
+ int val;
+
+ if (_isSmallInteger(low) && _isSmallInteger(hi)) {
+ val = (_intVal(hi) << 16) + _intVal(low);
+ h = (void *)(val);
+ printf("close handle = %x\n", h);
+ dlclose(h);
+ }
+#endif
+%}
+!
+
+getSymbol:aString from:handle
+ "return the address of a symbol from a dynamically loaded object file.
+ Handle must be the one returned previously from openDynamicObject.
+ Return the address of the symbol, or nil on any error."
+
+ |low hi lowAddr hiAddr|
+
+ hi := handle // 16r10000.
+ low := handle \\ 16r10000.
+%{
+#ifdef SYSV4
+# include <dlfcn.h>
+ void *h;
+ void *addr;
+ int val;
+
+ if (_isSmallInteger(low) && _isSmallInteger(hi)) {
+ val = (_intVal(hi) << 16) + _intVal(low);
+ h = (void *)(val);
+ if (_isString(aString)) {
+ printf("get sym <%s> handle = %x\n", _stringVal(aString), h);
+ addr = dlsym(h, _stringVal(aString));
+ if (addr) {
+ printf("addr = %x\n", addr);
+ lowAddr = _MKSMALLINT( (int)addr & 0xFFFF );
+ hiAddr = _MKSMALLINT( ((int)addr >> 16) & 0xFFFF );
+ } else {
+ printf("dlsym %s error: <%s>\n", _stringVal(aString), dlerror());
+ }
+ }
+ }
+#endif
+#ifdef NeXT
+ unsigned long addr;
+ long result;
+ NXStream *errOut;
+
+ if (_isString(aString)) {
+ printf("get sym <%s>\n", _stringVal(aString));
+ errOut = NXOpenFile(2, 2);
+ result = rld_lookup(errOut,
+ _stringVal(aString),
+ &addr);
+ NXClose(errOut);
+ if (result) {
+ printf("addr = %x\n", addr);
+ lowAddr = _MKSMALLINT( (int)addr & 0xFFFF );
+ hiAddr = _MKSMALLINT( ((int)addr >> 16) & 0xFFFF );
+ }
+ }
+#endif
+%}
+.
+ lowAddr notNil ifTrue:[
+ ^ (hiAddr * 16r10000) + lowAddr
+ ].
+ ^ nil
+!
+
+releaseSymbolTable
+ "this is needed on NeXT to forget loaded names. If this wasnt done,
+ the same class could nat be loaded in again due to multiple defines.
+ On other architectures, this is not needed and therefore a noop."
+
+%{
+#ifdef NeXT
+ NXStream *errOut;
+
+ errOut = NXOpenFile(2, 2);
+ rld_unload_all(errOut, (long)0);
+ rld_load_basefile(errOut, "smalltalk");
+ NXClose(errOut);
+#endif
+%}
+!
+
+callFunctionAt:address
+ "call a function at address - this is very dangerous.
+ This is needed to call the classes init-function after loading in a
+ class-object file. Dont use in your programs."
+
+ |low hi lowAddr hiAddr|
+
+ hi := address // 16r10000.
+ low := address \\ 16r10000.
+%{
+ void (*addr)();
+ unsigned val;
+ typedef void (*VOIDFUNC)();
+
+ if (_isSmallInteger(low) && _isSmallInteger(hi)) {
+ val = (_intVal(hi) << 16) + _intVal(low);
+ addr = (VOIDFUNC) val;
+ (*addr)();
+ }
+%}
+! !
+
+ObjectFileLoader initialize!
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/ObjectFileLoader.st Fri Jul 16 11:38:57 1993 +0200
@@ -0,0 +1,897 @@
+"
+ COPYRIGHT (c) 1993 by Claus Gittinger
+ All Rights Reserved
+
+ This software is furnished under a license and may be used
+ only in accordance with the terms of that license and with the
+ inclusion of the above copyright notice. This software may not
+ be provided or otherwise made available to, or used by, any
+ other person. No title to or ownership of the software is
+ hereby transferred.
+"
+
+Object subclass:#ObjectFileLoader
+ instanceVariableNames:''
+ classVariableNames:'mySymbolTable stubNr verbose'
+ poolDictionaries:''
+ category:'System-Compiler'
+!
+
+ObjectFileLoader comment:'
+
+COPYRIGHT (c) 1993 by Claus Gittinger
+ All Rights Reserved
+
+this one knowns how to load in external (c)-modules
+(see fileIn/cExample.c) it is all experimental and
+WILL DEFINITELY change soon ...
+
+(goal is to allow loading of binary classes)
+
+%W% %E%
+'!
+
+%{
+#ifdef NeXT
+# ifndef _RLD_H_
+# define _RLD_H_
+# include <rld.h>
+# endif
+#endif /* NeXT */
+%}
+
+!ObjectFileLoader class methodsFor:'initialization'!
+
+initialize
+ "name of object file, where initial symbol table is found"
+
+ mySymbolTable := 'smalltalk'.
+ stubNr := 1.
+ verbose := false
+!
+
+verbose:aBoolean
+ "turn on/off debug traces"
+
+ verbose := aBoolean
+
+ "ObjectFileLoader verbose:true"
+! !
+
+!ObjectFileLoader class methodsFor:'command defaults'!
+
+needSeparateIDSpaces
+ "return true, if we need separate I and D spaces"
+
+ |os cpu|
+
+ os := OperatingSystem getSystemType.
+ cpu := OperatingSystem getCPUType.
+
+ (os = 'sunos') ifTrue:[
+ (cpu = 'sparc') ifTrue:[ ^ true ]
+ ].
+ self error:'dont know if we need sepId'
+!
+
+absLd:file text:textAddr data:dataAddr
+ "this should return a string to link file.o to absolute address"
+
+ |os cpu|
+
+ os := OperatingSystem getSystemType.
+ cpu := OperatingSystem getCPUType.
+ (os = 'sunos') ifTrue:[
+ (cpu = 'sparc') ifTrue:[
+"
+ ^ ('ld -A ' , mySymbolTable , ' -x -Bstatic -Ttext '
+ , (textAddr printStringRadix:16) , ' -Tdata '
+ , (dataAddr printStringRadix:16) , ' ' , file)
+"
+ ^ ('ld -A ' , mySymbolTable , ' -T ',
+ (textAddr printStringRadix:16),
+ ' -N -x ' , file)
+
+ ]
+ ].
+"
+ (os = 'ultrix') ifTrue:[
+ (cpu = 'mips') ifTrue:[
+ ^ ('ld -A ' , mySymbolTable , ' -x -N -T ' , (textAddr printStringRadix:16) , ' ' , file)
+ ]
+ ].
+"
+ self error:'do not know how to link absolute'
+! !
+
+!ObjectFileLoader class methodsFor:'dynamic loading'!
+
+loadFile:aFileName library:librariesString withBindings:bindings in:aClass
+ "first, load the file itself"
+
+ (self loadFile:aFileName with:librariesString) ifFalse:[^ false].
+
+ "then, create stubs"
+ self bindExternalFunctions:bindings in:aClass
+!
+
+loadFile:aFileName withBindings:bindings in:aClass
+ "load an object file containing external functions, and bind the functions as described
+ in bindings, which is an Array of
+ (selector functionName argTypes returnType)
+ entries, example:
+ #(
+ (sel1:and: 'f1' (SmallInteger SmallInteger) nil) -> bind 'aClass sel1:and:' to: 'void f1(int, int)'
+ (sel2:and: 'f2' (String SmallInteger) String) -> bind 'aClass sel2:and:' to: 'char *f2(char *, int)'
+ )
+ "
+
+ "first, load the file itself"
+
+ (self loadFile:aFileName) ifFalse:[^ false].
+
+ "then, create stubs"
+ self bindExternalFunctions:bindings in:aClass
+!
+
+bindExternalFunctions:bindings in:aClass
+ | selector functionName argTypes returnType allOk |
+
+ allOk := true.
+ bindings do:[:aBinding |
+ selector := aBinding at:1.
+ functionName := aBinding at:2.
+ argTypes := aBinding at:3.
+ returnType := aBinding at:4.
+ (self createStubFor:selector calling:functionName args:argTypes returning:returnType in:aClass)
+ isNil ifTrue:[
+ Transcript showCr:'binding of ' , functionName , ' failed.'.
+ allOk := false
+ ]
+ ].
+ ^ allOk
+! !
+
+!ObjectFileLoader class methodsFor:'creating stubs'!
+
+storeGlobalAddressesOn:aStream
+
+ Smalltalk allKeysDo:[:key |
+ self storeGlobalAddressOf:key on:aStream
+ ]
+
+ "ObjectFileLoader storeGlobalAddressesOn:Transcript"
+ "|f|
+ f := FileStream newFileNamed:'syms.c'.
+ ObjectFileLoader storeGlobalAddressesOn:f.
+ f close"
+!
+
+storeGlobalAddressOf:aSymbol on:aStream
+ |globalName|
+
+ globalName := aSymbol asString.
+ (globalName includes:$:) ifTrue:[
+ globalName replaceAll:$: by:$_
+ ].
+
+ aStream nextPutAll:'#define ',globalName,'_addr '.
+ aStream nextPutAll:(Smalltalk cellAt:aSymbol) printString.
+ aStream cr.
+
+ aStream nextPutAll:'#define ',globalName,' ( *( (OBJ *) ',globalName,'_addr))'.
+ aStream cr
+
+ "ObjectFileLoader storeGlobalAddressOf:#String on:Transcript"
+ "ObjectFileLoader storeGlobalAddressOf:#Symbol on:Transcript"
+!
+
+createStubFor:aSelector calling:functionName args:argTypes returning:returnType in:aClass
+ "create a method calling a stub function"
+
+ |address newMethod|
+
+ address := self createStubCalling:functionName args:argTypes returning:returnType.
+ address isNil ifTrue:[^ nil].
+
+ newMethod := Method new.
+ newMethod code:address.
+ newMethod category:'external functions'.
+ newMethod numberOfMethodVars:0.
+ newMethod stackSize:0.
+
+ aClass class addSelector:aSelector withMethod:newMethod.
+
+ SilentLoading ifFalse:[
+ Transcript showCr:('created stub: ',aClass class name,' ', aSelector)
+ ].
+
+ ^ newMethod
+
+ "ObjectFileLoader createStubFor:#printf: calling:'printf' args:#(String) returning:nil in:TestClass"
+ "ObjectFileLoader createStubFor:#printf:with: calling:'printf'
+ args:#(String SmallInteger) returning:nil in:TestClass"
+!
+
+createStubCalling:functionName args:argTypes returning:returnType
+ "create a stub function for calling functionName - return the address of the
+ function in core or nil on error"
+
+ |baseName p t l handle address stubName|
+
+ stubName := 'stub000' , (stubNr printStringRadix:16).
+ stubName := stubName copyFrom:(stubName size - 7) to:(stubName size).
+
+ baseName := self createStubSource:stubName calling:functionName args:argTypes returning:returnType.
+ baseName isNil ifTrue:[^ nil].
+
+ "compile it ..."
+ verbose ifTrue:[
+ Transcript showCr:'compiling stub ...', baseName. Transcript endEntry
+ ].
+
+ (OperatingSystem executeCommand:('make /tmp/' , baseName , '.o')) ifFalse:[
+ Transcript showCr:'compilation error.'.
+ ^ nil
+ ].
+ OperatingSystem executeCommand:('mv ' , baseName , '.o /tmp/' , baseName , '.o').
+ verbose ifFalse:[
+ OperatingSystem executeCommand:('rm /tmp/' , baseName , '.c').
+ ].
+
+ (OperatingSystem getOSType = 'sys5.4') ifTrue:[
+ "make it a sharable object"
+
+ verbose ifTrue:[
+ Transcript showCr:'makeing shared object stub ...', baseName. Transcript endEntry.
+ ].
+ OperatingSystem executeCommand:('ld -G -o /tmp/',baseName,'.so /tmp/',baseName,'.o').
+
+ "attach to it"
+ handle := self openDynamicObject:('/tmp/',baseName,'.so').
+ handle isNil ifTrue:[
+ Transcript showCr:('dlopen error:', '/tmp/',baseName,'.so').
+ ^ nil
+ ].
+ "find the stubs address"
+ address := self getSymbol:stubName from:handle.
+ address isNil ifTrue:[
+ Transcript showCr:'dlsym failed'.
+ ^ nil
+ ]
+ ].
+
+ (OperatingSystem getOSType = 'sunos') ifTrue:[
+ "load it"
+ (self loadFile:('/tmp/' , baseName , '.o')) ifFalse:[
+ Transcript showCr:'load error.'.
+ ^ nil
+ ].
+
+ "find the stubs address (use nm to get the address)"
+ t := Text new.
+ p := PipeStream readingFrom:('nm SymbolTable|grep ' , stubName , ' |grep T').
+ [p atEnd] whileFalse:[
+ l := p nextLine.
+ l notNil ifTrue:[
+ t add:l
+ ]
+ ].
+ p close.
+ (t size == 1) ifFalse:[
+ Transcript showCr:('oops, ' , stubName , ' not in name-list.').
+ ^ nil
+ ].
+ address := Integer readFrom:(ReadStream on:(t at:1)) radix:16
+ ].
+
+ address isNil ifTrue:[
+ Transcript showCr:'no way to dynamically load objects'.
+ ^ nil
+ ].
+
+ verbose ifTrue:[
+ Transcript show:'stub ' , stubName , ' address:'.
+ Transcript showCr:(address printStringRadix:16).
+ ].
+
+ stubNr := stubNr + 1.
+ ^ address
+
+ "ObjectFileLoader createStubCalling:'printf'
+ args:#(String)
+ returning:nil"
+!
+
+createStubSource:stubName calling:functionName args:argTypes returning:returnType
+ "create a temp file with stub-code - return base-filename or nil"
+
+ |pid baseName index aStream argName|
+
+ pid := OperatingSystem getProcessId printString.
+ baseName := 'stc' , pid.
+ aStream := FileStream newFileNamed:('/tmp/' , baseName , '.c').
+ aStream nextPutAll:'
+#include <stc.h>
+'.
+
+ OperatingSystem getOSType = 'sys5.4' ifTrue:[
+ self storeGlobalAddressesOn:aStream.
+ ].
+
+ aStream nextPutAll:'
+' , stubName , '(self, __sel,
+#ifndef THIS_CONTEXT
+ __sender,
+#else
+# define __sender __thisContext
+#endif
+ __srch, __pI,
+#ifdef PASS_ARG_REF
+ __args)
+ OBJ __args[];
+# define __a1 __args[0]
+# define __a2 __args[1]
+# define __a3 __args[2]
+# define __a4 __args[3]
+# define __a5 __args[4]
+# define __a6 __args[5]
+# define __a7 __args[6]
+# define __a8 __args[7]
+
+#else
+ __a1, __a2, __a3, __a4, __a5, __a6, __a7, __a8)
+ OBJ __a1, __a2, __a3, __a4, __a5, __a6, __a7, __a8;
+#endif
+ OBJ __sel, __srch;
+{
+ extern OBJ ByteArray, ExternalStream;
+ extern OBJ _ISKINDOF_();
+'.
+
+ returnType notNil ifTrue:[
+ ((returnType == #SmallInteger) or:[returnType == #Boolean]) ifTrue:[
+ aStream nextPutAll:' int __ret;'
+ ] ifFalse:[
+ (returnType == #Float) ifTrue:[
+ aStream nextPutAll:' double __ret;'
+ ] ifFalse:[
+ (returnType == #String) ifTrue:[
+ aStream nextPutAll:' char *__ret;'
+ ] ifFalse:[
+ self error:'returnType ' , returnType, ' not supported'.
+ ^ nil
+ ]
+ ]
+ ].
+ aStream cr
+ ].
+
+ "gen type checking code"
+ argTypes notNil ifTrue:[
+ index := 0.
+ argTypes do:[:argType |
+ (index + 1) timesRepeat:[ aStream nextPutAll:' '].
+ argName := '__a' , (index + 1) printString.
+
+ (argType == #SmallInteger) ifTrue:[
+ aStream nextPutAll:'if (_isSmallInteger(' , argName , ')) {'
+ ] ifFalse:[
+ (argType == #Float) ifTrue:[
+ aStream nextPutAll:'if (_isFloat(' , argName , ')) {'
+ ] ifFalse:[
+ (argType == #String) ifTrue:[
+ aStream nextPutAll:'if (_isString(' , argName , ')) {'
+ ] ifFalse:[
+ (argType == #Boolean) ifTrue:[
+ aStream nextPutAll:'if ((' , argName , '==true)'.
+ aStream nextPutAll:'||(' , argName , '==false)) {'
+ ] ifFalse:[
+ (argType == #ByteArray) ifTrue:[
+ aStream nextPutAll:'if (_Class(' , argName , ')==ByteArray) {'
+ ] ifFalse:[
+ (argType == #ExternalStream) ifTrue:[
+ aStream nextPutAll:'if (_ISKINDOF_(' , argName , ',
+#ifndef THIS_CONTEXT
+__sender,
+#endif
+#ifdef PASS_ARG_REF
+ &ExternalStream
+#else
+ ExternalStream
+#endif
+)==true) {'
+ ] ifFalse:[
+ self error:'argType ' , argType, ' not supported'.
+ ^ nil
+ ]
+ ]
+ ]
+ ]
+ ]
+ ].
+ aStream cr.
+ index := index + 1
+ ]
+ ].
+ "call the function"
+
+ (index + 1) timesRepeat:[ aStream nextPutAll:' '].
+ returnType notNil ifTrue:[
+ aStream nextPutAll:'__ret = '
+ ].
+ aStream nextPutAll:functionName , '('.
+ argTypes notNil ifTrue:[
+ index := 0.
+ argTypes do:[:argType |
+ argName := '__a' , (index + 1) printString.
+ (argType == #SmallInteger) ifTrue:[
+ aStream nextPutAll:'_intVal(' , argName , ')'
+ ] ifFalse:[
+ (argType == #Float) ifTrue:[
+ aStream nextPutAll:'_floatVal(' , argName , ')'
+ ] ifFalse:[
+ (argType == #String) ifTrue:[
+ aStream nextPutAll:'_stringVal(' , argName , ')'
+ ] ifFalse:[
+ (argType == #Boolean) ifTrue:[
+ aStream nextPutAll:'((' , argName , '==true) ? 1 : 0)'
+ ] ifFalse:[
+ (argType == #ByteArray) ifTrue:[
+ aStream nextPutAll:'(_ByteArrayInstPtr(' , argName , ')->ba_element)'
+ ] ifFalse:[
+ (argType == #ExternalStream) ifTrue:[
+ aStream nextPutAll:'_intVal(_InstPtr(' , argName , ')->i_instvars[',
+ ((ExternalStream allInstVarNames indexOf:'filePointer') - 1) printString, '])'
+ ]
+ ]
+ ]
+ ]
+ ]
+ ].
+ index := index + 1.
+ (index == argTypes size) ifFalse:[
+ aStream nextPutAll:','
+ ]
+ ]
+ ].
+ aStream nextPutAll:');'. aStream cr.
+
+ argTypes notNil ifTrue:[
+ argTypes size timesRepeat:[
+ index timesRepeat:[ aStream nextPutAll:' '].
+ aStream nextPutAll:'}'. aStream cr.
+ index := index - 1
+ ]
+ ].
+
+ returnType notNil ifTrue:[
+ (returnType == #SmallInteger) ifTrue:[
+ aStream nextPutAll:' return _MKSMALLINT(__ret);'
+ ] ifFalse:[
+ (returnType == #Float) ifTrue:[
+ aStream nextPutAll:' return _MKFLOAT(__ret, __s);'
+ ] ifFalse:[
+ (returnType == #String) ifTrue:[
+ aStream nextPutAll:' return (__ret ? _MKSTRING(__ret, __s) : nil);'
+ ] ifFalse:[
+ (returnType == #Boolean) ifTrue:[
+ aStream nextPutAll:' return (__ret ? true : false);'
+ ]
+ ]
+ ]
+ ]
+ ] ifFalse:[
+ aStream nextPutAll:' return self;'
+ ].
+ aStream cr.
+
+ aStream nextPutAll:'}'. aStream cr.
+ aStream close.
+ ^ baseName
+
+ "ObjectFileLoader createStubSource:'stub1' calling:'printMessage' args:#(String) returning:nil"
+ "ObjectFileLoader createStubSource:'stub2' calling:'printMessage2' args:#(String SmallInteger) returning:#String"
+ "ObjectFileLoader createStubSource:'stub3' calling:'sqrt' args:#(Float) returning:#Float"
+ "ObjectFileLoader createStubSource:'stub4' calling:'checking' args:#(SmallInteger SmallInteger) returning:#Boolean"
+ "ObjectFileLoader createStubSource:'stub5' calling:'fprintf' args:#(ExternalStream String) returning:#SmallInteger"
+
+! !
+
+!ObjectFileLoader class methodsFor:'loading objects'!
+
+loadFile:oFile with:librariesString
+ "load in an object files code, linking in libraries"
+
+ |tmpOfile errStream errors errText ok pid|
+
+ pid := OperatingSystem getProcessId printString.
+ tmpOfile := '/tmp/stc_ld' , pid.
+ verbose ifTrue:[
+ Transcript showCr:'executing: ' , ('ld -o ',tmpOfile,' -r ' , oFile , ' ' , librariesString , '>/tmp/out 2>/tmp/err')
+ ].
+ (OperatingSystem executeCommand:'ld -o ',tmpOfile,' -r ' , oFile , ' ' , librariesString , '>/tmp/out 2>/tmp/err')
+ ifFalse:[
+ errStream := FileStream oldFileNamed:'/tmp/err'.
+ errStream isNil ifTrue:[
+ self notify:'errors during link.'
+ ] ifFalse:[
+ errors := errStream contents.
+ errText := errors asText.
+ (errText size > 20) ifTrue:[
+ errText grow:20.
+ errText add:'... '.
+ errors := errText
+ ].
+ OperatingSystem executeCommand:'rm /tmp/err /tmp/out'.
+ self notify:('link errors:\\' , errors asString) withCRs
+ ].
+ ^ false
+ ].
+ ok := self loadFile:tmpOfile.
+ OperatingSystem executeCommand:('rm ' , tmpOfile).
+ ^ ok
+!
+
+loadFile:oFile
+ "load in an object files code"
+
+ | unixCommand errStream errors errText
+ text data textSize dataSize |
+
+ "find out, how much memory we need"
+
+ textSize := ObjectFile textSizeOf:oFile.
+ textSize isNil ifTrue:[
+ Transcript showCr:'bad text-size in object file'.
+ ^ false
+ ].
+ verbose ifTrue:[
+ Transcript showCr:'text-size: ' , (textSize printStringRadix:16)
+ ].
+
+ dataSize := ObjectFile dataSizeOf:oFile.
+ dataSize isNil ifTrue:[
+ Transcript showCr:'bad data-size in object file'.
+ ^ false
+ ].
+
+ verbose ifTrue:[
+ Transcript showCr:'data-size: ' , (dataSize printStringRadix:16)
+ ].
+
+ "allocate some memory for text and some for data;
+ then call linker to link the file to those addresses"
+
+ self needSeparateIDSpaces ifTrue:[
+ text := ExternalBytes newForText:textSize.
+ (dataSize ~~ 0) ifTrue:[
+ data := ExternalBytes newForData:dataSize
+ ].
+
+ text isNil ifTrue:[
+ Transcript showCr:'cannot allocate memory for text'.
+ ^ false
+ ].
+
+ verbose ifTrue:[
+ Transcript showCr:'text: ' , (text address printStringRadix:16)
+ ].
+
+ (dataSize ~~ 0) ifTrue:[
+ (data isNil) ifTrue:[
+ Transcript showCr:'cannot allocate memory for data'.
+ text notNil ifTrue:[text free].
+ ^ false
+ ].
+ verbose ifTrue:[
+ Transcript showCr:'data: ' , (data address printStringRadix:16)
+ ]
+ ]
+
+ ] ifFalse:[
+ text := ExternalBytes newForText:(textSize + dataSize).
+ text isNil ifTrue:[
+ Transcript showCr:'cannot allocate memory for text'.
+ ^ false
+ ].
+ verbose ifTrue:[
+ Transcript showCr:'addr: ' , (text address printStringRadix:16)
+ ]
+ ].
+
+ unixCommand := (self absLd:oFile text:text address data:data address) , ' >/tmp/out 2>/tmp/err'.
+
+ verbose ifTrue:[
+ Transcript showCr:'executing: ' , unixCommand
+ ].
+
+ Transcript showCr:'linking ...'.
+ (OperatingSystem executeCommand:unixCommand) ifFalse: [
+ errStream := FileStream oldFileNamed:'/tmp/err'.
+ errStream notNil ifTrue:[
+ errors := errStream contents.
+ errText := errors asText.
+ (errText size > 20) ifTrue:[
+ errText grow:20.
+ errText add:'... '.
+ errors := errText
+ ].
+ OperatingSystem executeCommand:'rm /tmp/err /tmp/out'.
+ self notify:('link errors:\\' , errors asString) withCRs
+ ].
+ Transcript showCr:'link unsuccessful.'.
+ text notNil ifTrue:[text free].
+ data notNil ifTrue:[data free].
+ ^ false
+ ].
+
+ Transcript showCr:'link successful'.
+
+ OperatingSystem executeCommand:'rm /tmp/err /tmp/out'.
+
+ "only thing left to do is to load in text at textAddr and
+ data at dataAddr ... "
+
+ (ObjectFile loadObjectFile:'a.out'
+ textAddr:text address textSize:textSize
+ dataAddr:data address dataSize:dataSize) isNil ifTrue: [
+ Transcript showCr:'load in error'.
+ text notNil ifTrue:[text free].
+ data notNil ifTrue:[data free].
+ ^ false
+ ].
+
+ Transcript showCr:'load in successful'.
+
+ OperatingSystem executeCommand:'mv a.out SymbolTable'.
+ mySymbolTable := 'SymbolTable'.
+ ^ true
+! !
+
+!ObjectFileLoader class methodsFor:'dynamic class loading'!
+
+loadClass:aClassName fromObjectFile:aFileName
+ "load a compiled class (.o-file) into the image"
+
+ |handle initAddr symName|
+
+ handle := self openDynamicObject:aFileName.
+ handle isNil ifTrue:[
+ Transcript showCr:('openDynamic: ',aFileName,' failed.').
+ ^ nil
+ ].
+ OperatingSystem getOSType = 'sys5.4' ifTrue:[
+ symName := '_' , aClassName , '_Init'
+ ] ifFalse:[
+ symName := '__' , aClassName , '_Init'
+ ].
+ initAddr := self getSymbol:symName from:handle.
+ initAddr isNil ifTrue:[
+ Transcript showCr:('no symbol: ',symName,' in ',aFileName).
+ ^ nil
+ ].
+ self callFunctionAt:initAddr.
+ ^ Smalltalk at:aClassName asSymbol
+
+ "ObjectFileLoader loadClass:'Tetris' fromObjectFile:'../clients/Tetris/Tetris.o'"
+ "ObjectFileLoader loadClass:'TetrisBlock' fromObjectFile:'../clients/Tetris/TBlock.o'"
+!
+
+loadObjectFile:aFileName
+ "load a compiled class (.o-file) into the image; the class name
+ is not needed (multiple definitions may be in the file)"
+
+ |handle initAddr symName className|
+
+ handle := self openDynamicObject:aFileName.
+ handle isNil ifTrue:[
+ Transcript showCr:('openDynamic: ',aFileName,' failed.').
+ ^ nil
+ ].
+ className := OperatingSystem baseNameOf:aFileName.
+ (className endsWith:'.o') ifTrue:[
+ className := className copyFrom:1 to:(className size - 2)
+ ].
+ OperatingSystem getOSType = 'sys5.4' ifTrue:[
+ symName := '_' , className , '_Init'
+ ] ifFalse:[
+ symName := '__' , className , '_Init'
+ ].
+ initAddr := self getSymbol:symName from:handle.
+ initAddr isNil ifTrue:[
+ Transcript showCr:('no symbol: ',symName,' in ',aFileName).
+ ^ nil
+ ].
+ self callFunctionAt:initAddr.
+ ^ self
+! !
+
+!ObjectFileLoader class methodsFor:'dynamic object access'!
+
+openDynamicObject:pathName
+ "open an object-file (map into my address space).
+ Return a non-nil handle if ok, nil otherwise.
+ This function is not supported on all architectures."
+
+ |low hi|
+%{
+#ifdef SYSV4
+# include <dlfcn.h>
+ void *handle;
+
+ if ((pathName == nil) || _isString(pathName)) {
+ if (pathName == nil)
+ handle = dlopen((char *)0, RTLD_NOW);
+ else
+ handle = dlopen(_stringVal(pathName), RTLD_NOW);
+ if (handle) {
+ printf("open %s handle = %x\n", _stringVal(pathName), handle);
+ low = _MKSMALLINT( (int)handle & 0xFFFF );
+ hi = _MKSMALLINT( ((int)handle >> 16) & 0xFFFF );
+ } else {
+ printf("dlopen %s error: <%s>\n", _stringVal(pathName), dlerror());
+ }
+ }
+#endif
+#ifdef NeXT
+ long result;
+ char *files[2];
+ NXStream *errOut;
+
+ if (_isString(pathName)) {
+ files[0] = _stringVal(pathName);
+ files[1] = (char *)0;
+ errOut = NXOpenFile(2, 2);
+ result = rld_load(errOut,
+ (struct mach_header **)0,
+ files,
+ (char *)0);
+ NXClose(errOut);
+ if (result) {
+ printf("rld_load %s ok\n", _stringVal(pathName));
+ RETURN ( _MKSMALLINT(1) ); /* a dummy handle */
+ }
+ }
+ RETURN ( nil );
+#endif
+%}
+.
+ low notNil ifTrue:[
+ ^ (hi * 16r10000) + low
+ ].
+
+ ^ nil
+
+ "sys5.4:
+ |handle|
+ handle := ObjectFileLoader openDynamicObject:'../stc/mod1.so'.
+ ObjectFileLoader getSymbol:'module1' from:handle"
+ "next:
+ |handle|
+ handle := ObjectFileLoader openDynamicObject:'../goodies/Path/AbstrPath.o'.
+ ObjectFileLoader getSymbol:'__AbstractPath_Init' from:handle"
+!
+
+closeDynamicObject:handle
+ "close an object-file (unmap from my address space)."
+
+ |low hi|
+
+ hi := handle // 16r10000.
+ low := handle \\ 16r10000.
+%{
+#ifdef SYSV4
+# include <dlfcn.h>
+ void *h;
+ int val;
+
+ if (_isSmallInteger(low) && _isSmallInteger(hi)) {
+ val = (_intVal(hi) << 16) + _intVal(low);
+ h = (void *)(val);
+ printf("close handle = %x\n", h);
+ dlclose(h);
+ }
+#endif
+%}
+!
+
+getSymbol:aString from:handle
+ "return the address of a symbol from a dynamically loaded object file.
+ Handle must be the one returned previously from openDynamicObject.
+ Return the address of the symbol, or nil on any error."
+
+ |low hi lowAddr hiAddr|
+
+ hi := handle // 16r10000.
+ low := handle \\ 16r10000.
+%{
+#ifdef SYSV4
+# include <dlfcn.h>
+ void *h;
+ void *addr;
+ int val;
+
+ if (_isSmallInteger(low) && _isSmallInteger(hi)) {
+ val = (_intVal(hi) << 16) + _intVal(low);
+ h = (void *)(val);
+ if (_isString(aString)) {
+ printf("get sym <%s> handle = %x\n", _stringVal(aString), h);
+ addr = dlsym(h, _stringVal(aString));
+ if (addr) {
+ printf("addr = %x\n", addr);
+ lowAddr = _MKSMALLINT( (int)addr & 0xFFFF );
+ hiAddr = _MKSMALLINT( ((int)addr >> 16) & 0xFFFF );
+ } else {
+ printf("dlsym %s error: <%s>\n", _stringVal(aString), dlerror());
+ }
+ }
+ }
+#endif
+#ifdef NeXT
+ unsigned long addr;
+ long result;
+ NXStream *errOut;
+
+ if (_isString(aString)) {
+ printf("get sym <%s>\n", _stringVal(aString));
+ errOut = NXOpenFile(2, 2);
+ result = rld_lookup(errOut,
+ _stringVal(aString),
+ &addr);
+ NXClose(errOut);
+ if (result) {
+ printf("addr = %x\n", addr);
+ lowAddr = _MKSMALLINT( (int)addr & 0xFFFF );
+ hiAddr = _MKSMALLINT( ((int)addr >> 16) & 0xFFFF );
+ }
+ }
+#endif
+%}
+.
+ lowAddr notNil ifTrue:[
+ ^ (hiAddr * 16r10000) + lowAddr
+ ].
+ ^ nil
+!
+
+releaseSymbolTable
+ "this is needed on NeXT to forget loaded names. If this wasnt done,
+ the same class could nat be loaded in again due to multiple defines.
+ On other architectures, this is not needed and therefore a noop."
+
+%{
+#ifdef NeXT
+ NXStream *errOut;
+
+ errOut = NXOpenFile(2, 2);
+ rld_unload_all(errOut, (long)0);
+ rld_load_basefile(errOut, "smalltalk");
+ NXClose(errOut);
+#endif
+%}
+!
+
+callFunctionAt:address
+ "call a function at address - this is very dangerous.
+ This is needed to call the classes init-function after loading in a
+ class-object file. Dont use in your programs."
+
+ |low hi lowAddr hiAddr|
+
+ hi := address // 16r10000.
+ low := address \\ 16r10000.
+%{
+ void (*addr)();
+ unsigned val;
+ typedef void (*VOIDFUNC)();
+
+ if (_isSmallInteger(low) && _isSmallInteger(hi)) {
+ val = (_intVal(hi) << 16) + _intVal(low);
+ addr = (VOIDFUNC) val;
+ (*addr)();
+ }
+%}
+! !
+
+ObjectFileLoader initialize!
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/ParseNode.st Fri Jul 16 11:38:57 1993 +0200
@@ -0,0 +1,103 @@
+"
+ COPYRIGHT (c) 1989-93 by Claus Gittinger
+ All Rights Reserved
+
+ This software is furnished under a license and may be used
+ only in accordance with the terms of that license and with the
+ inclusion of the above copyright notice. This software may not
+ be provided or otherwise made available to, or used by, any
+ other person. No title to or ownership of the software is
+ hereby transferred.
+"
+
+Object subclass:#ParseNode
+ instanceVariableNames:'type'
+ classVariableNames:''
+ poolDictionaries:''
+ category:'System-Compiler-Support'
+!
+
+ParseNode comment:'
+
+COPYRIGHT (c) 1989-93 by Claus Gittinger
+ All Rights Reserved
+
+%W% %E%
+'!
+
+!ParseNode class methodsFor:'instance creation'!
+
+type:t
+ ^ (self basicNew) type:t
+! !
+
+!ParseNode methodsFor:'queries'!
+
+isConstant
+ ^ false
+!
+
+isMessage
+ ^ false
+!
+
+isBinaryMessage
+ ^ false
+!
+
+isUnaryMessage
+ ^ false
+! !
+
+!ParseNode methodsFor:'accessing'!
+
+type
+ ^ type
+!
+
+lineNumber:dummy
+ "ignored here"
+
+ ^ self
+! !
+
+!ParseNode methodsFor:'private'!
+
+type:t
+ 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
+ "generate code for this statement - value not needed"
+
+ self codeOn:aStream inBlock:b.
+ aStream nextPut:#drop
+! !
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/Parser.st Fri Jul 16 11:38:57 1993 +0200
@@ -0,0 +1,1929 @@
+"
+ COPYRIGHT (c) 1989-93 by Claus Gittinger
+ All Rights Reserved
+
+ This software is furnished under a license and may be used
+ only in accordance with the terms of that license and with the
+ inclusion of the above copyright notice. This software may not
+ be provided or otherwise made available to, or used by, any
+ other person. No title to or ownership of the software is
+ hereby transferred.
+"
+
+Scanner subclass:#Parser
+ instanceVariableNames:'classToCompileFor selfValue
+ contextToEvaluateIn
+ selector
+ methodArgs methodArgNames
+ methodVars methodVarNames
+ tree
+ currentBlock
+ usedInstVars usedClassVars
+ modifiedInstVars modifiedClassVars
+ localVarDefPosition
+ evalExitBlock
+ selfNode superNode primNr logged'
+ classVariableNames:'prevClass prevInstVarNames
+ prevClassVarNames prevClassInstVarNames'
+ poolDictionaries:''
+ category:'System-Compiler'
+!
+
+Parser comment:'
+
+COPYRIGHT (c) 1989-93 by Claus Gittinger
+ All Rights Reserved
+
+Parser is used for both evaluating and compiling smalltalk expressions;
+it first builds a parseTree which is then interpreted (evaluate) or
+compiled. Compilation is done in the subclass BCompiler.
+
+Parser is also used to find the referenced/modified inst/classvars of
+a method - this is done by sending parseXXX message to a parser and asking
+the parser for referencedXVars or modifiedXVars (see SystemBrowser).
+
+%W% %E%
+'!
+
+!Parser class methodsFor:'evaluating expressions'!
+
+evaluate:aString
+ "return the result of evaluating aString"
+
+ ^ self evaluate:aString notifying:nil
+!
+
+evaluate:aStringOrStream notifying:requestor
+ "return the result of evaluating aString,
+ errors are reported to requestor"
+
+ |parser tree mustBackup|
+
+ aStringOrStream isNil ifTrue:[^ nil].
+ aStringOrStream isStream ifTrue:[
+ parser := self for:aStringOrStream.
+ mustBackup := true
+ ] ifFalse:[
+ parser := self for:(ReadStream on:aStringOrStream).
+ mustBackup := false
+ ].
+ parser notifying:requestor.
+ parser nextToken.
+ tree := parser parseMethodBodyOrNil.
+
+ "if reading from a stream, backup for next expression"
+ mustBackup ifTrue:[
+ parser backupPosition
+ ].
+
+ (parser errorFlag or:[tree == #Error]) ifTrue:[
+ ^ #Error
+ ].
+ tree notNil ifTrue:[
+ parser evalExitBlock:[:value | ^ value].
+ ^ tree evaluate
+ ].
+ ^ nil
+!
+
+evaluate:aString receiver:anObject notifying:requestor
+ "return the result of evaluating aString,
+ errors are reported to requestor. Allow access to
+ anObject as self and to its instVars (used in the inspector)"
+
+ ^ self evaluate:aString
+ in:nil
+ receiver:anObject
+ notifying:requestor
+ ifFail:nil
+!
+
+evaluate:aStringOrStream in:aContext receiver:anObject
+ notifying:requestor
+ ifFail:failBlock
+ |parser tree mustBackup|
+
+ aStringOrStream isNil ifTrue:[^ nil].
+ aStringOrStream isStream ifTrue:[
+ parser := self for:aStringOrStream.
+ mustBackup := true
+ ] ifFalse:[
+ parser := self for:(ReadStream on:aStringOrStream).
+ mustBackup := false
+ ].
+ parser setSelf:anObject.
+ parser setContext:aContext.
+ parser notifying:requestor.
+ parser nextToken.
+ tree := parser parseMethodBodyOrNil.
+
+ "if reading from a stream, backup for next expression"
+ mustBackup ifTrue:[
+ parser backupPosition
+ ].
+
+ (parser errorFlag or:[tree == #Error]) ifTrue:[
+ failBlock notNil ifTrue:[
+ ^ failBlock value
+ ].
+ ^ #Error
+ ].
+ tree notNil ifTrue:[
+ parser evalExitBlock:[:value | ^ value].
+ ^ tree evaluate
+ ].
+ ^ nil
+! !
+
+!Parser class methodsFor:'instance creation'!
+
+for:aStream in:aClass
+ |parser|
+
+ parser := self for:aStream.
+ parser setClassToCompileFor:aClass.
+ ^ parser
+! !
+
+!Parser class methodsFor:'parsing'!
+
+parseExpression:aString
+ "parse aString as an expression; return the parseTree"
+
+ ^ self withSelf:nil parseExpression:aString notifying:nil
+!
+
+withSelf:anObject parseExpression:aString notifying:someOne
+ "parse aString as an expression with self set to anObject;
+ return the parseTree"
+
+ |parser tree|
+
+ aString isNil ifTrue:[^ nil].
+ parser := self for:(ReadStream on:aString).
+ parser setSelf:anObject.
+ parser notifying:someOne.
+ parser nextToken.
+ tree := parser expression.
+ (parser errorFlag or:[tree == #Error]) ifTrue:[^ #Error].
+ ^ tree
+!
+
+parseMethodSpecification:aString
+ "parse a methods selector & arg specification;
+ return the parser or nil on error"
+
+ ^ self parseMethodSpecification:aString in:nil
+!
+
+parseMethodSpecification:aString in:aClass
+ "parse a methods selector & arg spec for a given class;
+ return the parser or nil on error"
+
+ |parser tree|
+
+ aString isNil ifTrue:[^ nil].
+ parser := self for:(ReadStream on:aString) in:aClass.
+ parser nextToken.
+ tree := parser parseMethodSpec.
+ (parser errorFlag or:[tree == #Error]) ifTrue:[^ #Error].
+ ^ parser
+!
+
+parseMethodArgAndVarSpecification:aString
+ "parse a methods selector, arg and var spec;
+ return the parser or nil on error"
+
+ ^ self parseMethodArgAndVarSpecification:aString in:nil
+!
+
+parseMethodArgAndVarSpecification:aString in:aClass
+ "parse a methods selector, arg and var spec for a given class;
+ return the parser or nil on error"
+
+ |parser|
+
+ aString isNil ifTrue:[^ nil].
+ parser := self for:(ReadStream on:aString) in:aClass.
+ parser nextToken.
+ (parser parseMethodSpec == #Error) ifTrue:[^ nil].
+ (parser parseMethodBodyVarSpec == #Error) ifTrue:[^ nil].
+ parser errorFlag ifTrue:[^ nil].
+ ^ parser
+!
+
+parseMethod:aString
+ "parse a method; return parseTree"
+
+ ^ self parseMethod:aString in:nil
+!
+
+parseMethod:aString in:aClass
+ "parse a method for a given class; return parser or nil on error"
+
+ |parser tree|
+
+ aString isNil ifTrue:[^ nil].
+ parser := self for:(ReadStream on:aString) in:aClass.
+ tree := parser parseMethod.
+ (parser errorFlag or:[tree == #Error]) ifTrue:[^ nil].
+ ^ parser
+! !
+
+!Parser class methodsFor:'explaining'!
+
+explain:someText in:source forClass:aClass
+ "this is just a q&d implementation - there could be much more"
+
+ |parser variables v c string sym list count tmp|
+
+ string := someText withoutSeparators.
+ parser := self parseMethod:source in:aClass.
+ parser notNil ifTrue:[
+ "look for variables"
+
+ variables := parser methodVars.
+ (variables notNil and:[variables includes:string]) ifTrue:[
+ ^ string , ' is a method variable'
+ ].
+ variables := parser methodArgs.
+ (variables notNil and:[variables includes:string]) ifTrue:[
+ ^ string , ' is a method argument'
+ ]
+ ].
+ parser isNil ifTrue:[
+ parser := self for:(ReadStream on:source) in:aClass
+ ].
+
+ "instvars"
+ variables := aClass allInstVarNames.
+ (variables notNil and:[variables includes:string]) ifTrue:[
+ "where is it"
+ c := aClass.
+ [c notNil] whileTrue:[
+ v := c instVarNames.
+ (v notNil and:[v includes:string]) ifTrue:[
+ ^ string , ' is an instance variable in ' , c name
+ ].
+ c := c superclass
+ ].
+ self error:'oops'
+ ].
+ "class instvars"
+ variables := aClass class allInstVarNames.
+ (variables notNil and:[variables includes:string]) ifTrue:[
+ "where is it"
+ c := aClass.
+ [c notNil] whileTrue:[
+ v := c class instVarNames.
+ (v notNil and:[v includes:string]) ifTrue:[
+ ^ string , ' is a class instance variable in ' , c name
+ ].
+ c := c superclass
+ ].
+ self error:'oops'
+ ].
+ "classvars"
+ c := parser inWhichClassIsClassVar:string.
+ c notNil ifTrue:[
+ ^ string , ' is a class variable in ' , c name
+ ].
+
+ string knownAsSymbol ifTrue:[
+ "globals"
+ sym := string asSymbol.
+ (Smalltalk includesKey:sym) ifTrue:[
+ (Smalltalk at:sym) isBehavior ifTrue:[
+ ^ string , ' is a global variable.
+
+' , string , ' is a class in category ' , (Smalltalk at:sym) category , '.'
+ ] ifFalse:[
+ ^ string , ' is a global variable.
+
+Its current value is ' , (Smalltalk at:sym) classNameWithArticle , '.'
+ ]
+ ].
+
+ list := OrderedCollection new.
+ "selectors"
+ Smalltalk allClassesDo:[:c|
+ (c implements:sym) ifTrue:[
+ list add:(c name)
+ ].
+ (c class implements:sym) ifTrue:[
+ list add:(c name , 'class')
+ ]
+ ].
+ count := list size.
+ (count ~~ 0) ifTrue:[
+ tmp := ' is a selector implemented in '.
+ (count == 1) ifTrue:[
+ ^ string , tmp , (list at:1) , '.'
+ ].
+ (count == 2) ifTrue:[
+ ^ string , tmp , (list at:1) , ' and ' , (list at:2) , '.'
+ ].
+ (count == 3) ifTrue:[
+ ^ string , tmp , '
+' , (list at:1) , ', ' , (list at:2) , ' and ' , (list at:3) , '.'
+ ].
+ (count == 4) ifTrue:[
+ ^ string , tmp , '
+' , (list at:1) , ', ' , (list at:2) , ', ' , (list at:3), ' and ' , (list at:4) , '.'
+ ].
+ ^ string , tmp , count printString , ' classes.'
+ ]
+ ].
+
+ "try for some obvious things"
+ tmp := self explainPseudoVariable:string in:aClass.
+ tmp notNil ifTrue:[ ^ tmp].
+
+ "try syntax ..."
+
+ ((string = ':=') or:[string = '_']) ifTrue:[
+ ^ '<variable> := <expression>
+
+:= and _ (which is left-arrow in some fonts) mean assignment.
+The variable is bound to (i.e. points to) the value of <expression>.'
+ ].
+
+ (string = '^') ifTrue:[
+ ^ '^ <expression>
+
+return the value of <expression> as value from the method.
+A return from within a block exits the method where the block is defined.'
+ ].
+
+ (string = '|') ifTrue:[
+ ^ '| locals | or: [:arg | statements]
+
+| is used to mark a local variable declaration or separates arguments
+from the statements in a block. Notice, that in a block-argument declaration
+these must be prefixed by a colon character.
+| is also a selector understood by Booleans.'
+ ].
+
+ ((string startsWith:'(') or:[string endsWith:')']) ifTrue:[
+ ^ '(<expression>)
+
+expression grouping.'
+ ].
+
+ ((string startsWith:'[') or:[string endsWith:']']) ifTrue:[
+ ^ '[arguments | statements]
+
+defines a block.
+Blocks represent pieces of executable code. Definition of a block does
+not evaluate it. The block is evaluated by sending it a value/value:
+message.
+Blocks are often passed as arguments to Booleans (i.e. ifTrue:[...]) or
+collections (i.e. do:[...]).'
+ ].
+
+ string knownAsSymbol ifTrue:[
+ ^ string , ' is known as a symbol.
+
+Symbols are unique strings, meaning that there exists
+exactly one instance of a given symbol. Therefore symbols can
+be compared using == (identity compare) instead of = (contents compare).'
+ ].
+
+ (string startsWith:'#' ) ifTrue:[
+ (string startsWith:'#(' ) ifTrue:[
+ ^ 'is a constant Array.
+
+The elements of a constant Array must be Number-constants, nil, true or false.
+(notice, that not all smalltalk implementations allow true, false and nil as
+ constant-Array elements).'
+ ].
+
+ (string startsWith:'#[') ifTrue:[
+ ^ 'is a constant ByteArray.
+
+The elements of a constant ByteArray must be Integer constants in the range
+0 .. 255.
+(notice, that not all smalltalk implementations support constant ByteArrays).'
+ ].
+
+ ^ 'is a symbol.
+
+Symbols are unique strings, meaning that there exists
+exactly one instance of a given symbol. Therefore symbols can
+be compared using == (identity compare) instead of = (contents compare).'
+ ].
+
+ parser isNil ifTrue:[
+ ^ 'parse error -no explanation'
+ ].
+ ^ 'cannot explain this - select individual tokens for an explanation.'
+!
+
+explainPseudoVariable:string in:aClass
+ "return explanation for the pseudoVariables self, super etc."
+
+ (string = 'self') ifTrue:[
+ ^ 'self refers to the object which received the message.
+
+In this case, it will be an instance of ' , aClass name , '
+or one of its subclasses.'
+ ].
+
+ (string = 'super') ifTrue:[
+ ^ 'like self, super refers to the object which received the message.
+
+However, when sending a message to super the search for methods
+implementing this message will start in the superclass (' , aClass superclass name , ')
+instead of selfs class.'
+ ].
+
+ (string = 'true') ifTrue:[
+ ^ 'true is a pseudo variable (i.e. it is built in).
+
+True represents logical truth. It is the one and only instance of class True.'
+ ].
+
+ (string = 'thisContext') ifTrue:[
+ ^ 'thisContext is a pseudo variable (i.e. it is built in).
+
+ThisContext always refers to the context object for the currently executed Method or
+Block (an instance of Context or BlockContext respectively). The calling chain and calling
+selectors can be accessed via thisContext.'
+ ].
+
+ (string = 'false') ifTrue:[
+ ^ 'false is a pseudo variable (i.e. it is built in).
+
+False represents logical falseness. It is the one and only instance of class False.'
+ ].
+
+ (string = 'nil') ifTrue:[
+ ^ 'nil is a pseudo variable (i.e. it is built in).
+
+Nil is used for unitialized variables (among other uses).
+Nil is the one and only instance of class UndefinedObject.'
+ ].
+ ^ nil
+! !
+
+!Parser methodsFor:'ST-80 compatibility'!
+
+evaluate:aString in:aClass to:to notifying:aRequestor ifFail:failBlock
+ |parseTree|
+
+ aString isNil ifTrue:[^ nil].
+ self initializeFor:(ReadStream on:aString).
+ self setClassToCompileFor:aClass.
+ selfValue := nil.
+ requestor := aRequestor.
+
+ self nextToken.
+ parseTree := self parseMethodBody.
+ (errorFlag or:[tree == #Error]) ifTrue:[^ #Error].
+ parseTree notNil ifTrue:[
+ self evalExitBlock:[:value | ^ failBlock value].
+ ^ parseTree evaluate
+ ].
+ ^ nil
+! !
+
+!Parser class methodsFor:'changes'!
+
+update:aClass
+ "aClass has changed its definition - flush name caches if we have to"
+
+ (aClass == prevClass) ifTrue:[
+ prevClass := nil.
+ prevInstVarNames := nil.
+ prevClassVarNames := nil.
+ prevClassInstVarNames := nil.
+ aClass removeDependent:Parser
+ ]
+! !
+
+!Parser methodsFor:'setup'!
+
+setClassToCompileFor:aClass
+ "set the class to be used for parsing/evaluating"
+
+ classToCompileFor := aClass.
+ (classToCompileFor ~~ prevClass) ifTrue:[
+ prevClass notNil ifTrue:[
+ Parser update:prevClass
+ ]
+ ]
+!
+
+setSelf:anObject
+ "set the value to be used for self while evaluating"
+
+ selfValue := anObject.
+ classToCompileFor := anObject class.
+ (classToCompileFor ~~ prevClass) ifTrue:[
+ prevClass notNil ifTrue:[
+ Parser update:prevClass
+ ]
+ ]
+!
+
+setContext:aContext
+ "set the context used while evaluating"
+
+ contextToEvaluateIn := aContext
+! !
+
+!Parser methodsFor:'accessing'!
+
+tree
+ "return the parsetree"
+
+ ^tree
+!
+
+tree:aTree
+ tree := aTree
+!
+
+selector
+ "return the selector"
+
+ ^ selector
+!
+
+primitiveNumber
+ "return the primitiveNumber"
+
+ ^ primNr
+!
+
+numberOfMethodArgs
+ "return the number of methodargs"
+
+ ^ methodArgs size
+!
+
+methodArgs
+ "return an array with methodarg names"
+
+ ^ methodArgNames
+!
+
+numberOfMethodVars
+ "return the number of method variables"
+
+ ^ methodVars size
+!
+
+methodVars
+ "return a collection with method variablenames"
+
+ ^ methodVarNames
+!
+
+usedInstVars
+ "return a collection with instvariablenames refd by method"
+
+ ^ usedInstVars
+!
+
+usedClassVars
+ "return a collection with classvariablenames refd by method"
+
+ ^ usedClassVars
+!
+
+modifiedInstVars
+ "return a collection with instvariablenames modified by method"
+
+ ^ modifiedInstVars
+!
+
+modifiedClassVars
+ "return a collection with classvariablenames modified by method"
+
+ ^ modifiedClassVars
+!
+
+errorFlag
+ ^ errorFlag
+!
+
+evalExitBlock:aBlock
+ "when evaluating a return expression, this block is evaluated"
+
+ evalExitBlock := aBlock
+! !
+
+!Parser methodsFor:'error handling'!
+
+showErrorMessage:aMessage position:pos
+ Transcript show:(pos printString).
+ Transcript show:' '.
+ selector notNil ifTrue:[
+ Transcript show:aMessage.
+ Transcript showCr:(' in ' , selector)
+ ] ifFalse:[
+ Transcript showCr:aMessage
+ ]
+!
+
+parseError:aMessage position:position to:endPos
+ "report a syntax error"
+
+ |m|
+
+ errorFlag := true.
+ m := ' Error:' , aMessage.
+ self notifyError:m position:position to:endPos.
+ exitBlock notNil ifTrue:[exitBlock value].
+ ^ false
+!
+
+parseError:aMessage position:position
+ "report a syntax error"
+
+ ^ self parseError:aMessage position:position to:nil
+!
+
+parseError:aMessage
+ "report a syntax error"
+
+ ^ self parseError:aMessage position:tokenPosition to:nil
+!
+
+selectorCheck:aSelectorString position:pos to:pos2
+ aSelectorString knownAsSymbol ifFalse:[
+ self warning:(aSelectorString , ' is currently nowhere implemented')
+ position:pos to:pos2
+ ]
+!
+
+correctableError:message position:pos1 to:pos2
+ "report an error which can be corrected by compiler"
+
+ |correctIt|
+
+ requestor isNil ifTrue:[
+ self showErrorMessage:message position:pos1.
+ correctIt := false
+ ] ifFalse:[
+ correctIt := requestor correctableError:message position:pos1 to:pos2
+ ].
+ correctIt ifFalse:[
+ exitBlock notNil ifTrue:[exitBlock value]
+ ].
+ ^ correctIt
+!
+
+undefError:aName position:pos1 to:pos2
+ "report an undefined variable error"
+
+ ^ self correctableError:('Error: ' , aName , ' is undefined')
+ position:pos1 to:pos2
+!
+
+exitWith:something
+ "this is the longjump out of evaluation via a return expression"
+
+ evalExitBlock value:something
+! !
+
+!Parser methodsFor:'parsing'!
+
+parseMethod
+ "parse a method"
+
+ |parseTree|
+
+ self nextToken.
+ (self parseMethodSpec == #Error) ifTrue:[^ #Error].
+ parseTree := self parseMethodBody.
+ (parseTree == #Error) ifFalse:[
+ self tree:parseTree
+ ].
+ ^ parseTree
+!
+
+parseMethodSpec
+ "parse a methods selector & arg specification;
+ set selector and methodArgs as a side effect"
+
+ |var|
+
+ (tokenType == #Keyword) ifTrue:[
+ selector := ''.
+ [tokenType == #Keyword] whileTrue:[
+ selector := selector , tokenName.
+ self nextToken.
+ (tokenType ~~ #Identifier) ifTrue:[^ #Error].
+ var := Variable name:tokenName.
+ methodArgs isNil ifTrue:[
+ methodArgs := Array with:var.
+ methodArgNames := Array with:tokenName
+ ] ifFalse:[
+ methodArgs := methodArgs copyWith:var.
+ methodArgNames := methodArgNames copyWith:tokenName
+ ].
+ self nextToken
+ ].
+ selector := selector asSymbol.
+ ^ self
+ ].
+ (tokenType == #Identifier) ifTrue:[
+ selector := tokenName asSymbol.
+ self nextToken.
+ ^ self
+ ].
+ (tokenType == #BinaryOperator) ifTrue:[
+ selector := tokenName asSymbol.
+ self nextToken.
+ (tokenType ~~ #Identifier) ifTrue:[^ #Error].
+ var := Variable name:tokenName.
+ methodArgs isNil ifTrue:[
+ methodArgs := Array with:var.
+ methodArgNames := Array with:tokenName
+ ] ifFalse:[
+ methodArgs := methodArgs copyWith:var.
+ methodArgNames := methodArgNames copyWith:tokenName
+ ].
+ self nextToken.
+ ^ self
+ ].
+ ^ #Error
+!
+
+parseMethodBodyOrNil
+ "parse a methods body (locals & statements);
+ return a node-tree, nil or #Error. empty (or comment only) input
+ is accepted and returns nil"
+
+ |stats|
+
+ ((tokenType == #BinaryOperator) and:[tokenName = '<']) ifTrue:[
+ "an ST-80 primitive - parsed but ignored"
+ self nextToken.
+ primNr := self parsePrimitive.
+ (primNr == #Error) ifTrue:[^ #Error].
+ self warning:'ST-80 primitives not supported - ignored'
+ ].
+
+ (self parseMethodBodyVarSpec == #Error) ifTrue:[^ #Error].
+
+ (tokenType ~~ #EOF) ifTrue:[
+ stats := self statementList
+ ].
+ ^ stats
+!
+
+parseMethodBody
+ "parse a methods body (locals & statements); no more token may follow
+ return a node-tree, nil or #Error"
+
+ |stats|
+
+ stats := self parseMethodBodyOrNil.
+ (stats == #Error) ifFalse:[
+ (tokenType ~~ #EOF) ifTrue:[
+ self parseError:(tokenType printString , ' unexpected').
+ ^#Error
+ ]
+ ].
+ ^ stats
+!
+
+parseMethodBodyVarSpec
+ "parse a methods local variable specification"
+
+ |var|
+
+ (tokenType == $|) ifTrue:[
+ "memorize position for declaration in correction"
+ localVarDefPosition := tokenPosition.
+ self nextToken.
+ [tokenType == #Identifier] whileTrue:[
+ var := Variable name:tokenName.
+ methodVars isNil ifTrue:[
+ methodVars := Array with:var.
+ methodVarNames := Array with:tokenName
+ ] ifFalse:[
+ methodVars := methodVars copyWith:var.
+ methodVarNames := methodVarNames copyWith:tokenName
+ ].
+ self nextToken
+ ].
+ (tokenType ~~ $|) ifTrue:[
+ self syntaxError:'error in local var specification; | expected.'.
+ ^ #Error
+ ].
+ self nextToken
+ ].
+ ^ nil
+!
+
+parsePrimitive
+ "parse an ST-80 type primitive;
+ return primitive number or #Error"
+
+ |primNumber|
+
+ ((tokenType == #Keyword) and:[tokenName = 'primitive:']) ifFalse:[
+ self parseError:'bad primitive definition (primitive: expected)'.
+ ^ #Error
+ ].
+ self nextToken.
+ (tokenType == #Integer) ifFalse:[
+ self parseError:'primitive number expected'.
+ ^ #Error
+ ].
+ primNumber := tokenValue.
+ self nextToken.
+ ((tokenType == #BinaryOperator) and:[tokenName = '>']) ifFalse:[
+ self parseError:'bad primitive definition (> expected)'.
+ ^ #Error
+ ].
+ self nextToken.
+ ^ primNumber
+!
+
+statementList
+ "parse a statementlist; return a node-tree, nil or #Error.
+ Statements must be separated by periods."
+
+ |thisStatement prevStatement firstStatement correctIt periodPos|
+
+ thisStatement := self statement.
+ (thisStatement == #Error) ifTrue:[^ #Error].
+ firstStatement := thisStatement.
+ [tokenType == $.] whileTrue:[
+ periodPos := tokenPosition.
+ self nextToken.
+ (tokenType == $]) ifTrue:[
+ currentBlock isNil ifTrue:[
+ self parseError:'block nesting error'.
+ errorFlag := true
+"
+ *** I had a warning here (since it was not defined
+ *** in the blue-book; but PD-code contains a lot of
+ *** code with periods at the end so that the warnings
+ *** became annoying
+
+ ] ifFalse:[
+ self warning:'period after last statement' position:periodPos
+"
+ ].
+ ^ firstStatement
+ ].
+ (tokenType == #EOF) ifTrue:[
+ currentBlock notNil ifTrue:[
+ self parseError:'block nesting error'.
+ errorFlag := true
+"
+ *** I had a warning here (since it was not defined
+ *** in the blue-book; but PD-code contains a lot of
+ *** code with periods at the end so that the warnings
+ *** became annoying
+
+ ] ifFalse:[
+ self warning:'period after last statement' position:periodPos
+"
+ ].
+ ^ firstStatement
+ ].
+
+ prevStatement := thisStatement.
+ (prevStatement isKindOf:ReturnNode) ifTrue:[
+ self warning:'statements after return' position:tokenPosition
+ ].
+"
+ periodPos := tokenPosition.
+ self nextToken.
+"
+
+ ((tokenType == $]) or:[tokenType == #EOF]) ifTrue:[
+ (currentBlock isNil and:[tokenType == $]]) ifTrue:[
+ self parseError:'block nesting error'.
+ errorFlag := true
+ ] ifFalse:[
+ correctIt := self correctableError:'period after last statement in block'
+ position:periodPos to:(periodPos + 1).
+ correctIt ifTrue:[
+ (self correctByDeleting == #Error) ifTrue:[
+ errorFlag := true
+ ]
+ ]
+ ].
+ ^ firstStatement
+ ].
+ thisStatement := self statement.
+ (thisStatement == #Error) ifTrue:[^ #Error].
+ prevStatement nextStatement:thisStatement
+ ].
+ ^ firstStatement
+!
+
+statement
+ "parse a statement; return a node-tree, nil or #Error"
+
+ |expr node|
+
+ (tokenType == $^) ifTrue:[
+ self nextToken.
+ expr := self expression.
+ (expr == #Error) ifTrue:[^ #Error].
+ node := ReturnNode expression:expr.
+ node home:self blockHome:currentBlock.
+ ^ node
+ ].
+ (tokenType == #Primitive) ifTrue:[
+ self parseError:'cannot compile primitives (yet)'.
+ self nextToken.
+ ^ PrimitiveNode code:''
+ ].
+ (tokenType == #EOF) ifTrue:[
+ self syntaxError:'period after last statement'.
+ ^ #Error
+ ].
+ expr := self expression.
+"
+ classToCompileFor notNil ifTrue:[
+ currentBlock isNil ifTrue:[
+ (expr isKindOf:PrimaryNode) ifTrue:[
+ self warning:'useless computation - missing ^ ?'
+ ]
+ ]
+ ].
+"
+ (expr == #Error) ifTrue:[^ #Error].
+ ^ StatementNode expression:expr
+!
+
+expression
+ "parse a cascade-expression; return a node-tree, nil or #Error"
+
+ |receiver arg sel args pos pos2|
+
+ receiver := self keywordExpression.
+ (receiver == #Error) ifTrue:[^ #Error].
+ [tokenType == $;] whileTrue:[
+ self nextToken.
+ (tokenType == #Identifier) ifTrue:[
+ sel := tokenName.
+ self selectorCheck:sel position:tokenPosition
+ to:(tokenPosition + sel size - 1).
+ receiver := CascadeNode receiver:receiver
+ selector:sel.
+ self nextToken
+ ] ifFalse:[
+ (tokenType == #BinaryOperator) ifTrue:[
+ sel := tokenName.
+ self selectorCheck:sel position:tokenPosition
+ to:(tokenPosition + sel size - 1).
+ self nextToken.
+ arg := self unaryExpression.
+ (arg == #Error) ifTrue:[^ #Error].
+ receiver := CascadeNode receiver:receiver
+ selector:sel
+ arg:arg
+ ] ifFalse:[
+ (tokenType == #Keyword) ifTrue:[
+ pos := tokenPosition.
+ sel := tokenName.
+ self nextToken.
+ arg := self binaryExpression.
+ (arg == #Error) ifTrue:[^ #Error].
+ args := Array with:arg.
+ [tokenType == #Keyword] whileTrue:[
+ sel := sel , tokenName.
+ self nextToken.
+ arg := self binaryExpression.
+ (arg == #Error) ifTrue:[^ #Error].
+ args := args copyWith:arg.
+ pos2 := tokenPosition
+ ].
+ self selectorCheck:sel position:pos to:pos2.
+ receiver := CascadeNode receiver:receiver
+ selector:sel
+ args:args
+ ] ifFalse:[
+ (tokenType == #Error) ifTrue:[^ #Error].
+ self syntaxError:('invalid cascade; '
+ , tokenType printString
+ , ' unexpected').
+ ^ #Error
+ ]
+ ]
+ ]
+ ].
+ ^ receiver
+!
+
+keywordExpression
+ "parse a keyword-expression; return a node-tree, nil or #Error"
+
+ |receiver sel arg args pos1 pos2 try lno|
+
+ receiver := self binaryExpression.
+ (receiver == #Error) ifTrue:[^ #Error].
+ (tokenType == #Keyword) ifTrue:[
+ pos1 := tokenPosition.
+ sel := tokenName.
+ lno := tokenLineNr.
+ self nextToken.
+ arg := self binaryExpression.
+ (arg == #Error) ifTrue:[^ #Error].
+ args := Array with:arg.
+ [tokenType == #Keyword] whileTrue:[
+ sel := sel , tokenName.
+ self nextToken.
+ arg := self binaryExpression.
+ (arg == #Error) ifTrue:[^ #Error].
+ args := args copyWith:arg.
+ pos2 := tokenPosition
+ ].
+ self selectorCheck:sel position:pos1 to:pos2.
+ try := MessageNode receiver:receiver selector:sel args:args.
+ (try isMemberOf:String) ifTrue:[
+ self parseError:try position:pos1 to:pos2.
+ receiver := MessageNode receiver:receiver selector:sel args:args
+ fold:false
+ ] ifFalse:[
+ receiver := try
+ ].
+ receiver lineNumber:lno
+ ].
+ ^ receiver
+!
+
+binaryExpression
+ "parse a binary-expression; return a node-tree, nil or #Error"
+
+ |receiver arg sel pos try lno note|
+
+ receiver := self unaryExpression.
+ (receiver == #Error) ifTrue:[^ #Error].
+
+ "special kludge: since Scanner cannot know if -digit is a binary
+ expression or a negative constant, handle cases here"
+
+ [(tokenType == #BinaryOperator) or:[(tokenType == $|)
+ or:[(tokenType == #Integer) and:[tokenValue < 0]]]] whileTrue:[
+ pos := tokenPosition.
+
+ lno := tokenLineNr.
+
+ "kludge here: bar and minus are not scanned as binop "
+ (tokenType == $|) ifTrue:[
+ sel := '|'.
+ self nextToken
+ ] ifFalse:[
+ (tokenType == #BinaryOperator) ifTrue:[
+ sel := tokenName.
+ self selectorCheck:sel position:tokenPosition
+ to:(tokenPosition + sel size - 1).
+ self nextToken
+ ] ifFalse:[
+ sel := '-'.
+ tokenValue := tokenValue negated
+ ]
+ ].
+ arg := self unaryExpression.
+ (arg == #Error) ifTrue:[^ #Error].
+ try := BinaryNode receiver:receiver selector:sel arg:arg.
+ (try isMemberOf:String) ifTrue:[
+ self parseError:try position:pos to:tokenPosition.
+ receiver := BinaryNode receiver:receiver selector:sel arg:arg
+ fold:false
+ ] ifFalse:[
+ receiver := try
+ ].
+ note := receiver plausibilityCheck.
+ note notNil ifTrue:[
+ self warning:note position:pos to:tokenPosition
+ ].
+ receiver lineNumber:lno
+ ].
+ ^ receiver
+!
+
+unaryExpression
+ "parse a unary-expression; return a node-tree, nil or #Error"
+
+ |receiver sel pos try|
+
+ receiver := self primary.
+ (receiver == #Error) ifTrue:[^ #Error].
+ [tokenType == #Identifier] whileTrue:[
+ pos := tokenPosition.
+ sel := tokenName.
+ self selectorCheck:sel position:tokenPosition
+ to:(tokenPosition + sel size - 1).
+ try := UnaryNode receiver:receiver selector:sel.
+ (try isMemberOf:String) ifTrue:[
+ self warning:try position:pos to:(tokenPosition + sel size - 1).
+ receiver := UnaryNode receiver:receiver selector:sel fold:false
+ ] ifFalse:[
+ receiver := try
+ ].
+ receiver lineNumber:tokenLineNr.
+ self nextToken.
+ ].
+ ^ receiver
+!
+
+primary
+ "parse a primary-expression; return a node-tree, nil or #Error"
+
+ |val var expr pos name|
+
+ pos := tokenPosition.
+ (tokenType == #Identifier) ifTrue:[
+ var := self variable.
+ (var == #Error) ifTrue:[
+ errorFlag := true
+ ].
+ self nextToken.
+ (tokenType == $_) ifFalse:[
+ ^ var
+ ].
+ (var ~~ #Error) ifTrue:[
+ (var type == #MethodArg) ifTrue:[
+ self parseError:'assignment to method argument' position:pos to:tokenPosition.
+ errorFlag := true
+ ].
+ (var type == #BlockArg) ifTrue:[
+ self parseError:'assignment to block argument' position:pos to:tokenPosition.
+ errorFlag := true
+ ].
+
+ (var type == #InstanceVariable) ifTrue:[
+ modifiedInstVars isNil ifTrue:[
+ modifiedInstVars := OrderedCollection new
+ ].
+ name := prevInstVarNames at:(var index).
+ (modifiedInstVars includes:name) ifFalse:[
+ modifiedInstVars add:name
+ ]
+ ] ifFalse:[
+ (var type == #ClassVariable) ifTrue:[
+ modifiedClassVars isNil ifTrue:[
+ modifiedClassVars := OrderedCollection new
+ ].
+ name := var name.
+ name := name copyFrom:((name indexOf:$:) + 1).
+ (modifiedClassVars includes:name) ifFalse:[
+ modifiedClassVars add:name
+ ]
+ ]
+ ]
+ ].
+
+ self nextToken.
+ expr := self expression.
+ (errorFlag or:[expr == #Error]) ifTrue:[^ #Error].
+ ^ AssignmentNode variable:var expression:expr
+ ].
+ ((tokenType == #Integer) or:
+ [(tokenType == #Character) or:
+ [tokenType == #Float]]) ifTrue:[
+ val := ConstantNode type:tokenType value:tokenValue.
+ self nextToken.
+ (tokenType == $_) ifTrue:[
+ self parseError:'assignment to a constant' position:pos to:tokenPosition.
+ ^ #Error
+ ].
+ ^ val
+ ].
+ (tokenType == #String) ifTrue:[
+ val := ConstantNode type:tokenType value:tokenValue.
+ self nextToken.
+ (tokenType == $_) ifTrue:[
+ self parseError:'assignment to a constant' position:pos to:tokenPosition.
+ ^ #Error
+ ].
+ ^ val
+ ].
+ (tokenType == #Symbol) ifTrue:[
+ val := ConstantNode type:tokenType value:tokenValue.
+ self nextToken.
+ (tokenType == $_) ifTrue:[
+ self parseError:'assignment to a constant' position:pos to:tokenPosition.
+ ^ #Error
+ ].
+ ^ val
+ ].
+ (tokenType == #Nil) ifTrue:[
+ self nextToken.
+ (tokenType == $_) ifTrue:[
+ self parseError:'assignment to nil' position:pos to:tokenPosition.
+ ^ #Error
+ ].
+ ^ ConstantNode type:#Nil value:nil
+ ].
+ (tokenType == #True) ifTrue:[
+ self nextToken.
+ (tokenType == $_) ifTrue:[
+ self parseError:'assignment to true' position:pos to:tokenPosition.
+ ^ #Error
+ ].
+ ^ ConstantNode type:#True value:true
+ ].
+ (tokenType == #False) ifTrue:[
+ self nextToken.
+ (tokenType == $_) ifTrue:[
+ self parseError:'assignment to false' position:pos to:tokenPosition.
+ ^ #Error
+ ].
+ ^ ConstantNode type:#False value:false
+ ].
+ (tokenType == #Self) ifTrue:[
+ self nextToken.
+ (tokenType == $_) ifTrue:[
+ self parseError:'assignment to self' position:pos to:tokenPosition.
+ ^ #Error
+ ].
+ selfNode isNil ifTrue:[
+ selfNode := PrimaryNode type:#Self value:selfValue
+ ].
+ ^ selfNode
+ ].
+ (tokenType == #Super) ifTrue:[
+ self nextToken.
+ (tokenType == $_) ifTrue:[
+ self parseError:'assignment to super' position:pos to:tokenPosition.
+ ^ #Error
+ ].
+ superNode isNil ifTrue:[
+ superNode := PrimaryNode type:#Super value:selfValue
+ ].
+ ^ superNode
+ ].
+ (tokenType == #ThisContext) ifTrue:[
+ self nextToken.
+ (tokenType == $_) ifTrue:[
+ self parseError:'assignment to thisContext' position:pos to:tokenPosition.
+ ^ #Error
+ ].
+ ^ PrimaryNode type:#ThisContext value:nil
+ ].
+ (tokenType == #HashLeftParen) ifTrue:[
+ self nextToken.
+ val := self array.
+ self nextToken.
+ ^ ConstantNode type:#Array value:val
+ ].
+ (tokenType == #HashLeftBrack) ifTrue:[
+ self nextToken.
+ val := self byteArray.
+ self nextToken.
+ ^ ConstantNode type:#Array value:val
+ ].
+ (tokenType == $() ifTrue:[
+ self nextToken.
+ val := self expression.
+ (val == #Error) ifTrue:[^ #Error].
+ (tokenType ~~ $) ) ifTrue:[
+ (tokenType isMemberOf:Character) ifTrue:[
+ self syntaxError:'missing '')'' (i.e. ''' , tokenType asString , ''' unexpected)' withCRs position:pos to:tokenPosition.
+ ] ifFalse:[
+ self syntaxError:'missing '')''' position:pos to:tokenPosition.
+ ].
+ ^ #Error
+ ].
+ self nextToken.
+ ^ val
+ ].
+ (tokenType == $[ ) ifTrue:[
+ val := self block.
+ self nextToken.
+ ^ val
+ ].
+ (tokenType == #Error) ifTrue:[^ #Error].
+ (tokenType isKindOf:Character) ifTrue:[
+ self syntaxError:('error in primary; '
+ , tokenType printString ,
+ ' unexpected') position:tokenPosition to:tokenPosition
+ ] ifFalse:[
+ self syntaxError:('error in primary; '
+ , tokenType printString ,
+ ' unexpected')
+ ].
+ ^ #Error
+!
+
+variableOrError
+ "parse a variable; return a node-tree, nil or #Error"
+
+ |tokenFound var instIndex aClass searchBlock args vars
+ varName tokenSymbol theBlock className
+ runIndex "{ Class: SmallInteger }" |
+
+ varName := tokenName.
+
+ "is it a block-arg or block-var ?"
+ searchBlock := currentBlock.
+ [searchBlock notNil] whileTrue:[
+ runIndex := 1.
+ args := searchBlock arguments.
+ args notNil ifTrue:[
+ args do:[:aBlockArg |
+ (aBlockArg name = varName) ifTrue:[
+ tokenFound := aBlockArg.
+ instIndex := runIndex.
+ theBlock := searchBlock
+ ].
+ runIndex := runIndex + 1
+ ].
+ tokenFound notNil ifTrue:[
+ ^ PrimaryNode type:#BlockArg
+ name:varName
+ token:tokenFound
+ index:instIndex
+ block:theBlock
+ ]
+ ].
+
+ runIndex := 1.
+ vars := searchBlock variables.
+ vars notNil ifTrue:[
+ vars do:[:aBlockVar |
+ (aBlockVar name = varName) ifTrue:[
+ tokenFound := aBlockVar.
+ instIndex := runIndex.
+ theBlock := searchBlock
+ ].
+ runIndex := runIndex + 1
+ ].
+ tokenFound notNil ifTrue:[
+ ^ PrimaryNode type:#BlockVariable
+ name:varName
+ token:tokenFound
+ index:instIndex
+ block:theBlock
+ ]
+ ].
+ searchBlock := searchBlock home
+ ].
+
+ "is it a method-variable ?"
+ methodVars notNil ifTrue:[
+ instIndex := methodVarNames indexOf:varName.
+ (instIndex ~~ 0) ifTrue:[
+ var := methodVars at:instIndex.
+ var used:true.
+ ^ PrimaryNode type:#MethodVariable
+ name:varName
+ token:var
+ index:instIndex
+ ]
+ ].
+
+ "is it a method-argument ?"
+ methodArgs notNil ifTrue:[
+ instIndex := methodArgNames indexOf:varName.
+ (instIndex ~~ 0) ifTrue:[
+ ^ PrimaryNode type:#MethodArg
+ name:varName
+ token:(methodArgs at:instIndex)
+ index:instIndex
+ ]
+ ].
+
+ "is it an instance-variable ?"
+ classToCompileFor notNil ifTrue:[
+ "caching allInstVarNames for next compilation saves time ..."
+
+ (prevInstVarNames isNil or:[prevClass ~~ classToCompileFor]) ifTrue:[
+ prevClass notNil ifTrue:[
+ prevClass removeDependent:Parser
+ ].
+ prevClass := classToCompileFor.
+ prevInstVarNames := classToCompileFor allInstVarNames.
+ prevClassInstVarNames := nil.
+ prevClassVarNames := nil.
+ prevClass addDependent:Parser
+ ].
+
+ instIndex := prevInstVarNames indexOf:varName startingAt:1
+ ifAbsent:[nil].
+ instIndex notNil ifTrue:[
+ usedInstVars isNil ifTrue:[
+ usedInstVars := OrderedCollection new
+ ].
+ (usedInstVars includes:varName) ifFalse:[
+ usedInstVars add:varName
+ ].
+ ^ PrimaryNode type:#InstanceVariable
+ name:varName
+ index:instIndex
+ selfValue:selfValue
+ ]
+ ].
+
+ "is it a class-instance-variable ?"
+ classToCompileFor notNil ifTrue:[
+ prevClassInstVarNames isNil ifTrue:[
+ prevClassInstVarNames := classToCompileFor class allInstVarNames
+ ].
+
+ instIndex := prevClassInstVarNames indexOf:varName startingAt:1
+ ifAbsent:[nil].
+
+ instIndex notNil ifTrue:[
+ aClass := self inWhichClassIsClassInstVar:varName.
+ aClass notNil ifTrue:[
+ ^ PrimaryNode type:#ClassInstanceVariable
+ name:varName
+ index:instIndex
+ selfValue:selfValue
+ ]
+ ]
+ ].
+
+ "is it a class-variable ?"
+ classToCompileFor notNil ifTrue:[
+ prevClassVarNames isNil ifTrue:[
+ aClass := classToCompileFor.
+ classToCompileFor isMeta ifTrue:[
+ className := aClass name.
+ className := className copyFrom:1 to:(className size - 5).
+ aClass := Smalltalk at:(className asSymbol).
+ aClass isNil ifTrue:[
+ aClass := classToCompileFor
+ ]
+ ].
+ prevClassVarNames := aClass allClassVarNames
+ ].
+
+ instIndex := prevClassVarNames indexOf:varName startingAt:1
+ ifAbsent:[nil].
+
+ instIndex notNil ifTrue:[
+ aClass := self inWhichClassIsClassVar:varName.
+ aClass notNil ifTrue:[
+ usedClassVars isNil ifTrue:[
+ usedClassVars := OrderedCollection new
+ ].
+ (usedClassVars includes:varName) ifFalse:[
+ usedClassVars add:varName
+ ].
+ ^ PrimaryNode type:#ClassVariable
+ name:(aClass name , ':' , varName) asSymbol
+ ]
+ ]
+ ].
+
+ "is it a global-variable ?"
+ tokenSymbol := varName asSymbol.
+ (Smalltalk includesKey:tokenSymbol) ifTrue:[
+ ^ PrimaryNode type:#GlobalVariable
+ name:tokenSymbol
+ ].
+ ^ #Error
+!
+
+variable
+ "parse a variable; if undefined, notify error and correct if user wants to"
+
+ |v|
+
+ v := self variableOrError.
+ (v == #Error) ifFalse:[^ v].
+ v := self correctVariable.
+ (v == #Error) ifFalse:[^ v].
+ ^ PrimaryNode type:#GlobalVariable
+ name:tokenName asSymbol
+!
+
+inWhichClassIsClassVar:aString
+ "search class-chain for the classvariable named aString
+ - return the class or nil if not found"
+
+ |aClass className baseClass|
+
+ aClass := classToCompileFor.
+ aClass isMeta ifTrue:[
+ className := aClass name.
+ className := className copyFrom:1 to:(className size - 5).
+ baseClass := Smalltalk at:(className asSymbol).
+ baseClass notNil ifTrue:[
+ aClass := baseClass
+ ]
+ ].
+ [aClass notNil] whileTrue:[
+ (aClass classVarNames includes:aString) ifTrue:[ ^ aClass].
+ aClass := aClass superclass
+ ].
+ ^ nil
+!
+
+inWhichClassIsClassInstVar:aString
+ "search class-chain for the class-instance variable named aString
+ - return the class or nil if not found"
+
+ |aClass|
+
+ aClass := classToCompileFor.
+ [aClass notNil] whileTrue:[
+ (aClass class instVarNames includes:aString) ifTrue:[ ^ aClass].
+ aClass := aClass superclass
+ ].
+ ^ nil
+!
+
+block
+ "parse a block; return a node-tree, nil or #Error"
+
+ |stats node args var vars pos|
+
+ self nextToken.
+ (tokenType == $: ) ifTrue:[
+ [tokenType == $:] whileTrue:[
+ pos := tokenPosition.
+ self nextToken.
+ (tokenType == #Identifier) ifFalse:[
+ self syntaxError:'Identifier expected in block-arg declaration'
+ position:pos to:tokenPosition-1.
+ ^ #Error
+ ].
+ var := Variable name:tokenName.
+ args isNil ifTrue:[
+ args := Array with:var
+ ] ifFalse:[
+ args := args copyWith:var
+ ].
+ self nextToken
+ ].
+ (tokenType ~~ $| ) ifTrue:[
+ "ST-80 allows [:arg ]"
+ (tokenType == $] ) ifTrue:[
+ node := BlockNode arguments:args.
+ node home:currentBlock.
+ ^ node
+ ].
+ self syntaxError:'| expected after block-arg declaration'.
+ ^ #Error
+ ].
+ self nextToken
+ ].
+ (tokenType == $| ) ifTrue:[
+ self nextToken.
+ pos := tokenPosition.
+ [tokenType == $|] whileFalse:[
+ (tokenType == #Identifier) ifFalse:[
+ self syntaxError:'Identifier expected in block-var declaration' position:pos.
+ ^ #Error
+ ].
+ var := Variable name:tokenName.
+ vars isNil ifTrue:[
+ vars := Array with:var
+ ] ifFalse:[
+ vars := vars copyWith:var
+ ].
+ self nextToken
+ ].
+ self nextToken
+ ].
+ node := BlockNode arguments:args.
+ node home:currentBlock.
+ node variables:vars.
+ currentBlock := node.
+ stats := self blockStatementList.
+ node statements:stats.
+ currentBlock := node home.
+ (stats == #Error) ifTrue:[^ #Error].
+ ^ node
+!
+
+blockStatementList
+ "parse a blocks statementlist; return a node-tree, nil or #Error"
+
+ |thisStatement prevStatement firstStatement|
+
+ (tokenType == $] ) ifTrue:[^ nil].
+ thisStatement := self statement.
+ (thisStatement == #Error) ifTrue:[^ #Error].
+ firstStatement := thisStatement.
+ [tokenType == $] ] whileFalse:[
+ (tokenType == $.) ifFalse:[
+ (tokenType == #EOF) ifTrue:[
+ self syntaxError:'missing '']'' in block'
+ ] ifFalse:[
+ self syntaxError:'missing ''.'' in block'
+ ].
+ ^ #Error
+ ] ifTrue:[
+ prevStatement := thisStatement.
+ self nextToken.
+ tokenType == $] ifTrue:[
+"
+ *** I had a warning here (since it was not defined
+ *** in the blue-book; but PD-code contains a lot of
+ *** code with periods at the end so that the warnings
+ *** became annoying
+
+ self warning:'period after last statement in block'.
+"
+ ^ firstStatement
+ ].
+ thisStatement := self statement.
+ (thisStatement == #Error) ifTrue:[^ #Error].
+ prevStatement nextStatement:thisStatement
+ ]
+ ].
+ ^ firstStatement
+!
+
+array
+ |arr elem pos1 pos2|
+
+ pos1 := tokenPosition.
+ arr := OrderedCollection new:200.
+ [tokenType ~~ $) ] whileTrue:[
+ elem := self arrayConstant.
+ (elem == #Error) ifTrue:[
+ (tokenType == #EOF) ifTrue:[
+ self syntaxError:'unterminated array-constant; '')'' expected'
+ position:pos1 to:tokenPosition
+ ].
+ ^ #Error
+ ].
+ arr add:elem.
+ self nextToken
+ ].
+ ^ Array withAll:arr
+!
+
+byteArray
+ "for ST-80 R4 - allow byteArray constants"
+ |arr elem pos1 pos2|
+
+ pos1 := tokenPosition.
+ arr := OrderedCollection new.
+ [tokenType ~~ $] ] whileTrue:[
+ pos2 := tokenPosition.
+ elem := self arrayConstant.
+ (elem == #Error) ifTrue:[
+ (tokenType == #EOF) ifTrue:[
+ self syntaxError:'unterminated bytearray-constant; '']'' expected'
+ position:pos1 to:tokenPosition
+ ].
+ ^ #Error
+ ].
+ ((elem isMemberOf:SmallInteger) and:
+ [(elem >= 0) and:[elem <= 255]]) ifTrue:[
+ arr add:elem
+ ] ifFalse:[
+ self parseError:'invalid ByteArray element' position:pos2 to:tokenPosition - 1
+ ].
+ self nextToken
+ ].
+ ^ ByteArray withAll:arr
+!
+
+arrayConstant
+ (tokenType == #String) ifTrue:[
+ ^ tokenValue
+ ].
+ (tokenType == #Nil) ifTrue:[
+ ^ nil
+ ].
+ (tokenType == #Integer) ifTrue:[
+ ^ tokenValue
+ ].
+ (tokenType == #Character) ifTrue:[
+ ^ tokenValue
+ ].
+ (tokenType == #Float) ifTrue:[
+ ^ tokenValue
+ ].
+ (tokenType == #True) ifTrue:[
+ ^ true
+ ].
+ (tokenType == #False) ifTrue:[
+ ^ false
+ ].
+ (tokenType == #Error) ifTrue:[
+ ^ #Error
+ ].
+ (tokenType == #BinaryOperator) ifTrue:[
+ ^ tokenName asSymbol
+ ].
+ (tokenType == #Keyword) ifTrue:[
+ ^ tokenName asSymbol
+ ].
+ (tokenType == #Identifier) ifTrue:[
+ ^ tokenName asSymbol
+ ].
+ (tokenType == $() ifTrue:[
+ self nextToken.
+ ^ self array
+ ].
+ (tokenType == $[) ifTrue:[
+ self nextToken.
+ ^ self byteArray
+ ].
+ (tokenType == #Symbol) ifTrue:[
+"
+ self warning:'no # for symbols within array-constants'.
+"
+ ^ tokenValue
+ ].
+ (tokenType == #HashLeftParen) ifTrue:[
+"
+ self warning:'no # for arrays within array-constants'.
+"
+ self nextToken.
+ ^ self array
+ ].
+ (tokenType == #HashLeftBrack) ifTrue:[
+"
+ self warning:'no # for arrays within array-constants'.
+"
+ self nextToken.
+ ^ self byteArray
+ ].
+ (tokenType == #EOF) ifTrue:[
+ "just for the better error-hilight; let caller handle error"
+ ^ #Error
+ ].
+ self syntaxError:('error in array-constant; '
+ , tokenType printString
+ , ' unexpected').
+ ^ #Error
+! !
+
+!Parser methodsFor:'error correction'!
+
+correctByDeleting
+ "correct (by deleting token) if user wants to;
+ return #Error if there was no correction or nil"
+
+ (self confirm:'confirm deleting') ifFalse:[^ #Error].
+
+ "tell requestor about the change"
+ requestor deleteSelection.
+ ^ nil
+!
+
+findBestVariableFor:aString
+ "collect known variables with their levenshtein distances to aString;
+ return the 10 best suggestions"
+
+ |names dists searchBlock args vars globalVarName aClass className baseClass n|
+
+ names := VariableArray new.
+ dists := VariableArray new.
+
+ "block arguments"
+ searchBlock := currentBlock.
+ [searchBlock notNil] whileTrue:[
+ args := searchBlock arguments.
+ args notNil ifTrue:[
+ args do:[:aBlockArg |
+ names add:(aBlockArg name).
+ dists add:(aString levenshteinTo:(aBlockArg name))
+ ]
+ ].
+
+ vars := searchBlock variables.
+ vars notNil ifTrue:[
+ vars do:[:aBlockVar |
+ names add:(aBlockVar name).
+ dists add:(aString levenshteinTo:(aBlockVar name))
+ ]
+ ].
+ searchBlock := searchBlock home
+ ].
+
+ "method-variables"
+ methodVars notNil ifTrue:[
+ methodVarNames do:[:methodVarName |
+ names add:methodVarName.
+ dists add:(aString levenshteinTo:methodVarName)
+ ]
+ ].
+
+ "method-arguments"
+ methodArgs notNil ifTrue:[
+ methodArgNames do:[:methodArgName |
+ names add:methodArgName.
+ dists add:(aString levenshteinTo:methodArgName)
+ ]
+ ].
+
+ "instance-variables"
+ classToCompileFor notNil ifTrue:[
+ prevInstVarNames do:[:instVarName |
+ names add:instVarName.
+ dists add:(aString levenshteinTo:instVarName)
+ ]
+ ].
+
+ "class-variables"
+ classToCompileFor notNil ifTrue:[
+ aClass := classToCompileFor.
+ aClass isMeta ifTrue:[
+ className := aClass name.
+ className := className copyFrom:1 to:(className size - 5).
+ baseClass := Smalltalk at:(className asSymbol).
+ baseClass notNil ifTrue:[
+ aClass := baseClass
+ ]
+ ].
+ [aClass notNil] whileTrue:[
+ (aClass classVarNames) do:[:classVarName |
+ names add:classVarName.
+ dists add:(aString levenshteinTo:classVarName)
+ ].
+ aClass := aClass superclass
+ ]
+ ].
+
+ "globals"
+ Smalltalk allKeysDo:[:aKey |
+ globalVarName := aKey asString.
+ "only compare strings where length is about right"
+ ((globalVarName size - aString size) abs < 3) ifTrue:[
+ names add:globalVarName.
+ dists add:(aString levenshteinTo:globalVarName)
+ ]
+ ].
+
+ "misc"
+ #('self' 'super' 'nil') do:[:name |
+ "only compare strings where length is about right"
+ ((name size - aString size) abs < 3) ifTrue:[
+ names add:name.
+ dists add:(aString levenshteinTo:name)
+ ]
+ ].
+
+ (dists size ~~ 0) ifTrue:[
+ dists sortWith:names.
+ n := names size min:10.
+ ^ names copyFrom:1 to:n
+ ].
+ ^ nil
+!
+
+correctVariable
+ "notify error and correct if user wants to;
+ return #Error if there was no correction
+ or a ParseNode as returned by variable"
+
+ |correctIt varName suggestedNames newName pos1 pos2|
+
+ pos1 := tokenPosition.
+ varName := tokenName.
+ pos2 := pos1 + varName size - 1.
+ (varName at:1) isLowercase ifTrue:[
+ correctIt := self undefError:varName position:pos1 to:pos2.
+ correctIt ifFalse:[^ #Error]
+ ] ifFalse:[
+ correctIt := self warning:(varName , ' is undefined') position:pos1 to:pos2.
+ correctIt ifFalse:[
+ ^ PrimaryNode type:#GlobalVariable
+ name:(varName asSymbol)
+ ]
+ ].
+
+ suggestedNames := self findBestVariableFor:varName.
+ suggestedNames notNil ifTrue:[
+ newName := self askForVariable:'correct variable to: ' fromList:suggestedNames.
+ newName isNil ifTrue:[^ #Error].
+"
+ newName := suggestedNames at:1.
+ (self confirm:('confirm correction to: ' , newName)) ifFalse:[^ #Error]
+"
+ ] ifFalse:[
+ self notify:'no good correction found'.
+ ^ #Error
+ ].
+
+ "tell requestor about the change"
+ requestor replaceSelectionBy:newName.
+
+ "redo parse with new value"
+ tokenName := newName.
+ ^ self variableOrError
+!
+
+askForVariable:aString fromList:aList
+ "launch a selection box, which allows user to enter correction.
+ return true for yes, false for no"
+
+ |box|
+
+ ListSelectionBox isNil ifTrue:[
+ ^ self confirm:aString
+ ].
+ box := ListSelectionBox new.
+ box title:aString.
+ box initialText:(aList at:1).
+ box list:aList.
+ box okText:'replace'.
+ box abortText:'abort'.
+ box action:[:aString | ^ aString].
+ box showAtPointer.
+ ^ nil
+! !
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/PrimNd.st Fri Jul 16 11:38:57 1993 +0200
@@ -0,0 +1,83 @@
+"
+ COPYRIGHT (c) 1990-93 by Claus Gittinger
+ All Rights Reserved
+
+ This software is furnished under a license and may be used
+ only in accordance with the terms of that license and with the
+ inclusion of the above copyright notice. This software may not
+ be provided or otherwise made available to, or used by, any
+ other person. No title to or ownership of the software is
+ hereby transferred.
+"
+
+StatementNode subclass:#PrimitiveNode
+ instanceVariableNames:'code primNumber'
+ classVariableNames:''
+ poolDictionaries:''
+ category:'System-Compiler-Support'
+!
+
+PrimitiveNode comment:'
+
+COPYRIGHT (c) 1990-93 by Claus Gittinger
+ All Rights Reserved
+
+%W% %E%
+
+Primitives are currently not supported by the compiler - if you
+want a primitive, you must use the stc-compiler and link a new smalltalk.
+
+In the future, methods with primitives will be passed to stc and the resulting
+binary be loaded into the image (also a limited set of numeric primitives
+could be implemented for more ST-80 compatibility - if thats really needed).
+
+written 90 by claus
+'!
+
+!PrimitiveNode class methodsFor:'instance creation'!
+
+code:aString
+ ^ self basicNew code:aString
+!
+
+primitiveNumber:anInteger
+ ^ self basicNew primitiveNumber:anInteger
+! !
+
+!PrimitiveNode methodsFor:'accessing'!
+
+code:aString
+ code := aString
+!
+
+primitiveNumber:anInteger
+ primNumber := anInteger
+! !
+
+!PrimitiveNode methodsFor:'evaluating'!
+
+evaluateExpression
+ "catch evaluation"
+
+ self error:'cannot evaluate primitives'
+!
+
+evaluate
+ "catch evaluation"
+
+ self error:'cannot evaluate primitives'
+! !
+
+!PrimitiveNode methodsFor:'code generation'!
+
+codeForSideEffectOn:aStream inBlock:b
+ "catch code generation"
+
+ self error:'cannot compile primitives (as yet)'
+!
+
+codeOn:aStream inBlock:b
+ "catch code generation"
+
+ self error:'cannot compile primitives (as yet)'
+! !
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/PrimaryNd.st Fri Jul 16 11:38:57 1993 +0200
@@ -0,0 +1,474 @@
+"
+ COPYRIGHT (c) 1989-93 by Claus Gittinger
+ All Rights Reserved
+
+ This software is furnished under a license and may be used
+ only in accordance with the terms of that license and with the
+ inclusion of the above copyright notice. This software may not
+ be provided or otherwise made available to, or used by, any
+ other person. No title to or ownership of the software is
+ hereby transferred.
+"
+
+ParseNode subclass:#PrimaryNode
+ instanceVariableNames:'value name selfValue token index block'
+ classVariableNames:''
+ poolDictionaries:''
+ category:'System-Compiler-Support'
+!
+
+PrimaryNode comment:'
+
+COPYRIGHT (c) 1989-93 by Claus Gittinger
+ All Rights Reserved
+
+%W% %E%
+written 88 by claus
+'!
+
+!PrimaryNode 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 index:i selfValue:s
+ ^ (self basicNew) type:t index:i selfValue:s
+!
+
+type:t value:val
+ ^ (self basicNew) type:t value:val
+!
+
+type:t name:n value:val
+ ^ (self basicNew) type:t name:n value:val
+!
+
+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 token:tok index:i
+ ^ (self basicNew) type:t token:tok index:i
+!
+
+type:t token:tok index:i block:b
+ ^ (self basicNew) type:t token:tok index:i block:b
+! !
+
+!PrimaryNode methodsFor:'accessing'!
+
+type:t token:tok
+ type := t.
+ token := tok
+!
+
+type:t token:tok index:i
+ type := t.
+ index := i.
+ token := tok
+!
+
+type:t token:tok index:i block:b
+ type := t.
+ index := i.
+ block := b.
+ token := tok
+!
+
+type:t name:n
+ type := t.
+ value := nil.
+ name := n
+!
+
+type:t index:i selfValue:s
+ type := t.
+ value := nil.
+ index := i.
+ selfValue := s
+!
+
+type:t value:val
+ type := t.
+ value := val
+!
+
+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
+!
+
+type:t name:n token:tok index:i
+ type := t.
+ index := i.
+ token := tok.
+ name := n
+!
+
+type:t name:n token:tok index:i block:b
+ type := t.
+ index := i.
+ block := b.
+ token := tok.
+ name := n
+!
+
+name
+ ^ name
+!
+
+index
+ ^ index
+!
+
+value
+ ^ value
+! !
+
+!PrimaryNode methodsFor:'evaluating'!
+
+evaluate
+ (type == #MethodVariable) ifTrue:[
+ ^ token value
+ ].
+ (type == #InstanceVariable) ifTrue:[
+ ^ selfValue instVarAt:index
+ ].
+ (type == #BlockArg) ifTrue:[
+ ^ token value
+ ].
+ (type == #GlobalVariable) ifTrue:[
+ (Smalltalk includesKey:name) ifTrue:[
+ ^ Smalltalk at:name
+ ].
+"
+ self error:('global ' , name , ' is undefined').
+"
+
+ ^ UndefinedVariable name:name.
+ ^ nil
+ ].
+ (type == #BlockVariable) ifTrue:[
+ ^ token value
+ ].
+ (type == #ClassVariable) ifTrue:[
+ ^ Smalltalk at:name
+ ].
+ (type == #ClassInstanceVariable) ifTrue:[
+ ^ selfValue class instVarAt:index
+ ].
+ (type == #ThisContext) ifTrue:[
+ ^ thisContext
+ ].
+ ^ value
+!
+
+store:aValue
+ (type == #MethodVariable) ifTrue:[
+ token value:aValue
+ ].
+ (type == #InstanceVariable) ifTrue:[
+ ^ selfValue instVarAt:index put:aValue
+ ].
+ (type == #GlobalVariable) ifTrue:[
+ ^ Smalltalk at:name put:aValue
+ ].
+ (type == #ClassVariable) ifTrue:[
+ ^ Smalltalk at:name put:aValue
+ ].
+ (type == #BlockVariable) ifTrue:[
+ token value:aValue
+ ].
+ (type == #ClassInstanceVariable) ifTrue:[
+ ^ selfValue class instVarAt:index put:aValue
+ ].
+ ^ aValue
+! !
+
+!PrimaryNode methodsFor:'code generation'!
+
+codeForSideEffectOn:aStream inBlock:b
+ "no code at all"
+ ^ self
+!
+
+codeOn:aStream inBlock:codeBlock
+ |theCode b deltaLevel|
+
+ (type == #Self) ifTrue:[
+ aStream nextPut:#pushSelf. ^ self
+ ].
+ (type == #MethodArg) ifTrue:[
+ (index <= 4) ifTrue:[
+ aStream nextPut:(#(pushMethodArg1
+ pushMethodArg2
+ pushMethodArg3
+ pushMethodArg4) at:index).
+ ^ self
+ ].
+ aStream nextPut:#pushMethodArg.
+ aStream nextPut:index.
+ ^ self
+ ].
+ (type == #MethodVariable) ifTrue:[
+ (index <= 6) ifTrue:[
+ aStream nextPut:(#(pushMethodVar1
+ pushMethodVar2
+ pushMethodVar3
+ pushMethodVar4
+ pushMethodVar5
+ pushMethodVar6) at:index).
+ ^ self
+ ].
+ aStream nextPut:#pushMethodVar.
+ aStream nextPut:index.
+ ^ self
+ ].
+ (type == #InstanceVariable) ifTrue:[
+ (index <= 10) ifTrue:[
+ theCode := #(pushInstVar1 pushInstVar2 pushInstVar3
+ pushInstVar4 pushInstVar5 pushInstVar6
+ pushInstVar7 pushInstVar8 pushInstVar9
+ pushInstVar10) at:index.
+ aStream nextPut:theCode.
+ ^ self
+ ].
+ aStream nextPut:#pushInstVar.
+ aStream nextPut:index.
+ ^ self
+ ].
+ (type == #BlockArg) ifTrue:[
+ "find deltaLevel to block, where argument was defined"
+ b := codeBlock.
+ deltaLevel := 0.
+ [b notNil and:[b ~~ block]] whileTrue:[
+ b inlineBlock ifFalse:[
+ deltaLevel := deltaLevel + 1
+ ].
+ b := b home
+ ].
+ (deltaLevel == 0) ifTrue:[
+ (index <= 4) ifTrue:[
+ theCode := #(pushBlockArg1 pushBlockArg2 pushBlockArg3
+ pushBlockArg4) at:index.
+ aStream nextPut:theCode.
+ ^ self
+ ].
+ aStream nextPut:#pushBlockArg.
+ aStream nextPut:index
+ ] ifFalse:[
+ (deltaLevel == 1) ifTrue:[
+ aStream nextPut:#pushOuter1BlockArg
+ ] ifFalse:[
+ (deltaLevel == 2) ifTrue:[
+ aStream nextPut:#pushOuter2BlockArg
+ ] ifFalse:[
+ aStream nextPut:#pushOuterBlockArg.
+ aStream nextPut:deltaLevel
+ ]
+ ].
+ aStream nextPut:index
+ ].
+ ^ self
+ ].
+ (type == #Super) ifTrue:[
+ aStream nextPut:#pushSelf. ^ self
+ ].
+ (type == #GlobalVariable) ifTrue:[
+ aStream nextPut:#pushGlobal.
+ aStream nextPut:name.
+ aStream nextPut:0. "slot for generation "
+ aStream nextPut:0. "slot for cell address (4 byte) "
+ aStream nextPut:0.
+ aStream nextPut:0.
+ aStream nextPut:0.
+ ^ self
+ ].
+ (type == #ClassVariable) ifTrue:[
+ aStream nextPut:#pushClassVar.
+ aStream nextPut:name.
+ aStream nextPut:0. "slot for generation "
+ aStream nextPut:0. "slot for cell address (4 byte) "
+ aStream nextPut:0.
+ aStream nextPut:0.
+ aStream nextPut:0.
+ ^ self
+ ].
+ (type == #BlockVariable) ifTrue:[
+ "find deltaLevel to block, where variable was defined"
+ b := codeBlock.
+ deltaLevel := 0.
+ [b notNil and:[b ~~ block]] whileTrue:[
+ b inlineBlock ifFalse:[
+ deltaLevel := deltaLevel + 1
+ ].
+ b := b home
+ ].
+
+ (deltaLevel == 0) ifTrue:[
+ aStream nextPut:#pushBlockVar.
+ aStream nextPut:index
+ ] ifFalse:[
+ aStream nextPut:#pushOuterBlockVar.
+ aStream nextPut:deltaLevel.
+ aStream nextPut:index
+ ].
+ ^ self
+ ].
+ (type == #ClassInstanceVariable) ifTrue:[
+ aStream nextPut:#pushClassInstVar.
+ aStream nextPut:index.
+ ^ self
+ ].
+ (type == #ThisContext) ifTrue:[
+ aStream nextPut:#pushThisContext. ^ self
+ ].
+
+ "can this be reached ?"
+
+ aStream nextPut:#pushLit.
+ aStream nextPut:value
+!
+
+codeStoreOn:aStream inBlock:codeBlock valueNeeded:valueNeeded
+ |theCode b deltaLevel|
+
+ valueNeeded ifTrue:[
+ aStream nextPut:#dup
+ ].
+ (type == #MethodVariable) ifTrue:[
+ (index <= 6) ifTrue:[
+ theCode := #(storeMethodVar1 storeMethodVar2
+ storeMethodVar3 storeMethodVar4
+ storeMethodVar5 storeMethodVar6) at:index.
+ aStream nextPut:theCode.
+ ^ self
+ ].
+ aStream nextPut:#storeMethodVar.
+ aStream nextPut:index.
+ ^ self
+ ].
+ (type == #InstanceVariable) ifTrue:[
+ (index <= 10) ifTrue:[
+ theCode := #(storeInstVar1 storeInstVar2
+ storeInstVar3 storeInstVar4
+ storeInstVar5 storeInstVar6
+ storeInstVar7 storeInstVar8
+ storeInstVar9 storeInstVar10) at:index.
+ aStream nextPut:theCode.
+ ^ self
+ ].
+ aStream nextPut:#storeInstVar.
+ aStream nextPut:index.
+ ^ self
+ ].
+ (type == #GlobalVariable) ifTrue:[
+ aStream nextPut:#storeGlobal.
+ aStream nextPut:name.
+ aStream nextPut:0. "slot for generation "
+ aStream nextPut:0. "slot for cell address (4 byte) "
+ aStream nextPut:0.
+ aStream nextPut:0.
+ aStream nextPut:0.
+ ^ self
+ ].
+ (type == #BlockVariable) ifTrue:[
+ "find deltaLevel to block, where variable was defined"
+ b := codeBlock.
+ deltaLevel := 0.
+ [b notNil and:[b ~~ block]] whileTrue:[
+ b inlineBlock ifFalse:[
+ deltaLevel := deltaLevel + 1
+ ].
+ b := b home
+ ].
+
+ (deltaLevel == 0) ifTrue:[
+ aStream nextPut:#storeBlockVar.
+ aStream nextPut:index
+ ] ifFalse:[
+ aStream nextPut:#storeOuterBlockVar.
+ aStream nextPut:deltaLevel.
+ aStream nextPut:index
+ ].
+ ^ self
+ ].
+ (type == #ClassVariable) ifTrue:[
+ aStream nextPut:#storeClassVar.
+ aStream nextPut:name.
+ aStream nextPut:0. "slot for generation "
+ aStream nextPut:0. "slot for cell address (4 byte) "
+ aStream nextPut:0.
+ aStream nextPut:0.
+ aStream nextPut:0.
+ ^ self
+ ].
+ (type == #ClassInstanceVariable) ifTrue:[
+ aStream nextPut:#storeClassInstVar.
+ aStream nextPut:index.
+ ^ self
+ ].
+ "cannot be reached"
+ ^ self error:'bad assignment'
+! !
+
+!PrimaryNode methodsFor:'printing'!
+
+printOn:aStream indent:i
+ (type == #Self) ifTrue:[
+ aStream nextPutAll:'self'. ^ self
+ ].
+ (type == #MethodArg) ifTrue:[
+ aStream nextPutAll:name. ^ self
+ ].
+ (type == #MethodVariable) ifTrue:[
+ aStream nextPutAll:name. ^ self
+ ].
+ (type == #InstanceVariable) ifTrue:[
+ aStream nextPutAll:name. ^ self
+ ].
+ (type == #BlockArg) ifTrue:[
+ aStream nextPutAll:name. ^ self
+ ].
+ (type == #Super) ifTrue:[
+ aStream nextPutAll:'super'. ^ self
+ ].
+ (type == #GlobalVariable) ifTrue:[
+ aStream nextPutAll:name.^ self
+ ].
+ (type == #ClassVariable) ifTrue:[
+ aStream nextPutAll:name. ^ self
+ ].
+ (type == #BlockVariable) ifTrue:[
+ aStream nextPutAll:name. ^ self
+ ].
+ (type == #ClassInstanceVariable) ifTrue:[
+ aStream nextPutAll:name. ^ self
+ ].
+ (type == #ThisContext) ifTrue:[
+ aStream nextPutAll:'thisContext'. ^ self
+ ].
+ self halt
+! !
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/PrimaryNode.st Fri Jul 16 11:38:57 1993 +0200
@@ -0,0 +1,474 @@
+"
+ COPYRIGHT (c) 1989-93 by Claus Gittinger
+ All Rights Reserved
+
+ This software is furnished under a license and may be used
+ only in accordance with the terms of that license and with the
+ inclusion of the above copyright notice. This software may not
+ be provided or otherwise made available to, or used by, any
+ other person. No title to or ownership of the software is
+ hereby transferred.
+"
+
+ParseNode subclass:#PrimaryNode
+ instanceVariableNames:'value name selfValue token index block'
+ classVariableNames:''
+ poolDictionaries:''
+ category:'System-Compiler-Support'
+!
+
+PrimaryNode comment:'
+
+COPYRIGHT (c) 1989-93 by Claus Gittinger
+ All Rights Reserved
+
+%W% %E%
+written 88 by claus
+'!
+
+!PrimaryNode 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 index:i selfValue:s
+ ^ (self basicNew) type:t index:i selfValue:s
+!
+
+type:t value:val
+ ^ (self basicNew) type:t value:val
+!
+
+type:t name:n value:val
+ ^ (self basicNew) type:t name:n value:val
+!
+
+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 token:tok index:i
+ ^ (self basicNew) type:t token:tok index:i
+!
+
+type:t token:tok index:i block:b
+ ^ (self basicNew) type:t token:tok index:i block:b
+! !
+
+!PrimaryNode methodsFor:'accessing'!
+
+type:t token:tok
+ type := t.
+ token := tok
+!
+
+type:t token:tok index:i
+ type := t.
+ index := i.
+ token := tok
+!
+
+type:t token:tok index:i block:b
+ type := t.
+ index := i.
+ block := b.
+ token := tok
+!
+
+type:t name:n
+ type := t.
+ value := nil.
+ name := n
+!
+
+type:t index:i selfValue:s
+ type := t.
+ value := nil.
+ index := i.
+ selfValue := s
+!
+
+type:t value:val
+ type := t.
+ value := val
+!
+
+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
+!
+
+type:t name:n token:tok index:i
+ type := t.
+ index := i.
+ token := tok.
+ name := n
+!
+
+type:t name:n token:tok index:i block:b
+ type := t.
+ index := i.
+ block := b.
+ token := tok.
+ name := n
+!
+
+name
+ ^ name
+!
+
+index
+ ^ index
+!
+
+value
+ ^ value
+! !
+
+!PrimaryNode methodsFor:'evaluating'!
+
+evaluate
+ (type == #MethodVariable) ifTrue:[
+ ^ token value
+ ].
+ (type == #InstanceVariable) ifTrue:[
+ ^ selfValue instVarAt:index
+ ].
+ (type == #BlockArg) ifTrue:[
+ ^ token value
+ ].
+ (type == #GlobalVariable) ifTrue:[
+ (Smalltalk includesKey:name) ifTrue:[
+ ^ Smalltalk at:name
+ ].
+"
+ self error:('global ' , name , ' is undefined').
+"
+
+ ^ UndefinedVariable name:name.
+ ^ nil
+ ].
+ (type == #BlockVariable) ifTrue:[
+ ^ token value
+ ].
+ (type == #ClassVariable) ifTrue:[
+ ^ Smalltalk at:name
+ ].
+ (type == #ClassInstanceVariable) ifTrue:[
+ ^ selfValue class instVarAt:index
+ ].
+ (type == #ThisContext) ifTrue:[
+ ^ thisContext
+ ].
+ ^ value
+!
+
+store:aValue
+ (type == #MethodVariable) ifTrue:[
+ token value:aValue
+ ].
+ (type == #InstanceVariable) ifTrue:[
+ ^ selfValue instVarAt:index put:aValue
+ ].
+ (type == #GlobalVariable) ifTrue:[
+ ^ Smalltalk at:name put:aValue
+ ].
+ (type == #ClassVariable) ifTrue:[
+ ^ Smalltalk at:name put:aValue
+ ].
+ (type == #BlockVariable) ifTrue:[
+ token value:aValue
+ ].
+ (type == #ClassInstanceVariable) ifTrue:[
+ ^ selfValue class instVarAt:index put:aValue
+ ].
+ ^ aValue
+! !
+
+!PrimaryNode methodsFor:'code generation'!
+
+codeForSideEffectOn:aStream inBlock:b
+ "no code at all"
+ ^ self
+!
+
+codeOn:aStream inBlock:codeBlock
+ |theCode b deltaLevel|
+
+ (type == #Self) ifTrue:[
+ aStream nextPut:#pushSelf. ^ self
+ ].
+ (type == #MethodArg) ifTrue:[
+ (index <= 4) ifTrue:[
+ aStream nextPut:(#(pushMethodArg1
+ pushMethodArg2
+ pushMethodArg3
+ pushMethodArg4) at:index).
+ ^ self
+ ].
+ aStream nextPut:#pushMethodArg.
+ aStream nextPut:index.
+ ^ self
+ ].
+ (type == #MethodVariable) ifTrue:[
+ (index <= 6) ifTrue:[
+ aStream nextPut:(#(pushMethodVar1
+ pushMethodVar2
+ pushMethodVar3
+ pushMethodVar4
+ pushMethodVar5
+ pushMethodVar6) at:index).
+ ^ self
+ ].
+ aStream nextPut:#pushMethodVar.
+ aStream nextPut:index.
+ ^ self
+ ].
+ (type == #InstanceVariable) ifTrue:[
+ (index <= 10) ifTrue:[
+ theCode := #(pushInstVar1 pushInstVar2 pushInstVar3
+ pushInstVar4 pushInstVar5 pushInstVar6
+ pushInstVar7 pushInstVar8 pushInstVar9
+ pushInstVar10) at:index.
+ aStream nextPut:theCode.
+ ^ self
+ ].
+ aStream nextPut:#pushInstVar.
+ aStream nextPut:index.
+ ^ self
+ ].
+ (type == #BlockArg) ifTrue:[
+ "find deltaLevel to block, where argument was defined"
+ b := codeBlock.
+ deltaLevel := 0.
+ [b notNil and:[b ~~ block]] whileTrue:[
+ b inlineBlock ifFalse:[
+ deltaLevel := deltaLevel + 1
+ ].
+ b := b home
+ ].
+ (deltaLevel == 0) ifTrue:[
+ (index <= 4) ifTrue:[
+ theCode := #(pushBlockArg1 pushBlockArg2 pushBlockArg3
+ pushBlockArg4) at:index.
+ aStream nextPut:theCode.
+ ^ self
+ ].
+ aStream nextPut:#pushBlockArg.
+ aStream nextPut:index
+ ] ifFalse:[
+ (deltaLevel == 1) ifTrue:[
+ aStream nextPut:#pushOuter1BlockArg
+ ] ifFalse:[
+ (deltaLevel == 2) ifTrue:[
+ aStream nextPut:#pushOuter2BlockArg
+ ] ifFalse:[
+ aStream nextPut:#pushOuterBlockArg.
+ aStream nextPut:deltaLevel
+ ]
+ ].
+ aStream nextPut:index
+ ].
+ ^ self
+ ].
+ (type == #Super) ifTrue:[
+ aStream nextPut:#pushSelf. ^ self
+ ].
+ (type == #GlobalVariable) ifTrue:[
+ aStream nextPut:#pushGlobal.
+ aStream nextPut:name.
+ aStream nextPut:0. "slot for generation "
+ aStream nextPut:0. "slot for cell address (4 byte) "
+ aStream nextPut:0.
+ aStream nextPut:0.
+ aStream nextPut:0.
+ ^ self
+ ].
+ (type == #ClassVariable) ifTrue:[
+ aStream nextPut:#pushClassVar.
+ aStream nextPut:name.
+ aStream nextPut:0. "slot for generation "
+ aStream nextPut:0. "slot for cell address (4 byte) "
+ aStream nextPut:0.
+ aStream nextPut:0.
+ aStream nextPut:0.
+ ^ self
+ ].
+ (type == #BlockVariable) ifTrue:[
+ "find deltaLevel to block, where variable was defined"
+ b := codeBlock.
+ deltaLevel := 0.
+ [b notNil and:[b ~~ block]] whileTrue:[
+ b inlineBlock ifFalse:[
+ deltaLevel := deltaLevel + 1
+ ].
+ b := b home
+ ].
+
+ (deltaLevel == 0) ifTrue:[
+ aStream nextPut:#pushBlockVar.
+ aStream nextPut:index
+ ] ifFalse:[
+ aStream nextPut:#pushOuterBlockVar.
+ aStream nextPut:deltaLevel.
+ aStream nextPut:index
+ ].
+ ^ self
+ ].
+ (type == #ClassInstanceVariable) ifTrue:[
+ aStream nextPut:#pushClassInstVar.
+ aStream nextPut:index.
+ ^ self
+ ].
+ (type == #ThisContext) ifTrue:[
+ aStream nextPut:#pushThisContext. ^ self
+ ].
+
+ "can this be reached ?"
+
+ aStream nextPut:#pushLit.
+ aStream nextPut:value
+!
+
+codeStoreOn:aStream inBlock:codeBlock valueNeeded:valueNeeded
+ |theCode b deltaLevel|
+
+ valueNeeded ifTrue:[
+ aStream nextPut:#dup
+ ].
+ (type == #MethodVariable) ifTrue:[
+ (index <= 6) ifTrue:[
+ theCode := #(storeMethodVar1 storeMethodVar2
+ storeMethodVar3 storeMethodVar4
+ storeMethodVar5 storeMethodVar6) at:index.
+ aStream nextPut:theCode.
+ ^ self
+ ].
+ aStream nextPut:#storeMethodVar.
+ aStream nextPut:index.
+ ^ self
+ ].
+ (type == #InstanceVariable) ifTrue:[
+ (index <= 10) ifTrue:[
+ theCode := #(storeInstVar1 storeInstVar2
+ storeInstVar3 storeInstVar4
+ storeInstVar5 storeInstVar6
+ storeInstVar7 storeInstVar8
+ storeInstVar9 storeInstVar10) at:index.
+ aStream nextPut:theCode.
+ ^ self
+ ].
+ aStream nextPut:#storeInstVar.
+ aStream nextPut:index.
+ ^ self
+ ].
+ (type == #GlobalVariable) ifTrue:[
+ aStream nextPut:#storeGlobal.
+ aStream nextPut:name.
+ aStream nextPut:0. "slot for generation "
+ aStream nextPut:0. "slot for cell address (4 byte) "
+ aStream nextPut:0.
+ aStream nextPut:0.
+ aStream nextPut:0.
+ ^ self
+ ].
+ (type == #BlockVariable) ifTrue:[
+ "find deltaLevel to block, where variable was defined"
+ b := codeBlock.
+ deltaLevel := 0.
+ [b notNil and:[b ~~ block]] whileTrue:[
+ b inlineBlock ifFalse:[
+ deltaLevel := deltaLevel + 1
+ ].
+ b := b home
+ ].
+
+ (deltaLevel == 0) ifTrue:[
+ aStream nextPut:#storeBlockVar.
+ aStream nextPut:index
+ ] ifFalse:[
+ aStream nextPut:#storeOuterBlockVar.
+ aStream nextPut:deltaLevel.
+ aStream nextPut:index
+ ].
+ ^ self
+ ].
+ (type == #ClassVariable) ifTrue:[
+ aStream nextPut:#storeClassVar.
+ aStream nextPut:name.
+ aStream nextPut:0. "slot for generation "
+ aStream nextPut:0. "slot for cell address (4 byte) "
+ aStream nextPut:0.
+ aStream nextPut:0.
+ aStream nextPut:0.
+ ^ self
+ ].
+ (type == #ClassInstanceVariable) ifTrue:[
+ aStream nextPut:#storeClassInstVar.
+ aStream nextPut:index.
+ ^ self
+ ].
+ "cannot be reached"
+ ^ self error:'bad assignment'
+! !
+
+!PrimaryNode methodsFor:'printing'!
+
+printOn:aStream indent:i
+ (type == #Self) ifTrue:[
+ aStream nextPutAll:'self'. ^ self
+ ].
+ (type == #MethodArg) ifTrue:[
+ aStream nextPutAll:name. ^ self
+ ].
+ (type == #MethodVariable) ifTrue:[
+ aStream nextPutAll:name. ^ self
+ ].
+ (type == #InstanceVariable) ifTrue:[
+ aStream nextPutAll:name. ^ self
+ ].
+ (type == #BlockArg) ifTrue:[
+ aStream nextPutAll:name. ^ self
+ ].
+ (type == #Super) ifTrue:[
+ aStream nextPutAll:'super'. ^ self
+ ].
+ (type == #GlobalVariable) ifTrue:[
+ aStream nextPutAll:name.^ self
+ ].
+ (type == #ClassVariable) ifTrue:[
+ aStream nextPutAll:name. ^ self
+ ].
+ (type == #BlockVariable) ifTrue:[
+ aStream nextPutAll:name. ^ self
+ ].
+ (type == #ClassInstanceVariable) ifTrue:[
+ aStream nextPutAll:name. ^ self
+ ].
+ (type == #ThisContext) ifTrue:[
+ aStream nextPutAll:'thisContext'. ^ self
+ ].
+ self halt
+! !
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/PrimitiveNode.st Fri Jul 16 11:38:57 1993 +0200
@@ -0,0 +1,83 @@
+"
+ COPYRIGHT (c) 1990-93 by Claus Gittinger
+ All Rights Reserved
+
+ This software is furnished under a license and may be used
+ only in accordance with the terms of that license and with the
+ inclusion of the above copyright notice. This software may not
+ be provided or otherwise made available to, or used by, any
+ other person. No title to or ownership of the software is
+ hereby transferred.
+"
+
+StatementNode subclass:#PrimitiveNode
+ instanceVariableNames:'code primNumber'
+ classVariableNames:''
+ poolDictionaries:''
+ category:'System-Compiler-Support'
+!
+
+PrimitiveNode comment:'
+
+COPYRIGHT (c) 1990-93 by Claus Gittinger
+ All Rights Reserved
+
+%W% %E%
+
+Primitives are currently not supported by the compiler - if you
+want a primitive, you must use the stc-compiler and link a new smalltalk.
+
+In the future, methods with primitives will be passed to stc and the resulting
+binary be loaded into the image (also a limited set of numeric primitives
+could be implemented for more ST-80 compatibility - if thats really needed).
+
+written 90 by claus
+'!
+
+!PrimitiveNode class methodsFor:'instance creation'!
+
+code:aString
+ ^ self basicNew code:aString
+!
+
+primitiveNumber:anInteger
+ ^ self basicNew primitiveNumber:anInteger
+! !
+
+!PrimitiveNode methodsFor:'accessing'!
+
+code:aString
+ code := aString
+!
+
+primitiveNumber:anInteger
+ primNumber := anInteger
+! !
+
+!PrimitiveNode methodsFor:'evaluating'!
+
+evaluateExpression
+ "catch evaluation"
+
+ self error:'cannot evaluate primitives'
+!
+
+evaluate
+ "catch evaluation"
+
+ self error:'cannot evaluate primitives'
+! !
+
+!PrimitiveNode methodsFor:'code generation'!
+
+codeForSideEffectOn:aStream inBlock:b
+ "catch code generation"
+
+ self error:'cannot compile primitives (as yet)'
+!
+
+codeOn:aStream inBlock:b
+ "catch code generation"
+
+ self error:'cannot compile primitives (as yet)'
+! !
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/RetNode.st Fri Jul 16 11:38:57 1993 +0200
@@ -0,0 +1,124 @@
+"
+ COPYRIGHT (c) 1989-93 by Claus Gittinger
+ All Rights Reserved
+
+ This software is furnished under a license and may be used
+ only in accordance with the terms of that license and with the
+ inclusion of the above copyright notice. This software may not
+ be provided or otherwise made available to, or used by, any
+ other person. No title to or ownership of the software is
+ hereby transferred.
+"
+
+StatementNode subclass:#ReturnNode
+ instanceVariableNames:'myHome blockHome'
+ classVariableNames:''
+ poolDictionaries:''
+ category:'System-Compiler-Support'
+!
+
+ReturnNode comment:'
+COPYRIGHT (c) 1989-93 by Claus Gittinger
+ All Rights Reserved
+
+%W% %E%
+'!
+
+!ReturnNode methodsFor:'accessing'!
+
+home:someOne blockHome:aBlockNode
+ myHome := someOne.
+ blockHome := aBlockNode
+! !
+
+!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
+ "redefined - drop not needed since notreached"
+
+ ^ self codeOn:aStream inBlock:b
+!
+
+codeOn:aStream inBlock:b
+ |type value index|
+
+ (expression isKindOf:PrimaryNode) ifTrue:[
+ type := expression type.
+ (type == #Nil) ifTrue:[
+ aStream nextPut:#retNil. ^ self
+ ].
+ (type == #True) ifTrue:[
+ aStream nextPut:#retTrue. ^ self
+ ].
+ (type == #False) ifTrue:[
+ aStream nextPut:#retFalse. ^ self
+ ].
+ (type == #Self) ifTrue:[
+ aStream nextPut:#retSelf. ^ self
+ ].
+ (type == #Integer) ifTrue:[
+ value := expression evaluate.
+ (value between: -128 and:127) ifTrue:[
+ (value == 0) ifTrue:[
+ aStream nextPut:#ret0. ^ self
+ ].
+ aStream nextPut:#retNum.
+ aStream nextPut:value. ^ self
+ ]
+ ].
+ (type == #InstanceVariable) ifTrue:[
+ index := expression index.
+ (index <= 8) ifTrue:[
+ aStream nextPut:(#(retInstVar1
+ retInstVar2
+ retInstVar3
+ retInstVar4
+ retInstVar5
+ retInstVar6
+ retInstVar7
+ retInstVar8) at:index). ^ self
+ ]
+ ].
+ (type == #MethodVariable) ifTrue:[
+ index := expression index.
+ (index <= 6) ifTrue:[
+ aStream nextPut:(#(retMethodVar1
+ retMethodVar2
+ retMethodVar3
+ retMethodVar4
+ retMethodVar5
+ retMethodVar6) at:index). ^ self
+ ]
+ ].
+ (type == #MethodArg) ifTrue:[
+ index := expression index.
+ (index <= 2) ifTrue:[
+ aStream nextPut:(#(retMethodArg1
+ retMethodArg2) at:index). ^ self
+ ]
+ ]
+ ].
+ expression codeOn:aStream inBlock:b.
+ aStream nextPut:#retTop
+! !
+
+!ReturnNode methodsFor:'printing'!
+
+printOn:aStream indent:i
+ aStream nextPutAll:'^ '.
+ expression printOn:aStream
+! !
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/ReturnNode.st Fri Jul 16 11:38:57 1993 +0200
@@ -0,0 +1,124 @@
+"
+ COPYRIGHT (c) 1989-93 by Claus Gittinger
+ All Rights Reserved
+
+ This software is furnished under a license and may be used
+ only in accordance with the terms of that license and with the
+ inclusion of the above copyright notice. This software may not
+ be provided or otherwise made available to, or used by, any
+ other person. No title to or ownership of the software is
+ hereby transferred.
+"
+
+StatementNode subclass:#ReturnNode
+ instanceVariableNames:'myHome blockHome'
+ classVariableNames:''
+ poolDictionaries:''
+ category:'System-Compiler-Support'
+!
+
+ReturnNode comment:'
+COPYRIGHT (c) 1989-93 by Claus Gittinger
+ All Rights Reserved
+
+%W% %E%
+'!
+
+!ReturnNode methodsFor:'accessing'!
+
+home:someOne blockHome:aBlockNode
+ myHome := someOne.
+ blockHome := aBlockNode
+! !
+
+!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
+ "redefined - drop not needed since notreached"
+
+ ^ self codeOn:aStream inBlock:b
+!
+
+codeOn:aStream inBlock:b
+ |type value index|
+
+ (expression isKindOf:PrimaryNode) ifTrue:[
+ type := expression type.
+ (type == #Nil) ifTrue:[
+ aStream nextPut:#retNil. ^ self
+ ].
+ (type == #True) ifTrue:[
+ aStream nextPut:#retTrue. ^ self
+ ].
+ (type == #False) ifTrue:[
+ aStream nextPut:#retFalse. ^ self
+ ].
+ (type == #Self) ifTrue:[
+ aStream nextPut:#retSelf. ^ self
+ ].
+ (type == #Integer) ifTrue:[
+ value := expression evaluate.
+ (value between: -128 and:127) ifTrue:[
+ (value == 0) ifTrue:[
+ aStream nextPut:#ret0. ^ self
+ ].
+ aStream nextPut:#retNum.
+ aStream nextPut:value. ^ self
+ ]
+ ].
+ (type == #InstanceVariable) ifTrue:[
+ index := expression index.
+ (index <= 8) ifTrue:[
+ aStream nextPut:(#(retInstVar1
+ retInstVar2
+ retInstVar3
+ retInstVar4
+ retInstVar5
+ retInstVar6
+ retInstVar7
+ retInstVar8) at:index). ^ self
+ ]
+ ].
+ (type == #MethodVariable) ifTrue:[
+ index := expression index.
+ (index <= 6) ifTrue:[
+ aStream nextPut:(#(retMethodVar1
+ retMethodVar2
+ retMethodVar3
+ retMethodVar4
+ retMethodVar5
+ retMethodVar6) at:index). ^ self
+ ]
+ ].
+ (type == #MethodArg) ifTrue:[
+ index := expression index.
+ (index <= 2) ifTrue:[
+ aStream nextPut:(#(retMethodArg1
+ retMethodArg2) at:index). ^ self
+ ]
+ ]
+ ].
+ expression codeOn:aStream inBlock:b.
+ aStream nextPut:#retTop
+! !
+
+!ReturnNode methodsFor:'printing'!
+
+printOn:aStream indent:i
+ aStream nextPutAll:'^ '.
+ expression printOn:aStream
+! !
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/Scanner.st Fri Jul 16 11:38:57 1993 +0200
@@ -0,0 +1,590 @@
+"
+ COPYRIGHT (c) 1989-93 by Claus Gittinger
+ All Rights Reserved
+
+ This software is furnished under a license and may be used
+ only in accordance with the terms of that license and with the
+ inclusion of the above copyright notice. This software may not
+ be provided or otherwise made available to, or used by, any
+ other person. No title to or ownership of the software is
+ hereby transferred.
+"
+
+Object subclass:#Scanner
+ instanceVariableNames:'source
+ token tokenType tokenPosition tokenValue
+ tokenName tokenLineNr
+ thisChar peekChar
+ requestor exitBlock
+ errorFlag'
+ classVariableNames:'typeArray actionArray'
+ poolDictionaries:''
+ category:'System-Compiler'
+!
+
+Scanner comment:'
+
+COPYRIGHT (c) 1989-93 by Claus Gittinger
+ All Rights Reserved
+
+Scanner reads from a stream and returns individual smalltalk tokens
+%W% %E%
+'!
+
+!Scanner class methodsFor:'instance creation'!
+
+for:aStream
+ "return a new scanner reading from aStream"
+
+ ^ (super new) initializeFor:aStream
+! !
+
+!Scanner methodsFor:'private'!
+
+initializeFor:aStream
+ "initialize -
+ if this is the first time, setup character- and action tables"
+
+ |block|
+
+ errorFlag := false.
+ tokenLineNr := 1.
+ source := aStream.
+
+ actionArray isNil ifTrue:[
+ actionArray := Array new:256.
+ typeArray := Array new:256.
+
+ block := [:s :char | s nextNumber].
+ ($0 asciiValue) to:($9 asciiValue) do:[:index |
+ actionArray at:index put:block
+ ].
+
+ block := [:s :char | s nextIdentifier].
+ ($a asciiValue) to:($z asciiValue) do:[:index |
+ actionArray at:index put:block
+ ].
+ ($A asciiValue) to:($Z asciiValue) do:[:index |
+ actionArray at:index put:block
+ ].
+
+ block := [:s :char | s nextSpecial].
+ #( $& $- $+ $= $* $/ $\ $< $> $~ $@ $, $? ) do:[:binop |
+ typeArray at:(binop asciiValue) put:#special.
+ actionArray at:(binop asciiValue) put:block
+ ].
+
+ block := [:s :char | s nextToken:char].
+ #( $; $. $( $) $[ $] $!! $^ $| $_ ) do:[:ch |
+ actionArray at:(ch asciiValue) put:block
+ ].
+
+ "kludge: action is characterToken, but type is special"
+ typeArray at:($| asciiValue) put:#special.
+
+ actionArray at:($' asciiValue) put:[:s :char | s nextString].
+ actionArray at:($$ asciiValue) put:[:s :char | s nextCharacter].
+ actionArray at:($# asciiValue) put:[:s :char | s nextHash].
+ actionArray at:($% asciiValue) put:[:s :char | s nextPrimitive].
+ actionArray at:($: asciiValue) put:[:s :char | s nextColonOrAssign]
+ ]
+!
+
+notifying:anObject
+ "set the requestor to be notified"
+
+ requestor := anObject
+!
+
+initialize
+ "prepare a scan"
+
+ errorFlag := false.
+ tokenLineNr := 1
+!
+
+backupPosition
+ "if reading from a stream, at the end we might have read
+ one token too many"
+
+ (tokenType == #EOF) ifFalse:[
+ source position:tokenPosition
+ ]
+! !
+
+!Scanner methodsFor:'error handling'!
+
+showErrorMessage:aMessage position:pos
+ "show an errormessage on the Transcript"
+
+ Transcript showCr:(pos printString , ' ' , aMessage)
+!
+
+notifyError:aMessage position:position to:endPos
+ "notify requestor of an error - if there is no requestor
+ put it on the transcript.
+ Return the result passed back by the requestor."
+
+ requestor isNil ifTrue:[
+ self showErrorMessage:aMessage position:position.
+ ^ false
+ ].
+ ^ requestor error:aMessage position:position to:endPos
+!
+
+notifyWarning:aMessage position:position to:endPos
+ "notify requestor of an warning - if there is no requestor
+ put it on the transcript.
+ Return the result passed back by the requestor."
+
+ requestor isNil ifTrue:[
+ self showErrorMessage:aMessage position:position.
+ ^ false
+ ].
+ ^ requestor warning:aMessage position:position to:endPos
+!
+
+syntaxError:aMessage position:position to:endPos
+ "a syntax error happened"
+
+ self notifyError:(' Error:' , aMessage) position:position to:endPos.
+ exitBlock notNil ifTrue:[exitBlock value].
+ ^ false
+!
+
+syntaxError:aMessage position:position
+ "a syntax error happened - only start position is known"
+
+ ^ self syntaxError:aMessage position:position to:nil
+!
+
+syntaxError:aMessage
+ "a syntax error happened - position is not known"
+
+ ^ self syntaxError:aMessage position:tokenPosition
+!
+
+warning:aMessage position:position to:endPos
+ "a warning"
+
+ ^ self notifyWarning:(' Warning:' , aMessage) position:position to:endPos
+!
+
+warning:aMessage position:position
+ "a warning - only start position is known"
+
+ ^ self warning:aMessage position:position to:nil
+!
+
+warning:aMessage
+ "a warning - position is not known"
+
+ ^ self warning:aMessage position:tokenPosition
+! !
+
+!Scanner methodsFor:'reading next token'!
+
+nextToken
+ "return the next token from the source-stream"
+
+ |skipping actionBlock|
+
+ peekChar notNil ifTrue:[
+ thisChar := peekChar.
+ peekChar := nil
+ ] ifFalse:[
+ skipping := true.
+ [skipping] whileTrue:[
+ thisChar := source skipSeparatorsExceptCR.
+ thisChar == (Character cr) ifTrue:[
+ tokenLineNr := tokenLineNr + 1.
+ source next
+ ] ifFalse:[
+ thisChar == (Character doubleQuote) ifTrue:[
+ source next.
+ thisChar := source peek.
+ [thisChar notNil and:[thisChar ~~ (Character doubleQuote)]] whileTrue:[
+ thisChar == (Character cr) ifTrue:[
+ tokenLineNr := tokenLineNr + 1.
+ ].
+ source next.
+ thisChar := source peek
+ ].
+ source next.
+ thisChar := source peek.
+"
+ thisChar == (Character cr) ifTrue:[
+ tokenLineNr := tokenLineNr + 1.
+ ].
+"
+ "thisChar := source skipFor:(Character doubleQuote) "
+ ] ifFalse:[
+ skipping := false
+ ]
+ ]
+ ].
+ thisChar isNil ifTrue:[
+ tokenType := #EOF.
+ ^ tokenType
+ ]
+ ].
+ tokenPosition := source position.
+
+ actionBlock := actionArray at:(thisChar asciiValue).
+ actionBlock notNil ifTrue:[
+ ^ actionBlock value:self value:thisChar
+ ].
+
+ self syntaxError:('invalid character: ''' , thisChar asString , ''' ',
+ '(' , thisChar asciiValue printString , ')')
+ position:tokenPosition to:tokenPosition.
+ tokenType := #Error.
+ ^ #Error
+!
+
+nextToken:aCharacter
+ tokenType := aCharacter.
+ source next.
+ ^ tokenType
+!
+
+nextColonOrAssign
+ "colon has been read - look for = to make it an assign"
+
+ (source nextPeek == $=) ifTrue:[
+ source next.
+ tokenType := $_
+ ] ifFalse:[
+ tokenType := $:
+ ].
+ ^ tokenType
+!
+
+nextSpecial
+ "a special character has been read, look for another one.
+ also -number is handled here"
+
+ |firstChar secondChar thirdChar string p|
+
+ firstChar := source next.
+ secondChar := source peek.
+ (firstChar == $-) ifTrue:[
+ secondChar isDigit ifTrue:[
+ self nextNumber.
+ tokenValue := tokenValue negated.
+ ^ tokenType
+ ]
+ ].
+ string := firstChar asString.
+ ((typeArray at:(secondChar asciiValue)) == #special) ifTrue:[
+ (secondChar == $-) ifTrue:[
+ "special- look if minus belongs to number following"
+ p := source position.
+ source next.
+ thirdChar := source peek.
+ source position:p.
+ thirdChar isDigit ifTrue:[
+ tokenName := string.
+ tokenType := #BinaryOperator.
+ ^ tokenType
+ ]
+ ].
+ source next.
+ string := string copyWith:secondChar
+ ].
+ tokenName := string.
+ tokenType := #BinaryOperator.
+ ^ tokenType
+!
+
+nextCharacter
+ "a $ has been read - return a character token"
+
+ |nextChar|
+
+ source next.
+ nextChar := source next.
+ nextChar notNil ifTrue:[
+ tokenValue := nextChar.
+ tokenType := #Character
+ ] ifFalse:[
+ tokenType := #EOF
+ ].
+ ^ tokenType
+!
+
+nextMantissa:radix
+ |nextChar value factor|
+
+ value := 0.
+ factor := 1.0 / radix.
+ nextChar := source peek.
+ [(nextChar notNil and:[nextChar isDigitRadix:radix])] whileTrue:[
+ value := value + (nextChar digitValue * factor).
+ factor := factor / radix.
+ nextChar := source nextPeek
+ ].
+ ^ value
+!
+
+nextNumber
+ |nextChar value radix s|
+
+ radix := 10.
+ value := Integer readFrom:source radix:radix.
+ nextChar := source peek.
+ (nextChar == $r) ifTrue:[
+ radix := value.
+ source next.
+ value := Integer readFrom:source radix:radix.
+ nextChar := source peek
+ ].
+ (nextChar == $.) ifTrue:[
+ nextChar := source nextPeek.
+ (nextChar notNil and:[nextChar isDigitRadix:radix]) ifTrue:[
+ value := value asFloat + (self nextMantissa:radix).
+ nextChar := source peek
+ ] ifFalse:[
+ peekChar := $.
+ ]
+ ].
+ (nextChar == $e) ifTrue:[
+ nextChar := source nextPeek.
+ (nextChar notNil and:[(nextChar isDigitRadix:radix) or:['+-' includes:nextChar]]) ifTrue:[
+ s := 1.
+ (nextChar == $+) ifTrue:[
+ nextChar := source nextPeek
+ ] ifFalse:[
+ (nextChar == $-) ifTrue:[
+ nextChar := source nextPeek.
+ s := s negated
+ ]
+ ].
+ value := value asFloat
+ * (10.0 raisedToInteger:((Integer readFrom:source radix:radix) * s))
+ ]
+ ].
+ tokenValue := value.
+ (value isMemberOf:Float) ifTrue:[
+ tokenType := #Float
+ ] ifFalse:[
+ tokenType := #Integer
+ ].
+ ^ tokenType
+!
+
+nextId
+ |nextChar string oldString
+ index "{ Class: SmallInteger }"
+ max "{ Class: SmallInteger }" |
+
+ nextChar := source peek.
+ string := String new:10.
+ index := 0.
+ max := 10.
+ [true] whileTrue:[
+ (nextChar notNil and:[nextChar isAlphaNumeric]) ifFalse:[
+ ^ string copyFrom:1 to:index
+ ].
+ (index == max) ifTrue:[
+ oldString := string.
+ string := String new:(max * 2).
+ string replaceFrom:1 to:max with:oldString.
+ max := max * 2
+ ].
+ index := index + 1.
+ string at:index put:nextChar.
+ nextChar := source nextPeek
+ ]
+!
+
+nextIdentifier
+ |nextChar string firstChar|
+
+ string := source nextWord "self nextId".
+ nextChar := source peek.
+ (nextChar == $:) ifTrue:[
+ source next.
+ (source peek == $=) ifFalse:[
+ tokenName := string copyWith:nextChar.
+ tokenType := #Keyword.
+ ^ self
+ ].
+ peekChar := $_
+ ].
+ firstChar := string at:1.
+ (firstChar == $s) ifTrue:[
+ (string = 'self') ifTrue:[tokenType := #Self. ^self].
+ (string = 'super') ifTrue:[tokenType := #Super. ^self]
+ ].
+ (firstChar == $n) ifTrue:[
+ (string = 'nil') ifTrue:[tokenType := #Nil. ^self]
+ ].
+ (firstChar == $t) ifTrue:[
+ (string = 'true') ifTrue:[tokenType := #True. ^self].
+ (string = 'thisContext') ifTrue:[tokenType := #ThisContext. ^self]
+ ].
+ (firstChar == $f) ifTrue:[
+ (string = 'false') ifTrue:[tokenType := #False. ^self]
+ ].
+ tokenName := string.
+ tokenType := #Identifier.
+ ^ tokenType
+!
+
+nextPrimitive
+ |nextChar inPrimitive string
+ index "{ Class: SmallInteger }"
+ len "{ Class: SmallInteger }" |
+
+ nextChar := source nextPeek.
+ string := String new:500.
+ len := 500.
+ index := 1.
+ (nextChar == ${) ifTrue:[
+ nextChar := source nextPeek.
+ inPrimitive := true.
+ [inPrimitive] whileTrue:[
+ [nextChar == $%] whileFalse:[
+ string at:index put:nextChar.
+ (index == len) ifTrue:[
+ string := string , (String new:len).
+ len := len * 2
+ ].
+ index := index + 1.
+ nextChar := source next
+ ].
+ (source peek == $}) ifTrue:[
+ inPrimitive := false
+ ] ifFalse:[
+ string at:index put:nextChar.
+ (index == len) ifTrue:[
+ string := string , (String new:len).
+ len := len * 2
+ ].
+ index := index + 1.
+ nextChar := source next
+ ]
+ ].
+ source next.
+ tokenValue := string copyFrom:1 to:(index - 1).
+ tokenType := #Primitive.
+ tokenLineNr := tokenLineNr + (tokenValue occurrencesOf:(Character cr)).
+ ^ tokenType
+ ].
+
+ "a % alone is a binary operator"
+ tokenName := '%'.
+ tokenType := #BinaryOperator.
+ ^ tokenType.
+"
+ self syntaxError:('invalid character: ''' , nextChar asString , '''')
+ position:tokenPosition to:(tokenPosition + 1).
+ ^ #Error
+"
+!
+
+nextHash
+ |nextChar string|
+
+ tokenType := #Symbol.
+ nextChar := source nextPeek.
+ nextChar notNil ifTrue:[
+ nextChar isAlphaNumeric ifTrue:[
+ string := ''.
+ [nextChar notNil and:[nextChar isAlphaNumeric]] whileTrue:[
+ string := string , (source nextWord "self nextId").
+ nextChar := source peek.
+ (nextChar == $:) ifFalse:[
+ tokenValue := string asSymbol.
+ ^ self
+ ].
+ string := string copyWith:nextChar.
+ nextChar := source nextPeek
+ ].
+ tokenValue := string asSymbol.
+ ^ tokenType
+ ].
+ (nextChar == $( ) ifTrue:[
+ source next.
+ tokenType := #HashLeftParen.
+ ^ tokenType
+ ].
+ (nextChar == $[ ) ifTrue:[
+ "it seems that ST-80 supports Constant ByteArrays as #[...]
+ (seen in a PD program)"
+ source next.
+ tokenType := #HashLeftBrack.
+ ^ tokenType
+ ].
+ (nextChar == $' ) ifTrue:[
+ "it seems that ST-80 supports arbitrary symbols as #'...'
+ (seen in a PD program)"
+ self nextString.
+ tokenValue := tokenValue asSymbol.
+ tokenType := #Symbol.
+ ^ tokenType
+ ].
+ ((typeArray at:(nextChar asciiValue)) == #special) ifTrue:[
+ string := source next asString.
+ nextChar := source peek.
+ nextChar notNil ifTrue:[
+ ((typeArray at:(nextChar asciiValue)) == #special) ifTrue:[
+ source next.
+ string := string copyWith:nextChar
+ ]
+ ].
+ tokenValue := string asSymbol.
+ ^ tokenType
+ ]
+ ].
+ self syntaxError:'unexpected end-of-input in Symbol'
+ position:tokenPosition to:(tokenPosition + 1).
+ ^ #Error
+!
+
+nextString
+ |nextChar string pos
+ index "{ Class: SmallInteger }"
+ len "{ Class: SmallInteger }"
+ inString|
+
+ string := String new:20.
+ len := 20.
+ index := 1.
+ pos := source position.
+ source next.
+ nextChar := source next.
+ inString := true.
+
+ [inString] whileTrue:[
+ nextChar isNil ifTrue:[
+ self syntaxError:'unexpected end-of-input in String'
+ position:pos to:(source position - 1).
+ tokenType := #EOF.
+ ^ tokenType
+ ].
+ (nextChar == Character cr) ifTrue:[
+ tokenLineNr := tokenLineNr + 1
+ ].
+ (nextChar == Character quote) ifTrue:[
+ (source peek == Character quote) ifTrue:[
+ source next
+ ] ifFalse:[
+ inString := false
+ ]
+ ].
+ inString ifTrue:[
+ string at:index put:nextChar.
+ (index == len) ifTrue:[
+ string := string , (String new:len).
+ len := len * 2
+ ].
+ index := index + 1.
+ nextChar := source next
+ ]
+ ].
+ tokenValue := string copyFrom:1 to:(index - 1).
+ tokenType := #String.
+ ^ tokenType
+! !
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/StatNode.st Fri Jul 16 11:38:57 1993 +0200
@@ -0,0 +1,122 @@
+"
+ COPYRIGHT (c) 1989-93 by Claus Gittinger
+ All Rights Reserved
+
+ This software is furnished under a license and may be used
+ only in accordance with the terms of that license and with the
+ inclusion of the above copyright notice. This software may not
+ be provided or otherwise made available to, or used by, any
+ other person. No title to or ownership of the software is
+ hereby transferred.
+"
+
+ParseNode subclass:#StatementNode
+ instanceVariableNames:'expression nextStatement'
+ classVariableNames:''
+ poolDictionaries:''
+ category:'System-Compiler-Support'
+!
+
+StatementNode comment:'
+
+COPYRIGHT (c) 1989-93 by Claus Gittinger
+ All Rights Reserved
+
+%W% %E%
+'!
+
+!StatementNode class methodsFor:'instance creation'!
+
+expression:e
+ ^ (self basicNew) expression:e
+! !
+
+!StatementNode methodsFor:'evaluating'!
+
+evaluateExpression
+ ^ expression evaluate
+!
+
+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
+ "generate code for this statement"
+
+ expression codeOn:aStream inBlock:b
+!
+
+codeForSideEffectOn:aStream inBlock:b
+ "generate code for this statement - value not needed"
+
+ expression codeForSideEffectOn:aStream inBlock:b
+! !
+
+!StatementNode methodsFor:'accessing'!
+
+last
+ "return the last statement in a list"
+
+ |last this|
+
+ "this could be done more elegant - but with lots of recursion"
+ last := self.
+ this := self.
+ [this notNil] whileTrue:[
+ last := this.
+ this := this nextStatement
+ ].
+ ^ last
+!
+
+nextStatement:s
+ nextStatement := s
+!
+
+nextStatement
+ ^ nextStatement
+!
+
+expression:e
+ expression := e
+!
+
+expression
+ ^ expression
+! !
+
+!StatementNode methodsFor:'printing'!
+
+printOn:aStream indent:i
+ expression printOn:aStream indent:i.
+!
+
+printAllOn:aStream
+ self printAllOn:aStream indent:4
+!
+
+printAllOn:aStream indent:i
+ |thisStatement|
+
+ thisStatement := self.
+ [thisStatement notNil] whileTrue:[
+ i timesRepeat:[aStream space].
+ thisStatement printOn:aStream indent:i.
+ thisStatement nextStatement notNil ifTrue:[
+ aStream nextPut:$..
+ aStream cr.
+ ].
+ thisStatement := thisStatement nextStatement
+ ]
+! !
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/StatementNode.st Fri Jul 16 11:38:57 1993 +0200
@@ -0,0 +1,122 @@
+"
+ COPYRIGHT (c) 1989-93 by Claus Gittinger
+ All Rights Reserved
+
+ This software is furnished under a license and may be used
+ only in accordance with the terms of that license and with the
+ inclusion of the above copyright notice. This software may not
+ be provided or otherwise made available to, or used by, any
+ other person. No title to or ownership of the software is
+ hereby transferred.
+"
+
+ParseNode subclass:#StatementNode
+ instanceVariableNames:'expression nextStatement'
+ classVariableNames:''
+ poolDictionaries:''
+ category:'System-Compiler-Support'
+!
+
+StatementNode comment:'
+
+COPYRIGHT (c) 1989-93 by Claus Gittinger
+ All Rights Reserved
+
+%W% %E%
+'!
+
+!StatementNode class methodsFor:'instance creation'!
+
+expression:e
+ ^ (self basicNew) expression:e
+! !
+
+!StatementNode methodsFor:'evaluating'!
+
+evaluateExpression
+ ^ expression evaluate
+!
+
+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
+ "generate code for this statement"
+
+ expression codeOn:aStream inBlock:b
+!
+
+codeForSideEffectOn:aStream inBlock:b
+ "generate code for this statement - value not needed"
+
+ expression codeForSideEffectOn:aStream inBlock:b
+! !
+
+!StatementNode methodsFor:'accessing'!
+
+last
+ "return the last statement in a list"
+
+ |last this|
+
+ "this could be done more elegant - but with lots of recursion"
+ last := self.
+ this := self.
+ [this notNil] whileTrue:[
+ last := this.
+ this := this nextStatement
+ ].
+ ^ last
+!
+
+nextStatement:s
+ nextStatement := s
+!
+
+nextStatement
+ ^ nextStatement
+!
+
+expression:e
+ expression := e
+!
+
+expression
+ ^ expression
+! !
+
+!StatementNode methodsFor:'printing'!
+
+printOn:aStream indent:i
+ expression printOn:aStream indent:i.
+!
+
+printAllOn:aStream
+ self printAllOn:aStream indent:4
+!
+
+printAllOn:aStream indent:i
+ |thisStatement|
+
+ thisStatement := self.
+ [thisStatement notNil] whileTrue:[
+ i timesRepeat:[aStream space].
+ thisStatement printOn:aStream indent:i.
+ thisStatement nextStatement notNil ifTrue:[
+ aStream nextPut:$..
+ aStream cr.
+ ].
+ thisStatement := thisStatement nextStatement
+ ]
+! !
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/UnaryNd.st Fri Jul 16 11:38:57 1993 +0200
@@ -0,0 +1,172 @@
+"
+ COPYRIGHT (c) 1989-93 by Claus Gittinger
+ All Rights Reserved
+
+ This software is furnished under a license and may be used
+ only in accordance with the terms of that license and with the
+ inclusion of the above copyright notice. This software may not
+ be provided or otherwise made available to, or used by, any
+ other person. No title to or ownership of the software is
+ hereby transferred.
+"
+
+MessageNode subclass:#UnaryNode
+ instanceVariableNames:''
+ classVariableNames:''
+ poolDictionaries:''
+ category:'System-Compiler-Support'
+!
+
+UnaryNode comment:'
+
+COPYRIGHT (c) 1989-93 by Claus Gittinger
+ All Rights Reserved
+
+%W% %E%
+'!
+
+!UnaryNode class methodsFor:'instance creation'!
+
+receiver:r selector:s
+ ^ self receiver:r selector:s fold:true
+!
+
+receiver:r selector:s fold:folding
+ |result recVal sym|
+
+"
+ The constant folding code can usually not optimize things - this may change
+ when some kind of constant declaration is added to smalltalk.
+"
+ folding ifTrue:[
+ "do constant folding ..."
+ r isConstant ifTrue:[
+ "check if we can do it ..."
+ recVal := r evaluate.
+ s knownAsSymbol ifTrue:[
+ (recVal respondsTo:sym) 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, it will crash badly anyway ...)
+ "
+ Number domainErrorSignal handle:[:ex |
+ ex return
+ ] do:[
+ sym := s asSymbol.
+ recVal respondsToArithmetic ifTrue:[
+ (#( negated abs asPoint degreesToRadians radiansToDegrees
+ exp ln log sqrt reciprocal
+ arcCos arcSin arcTan sin cos tan) includes:sym)
+ ifTrue:[
+ result := recVal perform:sym.
+ ^ ConstantNode type:(ConstantNode typeOfConstant:result)
+ value:result
+ ]
+ ].
+ (recVal isMemberOf:Character) ifTrue:[
+ (#( asciiValue asInteger digitValue) includes:sym)
+ ifTrue:[
+ result := recVal perform:sym.
+ ^ ConstantNode type:(ConstantNode typeOfConstant:result)
+ value:result
+ ]
+ ].
+ (recVal isMemberOf:String) ifTrue:[
+ (sym == #withCRs) ifTrue:[
+ result := recVal perform:sym.
+ ^ ConstantNode type:(ConstantNode typeOfConstant:result)
+ value:result
+ ]
+ ].
+ ^ (self basicNew) receiver:r selector:s args:nil lineno:0
+ ].
+ "when we reach here, something went wrong (something like 0.0 log)"
+ ^ 'error occured when evaluating constant expression'
+ ]
+ ]
+ ]
+ ].
+ ^ (self basicNew) receiver:r selector:s args:nil lineno:0
+! !
+
+!UnaryNode methodsFor:'queries'!
+
+isUnaryMessage
+ ^ true
+! !
+
+!UnaryNode methodsFor:'checks'!
+
+plausibilityCheck
+ |rec arg operand|
+
+ "check for funny selector - careful to do string compare instead
+ of symbol identity compare: I dont want to introduce these as symbols
+ into the system (would make the '... is nowhere implemented' warning
+ go away."
+
+ ((selector = 'self') or:[
+ (selector = 'super') or:[
+ (Smalltalk includesKey:selector)]]) ifTrue:[
+ ^ 'funny selector; possible missing ''.'' or keyword'
+ ].
+ ^ nil
+! !
+
+!UnaryNode methodsFor:'evaluating'!
+
+evaluate
+ ^ (receiver evaluate) perform:selector
+! !
+
+!UnaryNode methodsFor:'code generation'!
+
+codeOn:aStream inBlock:b
+ "optimize
+ (a == b) not -> (a ~~ b)
+ (a ~~ b) not -> (a == b)
+ "
+ (selector == #not) ifTrue:[
+ (receiver class == BinaryNode) ifTrue:[
+ (receiver selector == #==) ifTrue:[
+ (BinaryNode receiver:(receiver receiver)
+ selector:#~~
+ arg:(receiver arg)) codeOn:aStream inBlock:b.
+ ^ self
+ ].
+ (receiver selector == #~~) ifTrue:[
+ (BinaryNode receiver:(receiver receiver)
+ selector:#==
+ arg:(receiver arg)) codeOn:aStream inBlock:b.
+ ^ self
+ ]
+ ]
+ ].
+
+ ^ super codeOn:aStream inBlock:b
+! !
+
+!UnaryNode methodsFor:'printing'!
+
+printOn:aStream indent:i
+ |needParen|
+
+ needParen := false.
+ receiver isMessage ifTrue:[
+ receiver isUnaryMessage ifFalse:[
+ needParen := true
+ ].
+ ].
+ needParen ifTrue:[
+ aStream nextPutAll:'('
+ ].
+ receiver printOn:aStream.
+ needParen ifTrue:[
+ aStream nextPutAll:') '
+ ].
+ aStream space.
+ selector printString printOn:aStream.
+" aStream space. "
+! !
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/UnaryNode.st Fri Jul 16 11:38:57 1993 +0200
@@ -0,0 +1,172 @@
+"
+ COPYRIGHT (c) 1989-93 by Claus Gittinger
+ All Rights Reserved
+
+ This software is furnished under a license and may be used
+ only in accordance with the terms of that license and with the
+ inclusion of the above copyright notice. This software may not
+ be provided or otherwise made available to, or used by, any
+ other person. No title to or ownership of the software is
+ hereby transferred.
+"
+
+MessageNode subclass:#UnaryNode
+ instanceVariableNames:''
+ classVariableNames:''
+ poolDictionaries:''
+ category:'System-Compiler-Support'
+!
+
+UnaryNode comment:'
+
+COPYRIGHT (c) 1989-93 by Claus Gittinger
+ All Rights Reserved
+
+%W% %E%
+'!
+
+!UnaryNode class methodsFor:'instance creation'!
+
+receiver:r selector:s
+ ^ self receiver:r selector:s fold:true
+!
+
+receiver:r selector:s fold:folding
+ |result recVal sym|
+
+"
+ The constant folding code can usually not optimize things - this may change
+ when some kind of constant declaration is added to smalltalk.
+"
+ folding ifTrue:[
+ "do constant folding ..."
+ r isConstant ifTrue:[
+ "check if we can do it ..."
+ recVal := r evaluate.
+ s knownAsSymbol ifTrue:[
+ (recVal respondsTo:sym) 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, it will crash badly anyway ...)
+ "
+ Number domainErrorSignal handle:[:ex |
+ ex return
+ ] do:[
+ sym := s asSymbol.
+ recVal respondsToArithmetic ifTrue:[
+ (#( negated abs asPoint degreesToRadians radiansToDegrees
+ exp ln log sqrt reciprocal
+ arcCos arcSin arcTan sin cos tan) includes:sym)
+ ifTrue:[
+ result := recVal perform:sym.
+ ^ ConstantNode type:(ConstantNode typeOfConstant:result)
+ value:result
+ ]
+ ].
+ (recVal isMemberOf:Character) ifTrue:[
+ (#( asciiValue asInteger digitValue) includes:sym)
+ ifTrue:[
+ result := recVal perform:sym.
+ ^ ConstantNode type:(ConstantNode typeOfConstant:result)
+ value:result
+ ]
+ ].
+ (recVal isMemberOf:String) ifTrue:[
+ (sym == #withCRs) ifTrue:[
+ result := recVal perform:sym.
+ ^ ConstantNode type:(ConstantNode typeOfConstant:result)
+ value:result
+ ]
+ ].
+ ^ (self basicNew) receiver:r selector:s args:nil lineno:0
+ ].
+ "when we reach here, something went wrong (something like 0.0 log)"
+ ^ 'error occured when evaluating constant expression'
+ ]
+ ]
+ ]
+ ].
+ ^ (self basicNew) receiver:r selector:s args:nil lineno:0
+! !
+
+!UnaryNode methodsFor:'queries'!
+
+isUnaryMessage
+ ^ true
+! !
+
+!UnaryNode methodsFor:'checks'!
+
+plausibilityCheck
+ |rec arg operand|
+
+ "check for funny selector - careful to do string compare instead
+ of symbol identity compare: I dont want to introduce these as symbols
+ into the system (would make the '... is nowhere implemented' warning
+ go away."
+
+ ((selector = 'self') or:[
+ (selector = 'super') or:[
+ (Smalltalk includesKey:selector)]]) ifTrue:[
+ ^ 'funny selector; possible missing ''.'' or keyword'
+ ].
+ ^ nil
+! !
+
+!UnaryNode methodsFor:'evaluating'!
+
+evaluate
+ ^ (receiver evaluate) perform:selector
+! !
+
+!UnaryNode methodsFor:'code generation'!
+
+codeOn:aStream inBlock:b
+ "optimize
+ (a == b) not -> (a ~~ b)
+ (a ~~ b) not -> (a == b)
+ "
+ (selector == #not) ifTrue:[
+ (receiver class == BinaryNode) ifTrue:[
+ (receiver selector == #==) ifTrue:[
+ (BinaryNode receiver:(receiver receiver)
+ selector:#~~
+ arg:(receiver arg)) codeOn:aStream inBlock:b.
+ ^ self
+ ].
+ (receiver selector == #~~) ifTrue:[
+ (BinaryNode receiver:(receiver receiver)
+ selector:#==
+ arg:(receiver arg)) codeOn:aStream inBlock:b.
+ ^ self
+ ]
+ ]
+ ].
+
+ ^ super codeOn:aStream inBlock:b
+! !
+
+!UnaryNode methodsFor:'printing'!
+
+printOn:aStream indent:i
+ |needParen|
+
+ needParen := false.
+ receiver isMessage ifTrue:[
+ receiver isUnaryMessage ifFalse:[
+ needParen := true
+ ].
+ ].
+ needParen ifTrue:[
+ aStream nextPutAll:'('
+ ].
+ receiver printOn:aStream.
+ needParen ifTrue:[
+ aStream nextPutAll:') '
+ ].
+ aStream space.
+ selector printString printOn:aStream.
+" aStream space. "
+! !
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/UndefVar.st Fri Jul 16 11:38:57 1993 +0200
@@ -0,0 +1,99 @@
+"
+ COPYRIGHT (c) 1993 by Claus Gittinger
+ All Rights Reserved
+
+ This software is furnished under a license and may be used
+ only in accordance with the terms of that license and with the
+ inclusion of the above copyright notice. This software may not
+ be provided or otherwise made available to, or used by, any
+ other person. No title to or ownership of the software is
+ hereby transferred.
+"
+
+Object subclass:#UndefinedVariable
+ instanceVariableNames:'name'
+ classVariableNames:''
+ poolDictionaries:''
+ category:'System-Compiler-Support'
+!
+
+UndefinedVariable comment:'
+
+COPYRIGHT (c) 1993 by Claus Gittinger
+ All Rights Reserved
+
+This class exists solely for the error message when accessing undefined
+variables - instead of returning nil, the compiler returns an instance
+of this class, which will not understand ANY message.
+The error message will then be "UndefinedVariable ..." instead of
+"UndefineObject ..."
+
+%W% %E%
+'!
+
+!UndefinedVariable class methodsFor:'instance creation'!
+
+name:aString
+ ^ (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:'catching messages'!
+
+class
+ ^ self
+!
+
+methods
+ self methodError
+!
+
+methodsFor:arg
+ self methodError
+!
+
+subclass:t instanceVariableNames:f classVariableNames:d poolDictionaries:s
+ self subclassingError
+!
+
+subclass:t instanceVariableNames:f classVariableNames:d poolDictionaries:s category:cat
+ self subclassingError
+!
+
+variableByteSubclass:t instanceVariableNames:f
+ classVariableNames:d poolDictionaries:s category:cat
+ self subclassingError
+!
+
+variableSubclass:t instanceVariableNames:f
+ classVariableNames:d poolDictionaries:s category:cat
+ self subclassingError
+!
+
+variableWordSubclass:t instanceVariableNames:f
+ classVariableNames:d poolDictionaries:s category:cat
+ self subclassingError
+! !
+
+!UndefinedVariable methodsFor:'private accessing'!
+
+setName:aString
+ name := aString
+! !
+
+!UndefinedVariable methodsFor:'printing & storing'!
+
+printString
+ "return a string for printing myself"
+
+ ^ 'UndefinedVariable(' , name , ')'
+! !
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/UndefinedVariable.st Fri Jul 16 11:38:57 1993 +0200
@@ -0,0 +1,99 @@
+"
+ COPYRIGHT (c) 1993 by Claus Gittinger
+ All Rights Reserved
+
+ This software is furnished under a license and may be used
+ only in accordance with the terms of that license and with the
+ inclusion of the above copyright notice. This software may not
+ be provided or otherwise made available to, or used by, any
+ other person. No title to or ownership of the software is
+ hereby transferred.
+"
+
+Object subclass:#UndefinedVariable
+ instanceVariableNames:'name'
+ classVariableNames:''
+ poolDictionaries:''
+ category:'System-Compiler-Support'
+!
+
+UndefinedVariable comment:'
+
+COPYRIGHT (c) 1993 by Claus Gittinger
+ All Rights Reserved
+
+This class exists solely for the error message when accessing undefined
+variables - instead of returning nil, the compiler returns an instance
+of this class, which will not understand ANY message.
+The error message will then be "UndefinedVariable ..." instead of
+"UndefineObject ..."
+
+%W% %E%
+'!
+
+!UndefinedVariable class methodsFor:'instance creation'!
+
+name:aString
+ ^ (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:'catching messages'!
+
+class
+ ^ self
+!
+
+methods
+ self methodError
+!
+
+methodsFor:arg
+ self methodError
+!
+
+subclass:t instanceVariableNames:f classVariableNames:d poolDictionaries:s
+ self subclassingError
+!
+
+subclass:t instanceVariableNames:f classVariableNames:d poolDictionaries:s category:cat
+ self subclassingError
+!
+
+variableByteSubclass:t instanceVariableNames:f
+ classVariableNames:d poolDictionaries:s category:cat
+ self subclassingError
+!
+
+variableSubclass:t instanceVariableNames:f
+ classVariableNames:d poolDictionaries:s category:cat
+ self subclassingError
+!
+
+variableWordSubclass:t instanceVariableNames:f
+ classVariableNames:d poolDictionaries:s category:cat
+ self subclassingError
+! !
+
+!UndefinedVariable methodsFor:'private accessing'!
+
+setName:aString
+ name := aString
+! !
+
+!UndefinedVariable methodsFor:'printing & storing'!
+
+printString
+ "return a string for printing myself"
+
+ ^ 'UndefinedVariable(' , name , ')'
+! !
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/Variable.st Fri Jul 16 11:38:57 1993 +0200
@@ -0,0 +1,58 @@
+"
+ COPYRIGHT (c) 1989-93 by Claus Gittinger
+ All Rights Reserved
+
+ This software is furnished under a license and may be used
+ only in accordance with the terms of that license and with the
+ inclusion of the above copyright notice. This software may not
+ be provided or otherwise made available to, or used by, any
+ other person. No title to or ownership of the software is
+ hereby transferred.
+"
+
+Object subclass:#Variable
+ instanceVariableNames:'value name used'
+ classVariableNames: ''
+ poolDictionaries:''
+ category:'System-Compiler-Support'
+!
+
+Variable comment:'
+
+COPYRIGHT (c) 1989-92 by Claus Gittinger
+ All Rights Reserved
+
+%W% %E%
+'!
+
+!Variable class methodsFor:'instance creation'!
+
+name:name
+ ^ (self new) name:name
+! !
+
+!Variable methodsFor:'accessing'!
+
+value:v
+ value := v
+!
+
+name:aString
+ name := aString
+!
+
+name
+ ^ name
+!
+
+value
+ ^ value
+!
+
+used:aBoolean
+ used := aBoolean
+!
+
+used
+ ^ used
+! !