logging doits.
"
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.
"
Scanner subclass:#Parser
instanceVariableNames:'classToCompileFor selfValue
contextToEvaluateIn
selector
methodArgs methodArgNames
methodVars methodVarNames
tree
currentBlock
usedInstVars usedClassVars usedVars
modifiedInstVars modifiedClassVars
localVarDefPosition
evalExitBlock
selfNode superNode
hasPrimitiveCode primitiveNr logged
warnedUndefVars
correctedSource'
classVariableNames:'PrevClass PrevInstVarNames
PrevClassVarNames PrevClassInstVarNames
LazyCompilation'
poolDictionaries:''
category:'System-Compiler'
!
Parser comment:'
COPYRIGHT (c) 1989 by Claus Gittinger
All Rights Reserved
$Header: /cvs/stx/stx/libcomp/Parser.st,v 1.14 1994-08-22 12:47:31 claus Exp $
'!
!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.
"
!
version
"
$Header: /cvs/stx/stx/libcomp/Parser.st,v 1.14 1994-08-22 12:47:31 claus Exp $
"
!
documentation
"
Parser is used for both parsing and evaluating smalltalk expressions;
it first builds a parseTree which is then interpreted (evaluate) or
compiled. Compilation is done in the subclass ByteCodeCompiler and/or
the (planned) MachineCodeCompiler.
methods of main interrest are:
Parser evaluateExpression:...
and:
Parser parseExpression:...
Parser parseMethod:...
there is protocol to parse complete methods, selector specs, body only etc.
Parser is also used to find the referenced/modified inst/classvars of
a method - this is done by sending parseXXX message to a parser and asking
the parser for referencedXVars or modifiedXVars (see SystemBrowser).
You can also use parsers for all kinds of other things (ChangesBrowser for
example analyzes the expressions in the changelist ...) by looking at the
parsers tree. (Although this is somewhat dangerous, since it exports the
compilers internals ... better style is to add specialized query methods here,
which will be done incrementally.)
One instance of Parser is created to parse one method or expression - i.e.
its not suggested to reuse parsers.
Instance variables:
classToCompileFor <Class> the class (or nil) we are compiling for
selfValue <any> value to use as self when interpreting
contextToEvaluateIn <Context> the context (or nil) when interpreting
selector <Symbol> the selector of the parsed method
(valid after parseMethodSpecification)
methodArgs internal
methodArgNames <Collection> the names of the arguments
(valid after parseMethodSpecification)
methodVars internal
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
primitiveNr <Integer> the parsed ST-80 type primitive number (or nil)
logged
warnedUndefVars <Set> set of all variables which the parser has
already output a warning (to avoid multiple
warnings about the same variable)
Class variables:
PrevClass <Class> class, of which properties are
cached in:
PrevInstVarNames <Collection> instance variablenames of cached class
PrevClassVarNames <Collection> class variablenames of cached class
PrevClassInstVarNames <Collection> class instance variablenames of cached class
LazyCompilation <Boolean> EXPERIMENTAL: lazy compilation
"
! !
!Parser class methodsFor:'evaluating expressions'!
evaluate:aStringOrStream
"return the result of evaluating an expression in aStringOrStream"
^ self
evaluate:aStringOrStream
in:nil
receiver:nil
notifying:nil
logged:false
ifFail:nil
"
Compiler evaluate:'1 + 2'
Compiler evaluate:'''hello world'' asSortedCollection displayString printNL'
Compiler evaluate:'''hello world'' asSortedCollection printNL'
"
!
evaluate:aStringOrStream ifFail:failBlock
"return the result of evaluating an expression in aStringOrStream.
In case of any syntax errors, return the value of failBlock."
^ self
evaluate:aStringOrStream
in:nil
receiver:nil
notifying:nil
logged:false
ifFail:failBlock
"
Compiler evaluate:'1 +' ifFail:['oops']
"
!
evaluate:aStringOrStream logged:logged
"return the result of evaluating an expression in aStringOrStream"
^ self
evaluate:aStringOrStream
in:nil
receiver:nil
notifying:nil
logged:logged
ifFail:nil
!
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
!
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
!
evaluate:aStringOrStream in:aContext receiver:anObject
notifying:requestor
ifFail:failBlock
^ self
evaluate:aStringOrStream
in:nil
receiver:anObject
notifying:requestor
logged:false
ifFail:nil
!
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."
"XXX: logging is not yet implemented"
|parser tree mustBackup loggedString chgStream value|
aStringOrStream isNil ifTrue:[^ nil].
aStringOrStream isStream ifTrue:[
parser := self for:aStringOrStream.
mustBackup := true
] ifFalse:[
loggedString := aStringOrStream.
parser := self for:(ReadStream on:aStringOrStream).
mustBackup := false
].
parser setSelf:anObject.
parser setContext:aContext.
parser notifying:requestor.
parser nextToken.
tree := parser parseMethodBodyOrNil.
"if reading from a stream, backup for next expression"
mustBackup ifTrue:[
parser backupPosition
].
(parser errorFlag or:[tree == #Error]) ifTrue:[
failBlock notNil ifTrue:[
^ failBlock value
].
^ #Error
].
tree notNil ifTrue:[
(logged
and:[loggedString notNil
and:[Smalltalk logDoits]]) ifTrue:[
chgStream := Class changesStream.
chgStream notNil ifTrue:[
chgStream nextChunkPut:loggedString.
chgStream cr.
chgStream close
].
].
parser evalExitBlock:[:value | parser release. ^ value].
value := tree evaluate
].
parser release.
^ value
! !
!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:'parsing'!
selectorInExpression:aString
"parse an expression - return the selector.
Used for SystemBrowsers implementors/senders query-box initial text.
Returns nil if unparsable."
|tree parser|
(aString isNil or:[aString isEmpty]) ifTrue:[^ nil].
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 ifTrue:[
tree expression isMessage ifTrue:[
tree := tree expression
]
].
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.
parser nextToken.
^ parser degeneratedKeywordExpressionForSelector
"
Parser selectorInExpression:'foo at:1 put:(5 * bar)'
Parser selectorInExpression:'(foo at:1) at:1'
Parser selectorInExpression:'1 + 4'
Parser selectorInExpression:'1 negated'
Parser selectorInExpression:'at:1 put:5'
Parser selectorInExpression:'a := foo at:1 put:5'
"
!
parseExpression:aString
"parse aString as an expression;
Return the parseTree (if ok), nil (for an empty string
or comment only) or #Error (syntactic error)."
^ self withSelf:nil
parseExpression:aString
notifying:nil
ignoreErrors:true "silence on Transcript"
ignoreWarnings:true
!
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
notifying:someOne
ignoreErrors:false
ignoreWarnings:false
!
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
notifying:someOne
ignoreErrors:ignore
ignoreWarnings:ignore
!
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."
|parser tree token|
aString isNil ifTrue:[^ nil].
parser := self for:(ReadStream on:aString).
parser setSelf:anObject.
parser notifying:someOne.
ignoreErrors ifTrue:[parser ignoreErrors].
ignoreWarnings ifTrue:[parser ignoreWarnings].
token := parser nextToken.
(token == $^) ifTrue:[
parser nextToken.
].
tree := parser expression.
(parser errorFlag or:[tree == #Error]) ifTrue:[^ #Error].
^ tree
!
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:noErrors ignoreWarnings:noWarnings
"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.
noErrors ifTrue:[
parser ignoreErrors
].
noWarnings ifTrue:[
parser ignoreWarnings
].
parser nextToken.
tree := parser parseMethodSpec.
(parser errorFlag or:[tree == #Error]) ifTrue:[^ #Error].
^ parser
!
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."
^ 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.
"
!
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"
|parser|
aString isNil ifTrue:[^ nil].
parser := self for:(ReadStream on:aString) in:aClass.
parser nextToken.
(parser parseMethodSpec == #Error) ifTrue:[^ nil].
(parser parseMethodBodyVarSpec == #Error) ifTrue:[^ nil].
parser errorFlag ifTrue:[^ nil].
^ parser
!
parseMethod:aString
"parse a method.
Return a parser (if ok), nil (empty) or #Error (syntax).
The parser can be queried for selector, receiver, args, locals,
used selectors etc."
^ 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.
"
!
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."
|parser tree|
aString isNil ifTrue:[^ nil].
parser := self for:(ReadStream on:aString) in:aClass.
tree := parser parseMethod.
(parser errorFlag or:[tree == #Error]) ifTrue:[^ nil].
^ parser
! !
!Parser class methodsFor:'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"
^ self methodSpecificationForSelector:aSelector
argNames:#('arg1' 'arg2' 'arg3' 'arg4' 'arg5' 'arg6'
'arg7' 'arg8' 'arg9' 'arg10' 'arg11' 'arg12'
'arg13' 'arg14' 'arg15')
"
Parser methodSpecificationForSelector:#foo:bar:
Parser methodSpecificationForSelector:#+
Parser methodSpecificationForSelector:#negated
"
!
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|
s := WriteStream on:String new.
nargs := aSelector nArgsIfSelector.
nargs == 0 ifTrue:[
s nextPutAll:aSelector
] ifFalse:[
parts := aSelector partsIfSelector.
1 to:nargs do:[:i |
s nextPutAll:(parts at:i); space;
nextPutAll:(argNames at:i); space.
]
].
^ s contents
"
Parser methodSpecificationForSelector:#foo:bar: argNames:#('one' 'two' 'three')
Parser methodSpecificationForSelector:#+ argNames:#('one')
Parser methodSpecificationForSelector:#negated
"
! !
!Parser class methodsFor:'controlling compilation'!
compileLazy:aBoolean
"turn on/off lazy compilation - return previous setting.
Actually this flag belongs into the ByteCodeCompiler subclass,
but it also controls the reporting of some errors here; therefore
its located here"
|oldLazy|
oldLazy := LazyCompilation.
LazyCompilation := aBoolean.
^ oldLazy
"Compiler compileLazy:false"
! !
!Parser methodsFor:'ST-80 compatibility'!
evaluate:aString in:aClass to:to notifying:aRequestor ifFail:failBlock
|parseTree value|
aString isNil ifTrue:[^ nil].
self initializeFor:(ReadStream on:aString).
self setClassToCompileFor:aClass.
selfValue := nil.
requestor := aRequestor.
self nextToken.
parseTree := self parseMethodBody.
(errorFlag or:[tree == #Error]) ifTrue:[^ #Error].
parseTree notNil ifTrue:[
self evalExitBlock:[:value | ^ failBlock value].
value := parseTree evaluate
].
self release.
^ value
! !
!Parser class methodsFor:'changes'!
update:aClass
"aClass has changed its definition - flush name caches if we have to"
(aClass == PrevClass) ifTrue:[
PrevClass := nil.
PrevInstVarNames := nil.
PrevClassVarNames := nil.
PrevClassInstVarNames := nil.
aClass removeDependent:Parser
]
!
flush
"unconditional flush name caches"
PrevClass notNil ifTrue:[
PrevClass removeDependent:Parser
].
PrevClass := nil.
PrevInstVarNames := nil.
PrevClassVarNames := nil.
PrevClassInstVarNames := nil.
"Parser flush"
! !
!Parser methodsFor:'setup'!
initialize
super initialize.
hasPrimitiveCode := false
!
initializeFor:aStringOrStream
super initializeFor:aStringOrStream.
hasPrimitiveCode := false
!
setClassToCompileFor:aClass
"set the class to be used for parsing/evaluating"
classToCompileFor := aClass.
(classToCompileFor ~~ PrevClass) ifTrue:[
PrevClass notNil ifTrue:[
Parser update:PrevClass
]
]
!
setSelf:anObject
"set the value to be used for self while evaluating"
selfValue := anObject.
classToCompileFor := anObject class.
(classToCompileFor ~~ PrevClass) ifTrue:[
PrevClass notNil ifTrue:[
Parser update:PrevClass
]
]
!
setContext:aContext
"set the context used while evaluating"
contextToEvaluateIn := aContext
! !
!Parser methodsFor:'accessing'!
tree
"return the parsetree"
^tree
!
tree:aTree
"private: set the tree - for internal use only"
tree := aTree
!
selector
"return the selector (valid after parsing spec)"
^ selector
!
correctedSource
^ correctedSource
!
numberOfMethodArgs
"return the number of methodargs (valid after parsing spec)"
^ methodArgs size
!
methodArgs
"return an array with methodarg names (valid after parsing spec)"
^ methodArgNames
!
numberOfMethodVars
"return the number of method variables (valid after parsing)"
^ methodVars size
!
methodVars
"return a collection with method variablenames (valid after parsing)"
^ methodVarNames
!
usedVars
"return a collection with variablenames refd by method (valid after parsing)"
^ usedVars
!
usedInstVars
"return a collection with instvariablenames refd by method (valid after parsing)"
^ usedInstVars
!
usedClassVars
"return a collection with classvariablenames refd by method (valid after parsing)"
^ usedClassVars
!
modifiedInstVars
"return a collection with instvariablenames modified by method (valid after parsing)"
^ modifiedInstVars
!
modifiedClassVars
"return a collection with classvariablenames modified by method (valid after parsing)"
^ modifiedClassVars
!
primitiveNumber
"return the ST-80 style primitiveNumber or nil (valid after parsing)"
^ primitiveNr
!
hasPrimitiveCode
"return true if there was any ST/X style primitive code (valid after parsing)"
^ hasPrimitiveCode
!
errorFlag
"return true if there where any errors (valid after parsing)"
^ errorFlag
!
evalExitBlock:aBlock
"when evaluating a return expression, this block is evaluated"
evalExitBlock := aBlock
!
release
methodArgs := methodVars := tree := selfNode := superNode := nil.
super release.
! !
!Parser methodsFor:'error handling'!
showErrorMessage:aMessage position:pos
"redefined since parser can give more detailed info about
the class & selector where the error occured."
ignoreErrors ifFalse:[
Smalltalk silentLoading == true ifFalse:[
Transcript show:(pos printString).
Transcript show:' '.
selector notNil ifTrue:[
Transcript show:aMessage.
classToCompileFor notNil ifTrue:[
Transcript showCr:(' in ' , classToCompileFor name , '>>' , selector)
] ifFalse:[
Transcript showCr:(' in ' , selector)
]
] ifFalse:[
classToCompileFor notNil ifTrue:[
Transcript showCr:aMessage , ' (' , classToCompileFor name , ')'
] ifFalse:[
Transcript showCr:aMessage
]
]
]
]
!
parseError:aMessage position:position to:endPos
"report a syntax error"
|m|
errorFlag := true.
m := ' Error:' , aMessage.
self notifyError:m position:position to:endPos.
exitBlock notNil ifTrue:[exitBlock value].
^ false
!
parseError:aMessage position:position
"report a syntax error"
^ self parseError:aMessage position:position to:nil
!
parseError:aMessage
"report a syntax error"
^ self parseError:aMessage position:tokenPosition to:nil
!
correctableError:message position:pos1 to:pos2
"report an error which can be corrected by compiler -
return true if correction is wanted"
|correctIt|
requestor isNil ifTrue:[
self showErrorMessage:message position:pos1.
correctIt := false
] ifFalse:[
correctIt := requestor correctableError:message position:pos1 to:pos2
].
correctIt ifFalse:[
exitBlock notNil ifTrue:[exitBlock value]
].
^ correctIt
!
undefError:aName position:pos1 to:pos2
"report an undefined variable error - return true, if it should be
corrected"
requestor isNil ifTrue:[
warnedUndefVars notNil ifTrue:[
(warnedUndefVars includes:aName) ifTrue:[
"already warned about this one"
^ false
].
].
self showErrorMessage:('Error: ' , aName , ' is undefined') position:pos1.
warnedUndefVars isNil ifTrue:[
warnedUndefVars := Set new.
].
warnedUndefVars add:aName.
^ false
].
^ self correctableError:('Error: ' , aName , ' is undefined') position:pos1 to:pos2
!
exitWith:something
"this is the longjump out of evaluation via a return expression"
evalExitBlock value:something
! !
!Parser methodsFor:'parsing'!
parseMethod
"parse a method.
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
].
^ parseTree
!
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
"
|var|
(tokenType == #Keyword) ifTrue:[
selector := ''.
[tokenType == #Keyword] whileTrue:[
selector := selector , tokenName.
self nextToken.
(tokenType ~~ #Identifier) ifTrue:[^ #Error].
var := Variable name:tokenName.
methodArgs isNil ifTrue:[
methodArgs := Array with:var.
methodArgNames := Array with:tokenName
] ifFalse:[
(methodArgNames includes:tokenName) ifTrue:[
self syntaxError:'redefinition of ''' , tokenName , ''' in argument list.'
position:tokenPosition
to:(tokenPosition + tokenName size - 1)
].
methodArgs := methodArgs copyWith:var.
methodArgNames := methodArgNames copyWith:tokenName
].
self nextToken
].
selector := selector asSymbol.
^ self
].
(tokenType == #Identifier) ifTrue:[
selector := tokenName asSymbol.
self nextToken.
^ self
].
(tokenType == #BinaryOperator) ifTrue:[
selector := tokenName asSymbol.
self nextToken.
(tokenType ~~ #Identifier) ifTrue:[^ #Error].
var := Variable name:tokenName.
methodArgs isNil ifTrue:[
methodArgs := Array with:var.
methodArgNames := Array with:tokenName
] ifFalse:[
methodArgs := methodArgs copyWith:var.
methodArgNames := methodArgNames copyWith:tokenName
].
self nextToken.
^ self
].
^ #Error
!
parseMethodBody
"parse a methods body (locals & statements).
No more tokens may follow.
Return a node-tree, or #Error
methodBody ::= '<' st80Primitive '>' #EOF
| '<' st80Primitive '>' methodBodyVarSpec statementList #EOF
"
|stats|
stats := self parseMethodBodyOrNil.
(stats == #Error) ifFalse:[
(tokenType ~~ #EOF) ifTrue:[
"/ just for the nicer error message
(#(Self Nil True False Super) includes:tokenType) ifTrue:[
self parseError:tokenName , ' unexpected (missing ''.'' before ' , tokenName , ' ?)'
position:tokenPosition to:(tokenPosition + tokenName size - 1)
] ifFalse:[
self parseError:(tokenType printString , ' unexpected').
].
^#Error
]
].
^ stats
!
parseMethodBodyOrNil
"parse a methods body (locals & statements);
return a node-tree, nil or #Error.
empty (or comment only) input is accepted and returns nil.
methodBodyOrNil ::= '<' st80Primitive '>'
| '<' st80Primitive '>' methodBodyVarSpec statementList
| <empty>
"
|stats|
((tokenType == #BinaryOperator) and:[tokenName = '<']) ifTrue:[
"an ST-80 primitive - parsed but ignored"
self nextToken.
primitiveNr := self parseST80Primitive.
(primitiveNr == #Error) ifTrue:[^ #Error].
self warning:'ST-80 primitives not supported - ignored'
].
(self parseMethodBodyVarSpec == #Error) ifTrue:[^ #Error].
(tokenType ~~ #EOF) ifTrue:[
stats := self statementList
].
^ stats
!
parseMethodBodyVarSpec
"parse a methods local variable specification.
Leave spec of locals in methodLocals as a side effect.
Return #Error or nil.
methodBodyVarSpec ::= '|' { IDENTIFIER } '|'
| <empty>
"
|var|
(tokenType == $|) ifTrue:[
"memorize position for declaration in correction"
localVarDefPosition := tokenPosition.
self nextToken.
[tokenType == #Identifier] whileTrue:[
var := Variable name:tokenName.
methodVars isNil ifTrue:[
methodVars := Array with:var.
methodVarNames := Array with:tokenName
] ifFalse:[
methodVars := methodVars copyWith:var.
methodVarNames := methodVarNames copyWith:tokenName
].
self nextToken
].
(tokenType ~~ $|) ifTrue:[
self syntaxError:'error in local var specification; | expected.'.
^ #Error
].
self nextToken
].
^ nil
!
parseST80Primitive
"parse an ST-80 type primitive as '< primitive: nr >';
return primitive number or #Error.
st80Primitive ::= 'primitive:' INTEGER
"
|primNumber|
((tokenType == #Keyword) and:[tokenName = 'primitive:']) ifFalse:[
self parseError:'bad primitive definition (primitive: expected)'.
^ #Error
].
self nextToken.
(tokenType == #Integer) ifFalse:[
self parseError:'primitive number expected'.
^ #Error
].
primNumber := tokenValue.
self nextToken.
((tokenType == #BinaryOperator) and:[tokenName = '>']) ifFalse:[
self parseError:'bad primitive definition (> expected)'.
^ #Error
].
self nextToken.
^ primNumber
!
statementList
"parse a statementlist; return a node-tree, nil or #Error.
Statements must be separated by periods."
|thisStatement prevStatement firstStatement correctIt periodPos|
thisStatement := self statement.
(thisStatement == #Error) ifTrue:[^ #Error].
firstStatement := thisStatement.
[tokenType == $.] whileTrue:[
periodPos := tokenPosition.
self nextToken.
(tokenType == $]) ifTrue:[
currentBlock isNil ifTrue:[
self parseError:'block nesting error'.
errorFlag := true
"
*** I had a warning here (since it was not defined
*** in the blue-book; but PD-code contains a lot of
*** code with periods at the end so that the warnings
*** became annoying
] ifFalse:[
self warning:'period after last statement' position:periodPos
"
].
^ firstStatement
].
(tokenType == #EOF) ifTrue:[
currentBlock notNil ifTrue:[
self parseError:'block nesting error (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 isKindOf:ReturnNode) ifTrue:[
self warning:'statements after return' position:tokenPosition
].
"
periodPos := tokenPosition.
self nextToken.
"
((tokenType == $]) or:[tokenType == #EOF]) ifTrue:[
(currentBlock isNil and:[tokenType == $]]) ifTrue:[
self parseError:'block nesting error'.
errorFlag := true
] ifFalse:[
correctIt := self correctableError:'period after last statement in block'
position:periodPos to:(periodPos + 1).
correctIt ifTrue:[
(self correctByDeleting == #Error) ifTrue:[
errorFlag := true
]
]
].
^ firstStatement
].
thisStatement := self statement.
(thisStatement == #Error) ifTrue:[^ #Error].
prevStatement nextStatement:thisStatement
].
^ firstStatement
!
statement
"parse a statement; return a node-tree or #Error.
statement ::= '^' expression
| PRIMITIVECODE
| expression
"
|expr node|
(tokenType == $^) ifTrue:[
self nextToken.
expr := self expression.
(expr == #Error) ifTrue:[^ #Error].
node := ReturnNode expression:expr.
node home:self blockHome:currentBlock.
^ node
].
(tokenType == #Primitive) ifTrue:[
"
self parseError:'cannot compile primitives (yet)'.
"
self nextToken.
hasPrimitiveCode := true.
^ PrimitiveNode code:''
].
(tokenType == #EOF) ifTrue:[
self syntaxError:'period after last statement'.
^ #Error
].
expr := self expression.
(expr == #Error) ifTrue:[^ #Error].
"
classToCompileFor notNil ifTrue:[
currentBlock isNil ifTrue:[
(expr isKindOf:PrimaryNode) ifTrue:[
self warning:'useless computation - missing ^ ?'
]
]
].
"
^ StatementNode expression:expr
!
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|
pos := tokenPosition.
receiver := self keywordExpression.
(receiver == #Error) ifTrue:[^ #Error].
(tokenType == $;) ifTrue:[
[tokenType == $;] whileTrue:[
receiver isMessage ifFalse:[
self syntaxError:'left side of cascade must be a message expression'
position:pos to:tokenPosition
].
self nextToken.
(tokenType == #Identifier) ifTrue:[
sel := self selectorCheck:tokenName for:receiver position:tokenPosition to:(tokenPosition + tokenName size - 1).
receiver := CascadeNode receiver:receiver selector:sel.
receiver lineNumber:tokenLineNr.
self nextToken.
] ifFalse:[
(tokenType == #BinaryOperator) ifTrue:[
sel := self selectorCheck:tokenName for:receiver position:tokenPosition to:(tokenPosition + tokenName size - 1).
lno := tokenLineNr.
self nextToken.
arg := self unaryExpression.
(arg == #Error) ifTrue:[^ #Error].
receiver := CascadeNode receiver:receiver selector:sel arg:arg.
receiver lineNumber:lno.
] ifFalse:[
(tokenType == #Keyword) ifTrue:[
pos := tokenPosition.
lno := tokenLineNr.
sel := tokenName.
self nextToken.
arg := self binaryExpression.
(arg == #Error) ifTrue:[^ #Error].
args := Array with:arg.
[tokenType == #Keyword] whileTrue:[
sel := sel , tokenName.
self nextToken.
arg := self binaryExpression.
(arg == #Error) ifTrue:[^ #Error].
args := args copyWith:arg.
pos2 := tokenPosition
].
sel := self selectorCheck:sel for:receiver position:pos to:pos2.
receiver := CascadeNode receiver:receiver selector:sel args:args.
receiver lineNumber:lno.
] ifFalse:[
(tokenType == #Error) ifTrue:[^ #Error].
self syntaxError:('invalid cascade; ' , tokenType printString , ' unexpected')
position:tokenPosition to:source position - 1.
^ #Error
]
]
]
].
"obscure (uspecified ?) 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
]
].
^ receiver
!
keywordExpression
"parse a keyword-expression; return a node-tree, nil or #Error"
|receiver sel arg args pos1 pos2 try lno note|
receiver := self binaryExpression.
(receiver == #Error) ifTrue:[^ #Error].
(tokenType == #Keyword) ifTrue:[
pos1 := tokenPosition.
sel := tokenName.
lno := tokenLineNr.
self nextToken.
arg := self binaryExpression.
(arg == #Error) ifTrue:[^ #Error].
args := Array with:arg.
[tokenType == #Keyword] whileTrue:[
sel := sel , tokenName.
self nextToken.
arg := self binaryExpression.
(arg == #Error) ifTrue:[^ #Error].
args := args copyWith:arg.
pos2 := tokenPosition
].
sel := self selectorCheck:sel for:receiver position:pos1 to:pos2.
try := MessageNode receiver:receiver selector:sel args:args.
(try isMemberOf:String) ifTrue:[
self parseError:try position:pos1 to:pos2.
receiver := MessageNode receiver:receiver selector:sel args:args fold:false.
note := receiver plausibilityCheck.
note notNil ifTrue:[
self warning:note position:pos1 to:pos2
].
] ifFalse:[
receiver := try
].
receiver lineNumber:lno
].
^ receiver
!
degeneratedKeywordExpressionForSelector
"parse a keyword-expression without receiver - for the selector
only. return the selector or nil"
|sel arg|
(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
].
^ nil
!
binaryExpression
"parse a binary-expression; return a node-tree, nil or #Error"
|receiver arg sel pos try lno note|
receiver := self unaryExpression.
(receiver == #Error) ifTrue:[^ #Error].
"special kludge: since Scanner cannot know if -digit is a binary
expression or a negative constant, handle cases here"
[(tokenType == #BinaryOperator) or:[(tokenType == $|)
or:[(tokenType == #Integer) and:[tokenValue < 0]]]] whileTrue:[
pos := tokenPosition.
lno := tokenLineNr.
"kludge here: bar and minus are not scanned as binop "
(tokenType == $|) ifTrue:[
sel := '|'.
self nextToken
] ifFalse:[
(tokenType == #BinaryOperator) ifTrue:[
sel := self selectorCheck:tokenName for:receiver position:tokenPosition to:(tokenPosition + tokenName size - 1).
self nextToken
] ifFalse:[
sel := '-'.
tokenValue := tokenValue negated
]
].
arg := self unaryExpression.
(arg == #Error) ifTrue:[^ #Error].
try := BinaryNode receiver:receiver selector:sel arg:arg.
(try isMemberOf:String) ifTrue:[
self parseError:try position:pos to:tokenPosition.
receiver := BinaryNode receiver:receiver selector:sel arg:arg fold:false.
note := receiver plausibilityCheck.
note notNil ifTrue:[
self warning:note position:pos to:tokenPosition
].
] ifFalse:[
receiver := try
].
receiver lineNumber:lno.
].
^ receiver
!
unaryExpression
"parse a unary-expression; return a node-tree, nil or #Error"
|receiver sel pos pos2 try|
receiver := self primary.
(receiver == #Error) ifTrue:[^ #Error].
[tokenType == #Identifier] whileTrue:[
pos := tokenPosition.
pos2 := pos + tokenName size - 1.
sel := self selectorCheck:tokenName for:receiver position:pos to:pos2.
try := UnaryNode receiver:receiver selector:sel.
(try isMemberOf:String) ifTrue:[
self warning:try position:pos to:pos2.
receiver := UnaryNode receiver:receiver selector:sel fold:false.
] ifFalse:[
receiver := try
].
receiver lineNumber:tokenLineNr.
self nextToken.
].
^ receiver
!
primary
"parse a primary-expression; return a node-tree, nil or #Error"
|val var expr pos name|
pos := tokenPosition.
(tokenType == #Identifier) ifTrue:[
var := self variable.
(var == #Error) ifTrue:[
errorFlag := true
].
self nextToken.
(tokenType == $_) ifFalse:[
^ var
].
(var ~~ #Error) ifTrue:[
(var type == #MethodArg) ifTrue:[
self parseError:'assignment to method argument' position:pos to:tokenPosition.
errorFlag := true
].
(var type == #BlockArg) ifTrue:[
self parseError:'assignment to block argument' position:pos to:tokenPosition.
errorFlag := true
].
(var type == #InstanceVariable) ifTrue:[
modifiedInstVars isNil ifTrue:[
modifiedInstVars := OrderedCollection new
].
name := PrevInstVarNames at:(var index).
(modifiedInstVars includes:name) ifFalse:[
modifiedInstVars add:name
]
] ifFalse:[
(var type == #ClassVariable) ifTrue:[
modifiedClassVars isNil ifTrue:[
modifiedClassVars := OrderedCollection new
].
name := var name.
name := name copyFrom:((name indexOf:$:) + 1).
(modifiedClassVars includes:name) ifFalse:[
modifiedClassVars add:name
]
]
]
].
self nextToken.
expr := self expression.
(errorFlag or:[expr == #Error]) ifTrue:[^ #Error].
^ AssignmentNode variable:var expression:expr
].
((tokenType == #Integer) or:
[(tokenType == #Character) or:
[tokenType == #Float]]) ifTrue:[
val := ConstantNode type:tokenType value:tokenValue.
self nextToken.
(tokenType == $_) ifTrue:[
self parseError:'assignment to a constant' position:pos to:tokenPosition.
^ #Error
].
^ val
].
(tokenType == #Self) ifTrue:[
self nextToken.
(tokenType == $_) ifTrue:[
self parseError:'assignment to self' position:pos to:tokenPosition.
^ #Error
].
selfNode isNil ifTrue:[
selfNode := SelfNode value:selfValue
].
^ selfNode
].
(tokenType == #String) ifTrue:[
val := ConstantNode type:tokenType value:tokenValue.
self nextToken.
(tokenType == $_) ifTrue:[
self parseError:'assignment to a constant' position:pos to:tokenPosition.
^ #Error
].
^ val
].
(tokenType == #Symbol) ifTrue:[
val := ConstantNode type:tokenType value:tokenValue.
self nextToken.
(tokenType == $_) ifTrue:[
self parseError:'assignment to a constant' position:pos to:tokenPosition.
^ #Error
].
^ val
].
(tokenType == #Nil) ifTrue:[
self nextToken.
(tokenType == $_) ifTrue:[
self parseError:'assignment to nil' position:pos to:tokenPosition.
^ #Error
].
^ ConstantNode type:#Nil value:nil
].
(tokenType == #True) ifTrue:[
self nextToken.
(tokenType == $_) ifTrue:[
self parseError:'assignment to true' position:pos to:tokenPosition.
^ #Error
].
^ ConstantNode type:#True value:true
].
(tokenType == #False) ifTrue:[
self nextToken.
(tokenType == $_) ifTrue:[
self parseError:'assignment to false' position:pos to:tokenPosition.
^ #Error
].
^ ConstantNode type:#False value:false
].
(tokenType == #Super) ifTrue:[
self nextToken.
(tokenType == $_) ifTrue:[
self parseError:'assignment to super' position:pos to:tokenPosition.
^ #Error
].
superNode isNil ifTrue:[
superNode := SuperNode value:selfValue inClass:classToCompileFor
].
^ superNode
].
(tokenType == #ThisContext) ifTrue:[
self nextToken.
(tokenType == $_) ifTrue:[
self parseError:'assignment to thisContext' position:pos to:tokenPosition.
^ #Error
].
^ VariableNode type:#ThisContext
].
(tokenType == #HashLeftParen) ifTrue:[
self nextToken.
val := self array.
self nextToken.
^ ConstantNode type:#Array value:val
].
(tokenType == #HashLeftBrack) ifTrue:[
self nextToken.
val := self byteArray.
self nextToken.
^ ConstantNode type:#Array value:val
].
(tokenType == $() ifTrue:[
self nextToken.
val := self expression.
(val == #Error) ifTrue:[^ #Error].
(tokenType ~~ $) ) ifTrue:[
(tokenType isMemberOf:Character) ifTrue:[
self syntaxError:'missing '')'' (i.e. ''' , tokenType asString , ''' unexpected)' withCRs position:pos to:tokenPosition.
] ifFalse:[
self syntaxError:'missing '')''' position:pos to:tokenPosition.
].
^ #Error
].
self nextToken.
val parenthized:true.
^ val
].
(tokenType == $[ ) ifTrue:[
val := self block.
self nextToken.
^ val
].
(tokenType == #Error) ifTrue:[^ #Error].
(tokenType isKindOf:Character) ifTrue:[
self syntaxError:('error in primary; '
, tokenType printString ,
' unexpected') position:tokenPosition to:tokenPosition
] ifFalse:[
(#(BinaryOperator Keyword) includes:tokenType) ifTrue:[
self syntaxError:('error in primary; '
, tokenType printString , '(' , tokenName , ') ' ,
' unexpected')
] ifFalse:[
self syntaxError:('error in primary; '
, tokenType printString ,
' unexpected')
]
].
^ #Error
!
variableOrError
"parse a variable; return a node-tree, nil or #Error"
^ self variableOrError:tokenName
!
variableOrError:varName
"parse a variable; return a node-tree, nil or #Error"
|var instIndex aClass searchBlock args vars
tokenSymbol className|
"is it a block-arg or block-var ?"
searchBlock := currentBlock.
[searchBlock notNil] whileTrue:[
args := searchBlock arguments.
args notNil ifTrue:[
instIndex := args findFirst:[:aBlockArg | aBlockArg name = varName].
instIndex ~~ 0 ifTrue:[
^ VariableNode type:#BlockArg
name:varName
token:(args at:instIndex)
index:instIndex
block:searchBlock
].
].
vars := searchBlock variables.
vars notNil ifTrue:[
instIndex := vars findFirst:[:aBlockVar | aBlockVar name = varName].
instIndex ~~ 0 ifTrue:[
^ VariableNode type:#BlockVariable
name:varName
token:(vars at:instIndex)
index:instIndex
block:searchBlock
].
].
searchBlock := searchBlock home
].
"is it a method-variable ?"
methodVars notNil ifTrue:[
instIndex := methodVarNames indexOf:varName.
instIndex ~~ 0 ifTrue:[
var := methodVars at:instIndex.
var used:true.
^ VariableNode type:#MethodVariable
name:varName
token:var
index:instIndex
]
].
"is it a method-argument ?"
methodArgs notNil ifTrue:[
instIndex := methodArgNames indexOf:varName.
instIndex ~~ 0 ifTrue:[
^ VariableNode type:#MethodArg
name:varName
token:(methodArgs at:instIndex)
index:instIndex
]
].
"is it an instance-variable ?"
classToCompileFor notNil ifTrue:[
"caching allInstVarNames for next compilation saves time ..."
(PrevInstVarNames isNil or:[PrevClass ~~ classToCompileFor]) ifTrue:[
PrevClass notNil ifTrue:[
PrevClass removeDependent:Parser
].
PrevClass := classToCompileFor.
PrevInstVarNames := classToCompileFor allInstVarNames.
PrevClassInstVarNames := nil.
PrevClassVarNames := nil.
PrevClass addDependent:Parser
].
instIndex := PrevInstVarNames indexOf:varName startingAt:1.
instIndex ~~ 0 ifTrue:[
usedInstVars isNil ifTrue:[
usedInstVars := OrderedCollection with:varName
] ifFalse:[
(usedInstVars includes:varName) ifFalse:[
usedInstVars add:varName
]
].
usedVars isNil ifTrue:[
usedVars := OrderedCollection with:varName
] ifFalse:[
(usedVars includes:varName) ifFalse:[
usedVars add:varName
]
].
^ VariableNode type:#InstanceVariable
name:varName
index:instIndex
selfValue:selfValue
]
].
"is it a class-instance-variable ?"
classToCompileFor notNil ifTrue:[
PrevClassInstVarNames isNil ifTrue:[
PrevClassInstVarNames := classToCompileFor class allInstVarNames
].
instIndex := PrevClassInstVarNames indexOf:varName startingAt:1.
instIndex ~~ 0 ifTrue:[
aClass := self inWhichClassIsClassInstVar:varName.
aClass notNil ifTrue:[
usedVars isNil ifTrue:[
usedVars := OrderedCollection with:varName
] ifFalse:[
(usedVars includes:varName) ifFalse:[
usedVars add:varName
]
].
^ VariableNode type:#ClassInstanceVariable
name:varName
index:instIndex
selfClass:aClass
]
]
].
"is it a class-variable ?"
classToCompileFor notNil ifTrue:[
PrevClassVarNames isNil ifTrue:[
aClass := classToCompileFor.
classToCompileFor isMeta ifTrue:[
className := aClass name.
className := className copyTo:(className size - 5).
aClass := Smalltalk at:(className asSymbol).
aClass isNil ifTrue:[
aClass := classToCompileFor
]
].
PrevClassVarNames := aClass allClassVarNames
].
instIndex := PrevClassVarNames indexOf:varName startingAt:1.
instIndex ~~ 0 ifTrue:[
aClass := self inWhichClassIsClassVar:varName.
aClass notNil ifTrue:[
usedClassVars isNil ifTrue:[
usedClassVars := OrderedCollection with:varName
] ifFalse:[
(usedClassVars includes:varName) ifFalse:[
usedClassVars add:varName
].
].
usedVars isNil ifTrue:[
usedVars := OrderedCollection with:varName
] ifFalse:[
(usedVars includes:varName) ifFalse:[
usedVars add:varName
].
].
^ VariableNode type:#ClassVariable
name:(aClass name , ':' , varName) asSymbol
]
]
].
"is it a global-variable ?"
tokenSymbol := varName asSymbol.
(Smalltalk includesKey:tokenSymbol) ifTrue:[
usedVars isNil ifTrue:[
usedVars := OrderedCollection with:varName
] ifFalse:[
(usedVars includes:varName) ifFalse:[
usedVars add:varName
]
].
^ VariableNode type:#GlobalVariable name:tokenSymbol
].
^ #Error
!
variable
"parse a variable; if undefined, notify error and correct if user wants to"
|v|
v := self variableOrError.
(v == #Error) ifFalse:[^ v].
v := self correctVariable.
(v == #Error) ifFalse:[^ v].
^ VariableNode type:#GlobalVariable name:tokenName asSymbol
!
inWhichClassIsClassVar:aString
"search class-chain for the classvariable named aString
- return the class or nil if not found"
|aClass className baseClass|
aClass := classToCompileFor.
aClass isMeta ifTrue:[
className := aClass name.
className := className copyTo:(className size - 5).
baseClass := Smalltalk at:(className asSymbol).
baseClass notNil ifTrue:[
aClass := baseClass
]
].
[aClass notNil] whileTrue:[
(aClass classVarNames includes:aString) ifTrue:[ ^ aClass].
aClass := aClass superclass
].
^ nil
!
inWhichClassIsClassInstVar:aString
"search class-chain for the class-instance variable named aString
- return the class or nil if not found"
|aClass|
aClass := classToCompileFor.
[aClass notNil] whileTrue:[
(aClass class instVarNames includes:aString) ifTrue:[ ^ aClass].
aClass := aClass superclass
].
^ nil
!
block
"parse a block; return a node-tree, nil or #Error"
|node args argNames arg pos lno|
lno := tokenLineNr.
self nextToken.
(tokenType == $: ) ifTrue:[
[tokenType == $:] whileTrue:[
pos := tokenPosition.
self nextToken.
(tokenType == #Identifier) ifFalse:[
self syntaxError:'Identifier expected in block-arg declaration'
position:pos to:tokenPosition-1.
^ #Error
].
arg := Variable name:tokenName.
args isNil ifTrue:[
args := Array with:arg.
argNames := Array with:tokenName.
] ifFalse:[
(argNames includes:tokenName) ifTrue:[
self syntaxError:'redefinition of ''' , tokenName , ''' in argument list.'
position:tokenPosition
to:(tokenPosition + tokenName size - 1)
].
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
!
blockBody:args
"parse a blocks body; return a node-tree, nil or #Error"
|stats node var vars pos lno|
lno := tokenLineNr.
(tokenType == $| ) ifTrue:[
self nextToken.
pos := tokenPosition.
[tokenType == $|] whileFalse:[
(tokenType == #Identifier) ifFalse:[
self syntaxError:'Identifier expected in block-var declaration' position:pos.
^ #Error
].
var := Variable name:tokenName.
vars isNil ifTrue:[
vars := Array with:var
] ifFalse:[
vars := vars copyWith:var
].
self nextToken
].
self nextToken
].
node := BlockNode arguments:args home:currentBlock variables:vars.
node lineNumber:lno.
currentBlock := node.
stats := self blockStatementList.
node statements:stats.
currentBlock := node home.
(stats == #Error) ifTrue:[^ #Error].
^ node
!
blockStatementList
"parse a blocks statementlist; return a node-tree, nil or #Error"
|thisStatement prevStatement firstStatement|
(tokenType == $] ) ifTrue:[^ nil].
thisStatement := self statement.
(thisStatement == #Error) ifTrue:[^ #Error].
firstStatement := thisStatement.
[tokenType == $] ] whileFalse:[
(tokenType == $.) ifFalse:[
(tokenType == #EOF) ifTrue:[
self syntaxError:'missing '']'' in block'
] ifFalse:[
self syntaxError:'missing ''.'' in block'
].
^ #Error
] ifTrue:[
prevStatement := thisStatement.
self nextToken.
tokenType == $] ifTrue:[
"
*** I had a warning here (since it was not defined
*** in the blue-book; but PD-code contains a lot of
*** code with periods at the end so that the warnings
*** became annoying
self warning:'period after last statement in block'.
"
^ firstStatement
].
thisStatement := self statement.
(thisStatement == #Error) ifTrue:[^ #Error].
prevStatement nextStatement:thisStatement
]
].
^ firstStatement
!
array
|arr elem pos1|
pos1 := tokenPosition.
arr := 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
].
arr add:elem.
self nextToken
].
^ Array withAll:arr
!
byteArray
"started with ST-80 R4 - allow byteArray constants as #[ ... ]"
|arr elem pos1 pos2|
pos1 := tokenPosition.
arr := OrderedCollection new:50.
[tokenType ~~ $] ] whileTrue:[
pos2 := tokenPosition.
elem := self arrayConstant.
(elem == #Error) ifTrue:[
(tokenType == #EOF) ifTrue:[
self syntaxError:'unterminated bytearray-constant; '']'' expected'
position:pos1 to:tokenPosition
].
^ #Error
].
((elem isMemberOf:SmallInteger) and:
[(elem >= 0) and:[elem <= 255]]) ifTrue:[
arr add:elem
] ifFalse:[
self parseError:'invalid ByteArray element' position:pos2 to:tokenPosition - 1
].
self nextToken
].
^ ByteArray withAll:arr
!
arrayConstant
(tokenType == #String) ifTrue:[
^ tokenValue
].
(tokenType == #Nil) ifTrue:[
^ nil
].
(tokenType == #Integer) ifTrue:[
^ tokenValue
].
(tokenType == #Character) ifTrue:[
^ tokenValue
].
(tokenType == #Float) ifTrue:[
^ tokenValue
].
(tokenType == #True) ifTrue:[
^ true
].
(tokenType == #False) ifTrue:[
^ false
].
(tokenType == #Error) ifTrue:[
^ #Error
].
(tokenType == #BinaryOperator) ifTrue:[
^ tokenName asSymbol
].
(tokenType == #Keyword) ifTrue:[
^ tokenName asSymbol
].
(tokenType == #Identifier) ifTrue:[
^ tokenName asSymbol
].
(tokenType == $() ifTrue:[
self nextToken.
^ self array
].
(tokenType == $[) ifTrue:[
self nextToken.
^ self byteArray
].
(tokenType == #Symbol) ifTrue:[
"
self warning:'no # for symbols within array-constants'.
"
^ tokenValue
].
(tokenType == #HashLeftParen) ifTrue:[
"
self warning:'no # for arrays within array-constants'.
"
self nextToken.
^ self array
].
(tokenType == #HashLeftBrack) ifTrue:[
"
self warning:'no # for arrays within array-constants'.
"
self nextToken.
^ self byteArray
].
(tokenType == #EOF) ifTrue:[
"just for the better error-hilight; let caller handle error"
^ #Error
].
self syntaxError:('error in array-constant; '
, tokenType printString
, ' unexpected').
^ #Error
! !
!Parser methodsFor:'error correction'!
correctByDeleting
"correct (by deleting token) if user wants to;
return #Error if there was no correction;
nil if there was one."
(self confirm:'confirm deleting') ifFalse:[^ #Error].
"
tell requestor (i.e. CodeView) about the change
this will update what the requestor shows.
"
requestor deleteSelection.
"
get the updated source-string
which is needed, when we eventually install the new method
"
correctedSource := requestor currentSourceCode.
^ nil
!
findBestVariablesFor:aString
"collect known variables with their spelling distances to aString;
return the 10 best suggestions"
|names dists searchBlock args vars globalVarName aClass className baseClass n|
names := OrderedCollection new.
dists := OrderedCollection new.
"block arguments"
searchBlock := currentBlock.
[searchBlock notNil] whileTrue:[
args := searchBlock arguments.
args notNil ifTrue:[
args do:[:aBlockArg |
names add:(aBlockArg name).
dists add:(aString spellAgainst: "levenshteinTo:"(aBlockArg name))
]
].
vars := searchBlock variables.
vars notNil ifTrue:[
vars do:[:aBlockVar |
names add:(aBlockVar name).
dists add:(aString spellAgainst: "levenshteinTo:"(aBlockVar name))
]
].
searchBlock := searchBlock home
].
"method-variables"
methodVars notNil ifTrue:[
methodVarNames do:[:methodVarName |
names add:methodVarName.
dists add:(aString spellAgainst: "levenshteinTo:"methodVarName)
]
].
"method-arguments"
methodArgs notNil ifTrue:[
methodArgNames do:[:methodArgName |
names add:methodArgName.
dists add:(aString spellAgainst: "levenshteinTo:"methodArgName)
]
].
"instance-variables"
classToCompileFor notNil ifTrue:[
PrevInstVarNames do:[:instVarName |
names add:instVarName.
dists add:(aString spellAgainst: "levenshteinTo:"instVarName)
]
].
"class-variables"
classToCompileFor notNil ifTrue:[
PrevClassVarNames do:[:classVarName |
names add:classVarName.
dists add:(aString spellAgainst: "levenshteinTo:"classVarName)
].
false ifTrue:[
aClass := classToCompileFor.
aClass isMeta ifTrue:[
className := aClass name.
className := className copyTo:(className size - 5).
baseClass := Smalltalk at:(className asSymbol).
baseClass notNil ifTrue:[
aClass := baseClass
]
].
[aClass notNil] whileTrue:[
(aClass classVarNames) do:[:classVarName |
names add:classVarName.
dists add:(aString spellAgainst: "levenshteinTo:"classVarName)
].
aClass := aClass superclass
]
].
].
"globals"
Smalltalk allKeysDo:[:aKey |
globalVarName := aKey asString.
"only compare strings where length is about right"
((globalVarName size - aString size) abs < 3) ifTrue:[
names add:globalVarName.
dists add:(aString spellAgainst: "levenshteinTo:"globalVarName)
]
].
"misc"
#('self' 'super' 'nil' 'thisContext') do:[:name |
names add:name.
dists add:(aString spellAgainst: "levenshteinTo:"name)
].
(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 do:[:methodVarName |
names add:methodVarName.
].
].
methodArgs notNil ifTrue:[
names add:'---- method arguments ----'.
methodArgNames do:[:methodArgName |
names add:methodArgName.
]
].
names add:'---- instance variables ----'.
PrevInstVarNames do:[:instVarName |
(names includes:instVarName) ifFalse:[
names add:instVarName.
]
]
].
^ names
].
^ nil
!
correctVariable
"notify error and correct if user wants to;
return #Error if there was no correction
or a ParseNode as returned by variable"
|correctIt varName suggestedNames newName pos1 pos2|
pos1 := tokenPosition.
varName := tokenName.
pos2 := pos1 + varName size - 1.
"OLD:
(varName at:1) isLowercase ifTrue:[
correctIt := self undefError:varName position:pos1 to:pos2.
correctIt ifFalse:[^ #Error]
] ifFalse:[
correctIt := self warning:(varName , ' is undefined') position:pos1 to:pos2.
correctIt ifFalse:[
^ VariableNode type:#GlobalVariable name:(varName asSymbol)
]
].
"
correctIt := self undefError:varName position:pos1 to:pos2.
correctIt ifFalse:[
(varName at:1) isLowercase ifTrue:[
^ #Error
] ifFalse:[
^ VariableNode type:#GlobalVariable name:(varName asSymbol)
]
].
suggestedNames := self findBestVariablesFor:varName.
suggestedNames notNil ifTrue:[
newName := self askForCorrection:'correct variable to: ' fromList:suggestedNames.
newName isNil ifTrue:[^ #Error].
"
newName := suggestedNames at:1.
(self confirm:('confirm correction to: ' , newName)) ifFalse:[^ #Error]
"
] ifFalse:[
self notify:'no good correction found'.
^ #Error
].
"
tell requestor (i.e. CodeView) about the change
this will update what the requestor shows.
"
requestor replaceSelectionBy:newName.
"
get the updated source-string
which is needed, when we eventually install the new method
"
correctedSource := requestor currentSourceCode.
"redo parse with new value"
tokenName := newName.
^ self variableOrError
!
askForCorrection:aString fromList:aList
"launch a selection box, which allows user to enter correction.
return newString or nil (for abort)"
|box|
ListSelectionBox isNil ifTrue:[
^ self confirm:aString
].
box := ListSelectionBox new.
box title:aString.
box initialText:(aList at:1).
box list:aList.
box okText:'correct'.
box action:[:aString | ^ aString].
box showAtPointer.
^ nil
!
findBestSelectorsFor:aString
"collect known selectors with their spelling distances to aString;
return the 10 best suggestions"
|info n|
info := SortedCollection new.
info sortBlock:[:a :b | a value > b value].
n := 0.
Symbol allInstancesDo:[:sym |
|dist|
dist := aString spellAgainst:sym.
dist > 20 ifTrue:[
info add:(sym -> dist).
n := n + 1.
n > 10 ifTrue:[
info removeLast.
]
]
].
^ info asOrderedCollection collect:[:a | a key]
"Time millisecondsToRun:[Parser new findBestSelectorsFor:'foo']"
"Parser new findBestSelectorsFor:'findBestSel'"
"Parser new findBestSelectorsFor:'fildBestSelectrFr'"
!
correctSelector:aSelectorString message:msg position:pos1 to:pos2
"notify error and correct if user wants to;
return #Error if there was no correction
or a ParseNode as returned by variable"
|correctIt suggestedNames newSelector|
"
sorry, but I cannot handle keywords with more than one-part
currently (too much work - maybe Ill do it later when everything else works :-)
"
(aSelectorString occurrencesOf:$:) > 1 ifTrue:[
self warning:msg position:pos1 to:pos2.
^ aSelectorString
].
correctIt := self correctableError:msg position:pos1 to:pos2.
correctIt ifFalse:[^ aSelectorString].
suggestedNames := self findBestSelectorsFor:aSelectorString.
suggestedNames notNil ifTrue:[
newSelector := self askForCorrection:'correct selector to: ' fromList:suggestedNames.
newSelector isNil ifTrue:[^ aSelectorString].
] ifFalse:[
self notify:'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.
^ newSelector
!
selectorCheck:aSelectorString for:receiver position:pos1 to:pos2
"just a quick check: if the selector is totally unknown
as a symbol, it cannot possibly be understood.
Simple, but catches many typos"
|ok err sym node|
(LazyCompilation == true) ifTrue:[^ aSelectorString].
(ignoreErrors or:[ignoreWarnings]) ifTrue:[^ aSelectorString].
err := ' is currently nowhere implemented'.
"
check if the selector is known at all
- if not, it cannot be understood
"
ok := aSelectorString knownAsSymbol.
ok ifTrue:[
sym := aSelectorString asSymbol.
receiver notNil ifTrue:[
"
if the receiver is a constant, we can check if it responds
to this selector
"
receiver isConstant ifTrue:[
ok := receiver evaluate respondsTo:sym.
err := ' will not be understood here'.
] ifFalse:[
"
if the receiver is a global, we check it too ...
"
receiver type == #GlobalVariable ifTrue:[
ok := receiver evaluate respondsTo:sym.
err := ' may not be understood here'.
] ifFalse:[
aSelectorString nArgsIfSelector == 0 ifTrue:[
"
if the (unary) selector is the name of a variable,
check more (usually, there is a missing '.' somewhere)
"
err := ' is currently nowhere implemented (''.'' missing ?)'.
node := self variableOrError:aSelectorString.
node ~~ #Error ifTrue:[
"
ok, its known as variable too ...
"
ok := false.
Smalltalk allClassesDo:[:aClass |
ok := ok or:[aClass implements:sym]
].
]
]
]
]
]
].
ok ifFalse:[
"OLD: "
self warning:('#' , aSelectorString , err) position:pos1 to:pos2
" "
"NEW: - not finished - need more interfaces
(currently produces warning output on Transcript while filing in
^ self correctSelector:aSelectorString message:('#' , aSelectorString , err) position:pos1 to:pos2
"
].
^ aSelectorString
! !