"
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 primNr logged
warnedUndefVars'
classVariableNames:'prevClass prevInstVarNames
prevClassVarNames prevClassInstVarNames'
poolDictionaries:''
category:'System-Compiler'
!
Parser comment:'
COPYRIGHT (c) 1989 by Claus Gittinger
All Rights Reserved
Parser is used for both evaluating and compiling smalltalk expressions;
it first builds a parseTree which is then interpreted (evaluate) or
compiled. Compilation is done in the subclass BCompiler.
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).
$Header: /cvs/stx/stx/libcomp/Parser.st,v 1.3 1993-10-13 02:41:36 claus Exp $
'!
!Parser class methodsFor:'evaluating expressions'!
evaluate:aString
"return the result of evaluating aString"
^ self evaluate:aString notifying:nil
!
evaluate:aStringOrStream notifying:requestor
"return the result of evaluating aString,
errors are reported to requestor"
|parser tree mustBackup|
aStringOrStream isNil ifTrue:[^ nil].
aStringOrStream isStream ifTrue:[
parser := self for:aStringOrStream.
mustBackup := true
] ifFalse:[
parser := self for:(ReadStream on:aStringOrStream).
mustBackup := false
].
parser notifying:requestor.
parser nextToken.
tree := parser parseMethodBodyOrNil.
"if reading from a stream, backup for next expression"
mustBackup ifTrue:[
parser backupPosition
].
(parser errorFlag or:[tree == #Error]) ifTrue:[
^ #Error
].
tree notNil ifTrue:[
parser evalExitBlock:[:value | ^ value].
^ tree evaluate
].
^ nil
!
evaluate:aString receiver:anObject notifying:requestor
"return the result of evaluating aString,
errors are reported to requestor. Allow access to
anObject as self and to its instVars (used in the inspector)"
^ self evaluate:aString
in:nil
receiver:anObject
notifying:requestor
ifFail:nil
!
evaluate:aStringOrStream in:aContext receiver:anObject
notifying:requestor
ifFail:failBlock
|parser tree mustBackup|
aStringOrStream isNil ifTrue:[^ nil].
aStringOrStream isStream ifTrue:[
parser := self for:aStringOrStream.
mustBackup := true
] ifFalse:[
parser := self for:(ReadStream on:aStringOrStream).
mustBackup := false
].
parser setSelf:anObject.
parser setContext:aContext.
parser notifying:requestor.
parser nextToken.
tree := parser parseMethodBodyOrNil.
"if reading from a stream, backup for next expression"
mustBackup ifTrue:[
parser backupPosition
].
(parser errorFlag or:[tree == #Error]) ifTrue:[
failBlock notNil ifTrue:[
^ failBlock value
].
^ #Error
].
tree notNil ifTrue:[
parser evalExitBlock:[:value | ^ value].
^ tree evaluate
].
^ nil
! !
!Parser class methodsFor:'instance creation'!
for:aStream in:aClass
|parser|
parser := self for:aStream.
parser setClassToCompileFor:aClass.
^ parser
! !
!Parser class methodsFor:'parsing'!
parseExpression:aString
"parse aString as an expression; return the parseTree"
^ self withSelf:nil parseExpression:aString notifying:nil
!
withSelf:anObject parseExpression:aString notifying:someOne
"parse aString as an expression with self set to anObject;
return the parseTree"
|parser tree|
aString isNil ifTrue:[^ nil].
parser := self for:(ReadStream on:aString).
parser setSelf:anObject.
parser notifying:someOne.
parser nextToken.
tree := parser expression.
(parser errorFlag or:[tree == #Error]) ifTrue:[^ #Error].
^ tree
!
parseMethodSpecification:aString
"parse a methods selector & arg specification;
return the parser or nil on error"
^ self parseMethodSpecification:aString in:nil
!
parseMethodSpecification:aString in:aClass
"parse a methods selector & arg spec for a given class;
return the parser or nil on error"
|parser tree|
aString isNil ifTrue:[^ nil].
parser := self for:(ReadStream on:aString) in:aClass.
parser nextToken.
tree := parser parseMethodSpec.
(parser errorFlag or:[tree == #Error]) ifTrue:[^ #Error].
^ parser
!
parseMethodArgAndVarSpecification:aString
"parse a methods selector, arg and var spec;
return the parser or nil on error"
^ self parseMethodArgAndVarSpecification:aString in:nil
!
parseMethodArgAndVarSpecification:aString in:aClass
"parse a methods selector, arg and var spec for a given class;
return the parser or nil on error"
|parser|
aString isNil ifTrue:[^ nil].
parser := self for:(ReadStream on:aString) in:aClass.
parser nextToken.
(parser parseMethodSpec == #Error) ifTrue:[^ nil].
(parser parseMethodBodyVarSpec == #Error) ifTrue:[^ nil].
parser errorFlag ifTrue:[^ nil].
^ parser
!
parseMethod:aString
"parse a method; return parseTree"
^ self parseMethod:aString in:nil
!
parseMethod:aString in:aClass
"parse a method for a given class; return parser or nil on error"
|parser tree|
aString isNil ifTrue:[^ nil].
parser := self for:(ReadStream on:aString) in:aClass.
tree := parser parseMethod.
(parser errorFlag or:[tree == #Error]) ifTrue:[^ nil].
^ parser
! !
!Parser methodsFor:'ST-80 compatibility'!
evaluate:aString in:aClass to:to notifying:aRequestor ifFail:failBlock
|parseTree|
aString isNil ifTrue:[^ nil].
self initializeFor:(ReadStream on:aString).
self setClassToCompileFor:aClass.
selfValue := nil.
requestor := aRequestor.
self nextToken.
parseTree := self parseMethodBody.
(errorFlag or:[tree == #Error]) ifTrue:[^ #Error].
parseTree notNil ifTrue:[
self evalExitBlock:[:value | ^ failBlock value].
^ parseTree evaluate
].
^ nil
! !
!Parser class methodsFor:'changes'!
update:aClass
"aClass has changed its definition - flush name caches if we have to"
(aClass == prevClass) ifTrue:[
prevClass := nil.
prevInstVarNames := nil.
prevClassVarNames := nil.
prevClassInstVarNames := nil.
aClass removeDependent:Parser
]
! !
!Parser methodsFor:'setup'!
setClassToCompileFor:aClass
"set the class to be used for parsing/evaluating"
classToCompileFor := aClass.
(classToCompileFor ~~ prevClass) ifTrue:[
prevClass notNil ifTrue:[
Parser update:prevClass
]
]
!
setSelf:anObject
"set the value to be used for self while evaluating"
selfValue := anObject.
classToCompileFor := anObject class.
(classToCompileFor ~~ prevClass) ifTrue:[
prevClass notNil ifTrue:[
Parser update:prevClass
]
]
!
setContext:aContext
"set the context used while evaluating"
contextToEvaluateIn := aContext
! !
!Parser methodsFor:'accessing'!
tree
"return the parsetree"
^tree
!
tree:aTree
tree := aTree
!
selector
"return the selector"
^ selector
!
primitiveNumber
"return the primitiveNumber"
^ primNr
!
numberOfMethodArgs
"return the number of methodargs"
^ methodArgs size
!
methodArgs
"return an array with methodarg names"
^ methodArgNames
!
numberOfMethodVars
"return the number of method variables"
^ methodVars size
!
methodVars
"return a collection with method variablenames"
^ methodVarNames
!
usedVars
"return a collection with variablenames refd by method"
^ usedVars
!
usedInstVars
"return a collection with instvariablenames refd by method"
^ usedInstVars
!
usedClassVars
"return a collection with classvariablenames refd by method"
^ usedClassVars
!
modifiedInstVars
"return a collection with instvariablenames modified by method"
^ modifiedInstVars
!
modifiedClassVars
"return a collection with classvariablenames modified by method"
^ modifiedClassVars
!
errorFlag
^ errorFlag
!
evalExitBlock:aBlock
"when evaluating a return expression, this block is evaluated"
evalExitBlock := aBlock
! !
!Parser methodsFor:'error handling'!
showErrorMessage:aMessage position:pos
Transcript show:(pos printString).
Transcript show:' '.
selector notNil ifTrue:[
Transcript show:aMessage.
Transcript showCr:(' in ' , selector)
] ifFalse:[
Transcript showCr:aMessage
]
!
parseError:aMessage position:position to:endPos
"report a syntax error"
|m|
errorFlag := true.
m := ' Error:' , aMessage.
self notifyError:m position:position to:endPos.
exitBlock notNil ifTrue:[exitBlock value].
^ false
!
parseError:aMessage position:position
"report a syntax error"
^ self parseError:aMessage position:position to:nil
!
parseError:aMessage
"report a syntax error"
^ self parseError:aMessage position:tokenPosition to:nil
!
selectorCheck:aSelectorString position:pos to:pos2
aSelectorString knownAsSymbol ifFalse:[
self warning:(aSelectorString , ' is currently nowhere implemented')
position:pos to:pos2
]
!
correctableError:message position:pos1 to:pos2
"report an error which can be corrected by compiler -
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"
|parseTree|
self nextToken.
(self parseMethodSpec == #Error) ifTrue:[^ #Error].
parseTree := self parseMethodBody.
(parseTree == #Error) ifFalse:[
self tree:parseTree
].
^ parseTree
!
parseMethodSpec
"parse a methods selector & arg specification;
set selector and methodArgs as a side effect"
|var|
(tokenType == #Keyword) ifTrue:[
selector := ''.
[tokenType == #Keyword] whileTrue:[
selector := selector , tokenName.
self nextToken.
(tokenType ~~ #Identifier) ifTrue:[^ #Error].
var := Variable name:tokenName.
methodArgs isNil ifTrue:[
methodArgs := Array with:var.
methodArgNames := Array with:tokenName
] ifFalse:[
methodArgs := methodArgs copyWith:var.
methodArgNames := methodArgNames copyWith:tokenName
].
self nextToken
].
selector := selector asSymbol.
^ self
].
(tokenType == #Identifier) ifTrue:[
selector := tokenName asSymbol.
self nextToken.
^ self
].
(tokenType == #BinaryOperator) ifTrue:[
selector := tokenName asSymbol.
self nextToken.
(tokenType ~~ #Identifier) ifTrue:[^ #Error].
var := Variable name:tokenName.
methodArgs isNil ifTrue:[
methodArgs := Array with:var.
methodArgNames := Array with:tokenName
] ifFalse:[
methodArgs := methodArgs copyWith:var.
methodArgNames := methodArgNames copyWith:tokenName
].
self nextToken.
^ self
].
^ #Error
!
parseMethodBodyOrNil
"parse a methods body (locals & statements);
return a node-tree, nil or #Error. empty (or comment only) input
is accepted and returns nil"
|stats|
((tokenType == #BinaryOperator) and:[tokenName = '<']) ifTrue:[
"an ST-80 primitive - parsed but ignored"
self nextToken.
primNr := self parsePrimitive.
(primNr == #Error) ifTrue:[^ #Error].
self warning:'ST-80 primitives not supported - ignored'
].
(self parseMethodBodyVarSpec == #Error) ifTrue:[^ #Error].
(tokenType ~~ #EOF) ifTrue:[
stats := self statementList
].
^ stats
!
parseMethodBody
"parse a methods body (locals & statements); no more token may follow
return a node-tree, nil or #Error"
|stats|
stats := self parseMethodBodyOrNil.
(stats == #Error) ifFalse:[
(tokenType ~~ #EOF) ifTrue:[
self parseError:(tokenType printString , ' unexpected').
^#Error
]
].
^ stats
!
parseMethodBodyVarSpec
"parse a methods local variable specification"
|var|
(tokenType == $|) ifTrue:[
"memorize position for declaration in correction"
localVarDefPosition := tokenPosition.
self nextToken.
[tokenType == #Identifier] whileTrue:[
var := Variable name:tokenName.
methodVars isNil ifTrue:[
methodVars := Array with:var.
methodVarNames := Array with:tokenName
] ifFalse:[
methodVars := methodVars copyWith:var.
methodVarNames := methodVarNames copyWith:tokenName
].
self nextToken
].
(tokenType ~~ $|) ifTrue:[
self syntaxError:'error in local var specification; | expected.'.
^ #Error
].
self nextToken
].
^ nil
!
parsePrimitive
"parse an ST-80 type primitive;
return primitive number or #Error"
|primNumber|
((tokenType == #Keyword) and:[tokenName = 'primitive:']) ifFalse:[
self parseError:'bad primitive definition (primitive: expected)'.
^ #Error
].
self nextToken.
(tokenType == #Integer) ifFalse:[
self parseError:'primitive number expected'.
^ #Error
].
primNumber := tokenValue.
self nextToken.
((tokenType == #BinaryOperator) and:[tokenName = '>']) ifFalse:[
self parseError:'bad primitive definition (> expected)'.
^ #Error
].
self nextToken.
^ primNumber
!
statementList
"parse a statementlist; return a node-tree, nil or #Error.
Statements must be separated by periods."
|thisStatement prevStatement firstStatement correctIt periodPos|
thisStatement := self statement.
(thisStatement == #Error) ifTrue:[^ #Error].
firstStatement := thisStatement.
[tokenType == $.] whileTrue:[
periodPos := tokenPosition.
self nextToken.
(tokenType == $]) ifTrue:[
currentBlock isNil ifTrue:[
self parseError:'block nesting error'.
errorFlag := true
"
*** I had a warning here (since it was not defined
*** in the blue-book; but PD-code contains a lot of
*** code with periods at the end so that the warnings
*** became annoying
] ifFalse:[
self warning:'period after last statement' position:periodPos
"
].
^ firstStatement
].
(tokenType == #EOF) ifTrue:[
currentBlock notNil ifTrue:[
self parseError:'block nesting error'.
errorFlag := true
"
*** I had a warning here (since it was not defined
*** in the blue-book; but PD-code contains a lot of
*** code with periods at the end so that the warnings
*** became annoying
] ifFalse:[
self warning:'period after last statement' position:periodPos
"
].
^ firstStatement
].
prevStatement := thisStatement.
(prevStatement isKindOf:ReturnNode) ifTrue:[
self warning:'statements after return' position:tokenPosition
].
"
periodPos := tokenPosition.
self nextToken.
"
((tokenType == $]) or:[tokenType == #EOF]) ifTrue:[
(currentBlock isNil and:[tokenType == $]]) ifTrue:[
self parseError:'block nesting error'.
errorFlag := true
] ifFalse:[
correctIt := self correctableError:'period after last statement in block'
position:periodPos to:(periodPos + 1).
correctIt ifTrue:[
(self correctByDeleting == #Error) ifTrue:[
errorFlag := true
]
]
].
^ firstStatement
].
thisStatement := self statement.
(thisStatement == #Error) ifTrue:[^ #Error].
prevStatement nextStatement:thisStatement
].
^ firstStatement
!
statement
"parse a statement; return a node-tree, nil or #Error"
|expr node|
(tokenType == $^) ifTrue:[
self nextToken.
expr := self expression.
(expr == #Error) ifTrue:[^ #Error].
node := ReturnNode expression:expr.
node home:self blockHome:currentBlock.
^ node
].
(tokenType == #Primitive) ifTrue:[
self parseError:'cannot compile primitives (yet)'.
self nextToken.
^ PrimitiveNode code:''
].
(tokenType == #EOF) ifTrue:[
self syntaxError:'period after last statement'.
^ #Error
].
expr := self expression.
"
classToCompileFor notNil ifTrue:[
currentBlock isNil ifTrue:[
(expr isKindOf:PrimaryNode) ifTrue:[
self warning:'useless computation - missing ^ ?'
]
]
].
"
(expr == #Error) ifTrue:[^ #Error].
^ StatementNode expression:expr
!
expression
"parse a cascade-expression; return a node-tree, nil or #Error"
|receiver arg sel args pos pos2|
pos := tokenPosition.
receiver := self keywordExpression.
(receiver == #Error) ifTrue:[^ #Error].
[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 := tokenName.
self selectorCheck:sel position:tokenPosition to:(tokenPosition + sel size - 1).
receiver := CascadeNode receiver:receiver selector:sel.
self nextToken
] ifFalse:[
(tokenType == #BinaryOperator) ifTrue:[
sel := tokenName.
self selectorCheck:sel position:tokenPosition to:(tokenPosition + sel size - 1).
self nextToken.
arg := self unaryExpression.
(arg == #Error) ifTrue:[^ #Error].
receiver := CascadeNode receiver:receiver selector:sel arg:arg
] ifFalse:[
(tokenType == #Keyword) ifTrue:[
pos := tokenPosition.
sel := tokenName.
self nextToken.
arg := self binaryExpression.
(arg == #Error) ifTrue:[^ #Error].
args := Array with:arg.
[tokenType == #Keyword] whileTrue:[
sel := sel , tokenName.
self nextToken.
arg := self binaryExpression.
(arg == #Error) ifTrue:[^ #Error].
args := args copyWith:arg.
pos2 := tokenPosition
].
self selectorCheck:sel position:pos to:pos2.
receiver := CascadeNode receiver:receiver selector:sel args:args
] ifFalse:[
(tokenType == #Error) ifTrue:[^ #Error].
self syntaxError:('invalid cascade; ' , tokenType printString , ' unexpected')
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
].
self selectorCheck:sel position:pos1 to:pos2.
try := MessageNode receiver:receiver selector:sel args:args.
(try isMemberOf:String) ifTrue:[
self parseError:try position:pos1 to:pos2.
receiver := MessageNode receiver:receiver selector:sel args:args
fold:false
] ifFalse:[
receiver := try
].
note := receiver plausibilityCheck.
note notNil ifTrue:[
self warning:note position:pos1 to:pos2
].
receiver lineNumber:lno
].
^ receiver
!
binaryExpression
"parse a binary-expression; return a node-tree, nil or #Error"
|receiver arg sel pos try lno note|
receiver := self unaryExpression.
(receiver == #Error) ifTrue:[^ #Error].
"special kludge: since Scanner cannot know if -digit is a binary
expression or a negative constant, handle cases here"
[(tokenType == #BinaryOperator) or:[(tokenType == $|)
or:[(tokenType == #Integer) and:[tokenValue < 0]]]] whileTrue:[
pos := tokenPosition.
lno := tokenLineNr.
"kludge here: bar and minus are not scanned as binop "
(tokenType == $|) ifTrue:[
sel := '|'.
self nextToken
] ifFalse:[
(tokenType == #BinaryOperator) ifTrue:[
sel := tokenName.
self selectorCheck:sel position:tokenPosition
to:(tokenPosition + sel size - 1).
self nextToken
] ifFalse:[
sel := '-'.
tokenValue := tokenValue negated
]
].
arg := self unaryExpression.
(arg == #Error) ifTrue:[^ #Error].
try := BinaryNode receiver:receiver selector:sel arg:arg.
(try isMemberOf:String) ifTrue:[
self parseError:try position:pos to:tokenPosition.
receiver := BinaryNode receiver:receiver selector:sel arg:arg
fold:false
] ifFalse:[
receiver := try
].
note := receiver plausibilityCheck.
note notNil ifTrue:[
self warning:note position:pos to:tokenPosition
].
receiver lineNumber:lno
].
^ receiver
!
unaryExpression
"parse a unary-expression; return a node-tree, nil or #Error"
|receiver sel pos try|
receiver := self primary.
(receiver == #Error) ifTrue:[^ #Error].
[tokenType == #Identifier] whileTrue:[
pos := tokenPosition.
sel := tokenName.
self selectorCheck:sel position:tokenPosition
to:(tokenPosition + sel size - 1).
try := UnaryNode receiver:receiver selector:sel.
(try isMemberOf:String) ifTrue:[
self warning:try position:pos to:(tokenPosition + sel size - 1).
receiver := UnaryNode receiver:receiver selector:sel fold:false
] ifFalse:[
receiver := try
].
receiver lineNumber:tokenLineNr.
self nextToken.
].
^ receiver
!
primary
"parse a primary-expression; return a node-tree, nil or #Error"
|val var expr pos name|
pos := tokenPosition.
(tokenType == #Identifier) ifTrue:[
var := self variable.
(var == #Error) ifTrue:[
errorFlag := true
].
self nextToken.
(tokenType == $_) ifFalse:[
^ var
].
(var ~~ #Error) ifTrue:[
(var type == #MethodArg) ifTrue:[
self parseError:'assignment to method argument' position:pos to:tokenPosition.
errorFlag := true
].
(var type == #BlockArg) ifTrue:[
self parseError:'assignment to block argument' position:pos to:tokenPosition.
errorFlag := true
].
(var type == #InstanceVariable) ifTrue:[
modifiedInstVars isNil ifTrue:[
modifiedInstVars := OrderedCollection new
].
name := prevInstVarNames at:(var index).
(modifiedInstVars includes:name) ifFalse:[
modifiedInstVars add:name
]
] ifFalse:[
(var type == #ClassVariable) ifTrue:[
modifiedClassVars isNil ifTrue:[
modifiedClassVars := OrderedCollection new
].
name := var name.
name := name copyFrom:((name indexOf:$:) + 1).
(modifiedClassVars includes:name) ifFalse:[
modifiedClassVars add:name
]
]
]
].
self nextToken.
expr := self expression.
(errorFlag or:[expr == #Error]) ifTrue:[^ #Error].
^ AssignmentNode variable:var expression:expr
].
((tokenType == #Integer) or:
[(tokenType == #Character) or:
[tokenType == #Float]]) ifTrue:[
val := ConstantNode type:tokenType value:tokenValue.
self nextToken.
(tokenType == $_) ifTrue:[
self parseError:'assignment to a constant' position:pos to:tokenPosition.
^ #Error
].
^ val
].
(tokenType == #Self) ifTrue:[
self nextToken.
(tokenType == $_) ifTrue:[
self parseError:'assignment to self' position:pos to:tokenPosition.
^ #Error
].
selfNode isNil ifTrue:[
selfNode := PrimaryNode type:#Self value:selfValue
].
^ selfNode
].
(tokenType == #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 := PrimaryNode type:#Super value:selfValue
].
^ superNode
].
(tokenType == #ThisContext) ifTrue:[
self nextToken.
(tokenType == $_) ifTrue:[
self parseError:'assignment to thisContext' position:pos to:tokenPosition.
^ #Error
].
^ PrimaryNode type:#ThisContext value:nil
].
(tokenType == #HashLeftParen) ifTrue:[
self nextToken.
val := self array.
self nextToken.
^ ConstantNode type:#Array value:val
].
(tokenType == #HashLeftBrack) ifTrue:[
self nextToken.
val := self byteArray.
self nextToken.
^ ConstantNode type:#Array value:val
].
(tokenType == $() ifTrue:[
self nextToken.
val := self expression.
(val == #Error) ifTrue:[^ #Error].
(tokenType ~~ $) ) ifTrue:[
(tokenType isMemberOf:Character) ifTrue:[
self syntaxError:'missing '')'' (i.e. ''' , tokenType asString , ''' unexpected)' withCRs position:pos to:tokenPosition.
] ifFalse:[
self syntaxError:'missing '')''' position:pos to:tokenPosition.
].
^ #Error
].
self nextToken.
^ val
].
(tokenType == $[ ) ifTrue:[
val := self block.
self nextToken.
^ val
].
(tokenType == #Error) ifTrue:[^ #Error].
(tokenType isKindOf:Character) ifTrue:[
self syntaxError:('error in primary; '
, tokenType printString ,
' unexpected') position:tokenPosition to:tokenPosition
] ifFalse:[
self syntaxError:('error in primary; '
, tokenType printString ,
' unexpected')
].
^ #Error
!
variableOrError
"parse a variable; return a node-tree, nil or #Error"
|tokenFound var instIndex aClass searchBlock args vars
varName tokenSymbol theBlock className
runIndex "{ Class: SmallInteger }" |
varName := tokenName.
"is it a block-arg or block-var ?"
searchBlock := currentBlock.
[searchBlock notNil] whileTrue:[
runIndex := 1.
args := searchBlock arguments.
args notNil ifTrue:[
args do:[:aBlockArg |
(aBlockArg name = varName) ifTrue:[
tokenFound := aBlockArg.
instIndex := runIndex.
theBlock := searchBlock
].
runIndex := runIndex + 1
].
tokenFound notNil ifTrue:[
^ PrimaryNode type:#BlockArg
name:varName
token:tokenFound
index:instIndex
block:theBlock
]
].
runIndex := 1.
vars := searchBlock variables.
vars notNil ifTrue:[
vars do:[:aBlockVar |
(aBlockVar name = varName) ifTrue:[
tokenFound := aBlockVar.
instIndex := runIndex.
theBlock := searchBlock
].
runIndex := runIndex + 1
].
tokenFound notNil ifTrue:[
^ PrimaryNode type:#BlockVariable
name:varName
token:tokenFound
index:instIndex
block:theBlock
]
].
searchBlock := searchBlock home
].
"is it a method-variable ?"
methodVars notNil ifTrue:[
instIndex := methodVarNames indexOf:varName.
(instIndex ~~ 0) ifTrue:[
var := methodVars at:instIndex.
var used:true.
^ PrimaryNode type:#MethodVariable
name:varName
token:var
index:instIndex
]
].
"is it a method-argument ?"
methodArgs notNil ifTrue:[
instIndex := methodArgNames indexOf:varName.
(instIndex ~~ 0) ifTrue:[
^ PrimaryNode type:#MethodArg
name:varName
token:(methodArgs at:instIndex)
index:instIndex
]
].
"is it an instance-variable ?"
classToCompileFor notNil ifTrue:[
"caching allInstVarNames for next compilation saves time ..."
(prevInstVarNames isNil or:[prevClass ~~ classToCompileFor]) ifTrue:[
prevClass notNil ifTrue:[
prevClass removeDependent:Parser
].
prevClass := classToCompileFor.
prevInstVarNames := classToCompileFor allInstVarNames.
prevClassInstVarNames := nil.
prevClassVarNames := nil.
prevClass addDependent:Parser
].
instIndex := prevInstVarNames indexOf:varName startingAt:1
ifAbsent:[nil].
instIndex notNil ifTrue:[
usedInstVars isNil ifTrue:[
usedInstVars := OrderedCollection new
].
(usedInstVars includes:varName) ifFalse:[
usedInstVars add:varName
].
usedVars isNil ifTrue:[
usedVars := OrderedCollection new
].
(usedVars includes:varName) ifFalse:[
usedVars add:varName
].
^ PrimaryNode type:#InstanceVariable
name:varName
index:instIndex
selfValue:selfValue
]
].
"is it a class-instance-variable ?"
classToCompileFor notNil ifTrue:[
prevClassInstVarNames isNil ifTrue:[
prevClassInstVarNames := classToCompileFor class allInstVarNames
].
instIndex := prevClassInstVarNames indexOf:varName startingAt:1
ifAbsent:[nil].
instIndex notNil ifTrue:[
aClass := self inWhichClassIsClassInstVar:varName.
aClass notNil ifTrue:[
usedVars isNil ifTrue:[
usedVars := OrderedCollection new
].
(usedVars includes:varName) ifFalse:[
usedVars add:varName
].
^ PrimaryNode type:#ClassInstanceVariable
name:varName
index:instIndex
selfValue:selfValue
]
]
].
"is it a class-variable ?"
classToCompileFor notNil ifTrue:[
prevClassVarNames isNil ifTrue:[
aClass := classToCompileFor.
classToCompileFor isMeta ifTrue:[
className := aClass name.
className := className copyFrom:1 to:(className size - 5).
aClass := Smalltalk at:(className asSymbol).
aClass isNil ifTrue:[
aClass := classToCompileFor
]
].
prevClassVarNames := aClass allClassVarNames
].
instIndex := prevClassVarNames indexOf:varName startingAt:1
ifAbsent:[nil].
instIndex notNil ifTrue:[
aClass := self inWhichClassIsClassVar:varName.
aClass notNil ifTrue:[
usedClassVars isNil ifTrue:[
usedClassVars := OrderedCollection new
].
(usedClassVars includes:varName) ifFalse:[
usedClassVars add:varName
].
usedVars isNil ifTrue:[
usedVars := OrderedCollection new
].
(usedVars includes:varName) ifFalse:[
usedVars add:varName
].
^ PrimaryNode type:#ClassVariable
name:(aClass name , ':' , varName) asSymbol
]
]
].
"is it a global-variable ?"
tokenSymbol := varName asSymbol.
(Smalltalk includesKey:tokenSymbol) ifTrue:[
usedVars isNil ifTrue:[
usedVars := OrderedCollection new
].
(usedVars includes:varName) ifFalse:[
usedVars add:varName
].
^ PrimaryNode type:#GlobalVariable
name:tokenSymbol
].
^ #Error
!
variable
"parse a variable; if undefined, notify error and correct if user wants to"
|v|
v := self variableOrError.
(v == #Error) ifFalse:[^ v].
v := self correctVariable.
(v == #Error) ifFalse:[^ v].
^ PrimaryNode type:#GlobalVariable
name:tokenName asSymbol
!
inWhichClassIsClassVar:aString
"search class-chain for the classvariable named aString
- return the class or nil if not found"
|aClass className baseClass|
aClass := classToCompileFor.
aClass isMeta ifTrue:[
className := aClass name.
className := className copyFrom:1 to:(className size - 5).
baseClass := Smalltalk at:(className asSymbol).
baseClass notNil ifTrue:[
aClass := baseClass
]
].
[aClass notNil] whileTrue:[
(aClass classVarNames includes:aString) ifTrue:[ ^ aClass].
aClass := aClass superclass
].
^ nil
!
inWhichClassIsClassInstVar:aString
"search class-chain for the class-instance variable named aString
- return the class or nil if not found"
|aClass|
aClass := classToCompileFor.
[aClass notNil] whileTrue:[
(aClass class instVarNames includes:aString) ifTrue:[ ^ aClass].
aClass := aClass superclass
].
^ nil
!
block
"parse a block; return a node-tree, nil or #Error"
|stats node args var vars pos|
self nextToken.
(tokenType == $: ) ifTrue:[
[tokenType == $:] whileTrue:[
pos := tokenPosition.
self nextToken.
(tokenType == #Identifier) ifFalse:[
self syntaxError:'Identifier expected in block-arg declaration'
position:pos to:tokenPosition-1.
^ #Error
].
var := Variable name:tokenName.
args isNil ifTrue:[
args := Array with:var
] ifFalse:[
args := args copyWith:var
].
self nextToken
].
(tokenType ~~ $| ) ifTrue:[
"ST-80 allows [:arg ]"
(tokenType == $] ) ifTrue:[
^ BlockNode arguments:args home:currentBlock variables:nil.
].
self syntaxError:'| expected after block-arg declaration'.
^ #Error
].
self nextToken
].
(tokenType == $| ) ifTrue:[
self nextToken.
pos := tokenPosition.
[tokenType == $|] whileFalse:[
(tokenType == #Identifier) ifFalse:[
self syntaxError:'Identifier expected in block-var declaration' position:pos.
^ #Error
].
var := Variable name:tokenName.
vars isNil ifTrue:[
vars := Array with:var
] ifFalse:[
vars := vars copyWith:var
].
self nextToken
].
self nextToken
].
node := BlockNode arguments:args home:currentBlock variables:vars.
currentBlock := node.
stats := self blockStatementList.
node statements:stats.
currentBlock := node home.
(stats == #Error) ifTrue:[^ #Error].
^ node
!
blockStatementList
"parse a blocks statementlist; return a node-tree, nil or #Error"
|thisStatement prevStatement firstStatement|
(tokenType == $] ) ifTrue:[^ nil].
thisStatement := self statement.
(thisStatement == #Error) ifTrue:[^ #Error].
firstStatement := thisStatement.
[tokenType == $] ] whileFalse:[
(tokenType == $.) ifFalse:[
(tokenType == #EOF) ifTrue:[
self syntaxError:'missing '']'' in block'
] ifFalse:[
self syntaxError:'missing ''.'' in block'
].
^ #Error
] ifTrue:[
prevStatement := thisStatement.
self nextToken.
tokenType == $] ifTrue:[
"
*** I had a warning here (since it was not defined
*** in the blue-book; but PD-code contains a lot of
*** code with periods at the end so that the warnings
*** became annoying
self warning:'period after last statement in block'.
"
^ firstStatement
].
thisStatement := self statement.
(thisStatement == #Error) ifTrue:[^ #Error].
prevStatement nextStatement:thisStatement
]
].
^ firstStatement
!
array
|arr elem pos1 pos2|
pos1 := tokenPosition.
arr := OrderedCollection new:200.
[tokenType ~~ $) ] whileTrue:[
elem := self arrayConstant.
(elem == #Error) ifTrue:[
(tokenType == #EOF) ifTrue:[
self syntaxError:'unterminated array-constant; '')'' expected'
position:pos1 to:tokenPosition
].
^ #Error
].
arr add:elem.
self nextToken
].
^ Array withAll:arr
!
byteArray
"for ST-80 R4 - allow byteArray constants"
|arr elem pos1 pos2|
pos1 := tokenPosition.
arr := OrderedCollection new.
[tokenType ~~ $] ] whileTrue:[
pos2 := tokenPosition.
elem := self arrayConstant.
(elem == #Error) ifTrue:[
(tokenType == #EOF) ifTrue:[
self syntaxError:'unterminated bytearray-constant; '']'' expected'
position:pos1 to:tokenPosition
].
^ #Error
].
((elem isMemberOf:SmallInteger) and:
[(elem >= 0) and:[elem <= 255]]) ifTrue:[
arr add:elem
] ifFalse:[
self parseError:'invalid ByteArray element' position:pos2 to:tokenPosition - 1
].
self nextToken
].
^ ByteArray withAll:arr
!
arrayConstant
(tokenType == #String) ifTrue:[
^ tokenValue
].
(tokenType == #Nil) ifTrue:[
^ nil
].
(tokenType == #Integer) ifTrue:[
^ tokenValue
].
(tokenType == #Character) ifTrue:[
^ tokenValue
].
(tokenType == #Float) ifTrue:[
^ tokenValue
].
(tokenType == #True) ifTrue:[
^ true
].
(tokenType == #False) ifTrue:[
^ false
].
(tokenType == #Error) ifTrue:[
^ #Error
].
(tokenType == #BinaryOperator) ifTrue:[
^ tokenName asSymbol
].
(tokenType == #Keyword) ifTrue:[
^ tokenName asSymbol
].
(tokenType == #Identifier) ifTrue:[
^ tokenName asSymbol
].
(tokenType == $() ifTrue:[
self nextToken.
^ self array
].
(tokenType == $[) ifTrue:[
self nextToken.
^ self byteArray
].
(tokenType == #Symbol) ifTrue:[
"
self warning:'no # for symbols within array-constants'.
"
^ tokenValue
].
(tokenType == #HashLeftParen) ifTrue:[
"
self warning:'no # for arrays within array-constants'.
"
self nextToken.
^ self array
].
(tokenType == #HashLeftBrack) ifTrue:[
"
self warning:'no # for arrays within array-constants'.
"
self nextToken.
^ self byteArray
].
(tokenType == #EOF) ifTrue:[
"just for the better error-hilight; let caller handle error"
^ #Error
].
self syntaxError:('error in array-constant; '
, tokenType printString
, ' unexpected').
^ #Error
! !
!Parser methodsFor:'error correction'!
correctByDeleting
"correct (by deleting token) if user wants to;
return #Error if there was no correction or nil"
(self confirm:'confirm deleting') ifFalse:[^ #Error].
"tell requestor about the change"
requestor deleteSelection.
^ nil
!
findBestVariableFor:aString
"collect known variables with their levenshtein distances to aString;
return the 10 best suggestions"
|names dists searchBlock args vars globalVarName aClass className baseClass n|
names := VariableArray new.
dists := VariableArray new.
"block arguments"
searchBlock := currentBlock.
[searchBlock notNil] whileTrue:[
args := searchBlock arguments.
args notNil ifTrue:[
args do:[:aBlockArg |
names add:(aBlockArg name).
dists add:(aString levenshteinTo:(aBlockArg name))
]
].
vars := searchBlock variables.
vars notNil ifTrue:[
vars do:[:aBlockVar |
names add:(aBlockVar name).
dists add:(aString levenshteinTo:(aBlockVar name))
]
].
searchBlock := searchBlock home
].
"method-variables"
methodVars notNil ifTrue:[
methodVarNames do:[:methodVarName |
names add:methodVarName.
dists add:(aString levenshteinTo:methodVarName)
]
].
"method-arguments"
methodArgs notNil ifTrue:[
methodArgNames do:[:methodArgName |
names add:methodArgName.
dists add:(aString levenshteinTo:methodArgName)
]
].
"instance-variables"
classToCompileFor notNil ifTrue:[
prevInstVarNames do:[:instVarName |
names add:instVarName.
dists add:(aString levenshteinTo:instVarName)
]
].
"class-variables"
classToCompileFor notNil ifTrue:[
aClass := classToCompileFor.
aClass isMeta ifTrue:[
className := aClass name.
className := className copyFrom:1 to:(className size - 5).
baseClass := Smalltalk at:(className asSymbol).
baseClass notNil ifTrue:[
aClass := baseClass
]
].
[aClass notNil] whileTrue:[
(aClass classVarNames) do:[:classVarName |
names add:classVarName.
dists add:(aString levenshteinTo:classVarName)
].
aClass := aClass superclass
]
].
"globals"
Smalltalk allKeysDo:[:aKey |
globalVarName := aKey asString.
"only compare strings where length is about right"
((globalVarName size - aString size) abs < 3) ifTrue:[
names add:globalVarName.
dists add:(aString levenshteinTo:globalVarName)
]
].
"misc"
#('self' 'super' 'nil') do:[:name |
"only compare strings where length is about right"
((name size - aString size) abs < 3) ifTrue:[
names add:name.
dists add:(aString levenshteinTo:name)
]
].
(dists size ~~ 0) ifTrue:[
dists sortWith:names.
n := names size min:10.
^ names copyFrom:1 to:n
].
^ nil
!
correctVariable
"notify error and correct if user wants to;
return #Error if there was no correction
or a ParseNode as returned by variable"
|correctIt varName suggestedNames newName pos1 pos2|
pos1 := tokenPosition.
varName := tokenName.
pos2 := pos1 + varName size - 1.
(varName at:1) isLowercase ifTrue:[
correctIt := self undefError:varName position:pos1 to:pos2.
correctIt ifFalse:[^ #Error]
] ifFalse:[
correctIt := self warning:(varName , ' is undefined') position:pos1 to:pos2.
correctIt ifFalse:[
^ PrimaryNode type:#GlobalVariable
name:(varName asSymbol)
]
].
suggestedNames := self findBestVariableFor:varName.
suggestedNames notNil ifTrue:[
newName := self askForVariable:'correct variable to: ' fromList:suggestedNames.
newName isNil ifTrue:[^ #Error].
"
newName := suggestedNames at:1.
(self confirm:('confirm correction to: ' , newName)) ifFalse:[^ #Error]
"
] ifFalse:[
self notify:'no good correction found'.
^ #Error
].
"tell requestor about the change"
requestor replaceSelectionBy:newName.
"redo parse with new value"
tokenName := newName.
^ self variableOrError
!
askForVariable:aString fromList:aList
"launch a selection box, which allows user to enter correction.
return true for yes, false for no"
|box|
ListSelectionBox isNil ifTrue:[
^ self confirm:aString
].
box := ListSelectionBox new.
box title:aString.
box initialText:(aList at:1).
box list:aList.
box okText:'replace'.
box abortText:'abort'.
box action:[:aString | ^ aString].
box showAtPointer.
^ nil
! !