--- a/BCompiler.st Wed Mar 30 12:09:50 1994 +0200
+++ b/BCompiler.st Wed Mar 30 12:10:24 1994 +0200
@@ -26,31 +26,39 @@
COPYRIGHT (c) 1989 by Claus Gittinger
All Rights Reserved
-$Header: /cvs/stx/stx/libcomp/Attic/BCompiler.st,v 1.9 1994-02-25 12:50:45 claus Exp $
+$Header: /cvs/stx/stx/libcomp/Attic/BCompiler.st,v 1.10 1994-03-30 10:09:41 claus Exp $
'!
!ByteCodeCompiler class methodsFor:'documentation'!
documentation
"
-This class performs compilation into ByteCodes.
-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.
+ This class performs compilation into ByteCodes.
+ 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 ...
+ (the intermediate step through symbolic codes is for debugging
+ only - it will vanish)
+
+ There are many dependencies to the run-time-system (especially the
+ interpreter) in here - be careful when playing around ...
-Instance variables:
+ 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
+ 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:
+ lineno <Boolean> return value of byteCodeFor:
+ maxStackDepth <SmallInteger> stack need of method
+ relocList <Array> used temporary for relocation
+
+ Class variables:
+
+ JumpToAbsJump <Dictionary> internal table to map opcodes
"
! !
@@ -128,10 +136,13 @@
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 symbolicCodeArray oldMethod|
+ |compiler newMethod tree lits symbolicCodeArray oldMethod lazy|
aString isNil ifTrue:[^ nil].
+ "lazy compilation is EXPERIMENTAL"
+ lazy := (LazyCompilation == true) and:[install].
+
"create a compiler, let it parse and create the parsetree"
compiler := self for:(ReadStream on:aString).
@@ -147,15 +158,17 @@
oldMethod := aClass compiledMethodAt:(compiler selector).
oldMethod notNil ifTrue:[
oldMethod source = aString ifTrue:[
- SilentLoading ifFalse:[
+ Smalltalk silentLoading == true ifFalse:[
Transcript showCr:('unchanged: ',aClass name,' ',compiler selector)
].
^ oldMethod
]
]
].
- tree := compiler parseMethodBody.
- compiler tree:tree.
+ lazy ifFalse:[
+ tree := compiler parseMethodBody.
+ compiler tree:tree.
+ ]
].
(compiler errorFlag or:[tree == #Error]) ifTrue:[
@@ -166,11 +179,28 @@
^ #Error
].
+ "if no error and also no selector ..."
compiler selector isNil ifTrue:[
- "it was just a comment or other empty stuff"
+ "... it was just a comment or other empty stuff"
^ nil
].
+ "will add freak-out support here soon ..."
+ compiler hasPrimitiveCode ifTrue:[
+ Transcript showCr:'cannot compile primitives (yet)'.
+ ^ #Error
+ ].
+
+ "EXPERIMENTAL: quick loading"
+ lazy ifTrue:[
+ newMethod := LazyMethod new.
+ newMethod source:aString.
+ newMethod category:cat.
+
+ aClass addSelector:(compiler selector) withLazyMethod:newMethod.
+ ^ newMethod
+ ].
+
"produce symbolic code first"
symbolicCodeArray := compiler genSymbolicCode.
@@ -182,6 +212,8 @@
^ #Error
].
+ "take this, producing bytecode
+ (someone willin' to make machine code :-)"
((compiler genByteCodeFrom:symbolicCodeArray) == #Error) ifTrue:[
compiler selector notNil ifTrue:[
Transcript show:(compiler selector,' ')
@@ -200,7 +232,13 @@
newMethod literals:lits
].
newMethod byteCode:(compiler code).
- newMethod source:aString.
+
+ "if there where any corrections, install the updated source"
+ compiler correctedSource notNil ifTrue:[
+ newMethod source:compiler correctedSource
+ ] ifFalse:[
+ newMethod source:aString.
+ ].
newMethod category:cat.
newMethod numberOfMethodVars:(compiler numberOfMethodVars).
newMethod numberOfMethodArgs:(compiler numberOfMethodArgs).
@@ -210,7 +248,7 @@
aClass addSelector:(compiler selector) withMethod:newMethod
].
- SilentLoading ifFalse:[
+ Smalltalk silentLoading == true ifFalse:[
Transcript showCr:('compiled: ',aClass name,' ',compiler selector)
].
@@ -276,15 +314,15 @@
^ codeStream contents
!
-checkForPrimitiveCode:primNr
+checkForPrimitiveCode:nr
"this was added to allow emulation of (some) ST-80
primitives (to fileIn Remote-Package)"
|cls sel|
- (primNr == 75) ifTrue:[ cls := Object. sel := #identityHash ].
- (primNr == 110) ifTrue:[ cls := Object. sel := #== ].
- (primNr == 111) ifTrue:[ cls := Object. sel := #class ].
+ (nr == 75) ifTrue:[ cls := Object. sel := #identityHash ].
+ (nr == 110) ifTrue:[ cls := Object. sel := #== ].
+ (nr == 111) ifTrue:[ cls := Object. sel := #class ].
cls notNil ifTrue:[
^ (cls compiledMethodAt:sel) code
].
--- a/BlockNode.st Wed Mar 30 12:09:50 1994 +0200
+++ b/BlockNode.st Wed Mar 30 12:10:24 1994 +0200
@@ -26,7 +26,7 @@
implement interpreted blocks
-$Header: /cvs/stx/stx/libcomp/BlockNode.st,v 1.5 1994-02-25 12:51:06 claus Exp $
+$Header: /cvs/stx/stx/libcomp/BlockNode.st,v 1.6 1994-03-30 10:09:44 claus Exp $
'!
!BlockNode class methodsFor:'instance creation'!
@@ -38,6 +38,7 @@
!BlockNode methodsFor:'private accessing'!
setArguments:argList home:h variables:vars
+ inlineBlock := false.
needsHome := false.
blockArgs := argList.
home := h.
@@ -387,6 +388,13 @@
(aStream contents) at:pos+1 put:(aStream position)
!
+codeForSideEffectOn:aStream inBlock:b
+ "generate code for this statement - value not needed.
+ For blocks, no code is generated at all."
+
+ ^ self
+!
+
codeInlineOn:aStream inBlock:b valueNeeded:valueNeeded
|thisStatement nextStatement|
@@ -439,12 +447,12 @@
cheapy := Block code:nil
byteCode:(ByteArray with:(ByteCodeCompiler byteCodeFor:#pushNil)
- with:(ByteCodeCompiler byteCodeFor:#blockRetTop))
+ with:(ByteCodeCompiler byteCodeFor:#blockRetTop))
nargs:(blockArgs size)
sourcePosition:nil
initialPC:nil
literals:nil
- dynamic:false.
+ dynamic:false.
^ ConstantNode type:#Block value:cheapy
].
@@ -458,14 +466,14 @@
val == 0 ifTrue:[
"a [0]-block"
- code := ByteArray with:(ByteCodeCompiler byteCodeFor:#push0)
- with:(ByteCodeCompiler byteCodeFor:#blockRetTop).
+ code := ByteArray with:(ByteCodeCompiler byteCodeFor:#push0)
+ with:(ByteCodeCompiler byteCodeFor:#blockRetTop).
].
val == 1 ifTrue:[
"a [1]-block"
- code := ByteArray with:(ByteCodeCompiler byteCodeFor:#push1)
- with:(ByteCodeCompiler byteCodeFor:#blockRetTop).
+ code := ByteArray with:(ByteCodeCompiler byteCodeFor:#push1)
+ with:(ByteCodeCompiler byteCodeFor:#blockRetTop).
].
val == true ifTrue:[
@@ -496,7 +504,7 @@
sourcePosition:nil
initialPC:nil
literals:nil
- dynamic:false.
+ dynamic:false.
^ ConstantNode type:#Block value:cheapy
].
--- a/ByteCodeCompiler.st Wed Mar 30 12:09:50 1994 +0200
+++ b/ByteCodeCompiler.st Wed Mar 30 12:10:24 1994 +0200
@@ -26,31 +26,39 @@
COPYRIGHT (c) 1989 by Claus Gittinger
All Rights Reserved
-$Header: /cvs/stx/stx/libcomp/ByteCodeCompiler.st,v 1.9 1994-02-25 12:50:45 claus Exp $
+$Header: /cvs/stx/stx/libcomp/ByteCodeCompiler.st,v 1.10 1994-03-30 10:09:41 claus Exp $
'!
!ByteCodeCompiler class methodsFor:'documentation'!
documentation
"
-This class performs compilation into ByteCodes.
-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.
+ This class performs compilation into ByteCodes.
+ 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 ...
+ (the intermediate step through symbolic codes is for debugging
+ only - it will vanish)
+
+ There are many dependencies to the run-time-system (especially the
+ interpreter) in here - be careful when playing around ...
-Instance variables:
+ 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
+ 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:
+ lineno <Boolean> return value of byteCodeFor:
+ maxStackDepth <SmallInteger> stack need of method
+ relocList <Array> used temporary for relocation
+
+ Class variables:
+
+ JumpToAbsJump <Dictionary> internal table to map opcodes
"
! !
@@ -128,10 +136,13 @@
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 symbolicCodeArray oldMethod|
+ |compiler newMethod tree lits symbolicCodeArray oldMethod lazy|
aString isNil ifTrue:[^ nil].
+ "lazy compilation is EXPERIMENTAL"
+ lazy := (LazyCompilation == true) and:[install].
+
"create a compiler, let it parse and create the parsetree"
compiler := self for:(ReadStream on:aString).
@@ -147,15 +158,17 @@
oldMethod := aClass compiledMethodAt:(compiler selector).
oldMethod notNil ifTrue:[
oldMethod source = aString ifTrue:[
- SilentLoading ifFalse:[
+ Smalltalk silentLoading == true ifFalse:[
Transcript showCr:('unchanged: ',aClass name,' ',compiler selector)
].
^ oldMethod
]
]
].
- tree := compiler parseMethodBody.
- compiler tree:tree.
+ lazy ifFalse:[
+ tree := compiler parseMethodBody.
+ compiler tree:tree.
+ ]
].
(compiler errorFlag or:[tree == #Error]) ifTrue:[
@@ -166,11 +179,28 @@
^ #Error
].
+ "if no error and also no selector ..."
compiler selector isNil ifTrue:[
- "it was just a comment or other empty stuff"
+ "... it was just a comment or other empty stuff"
^ nil
].
+ "will add freak-out support here soon ..."
+ compiler hasPrimitiveCode ifTrue:[
+ Transcript showCr:'cannot compile primitives (yet)'.
+ ^ #Error
+ ].
+
+ "EXPERIMENTAL: quick loading"
+ lazy ifTrue:[
+ newMethod := LazyMethod new.
+ newMethod source:aString.
+ newMethod category:cat.
+
+ aClass addSelector:(compiler selector) withLazyMethod:newMethod.
+ ^ newMethod
+ ].
+
"produce symbolic code first"
symbolicCodeArray := compiler genSymbolicCode.
@@ -182,6 +212,8 @@
^ #Error
].
+ "take this, producing bytecode
+ (someone willin' to make machine code :-)"
((compiler genByteCodeFrom:symbolicCodeArray) == #Error) ifTrue:[
compiler selector notNil ifTrue:[
Transcript show:(compiler selector,' ')
@@ -200,7 +232,13 @@
newMethod literals:lits
].
newMethod byteCode:(compiler code).
- newMethod source:aString.
+
+ "if there where any corrections, install the updated source"
+ compiler correctedSource notNil ifTrue:[
+ newMethod source:compiler correctedSource
+ ] ifFalse:[
+ newMethod source:aString.
+ ].
newMethod category:cat.
newMethod numberOfMethodVars:(compiler numberOfMethodVars).
newMethod numberOfMethodArgs:(compiler numberOfMethodArgs).
@@ -210,7 +248,7 @@
aClass addSelector:(compiler selector) withMethod:newMethod
].
- SilentLoading ifFalse:[
+ Smalltalk silentLoading == true ifFalse:[
Transcript showCr:('compiled: ',aClass name,' ',compiler selector)
].
@@ -276,15 +314,15 @@
^ codeStream contents
!
-checkForPrimitiveCode:primNr
+checkForPrimitiveCode:nr
"this was added to allow emulation of (some) ST-80
primitives (to fileIn Remote-Package)"
|cls sel|
- (primNr == 75) ifTrue:[ cls := Object. sel := #identityHash ].
- (primNr == 110) ifTrue:[ cls := Object. sel := #== ].
- (primNr == 111) ifTrue:[ cls := Object. sel := #class ].
+ (nr == 75) ifTrue:[ cls := Object. sel := #identityHash ].
+ (nr == 110) ifTrue:[ cls := Object. sel := #== ].
+ (nr == 111) ifTrue:[ cls := Object. sel := #class ].
cls notNil ifTrue:[
^ (cls compiledMethodAt:sel) code
].
--- a/MessageNd.st Wed Mar 30 12:09:50 1994 +0200
+++ b/MessageNd.st Wed Mar 30 12:10:24 1994 +0200
@@ -21,7 +21,7 @@
COPYRIGHT (c) 1989 by Claus Gittinger
All Rights Reserved
-$Header: /cvs/stx/stx/libcomp/Attic/MessageNd.st,v 1.7 1994-02-25 12:51:37 claus Exp $
+$Header: /cvs/stx/stx/libcomp/Attic/MessageNd.st,v 1.8 1994-03-30 10:09:47 claus Exp $
'!
!MessageNode class methodsFor:'instance creation'!
@@ -38,8 +38,8 @@
|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.
+ The constant folding code can usually not optimize much
+ - this may change when some kind of constant declaration is added to smalltalk.
"
folding ifTrue:[
"do constant folding ..."
@@ -48,7 +48,8 @@
selectorString knownAsSymbol ifTrue:[
selector := selectorString asSymbol.
(recNode respondsTo:selector) ifTrue:[
- "we could do much more here - but then, we need a dependency from
+ "
+ 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 ...)
@@ -152,7 +153,8 @@
!
isBuiltInUnarySelector:sel
- "return true, if unary selector sel is built in"
+ "return true, if unary selector sel is built-in.
+ (i.e. there is a single bytecode for it)"
(sel == #peek) ifTrue:[^ true].
(sel == #value) ifTrue:[^ true].
@@ -171,7 +173,8 @@
!
isBuiltIn1ArgSelector:sel
- "return true, if selector sel is built in"
+ "return true, if selector sel is built-in.
+ (i.e. there is a single bytecode for it)"
(sel == #at:) ifTrue:[^ true].
(sel == #value:) ifTrue:[^ true].
@@ -181,7 +184,8 @@
!
isBuiltIn2ArgSelector:sel
- "return true, if selector sel is built in"
+ "return true, if selector sel is built-in.
+ (i.e. there is a single bytecode for it)"
(sel == #at:put:) ifTrue:[^ true].
^ false
@@ -283,8 +287,15 @@
"
it once took me almost an hour, to find a '==' which
should have been an '=' (you cannot compare floats with ==)
- (well, I saw it 50 times but didn't think about it ...).
- reason enough to add this check here.
+ (well, I looked at the '==' at least 50 times -
+ - but didn't think about it ...).
+ thats reason enough to add this check here.
+ I will add more as heuristic knowledge increases ...
+ (send me comments on common programming errors ...)
+ "
+
+ "
+ check #== appled to Floats, Strings or Fractions
"
((selector == #==) or:[selector == #~~]) ifTrue:[
receiver isConstant ifTrue:[
@@ -312,6 +323,7 @@
].
"
+ [...] ifTrue:...
an error often occuring when you are a beginner ...
"
((selector == #ifTrue:) or:[selector == #ifFalse:]) ifTrue:[
@@ -324,7 +336,7 @@
^ 'will fail at runtime, if argument to ' , selector , ' does not evaluate to a block'
]
].
- ((selector == #ifTrue:ifFalse) or:[selector == #ifFalse:ifTrue]) ifTrue:[
+ ((selector == #ifTrue:ifFalse:) or:[selector == #ifFalse:ifTrue:]) ifTrue:[
receiver isBlock ifTrue:[
(Block canUnderstand:selector) ifFalse:[
^ 'blocks usually do not respond to ' , selector , ' messages'
@@ -337,9 +349,18 @@
^ 'will fail at runtime, if 2nd. argument to ' , selector , ' does not evaluate to a block'
]
].
+
+ "
+ (...) whileTrue:[
+ "
((selector == #whileTrue:) or:[selector == #whileFalse:]) ifTrue:[
receiver isBlock ifFalse:[
- ^ 'will fail at runtime, if receiver of ' , selector , ' does not evaluate to a block'
+ "
+ only warn, if code was originally parenthized
+ "
+ receiver parenthized ifTrue:[
+ ^ 'will fail at runtime, if receiver of ' , selector , ' does not evaluate to a block'
+ ]
].
(argArray at:1) isBlock ifFalse:[
^ 'will fail at runtime, if argument to ' , selector , ' does not evaluate to a block'
@@ -443,12 +464,12 @@
|rec sel|
rec := aReceiver.
- (rec class == BlockNode) ifTrue:[
+ (rec isBlock "class == BlockNode") ifTrue:[
rec statements nextStatement isNil ifTrue:[
rec := rec statements expression
]
].
- (rec class == UnaryNode) ifTrue:[
+ (rec isUnaryMessage "class == UnaryNode") ifTrue:[
sel := rec selector.
(sel == #isNil) ifTrue:[
(aByteCode == #trueJump) ifTrue:[^ #nilJump].
@@ -464,7 +485,7 @@
].
^ nil
].
- (rec class == BinaryNode) ifTrue:[
+ (rec isBinaryMessage "class == BinaryNode") ifTrue:[
sel := rec selector.
rec arg1 isConstant ifTrue:[
(rec arg1 value == 0) ifTrue:[
@@ -606,7 +627,7 @@
theReceiver := receiver.
- (theReceiver class == MessageNode) ifTrue:[
+ (theReceiver isMessage "class == MessageNode") ifTrue:[
subsel := theReceiver selector.
(subsel == #and:) ifTrue:[
self codeAndIfOn:aStream inBlock:b valueNeeded:valueNeeded.
@@ -832,11 +853,46 @@
isBuiltIn := false.
(nargs == 0) ifTrue:[
+ (receiver type == #ThisContext) ifTrue:[
+ valueNeeded ifFalse:[
+ "for now, only do it in methods"
+ b isNil ifTrue:[
+ (selector == #restart) ifTrue:[
+ aStream nextPut:#jump. "jump to start"
+ aStream nextPut:1.
+ ^ self
+ ].
+ ].
+ (selector == #return) ifTrue:[ "^ nil"
+ b isNil ifTrue:[
+ aStream nextPut:#retNil.
+ ] ifFalse:[
+ aStream nextPut:#pushNil.
+ aStream nextPut:#blockRetTop.
+ ].
+ ^ self
+ ].
+ ]
+ ].
isBuiltIn := self class isBuiltInUnarySelector:selector
].
(nargs == 1) ifTrue:[
- ((argArray at:1) class == BlockNode) ifTrue:[
+ (receiver type == #ThisContext) ifTrue:[
+ valueNeeded ifFalse:[
+ (selector == #return:) ifTrue:[
+ (argArray at:1) codeOn:aStream inBlock:b. "^ value"
+ b isNil ifTrue:[
+ aStream nextPut:#retTop.
+ ] ifFalse:[
+ aStream nextPut:#blockRetTop.
+ ].
+ ^ self
+ ].
+ ].
+ ].
+
+ ((argArray at:1) isBlock) ifTrue:[
((selector == #ifTrue:) or:[selector == #ifFalse:]) ifTrue:[
self codeIfOn:aStream inBlock:b valueNeeded:valueNeeded.
^ self
@@ -847,18 +903,16 @@
^ self
].
"
- receiver isConstant ifTrue:[
- receiver evaluate isNumber ifTrue:[
+ (selector == #timesRepeat:) ifTrue:[
+ (receiver isConstant and:[receiver evaluate isNumber]) 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.
+ ((selector == #whileTrue:) or:[selector == #whileFalse:]) ifTrue:[
+ (receiver isBlock) ifTrue:[
+ self codeWhileOn:aStream inBlock:b valueNeeded:valueNeeded.
^ self
]
]
@@ -867,12 +921,10 @@
].
(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.
+ ((selector == #ifTrue:ifFalse:) or:[selector == #ifFalse:ifTrue:]) ifTrue:[
+ (argArray at:1) isBlock ifTrue:[
+ (argArray at:2) isBlock ifTrue:[
+ self codeIfElseOn:aStream inBlock:b valueNeeded:valueNeeded.
^ self
]
]
--- a/MessageNode.st Wed Mar 30 12:09:50 1994 +0200
+++ b/MessageNode.st Wed Mar 30 12:10:24 1994 +0200
@@ -21,7 +21,7 @@
COPYRIGHT (c) 1989 by Claus Gittinger
All Rights Reserved
-$Header: /cvs/stx/stx/libcomp/MessageNode.st,v 1.7 1994-02-25 12:51:37 claus Exp $
+$Header: /cvs/stx/stx/libcomp/MessageNode.st,v 1.8 1994-03-30 10:09:47 claus Exp $
'!
!MessageNode class methodsFor:'instance creation'!
@@ -38,8 +38,8 @@
|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.
+ The constant folding code can usually not optimize much
+ - this may change when some kind of constant declaration is added to smalltalk.
"
folding ifTrue:[
"do constant folding ..."
@@ -48,7 +48,8 @@
selectorString knownAsSymbol ifTrue:[
selector := selectorString asSymbol.
(recNode respondsTo:selector) ifTrue:[
- "we could do much more here - but then, we need a dependency from
+ "
+ 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 ...)
@@ -152,7 +153,8 @@
!
isBuiltInUnarySelector:sel
- "return true, if unary selector sel is built in"
+ "return true, if unary selector sel is built-in.
+ (i.e. there is a single bytecode for it)"
(sel == #peek) ifTrue:[^ true].
(sel == #value) ifTrue:[^ true].
@@ -171,7 +173,8 @@
!
isBuiltIn1ArgSelector:sel
- "return true, if selector sel is built in"
+ "return true, if selector sel is built-in.
+ (i.e. there is a single bytecode for it)"
(sel == #at:) ifTrue:[^ true].
(sel == #value:) ifTrue:[^ true].
@@ -181,7 +184,8 @@
!
isBuiltIn2ArgSelector:sel
- "return true, if selector sel is built in"
+ "return true, if selector sel is built-in.
+ (i.e. there is a single bytecode for it)"
(sel == #at:put:) ifTrue:[^ true].
^ false
@@ -283,8 +287,15 @@
"
it once took me almost an hour, to find a '==' which
should have been an '=' (you cannot compare floats with ==)
- (well, I saw it 50 times but didn't think about it ...).
- reason enough to add this check here.
+ (well, I looked at the '==' at least 50 times -
+ - but didn't think about it ...).
+ thats reason enough to add this check here.
+ I will add more as heuristic knowledge increases ...
+ (send me comments on common programming errors ...)
+ "
+
+ "
+ check #== appled to Floats, Strings or Fractions
"
((selector == #==) or:[selector == #~~]) ifTrue:[
receiver isConstant ifTrue:[
@@ -312,6 +323,7 @@
].
"
+ [...] ifTrue:...
an error often occuring when you are a beginner ...
"
((selector == #ifTrue:) or:[selector == #ifFalse:]) ifTrue:[
@@ -324,7 +336,7 @@
^ 'will fail at runtime, if argument to ' , selector , ' does not evaluate to a block'
]
].
- ((selector == #ifTrue:ifFalse) or:[selector == #ifFalse:ifTrue]) ifTrue:[
+ ((selector == #ifTrue:ifFalse:) or:[selector == #ifFalse:ifTrue:]) ifTrue:[
receiver isBlock ifTrue:[
(Block canUnderstand:selector) ifFalse:[
^ 'blocks usually do not respond to ' , selector , ' messages'
@@ -337,9 +349,18 @@
^ 'will fail at runtime, if 2nd. argument to ' , selector , ' does not evaluate to a block'
]
].
+
+ "
+ (...) whileTrue:[
+ "
((selector == #whileTrue:) or:[selector == #whileFalse:]) ifTrue:[
receiver isBlock ifFalse:[
- ^ 'will fail at runtime, if receiver of ' , selector , ' does not evaluate to a block'
+ "
+ only warn, if code was originally parenthized
+ "
+ receiver parenthized ifTrue:[
+ ^ 'will fail at runtime, if receiver of ' , selector , ' does not evaluate to a block'
+ ]
].
(argArray at:1) isBlock ifFalse:[
^ 'will fail at runtime, if argument to ' , selector , ' does not evaluate to a block'
@@ -443,12 +464,12 @@
|rec sel|
rec := aReceiver.
- (rec class == BlockNode) ifTrue:[
+ (rec isBlock "class == BlockNode") ifTrue:[
rec statements nextStatement isNil ifTrue:[
rec := rec statements expression
]
].
- (rec class == UnaryNode) ifTrue:[
+ (rec isUnaryMessage "class == UnaryNode") ifTrue:[
sel := rec selector.
(sel == #isNil) ifTrue:[
(aByteCode == #trueJump) ifTrue:[^ #nilJump].
@@ -464,7 +485,7 @@
].
^ nil
].
- (rec class == BinaryNode) ifTrue:[
+ (rec isBinaryMessage "class == BinaryNode") ifTrue:[
sel := rec selector.
rec arg1 isConstant ifTrue:[
(rec arg1 value == 0) ifTrue:[
@@ -606,7 +627,7 @@
theReceiver := receiver.
- (theReceiver class == MessageNode) ifTrue:[
+ (theReceiver isMessage "class == MessageNode") ifTrue:[
subsel := theReceiver selector.
(subsel == #and:) ifTrue:[
self codeAndIfOn:aStream inBlock:b valueNeeded:valueNeeded.
@@ -832,11 +853,46 @@
isBuiltIn := false.
(nargs == 0) ifTrue:[
+ (receiver type == #ThisContext) ifTrue:[
+ valueNeeded ifFalse:[
+ "for now, only do it in methods"
+ b isNil ifTrue:[
+ (selector == #restart) ifTrue:[
+ aStream nextPut:#jump. "jump to start"
+ aStream nextPut:1.
+ ^ self
+ ].
+ ].
+ (selector == #return) ifTrue:[ "^ nil"
+ b isNil ifTrue:[
+ aStream nextPut:#retNil.
+ ] ifFalse:[
+ aStream nextPut:#pushNil.
+ aStream nextPut:#blockRetTop.
+ ].
+ ^ self
+ ].
+ ]
+ ].
isBuiltIn := self class isBuiltInUnarySelector:selector
].
(nargs == 1) ifTrue:[
- ((argArray at:1) class == BlockNode) ifTrue:[
+ (receiver type == #ThisContext) ifTrue:[
+ valueNeeded ifFalse:[
+ (selector == #return:) ifTrue:[
+ (argArray at:1) codeOn:aStream inBlock:b. "^ value"
+ b isNil ifTrue:[
+ aStream nextPut:#retTop.
+ ] ifFalse:[
+ aStream nextPut:#blockRetTop.
+ ].
+ ^ self
+ ].
+ ].
+ ].
+
+ ((argArray at:1) isBlock) ifTrue:[
((selector == #ifTrue:) or:[selector == #ifFalse:]) ifTrue:[
self codeIfOn:aStream inBlock:b valueNeeded:valueNeeded.
^ self
@@ -847,18 +903,16 @@
^ self
].
"
- receiver isConstant ifTrue:[
- receiver evaluate isNumber ifTrue:[
+ (selector == #timesRepeat:) ifTrue:[
+ (receiver isConstant and:[receiver evaluate isNumber]) 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.
+ ((selector == #whileTrue:) or:[selector == #whileFalse:]) ifTrue:[
+ (receiver isBlock) ifTrue:[
+ self codeWhileOn:aStream inBlock:b valueNeeded:valueNeeded.
^ self
]
]
@@ -867,12 +921,10 @@
].
(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.
+ ((selector == #ifTrue:ifFalse:) or:[selector == #ifFalse:ifTrue:]) ifTrue:[
+ (argArray at:1) isBlock ifTrue:[
+ (argArray at:2) isBlock ifTrue:[
+ self codeIfElseOn:aStream inBlock:b valueNeeded:valueNeeded.
^ self
]
]
--- a/ObjFLoader.st Wed Mar 30 12:09:50 1994 +0200
+++ b/ObjFLoader.st Wed Mar 30 12:10:24 1994 +0200
@@ -28,7 +28,7 @@
(goal is to allow loading of binary classes)
-$Header: /cvs/stx/stx/libcomp/Attic/ObjFLoader.st,v 1.5 1994-02-25 12:51:52 claus Exp $
+$Header: /cvs/stx/stx/libcomp/Attic/ObjFLoader.st,v 1.6 1994-03-30 10:09:51 claus Exp $
'!
%{
@@ -474,6 +474,8 @@
!
checkType:argType name:argName on:aStream
+ "generate type checking code"
+
(argType == #SmallInteger) ifTrue:[
aStream nextPutAll:'_isSmallInteger(' , argName , ')'.
^ true
@@ -482,10 +484,18 @@
aStream nextPutAll:'__isFloat(' , argName , ')'.
^ true
].
+ (argType == #Character) ifTrue:[
+ aStream nextPutAll:'__isCharacter(' , argName , ')'.
+ ^ true
+ ].
(argType == #String) ifTrue:[
aStream nextPutAll:'__isString(' , argName , ')'.
^ true
].
+ (argType == #Symbol) ifTrue:[
+ aStream nextPutAll:'__isSymbol(' , argName , ')'.
+ ^ true
+ ].
(argType == #Boolean) ifTrue:[
aStream nextPutAll:'((' , argName , '==true)'.
aStream nextPutAll:'||(' , argName , '==false))'.
@@ -504,6 +514,8 @@
!
convertStToC:stType name:argName on:aStream
+ "generate type conversion code"
+
|idx|
(stType == #SmallInteger) ifTrue:[
@@ -514,10 +526,18 @@
aStream nextPutAll:'_floatVal(' , argName , ')'.
^ true
].
+ (stType == #Character) ifTrue:[
+ aStream nextPutAll:'_characterVal(' , argName , ')'.
+ ^ true
+ ].
(stType == #String) ifTrue:[
aStream nextPutAll:'_stringVal(' , argName , ')'.
^ true
].
+ (stType == #Symbol) ifTrue:[
+ aStream nextPutAll:'_stringVal(' , argName , ')'.
+ ^ true
+ ].
(stType == #Boolean) ifTrue:[
aStream nextPutAll:'((' , argName , '==true) ? 1 : 0)'.
^ true
@@ -537,6 +557,8 @@
!
convertCToSt:stType name:argName on:aStream
+ "generate type conversion code"
+
(stType == #SmallInteger) ifTrue:[
aStream nextPutAll:'_MKSMALLINT(' , argName , ')'.
^ true
@@ -545,10 +567,18 @@
aStream nextPutAll:'_MKFLOAT(' , argName , ' COMMA_SND)'.
^ true
].
+ (stType == #Character) ifTrue:[
+ aStream nextPutAll:'_MKCHARACTER(' , argName , ')'.
+ ^ true
+ ].
(stType == #String) ifTrue:[
aStream nextPutAll:'(' , argName , ' ? _MKSTRING(' , argName , ' COMMA_SND) : nil)'.
^ true
].
+ (stType == #Symbol) ifTrue:[
+ aStream nextPutAll:'(' , argName , ' ? _MKSYMBOL(' , argName , ' COMMA_SND) : nil)'.
+ ^ true
+ ].
(stType == #Boolean) ifTrue:[
aStream nextPutAll:'(' , argName , ' ? true : false)'.
^ true
@@ -557,6 +587,8 @@
!
cTypeFor:aType
+ "return c-type for an ST-type"
+
(aType == #SmallInteger) ifTrue:[
^ 'int'
].
@@ -566,12 +598,24 @@
(aType == #Float) ifTrue:[
^ 'double'
].
+ (aType == #Character) ifTrue:[
+ ^ 'char'
+ ].
(aType == #String) ifTrue:[
^ 'char *'
].
+ (aType == #Symbol) ifTrue:[
+ ^ 'char *'
+ ].
+ (aType == #ByteArray) ifTrue:[
+ ^ 'unsigned char *'
+ ].
(aType == nil) ifTrue:[
^ 'void'
].
+ (aType == #ExternalStream) ifTrue:[
+ ^ 'void *' "actually its FILE *, but better avoid including stdio.h"
+ ].
self error:'type ' , aType, ' not supported'.
^ ''
! !
@@ -688,7 +732,7 @@
Transcript showCr:'executing: ' , unixCommand
].
- Transcript showCr:'linking ...'.
+ 'linking ...' printNewline.
(OperatingSystem executeCommand:unixCommand) ifFalse: [
errStream := FileStream oldFileNamed:'/tmp/err'.
errStream notNil ifTrue:[
@@ -708,7 +752,7 @@
^ false
].
- Transcript showCr:'link successful'.
+ 'link successful' printNewline.
OperatingSystem executeCommand:'rm /tmp/err /tmp/out'.
@@ -741,7 +785,7 @@
((newTextSize ~~ textSize) or:[newDataSize ~~ dataSize]) ifTrue:[
- Transcript showCr:'size changed after link - do it again'.
+ 'size changed after link - do it again' printNewline.
text notNil ifTrue:[text free. text := nil].
data notNil ifTrue:[data free. data := nil].
@@ -796,7 +840,7 @@
Transcript showCr:'executing: ' , unixCommand
].
- Transcript showCr:'linking ...'.
+ 'linking ...' printNewline.
(OperatingSystem executeCommand:unixCommand) ifFalse: [
errStream := FileStream oldFileNamed:'/tmp/err'.
errStream notNil ifTrue:[
@@ -816,7 +860,7 @@
^ false
].
- Transcript showCr:'link successful'.
+ 'link successful' printNewline.
OperatingSystem executeCommand:'rm /tmp/err /tmp/out'.
@@ -867,8 +911,14 @@
dataAddr := nil
].
- Transcript showCr:'loading ' , textSize printString , ' bytes at ' , (textAddr printStringRadix:16).
- Transcript showCr:'loading ' , dataSize printString , ' bytes at ' , (dataAddr printStringRadix:16).
+ Verbose ifTrue:[
+ textAddr notNil ifTrue:[
+ Transcript showCr:'loading ' , textSize printString , ' bytes at ' , (textAddr printStringRadix:16).
+ ].
+ dataAddr notNil ifTrue:[
+ Transcript showCr:'loading ' , dataSize printString , ' bytes at ' , (dataAddr printStringRadix:16).
+ ].
+ ].
(ObjectFile loadObjectFile:'a.out'
textAddr:textAddr textSize:textSize
@@ -879,7 +929,7 @@
^ false
].
- Transcript showCr:'load in successful'.
+ 'dynamic load successful' printNewline.
OperatingSystem executeCommand:'mv a.out SymbolTable'.
MySymbolTable := 'SymbolTable'.
@@ -898,15 +948,16 @@
Transcript showCr:('openDynamic: ',aFileName,' failed.').
^ nil
].
- OperatingSystem getOSType = 'sys5.4' ifTrue:[
- symName := '_' , aClassName , '_Init'
- ] ifFalse:[
- symName := '__' , aClassName , '_Init'
- ].
+ symName := '_' , aClassName , '_Init'.
initAddr := self getSymbol:symName from:handle.
initAddr isNil ifTrue:[
- Transcript showCr:('no symbol: ',symName,' in ',aFileName).
- ^ nil
+ "try with added underscore"
+ 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
@@ -926,27 +977,34 @@
Transcript showCr:('openDynamic: ',aFileName,' failed.').
^ nil
].
+
+ "load worked - now get init functions address"
+
className := OperatingSystem baseNameOf:aFileName.
(className endsWith:'.o') ifTrue:[
className := className copyTo:(className size - 2)
].
- OperatingSystem getOSType = 'sys5.4' ifTrue:[
- symName := '_' , className , '_Init'
- ] ifFalse:[
- symName := '__' , className , '_Init'
- ].
+ symName := '_' , className , '_Init'.
initAddr := self getSymbol:symName from:handle.
+
initAddr isNil ifTrue:[
- className := Smalltalk classNameForFile:className.
- OperatingSystem getOSType = 'sys5.4' ifTrue:[
- symName := '_' , className , '_Init'
- ] ifFalse:[
- symName := '__' , className , '_Init'
- ].
+ "try with added underscore"
+ symName := '__' , className , '_Init'.
initAddr := self getSymbol:symName from:handle.
initAddr isNil ifTrue:[
- Transcript showCr:('no symbol: ',symName,' in ',aFileName).
- ^ nil
+ "try className from fileName"
+ className := Smalltalk classNameForFile:className.
+ symName := '_' , className , '_Init'.
+ initAddr := self getSymbol:symName from:handle.
+ initAddr isNil ifTrue:[
+ "and with added underscore"
+ symName := '__' , className , '_Init'.
+ initAddr := self getSymbol:symName from:handle.
+ initAddr isNil ifTrue:[
+ Transcript showCr:('no symbol: ',symName,' in ',aFileName).
+ ^ nil
+ ].
+ ].
].
].
self callFunctionAt:initAddr.
@@ -1257,11 +1315,22 @@
void (*addr)();
unsigned val;
typedef void (*VOIDFUNC)();
+ int savInt;
+ extern int _immediateInterrupt;
if (_isSmallInteger(low) && _isSmallInteger(hi)) {
val = (_intVal(hi) << 16) + _intVal(low);
addr = (VOIDFUNC) val;
+
+ /*
+ * allow function to be interrupted
+ */
+ savInt = _immediateInterrupt;
+ _immediateInterrupt = 1;
+
(*addr)();
+
+ _immediateInterrupt = savInt;
}
%}
! !
--- a/ObjectFileLoader.st Wed Mar 30 12:09:50 1994 +0200
+++ b/ObjectFileLoader.st Wed Mar 30 12:10:24 1994 +0200
@@ -28,7 +28,7 @@
(goal is to allow loading of binary classes)
-$Header: /cvs/stx/stx/libcomp/ObjectFileLoader.st,v 1.5 1994-02-25 12:51:52 claus Exp $
+$Header: /cvs/stx/stx/libcomp/ObjectFileLoader.st,v 1.6 1994-03-30 10:09:51 claus Exp $
'!
%{
@@ -474,6 +474,8 @@
!
checkType:argType name:argName on:aStream
+ "generate type checking code"
+
(argType == #SmallInteger) ifTrue:[
aStream nextPutAll:'_isSmallInteger(' , argName , ')'.
^ true
@@ -482,10 +484,18 @@
aStream nextPutAll:'__isFloat(' , argName , ')'.
^ true
].
+ (argType == #Character) ifTrue:[
+ aStream nextPutAll:'__isCharacter(' , argName , ')'.
+ ^ true
+ ].
(argType == #String) ifTrue:[
aStream nextPutAll:'__isString(' , argName , ')'.
^ true
].
+ (argType == #Symbol) ifTrue:[
+ aStream nextPutAll:'__isSymbol(' , argName , ')'.
+ ^ true
+ ].
(argType == #Boolean) ifTrue:[
aStream nextPutAll:'((' , argName , '==true)'.
aStream nextPutAll:'||(' , argName , '==false))'.
@@ -504,6 +514,8 @@
!
convertStToC:stType name:argName on:aStream
+ "generate type conversion code"
+
|idx|
(stType == #SmallInteger) ifTrue:[
@@ -514,10 +526,18 @@
aStream nextPutAll:'_floatVal(' , argName , ')'.
^ true
].
+ (stType == #Character) ifTrue:[
+ aStream nextPutAll:'_characterVal(' , argName , ')'.
+ ^ true
+ ].
(stType == #String) ifTrue:[
aStream nextPutAll:'_stringVal(' , argName , ')'.
^ true
].
+ (stType == #Symbol) ifTrue:[
+ aStream nextPutAll:'_stringVal(' , argName , ')'.
+ ^ true
+ ].
(stType == #Boolean) ifTrue:[
aStream nextPutAll:'((' , argName , '==true) ? 1 : 0)'.
^ true
@@ -537,6 +557,8 @@
!
convertCToSt:stType name:argName on:aStream
+ "generate type conversion code"
+
(stType == #SmallInteger) ifTrue:[
aStream nextPutAll:'_MKSMALLINT(' , argName , ')'.
^ true
@@ -545,10 +567,18 @@
aStream nextPutAll:'_MKFLOAT(' , argName , ' COMMA_SND)'.
^ true
].
+ (stType == #Character) ifTrue:[
+ aStream nextPutAll:'_MKCHARACTER(' , argName , ')'.
+ ^ true
+ ].
(stType == #String) ifTrue:[
aStream nextPutAll:'(' , argName , ' ? _MKSTRING(' , argName , ' COMMA_SND) : nil)'.
^ true
].
+ (stType == #Symbol) ifTrue:[
+ aStream nextPutAll:'(' , argName , ' ? _MKSYMBOL(' , argName , ' COMMA_SND) : nil)'.
+ ^ true
+ ].
(stType == #Boolean) ifTrue:[
aStream nextPutAll:'(' , argName , ' ? true : false)'.
^ true
@@ -557,6 +587,8 @@
!
cTypeFor:aType
+ "return c-type for an ST-type"
+
(aType == #SmallInteger) ifTrue:[
^ 'int'
].
@@ -566,12 +598,24 @@
(aType == #Float) ifTrue:[
^ 'double'
].
+ (aType == #Character) ifTrue:[
+ ^ 'char'
+ ].
(aType == #String) ifTrue:[
^ 'char *'
].
+ (aType == #Symbol) ifTrue:[
+ ^ 'char *'
+ ].
+ (aType == #ByteArray) ifTrue:[
+ ^ 'unsigned char *'
+ ].
(aType == nil) ifTrue:[
^ 'void'
].
+ (aType == #ExternalStream) ifTrue:[
+ ^ 'void *' "actually its FILE *, but better avoid including stdio.h"
+ ].
self error:'type ' , aType, ' not supported'.
^ ''
! !
@@ -688,7 +732,7 @@
Transcript showCr:'executing: ' , unixCommand
].
- Transcript showCr:'linking ...'.
+ 'linking ...' printNewline.
(OperatingSystem executeCommand:unixCommand) ifFalse: [
errStream := FileStream oldFileNamed:'/tmp/err'.
errStream notNil ifTrue:[
@@ -708,7 +752,7 @@
^ false
].
- Transcript showCr:'link successful'.
+ 'link successful' printNewline.
OperatingSystem executeCommand:'rm /tmp/err /tmp/out'.
@@ -741,7 +785,7 @@
((newTextSize ~~ textSize) or:[newDataSize ~~ dataSize]) ifTrue:[
- Transcript showCr:'size changed after link - do it again'.
+ 'size changed after link - do it again' printNewline.
text notNil ifTrue:[text free. text := nil].
data notNil ifTrue:[data free. data := nil].
@@ -796,7 +840,7 @@
Transcript showCr:'executing: ' , unixCommand
].
- Transcript showCr:'linking ...'.
+ 'linking ...' printNewline.
(OperatingSystem executeCommand:unixCommand) ifFalse: [
errStream := FileStream oldFileNamed:'/tmp/err'.
errStream notNil ifTrue:[
@@ -816,7 +860,7 @@
^ false
].
- Transcript showCr:'link successful'.
+ 'link successful' printNewline.
OperatingSystem executeCommand:'rm /tmp/err /tmp/out'.
@@ -867,8 +911,14 @@
dataAddr := nil
].
- Transcript showCr:'loading ' , textSize printString , ' bytes at ' , (textAddr printStringRadix:16).
- Transcript showCr:'loading ' , dataSize printString , ' bytes at ' , (dataAddr printStringRadix:16).
+ Verbose ifTrue:[
+ textAddr notNil ifTrue:[
+ Transcript showCr:'loading ' , textSize printString , ' bytes at ' , (textAddr printStringRadix:16).
+ ].
+ dataAddr notNil ifTrue:[
+ Transcript showCr:'loading ' , dataSize printString , ' bytes at ' , (dataAddr printStringRadix:16).
+ ].
+ ].
(ObjectFile loadObjectFile:'a.out'
textAddr:textAddr textSize:textSize
@@ -879,7 +929,7 @@
^ false
].
- Transcript showCr:'load in successful'.
+ 'dynamic load successful' printNewline.
OperatingSystem executeCommand:'mv a.out SymbolTable'.
MySymbolTable := 'SymbolTable'.
@@ -898,15 +948,16 @@
Transcript showCr:('openDynamic: ',aFileName,' failed.').
^ nil
].
- OperatingSystem getOSType = 'sys5.4' ifTrue:[
- symName := '_' , aClassName , '_Init'
- ] ifFalse:[
- symName := '__' , aClassName , '_Init'
- ].
+ symName := '_' , aClassName , '_Init'.
initAddr := self getSymbol:symName from:handle.
initAddr isNil ifTrue:[
- Transcript showCr:('no symbol: ',symName,' in ',aFileName).
- ^ nil
+ "try with added underscore"
+ 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
@@ -926,27 +977,34 @@
Transcript showCr:('openDynamic: ',aFileName,' failed.').
^ nil
].
+
+ "load worked - now get init functions address"
+
className := OperatingSystem baseNameOf:aFileName.
(className endsWith:'.o') ifTrue:[
className := className copyTo:(className size - 2)
].
- OperatingSystem getOSType = 'sys5.4' ifTrue:[
- symName := '_' , className , '_Init'
- ] ifFalse:[
- symName := '__' , className , '_Init'
- ].
+ symName := '_' , className , '_Init'.
initAddr := self getSymbol:symName from:handle.
+
initAddr isNil ifTrue:[
- className := Smalltalk classNameForFile:className.
- OperatingSystem getOSType = 'sys5.4' ifTrue:[
- symName := '_' , className , '_Init'
- ] ifFalse:[
- symName := '__' , className , '_Init'
- ].
+ "try with added underscore"
+ symName := '__' , className , '_Init'.
initAddr := self getSymbol:symName from:handle.
initAddr isNil ifTrue:[
- Transcript showCr:('no symbol: ',symName,' in ',aFileName).
- ^ nil
+ "try className from fileName"
+ className := Smalltalk classNameForFile:className.
+ symName := '_' , className , '_Init'.
+ initAddr := self getSymbol:symName from:handle.
+ initAddr isNil ifTrue:[
+ "and with added underscore"
+ symName := '__' , className , '_Init'.
+ initAddr := self getSymbol:symName from:handle.
+ initAddr isNil ifTrue:[
+ Transcript showCr:('no symbol: ',symName,' in ',aFileName).
+ ^ nil
+ ].
+ ].
].
].
self callFunctionAt:initAddr.
@@ -1257,11 +1315,22 @@
void (*addr)();
unsigned val;
typedef void (*VOIDFUNC)();
+ int savInt;
+ extern int _immediateInterrupt;
if (_isSmallInteger(low) && _isSmallInteger(hi)) {
val = (_intVal(hi) << 16) + _intVal(low);
addr = (VOIDFUNC) val;
+
+ /*
+ * allow function to be interrupted
+ */
+ savInt = _immediateInterrupt;
+ _immediateInterrupt = 1;
+
(*addr)();
+
+ _immediateInterrupt = savInt;
}
%}
! !
--- a/ParseNode.st Wed Mar 30 12:09:50 1994 +0200
+++ b/ParseNode.st Wed Mar 30 12:10:24 1994 +0200
@@ -11,7 +11,7 @@
"
Object subclass:#ParseNode
- instanceVariableNames:'type comments'
+ instanceVariableNames:'type comments parenthized'
classVariableNames:''
poolDictionaries:''
category:'System-Compiler-Support'
@@ -22,7 +22,7 @@
COPYRIGHT (c) 1989 by Claus Gittinger
All Rights Reserved
-$Header: /cvs/stx/stx/libcomp/ParseNode.st,v 1.4 1994-01-16 03:51:38 claus Exp $
+$Header: /cvs/stx/stx/libcomp/ParseNode.st,v 1.5 1994-03-30 10:09:54 claus Exp $
'!
!ParseNode class methodsFor:'instance creation'!
@@ -39,6 +39,12 @@
^ false
!
+isPrimary
+ "return true, if this is a node for a primary (i.e. non-send)"
+
+ ^ false
+!
+
isSuper
"return true, if this is a super-node"
@@ -51,6 +57,12 @@
^ false
!
+isAssignment
+ "return true, if this is a node for an assignment"
+
+ ^ false
+!
+
isMessage
"return true, if this is a node for a message expression"
@@ -81,6 +93,14 @@
"set linenumber - ignored here"
^ self
+!
+
+parenthized:aBoolean
+ parenthized := aBoolean
+!
+
+parenthized
+ ^ parenthized
! !
!ParseNode methodsFor:'private'!
--- a/Parser.st Wed Mar 30 12:09:50 1994 +0200
+++ b/Parser.st Wed Mar 30 12:10:24 1994 +0200
@@ -22,10 +22,13 @@
modifiedInstVars modifiedClassVars
localVarDefPosition
evalExitBlock
- selfNode superNode primNr logged
- warnedUndefVars'
+ selfNode superNode
+ hasPrimitiveCode primitiveNr logged
+ warnedUndefVars
+ correctedSource'
classVariableNames:'PrevClass PrevInstVarNames
- PrevClassVarNames PrevClassInstVarNames'
+ PrevClassVarNames PrevClassInstVarNames
+ LazyCompilation'
poolDictionaries:''
category:'System-Compiler'
!
@@ -35,56 +38,138 @@
COPYRIGHT (c) 1989 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.
+$Header: /cvs/stx/stx/libcomp/Parser.st,v 1.10 1994-03-30 10:10:24 claus Exp $
+'!
+
+!Parser class methodsFor:'documentation'!
+
+documentation
+"
+ Parser is used for both parsing and evaluating smalltalk expressions;
+ it first builds a parseTree which is then interpreted (evaluate) or
+ compiled. Compilation is done in the subclass ByteCodeCompiler and/or
+ the (planned) MachineCodeCompiler.
+
+ methods of main interrest are:
+ Parser evaluateExpression:...
+
+ and:
+ Parser parseExpression:...
+ Parser parseMethod:...
+
+ there is protocol to parse complete methods, selector specs, body only etc.
+
+ 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).
+
+ You can also use parsers for all kinds of other things (ChangesBrowser for
+ example analyzes the expressions in the changelist ...) by looking at the
+ parsers tree. (Although this is somewhat dangerous, since it exports the
+ compilers internals ... better style would be to add specialized query
+ methods here.)
+
+ One instance of Parser is created to parse one method or expression - i.e.
+ its not suggested to reuse parsers.
+
+ Instance variables:
+
+ classToCompileFor <Class> the class (or nil) we are compiling for
+
+ selfValue <any> value to use as self when interpreting
+
+ contextToEvaluateIn <Context> the context (or nil) when interpreting
+
+ selector <Symbol> the selector of the parsed method
+ (valid after parseMethodSpecification)
+ methodArgs internal
+
+ methodArgNames <Collection> the names of the arguments
+ (valid after parseMethodSpecification)
+
+ methodVars internal
-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).
+ methodVarNames <Collection> the names of the method locals
+ (valid after parseMethodBodyVarSpec)
+
+ tree <ParseTree> the parse tree - valid after parsing
+
+ currentBlock if currently parsing for a block
+
+ usedInstVars set of all accessed instances variables
+ (valid after parsing)
+
+ usedClassVars same for classVars
+
+ usedVars all used variables (inst, class & globals)
+
+ modifiedInstVars set of all modified instance variables
+
+ modifiedClassVars same for clasVars
+
+ localVarDefPosition <Integer> the character offset of the local variable
+ def. (i.e. the first '|' if any)
+ Not yet used - prepared for automatic add of
+ undefined variables
+
+ evalExitBlock internal for interpretation
-$Header: /cvs/stx/stx/libcomp/Parser.st,v 1.9 1994-02-25 12:52:15 claus Exp $
-'!
+ selfNode <Node> cached one-and-only 'self' node
+ superNode <Node> cached one-and-only 'super' node
+
+ hasPrimitiveCode <Boolean> true, if it contains ST/X style primitive code
+
+ primitiveNr <Integer> the parsed ST-80 type primitive number (or nil)
+
+ logged
+
+ warnedUndefVars <Set> set of all variables which the parser has
+ already output a warning (to avoid multiple
+ warnings about the same variable)
+
+ Class variables:
+
+ PrevClass <Class> class, of which properties are
+ cached in:
+
+ PrevInstVarNames <Collection> instance variablenames of cached class
+ PrevClassVarNames <Collection> class variablenames of cached class
+ PrevClassInstVarNames <Collection> class instance variablenames of cached class
+
+ LazyCompilation <Boolean> EXPERIMENTAL: lazy compilation
+"
+! !
!Parser class methodsFor:'evaluating expressions'!
-evaluate:aString
- "return the result of evaluating aString"
+evaluate:aStringOrStream
+ "return the result of evaluating an expression in aStringOrStream"
- ^ self evaluate:aString notifying:nil
+ ^ self
+ evaluate:aStringOrStream
+ in:nil
+ receiver:nil
+ notifying:nil
+ ifFail:nil
+
+ "
+ Compiler evaluate:'1 + 2'
+ Compiler evaluate:'''hello world'' asSortedCollection displayString printNL'
+ Compiler evaluate:'''hello world'' asSortedCollection printNL'
+ "
!
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.
+ ^ self
+ evaluate:aStringOrStream
+ in:nil
+ receiver:nil
+ notifying:requestor
+ ifFail:nil
- "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
@@ -92,11 +177,12 @@
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
+ ^ self
+ evaluate:aString
+ in:nil
+ receiver:anObject
+ notifying:requestor
+ ifFail:nil
!
evaluate:aStringOrStream in:aContext receiver:anObject
@@ -139,6 +225,8 @@
!Parser class methodsFor:'instance creation'!
for:aStream in:aClass
+ "return a new parser, reading code for aClass from aStream"
+
|parser|
parser := self for:aStream.
@@ -158,6 +246,12 @@
tree := self withSelf:nil parseExpression:aString notifying:nil ignoreErrors:true.
(tree notNil and:[tree ~~ #Error]) ifTrue:[
+ tree isAssignment ifTrue:[
+ tree expression isMessage ifTrue:[
+ tree := tree expression
+ ]
+ ].
+
tree isMessage ifTrue:[
^ tree selector
].
@@ -176,25 +270,26 @@
Parser selectorInExpression:'1 + 4'
Parser selectorInExpression:'1 negated'
Parser selectorInExpression:'at:1 put:5'
+ Parser selectorInExpression:'a := foo at:1 put:5'
"
!
parseExpression:aString
- "parse aString as an expression; return the parseTree"
+ "parse aString as an expression; return the parseTree, nil or #error"
^ self withSelf:nil parseExpression:aString notifying:nil ignoreErrors:false
!
withSelf:anObject parseExpression:aString notifying:someOne
"parse aString as an expression with self set to anObject;
- return the parseTree"
+ return the parseTree, nil or #error"
^ self withSelf:anObject parseExpression:aString notifying:someOne ignoreErrors:false
!
withSelf:anObject parseExpression:aString notifying:someOne ignoreErrors:ignore
"parse aString as an expression with self set to anObject;
- return the parseTree"
+ return the parseTree, nil or #error"
|parser tree|
@@ -211,14 +306,14 @@
parseMethodSpecification:aString
"parse a methods selector & arg specification;
- return the parser or nil on error"
+ return the parser, nil or #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"
+ return the parser, nil or #error"
|parser tree|
@@ -232,14 +327,14 @@
parseMethodArgAndVarSpecification:aString
"parse a methods selector, arg and var spec;
- return the parser or nil on error"
+ return the parser, nil or #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"
+ return the parser, nil or #error"
|parser|
@@ -253,13 +348,13 @@
!
parseMethod:aString
- "parse a method; return parseTree"
+ "parse a method; return parser, nil or #error"
^ self parseMethod:aString in:nil
!
parseMethod:aString in:aClass
- "parse a method for a given class; return parser or nil on error"
+ "parse a method for a given class; return , nil or #error"
|parser tree|
@@ -270,6 +365,23 @@
^ parser
! !
+!Parser class methodsFor:'controlling compilation'!
+
+compileLazy:aBoolean
+ "turn on/off lazy compilation - return previous setting.
+ Actually this flag belongs into the ByteCodeCompiler subclass,
+ but it also controls the reporting of some errors here; therefore
+ its located here"
+
+ |oldLazy|
+
+ oldLazy := LazyCompilation.
+ LazyCompilation := aBoolean.
+ ^ oldLazy
+
+ "Compiler compileLazy:false"
+! !
+
!Parser methodsFor:'ST-80 compatibility'!
evaluate:aString in:aClass to:to notifying:aRequestor ifFail:failBlock
@@ -321,6 +433,18 @@
!Parser methodsFor:'setup'!
+initialize
+ super initialize.
+
+ hasPrimitiveCode := false
+!
+
+initializeFor:aStringOrStream
+ super initializeFor:aStringOrStream.
+
+ hasPrimitiveCode := false
+!
+
setClassToCompileFor:aClass
"set the class to be used for parsing/evaluating"
@@ -359,76 +483,90 @@
!
tree:aTree
+ "private: set the tree - for internal use only"
+
tree := aTree
!
selector
- "return the selector"
+ "return the selector (valid after parsing spec)"
^ selector
!
-primitiveNumber
- "return the primitiveNumber"
-
- ^ primNr
+correctedSource
+ ^ correctedSource
!
numberOfMethodArgs
- "return the number of methodargs"
+ "return the number of methodargs (valid after parsing spec)"
^ methodArgs size
!
methodArgs
- "return an array with methodarg names"
+ "return an array with methodarg names (valid after parsing spec)"
^ methodArgNames
!
numberOfMethodVars
- "return the number of method variables"
+ "return the number of method variables (valid after parsing)"
^ methodVars size
!
methodVars
- "return a collection with method variablenames"
+ "return a collection with method variablenames (valid after parsing)"
^ methodVarNames
!
usedVars
- "return a collection with variablenames refd by method"
+ "return a collection with variablenames refd by method (valid after parsing)"
^ usedVars
!
usedInstVars
- "return a collection with instvariablenames refd by method"
+ "return a collection with instvariablenames refd by method (valid after parsing)"
^ usedInstVars
!
usedClassVars
- "return a collection with classvariablenames refd by method"
+ "return a collection with classvariablenames refd by method (valid after parsing)"
^ usedClassVars
!
modifiedInstVars
- "return a collection with instvariablenames modified by method"
+ "return a collection with instvariablenames modified by method (valid after parsing)"
^ modifiedInstVars
!
modifiedClassVars
- "return a collection with classvariablenames modified by method"
+ "return a collection with classvariablenames modified by method (valid after parsing)"
^ modifiedClassVars
!
+primitiveNumber
+ "return the ST-80 style primitiveNumber or nil (valid after parsing)"
+
+ ^ primitiveNr
+!
+
+hasPrimitiveCode
+ "return true if there was any ST/X style primitive code (valid after parsing)"
+
+ ^ hasPrimitiveCode
+!
+
errorFlag
+ "return true if there where any errors (valid after parsing)"
+
^ errorFlag
!
@@ -441,20 +579,27 @@
!Parser methodsFor:'error handling'!
showErrorMessage:aMessage position:pos
- Transcript show:(pos printString).
- Transcript show:' '.
- selector notNil ifTrue:[
- Transcript show:aMessage.
- classToCompileFor notNil ifTrue:[
- Transcript showCr:(' in ' , classToCompileFor name , '>>' , selector)
- ] ifFalse:[
- Transcript showCr:(' in ' , selector)
- ]
- ] ifFalse:[
- classToCompileFor notNil ifTrue:[
- Transcript showCr:aMessage , ' (' , classToCompileFor name , ')'
- ] ifFalse:[
- Transcript showCr:aMessage
+ "redefined since parser can give more detailed info about
+ the class & selector where the error occured."
+
+ ignoreErrors ifFalse:[
+ Smalltalk silentLoading == true ifFalse:[
+ Transcript show:(pos printString).
+ Transcript show:' '.
+ selector notNil ifTrue:[
+ Transcript show:aMessage.
+ classToCompileFor notNil ifTrue:[
+ Transcript showCr:(' in ' , classToCompileFor name , '>>' , selector)
+ ] ifFalse:[
+ Transcript showCr:(' in ' , selector)
+ ]
+ ] ifFalse:[
+ classToCompileFor notNil ifTrue:[
+ Transcript showCr:aMessage , ' (' , classToCompileFor name , ')'
+ ] ifFalse:[
+ Transcript showCr:aMessage
+ ]
+ ]
]
]
!
@@ -483,13 +628,6 @@
^ 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 -
return true if correction is wanted"
@@ -527,8 +665,7 @@
^ false
].
- ^ self correctableError:('Error: ' , aName , ' is undefined')
- position:pos1 to:pos2
+ ^ self correctableError:('Error: ' , aName , ' is undefined') position:pos1 to:pos2
!
exitWith:something
@@ -540,7 +677,11 @@
!Parser methodsFor:'parsing'!
parseMethod
- "parse a method"
+ "parse a method.
+ Return the parseTree or #Error.
+
+ method ::= methodSpec methodBody
+ "
|parseTree|
@@ -555,7 +696,13 @@
parseMethodSpec
"parse a methods selector & arg specification;
- set selector and methodArgs as a side effect"
+ Set selector and methodArgs in the receiver as a side effect.
+ Return the receiver or #Error.
+
+ methodSpec ::= { KEYWORD IDENTIFIER }
+ | binaryOperator IDENTIFIER
+ | IDENTIFIER
+ "
|var|
@@ -601,18 +748,45 @@
^ #Error
!
+parseMethodBody
+ "parse a methods body (locals & statements).
+ No more tokens may follow.
+ Return a node-tree, or #Error
+
+ methodBody ::= '<' st80Primitive '>' #EOF
+ | '<' st80Primitive '>' methodBodyVarSpec statementList #EOF
+
+ "
+ |stats|
+
+ stats := self parseMethodBodyOrNil.
+ (stats == #Error) ifFalse:[
+ (tokenType ~~ #EOF) ifTrue:[
+ self parseError:(tokenType printString , ' unexpected').
+ ^#Error
+ ]
+ ].
+ ^ stats
+!
+
parseMethodBodyOrNil
"parse a methods body (locals & statements);
- return a node-tree, nil or #Error. empty (or comment only) input
- is accepted and returns nil"
+ return a node-tree, nil or #Error.
+ empty (or comment only) input is accepted and returns nil.
+
+ methodBodyOrNil ::= '<' st80Primitive '>'
+ | '<' st80Primitive '>' methodBodyVarSpec statementList
+ | <empty>
+ "
|stats|
((tokenType == #BinaryOperator) and:[tokenName = '<']) ifTrue:[
"an ST-80 primitive - parsed but ignored"
self nextToken.
- primNr := self parseST80Primitive.
- (primNr == #Error) ifTrue:[^ #Error].
+ primitiveNr := self parseST80Primitive.
+ (primitiveNr == #Error) ifTrue:[^ #Error].
+
self warning:'ST-80 primitives not supported - ignored'
].
@@ -624,24 +798,14 @@
^ stats
!
-parseMethodBody
- "parse a methods body (locals & statements); no more token may follow
- return a node-tree, nil or #Error"
-
- |stats|
+parseMethodBodyVarSpec
+ "parse a methods local variable specification.
+ Leave spec of locals in methodLocals as a side effect.
+ Return #Error or nil.
- stats := self parseMethodBodyOrNil.
- (stats == #Error) ifFalse:[
- (tokenType ~~ #EOF) ifTrue:[
- self parseError:(tokenType printString , ' unexpected').
- ^#Error
- ]
- ].
- ^ stats
-!
-
-parseMethodBodyVarSpec
- "parse a methods local variable specification"
+ methodBodyVarSpec ::= '|' { IDENTIFIER } '|'
+ | <empty>
+ "
|var|
@@ -671,7 +835,10 @@
parseST80Primitive
"parse an ST-80 type primitive as '< primitive: nr >';
- return primitive number or #Error"
+ return primitive number or #Error.
+
+ st80Primitive ::= 'primitive:' INTEGER
+ "
|primNumber|
@@ -724,7 +891,7 @@
].
(tokenType == #EOF) ifTrue:[
currentBlock notNil ifTrue:[
- self parseError:'block nesting error'.
+ self parseError:'block nesting error (expected '']'')'.
errorFlag := true
"
*** I had a warning here (since it was not defined
@@ -771,7 +938,12 @@
!
statement
- "parse a statement; return a node-tree, nil or #Error"
+ "parse a statement; return a node-tree or #Error.
+
+ statement ::= '^' expression
+ | PRIMITIVECODE
+ | expression
+ "
|expr node|
@@ -784,8 +956,11 @@
^ node
].
(tokenType == #Primitive) ifTrue:[
+"
self parseError:'cannot compile primitives (yet)'.
+"
self nextToken.
+ hasPrimitiveCode := true.
^ PrimitiveNode code:''
].
(tokenType == #EOF) ifTrue:[
@@ -807,7 +982,18 @@
!
expression
- "parse a cascade-expression; return a node-tree, nil or #Error"
+ "parse a cascade-expression; return a node-tree, nil or #Error.
+
+ expression ::= keywordExpression
+ | keywordExpression cascade
+
+ cascade ::= ';' expressionSendPart
+ | cascade ';' expressionSendPart
+
+ expressionSendPart ::= { KEYWORD binaryExpression }
+ | BINARYOPERATOR unaryExpression
+ | IDENTIFIER
+ "
|receiver arg sel args pos pos2|
@@ -822,14 +1008,12 @@
].
self nextToken.
(tokenType == #Identifier) ifTrue:[
- sel := tokenName.
- self selectorCheck:sel position:tokenPosition to:(tokenPosition + sel size - 1).
+ sel := self selectorCheck:tokenName for:receiver position:tokenPosition to:(tokenPosition + tokenName 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).
+ sel := self selectorCheck:tokenName for:receiver position:tokenPosition to:(tokenPosition + tokenName size - 1).
self nextToken.
arg := self unaryExpression.
(arg == #Error) ifTrue:[^ #Error].
@@ -850,7 +1034,7 @@
args := args copyWith:arg.
pos2 := tokenPosition
].
- self selectorCheck:sel position:pos to:pos2.
+ sel := self selectorCheck:sel for:receiver position:pos to:pos2.
receiver := CascadeNode receiver:receiver selector:sel args:args
] ifFalse:[
(tokenType == #Error) ifTrue:[^ #Error].
@@ -911,7 +1095,7 @@
args := args copyWith:arg.
pos2 := tokenPosition
].
- self selectorCheck:sel position:pos1 to:pos2.
+ sel := self selectorCheck:sel for:receiver position:pos1 to:pos2.
try := MessageNode receiver:receiver selector:sel args:args.
(try isMemberOf:String) ifTrue:[
self parseError:try position:pos1 to:pos2.
@@ -973,9 +1157,7 @@
self nextToken
] ifFalse:[
(tokenType == #BinaryOperator) ifTrue:[
- sel := tokenName.
- self selectorCheck:sel position:tokenPosition
- to:(tokenPosition + sel size - 1).
+ sel := self selectorCheck:tokenName for:receiver position:tokenPosition to:(tokenPosition + tokenName size - 1).
self nextToken
] ifFalse:[
sel := '-'.
@@ -1003,18 +1185,17 @@
unaryExpression
"parse a unary-expression; return a node-tree, nil or #Error"
- |receiver sel pos try|
+ |receiver sel pos pos2 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).
+ pos2 := pos + tokenName size - 1.
+ sel := self selectorCheck:tokenName for:receiver position:pos to:pos2.
try := UnaryNode receiver:receiver selector:sel.
(try isMemberOf:String) ifTrue:[
- self warning:try position:pos to:(tokenPosition + sel size - 1).
+ self warning:try position:pos to:pos2.
receiver := UnaryNode receiver:receiver selector:sel fold:false
] ifFalse:[
receiver := try
@@ -1185,6 +1366,7 @@
^ #Error
].
self nextToken.
+ val parenthized:true.
^ val
].
(tokenType == $[ ) ifTrue:[
@@ -1192,15 +1374,22 @@
self nextToken.
^ val
].
+
(tokenType == #Error) ifTrue:[^ #Error].
(tokenType isKindOf:Character) ifTrue:[
self syntaxError:('error in primary; '
- , tokenType printString ,
+ , tokenType printString ,
' unexpected') position:tokenPosition to:tokenPosition
] ifFalse:[
- self syntaxError:('error in primary; '
- , tokenType printString ,
- ' unexpected')
+ (#(BinaryOperator Keyword) includes:tokenType) ifTrue:[
+ self syntaxError:('error in primary; '
+ , tokenType printString , '(' , tokenName , ') ' ,
+ ' unexpected')
+ ] ifFalse:[
+ self syntaxError:('error in primary; '
+ , tokenType printString ,
+ ' unexpected')
+ ]
].
^ #Error
!
@@ -1208,53 +1397,37 @@
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 }" |
+ |var instIndex aClass searchBlock args vars
+ varName tokenSymbol className|
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:[
+ instIndex := args findFirst:[:aBlockArg | aBlockArg name = varName].
+ instIndex ~~ 0 ifTrue:[
^ VariableNode type:#BlockArg
name:varName
- token:tokenFound
+ token:(args at:instIndex)
index:instIndex
- block:theBlock
- ]
+ block:searchBlock
+ ].
+
].
- 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:[
+ instIndex := vars findFirst:[:aBlockVar | aBlockVar name = varName].
+ instIndex ~~ 0 ifTrue:[
^ VariableNode type:#BlockVariable
name:varName
- token:tokenFound
+ token:(vars at:instIndex)
index:instIndex
- block:theBlock
- ]
+ block:searchBlock
+ ].
].
searchBlock := searchBlock home
].
@@ -1301,16 +1474,18 @@
instIndex := PrevInstVarNames indexOf:varName startingAt:1.
instIndex ~~ 0 ifTrue:[
usedInstVars isNil ifTrue:[
- usedInstVars := OrderedCollection new
- ].
- (usedInstVars includes:varName) ifFalse:[
- usedInstVars add:varName
+ usedInstVars := OrderedCollection with:varName
+ ] ifFalse:[
+ (usedInstVars includes:varName) ifFalse:[
+ usedInstVars add:varName
+ ]
].
usedVars isNil ifTrue:[
- usedVars := OrderedCollection new
- ].
- (usedVars includes:varName) ifFalse:[
- usedVars add:varName
+ usedVars := OrderedCollection with:varName
+ ] ifFalse:[
+ (usedVars includes:varName) ifFalse:[
+ usedVars add:varName
+ ]
].
^ VariableNode type:#InstanceVariable
name:varName
@@ -1330,10 +1505,11 @@
aClass := self inWhichClassIsClassInstVar:varName.
aClass notNil ifTrue:[
usedVars isNil ifTrue:[
- usedVars := OrderedCollection new
- ].
- (usedVars includes:varName) ifFalse:[
- usedVars add:varName
+ usedVars := OrderedCollection with:varName
+ ] ifFalse:[
+ (usedVars includes:varName) ifFalse:[
+ usedVars add:varName
+ ]
].
^ VariableNode type:#ClassInstanceVariable
name:varName
@@ -1363,16 +1539,18 @@
aClass := self inWhichClassIsClassVar:varName.
aClass notNil ifTrue:[
usedClassVars isNil ifTrue:[
- usedClassVars := OrderedCollection new
- ].
- (usedClassVars includes:varName) ifFalse:[
- usedClassVars add:varName
+ usedClassVars := OrderedCollection with:varName
+ ] ifFalse:[
+ (usedClassVars includes:varName) ifFalse:[
+ usedClassVars add:varName
+ ].
].
usedVars isNil ifTrue:[
- usedVars := OrderedCollection new
- ].
- (usedVars includes:varName) ifFalse:[
- usedVars add:varName
+ usedVars := OrderedCollection with:varName
+ ] ifFalse:[
+ (usedVars includes:varName) ifFalse:[
+ usedVars add:varName
+ ].
].
^ VariableNode type:#ClassVariable
name:(aClass name , ':' , varName) asSymbol
@@ -1384,10 +1562,11 @@
tokenSymbol := varName asSymbol.
(Smalltalk includesKey:tokenSymbol) ifTrue:[
usedVars isNil ifTrue:[
- usedVars := OrderedCollection new
- ].
- (usedVars includes:varName) ifFalse:[
- usedVars add:varName
+ usedVars := OrderedCollection with:varName
+ ] ifFalse:[
+ (usedVars includes:varName) ifFalse:[
+ usedVars add:varName
+ ]
].
^ VariableNode type:#GlobalVariable name:tokenSymbol
].
@@ -1669,12 +1848,22 @@
correctByDeleting
"correct (by deleting token) if user wants to;
- return #Error if there was no correction or nil"
+ return #Error if there was no correction;
+ nil if there was one."
(self confirm:'confirm deleting') ifFalse:[^ #Error].
- "tell requestor about the change"
+ "
+ tell requestor (i.e. CodeView) about the change
+ this will update what the requestor shows.
+ "
requestor deleteSelection.
+
+ "
+ get the updated source-string
+ which is needed, when we eventually install the new method
+ "
+ correctedSource := requestor currentSourceCode.
^ nil
!
@@ -1785,18 +1974,98 @@
^ 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.
+
+"OLD:
+ (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:[
+ ^ VariableNode type:#GlobalVariable name:(varName asSymbol)
+ ]
+ ].
+"
+
+ correctIt := self undefError:varName position:pos1 to:pos2.
+ correctIt ifFalse:[
+ (varName at:1) isLowercase ifTrue:[
+ ^ #Error
+ ] ifFalse:[
+ ^ VariableNode type:#GlobalVariable name:(varName asSymbol)
+ ]
+ ].
+
+ suggestedNames := self findBestVariablesFor:varName.
+ suggestedNames notNil ifTrue:[
+ newName := self askForCorrection:'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 (i.e. CodeView) about the change
+ this will update what the requestor shows.
+ "
+ requestor replaceSelectionBy:newName.
+ "
+ get the updated source-string
+ which is needed, when we eventually install the new method
+ "
+ correctedSource := requestor currentSourceCode.
+
+ "redo parse with new value"
+ tokenName := newName.
+ ^ self variableOrError
+!
+
+askForCorrection: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:'correct'.
+ "box abortText:'abort'."
+ box action:[:aString | ^ aString].
+ box showAtPointer.
+ ^ nil
+!
+
findBestSelectorsFor:aString
"collect known selectors with their spelling distances to aString;
return the 10 best suggestions"
- |info best worst n|
+ |info n|
info := SortedCollection new.
info sortBlock:[:a :b | a value > b value].
n := 0.
- "block arguments"
Symbol allInstancesDo:[:sym |
|dist|
@@ -1812,68 +2081,83 @@
^ info asOrderedCollection collect:[:a | a key]
- "Time millisecondsToRun:[Parser new findBestSelectorsFor:#foo]"
- "Parser new findBestSelectorsFor:#findBestSel"
- "Parser new findBestSelectorsFor:#fildBestSelectrFr"
+ "Time millisecondsToRun:[Parser new findBestSelectorsFor:'foo']"
+ "Parser new findBestSelectorsFor:'findBestSel'"
+ "Parser new findBestSelectorsFor:'fildBestSelectrFr'"
!
-correctVariable
+correctSelector:aSelectorString message:msg position:pos1 to:pos2
"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|
+ |correctIt suggestedNames newSelector l c|
- 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:[
- ^ VariableNode type:#GlobalVariable name:(varName asSymbol)
- ]
+ "
+ sorry, but I cannot handle keywords with more than one-part
+ currently (too much work - maybe Ill do it later when everything else works :-)
+ "
+ (aSelectorString occurrencesOf:$:) > 1 ifTrue:[
+ self warning:msg position:pos1 to:pos2.
+ ^ aSelectorString
].
- suggestedNames := self findBestVariablesFor:varName.
+ correctIt := self correctableError:msg position:pos1 to:pos2.
+ correctIt ifFalse:[^ aSelectorString].
+
+ suggestedNames := self findBestSelectorsFor:aSelectorString.
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]
-"
+ newSelector := self askForCorrection:'correct selector to: ' fromList:suggestedNames.
+ newSelector isNil ifTrue:[^ aSelectorString].
] ifFalse:[
self notify:'no good correction found'.
- ^ #Error
+ ^ aSelectorString
].
- "tell requestor about the change"
- requestor replaceSelectionBy:newName.
+ "
+ tell requestor (i.e. CodeView) about the change
+ this will update what the requestor shows.
+ "
- "redo parse with new value"
- tokenName := newName.
- ^ self variableOrError
+ requestor replaceSelectionBy:newSelector keepCursor:false.
+ "
+ get the updated source-string
+ which is needed, when we eventually install the new method
+ "
+ correctedSource := requestor currentSourceCode.
+
+ ^ newSelector
!
-askForVariable:aString fromList:aList
- "launch a selection box, which allows user to enter correction.
- return true for yes, false for no"
+selectorCheck:aSelectorString for:receiver position:pos1 to:pos2
+ "just a quick check: if the selector is totally unknown
+ as a symbol, it cannot possibly be understood.
+ Simple, but catches many typos"
+
+ |ok err|
- |box|
+ (LazyCompilation == true) ifFalse:[
+ ok := aSelectorString knownAsSymbol.
+ err := ' is currently nowhere implemented'.
+ ok ifTrue:[
+ (receiver notNil and:[receiver isConstant]) ifTrue:[
+ ok := receiver evaluate respondsTo:(aSelectorString asSymbol).
+ err := ' will not be understood here'.
+ ]
+ ].
+ ok ifFalse:[
- ListSelectionBox isNil ifTrue:[
- ^ self confirm:aString
+"OLD: "
+ self warning:(aSelectorString , err) position:pos1 to:pos2
+" "
+
+"NEW: - not finished - need more interfaces
+ (currently produces warning output on Transcript while filing in
+
+
+ ^ self correctSelector:aSelectorString message:(aSelectorString , err) position:pos1 to:pos2
+"
+ ]
].
- 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
+ ^ aSelectorString
! !
--- a/PrimaryNd.st Wed Mar 30 12:09:50 1994 +0200
+++ b/PrimaryNd.st Wed Mar 30 12:10:24 1994 +0200
@@ -22,7 +22,7 @@
COPYRIGHT (c) 1989 by Claus Gittinger
All Rights Reserved
-$Header: /cvs/stx/stx/libcomp/Attic/PrimaryNd.st,v 1.5 1994-01-16 03:51:42 claus Exp $
+$Header: /cvs/stx/stx/libcomp/Attic/PrimaryNd.st,v 1.6 1994-03-30 10:09:38 claus Exp $
written 88 by claus
'!
@@ -32,14 +32,22 @@
^ value
! !
+!PrimaryNode methodsFor:'queries'!
+
+isPrimary
+ "return true, if this is a node for a primary (i.e. non-send)"
+
+ ^ true
+! !
+
!PrimaryNode methodsFor:'evaluating'!
evaluate
- self subclassResponsibility
+ ^ self subclassResponsibility
!
store:aValue
- self subclassResponsibility
+ ^ self subclassResponsibility
! !
!PrimaryNode methodsFor:'code generation'!
@@ -50,19 +58,19 @@
!
codeOn:aStream inBlock:codeBlock
- self subclassResponsibility
+ ^ self subclassResponsibility
!
codeStoreOn:aStream inBlock:codeBlock valueNeeded:valueNeeded
- self subclassResponsibility
+ ^ self subclassResponsibility
! !
!PrimaryNode methodsFor:'printing'!
displayString
- self subclassResponsibility
+ ^ self subclassResponsibility
!
printOn:aStream indent:i
- self subclassResponsibility
+ ^ self subclassResponsibility
! !
--- a/PrimaryNode.st Wed Mar 30 12:09:50 1994 +0200
+++ b/PrimaryNode.st Wed Mar 30 12:10:24 1994 +0200
@@ -22,7 +22,7 @@
COPYRIGHT (c) 1989 by Claus Gittinger
All Rights Reserved
-$Header: /cvs/stx/stx/libcomp/PrimaryNode.st,v 1.5 1994-01-16 03:51:42 claus Exp $
+$Header: /cvs/stx/stx/libcomp/PrimaryNode.st,v 1.6 1994-03-30 10:09:38 claus Exp $
written 88 by claus
'!
@@ -32,14 +32,22 @@
^ value
! !
+!PrimaryNode methodsFor:'queries'!
+
+isPrimary
+ "return true, if this is a node for a primary (i.e. non-send)"
+
+ ^ true
+! !
+
!PrimaryNode methodsFor:'evaluating'!
evaluate
- self subclassResponsibility
+ ^ self subclassResponsibility
!
store:aValue
- self subclassResponsibility
+ ^ self subclassResponsibility
! !
!PrimaryNode methodsFor:'code generation'!
@@ -50,19 +58,19 @@
!
codeOn:aStream inBlock:codeBlock
- self subclassResponsibility
+ ^ self subclassResponsibility
!
codeStoreOn:aStream inBlock:codeBlock valueNeeded:valueNeeded
- self subclassResponsibility
+ ^ self subclassResponsibility
! !
!PrimaryNode methodsFor:'printing'!
displayString
- self subclassResponsibility
+ ^ self subclassResponsibility
!
printOn:aStream indent:i
- self subclassResponsibility
+ ^ self subclassResponsibility
! !