when required to compile, use Compiler instead of self class.
"
COPYRIGHT (c) 1989 by Claus Gittinger
All Rights Reserved
This software is furnished under a license and may be used
only in accordance with the terms of that license and with the
inclusion of the above copyright notice. This software may not
be provided or otherwise made available to, or used by, any
other person. No title to or ownership of the software is
hereby transferred.
"
"{ Package: 'stx:libcomp' }"
Scanner subclass:#Parser
instanceVariableNames:'classToCompileFor selfValue contextToEvaluateIn selector
methodArgs methodArgNames methodVars methodVarNames tree
currentBlock parseForCode readInstVars readClassVars readGlobals
usedInstVars usedClassVars usedVars modifiedInstVars
modifiedClassVars modifiedGlobals usesSuper usedGlobals
usedSymbols messagesSent messagesSentToSelf messagesSentToSuper
localVarDefPosition evalExitBlock selfNode superNode nilNode
hasPrimitiveCode hasNonOptionalPrimitiveCode primitiveNr
primitiveResource logged warnedUndefVars warnedUnknownNamespaces
warnSTXHereExtensionUsed warnUnusedVars correctedSource
foldConstants lineNumberInfo currentNamespace
currentUsedNamespaces warnUndeclared methodNode
alreadyWarnedClassInstVarRefs localBlockVarDefPosition
endOfSelectorPosition startOfBlockPosition primitiveContextInfo
usedLocalVars modifiedLocalVars alreadyWarnedUninitializedVars
alreadyWarnedUnimplementedSelectors returnedValues currentPackage
doItTemporaries inFunctionCallArgument'
classVariableNames:'PrevClass PrevInstVarNames PrevClassVarNames
PrevClassInstVarNames LazyCompilation ArraysAreImmutable
ImplicitSelfSends WarnST80Directives WarnUnusedVars FoldConstants
LineNumberInfo SuppressDoItCompilation StringsAreImmutable
ParseErrorSignal RestartCompilationSignal
AllowFunctionCallSyntaxForBlockEvaluation AllowLazyValueExtension
AllowVariableReferences AllowReservedWordsAsSelectors
AllowLocalVariableDeclarationWithInitializerExpression'
poolDictionaries:''
category:'System-Compiler'
!
Error subclass:#ParseError
instanceVariableNames:'errorMessage startPosition endPosition'
classVariableNames:''
poolDictionaries:''
privateIn:Parser
!
Parser::ParseError subclass:#UndefinedSuperclassError
instanceVariableNames:''
classVariableNames:''
poolDictionaries:''
privateIn:Parser
!
!Parser class methodsFor:'documentation'!
copyright
"
COPYRIGHT (c) 1989 by Claus Gittinger
All Rights Reserved
This software is furnished under a license and may be used
only in accordance with the terms of that license and with the
inclusion of the above copyright notice. This software may not
be provided or otherwise made available to, or used by, any
other person. No title to or ownership of the software is
hereby transferred.
"
!
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 interest 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 is 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.
Constant folding:
The parser has various modes for constant folding; by default, only numeric
expressions involving integers and floats are constant folded
(i.e. something like 'Float pi sin' or '1.5 + 0.3' will be reduced to a constant).
Constant folding can be turned off completely (setting FoldConstants to nil)
to ``secure folding'', which only folds constant numbers (#level1) or to #full.
In full mode, more constant expressions are folded (for example: '1.0 @ 1.0' is
reduced to a constant point), but the resulting code may not be compatible with other
smalltalk systems (consider the case, where the point is modified using #x: or #y: messages).
Therefore, this mode is a bit dangerous and disabled by default.
The current implementation, base upon a global constant-folding setting is somewhat stupid
and intermediate - a better solution would be to allow the optimization to be controlled
by a method-pragma, since it may make sense to disable optimization on a method level,
if its known that the used constant objects are subject of modifications as described above.
Immutable arrays:
Immutable arrays are experimental and being evaluated.
Consider the case of a method returning '#(1 2 3 4)', and that array being modified
by some other method (using #at:put:). Since the array-return is actually a return of
a reference to the compiler created array, the next invokation of the method will
return the modified array. These are hard to find bugs.
By an option, the compiler can generate immutable arrays, which dont allow modification
of its elements. For clean code, you should enable this option during development.
As mentioned above, this is experimental. If it is reported to be a useful feature,
the immutable feature will be extended to strings, point-literals etc. in a future version
of st/x.
[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
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
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
hasNonOptionalPrimitiveCode
<Boolean> true, if it contains ST/X style primitive code
which is NOT flagged by the OPTIONAL directive.
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
ArraysAreImmutable <Boolean> if true, create array literals
as instances of ImmutableArray,
which cannot be stored into.
Default is false, for compatibility.
Can be turned on while developping
new code to make certain that side
effects are avoided.
WarnST80Directives <Boolean> if true, give warnings about
ST-80 directives (resource defs)
which are ignored in st/x.
defaults to false.
FoldConstants <Symbol> controls how constant folding should be
done.
Can be one of:
nil - no constant folding
#level1 - numeric optimizations only
#level2 - secure optimizations only
#full - full folding
level1: arithmetic on constant numbers
level2: above PLUS array conversions with #asFloatArray,
#asDoubleArray, string concatenation
full: constant points.
[see also:]
ByteCodeCompiler Scanner ObjectFileLoader
Workspace
SystemBrowser
[author:]
Claus Gittinger
"
! !
!Parser class methodsFor:'instance creation'!
for:aStringOrStream in:aClass
"return a new parser, reading code for aClass from aStringOrStream"
|parser|
parser := self for:aStringOrStream.
parser setClassToCompileFor:aClass.
^ parser
! !
!Parser class methodsFor:'Compatibility - ST80'!
parse:aString class:aClass
"same as #parseMethod:in: for ST80 compatibility."
|parser|
parser := self parseMethod:aString in:aClass.
parser notNil ifTrue:[^ parser tree].
^ nil
"Modified: 19.6.1997 / 16:34:57 / cg"
! !
!Parser class methodsFor:'Compatibility - Squeak'!
evaluate:someString for:aReceiver logged:logged
^ self evaluate:someString receiver:aReceiver logged:logged
! !
!Parser class methodsFor:'Signal constants'!
parseErrorSignal
^ ParseErrorSignal
! !
!Parser class methodsFor:'changes'!
flushNameCache
"unconditional flush name caches"
[
PrevClass notNil ifTrue:[
PrevClass removeDependent:Parser
].
PrevClass := nil.
PrevInstVarNames := nil.
PrevClassVarNames := nil.
PrevClassInstVarNames := nil.
] valueUninterruptably
"Parser flushNameCache"
!
update:something with:someArgument from:changedObject
"aClass has changed its definition - flush name caches if we have to"
(changedObject == PrevClass) ifTrue:[
something == #definition ifTrue:[
self flushNameCache
]
].
(changedObject == Smalltalk) ifTrue:[
something == #classDefinition ifTrue:[
self flushNameCache
]
]
! !
!Parser class methodsFor:'class initialization'!
initialize
LazyCompilation := false. "/ usually set to true in your .rc file
ArraysAreImmutable := false. "/ usually left false for ST-80 compatibility
StringsAreImmutable := false. "/ usually left false for ST-80 compatibility
ImplicitSelfSends := false.
WarnST80Directives := false.
WarnUnusedVars := true.
FoldConstants := #level1.
LineNumberInfo := false.
ParseErrorSignal isNil ifTrue:[
ParseErrorSignal := Error newSignalMayProceed:true.
ParseErrorSignal notifierString:'parse error'.
ParseErrorSignal nameClass:self message:#parseErrorSignal.
].
RestartCompilationSignal := Signal new.
Smalltalk addDependent:self.
"
self initialize
"
"Modified: / 15.11.2001 / 22:54:09 / cg"
! !
!Parser class methodsFor:'controlling compilation'!
arraysAreImmutable
"return true if arrays are immutable literals"
^ ArraysAreImmutable
!
arraysAreImmutable:aBoolean
"turn on/off immutable array literals - default is false for ST-80 compatibilty."
ArraysAreImmutable := aBoolean.
"
can be added to your private.rc file:
Compiler arraysAreImmutable:true
Compiler arraysAreImmutable:false
"
!
compileLazy
"return true if compiling lazy"
^ LazyCompilation.
!
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
"
usually set in your .rc file
Compiler compileLazy:false
Compiler compileLazy:true
"
!
foldConstants
"return a symbol describing how constants are to be folded"
^ FoldConstants
"Created: 9.2.1996 / 17:40:13 / cg"
!
foldConstants:aSymbol
"set the symbol describing how constants are to be folded.
It can be:
nil - no constant folding
#level1 - numeric constants only
#level2 - level1 PLUS array conversions PLUS string concatenation
#full - level2 PLUS constant points, constant rectangles (dangerous)"
FoldConstants := aSymbol
"Created: 9.2.1996 / 17:40:34 / cg"
!
implicitSelfSends
"return true if undefined variables with
lowercase first character are to be turned
into implicit self sends"
^ ImplicitSelfSends
!
implicitSelfSends:aBoolean
"turn on/off implicit self sends"
ImplicitSelfSends := aBoolean
"
Compiler implicitSelfSends:true
Compiler implicitSelfSends:false
"
!
lineNumberInfo
^ LineNumberInfo
!
lineNumberInfo:aBoolean
LineNumberInfo := aBoolean
!
stringsAreImmutable
"return true if strings are immutable literals"
^ StringsAreImmutable
"Created: / 3.8.1998 / 14:53:25 / cg"
!
stringsAreImmutable:aBoolean
"turn on/off immutable string literals - default is false for ST-80 compatibilty."
StringsAreImmutable := aBoolean.
"
can be added to your private.rc file:
Compiler stringsAreImmutable:true
Compiler stringsAreImmutable:false
"
"Created: / 3.8.1998 / 14:53:28 / cg"
!
warnUnusedVars
"controls generation of warning messages about unued method variables"
^ WarnUnusedVars
!
warnUnusedVars:aBoolean
"controls generation of warning messages about unued method variables"
WarnUnusedVars := aBoolean
! !
!Parser class methodsFor:'defaults'!
allowReservedWordsAsSelectors
"return true, if self, super, thisContext, nil, true and false are to be allowed
as unary message selectors."
^ AllowReservedWordsAsSelectors ? false
!
allowReservedWordsAsSelectors:aBoolean
"enable/disable, if self, super, thisContext, nil, true and false are to be allowed
as unary message selectors."
AllowReservedWordsAsSelectors := aBoolean.
self setupActions
"
self allowReservedWordsAsSelectors:true
self allowReservedWordsAsSelectors:false
"
!
maxLineNumber
"return the maximum lineNumber that is possibly
encoded in a methods byteCode debugging information.
Since lineNumber entries only have 1 byte available,
this is 255 for byteCode methods."
^ 255
"Created: 14.2.1997 / 16:52:54 / cg"
! !
!Parser class methodsFor:'error correction'!
findBest:nMax selectorsFor:aString in:aClassOrNil
"collect known selectors with their spelling distances to aString;
return the nMax best suggestions. If the argument, aClassOrNil is not nil,
the message is assumed to be sent to instances of that class (i.e. offer
corrections from that hierarchy only)"
|info block lcSelector|
info := SortedCollection new.
info sortBlock:[:a :b | a value > b value].
lcSelector := aString asLowercase.
block := [:sym :mthd|
|dist lcSym keepThis|
lcSym := sym asLowercase.
(info contains:[:i | i key == sym]) ifFalse:[
dist := lcSelector spellAgainst:lcSym.
(lcSym startsWith:lcSelector) ifTrue:[
dist := dist + (aString size * 10).
].
(dist > 20) ifTrue:[
(info contains:[:entry | entry key = sym]) ifFalse:[
keepThis := true.
info size >= nMax ifTrue:[
"will remove last entry anyway - so check if this one will remain ..."
dist < info last value ifTrue:[
keepThis := false.
]
].
keepThis ifTrue:[
"expensive - therefore do this check at last"
mthd isObsolete ifFalse:[
info add:(sym -> dist).
info size > nMax ifTrue:[
info removeLast.
]
]
]
]
]
]
].
aClassOrNil isNil ifTrue:[
Smalltalk allClassesDo:[:cls |
cls methodDictionary keysAndValuesDo:block.
cls class methodDictionary keysAndValuesDo:block.
]
] ifFalse:[
aClassOrNil withAllSuperclassesDo:[:cls |
cls methodDictionary keysAndValuesDo:block.
"/ cls class methodDictionary keysAndValuesDo:block.
]
].
^ info asOrderedCollection collect:[:a | a key]
"Modified: / 19.1.2000 / 16:43:37 / cg"
!
findBestSelectorsFor:aString
"collect known selectors with their spelling distances to aString;
return the 10 best suggestions"
^ self findBestSelectorsFor:aString in:nil
"
Parser findBestSelectorsFor:'at'
Parser findBestSelectorsFor:'at:pu'
"
!
findBestSelectorsFor:aString in:aClassOrNil
"collect known selectors with their spelling distances to aString;
return the 15 best suggestions. If the argument, aClassOrNil is not nil,
the message is assumed to be sent to instances of that class (i.e. offer
corrections from that hierarchy only)"
^ self
findBest:15 selectorsFor:aString in:aClassOrNil
! !
!Parser class methodsFor:'evaluating expressions'!
evaluate:aStringOrStream
"return the result of evaluating an expression in aStringOrStream.
No doit-entry is added to the changeLog."
^ self
evaluate:aStringOrStream
in:nil
receiver:nil
notifying:nil
logged:false
ifFail:nil
compile:true
"
Compiler evaluate:'1 + 2'
Compiler evaluate:'''hello world'' asSortedCollection displayString printNL'
Compiler evaluate:'''hello world'' asSortedCollection printNL'
"
!
evaluate:aStringOrStream compile:compile
"return the result of evaluating aString,
The compile argument specifies if the string should be compiled down to
bytecode or instead be interpreted from the parseTree.
The first should be done for doIts etc, where a readable walkback is
required.
The latter is better done for constants, styleSheet and resource
reading and simple sends, where the overhead of compilation is bigger
than the interpretation overhead."
^ self
evaluate:aStringOrStream
in:nil
receiver:nil
notifying:nil
logged:false
ifFail:nil
compile:compile
!
evaluate:aStringOrStream ifFail:failBlock
"return the result of evaluating an expression in aStringOrStream.
In case of any syntax errors, return the value of failBlock.
No doit-entry is added to the changeLog."
^ self
evaluate:aStringOrStream
in:nil
receiver:nil
notifying:nil
logged:false
ifFail:failBlock
compile:true
"
Compiler evaluate:'1 +' ifFail:['oops']
"
!
evaluate:aStringOrStream in:aContext receiver:anObject notifying:requestor ifFail:failBlock
"return the result of evaluating aStringOrStream, errors are reported to requestor.
Allow access to anObject as self and to its instVars (used in the inspector).
No doIt entry is added to the change-file.
If the failBlock argument is non-nil, it is evaluated if an error occurs."
^ self
evaluate:aStringOrStream
in:aContext
receiver:anObject
notifying:requestor
logged:false
ifFail:nil
compile:true
"Modified: / 17.1.1998 / 02:54:07 / cg"
!
evaluate:aStringOrStream in:aContext receiver:anObject notifying:requestor logged:logged ifFail:failBlock
"return the result of evaluating aStringOrStream, errors are reported to requestor.
Allow access to anObject as self and to its instVars (used in the inspector).
If logged is true, an entry is added to the change-file. If the failBlock argument
is non-nil, it is evaluated if an error occurs."
^ self
evaluate:aStringOrStream
in:aContext
receiver:anObject
notifying:requestor
logged:logged
ifFail:failBlock
compile:true
!
evaluate:aStringOrStream in:aContext receiver:anObject notifying:requestor logged:logged ifFail:failBlock compile:compile
"return the result of evaluating aStringOrStream, errors are reported to requestor.
Allow access to anObject as self and to its instVars (used in the inspector).
If logged is true, an entry is added to the change-file. If the failBlock argument
is non-nil, it is evaluated if an error occurs.
Finally, compile specifies if the string should be compiled down to
bytecode or instead be interpreted from the parseTree.
The first should be done for doIts etc, where a readable walkback is
required.
The latter is better done for constants, styleSheet and resource
reading and simple sends, where the overhead of compilation is bigger
than the interpretation overhead."
^ self new
evaluate:aStringOrStream in:aContext receiver:anObject notifying:requestor logged:logged ifFail:failBlock compile:compile
!
evaluate:aStringOrStream logged:logged
"return the result of evaluating an expression in aStringOrStream.
The argument log controls if an entry is added to the changeLog."
^ self
evaluate:aStringOrStream
in:nil
receiver:nil
notifying:nil
logged:logged
ifFail:nil
compile:true
"
Compiler evaluate:'''some string''' logged:false
Compiler evaluate:'''some string''' logged:true
"
!
evaluate:aStringOrStream notifying:requestor
"return the result of evaluating aString,
errors are reported to requestor"
^ self
evaluate:aStringOrStream
in:nil
receiver:nil
notifying:requestor
logged:false
ifFail:nil
compile:true
!
evaluate:aStringOrStream notifying:requestor compile:compile
"return the result of evaluating aString,
errors are reported to requestor.
The compile argument specifies if the string should be compiled down to
bytecode or instead be interpreted from the parseTree.
The first should be done for doIts etc, where a readable walkback is
required.
The latter is better done for constants, styleSheet and resource
reading and simple sends, where the overhead of compilation is bigger
than the interpretation overhead."
^ self
evaluate:aStringOrStream
in:nil
receiver:nil
notifying:requestor
logged:false
ifFail:nil
compile:compile
!
evaluate:aStringOrStream notifying:requestor logged:logged
"return the result of evaluating aString,
errors are reported to requestor"
^ self
evaluate:aStringOrStream
in:nil
receiver:nil
notifying:requestor
logged:logged
ifFail:nil
compile:true
!
evaluate:aStringOrStream receiver:anObject
"return the result of evaluating aString,
errors are reported to requestor. Allow access to
anObject as self and to its instVars "
^ self
evaluate:aStringOrStream
in:nil
receiver:anObject
notifying:nil
logged:false
ifFail:nil
compile:true
"
Compiler evaluate:'self x' receiver:(1 @ 2)
"
"Created: 1.7.1997 / 19:02:24 / cg"
"Modified: 1.7.1997 / 19:02:33 / cg"
!
evaluate:aStringOrStream receiver:someOne logged:logged
"return the result of evaluating an expression in aStringOrStream.
The argument log controls if an entry is added to the changeLog."
^ self
evaluate:aStringOrStream
in:nil
receiver:someOne
notifying:nil
logged:logged
ifFail:nil
compile:true
"
Compiler evaluate:'''some string''' logged:false
Compiler evaluate:'''some string''' logged:true
Compiler evaluate:'self class' receiver:nil logged:false
Compiler evaluate:'self class' receiver:1 logged:false
"
!
evaluate:aStringOrStream 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:aStringOrStream
in:nil
receiver:anObject
notifying:requestor
logged:false
ifFail:nil
compile:true
"
Compiler evaluate:'self x' receiver:(1 @ 2) notifying:nil
"
!
evaluate:aStringOrStream receiver:anObject notifying:requestor compile:compile
"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).
The compile argument specifies if the string should be compiled down to
bytecode or instead be interpreted from the parseTree.
The first should be done for doIts etc, where a readable walkback is
required.
The latter is better done for constants, styleSheet and resource
reading and simple sends, where the overhead of compilation is bigger
than the interpretation overhead."
^ self
evaluate:aStringOrStream
in:nil
receiver:anObject
notifying:requestor
logged:false
ifFail:nil
compile:compile
! !
!Parser class methodsFor:'general helpers'!
argAndVarNamesForContext:aContext
"helper: given a context, return a collection of arg&var names"
|homeContext method numArgs numVars m src
blockNode argNames varNames vars sel isDoIt|
numArgs := aContext numArgs.
numVars := aContext numVars.
(numArgs == 0 and:[numVars == 0]) ifTrue:[^ #()].
homeContext := aContext methodHome.
sel := homeContext selector.
method := homeContext method.
"/ #doIt needs special handling below
isDoIt := (sel == #doIt) or:[sel == #doIt:].
aContext isBlockContext ifFalse:[
isDoIt ifTrue:[
method notNil ifTrue:[
"/ special for #doIt
m := nil.
src := ('[' , method source , '\]') withCRs.
blockNode := Compiler
blockAtLine:(aContext lineNumber)
in:m
orSource:src
numArgs:numArgs
numVars:numVars.
blockNode notNil ifTrue:[
argNames := #().
varNames := #().
numArgs > 0 ifTrue:[
vars := blockNode arguments.
vars size > 0 ifTrue:[
argNames := vars collect:[:var | var name]
]
].
numVars > 0 ifTrue:[
vars := blockNode variables.
vars size > 0 ifTrue:[
varNames := vars collect:[:var | var name].
]
].
^ argNames , varNames
].
]
].
method notNil ifTrue:[
^ method methodArgAndVarNames.
].
^ #()
].
method notNil ifTrue:[
isDoIt ifTrue:[
"/ special for #doIt
"/ my source is found in the method.
m := nil.
src := ('[' , method source , '\]') withCRs.
] ifFalse:[
m := method.
src := nil.
].
blockNode := Compiler
blockAtLine:(aContext lineNumber)
in:m
orSource:src
numArgs:numArgs
numVars:numVars.
blockNode notNil ifTrue:[
argNames := #().
varNames := #().
numArgs > 0 ifTrue:[
vars := blockNode arguments.
vars size > 0 ifTrue:[
argNames := vars collect:[:var | var name]
]
].
numVars > 0 ifTrue:[
vars := blockNode variables.
vars size > 0 ifTrue:[
varNames := vars collect:[:var | var name].
]
].
^ argNames , varNames
].
].
^ #()
"Created: / 17.1.1998 / 03:18:05 / cg"
"Modified: / 17.1.1998 / 03:55:44 / cg"
! !
!Parser class methodsFor:'parsing'!
blockAtLine:line in:aMethod orSource:aString numArgs:nA numVars:nV
"given a lineNr in some method,
return the containing BlockNode or nil.
The given lineNr must be within a block for this to work.
This is used by the debugger, to guess reverse from a lineNumber,
to the corresponding block, in order to find out the blocks
variable names (mhmh - all of this wasnt't needed, if blocks stored
their characterPosition internally)."
|compiler tree mSource who mClass blocks
maxSoFar innerBlock m|
(line isNil or:[line == self maxLineNumber]) ifTrue:[
^ nil
].
aMethod notNil ifTrue:[
m := aMethod.
who := m who.
who isNil ifTrue:[
m isWrapped ifTrue:[
m := m wrapper.
m notNil ifTrue:[
who := m who.
]
]
].
who notNil ifTrue:[
mClass := who methodClass.
mClass isNil ifTrue:[ ^ nil].
].
mSource := m source.
mSource isNil ifTrue:[^ nil].
] ifFalse:[
aString notNil ifTrue:[
mSource := aString.
mClass := UndefinedObject
] ifFalse:[
^ nil
]
].
"create a compiler, let it parse and create the parsetree"
compiler := self for:(ReadStream on:mSource) in:mClass.
compiler parseForCode.
compiler notifying:nil.
compiler ignoreWarnings:true.
compiler ignoreErrors:true.
compiler lineNumberInfo:#full.
aMethod notNil ifTrue:[
(compiler parseMethodSpec == #Error) ifTrue:[
^ nil.
].
who notNil ifTrue:[
compiler selector ~~ (who methodSelector) ifTrue:[
^ nil
]
].
] ifFalse:[
compiler nextToken.
].
tree := compiler parseMethodBody.
(compiler errorFlag
or:[tree == #Error
or:[tree isNil]]) ifTrue:[
^ nil
].
blocks := OrderedCollection new.
tree collectBlocksInto:blocks.
blocks := blocks select:[:aBlock |
line between: aBlock lineNumber and:aBlock endLineNumber
].
blocks size == 1 ifTrue:[
^ blocks at:1
].
nA notNil ifTrue:[
blocks := blocks select:[:aBlock |
aBlock numArgs == nA
].
blocks size == 1 ifTrue:[
^ blocks at:1
].
].
nV notNil ifTrue:[
blocks := blocks select:[:aBlock |
aBlock numVars == nV
].
blocks size == 1 ifTrue:[
^ blocks at:1
].
].
"/ look for the inner one
maxSoFar := 0.
blocks do:[:aBlock |
aBlock lineNumber > maxSoFar ifTrue:[
innerBlock := aBlock.
maxSoFar := aBlock lineNumber
]
].
^ innerBlock.
"Created: 11.1.1997 / 23:29:13 / cg"
"Modified: 14.2.1997 / 16:51:25 / cg"
!
checkMethod:aString in:aClass ignoreErrors:ignoreErrors ignoreWarnings:ignoreWarnings
"parse a method in a given class.
Return a parser (if ok), nil (empty) or #Error (syntax).
The parser can be queried for selector, receiver, args, locals,
used selectors, modified instvars, referenced classvars etc.
The noErrors and noWarnings arguments specify if error and warning
messages should be sent to the Transcript or suppressed."
|parser tree|
aString isNil ifTrue:[^ nil].
parser := self for:(ReadStream on:aString) in:aClass.
parser ignoreErrors:ignoreErrors.
parser ignoreWarnings:ignoreWarnings.
tree := parser parseMethod.
(parser errorFlag or:[tree == #Error]) ifTrue:[^ nil].
ReadBeforeWrittenTester searchForReadBeforeWrittenIn:tree
"
self
checkMethod:'foo
|local1 local2 local3|
local1 := local2.
^ local3
'
in:UndefinedObject
ignoreErrors:true
ignoreWarnings:true
"
"Modified: / 30.10.1997 / 16:38:31 / cg"
!
parseExpression:aString
"parse aString as an expression;
Return the parseTree (if ok), nil (for an empty string
or comment only) or #Error (syntactic error).
Error and warning messages are suppressed."
^ self
withSelf:nil
parseExpression:aString
onError:#Error
notifying:nil
ignoreErrors:true "silence on Transcript"
ignoreWarnings:true
inNameSpace:nil
"
Parser parseExpression:'self foo'
Parser parseExpression:'self:123'
Parser parseExpression:'self:123' onError:nil
"
!
parseExpression:aString inNameSpace:aNameSpaceOrNil
"parse aString as an expression;
Return the parseTree (if ok), nil (for an empty string
or comment only) or #Error (syntactic error).
Error and warning messages are suppressed."
^ self
withSelf:nil
parseExpression:aString
onError:#Error
notifying:nil
ignoreErrors:true "silence on Transcript"
ignoreWarnings:true
inNameSpace:aNameSpaceOrNil
"Modified: 24.6.1997 / 16:44:00 / cg"
"Created: 24.6.1997 / 16:44:26 / cg"
!
parseExpression:aString inNameSpace:aNameSpaceOrNil onError:errorValue
"parse aString as an expression;
Return the parseTree (if ok), nil (for an empty string
or comment only) or errorValue (syntactic error).
Error and warning messages are suppressed."
^ self
withSelf:nil
parseExpression:aString
onError:errorValue
notifying:nil
ignoreErrors:true "silence on Transcript"
ignoreWarnings:true
inNameSpace:aNameSpaceOrNil
"Modified: 24.6.1997 / 16:44:00 / cg"
"Created: 24.6.1997 / 16:44:26 / cg"
!
parseExpression:aString onError:errorValue
"parse aString as an expression;
Return the parseTree (if ok), nil (for an empty string
or comment only) or errorValue (syntactic error).
Error and warning messages are suppressed."
^ self
withSelf:nil
parseExpression:aString
onError:errorValue
notifying:nil
ignoreErrors:true "silence on Transcript"
ignoreWarnings:true
inNameSpace:nil
"Modified: 24.6.1997 / 16:44:00 / cg"
!
parseMethod:aString
"parse a method.
Return a parser (if ok), nil (empty) or #Error (syntax).
The parser can be queried for selector, receiver, args, locals,
used selectors etc.
Error and warning messages are sent to the Transcript."
^ self parseMethod:aString in:nil
"
|p|
p := Parser
parseMethod:'
foo:arg1 bar:arg2 baz:arg3
|l1 l2|
l1 := 0.
l2 := arg1.
^ self'.
'nArgs: ' print. p numberOfMethodArgs printNL.
'args: ' print. p methodArgs printNL.
'sel: ' print. p selector printNL.
'nLocal: ' print. p numberOfMethodVars printNL.
'locals: ' print. p methodVars printNL.
'tree: ' printNL. p tree printAllOn:Stdout. Stdout cr.
"
"Modified: 24.4.1996 / 13:18:02 / cg"
!
parseMethod:aString in:aClass
"parse a method in a given class.
Return a parser (if ok), nil (empty) or #Error (syntax).
The parser can be queried for selector, receiver, args, locals,
used selectors, modified instvars, referenced classvars etc.
Error and warning messages are sent to the Transcript."
^ self
parseMethod:aString
in:aClass
ignoreErrors:false
ignoreWarnings:false
"Modified: 24.4.1996 / 13:18:34 / cg"
!
parseMethod:aString in:aClass ignoreErrors:ignoreErrors ignoreWarnings:ignoreWarnings
"parse a method in a given class.
Return a parser (if ok), nil (empty) or #Error (syntax).
The parser can be queried for selector, receiver, args, locals,
used selectors, modified instvars, referenced classvars etc.
The noErrors and noWarnings arguments specify if error and warning
messages should be sent to the Transcript or suppressed."
|parser tree|
aString isNil ifTrue:[^ nil].
parser := self for:(ReadStream on:aString) in:aClass.
parser ignoreErrors:ignoreErrors.
parser ignoreWarnings:ignoreWarnings.
tree := parser parseMethod.
(parser errorFlag or:[tree == #Error]) ifTrue:[^ nil].
^ parser
"Modified: 24.4.1996 / 13:19:23 / cg"
!
parseMethod:aString in:aClass warnings:warnBoolean
"parse a method in a given class.
Return a parser (if ok), nil (empty) or #Error (syntax).
The parser can be queried for selector, receiver, args, locals,
used selectors, modified instvars, referenced classvars etc.
The warnBoolean arguments specifies if warning
messages should be sent to the Transcript or suppressed.
This method is OBSOLETE, and left in for backward compatibility."
self obsoleteMethodWarning.
^ self
parseMethod:aString
in:aClass
ignoreErrors:false
ignoreWarnings:warnBoolean not
"Modified: 24.4.1996 / 13:28:05 / cg"
!
parseMethodArgAndVarSpecification:aString
"parse a methods selector, arg and var spec (i.e. locals);
Return a parser (if ok), nil (empty) or #Error (syntax).
The parser can be queried for selector, receiver etc.
Error and warning messages are sent to the Transcript.
This method is OBSOLETE."
self obsoleteMethodWarning.
^ self parseMethodArgAndVarSpecification:aString in:nil
"
|p|
p := Parser
parseMethodArgAndVarSpecification:'
foo:arg1 bar:arg2 baz:arg3
|l1 l2|'.
'nArgs: ' print. p numberOfMethodArgs printNL.
'args: ' print. p methodArgs printNL.
'sel: ' print. p selector printNL.
'nLocal: ' print. p numberOfMethodVars printNL.
'locals: ' print. p methodVars printNL.
"
"Modified: 24.4.1996 / 13:29:43 / cg"
!
parseMethodArgAndVarSpecification:aString in:aClass
"parse a methods selector, arg and var spec in a given class;
Return a parser (if ok), nil (empty) or #Error (syntax).
The parser can be queried for selector, receiver, args and locals.
Error and warning messages are sent to the Transcript.
This method is OBSOLETE."
self obsoleteMethodWarning.
^ self parseMethodArgAndVarSpecification:aString
in:aClass
ignoreErrors:false
ignoreWarnings:false
parseBody:false
"Modified: 24.4.1996 / 13:30:03 / cg"
!
parseMethodArgAndVarSpecification:aString in:aClass ignoreErrors:ignoreErrors ignoreWarnings:ignoreWarnings parseBody:body
"parse a methods selector, arg and var spec in a given class;
If parseBody is true, also parse the statements
(for primitives & resourceSpecs).
The noErrors and noWarnings arguments specify if error and warning
messages should be sent to the Transcript or suppressed.
Return a parser (if ok), nil (empty) or #Error (syntax).
The parser can be queried for selector, receiver, args and locals"
|parser|
aString isNil ifTrue:[^ nil].
parser := self for:(ReadStream on:aString) in:aClass.
parser ignoreErrors:ignoreErrors.
parser ignoreWarnings:ignoreWarnings.
"/ parser nextToken.
(parser parseMethodSpec == #Error) ifTrue:[^ nil].
"/
"/ used to be #parseMethodBodyVarSpec
"/ - now, alternatively parse body for resource & primitive specs ..
"/
body ifTrue:[
parser parseMethodBodyOrEmpty
] ifFalse:[
parser parseMethodBodyVarSpec
].
parser errorFlag ifTrue:[^ nil].
^ parser
"Created: 24.4.1996 / 13:13:06 / cg"
"Modified: 27.4.1996 / 16:58:02 / cg"
!
parseMethodArgAndVarSpecificationSilent:aString
"parse a methods selector, arg and var spec (i.e. locals);
Return a parser (if ok), nil (empty) or #Error (syntax).
The parser can be queried for selector, receiver etc.
Like #parseMethodArgAndVarSpecification:, but does NOT
display error/warning messages on the transcript."
^ self parseMethodArgAndVarSpecificationSilent:aString in:nil
"Modified: 24.4.1996 / 13:30:54 / cg"
!
parseMethodArgAndVarSpecificationSilent:aString in:aClass
"parse a methods selector, arg and var spec in a given class;
Return a parser (if ok), nil (empty) or #Error (syntax).
The parser can be queried for selector, receiver, args and locals.
Like #parseMethodArgAndVarSpecification:in:, but does not
display error/warning messages on the transcript."
^ self parseMethodArgAndVarSpecification:aString
in:aClass
ignoreErrors:true
ignoreWarnings:true
parseBody:false
"Modified: 24.4.1996 / 13:14:27 / cg"
!
parseMethodSilent:aString
"parse a method.
Return a parser (if ok), nil (empty) or #Error (syntax).
The parser can be queried for selector, receiver, args, locals,
used selectors etc.
Like #parseMethod:, but warning/error messages are suppressed."
^ self parseMethodSilent:aString in:nil
"Modified: 24.4.1996 / 13:32:44 / cg"
!
parseMethodSilent:aString in:aClass
"parse a method in a given class.
Return a parser (if ok), nil (empty) or #Error (syntax).
The parser can be queried for selector, receiver, args, locals,
used selectors, modified instvars, referenced classvars etc.
Like #parseMethod:in:, but warning/error messages are suppressed."
^ self
parseMethod:aString
in:aClass
ignoreErrors:true
ignoreWarnings:true
"Modified: 24.4.1996 / 13:32:57 / cg"
!
parseMethodSpecification:aString
"parse a methods selector & arg specification;
Return a parser (if ok), nil (empty) or #Error (syntax).
The parser can be queried for selector, receiver etc."
^ self parseMethodSpecification:aString in:nil
"
|p|
p := Parser parseMethodSpecification:'foo:arg1 bar:arg2 baz:arg3'.
'nArgs: ' print. p numberOfMethodArgs printNL.
'args: ' print. p methodArgs printNL.
'sel: ' print. p selector printNL
"
!
parseMethodSpecification:aString in:aClass
"parse a methods selector & arg spec for a given class;
Return a parser (if ok), nil (empty) or #Error (syntax).
The parser can be queried for selector, receiver etc."
^ self parseMethodSpecification:aString
in:aClass
ignoreErrors:false
ignoreWarnings:false
!
parseMethodSpecification:aString in:aClass ignoreErrors:ignoreErrors ignoreWarnings:ignoreWarnings
"parse a methods selector & arg spec for a given class;
Return a parser (if ok), nil (empty) or #Error (syntax).
The parser can be queried for selector, receiver etc.
noErrors and noWarnings specify if error- and warningMessages are
to be output onto the Transcript."
|parser tree|
aString isNil ifTrue:[^ nil].
parser := self for:(ReadStream on:aString) in:aClass.
parser ignoreErrors:ignoreErrors.
parser ignoreWarnings:ignoreWarnings.
"/ parser nextToken.
tree := parser parseMethodSpec.
(parser errorFlag or:[tree == #Error]) ifTrue:[^ #Error].
^ parser
"Modified: 20.4.1996 / 20:09:48 / cg"
!
parseMethodSpecificationSilent:aString
"parse a methods selector & arg specification;
Return a parser (if ok), nil (empty) or #Error (syntax).
The parser can be queried for selector, receiver etc.
Like #parseMethodSpecification:, but does not display any error/warning Messages on the transcript."
^ self parseMethodSpecificationSilent:aString in:nil
!
parseMethodSpecificationSilent:aString in:aClass
"parse a methods selector & arg spec for a given class;
Return a parser (if ok), nil (empty) or #Error (syntax).
The parser can be queried for selector, receiver etc.
Like #parseMethodSpecification:in:, but does not display any error/warning Messages on the transcript."
^ self parseMethodSpecification:aString
in:aClass
ignoreErrors:true
ignoreWarnings:true
"Created: 31.10.1995 / 14:37:49 / cg"
!
selectorInExpression:aString
"parse an expression - return the selector. Even malformed expressions
(such as missing receiver or missing arg are parsed.
Used for the SystemBrowsers implementors/senders query-box initial text.
Returns nil if unparsable."
|tree parser sel|
(aString size == 0) ifTrue:[^ nil].
Error
handle:[:ex | ]
do:[
tree := self withSelf:nil
parseExpression:aString
notifying:nil
ignoreErrors:true
ignoreWarnings:true.
].
"
special: take the expression of the right side, if its an
assignment or return
"
(tree notNil and:[tree ~~ #Error]) ifTrue:[
(tree isAssignment
or:[tree isReturnNode]) ifTrue:[
tree expression isMessage ifTrue:[
tree := tree expression
]
].
tree isMessage ifTrue:[
^ tree selector
].
].
"
mhmh, try expression without receiver
"
parser := self for:(ReadStream on:aString).
parser ignoreErrors:true.
parser nextToken.
Error
handle:[:ex | ]
do:[
sel := parser degeneratedKeywordExpressionForSelector
].
^ sel
"
Parser selectorInExpression:'foo at:1 put:(5 * bar)'
Parser selectorInExpression:'(foo at:1) at:1'
Parser selectorInExpression:'a + 4'
Parser selectorInExpression:'a negated'
Parser selectorInExpression:'at:1 put:5'
Parser selectorInExpression:'at:1 put:'
Parser selectorInExpression:'a at:1 put:5'
Parser selectorInExpression:'a at:1 put:'
Parser selectorInExpression:'a := foo at:1 put:5'
"
"Modified: 17.12.1996 / 12:12:47 / cg"
!
withSelf:anObject parseExpression:aString notifying:someOne
"parse aString as an expression with self set to anObject;
Return the parseTree (if ok), nil (for an empty string
or comment only ) or #Error (syntactic error).
Errors and warnings are forwarded to someOne (usually some
codeView) which can highlight it and show a popup box."
^ self
withSelf:anObject
parseExpression:aString
onError:#Error
notifying:someOne
ignoreErrors:false
ignoreWarnings:false
inNameSpace:nil
"Modified: 24.6.1997 / 16:43:37 / cg"
!
withSelf:anObject parseExpression:aString notifying:someOne ignoreErrors:ignore
"parse aString as an expression with self set to anObject;
Return the parseTree (if ok), nil (for an empty string
or comment only ) or #Error (syntactic error).
Errors and warnings are forwarded to someOne (usually some
codeView) which can highlight it and show a popup box."
^ self
withSelf:anObject
parseExpression:aString
onError:#Error
notifying:someOne
ignoreErrors:ignore
ignoreWarnings:ignore
inNameSpace:nil
"Modified: 24.6.1997 / 16:43:26 / cg"
!
withSelf:anObject parseExpression:aString notifying:someOne ignoreErrors:ignoreErrors ignoreWarnings:ignoreWarnings
"parse aString as an expression with self set to anObject;
Return the parseTree (if ok), nil (for an empty string
or comment only ) or #Error (syntactic error).
Errors and warnings are forwarded to someOne (usually some
codeView) which can highlight it and show a popup box,
iff ignoreErrors/ignoreWarnings is true respectively."
^ self
withSelf:anObject
parseExpression:aString
onError:#Error
notifying:someOne
ignoreErrors:ignoreErrors
ignoreWarnings:ignoreWarnings
inNameSpace:nil
"Modified: 24.6.1997 / 16:43:12 / cg"
!
withSelf:anObject parseExpression:aString notifying:someOne ignoreErrors:ignoreErrors ignoreWarnings:ignoreWarnings inNameSpace:aNameSpaceOrNil
"parse aString as an expression with self set to anObject;
Return the parseTree (if ok), nil (for an empty string
or comment only ) or #Error (syntactic error).
Errors and warnings are forwarded to someOne (usually some
codeView) which can highlight it and show a popup box,
iff ignoreErrors/ignoreWarnings is true respectively."
^ self
withSelf:anObject
parseExpression:aString
onError:#Error
notifying:someOne
ignoreErrors:ignoreErrors
ignoreWarnings:ignoreWarnings
inNameSpace:aNameSpaceOrNil
!
withSelf:anObject parseExpression:aString onError:errorValue notifying:someOne ignoreErrors:ignoreErrors ignoreWarnings:ignoreWarnings inNameSpace:aNameSpaceOrNil
"parse aString as an expression with self set to anObject;
Return the parseTree (if ok), nil (for an empty string
or comment only ) or errorValue (syntactic error).
Errors and warnings are forwarded to someOne (usually some
codeView) which can highlight it and show a popup box,
iff ignoreErrors/ignoreWarnings is true respectively."
|parser tree|
aString isNil ifTrue:[^ nil].
parser := self for:(ReadStream on:aString).
tree := parser
parseExpressionWithSelf:anObject
notifying:someOne
ignoreErrors:ignoreErrors
ignoreWarnings:ignoreWarnings
inNameSpace:aNameSpaceOrNil.
tree == #Error ifTrue:[
^ errorValue value
].
^ tree
"Modified: / 14.12.1999 / 15:12:16 / cg"
! !
!Parser class methodsFor:'unparsing'!
methodSpecificationForSelector:aSelector
"given a selector such as #foo:bar:, return a string that could
serve as a methods specification source code.
To be used for code generators"
|argNames n|
n := aSelector numArgs.
n == 1 ifTrue:[
argNames := #('arg')
] ifFalse:[
n <= 15 ifTrue:[
argNames := #('arg1' 'arg2' 'arg3' 'arg4' 'arg5' 'arg6'
'arg7' 'arg8' 'arg9' 'arg10' 'arg11' 'arg12'
'arg13' 'arg14' 'arg15')
] ifFalse:[
argNames := (1 to:aSelector numArgs) collect:[:i | 'arg' , i printString].
].
].
^ self methodSpecificationForSelector:aSelector argNames:argNames
"
Parser methodSpecificationForSelector:#foo:
Parser methodSpecificationForSelector:#foo:bar:
Parser methodSpecificationForSelector:#foo:bar:baz:
Parser methodSpecificationForSelector:#+
Parser methodSpecificationForSelector:#negated
"
"Modified: / 12.2.1999 / 13:12:44 / cg"
!
methodSpecificationForSelector:aSelector argNames:argNames
"given a selector such as #foo:bar:, return a string that could
serve as a methods specification source code.
To be used for code generators"
|s nargs parts part|
s := WriteStream on:String new.
nargs := aSelector numArgs.
nargs == 0 ifTrue:[
s nextPutAll:aSelector
] ifFalse:[
parts := aSelector partsIfSelector.
1 to:nargs do:[:i |
part := parts at:i.
s nextPutAll:part.
(part endsWith:$:) ifFalse:[
s space.
].
s nextPutAll:(argNames at:i).
i ~~ nargs ifTrue:[s space].
]
].
^ s contents
"
Parser methodSpecificationForSelector:#foo:bar: argNames:#('one' 'two' 'three')
Parser methodSpecificationForSelector:#+ argNames:#('one')
Parser methodSpecificationForSelector:#negated
"
"Modified: / 12.2.1999 / 12:33:50 / cg"
! !
!Parser methodsFor:'Compatibility - ST80'!
evaluate:aString in:aClassOrContext to:to notifying:aRequestor ifFail:failBlock
|parseTree value|
aString isNil ifTrue:[^ nil].
self initializeFor:(ReadStream on:aString).
"/ stupid - there seem to be differences among the various
"/ ST dialects ...
aClassOrContext isBehavior ifTrue:[
self setClassToCompileFor:aClassOrContext.
selfValue := nil.
] ifFalse:[
self setContext:aClassOrContext.
aClassOrContext notNil ifTrue:[
self setSelf:(aClassOrContext receiver)
].
].
requestor := aRequestor.
self nextToken.
parseTree := self parseMethodBody.
(errorFlag or:[tree == #Error]) ifTrue:[^ #Error].
parseTree notNil ifTrue:[
self evalExitBlock:[:value | ^ failBlock value].
value := parseTree evaluate
].
self release.
^ value
!
parse:methodSource in:aClass notifying:aRequestor
"parse a methods source.
Return the methods parseTree"
self initializeFor:methodSource.
classToCompileFor := aClass.
requestor := aRequestor.
self parseMethod.
^ MethodNode new
selector:selector
arguments:methodArgs
locals:methodVars
statements:tree asCollectionOfStatements
"Created: / 17.10.1997 / 12:35:01 / cg"
"Modified: / 5.11.2001 / 16:56:43 / cg"
!
parseSelector:aStringOrStream
"parse a methods source for the methods selector.
Return the selector"
self initializeFor:aStringOrStream.
self parseMethodSpec.
^ selector.
"
Parser new
parseSelector:'
parseSelector:aStringOrStream
self initializeFor:aStringOrStream.
self parseMethodSpec.
^ selector.
'
"
"Modified: 17.10.1997 / 12:35:46 / cg"
! !
!Parser methodsFor:'Signal constants'!
restartCompilationSignal
^ RestartCompilationSignal
"Created: / 15.11.2001 / 22:57:05 / cg"
! !
!Parser methodsFor:'accessing'!
correctedSource
^ correctedSource
!
errorFlag
"return true if there where any errors (valid after parsing)"
^ errorFlag
!
evalExitBlock:aBlock
"when evaluating a return expression, this block is evaluated"
evalExitBlock := aBlock
!
getNameSpace
"retrieve the nameSpace, as found in a Namespace directive"
^ currentNamespace
"Modified: 8.11.1996 / 13:45:35 / cg"
!
primitiveNumber
"return the ST-80 style primitiveNumber or nil (valid after parsing)"
^ primitiveNr
!
primitiveResources
"return the ST-80 style resource info or nil (valid after parsing)."
^ primitiveResource
"Created: 29.5.1996 / 17:28:00 / cg"
!
release
methodArgs := methodVars := tree := selfNode := superNode := nilNode := nil.
super release.
"Modified: / 31.3.1998 / 19:45:58 / cg"
!
setNameSpace:aNameSpaceName
currentNamespace := NameSpace fullName:aNameSpaceName
"Modified: 8.11.1996 / 13:43:14 / cg"
!
setPackage:aPackageID
currentPackage := aPackageID
!
targetClass
^ classToCompileFor
!
targetClass:aClass
classToCompileFor := aClass
!
tree
"return the parsetree"
^tree
!
tree:aTree
"private: set the tree - for internal use only"
tree := aTree
!
warnSTXHereExtensionUsed
"return the value of the instance variable 'warnSTXHereExtensionUsed' (automatically generated)"
^ warnSTXHereExtensionUsed
! !
!Parser methodsFor:'dummy - syntax detection'!
markArgumentIdentifierFrom:pos1 to:pos2
"Created: / 31.3.1998 / 13:22:15 / cg"
!
markBadIdentifierFrom:pos1 to:pos2
"Modified: / 31.3.1998 / 19:16:26 / cg"
"Created: / 31.3.1998 / 19:35:53 / cg"
!
markBooleanConstantFrom:pos1 to:pos2
"Created: / 31.3.1998 / 18:06:22 / cg"
!
markBracketAt:pos
!
markConstantFrom:pos1 to:pos2
"Created: / 31.3.1998 / 18:06:24 / cg"
!
markGlobalClassIdentifierFrom:pos1 to:pos2
"Created: / 4.3.1999 / 12:52:45 / cg"
!
markGlobalIdentifierFrom:pos1 to:pos2
"Created: / 31.3.1998 / 15:29:39 / cg"
!
markHereFrom:pos1 to:pos2
"Created: / 31.3.1998 / 17:39:01 / cg"
!
markIdentifierFrom:pos1 to:pos2
"Created: / 31.3.1998 / 18:06:17 / cg"
!
markInstVarIdentifierFrom:pos1 to:pos2
"Created: / 16.4.1998 / 18:34:10 / cg"
!
markLocalIdentifierFrom:pos1 to:pos2
"Created: / 31.3.1998 / 15:29:35 / cg"
!
markMethodSelectorFrom:pos1 to:pos2
"Modified: / 31.3.1998 / 13:30:09 / cg"
"Created: / 31.3.1998 / 16:39:44 / cg"
!
markReturnAt:pos
"Created: / 5.1.1980 / 00:48:24 / cg"
!
markSelector:sel from:pos1 to:pos2 receiverNode:aNode
"Created: / 31.3.1998 / 13:22:15 / cg"
"Modified: / 31.3.1998 / 13:30:09 / cg"
!
markSelfFrom:pos1 to:pos2
"Created: / 31.3.1998 / 17:49:38 / cg"
!
markSuperFrom:pos1 to:pos2
"Created: / 31.3.1998 / 17:40:20 / cg"
!
markUnknownIdentifierFrom:pos1 to:pos2
"Modified: / 31.3.1998 / 19:16:26 / cg"
"Created: / 31.3.1998 / 19:35:53 / cg"
!
markVariable:v
"support for syntaxColoring"
"Modified: / 16.4.1998 / 18:47:45 / cg"
!
markVariable:v from:pos1 to:pos2
"support for syntaxColoring"
"Modified: / 16.4.1998 / 18:47:45 / cg"
"Created: / 16.4.1998 / 18:50:03 / cg"
! !
!Parser methodsFor:'error correction'!
addDoItTemporary:varName
|holder|
doItTemporaries isNil ifTrue:[
doItTemporaries := IdentityDictionary new.
].
doItTemporaries at:varName asSymbol put:(holder := ValueHolder new).
^ holder
!
askForCorrection:aString fromList:aList
"launch a selection box, which allows user to enter correction.
return newString or nil (for abort)"
|box rslt|
"in systems without widgets ..."
ListSelectionBox isNil ifTrue:[
^ self confirm:aString
].
box := ListSelectionBox title:aString.
box initialText:(aList at:1).
box list:aList.
box okText:'Correct'.
box action:[:aString | rslt := aString].
box showAtPointer.
box destroy.
^ rslt
!
askForCorrection:aString fromList:aList for:originalSelector
"launch a selection box, which allows user to enter correction.
return newString or nil (for abort)"
|box rslt|
"in systems without widgets ..."
ListSelectionBox isNil ifTrue:[
^ self confirm:aString
].
box := ListSelectionBox title:aString.
box initialText:(aList at:1).
box list:aList.
box okText:'Correct'.
box action:[:aString | rslt := aString].
box addButton:(Button label:'Keep Selector' action:[rslt := originalSelector. box hide]) after:(box okButton).
box showAtPointer.
box destroy.
^ rslt
!
askForVariableTypeWhenDeclaringUndefined:varName
|l how varNameIsLowercase choice holder newClass|
l := #().
how := #().
varNameIsLowercase := (varName at:1) isLowercase.
"/ BlockVar, InstVar and classInstVar not yet implemented
varNameIsLowercase ifTrue:[
"/ currentBlock notNil ifTrue:[
"/ l := l , #( 'Block local' ).
"/ how := how , #( BlockVariable ).
"/ ].
selector notNil ifTrue:[
l := l , #( 'Method Local Variable' ).
how := how , #( MethodVariable ).
].
(classToCompileFor notNil
and:[classToCompileFor isMeta not
and:[classToCompileFor isBuiltInClass not
and:[selector notNil and:[selector ~~ #doIt]]]]) ifTrue:[
l := l copyWith:'Instance Variable'.
how := how copyWith: #InstanceVariable.
].
] ifFalse:[
l := l , #( 'New Class' 'Global' 'NameSpace' ).
how := how , #( NewClass GlobalVariable NameSpace ).
(classToCompileFor notNil
and:[classToCompileFor isBuiltInClass not
and:[selector notNil and:[selector ~~ #doIt]]]) ifTrue:[
classToCompileFor isMeta ifTrue:[
l := l , #('Class Instance Variable').
how := how , #( ClassInstanceVariable).
].
l := l , #('Class Variable' ).
how := how , #( ClassVariable).
]
].
(selector isNil or:[selector == #doIt]) ifTrue:[
l size > 0 ifTrue:[
l := l , #( '-' ).
how := how , #( nil ).
].
l := l , #( 'Workspace Variable' 'DoIt Temporary').
how := how , #( WorkspaceVariable DoItTemporary ).
].
l size > 0 ifTrue:[
l := (Array with:('Declare ' , varName allBold , ' as:')
with:'-'
) , l.
how := #(nil nil) , how.
choice := (PopUpMenu labels:l) startUp.
(choice notNil and:[choice > 0]) ifTrue:[
choice := how at:choice.
choice == #WorkspaceVariable ifTrue:[
holder := Workspace addWorkspaceVariable:varName.
^ VariableNode type:#WorkspaceVariable holder:holder name:varName
].
choice == #DoItTemporary ifTrue:[
holder := self addDoItTemporary:varName.
^ VariableNode type:#DoItTemporary holder:holder name:varName
].
choice == #GlobalVariable ifTrue:[
Smalltalk at:varName asSymbol put:nil.
^ VariableNode globalNamed:varName
].
choice == #NewClass ifTrue:[
newClass := Object subclass:varName asSymbol
instanceVariableNames:''
classVariableNames:''
poolDictionaries:''
category:'* As yet uncategorized *'.
^ VariableNode globalNamed:newClass name
].
choice == #NameSpace ifTrue:[
NameSpace name:varName.
^ VariableNode globalNamed:varName
].
choice == #ClassVariable ifTrue:[
classToCompileFor theNonMetaclass addClassVarName:varName.
^ VariableNode type:#ClassVariable class:classToCompileFor theNonMetaclass name:varName
].
choice == #InstanceVariable ifTrue:[
classToCompileFor theNonMetaclass addInstVarName:varName.
"/ ST/X special - classToCompileFor is obsoleted
classToCompileFor := Smalltalk classNamed:(classToCompileFor name).
RestartCompilationSignal raise.
"/ not reached - restarted compile will not arrive here again
self error:'restart compile failed'.
].
choice == #ClassInstanceVariable ifTrue:[
classToCompileFor theMetaclass addInstVarName:varName.
"/ ST/X special - classToCompileFor is obsoleted
classToCompileFor := Smalltalk classNamed:(classToCompileFor name).
RestartCompilationSignal raise.
"/ not reached - restarted compile will not arrive here again
self error:'restart compile failed'.
].
choice == #MethodVariable ifTrue:[
|varIndex var endLocalsPos posToInsert ins|
localVarDefPosition size == 2 ifTrue:[
endLocalsPos := posToInsert := localVarDefPosition at:2.
ins := ' ' , varName.
] ifFalse:[
endOfSelectorPosition notNil ifTrue:[
posToInsert := endOfSelectorPosition.
ins := '|' , varName , '|' , Character cr asString , Character cr asString.
ins := ins , (String new:(requestor colOfCharacterPosition:posToInsert)-1).
]
].
posToInsert notNil ifTrue:[
requestor
insertString:ins
atCharacterPosition:posToInsert.
endLocalsPos notNil ifTrue:[
localVarDefPosition at:2 put:(endLocalsPos + varName size + 1).
methodVarNames := methodVarNames copyWith:varName.
methodVars := methodVars copyWith:(var := Variable new name:varName).
] ifFalse:[
localVarDefPosition := Array with:posToInsert with:posToInsert+varName size+1.
methodVarNames := Array with:varName.
methodVars := Array with:(var := Variable new name:varName).
].
correctedSource := requestor currentSourceCode.
source := (ReadStream on:correctedSource)
position:(source position + ins size).
varIndex := methodVarNames size.
var used:true.
^ VariableNode type:#MethodVariable
name:varName
token:var
index:varIndex
].
].
self warning:'Sorry - unimplemented (adding ' , choice , ')'.
].
^ #Error
].
^ nil.
!
checkSelector:selector inClass:cls
"check wether a method with selector exists in class cls an
that the methos is not obsolete.
Return an error string on error or nil on success"
|err mthd implementor implementors|
cls isNil ifTrue:[
implementors := SystemBrowser
findImplementorsOf:selector
in:(Smalltalk allClasses)
ignoreCase:false.
implementors size == 0 ifTrue:[
^ 'is nowhere implemented'
].
^ nil
].
mthd := cls lookupMethodFor:selector.
mthd isNil ifTrue:[
cls == Boolean ifTrue:[
mthd := True lookupMethodFor:selector.
mthd isNil ifTrue:[
mthd := False lookupMethodFor:selector.
].
]
].
mthd isNil ifTrue:[
"if it implements #doesNotUnderstand somewhere, assume it is ok"
implementor := cls whichClassIncludesSelector:#doesNotUnderstand:.
(implementor isNil or:[implementor == Object]) ifTrue:[
err := 'is not implemented'
].
] ifFalse:[
mthd isObsolete ifTrue:[
err := 'is deprecated'.
].
].
^ err.
!
correctByDeleting
"correct (by deleting token) if user wants to;
return #Error if there was no correction;
nil if there was one."
|selectionSize|
(self confirm:'confirm deleting') ifFalse:[^ #Error].
"
tell requestor (i.e. CodeView) about the change
this will update what the requestor shows.
"
selectionSize := requestor selection size.
requestor deleteSelection.
"
get the updated source-string
which is needed, when we eventually install the new method
"
correctedSource := requestor currentSourceCode.
"/ update the current source position
source := (ReadStream on:correctedSource)
position:(source position - selectionSize).
^ nil
"Modified: / 22.1.1998 / 16:39:11 / stefan"
!
correctSelector:aSelectorString message:msg position:pos1 to:pos2 in:aClassOrNil for:receiverNode
"notify error and correct if user wants to;
return #Error if there was no correction
or a ParseNode as returned by variable"
|correctIt suggestedNames newSelector className classToGenerateCode|
alreadyWarnedUnimplementedSelectors isNil ifTrue:[
alreadyWarnedUnimplementedSelectors := Set new
].
(alreadyWarnedUnimplementedSelectors includes:aSelectorString) ifTrue:[
^ aSelectorString
].
"
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.
alreadyWarnedUnimplementedSelectors add:aSelectorString.
^ aSelectorString
].
correctIt := self correctableSelectorWarning:msg position:pos1 to:pos2.
correctIt == #generate ifTrue:[
receiverNode isSelf ifTrue:[
classToGenerateCode := classToCompileFor
] ifFalse:[
receiverNode isVariable ifTrue:[
receiverNode isGlobal ifTrue:[
classToGenerateCode := receiverNode evaluate.
classToGenerateCode isBehavior ifTrue:[
classToGenerateCode := classToGenerateCode theMetaclass.
] ifFalse:[
classToGenerateCode := nil
].
].
]
].
classToGenerateCode isNil ifTrue:[
className := Dialog request:'Generate code in class:' initialAnswer:classToCompileFor name.
className size == 0 ifTrue:[
^ aSelectorString
].
classToGenerateCode := Smalltalk at:className asSymbol.
classToGenerateCode isNil ifTrue:[
self warn:'No such class.'.
^ aSelectorString
].
].
(classToGenerateCode includesSelector:aSelectorString asSymbol) ifFalse:[
"do not overwrite an already existant (deprecated) method"
classToGenerateCode
compile:((self class methodSpecificationForSelector:aSelectorString) , '\ self shouldImplement' withCRs)
classified:(Compiler defaultMethodCategory).
].
correctIt := false.
].
correctIt ifFalse:[
alreadyWarnedUnimplementedSelectors add:aSelectorString.
^ aSelectorString
].
suggestedNames := self findBestSelectorsFor:aSelectorString in:aClassOrNil.
suggestedNames notNil ifTrue:[
newSelector := self askForCorrection:'Correct Selector to: ' fromList:suggestedNames for:aSelectorString.
newSelector isNil ifTrue:[AbortSignal raise "^ aSelectorString"].
] ifFalse:[
self information:'no good correction found'.
^ aSelectorString
].
"
tell requestor (i.e. CodeView) about the change
this will update what the requestor shows.
"
requestor replaceSelectionBy:newSelector keepCursor:false.
"
get the updated source-string
which is needed, when we eventually install the new method
"
correctedSource := requestor currentSourceCode.
source := (ReadStream on:correctedSource)
position:(source position + 1 + (newSelector size - aSelectorString size)).
"/ Parser murks.
^ newSelector
"Modified: / 22.1.1998 / 16:36:04 / stefan"
"Created: / 19.1.2000 / 16:34:01 / cg"
"Modified: / 19.1.2000 / 16:34:55 / cg"
!
correctSourceByDeletingFrom:start to:stop
"correct (by deleting token) if user wants to;
return #Error if there was no correction;
nil if there was one."
|deleteSize|
"
tell requestor (i.e. CodeView) about the change
this will update what the requestor shows.
"
deleteSize := stop - start + 1.
requestor deleteFromCharacterPosition:start to:stop.
"
get the updated source-string
which is needed, when we eventually install the new method
"
correctedSource := requestor currentSourceCode.
"/ update the current source position
source := (ReadStream on:correctedSource)
position:(source position - deleteSize).
^ nil
!
correctVariable:varName atPosition: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 suggestedNames newName rslt
varNameIsLowercase undeclared boldName|
varNameIsLowercase := (varName at:1) isLowercase.
correctIt := self undefError:varName position:pos1 to:pos2.
(correctIt == false or:[correctIt == #continue]) ifTrue:[
"/ no correction wanted.
"/ lowerCase vars are added to the Undeclared dictionary,
"/ allowing easy search for bad-spots later.
boldName := varName allBold.
varNameIsLowercase ifTrue:[
undeclared := Smalltalk at:#Undeclared.
((undeclared notNil)
and:[(undeclared includes:varName asSymbol)]) ifFalse:[
self warning:('Adding ''' , boldName , ''' as Undeclared.\\Remember to fix that later.') withCRs position:pos1 to:pos2.
].
^ self defineAsUndeclaredVariable:varName
].
"/ upperCase vars are declared as global
(warnedUndefVars isNil or:[(warnedUndefVars includes:varName) not]) ifTrue:[
(warnedUnknownNamespaces isNil or:[(warnedUnknownNamespaces includes:varName) not]) ifTrue:[
self warning:('adding ''' , boldName , ''' as Global.') withCRs position:pos1 to:pos2.
].
].
^ VariableNode globalNamed:varName
].
correctIt == #declare ifTrue:[
"/ declare it
rslt := self askForVariableTypeWhenDeclaringUndefined:varName.
rslt notNil ifTrue:[
^ rslt
].
].
suggestedNames := self findBestVariablesFor:varName.
suggestedNames isNil ifTrue:[
self information:'No good correction found'.
^ #Error
].
newName := self askForCorrection:'Correct Variable to: ' fromList:suggestedNames.
newName isNil ifTrue:[^ #Error].
"
newName := suggestedNames at:1.
(self confirm:('confirm correction to: ' , newName)) ifFalse:[^ #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.
source := (ReadStream on:correctedSource)
position:(source position + newName size - tokenName size).
"redo parse with new value"
token := tokenName := newName.
rslt := self variableOrError:tokenName.
"/ failed again ?
rslt == #Error ifTrue:[
"/ install as Undeclared:<name>, remember in #undeclared
rslt := self defineAsUndeclaredVariable:varName
].
^ rslt
"Modified: / 22.1.1998 / 16:34:01 / stefan"
"Modified: / 15.11.2001 / 22:56:38 / cg"
!
defineAsUndeclaredVariable:aName
"define varName as undeclared variable
(actually, it will be installed as a funny global named 'Undeclared:::<name>').
You can browse for methods with undeclareds by searching for global accesses
to 'Undeclared:::*' (or use the search-undeclared item in the launchers menu)."
|varName undeclared|
varName := aName.
"/ install as Undeclared:<name>, remember in Undeclared
undeclared := Smalltalk at:#Undeclared.
undeclared isNil ifTrue:[
Smalltalk at:#Undeclared put:(undeclared := IdentitySet new).
].
undeclared add:tokenName asSymbol.
varName := (Smalltalk undeclaredPrefix) , tokenName.
varName := varName asSymbol.
Smalltalk at:varName put:nil.
parseForCode ifFalse:[self rememberGlobalUsed:aName].
^ VariableNode globalNamed:varName
"Modified: / 31.10.1997 / 01:16:03 / cg"
!
deleteDefinitionOf:varName in:defStartPos to:defEndPos
|source startSearch pos pos2 nextChar varSlot|
varSlot := methodVars detect:[:var | var name = varName].
methodVars removeIdentical:varSlot.
source := requestor currentSourceCode.
startSearch := defStartPos+1.
[
"/ search this names position in the declaration part ...
pos := source indexOfSubCollection:varName startingAt:startSearch ifAbsent:0.
(pos == 0 or:[pos >= defEndPos]) ifTrue:[
self error:'should not happen' mayProceed:true.
^ self.
].
pos2 := pos + varName size - 1.
nextChar := source at:pos2+1.
nextChar isLetterOrDigit ifFalse:[
(source at:pos-1) == Character space ifTrue:[
pos := pos - 1.
].
"/ [nextChar == Character space] whileTrue:[
"/ pos2 := pos2 + 1.
"/ nextChar := source at:pos2+1.
"/ ].
"/
self correctSourceByDeletingFrom:pos to:pos2.
^ self.
].
startSearch := pos2 + 1.
] loop
!
findBestSelectorsFor:aString
"collect known selectors with their spelling distances to aString;
return the 10 best suggestions"
^ self class findBestSelectorsFor:aString
"Time millisecondsToRun:[Parser new findBestSelectorsFor:'foo']"
"Parser new findBestSelectorsFor:'findBestSel'"
"Parser new findBestSelectorsFor:'fildBestSelectrFr'"
!
findBestSelectorsFor:aString in:aClassOrNil
"collect known selectors with their spelling distances to aString;
return the 10 best suggestions. If the argument, aClassOrNil is not nil,
the message is assumed to be sent to instances of that class (i.e. offer
corrections from that hierarchy only)"
^ self class findBestSelectorsFor:aString in:aClassOrNil
!
findBestVariablesFor:aString
"collect known variables with their spelling distances to aString;
return the 10 best suggestions"
|names dists searchBlock args vars "aClass className baseClass"
n instVarNames classVarNames spellAgainstAction|
names := OrderedCollection new.
dists := OrderedCollection new.
spellAgainstAction :=
[:aVarNode |
|varName dist|
varName := aVarNode name.
names add:varName.
dist := aString spellAgainst:varName.
(aString startsWith:varName) ifTrue:[
dist := dist + (aString size * 10).
].
dists add:dist
].
"block arguments"
searchBlock := currentBlock.
[searchBlock notNil] whileTrue:[
args := searchBlock arguments.
args notNil ifTrue:[
args do:spellAgainstAction
].
vars := searchBlock variables.
vars notNil ifTrue:[
vars do:spellAgainstAction
].
searchBlock := searchBlock home
].
spellAgainstAction :=
[:givenName |
|dist|
names add:givenName.
dist := aString spellAgainst:givenName.
(aString startsWith:givenName) ifTrue:[
dist := dist + (aString size * 10).
].
dists add:dist
].
"method-variables"
methodVars notNil ifTrue:[
methodVarNames do:spellAgainstAction
].
"method-arguments"
methodArgs notNil ifTrue:[
methodArgNames do:spellAgainstAction
].
"instance-variables"
classToCompileFor notNil ifTrue:[
self classesInstVarNames do:spellAgainstAction
].
"class-variables"
classToCompileFor notNil ifTrue:[
self classesClassVarNames do:spellAgainstAction.
"/ aClass := classToCompileFor.
"/ aClass isMeta ifTrue:[
"/ className := aClass name.
"/ className := className copyWithoutLast:5.
"/ baseClass := Smalltalk at:(className asSymbol).
"/ baseClass notNil ifTrue:[
"/ aClass := baseClass
"/ ]
"/ ].
"/ [aClass notNil] whileTrue:[
"/ (aClass classVarNames) do:[:classVarName |
"/ names add:classVarName.
"/ dists add:(aString spellAgainst: "levenshteinTo:"classVarName)
"/ ].
"/ aClass := aClass superclass
"/ ]
].
"globals"
Smalltalk keysDo:[:aKey |
|globalVarName|
globalVarName := aKey asString.
"only compare strings where length is about right"
((globalVarName size - aString size) abs < 3) ifTrue:[
spellAgainstAction value:globalVarName.
]
].
"misc"
#('self' 'super' 'nil' 'thisContext') do:spellAgainstAction.
(dists size ~~ 0) ifTrue:[
dists sortWith:names.
dists := dists reverse.
names := names reverse.
n := names size min:10.
names := names copyTo:n.
"if it starts with a lower case character, add all local & instvar names"
(aString at:1) isLowercase ifTrue:[
methodVarNames size > 0 ifTrue:[
names add:'---- method locals ----'.
methodVarNames asSortedCollection do:[:methodVarName |
names add:methodVarName.
].
].
methodArgs size > 0 ifTrue:[
names add:'---- method arguments ----'.
methodArgNames asSortedCollection do:[:methodArgName |
names add:methodArgName.
]
].
classToCompileFor notNil ifTrue:[
instVarNames := OrderedCollection new.
self classesInstVarNames asSortedCollection do:[:instVarName |
(instVarNames includes:instVarName) ifFalse:[
instVarNames add:instVarName.
]
].
instVarNames size > 0 ifTrue:[
(classToCompileFor notNil and:[classToCompileFor isMeta]) ifTrue:[
names add:'---- class instance variables ----'.
] ifFalse:[
names add:'---- instance variables ----'.
].
instVarNames do:[:instVarName |
(names includes:instVarName) ifFalse:[
names add:instVarName.
]
]
].
classVarNames := OrderedCollection new.
self classesClassVarNames asSortedCollection do:[:classVarName |
(classVarNames includes:classVarName) ifFalse:[
classVarNames add:classVarName.
]
].
classVarNames size > 0 ifTrue:[
names add:'---- class variables ----'.
classVarNames do:[:classVarName |
(names includes:classVarName) ifFalse:[
names add:classVarName.
]
]
].
].
].
^ names
].
^ nil
"Modified: 11.1.1997 / 21:28:28 / cg"
!
selectorCheck:aSelectorString for:receiver position:pos1 to:pos2
"just a quick check: if a selector is totally unknown as a symbol,
has the same name as a variable, cannot be understood or is obsolete.
Simple, but catches many typos"
|err sym rec names recType selClass newSelector nm nowhereImplemented|
"
if compiling lazy, or errors are to be ignored, or there
is no requestor, do not check
"
(LazyCompilation == true) ifTrue:[^ aSelectorString].
self isSyntaxHighlighter ifFalse:[
(ignoreErrors or:[ignoreWarnings]) ifTrue:[^ aSelectorString].
(requestor isNil or:[requestor isStream]) ifTrue:[^ aSelectorString].
].
aSelectorString = '#' ifTrue:[
self warnPossibleIncompatibility:'''#'' might not be a valid selector in other smalltalk systems' position:pos1 to:pos2.
].
"
check if the selector is known at all
- if not, it cannot be understood
"
nowhereImplemented := false.
sym := aSelectorString asSymbolIfInterned.
sym isNil ifTrue:[
nowhereImplemented := true.
"/ ] ifFalse:[
"/ nowhereImplemented := (self implementedInAnyClass:sym) not.
].
nowhereImplemented ifTrue:[
err := ' is currently nowhere implemented'.
"
if the selector has the name of a variable, use another message
"
((methodVarNames notNil and:[methodVarNames includes:aSelectorString])
or:[(methodArgNames notNil and:[methodArgNames includes:aSelectorString])
or:[(classToCompileFor notNil
and:[((names := self classesInstVarNames) notNil and:[names includes:aSelectorString])])
or:[(classToCompileFor notNil
and:[((names := self classesClassInstVarNames) notNil and:[names includes:aSelectorString])])
or:[classToCompileFor notNil
and:[((names := self classesClassVarNames) notNil and:[names includes:aSelectorString])]]]]]) ifTrue:[
err := ' is currently nowhere implemented ..
.. but a variable with that name is defined.
Missing ''.'' after the previous expression
or missing keyword/receiver before that word ?'.
].
] ifFalse:[
receiver notNil ifTrue:[
selClass := self typeOfNode:receiver.
selClass notNil ifTrue:[
err := self checkSelector:sym inClass:selClass.
].
(receiver isConstant or:[receiver isBlock]) ifTrue:[
err notNil ifTrue:[
err := err, ' in ' , selClass name , ' or any of its superclasses'.
].
] ifFalse:[(((recType := receiver type) == #GlobalVariable)
or:[recType == #PrivateClass]) ifTrue:[
rec := receiver evaluate.
"/ dont check autoloaded classes - it may work after loading
(rec isNil
or:[rec isBehavior and:[rec isLoaded not]]) ifTrue:[
^ aSelectorString
].
err notNil ifTrue:[
(rec isBehavior
and:[rec theNonMetaclass name = receiver name]) ifTrue:[
err := err, ' in ' , rec theNonMetaclass name.
] ifFalse:[
err := err, ' in currently assigned value (is currently ' , rec classNameWithArticle , ')'.
]
].
] ifFalse:[receiver isSuper ifTrue:[
receiver isHere ifFalse:[
err notNil ifTrue:[
err := err, ' in superclass chain'.
].
] ifTrue:[
err notNil ifTrue:[
err := err, ' in this class or superclass chain'.
].
]
] ifFalse:[receiver isSelf ifTrue:[
err notNil ifTrue:[
|subErr|
"/ understood by all subclasses ?
classToCompileFor allSubclassesDo:[:eachSubclass |
subErr isNil ifTrue:[
selClass := eachSubclass.
subErr := self checkSelector:sym inClass:selClass.
].
].
subErr notNil ifTrue:[
err := subErr, ' in this class, superclass chain or all subclasses'
] ifFalse:[
err := err, ' in this class or superclass chain'.
].
].
] ifFalse:[(receiver isUnaryMessage
and:[receiver selector == #class
and:[receiver receiver isSelf]]) ifTrue:[
"its a message to self class - can check this too ..."
err notNil ifTrue:[
classToCompileFor isMeta ifTrue:[
err := err, ' for the classes class'.
(self checkSelector:sym inClass:classToCompileFor) isNil ifTrue:[
err := err, '...\\...but its implemented for the class itself. You probably do not want the #class message here.'.
err := err withCRs.
].
] ifFalse:[
err := err, ' for my class'.
(self checkSelector:sym inClass:classToCompileFor) isNil ifTrue:[
err := err, '...\\...but its implemented for instances. You may want to remove the #class message.'.
err := err withCRs.
].
].
].
] ifFalse:[(receiver isMethodVariable and:[receiver token type isNil]) ifTrue:[
"if it is an uninitialized variable ..."
((modifiedLocalVars isNil or:[(modifiedLocalVars includes:receiver name) not])
and:[alreadyWarnedUninitializedVars isNil
or:[(alreadyWarnedUninitializedVars includes:receiver name) not]])
ifTrue:[
((#(at: at:put: basicAt: basicAt:put:) includes:sym)
or:[(nil respondsTo:sym) not])ifTrue:[
"/ avoid trouble in miniTalk
"/ during bootstrap
nm := receiver name.
Text notNil ifTrue:[
nm := nm allItalic
].
err := 'sent to possibly uninitialized variable ''' , nm , ''' here (?)'.
alreadyWarnedUninitializedVars isNil ifTrue:[
alreadyWarnedUninitializedVars := Set new
].
alreadyWarnedUninitializedVars add:receiver name
]
]
] ifFalse:[
err notNil ifTrue:[
err := err, ' (message to ' , selClass nameWithArticle , ')'.
].
]]]]]].
]
].
err notNil ifTrue:[
(receiver notNil
and:[((recType := receiver type) == #GlobalVariable)
or:[recType == #PrivateClass]]) ifTrue:[
"/ dont check autoloaded classes
"/ - it may work after loading
rec := receiver evaluate.
(rec notNil
and:[rec isBehavior
and:[rec isLoaded not]]) ifTrue:[
^ aSelectorString
].
rec class == UndefinedVariable ifTrue:[
"/ dont check undefined vars;
"/ it may work after loading/defining
^ aSelectorString
].
].
Text notNil ifTrue:[
err := '"' , aSelectorString allBold "allItalic" , '" ', err
] ifFalse:[
err := aSelectorString , ' ', err
].
"/ if its a recursive invocation of just that selector, do not complain
(selector = aSelectorString and:[ receiver isSelf]) ifTrue:[
^ aSelectorString
].
newSelector := self correctSelector:aSelectorString
message:err position:pos1 to:pos2 in:selClass for:receiver.
"/ self warning:('#' , aSelectorString , '\\' , err) withCRs position:pos1 to:pos2.
^ newSelector.
].
^ aSelectorString
"Modified: / 5.9.1995 / 17:02:11 / claus"
"Modified: / 19.1.2000 / 16:34:03 / cg"
!
typeOfNode:aNode
|nodeVal nodeType|
aNode isConstant ifTrue:[
"
if the receiver is a constant, we can check if it responds
to this selector
"
nodeVal := aNode evaluate.
^ nodeVal class.
].
"/ this should help with typos, sending #ifTrue to blocks ...
aNode isBlock ifTrue:[
^ Block
].
(((nodeType := aNode type) == #GlobalVariable)
or:[nodeType == #PrivateClass]) ifTrue:[
"if the receiver is a global, we check it too ..."
nodeVal := aNode evaluate.
"/ dont check autoloaded classes
"/ - it may work after loading
(nodeVal isNil
or:[nodeVal isBehavior and:[nodeVal isLoaded not]]) ifTrue:[
^ nil
].
^ nodeVal class.
].
aNode isSuper ifTrue:[
"if its a super- or here-send, we can do more checking"
aNode isHere ifFalse:[
^ classToCompileFor superclass ? UndefinedObject.
].
^ classToCompileFor.
].
aNode isSelf ifTrue:[
^ classToCompileFor.
].
(aNode isUnaryMessage) ifTrue:[
(aNode selector == #class) ifTrue:[
aNode receiver isSelf ifTrue:[
"its a message to self class - can check this too ..."
^ classToCompileFor class.
].
].
( #(#'isNil' #'notNil') includes:aNode selector) ifTrue:[
^ Boolean.
]
].
aNode isBinaryMessage ifTrue:[
( #(#'<' #'>' #'>=' #'<=' #'=' #'==' #'~=' #'~~') includes:aNode selector) ifTrue:[
^ Boolean.
]
].
^ nil
! !
!Parser methodsFor:'error handling'!
blockArgRedefined:tokenName from:pos1 to:pos2
"argname reuse"
self isSyntaxHighlighter ifTrue:[
self markBadIdentifierFrom:pos1 to:pos2.
] ifFalse:[
self
syntaxError:'redefinition of ''' , tokenName , ''' in argument list.'
position:pos1 to:pos2
].
!
exitWith:something
"this is the longjump out of evaluation via a return expression"
evalExitBlock value:something
!
identifierExpectedIn:what
|msg|
(#(True False Self Nil Super ThisContext) includes:tokenType) ifTrue:[
msg := 'Reserved keyword in '
] ifFalse:[
msg := 'Identifier expected in '
].
self syntaxError:(msg , what , ' (got ''' , tokenType printString, ''')')
position:tokenPosition to:source position - 1.
^ #Error
!
methodArgRedefined:tokenName from:pos1 to:pos2
"argname reuse"
self isSyntaxHighlighter ifTrue:[
self markBadIdentifierFrom:pos1 to:pos2.
] ifFalse:[
self
syntaxError:'redefinition of ''' , tokenName , ''' in argument list.'
position:pos1 to:pos2
].
!
showErrorMessage:aMessage position:pos
"redefined since parser can give more detailed info about
the class & selector where the error occured."
|text|
ignoreErrors ifFalse:[
Smalltalk silentLoading == true ifFalse:[
pos notNil ifTrue:[
Transcript show:(pos printString).
Transcript show:' '.
].
selector notNil ifTrue:[
Transcript show:aMessage.
classToCompileFor notNil ifTrue:[
text := ' in ' , classToCompileFor name , '>>' , selector
] ifFalse:[
text := ' in ' , selector
]
] ifFalse:[
classToCompileFor notNil ifTrue:[
text := aMessage , ' (' , classToCompileFor name , ')'
] ifFalse:[
text := aMessage
]
].
Transcript showCR:text.
]
]
"Modified: 18.5.1996 / 15:44:15 / cg"
!
showErrorMessageForClass:aClass
"/ compiler parseError:'syntax error'.
Transcript show:' '.
aClass notNil ifTrue:[
Transcript show:aClass name , '>>'
].
selector notNil ifTrue:[
Transcript show:(selector)
].
Transcript showCR:' -> Error'.
"Created: 13.12.1995 / 20:24:34 / cg"
"Modified: 18.5.1996 / 15:44:17 / cg"
!
undefError:aName position:pos1 to:pos2
"report an undefined variable error - return true, if it should be
corrected. If not corrected, only one warning is made per undefined
variable."
|doCorrect msg idx boldName|
warnUndeclared ifFalse:[^ false].
ignoreWarnings ifTrue:[^ false].
"
alredy warned about this one ?
"
warnedUndefVars notNil ifTrue:[
(warnedUndefVars includes:aName) ifTrue:[
"already warned about this one"
^ false
].
].
"/ (classToCompileFor notNil
"/ and:[classToCompileFor superclass notNil
"/ and:[classToCompileFor superclass instanceVariableString isNil]]) ifTrue:[
"/ self showErrorMessage:'Error: no source information (instvar names)' position:pos1.
"/ ^ false
"/ ].
boldName := aName allBold.
(requestor isNil or:[requestor isStream]) ifTrue:[
aName first isUppercase ifFalse:[
self showErrorMessage:('Error: ''' , boldName , ''' is undefined') position:pos1.
].
doCorrect := false.
] ifFalse:[
"
ask requestor for correct/continue/abort ...
it is supposed to raise abort or return true/false.
True return means that correction is wanted.
"
msg := 'Warning: ''' , boldName , ''' is undefined'.
classToCompileFor notNil ifTrue:[
"/ is it an instance-variable marked inaccessable ?
idx := (self classesInstVarNames) indexOf:(aName , '*') startingAt:1.
idx ~~ 0 ifTrue:[
msg := 'Warning: ''' , boldName , ''' is a hidden instvar (not accessable from ST-code)'.
].
"/ is it an instance variable, while evaluateing for the class ?
classToCompileFor isMeta ifTrue:[
(classToCompileFor soleInstance allInstVarNames includes:aName) ifTrue:[
msg := 'Warning: ''' , boldName , ''' is an instvar\(hint: you are evaluating/compiling in the classes context)' withCRs.
]
]
].
doCorrect := self correctableError:msg position:pos1 to:pos2
].
doCorrect == false ifTrue:[
warnedUndefVars isNil ifTrue:[
warnedUndefVars := Set new.
].
warnedUndefVars add:aName.
].
^ doCorrect
"Modified: 7.9.1997 / 02:14:36 / cg"
!
warnUnused:aNameCollection
"report an unused method variable"
|s msg answer localsPos1 localsPos2|
(ignoreErrors not and:[ignoreWarnings not and:[warnUnusedVars]]) ifTrue:[
s := '' writeStream.
s nextPutAll:'Unused method variable(s): '.
aNameCollection asSortedCollection do:[:name|
s nextPutAll:' '; nextPutAll:name asText allBold.
].
msg := s contents.
(requestor isNil or:[requestor isStream]) ifTrue:[
self showErrorMessage:('Warning: ', msg) position:nil.
] ifFalse:[
localsPos1 := localVarDefPosition first.
localsPos2 := localVarDefPosition last.
answer := requestor
unusedVariableWarning:msg
position:localsPos1 to:localsPos2 from:self.
answer == true ifTrue:[
"/ delete the definitions ...
aNameCollection do:[:eachName |
self deleteDefinitionOf:eachName in:localsPos1 to:localsPos2.
].
RestartCompilationSignal raise
].
].
].
"Modified: / 17.11.2001 / 10:30:47 / cg"
! !
!Parser methodsFor:'evaluating expressions'!
evaluate:aStringOrStream in:aContext receiver:anObject notifying:requestor logged:logged ifFail:failBlock compile:compile
"return the result of evaluating aStringOrStream, errors are reported to requestor.
Allow access to anObject as self and to its instVars (used in the inspector).
If logged is true, an entry is added to the change-file. If the failBlock argument
is non-nil, it is evaluated if an error occurs.
Finally, compile specifies if the string should be compiled down to
bytecode or instead be interpreted from the parseTree.
The first should be done for doIts etc, where a readable walkback is
required.
The latter is better done for constants, styleSheet and resource
reading and simple sends, where the overhead of compilation is bigger
than the interpretation overhead."
|tree mustBackup loggedString chgStream value s sReal spc
nameSpaceQuerySignal compiler|
aStringOrStream isNil ifTrue:[
EmptySourceNotificationSignal raiseRequest.
^ nil
].
(mustBackup := aStringOrStream isStream) ifTrue:[
s := aStringOrStream.
] ifFalse:[
loggedString := aStringOrStream.
s := ReadStream on:aStringOrStream.
].
self source:s.
self parseForCode.
self foldConstants:nil.
self setSelf:anObject.
self setContext:aContext.
aContext notNil ifTrue:[
self setSelf:(aContext receiver).
"/ aContext method notNil ifTrue:[
"/ cls := aContext method mclass
"/ ].
"/ self setClassToCompileFor:(cls ? aContext receiver class).
self setClassToCompileFor:(aContext receiver class).
].
self notifying:requestor.
self nextToken.
self evalExitBlock:[:value | self release. ^ value].
tree := self parseMethodBodyOrEmpty.
self checkForEndOfInput.
"if reading from a stream, backup for next expression"
mustBackup ifTrue:[
self backupPosition
].
(self errorFlag or:[tree == #Error]) ifTrue:[
failBlock notNil ifTrue:[
^ failBlock value
].
^ #Error
].
tree isNil ifTrue:[
EmptySourceNotificationSignal raiseRequest.
^ nil
].
(logged
and:[loggedString notNil
and:[Smalltalk logDoits]]) ifTrue:[
Class updateChangeFileQuerySignal query ifTrue:[
chgStream := Class changesStream.
chgStream notNil ifTrue:[
chgStream nextChunkPut:loggedString.
chgStream cr.
chgStream close
]
].
Project notNil ifTrue:[
Class updateChangeListQuerySignal query ifTrue:[
Project addDoIt:loggedString
]
]
].
"
during the evaluation, handle nameSpace queries
from the value as defined by any namespace directive.
This, if its a class definition expression, the class will
be installed there.
"
nameSpaceQuerySignal := Class nameSpaceQuerySignal.
spc := self getNameSpace.
spc isNil ifTrue:[
(requestor respondsTo:#currentNameSpace) ifTrue:[
spc := requestor currentNameSpace
] ifFalse:[
spc := nameSpaceQuerySignal query.
]
].
nameSpaceQuerySignal answer:spc
do:[
|method|
"
if compile is false, or the parse tree is that of a constant,
or a variable, quickly return its value.
This is used for example, when reading simple objects
via #readFrom:.
The overhead of compiling a method is avoided in this case.
"
((SuppressDoItCompilation == true)
or:[compile not
or:[tree isConstant
or:[tree isVariable
or:[aStringOrStream isStream
or:[aContext notNil]]]]]) ifTrue:[
^ tree evaluate
].
"
if I am the ByteCodeCompiler,
generate a dummy method, execute it and return the value.
otherwise, just evaluate the tree; slower, but not too bad ...
This allows systems to be delivered without the ByteCodeCompiler,
and still evaluate expressions
(needed to read resource files or to process .rc files).
"
self == Parser ifTrue:[
self evalExitBlock:[:value | self release. ^ value].
value := tree evaluate.
self evalExitBlock:nil.
] ifFalse:[
s := self correctedSource.
s isNil ifTrue:[
aStringOrStream isStream ifTrue:[
s := self collectedSource. "/ does not work yet ...
] ifFalse:[
s := aStringOrStream
].
].
"/ actually, its a block, to allow
"/ easy return ...
sReal := 'doIt ^[\' withCRs , s , '\] value' withCRs.
compiler := ByteCodeCompiler new.
compiler initializeFlagsFrom:self.
method := compiler
compile:sReal
forClass:anObject class
inCategory:'_temporary_'
notifying:requestor
install:false
skipIfSame:false
silent:true
foldConstants:false.
method notNil ifTrue:[
method ~~ #Error ifTrue:[
"
fake: patch the source string, to what the user expects
in the browser
"
method source:' \' withCRs , s string.
"
dont do any just-in-time compilation on it.
"
method checked:true.
value := method
valueWithReceiver:anObject
arguments:nil "/ (Array with:m)
selector:#doIt "/ #doIt:
search:nil
sender:nil.
] ifFalse:[
self evalExitBlock:[:value | self release. ^ value].
value := tree evaluate.
self evalExitBlock:nil.
]
].
]
].
self release.
^ value
"Created: / 8.2.1997 / 19:34:44 / cg"
"Modified: / 18.3.1999 / 18:25:40 / stefan"
"Modified: / 6.2.2000 / 15:01:57 / cg"
! !
!Parser methodsFor:'parsing'!
block
"parse a block; return a node-tree, nil or #Error"
|node args argNames arg pos pos2 lno|
lno := tokenLineNr.
self nextToken.
(tokenType == $: ) ifTrue:[
[tokenType == $:] whileTrue:[
pos := tokenPosition.
self nextToken.
(tokenType ~~ #Identifier) ifTrue:[
^ self identifierExpectedIn:'block-arg declaration'
].
pos2 := tokenPosition + tokenName size - 1.
self markArgumentIdentifierFrom:tokenPosition to:pos2.
arg := Variable name:tokenName.
args isNil ifTrue:[
args := Array with:arg.
argNames := Array with:tokenName.
] ifFalse:[
(argNames includes:tokenName) ifTrue:[
self blockArgRedefined:tokenName from:tokenPosition to:pos2
].
args := args copyWith:arg.
argNames := argNames copyWith:tokenName.
].
self nextToken
].
(tokenType ~~ $| ) ifTrue:[
"ST-80 allows [:arg ]"
(tokenType == $] ) ifTrue:[
node := BlockNode arguments:args home:currentBlock variables:nil.
node lineNumber:lno.
^ node
].
self syntaxError:'| expected after block-arg declaration'.
^ #Error
].
self nextToken
].
node := self blockBody:args.
(node notNil and:[node ~~ #Error]) ifTrue:[
node lineNumber:lno.
].
^ node
"Modified: / 31.3.1998 / 17:31:34 / cg"
!
blockBody:args
"parse a blocks body; return a node-tree, nil or #Error"
|stats node var vars lno pos2|
lno := tokenLineNr.
(tokenType == $| ) ifTrue:[
self nextToken.
[tokenType == $|] whileFalse:[
(tokenType == #Identifier) ifFalse:[
^ self identifierExpectedIn:'block-var declaration'
].
pos2 := tokenPosition + tokenName size - 1.
self markLocalIdentifierFrom:tokenPosition to:pos2.
var := Variable name:tokenName.
vars isNil ifTrue:[
vars := Array with:var.
] ifFalse:[
(vars contains:[:var | var name = tokenName]) ifTrue:[
"/ varname reuse
self isSyntaxHighlighter ifTrue:[
self markBadIdentifierFrom:tokenPosition to:pos2.
] ifFalse:[
self
parseError:'redefinition of ''' , tokenName , ''' in local variables'
position:tokenPosition to:pos2.
]
] ifFalse:[
vars := vars copyWith:var.
]
].
self nextToken.
"/ ((tokenType == $_) or:[tokenType == #':=']) ifTrue:[
"/ AllowLocalVariableDeclarationWithInitializerExpression == true ifTrue:[
"/ "/ self halt.
"/ "/ Q: should we allow literals only, or arbitrary expression.
"/ ]
"/ ].
(tokenType == $() ifTrue:[
self variableTypeDeclarationFor:var.
].
].
self nextToken
].
node := BlockNode arguments:args home:currentBlock variables:vars.
node lineNumber:lno.
currentBlock := node.
stats := self blockStatementList.
(stats == #Error) ifTrue:[^ #Error].
lineNumberInfo == #full ifTrue:[
node endLineNumber:tokenLineNr
].
node statements:stats.
currentBlock := node home.
^ node
"Modified: / 31.3.1998 / 22:46:09 / cg"
!
blockExpression
"parse a blockExpression; return a node-tree, nil or #Error.
Not used by ST/X's parser, but added for ST-80 compatibility."
tokenType ~~ $[ ifTrue:[
self syntaxError:'[ expected'.
^ #Error.
].
^ self block
!
blockStatementList
"parse a blocks statementlist; return a node-tree, nil or #Error"
|thisStatement prevStatement firstStatement eMsg|
(tokenType == $] ) ifTrue:[^ nil].
thisStatement := self statement.
(thisStatement == #Error) ifTrue:[^ #Error].
firstStatement := thisStatement.
[tokenType == $] ] whileFalse:[
(tokenType == $.) ifFalse:[
(tokenType == #EOF) ifTrue:[
self syntaxError:'missing '']'' in block' position:(source position) to:(source position).
^ #Error.
].
(tokenType == $) ) ifTrue:[
eMsg := 'missing '']'' or bad '')'' in block'
] ifFalse:[
eMsg := 'missing ''.'' between statements (i.e. ''' , tokenType printString , '''-token unexpected)'
].
self syntaxError:eMsg position:tokenPosition to:tokenPosition.
^ #Error
].
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'.
"
self markBracketAt:tokenPosition.
^ firstStatement
].
thisStatement := self statement.
(thisStatement == #Error) ifTrue:[^ #Error].
prevStatement nextStatement:thisStatement
].
self markBracketAt:tokenPosition.
^ firstStatement
"Modified: / 16.7.1998 / 20:38:25 / cg"
!
checkForEndOfInput
(tokenType ~~ #EOF) ifTrue:[
"/ just for the nicer error message
(#(Self Nil True False Super Here) includes:tokenType) ifTrue:[
self parseError:tokenName , ' unexpected (missing ''.'' before ' , tokenName , ' ?)'
position:tokenPosition to:(tokenPosition + tokenName size - 1)
] ifFalse:[
self parseError:(tokenType printString , ' unexpected (missing ''.'' or selector before it ?)')
position:tokenPosition to:source position-1.
].
^#Error
]
!
checkReturnedValues
| returnsSelf returnsBoolean returnsNonBooleanLiteral|
ignoreWarnings ifTrue:[^ self].
returnedValues isNil ifTrue:[^ self].
returnsBoolean := returnedValues contains:[:node | node isConstant and:[node value isBoolean]].
returnsNonBooleanLiteral := returnedValues contains:[:node | node isConstant and:[node value isBoolean not]].
returnsSelf := returnedValues contains:[:node | node isSelf].
returnsBoolean ifTrue:[
(returnsNonBooleanLiteral or:[returnsSelf]) ifTrue:[
self notifyWarning:'Possible Error Warning:\\Method returns both boolean and non-boolean values.' withCRs
position:1 to:tokenPosition
]
].
"Created: / 17.11.2001 / 10:31:03 / cg"
"Modified: / 17.11.2001 / 10:34:16 / cg"
!
checkUnusedMethodVars
| unused|
ignoreWarnings ifFalse:[
methodVars notNil ifTrue:[
unused := methodVars select:[:var| var used ~~ true] thenCollect:[:var| var name].
].
unused size > 0 ifTrue:[
self warnUnused:unused.
].
].
"Created: / 17.11.2001 / 10:23:47 / cg"
!
parseExceptionOrContextPragma
|pragmaType|
"/ < resource: has already been parsed.
pragmaType := tokenName.
self nextToken.
(tokenType ~~ #Symbol) ifTrue:[
self parseError:'symbol expected'.
^ #Error
].
((pragmaType = 'exception:'
and:[tokenValue == #'handle'
or:[tokenValue == #'raise'
or:[tokenValue == #'unwind']]])
or:[
pragmaType = 'context:'
and:[(tokenValue == #'return')]])
ifTrue:[
primitiveContextInfo isNil ifTrue:[
primitiveContextInfo := Set new.
].
primitiveContextInfo add:(pragmaType->tokenValue).
] ifFalse:[
self parseError:'unrecognized exception pragma: ' , tokenValue.
].
self nextToken.
!
parseExpressionWithSelf:anObject notifying:someOne ignoreErrors:ignoreErrors ignoreWarnings:ignoreWarnings inNameSpace:aNameSpaceOrNil
"parse aString as an expression with self set to anObject;
Return the parseTree (if ok), nil (for an empty string
or comment only ) or #Error (syntactic error).
Errors and warnings are forwarded to someOne (usually some
codeView) which can highlight it and show a popup box,
iff ignoreErrors/ignoreWarnings is true respectively."
|tree token|
aNameSpaceOrNil notNil ifTrue:[
self currentNameSpace:aNameSpaceOrNil
].
self setSelf:anObject.
self notifying:someOne.
self ignoreErrors:ignoreErrors.
self ignoreWarnings:ignoreWarnings.
token := self nextToken.
(token == $^) ifTrue:[
self nextToken.
].
tree := self expression.
(self errorFlag or:[tree == #Error]) ifTrue:[^ #Error].
"/ tokenType ~~ #EOF ifTrue:[
"/ self parseError:'nothing more expected' position:tokenPosition
"/ ].
^ tree
"Created: / 14.12.1999 / 15:11:37 / cg"
!
parseExtendedMethodSpec
|pos1 pos2 var|
"/ EXPERIMENTAL
false ifTrue:[
(tokenType == #Symbol) ifTrue:[
pos1 := tokenPosition.
selector := token asSymbol.
self nextToken.
self markMethodSelectorFrom:pos1 to:(tokenPosition-1).
endOfSelectorPosition := tokenPosition.
tokenType == $( ifTrue:[
self nextToken.
[ tokenType ~~ $) ] whileTrue:[
(tokenType ~~ #Identifier) ifTrue:[^ #Error].
pos2 := tokenPosition+tokenName size-1.
self markArgumentIdentifierFrom:tokenPosition to:pos2.
var := Variable name:tokenName.
methodArgs isNil ifTrue:[
methodArgs := Array with:var.
methodArgNames := Array with:tokenName
] ifFalse:[
(methodArgNames includes:tokenName) ifTrue:[
self methodArgRedefined:tokenName from:tokenPosition to:pos2
].
methodArgs := methodArgs copyWith:var.
methodArgNames := methodArgNames copyWith:tokenName
].
self nextToken.
].
self nextToken.
].
^ self
].
].
^ #Error
!
parseMethod
"parse a method.
Return the parseTree or #Error.
method ::= methodSpec methodBody
"
|parseTree|
"/ self nextToken.
(self parseMethodSpec == #Error) ifTrue:[^ #Error].
parseTree := self parseMethodBody.
(parseTree == #Error) ifFalse:[
self tree:parseTree
].
self checkForEndOfInput.
^ parseTree
"Modified: 20.4.1996 / 20:09:26 / cg"
!
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 parseMethodBodyOrEmpty.
(stats == #Error) ifFalse:[
self checkForEndOfInput.
].
ignoreWarnings ifFalse:[
self checkUnusedMethodVars.
self checkReturnedValues.
].
^ stats
"Modified: / 17.11.2001 / 10:31:12 / cg"
!
parseMethodBodyOrEmpty
"parse a methods body (locals & statements);
return a node-tree, nil or #Error.
empty (or comment only) input is accepted and returns nil.
methodBodyOrNil ::= '<' st80Primitive '>'
| '<' st80Primitive '>' methodBodyVarSpec statementList
| <empty>
"
|stats|
(self parseMethodBodyVarSpec == #Error) ifTrue:[^ #Error].
(tokenType ~~ #EOF) ifTrue:[
stats := self statementList
].
"/ (tokenType ~~ #EOF) ifTrue:[
"/ self parseError:'nothing more expected here' position:tokenPosition to:tokenPosition.
"/ ^ #Error
"/ ].
(stats notNil
and:[stats ~~ #Error]) ifTrue:[
stats last isReturnNode ifFalse:[
"/ remember a returned self here.
self rememberReturnedValue:(self selfNode)
].
].
^ stats
"Modified: 27.4.1996 / 16:57:56 / cg"
!
parseMethodBodyVarSpec
"parse a methods local variable specification, handling
possible primitive or resourceSpecs.
.
Leave spec of locals in methodLocals as a side effect.
Return #Error or nil.
methodBodyVarSpec ::= '|' { IDENTIFIER } '|'
| <empty>
"
|var pos pos2 msg|
((tokenType == #BinaryOperator) and:[tokenName = '<']) ifTrue:[
self parsePrimitiveOrResourceSpecOrEmpty.
].
(tokenType == $|) ifTrue:[
"memorize position for declaration in correction"
localVarDefPosition := tokenPosition.
self nextToken.
pos := tokenPosition.
[tokenType == #Identifier] whileTrue:[
pos2 := tokenPosition + tokenName size - 1.
self markLocalIdentifierFrom:tokenPosition to:pos2.
var := Variable name:tokenName.
methodVars isNil ifTrue:[
methodVars := OrderedCollection with:var.
methodVarNames := OrderedCollection with:tokenName
] ifFalse:[
(methodVarNames includes:tokenName) ifTrue:[
"/ redefinition
self isSyntaxHighlighter ifTrue:[
self markBadIdentifierFrom:tokenPosition to:pos2.
] ifFalse:[
self
parseError:'redefinition of ''' , tokenName , ''' in local variables'
position:tokenPosition to:pos2.
]
] ifFalse:[
methodVars add:var.
methodVarNames add:tokenName
]
].
methodArgNames notNil ifTrue:[
(methodArgNames includes:tokenName) ifTrue:[
self
warning:'local variable ''' , tokenName , ''' hides argument.'
position:tokenPosition to:pos2
]
].
self nextToken.
(tokenType == $() ifTrue:[
self variableTypeDeclarationFor:var.
].
pos := tokenPosition
].
(tokenType ~~ $|) ifTrue:[
(#(True False Self Nil Super ThisContext) includes:tokenType) ifTrue:[
msg := 'Reserved keyword in local var declaration'.
pos2 := tokenPosition + tokenName size - 1.
self markBadIdentifierFrom:tokenPosition to:pos2.
] ifFalse:[
pos2 := source position-1.
msg := 'Identifier or | expected in local var declaration'
].
self syntaxError:msg position:tokenPosition to:pos2.
^ #Error
].
localVarDefPosition := Array with:localVarDefPosition with:tokenPosition.
self nextToken
].
allowSqueakExtensions ifTrue:[
"/ allow for primitiveSpec after local-var decl.
((tokenType == #BinaryOperator) and:[tokenName = '<']) ifTrue:[
self parsePrimitiveOrResourceSpecOrEmpty.
]
].
^ nil
"Modified: / 31.3.1998 / 17:30:33 / cg"
!
parseMethodSpec
"parse a methods selector & arg specification;
Set selector and methodArgs in the receiver as a side effect.
Return the receiver or #Error.
methodSpec ::= { KEYWORD IDENTIFIER }
| binaryOperator IDENTIFIER
| IDENTIFIER
"
|arg pos2|
tokenType isNil ifTrue:[
self nextToken.
].
(tokenType == #Keyword) ifTrue:[
selector := ''.
[tokenType == #Keyword] whileTrue:[
self markMethodSelectorFrom:tokenPosition to:(tokenPosition+tokenName size-1).
selector := selector , tokenName.
self nextToken.
(tokenType ~~ #Identifier) ifTrue:[
"/ ^ #Error].
^ self identifierExpectedIn:'method-arg declaration'
].
pos2 := tokenPosition+tokenName size-1.
self markArgumentIdentifierFrom:tokenPosition to:pos2.
arg := Variable name:tokenName.
methodArgs isNil ifTrue:[
methodArgs := Array with:arg.
methodArgNames := Array with:tokenName
] ifFalse:[
(methodArgNames includes:tokenName) ifTrue:[
self methodArgRedefined:tokenName from:tokenPosition to:pos2
].
methodArgs := methodArgs copyWith:arg.
methodArgNames := methodArgNames copyWith:tokenName
].
self nextToken.
"/ ((tokenType == #BinaryOperator) and:[token = '#']) ifTrue:[
"/ self nextToken.
"/ arg domain:nil.
"/ ].
].
selector := selector asSymbol.
endOfSelectorPosition := tokenPosition.
^ self
].
(self isValidUnarySelector:tokenType) ifTrue:[
self markMethodSelectorFrom:tokenPosition to:(tokenPosition+tokenName size-1).
selector := tokenName asSymbol.
self nextToken.
endOfSelectorPosition := tokenPosition.
^ self
].
"/ special handling for |, which is also a lexical token
tokenType == $| ifTrue:[
tokenType := #BinaryOperator.
token := tokenName := '|'
].
(tokenType == #BinaryOperator) ifTrue:[
self markMethodSelectorFrom:tokenPosition to:(tokenPosition+tokenName size-1).
selector := tokenName asSymbol.
self nextToken.
(tokenType ~~ #Identifier) ifTrue:[^ #Error].
self markArgumentIdentifierFrom:tokenPosition to:(tokenPosition+tokenName size-1).
arg := Variable name:tokenName.
methodArgs := Array with:arg.
methodArgNames := Array with:tokenName.
self nextToken.
"/ ((tokenType == #BinaryOperator) and:[token = '#']) ifTrue:[
"/ self nextToken.
"/ arg domain:nil.
"/ ].
endOfSelectorPosition := tokenPosition.
^ self
].
^ self parseExtendedMethodSpec
"Modified: / 31.3.1998 / 17:31:59 / cg"
!
parsePrimitive
"parse an ST-80 type primitive as '< primitive: nr >';
return primitive number or #Error.
or a Squeak-style primitive, as '< primitive: string >';
return primitive name or #Error.
Also, ST-80 style resource specs are parsed; the result is
left (as side effect) in primitiveResource.
(maybe someone else knows what to do with it ...)
Well, as we now have this mechanism, I'll use it to mark methods which
do keyboard processing ... <resource: keyboard ( keys )>
For faster finding of used keyboard accelerators,
and to mark resource methods (image, menu or canvas resources).
prim ::= st80Primitive | st80Pragma | stxPragma
squeakPrimitive | newSTXPrimitive | resourceDecl
st80Primitive ::= 'primitive:' INTEGER
st80Pragma ::= 'exception:' ( 'handle | 'raise' | 'unwind' )
stxPragma ::= 'context:' 'return'
squeakPrimitive ::= 'primitive:' STRING
newSTXPrimitive ::= 'primitive'
resourceDecl ::= 'resource:' SYMBOL - leave SYMBOL in primitiveResource
| 'resource:' SYMBOL (...) - leave (SYMBOL (...)) in primitiveResource
"
|primNumber cString cParser cType|
(tokenType == #Keyword or:[tokenType == #Identifier]) ifFalse:[
self parseError:'bad primitive definition (keyword expected)'.
^ #Error
].
(tokenName = 'primitive:') ifTrue:[
self nextToken.
(tokenType == #Integer) ifFalse:[
allowSqueakExtensions ifTrue:[
(tokenType == #String) ifFalse:[
self parseError:'primitive number or name expected'.
^ #Error
]
] ifFalse:[
self parseError:'primitive number expected'.
^ #Error
]
].
primitiveNr notNil ifTrue:[
self parseError:'only one primitive spec allowed'.
primNumber := -1.
] ifFalse:[
primNumber := tokenValue.
].
self nextToken.
((tokenType == #BinaryOperator) and:[tokenName = '>']) ifFalse:[
((tokenType == #Keyword) and:[tokenName = 'errorCode:']) ifTrue:[
self nextToken.
(tokenType == #Identifier) ifTrue:[
self nextToken.
] ifFalse:[
self error:'not yet implemented'.
]
].
]
] ifFalse:[
(tokenName = 'primitive') ifTrue:[
self nextToken.
primNumber := 0.
] ifFalse:[
(tokenName = 'resource:') ifTrue:[
self parseResourcePragma.
primNumber := -1.
] ifFalse:[
(tokenName = 'exception:'
or:[tokenName = 'context:']) ifTrue:[
self parseExceptionOrContextPragma.
] ifFalse:[
(tokenName = 'C:') ifTrue:[
cString := source upTo:$>.
self nextToken.
"/ TODO: generate that type
cParser := CParser parse:(cString , ';').
cType := cParser types first.
primitiveResource "primitiveType" := cType.
^ -1
] ifFalse:[
(tokenName = 'api:') ifTrue:[
cString := source upTo:$>.
self nextToken.
"/ TODO: generate that interface ...
^ -1
] ifFalse:[
self parseError:'unrecognized pragma: ' , tokenName.
"/ skip
[tokenType ~~ #EOF] whileTrue:[
((tokenType == #BinaryOperator) and:[tokenName = '>']) ifTrue:[
self nextToken.
^ -1 "/ primNr.
].
self nextToken.
].
].
].
]
].
].
].
((tokenType == #BinaryOperator) and:[tokenName = '>']) ifFalse:[
self parseError:'bad primitive definition (> expected)'.
^ #Error
].
self nextToken.
^ primNumber
"Modified: 29.5.1996 / 17:24:09 / cg"
!
parsePrimitiveOrResourceSpecOrEmpty
"parse a methods primitive or resource spec"
|pos wmsg primNr primNrOrString|
[(tokenType == #BinaryOperator) and:[tokenName = '<']] whileTrue:[
"/ an ST-80 primitive or resourceSpec - parsed but ignored
pos := tokenPosition.
self nextToken.
primNrOrString := self parsePrimitive.
(primNrOrString == #Error) ifTrue:[^ #Error].
wmsg := nil.
primNrOrString isString ifTrue:[
primNr := self primitiveNumberFromName:primNrOrString
] ifFalse:[
primNr := primNrOrString
].
primNr notNil ifTrue:[
primNr < 0 ifTrue:[
WarnST80Directives == true ifTrue:[
wmsg := 'ST-80/Squeak directive ignored'.
].
] ifFalse:[
primNr > 0 ifTrue:[
primitiveNr := primNr.
wmsg := 'ST-80 primitive may not work'
] ifFalse:[
primitiveNr := primNr.
wmsg := 'ST/X primitives only work in rel5 and newer'
]
].
].
wmsg notNil ifTrue:[self warning:wmsg position:pos]
].
"Created: 27.4.1996 / 16:55:55 / cg"
"Modified: 29.5.1996 / 17:25:52 / cg"
!
parseResourcePragma
|keys resource resourceValue|
"/ < resource: has already been parsed.
self nextToken.
(tokenType ~~ #Symbol) ifTrue:[
self parseError:'symbol expected'.
^ #Error
].
resource := tokenValue.
resourceValue := true.
self nextToken.
tokenType == $( ifTrue:[
self nextToken.
keys := OrderedCollection new.
[(tokenType == $)) or:[tokenType == #EOF] ] whileFalse:[
keys add:tokenValue.
self nextToken.
].
resourceValue := keys.
(tokenType == $)) ifFalse:[
self parseError:'unterminated primitive/spec (missing '')'')'.
].
self nextToken.
].
primitiveResource isNil ifTrue:[
primitiveResource := IdentityDictionary new.
].
primitiveResource at:(resource asSymbol) put:resourceValue.
!
primitiveNumberFromName:aPrimitiveName
"for future compatibility with Squeak ..."
^ nil
!
statement
"parse a statement; return a node-tree or #Error.
statement ::= '^' expression
| PRIMITIVECODE
| expression
"
|expr node lnr code|
(tokenType == $^) ifTrue:[
self markReturnAt:tokenPosition.
lnr := tokenLineNr.
self nextToken.
expr := self expression.
(expr == #Error) ifTrue:[^ #Error].
node := ReturnNode expression:expr.
node home:self blockHome:currentBlock.
(lineNumberInfo == #full) ifTrue:[node lineNumber:lnr].
self rememberReturnedValue:expr.
^ node
].
(tokenType == #Primitive) ifTrue:[
code := tokenValue.
self nextToken.
node := PrimitiveNode code:code.
node isOptional ifFalse:[
hasNonOptionalPrimitiveCode := true
].
hasPrimitiveCode := true.
^ node
].
(tokenType == #EOF) ifTrue:[
currentBlock notNil ifTrue:[
self syntaxError:'missing '']'' at end of block'.
] ifFalse:[
self syntaxError:'period after last statement'.
].
^ #Error
].
(tokenType == $.) ifTrue:[
allowSqueakExtensions == true ifTrue:[
"/ allow empty statement
^ StatementNode expression:nil.
].
].
expr := self expression.
(expr == #Error) ifTrue:[^ #Error].
"/ classToCompileFor notNil ifTrue:[
"/ currentBlock isNil ifTrue:[
"/ expr isPrimary ifTrue:[
"/ self warning:'useless computation - missing ^ ?'
"/ ]
"/ ]
"/ ].
node := StatementNode expression:expr.
(lineNumberInfo == #full) ifTrue:[node lineNumber:lnr].
^ node
"Modified: / 17.11.2001 / 10:22:33 / cg"
!
statementList
"parse a statementlist; return a node-tree, nil or #Error.
Statements must be separated by periods.
statementList ::= <statement>
| <statementList> . <statement>
"
|thisStatement prevStatement firstStatement correctIt periodPos
prevExpr|
thisStatement := self statement.
(thisStatement == #Error) ifTrue:[^ #Error].
firstStatement := thisStatement.
[tokenType == $.] whileTrue:[
prevExpr := thisStatement expression.
(prevExpr notNil
and:[prevExpr isMessage
and:[thisStatement isReturnNode not]]) ifTrue:[
(#(#'=' #'==') includes:prevExpr selector) ifTrue:[
self warning:'useless computation - mistyped assignment ?'
].
].
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 (expected '']'')'.
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 isReturnNode 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
"Modified: 14.4.1997 / 20:46:46 / cg"
!
variableTypeDeclarationFor:aVariable
|min max domain enumValues|
(tokenType == $() ifFalse:[
self syntaxError:'''('' expected' position:tokenPosition.
^ #Error
].
self nextToken.
(tokenType == #Integer) ifTrue:[
min := token.
self nextToken.
((tokenType == #BinaryOperator) and:[token = '%%']) ifFalse:[
self syntaxError:'''%%'' expected' position:tokenPosition.
].
self nextToken.
(tokenType == #Integer) ifFalse:[
self syntaxError:'Integer (upper bound) expected' position:tokenPosition.
].
max := token.
self nextToken.
domain := IntegerDomain min:min max:max.
] ifFalse:[
((tokenType == #Identifier) and:[token first isUppercase]) ifTrue:[
token = 'Bool' ifTrue:[
self nextToken.
domain := BooleanDomain new.
].
token = 'Nat' ifTrue:[
self nextToken.
domain := IntegerDomain min:0 max:(SmallInteger maxVal).
].
token = 'Int' ifTrue:[
self nextToken.
domain := IntegerDomain min:(SmallInteger minVal) max:(SmallInteger maxVal).
].
] ifFalse:[
((tokenType == #Symbol) or:[(tokenType == #Identifier)]) ifTrue:[
enumValues := OrderedCollection new.
[((tokenType == #Symbol) or:[(tokenType == #Identifier)])] whileTrue:[
enumValues add:token.
self nextToken.
].
domain := EnumeratedDomain new values:enumValues.
].
].
].
domain isNil ifTrue:[
self syntaxError:'invalid domain' position:tokenPosition.
].
aVariable domain:domain.
(tokenType == $)) ifFalse:[
self syntaxError:''')'' expected' position:tokenPosition.
^ #Error
].
self nextToken.
! !
!Parser methodsFor:'parsing-expressions'!
array
|arr elements elem pos1|
pos1 := tokenPosition.
elements := OrderedCollection new:20.
[tokenType ~~ $) ] whileTrue:[
elem := self arrayConstant.
"/ (elem == #Error) ifTrue:[
"/ (tokenType == #EOF) ifTrue:[
"/ self syntaxError:'unterminated array-constant; '')'' expected'
"/ position:pos1 to:tokenPosition
"/ ].
"/ ^ #Error
"/ ].
elem isSymbol ifTrue:[
self markSymbolFrom:tokenPosition to:(source position-1).
].
elements add:elem.
self nextToken
].
arr := Array withAll:elements.
(ArraysAreImmutable and:[ImmutableArray notNil]) ifTrue:[
arr changeClassTo:ImmutableArray.
].
^ arr
"Modified: / 14.4.1998 / 17:03:29 / cg"
!
arrayConstant
|val|
(tokenType == #Nil) ifTrue:[
^ nil
].
((tokenType == #Integer)
or:[tokenType == #Float]) ifTrue:[
^ tokenValue
].
((tokenType == #String)
or:[tokenType == #Character]) ifTrue:[
^ tokenValue
].
(tokenType == #True) ifTrue:[
^ true
].
(tokenType == #False) ifTrue:[
^ false
].
(tokenType == #Error) ifTrue:[
^ ParseErrorSignal raise.
].
(tokenType == #BinaryOperator) ifTrue:[
^ tokenName asSymbol
].
"/ some more special symbol consts ...
(tokenType == $| ) ifTrue:[
^ #|
].
(tokenType == #Self ) ifTrue:[
^ #'self'
].
(tokenType == #Super ) ifTrue:[
^ #'super'
].
(tokenType == #Here ) ifTrue:[
^ #'here'
].
(tokenType == #ThisContext ) ifTrue:[
^ #'thisContext'
].
((tokenType == #Keyword)
or:[tokenType == #Identifier]) ifTrue:[
^ tokenName asSymbol
].
((tokenType == $()
or:[tokenType == #HashLeftParen]) ifTrue:[
self nextToken.
^ self array
].
((tokenType == $[)
or:[tokenType == #HashLeftBrack]) ifTrue:[
self nextToken.
^ self byteArray
].
(tokenType == #HashLeftBrace) ifTrue:[
val := self qualifiedName.
val := QualifiedName for:val name.
^ val
].
(tokenType == #Symbol) ifTrue:[
parseForCode ifFalse:[
self rememberSymbolUsed:tokenValue.
].
^ tokenValue
].
(tokenType == #EOF) ifTrue:[
"just for the better error-hilight; let caller handle error"
self syntaxError:'error in array-constant; EOF unexpected'.
^ ParseErrorSignal raise.
].
self syntaxError:('error in array-constant; '
, tokenType printString
, ' unexpected').
^ ParseErrorSignal raise.
"Modified: / 14.4.1998 / 18:22:54 / cg"
!
binaryExpression
"parse a binary-expression; return a node-tree, nil or #Error"
|receiver|
receiver := self unaryExpression.
(receiver == #Error) ifTrue:[^ #Error].
^ self binaryExpressionFor:receiver
!
binaryExpressionFor:receiverArg
"parse a binary-expression; return a node-tree, nil or #Error"
|receiver theReceiver arg sel pos try lno note|
receiver := receiverArg.
(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) or:[tokenType == #Float])
and:[tokenValue < 0]]]
] whileTrue:[
"/ kludge alarm: in a function-call argList, #, is not a binarySelector
inFunctionCallArgument == true ifTrue:[
((tokenType == #BinaryOperator) and:[tokenName = ',']) ifTrue:[
^ receiver
].
].
pos := tokenPosition.
lno := tokenLineNr.
"/ kludge alarm: bar and minus are not scanned as binop
(tokenType == $|) ifTrue:[
sel := '|'.
sel := self selectorCheck:sel for:receiver position:tokenPosition to:tokenPosition.
self nextToken
] ifFalse:[
(tokenType == #BinaryOperator) ifTrue:[
sel := tokenName.
sel := self selectorCheck:sel for:receiver position:tokenPosition to:(tokenPosition + tokenName size - 1).
self nextToken
] ifFalse:[
sel := '-'.
token := tokenValue := tokenValue negated
]
].
self markSelector:sel from:pos to:(pos + sel size - 1) receiverNode:receiver.
arg := self unaryExpression.
(arg == #Error) ifTrue:[^ #Error].
theReceiver := receiver.
try := BinaryNode receiver:receiver selector:sel arg:arg fold:foldConstants.
(try isMemberOf:String) ifTrue:[
self parseError:try position:pos to:tokenPosition.
errorFlag := false. "ok, user wants it - so he'll get it"
receiver := BinaryNode receiver:receiver selector:sel arg:arg fold:nil.
] ifFalse:[
receiver := try
].
note := self plausibilityCheck:receiver.
note notNil ifTrue:[
self warning:note position:pos to:tokenPosition
].
receiver lineNumber:lno.
receiver selectorPosition:pos.
parseForCode ifFalse:[
self rememberSelectorUsed:sel receiver:theReceiver
].
].
^ receiver
"Modified: / 9.1.1998 / 19:05:18 / stefan"
"Modified: / 19.1.2000 / 16:22:04 / cg"
!
byteArray
"started with ST-80 R4 - allow byteArray constants as #[ ... ]"
|bytes index limit newArray elem pos1 pos2|
pos1 := tokenPosition.
bytes := ByteArray uninitializedNew:5000.
index := 0. limit := 5000.
[tokenType ~~ $] ] whileTrue:[
pos2 := tokenPosition.
"
this is not good programming style, but speeds up
reading of huge byte arrays (i.e. stored Images ...)
"
(tokenType == #Integer) ifTrue:[
elem := tokenValue
] ifFalse:[
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 between:0 and:255]) ifTrue:[
index := index + 1.
bytes at:index put:elem.
index == limit ifTrue:[
newArray := ByteArray uninitializedNew:(limit * 2).
newArray replaceFrom:1 to:limit with:bytes startingAt:1.
limit := limit * 2.
bytes := newArray
].
] ifFalse:[
self parseError:'invalid ByteArray element' position:pos2 to:tokenPosition - 1
].
self nextToken.
].
newArray := ByteArray uninitializedNew:index.
newArray replaceFrom:1 to:index with:bytes startingAt:1.
^ newArray
!
degeneratedKeywordExpressionForSelector
"parse a keyword-expression without receiver - for the selector
only. return the selector or nil. This is not used in normal parsing,
but instead to extract the selector from a code fragment.
(for example, the system browsers implementors-function uses this)"
|sel arg rec|
(tokenType == #Keyword) ifTrue:[
sel := tokenName.
self nextToken.
arg := self binaryExpression.
(arg == #Error) ifTrue:[^ sel].
[tokenType == #Keyword] whileTrue:[
sel := sel , tokenName.
self nextToken.
arg := self binaryExpression.
(arg == #Error) ifTrue:[^ sel].
].
^ sel
].
(rec := self functionCallExpression) ~~ #Error ifTrue:[
sel := self degeneratedKeywordExpressionForSelector.
sel isNil ifTrue:[
rec isMessage ifTrue:[
sel := rec selector
] ifFalse:[
rec isAssignment ifTrue:[
rec expression isMessage ifTrue:[
sel := rec expression selector
]
]
]
]
].
^ sel
!
expression
"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 lno tokenEnd realReceiver positions|
pos := tokenPosition.
receiver := self keywordExpression.
(receiver == #Error) ifTrue:[^ #Error].
(tokenType == $;) ifTrue:[
receiver isMessage ifFalse:[
self syntaxError:'left side of cascade must be a message expression'
position:pos to:tokenPosition.
realReceiver := receiver. "/ only to allow continuing.
] ifTrue:[
realReceiver := receiver receiver.
].
[tokenType == $;] whileTrue:[
self nextToken.
(tokenType == #Identifier) ifTrue:[
tokenEnd := tokenPosition + tokenName size - 1.
self markSelector:tokenName from:tokenPosition to:tokenEnd receiverNode:realReceiver.
sel := tokenName.
sel := self selectorCheck:tokenName for:realReceiver position:tokenPosition to:tokenEnd.
receiver := CascadeNode receiver:receiver selector:sel.
receiver lineNumber:tokenLineNr.
parseForCode ifFalse:[
self rememberSelectorUsed:sel
].
self nextToken.
] ifFalse:[
(tokenType == #BinaryOperator) ifTrue:[
tokenEnd := tokenPosition + tokenName size - 1.
self markSelector:tokenName from:tokenPosition to:tokenEnd receiverNode:realReceiver.
sel := tokenName.
sel := self selectorCheck:tokenName for:realReceiver position:tokenPosition to:tokenEnd.
lno := tokenLineNr.
self nextToken.
arg := self unaryExpression.
(arg == #Error) ifTrue:[^ #Error].
receiver := CascadeNode receiver:receiver selector:sel arg:arg.
receiver lineNumber:lno.
parseForCode ifFalse:[
self rememberSelectorUsed:sel
].
] ifFalse:[
(tokenType == #Keyword) ifTrue:[
tokenEnd := tokenPosition + tokenName size - 1.
positions := OrderedCollection with:(tokenPosition to:tokenEnd).
pos := tokenPosition.
pos2 := tokenEnd.
lno := tokenLineNr.
sel := tokenName.
self nextToken.
arg := self binaryExpression.
(arg == #Error) ifTrue:[^ #Error].
args := Array with:arg.
[tokenType == #Keyword] whileTrue:[
tokenEnd := tokenPosition + tokenName size - 1.
positions add:(tokenPosition to:tokenEnd).
sel := sel , tokenName.
self nextToken.
arg := self binaryExpression.
(arg == #Error) ifTrue:[^ #Error].
args := args copyWith:arg.
pos2 := tokenEnd
].
sel := self selectorCheck:sel for:realReceiver position:pos to:pos2.
positions do:[:p |
self markSelector:sel from:p start to:p stop receiverNode:realReceiver.
].
receiver := CascadeNode receiver:receiver selector:sel args:args.
receiver lineNumber:lno.
parseForCode ifFalse:[
self rememberSelectorUsed:sel
].
] ifFalse:[
(tokenType == #Error) ifTrue:[^ #Error].
self syntaxError:('invalid cascade; ' , tokenType printString , ' unexpected')
position:tokenPosition to:source position - 1.
^ #Error
]
]
]
].
"obscure (unspecified ?) if selector follows; Question:
is
'expr sel1; sel2 sel3'
to be parsed as:
(t := expr.
t sel1.
t sel2) sel3
or:
(t := expr.
t sel1.
t sel2 sel3)
"
((tokenType == #Identifier)
or:[(tokenType == #BinaryOperator)
or:[tokenType == #Keyword]]) ifTrue:[
self syntaxError:'ambigous cascade - please group using (...)'
position:tokenPosition to:source position - 1.
^ #Error
"/ self warning: "syntaxError:" 'possibly ambigous cascade - please group using (...)'
"/ position:tokenPosition to:source position - 1.
"/ tokenType == #Identifier ifTrue:[
"/ ^ self unaryExpressionFor:receiver
"/ ].
"/ tokenType == #BinaryOperator ifTrue:[
"/ ^ self binaryExpressionFor:receiver
"/ ].
"/ ^ self keywordExpressionFor:receiver
]
].
^ receiver
"Modified: / 19.1.2000 / 16:22:16 / cg"
!
functionCallArgList
|argList arg prevInFunctionCallArgument|
self nextToken.
tokenType == $) ifTrue:[ self nextToken. ^ #() ].
argList := OrderedCollection new.
[ true ] whileTrue:[
prevInFunctionCallArgument := inFunctionCallArgument.
inFunctionCallArgument := true.
arg := self expression.
argList add:arg.
inFunctionCallArgument := prevInFunctionCallArgument.
tokenType == $) ifTrue:[
self nextToken.
^ argList
].
((tokenType == #BinaryOperator) and:[tokenName = ',']) ifFalse:[
self parseError:'"," or ")" expected'.
].
self nextToken.
].
!
functionCallExpression
"parse a functionCall; this is an st/x extension.
foo(x) is syntactic sugar for foo value:x"
|receiver numArgs argList evalSelectors evalSelector|
receiver := self primary.
tokenType == $( ifFalse:[^ receiver].
AllowFunctionCallSyntaxForBlockEvaluation == true ifFalse:[^ receiver.].
(receiver == #Error) ifTrue:[^ #Error].
receiver isVariable ifFalse:[
((receiver isMessage or:[receiver isAssignment]) and:[receiver parenthized]) ifFalse:[
receiver isBlock ifFalse:[
^ receiver
]
].
].
argList := self functionCallArgList.
"/ make it a block evaluation
numArgs := argList size.
numArgs == 0 ifTrue:[
^ UnaryNode receiver:receiver selector:#value
].
evalSelectors := #( #'value:'
#'value:value:'
#'value:value:value:'
#'value:value:value:value:'
#'value:value:value:value:value:'
#'value:value:value:value:value:value:'
#'value:value:value:value:value:value:value:'
#'value:value:value:value:value:value:value:value:'
).
numArgs <= evalSelectors size ifTrue:[
evalSelector := evalSelectors at:numArgs.
^ MessageNode
receiver:receiver
selector:evalSelector
args:argList.
].
"/ gen argument vector
^ MessageNode
receiver:receiver
selector:#valueWithArguments:
args:(self genMakeArrayWith:argList).
"
AllowFunctionCallSyntaxForBlockEvaluation := true.
"
"
|foo|
foo := [:x | x + 1].
1 + foo(1).
foo(1).
"
"
|addN add1|
addN := [:n | [:x | x + n]].
add1 := addN(1).
add1(10).
"
"AllowFunctionCallSyntaxForBlockEvaluation := false."
"
|addN add1|
addN := [:n | [:x | x + n]].
add1 := addN value:1.
add1 value:10
"
!
genMakeArrayWith:elementExpressions
"return a node to generate an array at runtime.
Will generate:
Array with:el1 ... with:elN (if N <= 5)
or:
(Array new at:1 put:el1; ... at:N put:elN; yourself) (otherwise)
"
|numEl arrRec sel expr|
arrRec := VariableNode globalNamed:#Array.
numEl := elementExpressions size.
(numEl between:1 and:8) ifTrue:[
sel := #(
#'with:'
#'with:with:'
#'with:with:with:'
#'with:with:with:with:'
#'with:with:with:with:with:'
#'with:with:with:with:with:with:'
#'with:with:with:with:with:with:with:'
#'with:with:with:with:with:with:with:with:'
) at:numEl.
^ MessageNode
receiver:arrRec
selector:sel
args:elementExpressions.
].
"/ array creation expression ...
expr := MessageNode
receiver:arrRec
selector:#new:
arg:(ConstantNode type:#Integer value:numEl).
numEl == 0 ifTrue:[
^ expr.
].
"/ followed by a bunch of #at:put: messages...
elementExpressions keysAndValuesDo:[:idx :e |
expr := (idx == 1 ifTrue:[MessageNode] ifFalse:[CascadeNode])
receiver:expr
selector:#at:put:
arg1:(ConstantNode type:#Integer value:idx)
arg2:e
fold:false.
].
"/ followed by a #yourself: message...
expr := CascadeNode
receiver:expr
selector:#yourself.
^ expr
!
isValidUnarySelector:tokenType
tokenType == #Identifier ifTrue:[^true].
AllowReservedWordsAsSelectors == true ifTrue:[
tokenType == #Self ifTrue:[^true].
tokenType == #Nil ifTrue:[^true].
tokenType == #True ifTrue:[^true].
tokenType == #False ifTrue:[^true].
tokenType == #Here ifTrue:[^true].
tokenType == #Super ifTrue:[^true].
tokenType == #ThisContext ifTrue:[^true].
].
^ false
"
AllowReservedWordsAsSelectors := true
AllowReservedWordsAsSelectors := false
"
"
1234 self
1234 nil
1234 true
1234 false
1234 here
1234 super
1234 thisContext
"
!
keywordExpression
"parse a keyword-expression; return a node-tree, nil or #Error.
keywordExpression ::= binaryexpression
| { KEYWORD-PART binaryExpression }
"
|receiver|
receiver := self binaryExpression.
(receiver == #Error) ifTrue:[^ #Error].
^ self keywordExpressionFor:receiver
!
keywordExpressionFor:receiverArg
"parse a keyword-expression; return a node-tree, nil or #Error.
keywordExpression ::= binaryexpression
| { KEYWORD-PART binaryExpression }
"
|lastReceiver receiver sel arg args posR1 posR2 pos1 pos2 try lno note positions|
receiver := receiverArg.
posR1 := tokenPosition.
(tokenType == #Keyword) ifTrue:[
pos1 := posR2 := tokenPosition.
pos2 := tokenPosition + tokenName size - 1.
positions := OrderedCollection with:(pos1 to:pos2).
sel := tokenName.
lno := tokenLineNr.
self nextToken.
arg := self binaryExpression.
(arg == #Error) ifTrue:[^ #Error].
args := Array with:arg.
[tokenType == #Keyword] whileTrue:[
sel := sel , tokenName.
pos2 := tokenPosition + tokenName size - 1.
positions add:(tokenPosition to:pos2).
self nextToken.
arg := self binaryExpression.
(arg == #Error) ifTrue:[^ #Error].
args := args copyWith:arg.
].
positions do:[:p |
self markSelector:sel from:p start to:p stop receiverNode:receiver.
].
sel := self selectorCheck:sel for:receiver position:pos1 to:pos2.
ignoreErrors ifFalse:[
(Class definitionSelectors includes:sel) ifTrue:[
receiver isVariable ifTrue:[
receiver isUndeclared ifTrue:[
self parseError:('undefined superclass: ' , receiver name) position:pos1 to:pos2.
].
]
].
].
lastReceiver := receiver.
try := MessageNode receiver:receiver selector:sel args:args fold:foldConstants.
(try isMemberOf:String) ifTrue:[
self parseError:try position:pos1 to:pos2.
errorFlag := false. "ok, user wants it - so he'll get it"
receiver := MessageNode receiver:receiver selector:sel args:args fold:nil.
] ifFalse:[
receiver := try
].
note := self plausibilityCheck:receiver.
note notNil ifTrue:[
self warning:note position:pos1 to:pos2
].
receiver lineNumber:lno.
parseForCode ifFalse:[
self rememberSelectorUsed:sel receiver:lastReceiver
].
"/ (contextToEvaluateIn isNil and:[selfValue isNil]) ifTrue:[ "/ do not check this for doits
"/ receiver isSuper ifTrue:[
"/ sel ~= selector ifTrue:[
"/ self warnCommonMistake:'possible bad super message (selector should be same as in current method) ?'
"/ position:posR1 to:posR2-1
"/ ].
"/ ].
"/ ].
"/
(sel = #and: or:[sel = #or:]) ifTrue:[
receiver arg1 isBlock ifFalse:[
self warnCommonMistake:'(possible common mistake) missing block brackets ?'
position:pos2+1 to:tokenPosition-1
]
].
(sel = #whileTrue: or:[sel = #whileFalse:]) ifTrue:[
receiver receiver isBlock ifFalse:[
self warnCommonMistake:'(possible common mistake) missing block brackets ?'
position:posR1 to:posR2-1
]
].
].
^ receiver
"Modified: / 19.1.2000 / 16:22:22 / cg"
!
nodeForMethodArg:varName
|varIndex var|
methodArgNames isNil ifTrue:[^ nil].
varIndex := methodArgNames indexOf:varName.
varIndex == 0 ifTrue:[^ nil].
var := methodArgs at:varIndex.
"/ var used:true.
^ VariableNode type:#MethodArg
name:varName
token:var
index:varIndex
!
nodeForMethodVariable:varName
|varIndex var|
methodVarNames isNil ifTrue:[^ nil].
varIndex := methodVarNames indexOf:varName.
varIndex == 0 ifTrue:[^ nil].
var := methodVars at:varIndex.
var used:true.
parseForCode ifFalse:[self rememberLocalUsed:varName].
^ VariableNode type:#MethodVariable
name:varName
token:var
index:varIndex
!
primary
"parse a primary-expression; return a node-tree, nil or #Error.
This also cares for namespace-access-pathes."
|val pos node eMsg|
(tokenType == #Self) ifTrue:[
^ self primary_self.
].
pos := tokenPosition.
(tokenType == #Identifier) ifTrue:[
"
must check for variable first, to be backward compatible
with other smalltalks.
"
tokenName = 'here' ifTrue:[
(self variableOrError:tokenName) == #Error ifTrue:[
tokenType := #Here.
warnSTXHereExtensionUsed ifTrue:[
self warning:'here-sends are a nonstandard feature of ST/X'
position:pos to:pos+3.
"
only warn once
"
warnSTXHereExtensionUsed := false
].
^ self primary_here.
]
].
^ self primary_identifier
].
((tokenType == #Integer)
or:[(tokenType == #String)
or:[(tokenType == #Character)
or:[(tokenType == #Float)
or:[(tokenType == #Symbol)]]]]) ifTrue:[
^ self primary_simpleLiteral.
].
(tokenType == #FixedPoint) ifTrue:[
AllowFixedPointLiterals == true ifFalse:[
self parseError:'non-Standard literal: FixedPoint. Please enable in settings.' position:pos to:tokenPosition.
^ #Error
].
^ self primary_simpleLiteral.
].
(tokenType == #Nil) ifTrue:[
^ self primary_nil.
].
(tokenType == #True) ifTrue:[
^ self primary_true
].
(tokenType == #False) ifTrue:[
^ self primary_false
].
(tokenType == #Super) ifTrue:[
^ self primary_super.
].
(tokenType == #ThisContext) ifTrue:[
^ self primary_thisContext
].
(tokenType == #HashLeftParen) ifTrue:[
self inArrayLiteral:true.
self nextToken.
ParseErrorSignal handle:[:ex |
self inArrayLiteral:false.
^ #Error
] do:[
val := self array.
].
self inArrayLiteral:false.
self nextToken.
(self noAssignmentAllowed:'assignment to a constant' at:pos) ifFalse:[
^ #Error
].
^ ConstantNode type:#Array value:val
].
(tokenType == #HashLeftBrace) ifTrue:[
val := self qualifiedName.
self nextToken.
^ val.
].
(tokenType == #HashLeftBrack) ifTrue:[
self nextToken.
val := self byteArray.
self nextToken.
(self noAssignmentAllowed:'assignment to a constant' at:pos) ifFalse:[
^ #Error
].
^ ConstantNode type:#ByteArray value:val
].
(tokenType == $() ifTrue:[
^ self primary_expression.
].
(tokenType == $[ ) ifTrue:[
self markBracketAt:tokenPosition.
val := self block.
self nextToken.
(self noAssignmentAllowed:'invalid assignment' at:pos) ifFalse:[
^ #Error
].
^ val
].
"/ EXPERIMENTAL - may be in next release
AllowVariableReferences == true ifTrue:[
((tokenType == #BinaryOperator) and:[token = '&']) ifTrue:[
self nextToken.
node := self primary_identifier.
"/ generate a Reference
^ self makeReferenceFor:node
].
].
(tokenType == ${ ) ifTrue:[
allowSqueakExtensions == true ifFalse:[
self parseError:'non-Standard Squeak extension: Brace Computed Array. Enable in settings.' position:pos to:tokenPosition.
^ #Error
].
^ self primary_squeakComputedArray.
].
(tokenType == #Primitive) ifTrue:[
self nextToken.
node := PrimitiveNode code:tokenValue.
hasNonOptionalPrimitiveCode := true.
hasPrimitiveCode := true.
^ node
].
tokenType == #HashHashLeftParen ifTrue:[
self halt.
self nextToken.
AllowDolphinExtensions == true ifFalse:[
self parseError:'non-Standard Dolphin extension: ##(..). Enable in settings.' position:pos to:tokenPosition.
^ #Error
].
^ self primary_dolphinComputedLiteral.
].
tokenType == #ExclaLeftBrack ifTrue:[
self nextToken.
AllowLazyValueExtension == true ifFalse:[
self parseError:'non-Standard LazyValue extension. Enable in classVariable.' position:pos to:tokenPosition.
^ #Error
].
^ self primary_lazyValue.
].
tokenType == #HashHash ifTrue:[
self warnPossibleIncompatibility:'''##'' might be interpreted differently in other smalltalk systems' position:pos to:tokenPosition.
tokenType := #Symbol.
token := tokenValue := tokenName := '#'.
^ self primary_simpleLiteral.
].
(tokenType == #Error) ifTrue:[^ #Error].
tokenType isCharacter ifTrue:[
self syntaxError:('error in primary; '
, tokenType printString ,
' unexpected') position:tokenPosition to:tokenPosition
] ifFalse:[
(#(BinaryOperator Keyword) includes:tokenType) ifTrue:[
eMsg := ('error in primary; '
, tokenType printString , '(' , tokenName , ') ' ,
' unexpected (missing receiver ?)')
] ifFalse:[
eMsg := ('error in primary; '
, (token ? '') , ' (', tokenType printString ,
') unexpected')
].
self syntaxError:eMsg position:tokenPosition to:source position
].
^ #Error
"Created: / 13.9.1995 / 12:50:50 / claus"
"Modified: / 18.8.2000 / 20:51:22 / cg"
!
primary_dolphinComputedLiteral
"parse a dolphin computed literal; return a node-tree, or raise an Error.
In dolphin, these are written as: ##( expression )
and create a literal constant for the expressions value.
Right now, only a subset is supported - Strings, ByteArrays and Characters.
WARNING: this is only supported to allow filing in dolphin code.
since stc cannot handle this (at the moment), you should rewrite the code
if you ever plan to stc-compile it into a shared library"
|pos expr val|
pos := tokenPosition.
expr := self expression.
tokenType ~~ $) ifTrue:[
self parseError:''')'' expected' position:tokenPosition.
^ #Error
].
self nextToken.
(self noAssignmentAllowed:'invalid assignment' at:pos) ifFalse:[
^ #Error
].
val := expr evaluate.
val isLiteral ifTrue:[
val isString ifTrue:[
^ ConstantNode type:#String value:val
].
val isByteArray ifTrue:[
^ ConstantNode type:#ByteArray value:val
].
val isCharacter ifTrue:[
^ ConstantNode type:#Character value:val
].
val isInteger ifTrue:[
^ ConstantNode type:#Integer value:val
].
val isLimitedPrecisionReal ifTrue:[
^ ConstantNode type:#Float value:val
].
val isArray ifTrue:[
^ ConstantNode type:#Array value:val
].
] ifFalse:[
self parseError:'must be representable as a literal (for now)' position:pos.
^ #Error
].
self halt:'unimplemented'.
"/ "/ make it an array creation expression ...
"/ expr := MessageNode
"/ receiver:(VariableNode globalNamed:#Array)
"/ selector:#new:
"/ arg:(ConstantNode type:#Integer value:(exprList size)).
"/
"/ exprList size == 0 ifTrue:[
"/ ^ expr.
"/ ].
"/ exprList keysAndValuesDo:[:idx :e |
"/ expr := (idx == 1 ifTrue:[MessageNode] ifFalse:[CascadeNode])
"/ receiver:expr
"/ selector:#at:put:
"/ arg1:(ConstantNode type:#Integer value:idx)
"/ arg2:e
"/ fold:false.
"/ ].
"/ expr := CascadeNode
"/ receiver:expr
"/ selector:#yourself.
"/ ^ expr
!
primary_expression
"parse a parentized expression primary; return a node-tree, or raise an Error."
|pos val eMsg|
pos := tokenPosition.
self nextToken.
val := self expression.
(val == #Error) ifTrue:[^ #Error].
(tokenType ~~ $) ) ifTrue:[
tokenType isCharacter ifTrue:[
eMsg := 'missing '')'' (i.e. ''' , tokenType asString , ''' unexpected)'.
] ifFalse:[
eMsg := 'missing '')'''.
].
self syntaxError:eMsg withCRs position:pos to:tokenPosition.
^ #Error
].
self nextToken.
(self noAssignmentAllowed:'invalid assignment' at:pos) ifFalse:[
^ #Error
].
val parenthized:true.
^ val
!
primary_false
"parse a false primary; return a node-tree, or raise an Error."
|pos|
pos := tokenPosition.
self nextToken.
(self noAssignmentAllowed:'assignment to ''false''' at:pos) ifFalse:[
^ #Error
].
self markBooleanConstantFrom:pos to:pos+4.
^ ConstantNode type:#False value:false
!
primary_here
"parse a here primary; return a node-tree, nil or #Error."
|pos|
pos := tokenPosition.
self nextToken.
(self noAssignmentAllowed:'assignment to pseudo variable ''here''' at:pos) ifFalse:[
^ #Error
].
classToCompileFor isNil ifTrue:[
self warning:'in which class are you ?' position:pos to:(pos + 3).
].
self markSelfFrom:pos to:pos+3.
^ SuperNode value:selfValue inClass:classToCompileFor here:true
!
primary_identifier
"parse a false primary; return a node-tree, or raise an Error."
|pos1 pos2 expr varName rawName var globlName nameSpace nameSpaceGlobal
t cls lnr node holder autoHow|
pos1 := tokenPosition.
pos2 := tokenPosition + tokenName size - 1.
varName := tokenName.
((selector isNil or:[selector == #doIt])
and:[currentBlock isNil
and:[(requestor askFor:#isWorkspace)
and:[(autoHow := requestor autoDefineVariables) notNil]]]) ifTrue:[
var := self variableOrError:varName.
self nextToken.
(var == #Error) ifTrue:[
((tokenType == $_) or:[tokenType == #':=']) ifTrue:[
autoHow == #workspace ifTrue:[
holder := Workspace addWorkspaceVariable:varName.
var := VariableNode type:#WorkspaceVariable holder:holder name:varName
] ifFalse:[
holder := self addDoItTemporary:varName.
var := VariableNode type:#DoItTemporary holder:holder name:varName
].
] ifFalse:[
var := self correctVariable:varName atPosition:pos1 to:pos2.
].
]
] ifFalse:[
var := self variable.
self nextToken.
].
"/ errorFlag == true ifTrue:[self halt].
(var == #Error) ifTrue:[
errorFlag := true
].
(tokenType == #'::') ifTrue:[
globlName := rawName := varName.
"is it in a namespace ?"
nameSpace := self findNameSpaceWith:globlName.
nameSpace notNil ifTrue:[
globlName := nameSpace name , '::' , globlName
].
[tokenType == #'::'] whileTrue:[
nameSpace := globlName.
self nextToken.
(tokenType == #Identifier) ifTrue:[
ignoreWarnings ifFalse:[
warnSTXNameSpaceUse ifTrue:[
self warning:'nameSpaces are a nonstandard feature of ST/X'
position:pos1 to:(source position).
"
only warn once
"
warnSTXNameSpaceUse := false
]
].
varName := tokenName.
globlName := (nameSpace , '::' , varName).
rawName := (rawName , '::' , varName).
nameSpaceGlobal := Smalltalk at:nameSpace asSymbol ifAbsent:nil.
nameSpaceGlobal isNil ifTrue:[
warnedUnknownNamespaces isNil ifTrue:[
warnedUnknownNamespaces := Set new.
].
(warnedUnknownNamespaces includes:nameSpace) ifFalse:[
self warning:('unknown nameSpace: ', nameSpace)
position:pos1 to:tokenPosition-1.
"/ self parseError:('unknown nameSpace: ', nameSpace) position:pos to:tokenPosition-1.
warnedUnknownNamespaces add:nameSpace.
]
] ifFalse:[
nameSpaceGlobal isNameSpace ifTrue:[
"/ for now: only Smalltalk is allowed
nameSpaceGlobal ~~ Smalltalk ifTrue:[
"/ self parseError:('(currently) the only valid nameSpace is `Smalltalk''') position:pos to:tokenPosition-1.
] ifFalse:[
globlName := varName
].
] ifFalse:[
nameSpaceGlobal isBehavior ifFalse:[
self parseError:('invalid nameSpace: ' , nameSpace) position:pos1 to:tokenPosition-1.
] ifTrue:[
(nameSpaceGlobal privateClassesAt:varName asSymbol) isNil ifTrue:[
self warning:('no private class: ' , varName , ' in class: ' , nameSpace)
position:pos1 to:tokenPosition-1.
"/ self parseError:('no private class: ' , name , ' in class: ' , nameSpace) position:pos to:tokenPosition-1.
]
]
].
].
self nextToken.
].
var := VariableNode globalNamed:globlName.
parseForCode ifFalse:[self rememberGlobalUsed:globlName].
].
self markVariable:var from:pos1 to:pos1 + rawName size - 1.
].
var == #Error ifTrue:[
^ #Error
].
errorFlag ~~ true ifTrue:[
self markVariable:var from:pos1 to:pos1 + varName size - 1.
].
(ignoreErrors or:[ignoreWarnings or:[parseForCode not]]) ifTrue:[
errorFlag := false.
].
((tokenType ~~ $_) and:[tokenType ~~ #':=']) ifTrue:[
parseForCode ifFalse:[
var isInstanceVariable ifTrue:[ self rememberInstVarRead:var name].
var isClassVariable ifTrue:[ self rememberClassVarRead:var name].
].
^ var
].
"/ careful: it could already be an implicit self send
ImplicitSelfSends ifTrue:[
var isMessage ifTrue:[
self nextToken.
expr := self expression.
self isSyntaxHighlighter ifFalse:[
(errorFlag or:[expr == #Error]) ifTrue:[^ #Error].
].
^ MessageNode receiver:(self selfNode) selector:('__' , varName , ':') asSymbol arg:expr.
].
].
(var ~~ #Error) ifTrue:[
t := var type.
(t ~~ #MethodVariable) ifTrue:[
(t == #PrivateClass) ifTrue:[
self parseError:'assignment to private class' position:pos1 to:pos2.
] ifFalse:[
(t == #MethodArg) ifTrue:[
self parseError:'assignment to method argument' position:pos1 to:pos2.
] ifFalse:[
(t == #BlockArg) ifTrue:[
self parseError:'assignment to block argument' position:pos1 to:pos2.
] ifFalse:[
(t == #InstanceVariable) ifTrue:[
varName := self classesInstVarNames at:(var index).
"/ ca once did this to `name' and wondered what happened to his class ...
"/ (not really a beginners bug, but may happen as a typo or missing local variable;
"/ and is hard to track down later)
warnCommonMistakes ifTrue:[
classToCompileFor isMeta ifTrue:[
(classToCompileFor isSubclassOf:Class) ifTrue:[
(Class allInstVarNames includes:(var name)) ifTrue:[
self warning:'assignment to a classInstanceVariable\(see hierarchy of `Class'')' withCRs position:pos1 to:pos2.
]
]
]
].
parseForCode ifFalse:[
modifiedInstVars isNil ifTrue:[
modifiedInstVars := Set new
].
modifiedInstVars add:varName
]
] ifFalse:[
(t == #ClassVariable) ifTrue:[
varName := var name.
varName := varName copyFrom:((varName indexOf:$:) + 1).
parseForCode ifFalse:[
modifiedClassVars isNil ifTrue:[
modifiedClassVars := Set new
].
modifiedClassVars add:varName
]
] ifFalse:[
(t == #GlobalVariable) ifTrue:[
(cls := Smalltalk classNamed:var name) notNil ifTrue:[
cls name = var name ifTrue:[
self warning:'assignment to global which refers to a class' position:pos1 to:pos2.
]
].
parseForCode ifFalse:[
modifiedGlobals isNil ifTrue:[
modifiedGlobals := Set new
].
modifiedGlobals add:var name
]
]
]
]
]
]
]
].
t == #MethodVariable ifTrue:[
modifiedLocalVars isNil ifTrue:[
modifiedLocalVars := Set new.
].
modifiedLocalVars add:var name.
].
].
lnr := tokenLineNr.
self nextToken.
pos2 := tokenPosition.
expr := self expression.
"/ a typical beginner error:
"/ expr ifTrue:[
"/ var := super
"/ ] ifFalse:[
"/ var := something-else
"/ ].
"/ var messageSend
"/
"/ does not what a beginner might think.
self isSyntaxHighlighter ifTrue:[
(expr == #Error) ifTrue:[^ #Error].
] ifFalse:[
warnCommonMistakes ifTrue:[
(expr ~~ #Error and:[expr isSuper]) ifTrue:[
self warning:'followup messageSends to `' , var name , ''' will have normal send semantics\(i.e. NO super- or here-sends). Use self to avoid confusion.' withCRs position:pos1 to:pos2.
].
].
(errorFlag or:[expr == #Error]) ifTrue:[^ #Error].
expr isVariable ifTrue:[
expr name = var name ifTrue:[
self warning:('useless assignment to `' , var name, '''' ) position:pos1 to:pos2-1.
].
].
].
node := AssignmentNode variable:var expression:expr.
(lineNumberInfo == #full) ifTrue:[node lineNumber:lnr].
^ node
!
primary_lazyValue
|pos block expr|
pos := tokenPosition.
(tokenType == $: ) ifTrue:[
self parseError:'lazyValues have no arguments' position:tokenPosition.
^ #Error
].
block := self blockBody:#().
self nextToken.
expr := MessageNode
receiver:(VariableNode globalNamed:#LazyValue)
selector:#'block:'
arg:block.
^ expr
!
primary_nil
"parse a nil primary; return a node-tree, nil or #Error."
|pos|
pos := tokenPosition.
self nextToken.
(self noAssignmentAllowed:'assignment to ''nil''' at:pos) ifFalse:[
^ #Error
].
"/ self markConstantFrom:pos to:pos+2.
nilNode isNil ifTrue:[
nilNode := ConstantNode type:#Nil value:nil
].
^ nilNode
!
primary_self
"parse a self primary; return a node-tree, nil or #Error."
|pos|
pos := tokenPosition.
self nextToken.
(self noAssignmentAllowed:'assignment to pseudo variable ''self''' at:pos) ifFalse:[
^ ParseError raise
].
self markSelfFrom:pos to:pos+3.
^ self selfNode
!
primary_simpleLiteral
"parse a simple literal primary; return a node-tree, or raise an Error."
|pos val|
pos := tokenPosition.
"/
"/ ImmutableStrings are experimental
"/
((tokenType == #String)
and:[(StringsAreImmutable == true)
and:[ImmutableString notNil]]) ifTrue:[
tokenValue := tokenValue copy.
tokenValue changeClassTo:ImmutableString.
token := tokenValue
].
(tokenType == #Symbol) ifTrue:[
parseForCode ifFalse:[
self rememberSymbolUsed:tokenValue
].
].
val := ConstantNode type:tokenType value:tokenValue.
tokenValue isSymbol ifTrue:[
self markSymbolFrom:tokenPosition to:tokenPosition+tokenValue size-1.
].
self nextToken.
(self noAssignmentAllowed:'assignment to a constant' at:pos) ifFalse:[
^ #Error
].
^ val
!
primary_squeakComputedArray
"parse a squeak computed array literal; return a node-tree, or raise an Error.
In squeak, these are written as: { expr1 . expr2 . ... exprN )
and create a literalArray containing the exprI values.
WARNING: this is only supported to allow filing in squeak code.
since stc cannot handle this (at the moment), you should rewrite the code
if you ever plan to stc-compile it into a shared library"
|pos exprList|
pos := tokenPosition.
self nextToken.
exprList := self squeakComputedArray.
(exprList == #Error) ifTrue:[ ^ #Error ].
tokenType ~~ $} ifTrue:[
self parseError:'''}'' expected' position:tokenPosition.
^ #Error
].
self nextToken.
(self noAssignmentAllowed:'invalid assignment' at:pos) ifFalse:[
^ #Error
].
"/ make it an array creation expression ...
^ self genMakeArrayWith:exprList
"
Compiler allowSqueakExtensions:true.
"
"
{ 1@2. 10 factorial. Date today }.
"
"
Compiler allowSqueakExtensions:false.
"
!
primary_super
"parse a super primary; return a node-tree, nil or #Error."
|pos|
pos := tokenPosition.
usesSuper := true.
self nextToken.
(self noAssignmentAllowed:'assignment to pseudo variable ''super''' at:pos) ifFalse:[
^ #Error
].
(classToCompileFor isNil or:[classToCompileFor superclass isNil]) ifTrue:[
self warning:'superclass is (currently ?) nil' position:pos to:(pos + 4).
].
superNode isNil ifTrue:[
superNode := SuperNode value:selfValue inClass:classToCompileFor
].
self markSelfFrom:pos to:pos+4.
^ superNode
!
primary_thisContext
"parse a thisContext primary; return a node-tree, or raise an Error."
|pos|
pos := tokenPosition.
self nextToken.
(self noAssignmentAllowed:'assignment to pseudo variable ''thisContext''' at:pos) ifFalse:[
^ #Error
].
self markIdentifierFrom:pos to:pos+10.
^ VariableNode type:#ThisContext context:contextToEvaluateIn. "/ often nil
!
primary_true
"parse a true primary; return a node-tree, or raise an Error."
|pos|
pos := tokenPosition.
self nextToken.
(self noAssignmentAllowed:'assignment to ''true''' at:pos) ifFalse:[
^ #Error
].
self markBooleanConstantFrom:pos to:pos+3.
^ ConstantNode type:#True value:true
!
qualifiedName
"a vw3.x (and later) feature: QualifiedName is #{ id ... id }
and mapped to a global variable here.
The initial #{ is supposed to be not yet skipped."
|elements elem pos1|
pos1 := tokenPosition.
self nextToken.
elements := OrderedCollection new.
[tokenType ~~ $} ] whileTrue:[
elem := self variable.
(elem == #Error) ifTrue:[
(tokenType == #EOF) ifTrue:[
self syntaxError:'unterminated qualifiedName; ''}'' expected'
position:pos1 to:tokenPosition
].
^ #Error
].
errorFlag := false.
(elem isVariable and:[elem isGlobal]) ifFalse:[
self warning:'elements of a qualifiedName should be globalIdentifiers'
position:pos1 to:tokenPosition
].
elements add:elem.
self nextToken.
tokenType == #'::' ifTrue:[
"/ notice that Foo.Bar has already been scanned as Foo::Bar
"/(which is a kludge)
self nextToken.
] ifFalse:[
tokenType ~~ $} ifTrue:[
self syntaxError:'bad qualifiedName syntax; ''.'' or ''}'' expected'
position:pos1 to:tokenPosition.
^ #Error
].
].
].
elements size > 1 ifTrue:[
self syntaxError:'Sorry: qualified names are not yet implemented.'.
].
^ elements first.
"Modified: / 14.4.1998 / 17:03:29 / cg"
!
squeakComputedArray
|expressions elem pos1|
tokenType == $} ifTrue:[
^ #()
].
pos1 := tokenPosition.
expressions := OrderedCollection new:20.
[true] whileTrue:[
elem := self expression.
(elem == #Error) ifTrue:[
(tokenType == #EOF) ifTrue:[
self syntaxError:'unterminated computed-array-element; ''}'' expected'
position:pos1 to:tokenPosition
].
^ #Error
].
expressions add:elem.
tokenType == $. ifFalse:[
^ expressions
].
self nextToken.
tokenType == $} ifTrue:[
^ expressions
].
].
"/ not reached
!
unaryExpression
"parse a unary-expression; return a node-tree, nil or #Error"
|receiver|
receiver := self functionCallExpression.
(receiver == #Error) ifTrue:[^ #Error].
^ self unaryExpressionFor:receiver
!
unaryExpressionFor:receiverArg
"parse a unary-expression; return a node-tree, nil or #Error"
|receiver thisReceiver sel pos pos2 try note|
receiver := receiverArg.
(receiver == #Error) ifTrue:[^ #Error].
[ self isValidUnarySelector:tokenType ] whileTrue:[
pos := tokenPosition.
pos2 := pos + tokenName size - 1.
self markSelector:tokenName from:pos to:pos2 receiverNode:receiver.
sel := tokenName.
sel := self selectorCheck:sel for:receiver position:pos to:pos2.
thisReceiver := receiver.
try := UnaryNode receiver:receiver selector:sel fold:foldConstants.
(try isMemberOf:String) ifTrue:[
self parseError:try position:pos to:pos2.
errorFlag := false. "ok, user wants it - so he'll get it"
receiver := UnaryNode receiver:receiver selector:sel fold:nil.
] ifFalse:[
receiver := try
].
note := self plausibilityCheck:receiver.
note notNil ifTrue:[
self warning:note position:pos to:pos2
].
receiver lineNumber:tokenLineNr.
parseForCode ifFalse:[
self rememberSelectorUsed:sel receiver:thisReceiver
].
self nextToken.
].
^ receiver
"Modified: / 6.2.2000 / 14:54:20 / cg"
!
variable
"parse a simple (i.e. non-namespace-access path) variable;
return a node-tree, nil or #Error.
Does not advance to next token.
If undefined, notify error and correct if user wants to"
|v pos1 pos2|
v := self variableOrError:tokenName.
(v ~~ #Error) ifTrue:[
(v isMemberOf:VariableNode) ifTrue:[
self markVariable:v.
].
^ v
].
pos1 := tokenPosition.
pos2 := pos1+tokenName size-1.
self markUnknownIdentifierFrom:pos1 to:pos2.
parseForCode == true ifTrue:[
v := self correctVariable:tokenName atPosition:pos1 to:pos2.
(v ~~ #Error) ifTrue:[^ v].
].
errorFlag := true.
parseForCode ifFalse:[
self rememberGlobalUsed:(Smalltalk undeclaredPrefix) , tokenName.
self rememberGlobalUsed:tokenName.
] ifTrue:[
tokenName first isLowercase ifTrue:[
ImplicitSelfSends ifTrue:[
^ UnaryNode receiver:(self selfNode) selector:('__' , tokenName) asSymbol.
].
^ #Error
]
].
"/ self markGlobalIdentifierFrom:pos1 to:pos2.
^ VariableNode globalNamed:tokenName
"Modified: / 16.4.1998 / 18:46:45 / cg"
!
variableOrError
"parse a simple (i.e. non-namespace-access path) variable;
return a node-tree, nil or #Error.
Does not advance to next token."
^ self variableOrError:tokenName
!
variableOrError:varName
"parse a simple (i.e. non-namespace-access path) variable;
return a node-tree, nil or #Error.
Does not advance to next token."
|varIndex aClass searchBlock args vars
tokenSymbol space classVarIndex holder node|
"is it a block-arg or block-var ?"
searchBlock := currentBlock.
[searchBlock notNil] whileTrue:[
vars := searchBlock variables.
vars notNil ifTrue:[
varIndex := vars findFirst:[:aBlockVar | aBlockVar name = varName].
varIndex ~~ 0 ifTrue:[
^ VariableNode type:#BlockVariable
name:varName
token:(vars at:varIndex)
index:varIndex
block:searchBlock
from:currentBlock
].
].
args := searchBlock arguments.
args notNil ifTrue:[
varIndex := args findFirst:[:aBlockArg | aBlockArg name = varName].
varIndex ~~ 0 ifTrue:[
^ VariableNode type:#BlockArg
name:varName
token:(args at:varIndex)
index:varIndex
block:searchBlock
from:currentBlock
].
].
searchBlock := searchBlock home
].
"is it a method-variable ?"
(node := self nodeForMethodVariable:varName) notNil
ifTrue:[
^ node
].
"is it a method-argument ?"
(node := self nodeForMethodArg:varName) notNil
ifTrue:[
^ node
].
contextToEvaluateIn notNil ifTrue:[
|con varNames|
"/
"/ search names of the context.
"/
con := contextToEvaluateIn.
[con notNil] whileTrue:[
varNames := self class argAndVarNamesForContext:con.
varNames size > 0 ifTrue:[
varIndex := varNames lastIndexOf:varName.
varIndex ~~ 0 ifTrue:[
^ VariableNode type:#ContextVariable
name:varName
context:con
index:varIndex
].
].
con := con home.
].
].
classToCompileFor notNil ifTrue:[
"is it an instance-variable ?"
varIndex := (self classesInstVarNames) lastIndexOf:varName.
varIndex ~~ 0 ifTrue:[
classToCompileFor isMeta ifTrue:[
classVarIndex := (self classesClassVarNames) lastIndexOf:varName.
classVarIndex ~~ 0 ifTrue:[
"/ give a warning - that maybe a common error
alreadyWarnedClassInstVarRefs isNil ifTrue:[
alreadyWarnedClassInstVarRefs := Set new
].
(alreadyWarnedClassInstVarRefs includes:varName) ifFalse:[
self warning:('there is both a class variable and a class-instance variable named ''' , varName , '''.\\Refering to the class-instance variable here.') withCRs.
alreadyWarnedClassInstVarRefs add:varName.
].
].
].
parseForCode ifFalse:[self rememberInstVarUsed:varName].
^ VariableNode type:#InstanceVariable
name:varName
index:varIndex
selfValue:selfValue
].
"/ see if there is a corresponding classVar (for the warning)
classVarIndex := (self classesClassVarNames) lastIndexOf:varName.
"/ "is it a class-instance-variable ?"
"/
"/ Notice:
"/ it is no longer allowed to fetch class-instance variables
"/ from instance methods ...
"/ (used to be in previous ST/X versions)
"/
varIndex := (self classesClassInstVarNames) lastIndexOf:varName.
varIndex ~~ 0 ifTrue:[
aClass := self inWhichClassIsClassInstVar:varName.
aClass notNil ifTrue:[
classToCompileFor isMeta ifFalse:[
classVarIndex == 0 ifTrue:[
"/ there is no corresponding classVar;
"/ wants to access classInstVar ?
contextToEvaluateIn notNil ifTrue:[
"/ allow it in a doIt ...
^ VariableNode type:#ClassInstanceVariable
name:varName
index:varIndex
selfClass:aClass
].
self parseError:'access to class-inst-var from inst method is not allowed'.
^ #Error.
] ifFalse:[
"/ give a warning - that maybe a common error
self warning:('there is both a class variable and a class-instance variable named ''' , varName , '''.\\Refering to the class variable here (instMethods dont see classInstVars).') withCRs.
]
].
"/ OLD CODE:
"/ self warning:'access to class-inst-var from inst method will soon be no longer supported'.
"/
"/ parseForCode ifFalse:[self rememberClassVarUsed:varName].
"/ ^ VariableNode type:#ClassInstanceVariable
"/ name:varName
"/ index:varIndex
"/ selfClass:aClass
"/ ].
] ifFalse:[
"/ self halt:'oops - should not happen'.
]
].
"is it a class-variable ?"
varIndex := classVarIndex.
varIndex ~~ 0 ifTrue:[
aClass := self inWhichClassIsClassVar:varName.
aClass notNil ifTrue:[
parseForCode ifFalse:[self rememberClassVarUsed:varName].
^ VariableNode type:#ClassVariable class:aClass name:varName
].
"/ self halt:'oops - should not happen'.
].
"is it a private-class ?"
aClass := self classToLookForClassVars.
aClass := aClass theNonMetaclass.
(aClass privateClassesAt:varName) notNil ifTrue:[
parseForCode ifFalse:[self rememberGlobalUsed:(aClass name , '::' , varName)].
^ VariableNode type:#PrivateClass class:aClass name:varName
].
].
"is it in a namespace ?"
space := self findNameSpaceWith:varName.
space notNil ifTrue:[
space ~~ Smalltalk ifTrue:[
parseForCode ifFalse:[self rememberGlobalUsed:(space name , '::' , varName)].
space isNameSpace ifTrue:[
^ VariableNode globalNamed:(space name , '::' , varName)
].
^ VariableNode type:#PrivateClass class:space name:varName
].
parseForCode ifFalse:[self rememberGlobalUsed:varName].
^ VariableNode globalNamed:varName
].
"is it a global-variable ?"
tokenSymbol := varName asSymbolIfInterned.
tokenSymbol notNil ifTrue:[
(Smalltalk includesKey:tokenSymbol) ifTrue:[
parseForCode ifFalse:[self rememberGlobalUsed:varName].
^ VariableNode globalNamed:tokenSymbol
]
].
"is it a workspace variable ?"
(requestor notNil and:[requestor isStream not]) ifTrue:[
"/ when parsing doits, this is done twice;
"/ first, for the parse, then as a block-code
"/ for the code.
"/ We only care for WorkspaceVars in doIts
(selector isNil or:[selector == #doIt]) ifTrue:[
(Workspace notNil
and:[(holder := Workspace workspaceVariableAt:varName) notNil])
ifTrue:[
^ VariableNode type:#WorkspaceVariable holder:holder name:varName
]
]
].
"is it a doIt variable ?"
"/ (requestor notNil and:[requestor isStream not]) ifTrue:[
"/ when parsing doits, this is done twice;
"/ first, for the parse, then as a block-code
"/ for the code.
"/ We only care for WorkspaceVars in doIts
(selector isNil or:[selector == #doIt]) ifTrue:[
(doItTemporaries notNil
and:[(holder := doItTemporaries at:varName asSymbol ifAbsent:nil) notNil])
ifTrue:[
^ VariableNode type:#DoItTemporary holder:holder name:varName
]
].
"/ ].
^ #Error
"Modified: / 5.11.2001 / 16:45:35 / cg"
! !
!Parser methodsFor:'private'!
currentNameSpace
|spc|
spc := currentNamespace.
spc isNil ifTrue:[
(requestor respondsTo:#currentNameSpace) ifTrue:[
spc := requestor currentNameSpace
] ifFalse:[
spc := Class nameSpaceQuerySignal query.
].
currentNamespace := spc.
].
^ spc
"Created: / 19.12.1996 / 23:47:58 / cg"
"Modified: / 14.10.1997 / 20:56:06 / cg"
"Modified: / 18.3.1999 / 18:25:50 / stefan"
!
currentNameSpace:aNameSpace
currentNamespace := aNameSpace.
"Created: 8.2.1997 / 19:37:03 / cg"
!
currentPackage
|pkg|
pkg := currentPackage.
pkg isNil ifTrue:[
(requestor respondsTo:#currentPackage) ifTrue:[
pkg := requestor currentPackage
] ifFalse:[
pkg := Class packageQuerySignal query.
].
currentPackage := pkg.
].
^ pkg
!
currentPackage:aPackageName
currentPackage := aPackageName.
!
currentUsedNameSpaces
|spaces|
spaces := currentUsedNamespaces.
spaces isNil ifTrue:[
(requestor respondsTo:#usedNameSpaces) ifTrue:[
spaces := requestor usedNameSpaces
] ifFalse:[
spaces := Class usedNameSpaceQuerySignal query.
].
spaces isNil ifTrue:[
spaces := #()
].
currentUsedNamespaces := spaces.
].
^ spaces
"Created: / 19.12.1996 / 23:49:10 / cg"
"Modified: / 7.4.1998 / 08:59:28 / cg"
"Modified: / 18.3.1999 / 18:25:57 / stefan"
!
findNameSpaceWith:aVariableName
|ns currentSpace usedSpaces|
"/ private names have already been searched for.
classToCompileFor notNil ifTrue:[
"/ Q:
"/ consider private classes of superclasses.
"/ or search in the top owing classes namespace only ?
"/ for now, ignore other private classes - they are only
"/ known to the corresponding ownerClass.
"is it in the classes namespace ?"
ns := classToCompileFor topNameSpace.
(ns notNil
and:[ns ~~ Smalltalk]) ifTrue:[
ns isNameSpace ifTrue:[
(ns at:aVariableName) notNil ifTrue:[
^ ns
]
]
].
"/ ns := classToCompileFor nameSpace.
"/ ns notNil ifTrue:[
"/ "is it in the current classes namespace ?"
"/ (ns at:aVariableName asSymbol) notNil ifTrue:[
"/ ^ ns
"/ ]
"/ ].
].
"is it in the current namespace ?"
currentSpace := self currentNameSpace.
(currentSpace notNil
and:[currentSpace ~~ Smalltalk]) ifTrue:[
currentSpace isNameSpace ifTrue:[
(currentSpace at:aVariableName) notNil ifTrue:[
^ currentSpace
]
] ifFalse:[
(currentSpace privateClassesAt:aVariableName) notNil ifTrue:[
^ currentSpace
]
]
].
"is it in one of the used namespaces ?"
usedSpaces := self currentUsedNameSpaces.
usedSpaces notNil ifTrue:[
usedSpaces do:[:aNameSpace |
(aNameSpace at:aVariableName) notNil ifTrue:[
^ aNameSpace
]
]
].
^ nil
"Created: 19.12.1996 / 23:51:02 / cg"
"Modified: 14.10.1997 / 20:56:35 / cg"
!
implementedInAnyClass:selector
Smalltalk allClassesAndMetaclassesDo:[:cls |
(cls implements:selector) ifTrue:[^ true].
].
^ false
!
inWhichClassIsClassInstVar:aString
"search class-chain for the class-instance variable named aString
- return the class or nil if not found"
|aClass|
aClass := self classToLookForClassVars.
[aClass notNil] whileTrue:[
(aClass class instVarNames includes:aString) ifTrue:[ ^ aClass].
aClass := aClass superclass
].
^ nil
"Modified: / 18.6.1998 / 15:45:34 / cg"
!
inWhichClassIsClassVar:aString
"search class-chain for the classvariable named aString
- return the class or nil if not found"
|aClass className baseClass|
aClass := self classToLookForClassVars.
aClass isMeta ifTrue:[
className := aClass name copyWithoutLast:6.
baseClass := Smalltalk at:(className asSymbol).
baseClass notNil ifTrue:[
aClass := baseClass
]
].
^ aClass whichClassDefinesClassVar:aString
"/ [aClass notNil] whileTrue:[
"/ (aClass classVarNames includes:aString) ifTrue:[ ^ aClass].
"/ aClass := aClass superclass
"/ ].
"/ ^ nil
"Modified: / 17.6.1996 / 17:18:41 / stefan"
"Modified: / 18.6.1998 / 15:45:29 / cg"
!
makeReferenceFor:aNode
|rec sel indexNode contextNode arg1 arg2|
contextNode := VariableNode type:#ThisContext context:contextToEvaluateIn.
indexNode := ConstantNode type:#Integer value:aNode index.
aNode isArgument ifTrue:[
sel := #forArgument:in:.
arg1 := indexNode.
arg2 := contextNode.
] ifFalse:[
aNode isLocal ifTrue:[
sel := #forLocal:in:.
arg1 := indexNode.
arg2 := contextNode.
] ifFalse:[
self parseError:'unsupported variable reference (must be local or argument)'.
^ aNode
]
].
parseForCode ifFalse:[self rememberGlobalUsed:'Reference'].
rec := VariableNode globalNamed:'Reference'.
^ MessageNode receiver:rec selector:sel arg1:arg1 arg2:arg2.
!
noAssignmentAllowed:eMsg at:pos
((tokenType == $_) or:[tokenType == #':=']) ifTrue:[
self parseError:eMsg position:pos to:tokenPosition + tokenType size - 1.
self isSyntaxHighlighter ifFalse:[
^ false
].
self nextToken. "/ eat the assign when doing highlighting only
].
^ true
!
plausibilityCheck:aNode
|note|
note := aNode plausibilityCheck.
note isNil ifTrue:[
aNode isMessage ifTrue:[
(contextToEvaluateIn isNil and:[selfValue isNil]) ifTrue:[ "/ do not check this for doits
aNode receiver isSuper ifTrue:[
aNode selector ~= selector ifTrue:[
^ 'possible bad super message (selector should be same as in current method) ?'
].
].
].
].
].
^ note
!
selfNode
selfNode isNil ifTrue:[
selfNode := SelfNode value:selfValue
].
^ selfNode
! !
!Parser methodsFor:'queries'!
classToLookForClassVars
"helper - return the class to look for classVars.
If there is a context in which we evaluate, the
methods implementing class is used instead of the
class of the receiver."
|m who|
contextToEvaluateIn notNil ifTrue:[
m := contextToEvaluateIn method.
m notNil ifTrue:[
who := contextToEvaluateIn method who.
who notNil ifTrue:[
^ who methodClass.
]
].
"/ mhmh - might be a doIt ...
].
^ classToCompileFor
"Created: / 18.6.1998 / 15:43:42 / cg"
"Modified: / 21.7.1998 / 18:19:52 / cg"
!
classesClassInstVarNames
"caching allInstVarNames for next compilation saves time ..."
|names|
[
|cls|
cls := self classToLookForClassVars.
(PrevClassInstVarNames isNil or:[PrevClass ~~ cls]) ifTrue:[
PrevClass notNil ifTrue:[
PrevClass removeDependent:Parser
].
PrevClass := cls.
PrevClassInstVarNames := cls class allInstVarNames.
PrevClass addDependent:Parser.
].
names := PrevClassInstVarNames.
] valueUninterruptably.
^ names
"Created: / 14.10.1996 / 18:03:35 / cg"
"Modified: / 18.6.1998 / 15:44:41 / cg"
!
classesClassVarNames
"caching allClassVarNames for next compilation saves time ..."
|names|
[
|cls aClass|
cls := self classToLookForClassVars.
(PrevClassVarNames isNil or:[PrevClass ~~ cls]) ifTrue:[
PrevClass notNil ifTrue:[
PrevClass removeDependent:Parser
].
aClass := PrevClass := cls.
aClass isMeta ifTrue:[
aClass := aClass soleInstance.
aClass isNil ifTrue:[
aClass := classToCompileFor
]
].
PrevClassVarNames := aClass allClassVarNames.
PrevClass addDependent:Parser.
].
names := PrevClassVarNames.
] valueUninterruptably.
^ names
"Modified: / 17.6.1996 / 17:15:53 / stefan"
"Created: / 14.10.1996 / 18:02:41 / cg"
"Modified: / 18.6.1998 / 15:44:30 / cg"
!
classesInstVarNames
"caching allInstVarNames for next compilation saves time ..."
|names|
[
(PrevInstVarNames isNil or:[PrevClass ~~ classToCompileFor]) ifTrue:[
PrevClass notNil ifTrue:[
PrevClass removeDependent:Parser
].
PrevClass := classToCompileFor.
PrevInstVarNames := classToCompileFor allInstVarNames.
PrevClassInstVarNames := nil.
PrevClassVarNames := nil.
PrevClass addDependent:Parser
].
names := PrevInstVarNames
] valueUninterruptably.
^ names
"Created: 14.10.1996 / 18:00:26 / cg"
!
contextMustBeReturnable
^ primitiveContextInfo notNil
and:[ ^ primitiveContextInfo includes:('context:' -> #return) ]
!
hasNonOptionalPrimitiveCode
"return true if there was any ST/X style primitive code (valid after parsing)"
^ hasNonOptionalPrimitiveCode
!
hasPrimitiveCode
"return true if there was any ST/X style primitive code (valid after parsing)"
^ hasPrimitiveCode
!
isSyntaxHighlighter
^ false
!
lineNumberInfo
^ lineNumberInfo
"Created: 21.10.1996 / 17:06:16 / cg"
!
lineNumberInfo:how
lineNumberInfo := how
"Created: 23.10.1996 / 15:39:43 / cg"
!
messagesSent
"return a collection with sent message selectors (valid after parsing).
Includes all sent messages (i.e. also sent super messages)"
^ (messagesSent ? #()) collect:[:each | each asSymbol]
!
messagesSentToSelf
"return a collection with message selectors sent to self only (valid after parsing)"
^ (messagesSentToSelf ? #()) collect:[:each | each asSymbol]
!
messagesSentToSuper
"return a collection with message selectors sent to super only (valid after parsing)"
^ (messagesSentToSuper ? #()) collect:[:each | each asSymbol]
!
methodArgs
"return an array with methodarg names (valid after parsing spec)"
^ methodArgNames
!
methodVars
"return a collection with method variablenames (valid after parsing)"
^ methodVarNames
!
modifiedClassVars
"return a collection with classvariablenames modified by method (valid after parsing)"
^ modifiedClassVars ? #()
"Modified: 19.6.1997 / 17:54:48 / cg"
!
modifiedGlobals
"return a collection with globalnames modified by method (valid after parsing)"
^ modifiedGlobals ? #()
"Modified: 19.6.1997 / 17:54:51 / cg"
!
modifiedInstVars
"return a collection with instvariablenames modified by method (valid after parsing)"
^ modifiedInstVars ? #()
"Modified: 19.6.1997 / 17:54:27 / cg"
!
numberOfMethodArgs
"return the number of methodargs (valid after parsing spec)"
^ methodArgs size
!
numberOfMethodVars
"return the number of method variables (valid after parsing)"
^ methodVars size
!
readClassVars
"return a collection with classvariablenames read by method (valid after parsing)"
^ readClassVars ? #()
"Modified: 19.6.1997 / 17:54:38 / cg"
!
readInstVars
"return a collection with instvariablenames read by method (valid after parsing)"
^ readInstVars ? #()
"Modified: 19.6.1997 / 17:54:38 / cg"
!
selector
"return the selector (valid after parsing spec)"
^ selector
!
usedClassVars
"return a collection with classvariablenames refd by method (valid after parsing)"
^ usedClassVars ? #()
"Modified: 19.6.1997 / 17:54:56 / cg"
!
usedGlobals
"return a collection with globalnames refd by method (valid after parsing)"
^ usedGlobals ? #()
"Modified: 19.6.1997 / 17:55:00 / cg"
!
usedInstVars
"return a collection with instvariablenames refd by method (valid after parsing)"
^ usedInstVars ? #()
"Modified: 19.6.1997 / 17:54:38 / cg"
!
usedSymbols
"return a collection with used symbols (except for sent messages) (valid after parsing)"
^ (usedSymbols ? #())
!
usedVars
"return a collection with variablenames refd by method (valid after parsing)"
^ usedVars ? #()
"Modified: 19.6.1997 / 17:55:04 / cg"
!
usesSuper
"return true if the parsed method uses super (valid after parsing)"
^ usesSuper
! !
!Parser methodsFor:'setup'!
classToCompileFor
^ classToCompileFor
"Created: / 15.11.2001 / 17:21:10 / cg"
!
foldConstants:aSymbolOrNil
"change the constant folding level. See the classMethod for a description."
foldConstants := aSymbolOrNil
"Created: 21.3.1996 / 16:03:22 / cg"
"Modified: 21.3.1996 / 16:05:04 / cg"
!
initialize
super initialize.
hasPrimitiveCode := hasNonOptionalPrimitiveCode := false.
warnSTXHereExtensionUsed := WarnSTXSpecials.
usesSuper := false.
parseForCode := false.
foldConstants := FoldConstants.
lineNumberInfo := LineNumberInfo.
warnUndeclared := true.
warnUnusedVars := WarnUnusedVars.
"Modified: 7.9.1997 / 02:04:34 / cg"
!
initializeFlagsFrom:aParser
"initialize flags from another scanner"
super initializeFlagsFrom:aParser.
warnSTXHereExtensionUsed := aParser warnSTXHereExtensionUsed.
!
parseForCode
"turns off certain statistics (keeping referenced variables, modified vars etc.)
Use this when parsing for compilation or evaluation"
parseForCode := true
!
setClassToCompileFor:aClass
"set the class to be used for parsing/evaluating"
classToCompileFor := aClass.
(classToCompileFor ~~ PrevClass) ifTrue:[
PrevClass notNil ifTrue:[
Parser update:PrevClass
]
]
!
setContext:aContext
"set the context used while evaluating"
contextToEvaluateIn := aContext
!
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
]
]
!
warnUndeclared:aBoolean
warnUndeclared := aBoolean.
"Created: 7.9.1997 / 02:05:00 / cg"
!
warnUnusedVars:aBoolean
warnUnusedVars := aBoolean.
! !
!Parser methodsFor:'statistic'!
rememberClassVarRead:name
readClassVars isNil ifTrue:[
readClassVars := Set new
].
readClassVars add:name.
self rememberClassVarUsed:name
!
rememberClassVarUsed:name
usedClassVars isNil ifTrue:[
usedClassVars := Set new
].
usedClassVars add:name.
self rememberVariableUsed:name
!
rememberGlobalUsed:name
usedGlobals isNil ifTrue:[
usedGlobals := Set new
].
usedGlobals add:name.
self rememberVariableUsed:name
!
rememberInstVarRead:name
readInstVars isNil ifTrue:[
readInstVars := Set new
].
readInstVars add:name.
self rememberVariableUsed:name
!
rememberInstVarUsed:name
usedInstVars isNil ifTrue:[
usedInstVars := Set new
].
usedInstVars add:name.
self rememberVariableUsed:name
!
rememberLocalUsed:name
usedLocalVars isNil ifTrue:[
usedLocalVars := Set new
].
usedLocalVars add:name.
!
rememberReturnedValue:anExpressionNode
|expr|
returnedValues isNil ifTrue:[returnedValues := Set new].
expr := anExpressionNode.
expr isAssignment ifTrue:[
expr := expr expression.
].
(expr isConstant or:[expr isSelf]) ifTrue:[
returnedValues add:expr
].
!
rememberSelectorUsed:sel
messagesSent isNil ifTrue:[
messagesSent := IdentitySet new.
].
messagesSent add:sel
!
rememberSelectorUsed:sel receiver:receiverNode
self rememberSelectorUsed:sel.
receiverNode isSuper ifTrue:[
self rememberSelectorUsedInSuperSend:sel
] ifFalse:[
receiverNode isSelf ifTrue:[
self rememberSelectorUsedInSelfSend:sel
].
].
!
rememberSelectorUsedInSelfSend:sel
messagesSentToSelf isNil ifTrue:[
messagesSentToSelf := IdentitySet new.
].
messagesSentToSelf add:sel
!
rememberSelectorUsedInSuperSend:sel
messagesSentToSuper isNil ifTrue:[
messagesSentToSuper := IdentitySet new.
].
messagesSentToSuper add:sel
!
rememberSymbolUsed:aSymbol
usedSymbols isNil ifTrue:[
usedSymbols := IdentitySet new.
].
usedSymbols add:aSymbol
!
rememberVariableUsed:name
usedVars isNil ifTrue:[
usedVars := Set new
].
usedVars add:name
! !
!Parser::ParseError methodsFor:'accessing'!
endPosition
"return the value of the instance variable 'endPosition' (automatically generated)"
^ endPosition
!
errorMessage
"return the value of the instance variable 'errorMessage' (automatically generated)"
^ errorMessage
!
errorMessage:errorMessageArg startPosition:startPositionArg endPosition:endPositionArg
"set instance variables (automatically generated)"
errorMessage := errorMessageArg.
startPosition := startPositionArg.
endPosition := endPositionArg.
!
parser
^ originator
!
startPosition
"return the value of the instance variable 'startPosition' (automatically generated)"
^ startPosition
! !
!Parser class methodsFor:'documentation'!
version
^ '$Header: /cvs/stx/stx/libcomp/Parser.st,v 1.368 2003-02-02 15:52:47 cg Exp $'
! !
Parser initialize!