--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/Parser.st Fri Jul 16 11:38:57 1993 +0200
@@ -0,0 +1,1929 @@
+"
+ COPYRIGHT (c) 1989-93 by Claus Gittinger
+ All Rights Reserved
+
+ This software is furnished under a license and may be used
+ only in accordance with the terms of that license and with the
+ inclusion of the above copyright notice. This software may not
+ be provided or otherwise made available to, or used by, any
+ other person. No title to or ownership of the software is
+ hereby transferred.
+"
+
+Scanner subclass:#Parser
+ instanceVariableNames:'classToCompileFor selfValue
+ contextToEvaluateIn
+ selector
+ methodArgs methodArgNames
+ methodVars methodVarNames
+ tree
+ currentBlock
+ usedInstVars usedClassVars
+ modifiedInstVars modifiedClassVars
+ localVarDefPosition
+ evalExitBlock
+ selfNode superNode primNr logged'
+ classVariableNames:'prevClass prevInstVarNames
+ prevClassVarNames prevClassInstVarNames'
+ poolDictionaries:''
+ category:'System-Compiler'
+!
+
+Parser comment:'
+
+COPYRIGHT (c) 1989-93 by Claus Gittinger
+ All Rights Reserved
+
+Parser is used for both evaluating and compiling smalltalk expressions;
+it first builds a parseTree which is then interpreted (evaluate) or
+compiled. Compilation is done in the subclass BCompiler.
+
+Parser is also used to find the referenced/modified inst/classvars of
+a method - this is done by sending parseXXX message to a parser and asking
+the parser for referencedXVars or modifiedXVars (see SystemBrowser).
+
+%W% %E%
+'!
+
+!Parser class methodsFor:'evaluating expressions'!
+
+evaluate:aString
+ "return the result of evaluating aString"
+
+ ^ self evaluate:aString notifying:nil
+!
+
+evaluate:aStringOrStream notifying:requestor
+ "return the result of evaluating aString,
+ errors are reported to requestor"
+
+ |parser tree mustBackup|
+
+ aStringOrStream isNil ifTrue:[^ nil].
+ aStringOrStream isStream ifTrue:[
+ parser := self for:aStringOrStream.
+ mustBackup := true
+ ] ifFalse:[
+ parser := self for:(ReadStream on:aStringOrStream).
+ mustBackup := false
+ ].
+ parser notifying:requestor.
+ parser nextToken.
+ tree := parser parseMethodBodyOrNil.
+
+ "if reading from a stream, backup for next expression"
+ mustBackup ifTrue:[
+ parser backupPosition
+ ].
+
+ (parser errorFlag or:[tree == #Error]) ifTrue:[
+ ^ #Error
+ ].
+ tree notNil ifTrue:[
+ parser evalExitBlock:[:value | ^ value].
+ ^ tree evaluate
+ ].
+ ^ nil
+!
+
+evaluate:aString receiver:anObject notifying:requestor
+ "return the result of evaluating aString,
+ errors are reported to requestor. Allow access to
+ anObject as self and to its instVars (used in the inspector)"
+
+ ^ self evaluate:aString
+ in:nil
+ receiver:anObject
+ notifying:requestor
+ ifFail:nil
+!
+
+evaluate:aStringOrStream in:aContext receiver:anObject
+ notifying:requestor
+ ifFail:failBlock
+ |parser tree mustBackup|
+
+ aStringOrStream isNil ifTrue:[^ nil].
+ aStringOrStream isStream ifTrue:[
+ parser := self for:aStringOrStream.
+ mustBackup := true
+ ] ifFalse:[
+ parser := self for:(ReadStream on:aStringOrStream).
+ mustBackup := false
+ ].
+ parser setSelf:anObject.
+ parser setContext:aContext.
+ parser notifying:requestor.
+ parser nextToken.
+ tree := parser parseMethodBodyOrNil.
+
+ "if reading from a stream, backup for next expression"
+ mustBackup ifTrue:[
+ parser backupPosition
+ ].
+
+ (parser errorFlag or:[tree == #Error]) ifTrue:[
+ failBlock notNil ifTrue:[
+ ^ failBlock value
+ ].
+ ^ #Error
+ ].
+ tree notNil ifTrue:[
+ parser evalExitBlock:[:value | ^ value].
+ ^ tree evaluate
+ ].
+ ^ nil
+! !
+
+!Parser class methodsFor:'instance creation'!
+
+for:aStream in:aClass
+ |parser|
+
+ parser := self for:aStream.
+ parser setClassToCompileFor:aClass.
+ ^ parser
+! !
+
+!Parser class methodsFor:'parsing'!
+
+parseExpression:aString
+ "parse aString as an expression; return the parseTree"
+
+ ^ self withSelf:nil parseExpression:aString notifying:nil
+!
+
+withSelf:anObject parseExpression:aString notifying:someOne
+ "parse aString as an expression with self set to anObject;
+ return the parseTree"
+
+ |parser tree|
+
+ aString isNil ifTrue:[^ nil].
+ parser := self for:(ReadStream on:aString).
+ parser setSelf:anObject.
+ parser notifying:someOne.
+ parser nextToken.
+ tree := parser expression.
+ (parser errorFlag or:[tree == #Error]) ifTrue:[^ #Error].
+ ^ tree
+!
+
+parseMethodSpecification:aString
+ "parse a methods selector & arg specification;
+ return the parser or nil on error"
+
+ ^ self parseMethodSpecification:aString in:nil
+!
+
+parseMethodSpecification:aString in:aClass
+ "parse a methods selector & arg spec for a given class;
+ return the parser or nil on error"
+
+ |parser tree|
+
+ aString isNil ifTrue:[^ nil].
+ parser := self for:(ReadStream on:aString) in:aClass.
+ parser nextToken.
+ tree := parser parseMethodSpec.
+ (parser errorFlag or:[tree == #Error]) ifTrue:[^ #Error].
+ ^ parser
+!
+
+parseMethodArgAndVarSpecification:aString
+ "parse a methods selector, arg and var spec;
+ return the parser or nil on error"
+
+ ^ self parseMethodArgAndVarSpecification:aString in:nil
+!
+
+parseMethodArgAndVarSpecification:aString in:aClass
+ "parse a methods selector, arg and var spec for a given class;
+ return the parser or nil on error"
+
+ |parser|
+
+ aString isNil ifTrue:[^ nil].
+ parser := self for:(ReadStream on:aString) in:aClass.
+ parser nextToken.
+ (parser parseMethodSpec == #Error) ifTrue:[^ nil].
+ (parser parseMethodBodyVarSpec == #Error) ifTrue:[^ nil].
+ parser errorFlag ifTrue:[^ nil].
+ ^ parser
+!
+
+parseMethod:aString
+ "parse a method; return parseTree"
+
+ ^ self parseMethod:aString in:nil
+!
+
+parseMethod:aString in:aClass
+ "parse a method for a given class; return parser or nil on error"
+
+ |parser tree|
+
+ aString isNil ifTrue:[^ nil].
+ parser := self for:(ReadStream on:aString) in:aClass.
+ tree := parser parseMethod.
+ (parser errorFlag or:[tree == #Error]) ifTrue:[^ nil].
+ ^ parser
+! !
+
+!Parser class methodsFor:'explaining'!
+
+explain:someText in:source forClass:aClass
+ "this is just a q&d implementation - there could be much more"
+
+ |parser variables v c string sym list count tmp|
+
+ string := someText withoutSeparators.
+ parser := self parseMethod:source in:aClass.
+ parser notNil ifTrue:[
+ "look for variables"
+
+ variables := parser methodVars.
+ (variables notNil and:[variables includes:string]) ifTrue:[
+ ^ string , ' is a method variable'
+ ].
+ variables := parser methodArgs.
+ (variables notNil and:[variables includes:string]) ifTrue:[
+ ^ string , ' is a method argument'
+ ]
+ ].
+ parser isNil ifTrue:[
+ parser := self for:(ReadStream on:source) in:aClass
+ ].
+
+ "instvars"
+ variables := aClass allInstVarNames.
+ (variables notNil and:[variables includes:string]) ifTrue:[
+ "where is it"
+ c := aClass.
+ [c notNil] whileTrue:[
+ v := c instVarNames.
+ (v notNil and:[v includes:string]) ifTrue:[
+ ^ string , ' is an instance variable in ' , c name
+ ].
+ c := c superclass
+ ].
+ self error:'oops'
+ ].
+ "class instvars"
+ variables := aClass class allInstVarNames.
+ (variables notNil and:[variables includes:string]) ifTrue:[
+ "where is it"
+ c := aClass.
+ [c notNil] whileTrue:[
+ v := c class instVarNames.
+ (v notNil and:[v includes:string]) ifTrue:[
+ ^ string , ' is a class instance variable in ' , c name
+ ].
+ c := c superclass
+ ].
+ self error:'oops'
+ ].
+ "classvars"
+ c := parser inWhichClassIsClassVar:string.
+ c notNil ifTrue:[
+ ^ string , ' is a class variable in ' , c name
+ ].
+
+ string knownAsSymbol ifTrue:[
+ "globals"
+ sym := string asSymbol.
+ (Smalltalk includesKey:sym) ifTrue:[
+ (Smalltalk at:sym) isBehavior ifTrue:[
+ ^ string , ' is a global variable.
+
+' , string , ' is a class in category ' , (Smalltalk at:sym) category , '.'
+ ] ifFalse:[
+ ^ string , ' is a global variable.
+
+Its current value is ' , (Smalltalk at:sym) classNameWithArticle , '.'
+ ]
+ ].
+
+ list := OrderedCollection new.
+ "selectors"
+ Smalltalk allClassesDo:[:c|
+ (c implements:sym) ifTrue:[
+ list add:(c name)
+ ].
+ (c class implements:sym) ifTrue:[
+ list add:(c name , 'class')
+ ]
+ ].
+ count := list size.
+ (count ~~ 0) ifTrue:[
+ tmp := ' is a selector implemented in '.
+ (count == 1) ifTrue:[
+ ^ string , tmp , (list at:1) , '.'
+ ].
+ (count == 2) ifTrue:[
+ ^ string , tmp , (list at:1) , ' and ' , (list at:2) , '.'
+ ].
+ (count == 3) ifTrue:[
+ ^ string , tmp , '
+' , (list at:1) , ', ' , (list at:2) , ' and ' , (list at:3) , '.'
+ ].
+ (count == 4) ifTrue:[
+ ^ string , tmp , '
+' , (list at:1) , ', ' , (list at:2) , ', ' , (list at:3), ' and ' , (list at:4) , '.'
+ ].
+ ^ string , tmp , count printString , ' classes.'
+ ]
+ ].
+
+ "try for some obvious things"
+ tmp := self explainPseudoVariable:string in:aClass.
+ tmp notNil ifTrue:[ ^ tmp].
+
+ "try syntax ..."
+
+ ((string = ':=') or:[string = '_']) ifTrue:[
+ ^ '<variable> := <expression>
+
+:= and _ (which is left-arrow in some fonts) mean assignment.
+The variable is bound to (i.e. points to) the value of <expression>.'
+ ].
+
+ (string = '^') ifTrue:[
+ ^ '^ <expression>
+
+return the value of <expression> as value from the method.
+A return from within a block exits the method where the block is defined.'
+ ].
+
+ (string = '|') ifTrue:[
+ ^ '| locals | or: [:arg | statements]
+
+| is used to mark a local variable declaration or separates arguments
+from the statements in a block. Notice, that in a block-argument declaration
+these must be prefixed by a colon character.
+| is also a selector understood by Booleans.'
+ ].
+
+ ((string startsWith:'(') or:[string endsWith:')']) ifTrue:[
+ ^ '(<expression>)
+
+expression grouping.'
+ ].
+
+ ((string startsWith:'[') or:[string endsWith:']']) ifTrue:[
+ ^ '[arguments | statements]
+
+defines a block.
+Blocks represent pieces of executable code. Definition of a block does
+not evaluate it. The block is evaluated by sending it a value/value:
+message.
+Blocks are often passed as arguments to Booleans (i.e. ifTrue:[...]) or
+collections (i.e. do:[...]).'
+ ].
+
+ string knownAsSymbol ifTrue:[
+ ^ string , ' is known as a symbol.
+
+Symbols are unique strings, meaning that there exists
+exactly one instance of a given symbol. Therefore symbols can
+be compared using == (identity compare) instead of = (contents compare).'
+ ].
+
+ (string startsWith:'#' ) ifTrue:[
+ (string startsWith:'#(' ) ifTrue:[
+ ^ 'is a constant Array.
+
+The elements of a constant Array must be Number-constants, nil, true or false.
+(notice, that not all smalltalk implementations allow true, false and nil as
+ constant-Array elements).'
+ ].
+
+ (string startsWith:'#[') ifTrue:[
+ ^ 'is a constant ByteArray.
+
+The elements of a constant ByteArray must be Integer constants in the range
+0 .. 255.
+(notice, that not all smalltalk implementations support constant ByteArrays).'
+ ].
+
+ ^ 'is a symbol.
+
+Symbols are unique strings, meaning that there exists
+exactly one instance of a given symbol. Therefore symbols can
+be compared using == (identity compare) instead of = (contents compare).'
+ ].
+
+ parser isNil ifTrue:[
+ ^ 'parse error -no explanation'
+ ].
+ ^ 'cannot explain this - select individual tokens for an explanation.'
+!
+
+explainPseudoVariable:string in:aClass
+ "return explanation for the pseudoVariables self, super etc."
+
+ (string = 'self') ifTrue:[
+ ^ 'self refers to the object which received the message.
+
+In this case, it will be an instance of ' , aClass name , '
+or one of its subclasses.'
+ ].
+
+ (string = 'super') ifTrue:[
+ ^ 'like self, super refers to the object which received the message.
+
+However, when sending a message to super the search for methods
+implementing this message will start in the superclass (' , aClass superclass name , ')
+instead of selfs class.'
+ ].
+
+ (string = 'true') ifTrue:[
+ ^ 'true is a pseudo variable (i.e. it is built in).
+
+True represents logical truth. It is the one and only instance of class True.'
+ ].
+
+ (string = 'thisContext') ifTrue:[
+ ^ 'thisContext is a pseudo variable (i.e. it is built in).
+
+ThisContext always refers to the context object for the currently executed Method or
+Block (an instance of Context or BlockContext respectively). The calling chain and calling
+selectors can be accessed via thisContext.'
+ ].
+
+ (string = 'false') ifTrue:[
+ ^ 'false is a pseudo variable (i.e. it is built in).
+
+False represents logical falseness. It is the one and only instance of class False.'
+ ].
+
+ (string = 'nil') ifTrue:[
+ ^ 'nil is a pseudo variable (i.e. it is built in).
+
+Nil is used for unitialized variables (among other uses).
+Nil is the one and only instance of class UndefinedObject.'
+ ].
+ ^ nil
+! !
+
+!Parser methodsFor:'ST-80 compatibility'!
+
+evaluate:aString in:aClass to:to notifying:aRequestor ifFail:failBlock
+ |parseTree|
+
+ aString isNil ifTrue:[^ nil].
+ self initializeFor:(ReadStream on:aString).
+ self setClassToCompileFor:aClass.
+ selfValue := nil.
+ requestor := aRequestor.
+
+ self nextToken.
+ parseTree := self parseMethodBody.
+ (errorFlag or:[tree == #Error]) ifTrue:[^ #Error].
+ parseTree notNil ifTrue:[
+ self evalExitBlock:[:value | ^ failBlock value].
+ ^ parseTree evaluate
+ ].
+ ^ nil
+! !
+
+!Parser class methodsFor:'changes'!
+
+update:aClass
+ "aClass has changed its definition - flush name caches if we have to"
+
+ (aClass == prevClass) ifTrue:[
+ prevClass := nil.
+ prevInstVarNames := nil.
+ prevClassVarNames := nil.
+ prevClassInstVarNames := nil.
+ aClass removeDependent:Parser
+ ]
+! !
+
+!Parser methodsFor:'setup'!
+
+setClassToCompileFor:aClass
+ "set the class to be used for parsing/evaluating"
+
+ classToCompileFor := aClass.
+ (classToCompileFor ~~ prevClass) ifTrue:[
+ prevClass notNil ifTrue:[
+ Parser update:prevClass
+ ]
+ ]
+!
+
+setSelf:anObject
+ "set the value to be used for self while evaluating"
+
+ selfValue := anObject.
+ classToCompileFor := anObject class.
+ (classToCompileFor ~~ prevClass) ifTrue:[
+ prevClass notNil ifTrue:[
+ Parser update:prevClass
+ ]
+ ]
+!
+
+setContext:aContext
+ "set the context used while evaluating"
+
+ contextToEvaluateIn := aContext
+! !
+
+!Parser methodsFor:'accessing'!
+
+tree
+ "return the parsetree"
+
+ ^tree
+!
+
+tree:aTree
+ tree := aTree
+!
+
+selector
+ "return the selector"
+
+ ^ selector
+!
+
+primitiveNumber
+ "return the primitiveNumber"
+
+ ^ primNr
+!
+
+numberOfMethodArgs
+ "return the number of methodargs"
+
+ ^ methodArgs size
+!
+
+methodArgs
+ "return an array with methodarg names"
+
+ ^ methodArgNames
+!
+
+numberOfMethodVars
+ "return the number of method variables"
+
+ ^ methodVars size
+!
+
+methodVars
+ "return a collection with method variablenames"
+
+ ^ methodVarNames
+!
+
+usedInstVars
+ "return a collection with instvariablenames refd by method"
+
+ ^ usedInstVars
+!
+
+usedClassVars
+ "return a collection with classvariablenames refd by method"
+
+ ^ usedClassVars
+!
+
+modifiedInstVars
+ "return a collection with instvariablenames modified by method"
+
+ ^ modifiedInstVars
+!
+
+modifiedClassVars
+ "return a collection with classvariablenames modified by method"
+
+ ^ modifiedClassVars
+!
+
+errorFlag
+ ^ errorFlag
+!
+
+evalExitBlock:aBlock
+ "when evaluating a return expression, this block is evaluated"
+
+ evalExitBlock := aBlock
+! !
+
+!Parser methodsFor:'error handling'!
+
+showErrorMessage:aMessage position:pos
+ Transcript show:(pos printString).
+ Transcript show:' '.
+ selector notNil ifTrue:[
+ Transcript show:aMessage.
+ Transcript showCr:(' in ' , selector)
+ ] ifFalse:[
+ Transcript showCr:aMessage
+ ]
+!
+
+parseError:aMessage position:position to:endPos
+ "report a syntax error"
+
+ |m|
+
+ errorFlag := true.
+ m := ' Error:' , aMessage.
+ self notifyError:m position:position to:endPos.
+ exitBlock notNil ifTrue:[exitBlock value].
+ ^ false
+!
+
+parseError:aMessage position:position
+ "report a syntax error"
+
+ ^ self parseError:aMessage position:position to:nil
+!
+
+parseError:aMessage
+ "report a syntax error"
+
+ ^ self parseError:aMessage position:tokenPosition to:nil
+!
+
+selectorCheck:aSelectorString position:pos to:pos2
+ aSelectorString knownAsSymbol ifFalse:[
+ self warning:(aSelectorString , ' is currently nowhere implemented')
+ position:pos to:pos2
+ ]
+!
+
+correctableError:message position:pos1 to:pos2
+ "report an error which can be corrected by compiler"
+
+ |correctIt|
+
+ requestor isNil ifTrue:[
+ self showErrorMessage:message position:pos1.
+ correctIt := false
+ ] ifFalse:[
+ correctIt := requestor correctableError:message position:pos1 to:pos2
+ ].
+ correctIt ifFalse:[
+ exitBlock notNil ifTrue:[exitBlock value]
+ ].
+ ^ correctIt
+!
+
+undefError:aName position:pos1 to:pos2
+ "report an undefined variable error"
+
+ ^ self correctableError:('Error: ' , aName , ' is undefined')
+ position:pos1 to:pos2
+!
+
+exitWith:something
+ "this is the longjump out of evaluation via a return expression"
+
+ evalExitBlock value:something
+! !
+
+!Parser methodsFor:'parsing'!
+
+parseMethod
+ "parse a method"
+
+ |parseTree|
+
+ self nextToken.
+ (self parseMethodSpec == #Error) ifTrue:[^ #Error].
+ parseTree := self parseMethodBody.
+ (parseTree == #Error) ifFalse:[
+ self tree:parseTree
+ ].
+ ^ parseTree
+!
+
+parseMethodSpec
+ "parse a methods selector & arg specification;
+ set selector and methodArgs as a side effect"
+
+ |var|
+
+ (tokenType == #Keyword) ifTrue:[
+ selector := ''.
+ [tokenType == #Keyword] whileTrue:[
+ selector := selector , tokenName.
+ self nextToken.
+ (tokenType ~~ #Identifier) ifTrue:[^ #Error].
+ var := Variable name:tokenName.
+ methodArgs isNil ifTrue:[
+ methodArgs := Array with:var.
+ methodArgNames := Array with:tokenName
+ ] ifFalse:[
+ methodArgs := methodArgs copyWith:var.
+ methodArgNames := methodArgNames copyWith:tokenName
+ ].
+ self nextToken
+ ].
+ selector := selector asSymbol.
+ ^ self
+ ].
+ (tokenType == #Identifier) ifTrue:[
+ selector := tokenName asSymbol.
+ self nextToken.
+ ^ self
+ ].
+ (tokenType == #BinaryOperator) ifTrue:[
+ selector := tokenName asSymbol.
+ self nextToken.
+ (tokenType ~~ #Identifier) ifTrue:[^ #Error].
+ var := Variable name:tokenName.
+ methodArgs isNil ifTrue:[
+ methodArgs := Array with:var.
+ methodArgNames := Array with:tokenName
+ ] ifFalse:[
+ methodArgs := methodArgs copyWith:var.
+ methodArgNames := methodArgNames copyWith:tokenName
+ ].
+ self nextToken.
+ ^ self
+ ].
+ ^ #Error
+!
+
+parseMethodBodyOrNil
+ "parse a methods body (locals & statements);
+ return a node-tree, nil or #Error. empty (or comment only) input
+ is accepted and returns nil"
+
+ |stats|
+
+ ((tokenType == #BinaryOperator) and:[tokenName = '<']) ifTrue:[
+ "an ST-80 primitive - parsed but ignored"
+ self nextToken.
+ primNr := self parsePrimitive.
+ (primNr == #Error) ifTrue:[^ #Error].
+ self warning:'ST-80 primitives not supported - ignored'
+ ].
+
+ (self parseMethodBodyVarSpec == #Error) ifTrue:[^ #Error].
+
+ (tokenType ~~ #EOF) ifTrue:[
+ stats := self statementList
+ ].
+ ^ stats
+!
+
+parseMethodBody
+ "parse a methods body (locals & statements); no more token may follow
+ return a node-tree, nil or #Error"
+
+ |stats|
+
+ stats := self parseMethodBodyOrNil.
+ (stats == #Error) ifFalse:[
+ (tokenType ~~ #EOF) ifTrue:[
+ self parseError:(tokenType printString , ' unexpected').
+ ^#Error
+ ]
+ ].
+ ^ stats
+!
+
+parseMethodBodyVarSpec
+ "parse a methods local variable specification"
+
+ |var|
+
+ (tokenType == $|) ifTrue:[
+ "memorize position for declaration in correction"
+ localVarDefPosition := tokenPosition.
+ self nextToken.
+ [tokenType == #Identifier] whileTrue:[
+ var := Variable name:tokenName.
+ methodVars isNil ifTrue:[
+ methodVars := Array with:var.
+ methodVarNames := Array with:tokenName
+ ] ifFalse:[
+ methodVars := methodVars copyWith:var.
+ methodVarNames := methodVarNames copyWith:tokenName
+ ].
+ self nextToken
+ ].
+ (tokenType ~~ $|) ifTrue:[
+ self syntaxError:'error in local var specification; | expected.'.
+ ^ #Error
+ ].
+ self nextToken
+ ].
+ ^ nil
+!
+
+parsePrimitive
+ "parse an ST-80 type primitive;
+ return primitive number or #Error"
+
+ |primNumber|
+
+ ((tokenType == #Keyword) and:[tokenName = 'primitive:']) ifFalse:[
+ self parseError:'bad primitive definition (primitive: expected)'.
+ ^ #Error
+ ].
+ self nextToken.
+ (tokenType == #Integer) ifFalse:[
+ self parseError:'primitive number expected'.
+ ^ #Error
+ ].
+ primNumber := tokenValue.
+ self nextToken.
+ ((tokenType == #BinaryOperator) and:[tokenName = '>']) ifFalse:[
+ self parseError:'bad primitive definition (> expected)'.
+ ^ #Error
+ ].
+ self nextToken.
+ ^ primNumber
+!
+
+statementList
+ "parse a statementlist; return a node-tree, nil or #Error.
+ Statements must be separated by periods."
+
+ |thisStatement prevStatement firstStatement correctIt periodPos|
+
+ thisStatement := self statement.
+ (thisStatement == #Error) ifTrue:[^ #Error].
+ firstStatement := thisStatement.
+ [tokenType == $.] whileTrue:[
+ periodPos := tokenPosition.
+ self nextToken.
+ (tokenType == $]) ifTrue:[
+ currentBlock isNil ifTrue:[
+ self parseError:'block nesting error'.
+ errorFlag := true
+"
+ *** I had a warning here (since it was not defined
+ *** in the blue-book; but PD-code contains a lot of
+ *** code with periods at the end so that the warnings
+ *** became annoying
+
+ ] ifFalse:[
+ self warning:'period after last statement' position:periodPos
+"
+ ].
+ ^ firstStatement
+ ].
+ (tokenType == #EOF) ifTrue:[
+ currentBlock notNil ifTrue:[
+ self parseError:'block nesting error'.
+ errorFlag := true
+"
+ *** I had a warning here (since it was not defined
+ *** in the blue-book; but PD-code contains a lot of
+ *** code with periods at the end so that the warnings
+ *** became annoying
+
+ ] ifFalse:[
+ self warning:'period after last statement' position:periodPos
+"
+ ].
+ ^ firstStatement
+ ].
+
+ prevStatement := thisStatement.
+ (prevStatement isKindOf:ReturnNode) ifTrue:[
+ self warning:'statements after return' position:tokenPosition
+ ].
+"
+ periodPos := tokenPosition.
+ self nextToken.
+"
+
+ ((tokenType == $]) or:[tokenType == #EOF]) ifTrue:[
+ (currentBlock isNil and:[tokenType == $]]) ifTrue:[
+ self parseError:'block nesting error'.
+ errorFlag := true
+ ] ifFalse:[
+ correctIt := self correctableError:'period after last statement in block'
+ position:periodPos to:(periodPos + 1).
+ correctIt ifTrue:[
+ (self correctByDeleting == #Error) ifTrue:[
+ errorFlag := true
+ ]
+ ]
+ ].
+ ^ firstStatement
+ ].
+ thisStatement := self statement.
+ (thisStatement == #Error) ifTrue:[^ #Error].
+ prevStatement nextStatement:thisStatement
+ ].
+ ^ firstStatement
+!
+
+statement
+ "parse a statement; return a node-tree, nil or #Error"
+
+ |expr node|
+
+ (tokenType == $^) ifTrue:[
+ self nextToken.
+ expr := self expression.
+ (expr == #Error) ifTrue:[^ #Error].
+ node := ReturnNode expression:expr.
+ node home:self blockHome:currentBlock.
+ ^ node
+ ].
+ (tokenType == #Primitive) ifTrue:[
+ self parseError:'cannot compile primitives (yet)'.
+ self nextToken.
+ ^ PrimitiveNode code:''
+ ].
+ (tokenType == #EOF) ifTrue:[
+ self syntaxError:'period after last statement'.
+ ^ #Error
+ ].
+ expr := self expression.
+"
+ classToCompileFor notNil ifTrue:[
+ currentBlock isNil ifTrue:[
+ (expr isKindOf:PrimaryNode) ifTrue:[
+ self warning:'useless computation - missing ^ ?'
+ ]
+ ]
+ ].
+"
+ (expr == #Error) ifTrue:[^ #Error].
+ ^ StatementNode expression:expr
+!
+
+expression
+ "parse a cascade-expression; return a node-tree, nil or #Error"
+
+ |receiver arg sel args pos pos2|
+
+ receiver := self keywordExpression.
+ (receiver == #Error) ifTrue:[^ #Error].
+ [tokenType == $;] whileTrue:[
+ self nextToken.
+ (tokenType == #Identifier) ifTrue:[
+ sel := tokenName.
+ self selectorCheck:sel position:tokenPosition
+ to:(tokenPosition + sel size - 1).
+ receiver := CascadeNode receiver:receiver
+ selector:sel.
+ self nextToken
+ ] ifFalse:[
+ (tokenType == #BinaryOperator) ifTrue:[
+ sel := tokenName.
+ self selectorCheck:sel position:tokenPosition
+ to:(tokenPosition + sel size - 1).
+ self nextToken.
+ arg := self unaryExpression.
+ (arg == #Error) ifTrue:[^ #Error].
+ receiver := CascadeNode receiver:receiver
+ selector:sel
+ arg:arg
+ ] ifFalse:[
+ (tokenType == #Keyword) ifTrue:[
+ pos := tokenPosition.
+ sel := tokenName.
+ self nextToken.
+ arg := self binaryExpression.
+ (arg == #Error) ifTrue:[^ #Error].
+ args := Array with:arg.
+ [tokenType == #Keyword] whileTrue:[
+ sel := sel , tokenName.
+ self nextToken.
+ arg := self binaryExpression.
+ (arg == #Error) ifTrue:[^ #Error].
+ args := args copyWith:arg.
+ pos2 := tokenPosition
+ ].
+ self selectorCheck:sel position:pos to:pos2.
+ receiver := CascadeNode receiver:receiver
+ selector:sel
+ args:args
+ ] ifFalse:[
+ (tokenType == #Error) ifTrue:[^ #Error].
+ self syntaxError:('invalid cascade; '
+ , tokenType printString
+ , ' unexpected').
+ ^ #Error
+ ]
+ ]
+ ]
+ ].
+ ^ receiver
+!
+
+keywordExpression
+ "parse a keyword-expression; return a node-tree, nil or #Error"
+
+ |receiver sel arg args pos1 pos2 try lno|
+
+ receiver := self binaryExpression.
+ (receiver == #Error) ifTrue:[^ #Error].
+ (tokenType == #Keyword) ifTrue:[
+ pos1 := tokenPosition.
+ sel := tokenName.
+ lno := tokenLineNr.
+ self nextToken.
+ arg := self binaryExpression.
+ (arg == #Error) ifTrue:[^ #Error].
+ args := Array with:arg.
+ [tokenType == #Keyword] whileTrue:[
+ sel := sel , tokenName.
+ self nextToken.
+ arg := self binaryExpression.
+ (arg == #Error) ifTrue:[^ #Error].
+ args := args copyWith:arg.
+ pos2 := tokenPosition
+ ].
+ self selectorCheck:sel position:pos1 to:pos2.
+ try := MessageNode receiver:receiver selector:sel args:args.
+ (try isMemberOf:String) ifTrue:[
+ self parseError:try position:pos1 to:pos2.
+ receiver := MessageNode receiver:receiver selector:sel args:args
+ fold:false
+ ] ifFalse:[
+ receiver := try
+ ].
+ receiver lineNumber:lno
+ ].
+ ^ receiver
+!
+
+binaryExpression
+ "parse a binary-expression; return a node-tree, nil or #Error"
+
+ |receiver arg sel pos try lno note|
+
+ receiver := self unaryExpression.
+ (receiver == #Error) ifTrue:[^ #Error].
+
+ "special kludge: since Scanner cannot know if -digit is a binary
+ expression or a negative constant, handle cases here"
+
+ [(tokenType == #BinaryOperator) or:[(tokenType == $|)
+ or:[(tokenType == #Integer) and:[tokenValue < 0]]]] whileTrue:[
+ pos := tokenPosition.
+
+ lno := tokenLineNr.
+
+ "kludge here: bar and minus are not scanned as binop "
+ (tokenType == $|) ifTrue:[
+ sel := '|'.
+ self nextToken
+ ] ifFalse:[
+ (tokenType == #BinaryOperator) ifTrue:[
+ sel := tokenName.
+ self selectorCheck:sel position:tokenPosition
+ to:(tokenPosition + sel size - 1).
+ self nextToken
+ ] ifFalse:[
+ sel := '-'.
+ tokenValue := tokenValue negated
+ ]
+ ].
+ arg := self unaryExpression.
+ (arg == #Error) ifTrue:[^ #Error].
+ try := BinaryNode receiver:receiver selector:sel arg:arg.
+ (try isMemberOf:String) ifTrue:[
+ self parseError:try position:pos to:tokenPosition.
+ receiver := BinaryNode receiver:receiver selector:sel arg:arg
+ fold:false
+ ] ifFalse:[
+ receiver := try
+ ].
+ note := receiver plausibilityCheck.
+ note notNil ifTrue:[
+ self warning:note position:pos to:tokenPosition
+ ].
+ receiver lineNumber:lno
+ ].
+ ^ receiver
+!
+
+unaryExpression
+ "parse a unary-expression; return a node-tree, nil or #Error"
+
+ |receiver sel pos try|
+
+ receiver := self primary.
+ (receiver == #Error) ifTrue:[^ #Error].
+ [tokenType == #Identifier] whileTrue:[
+ pos := tokenPosition.
+ sel := tokenName.
+ self selectorCheck:sel position:tokenPosition
+ to:(tokenPosition + sel size - 1).
+ try := UnaryNode receiver:receiver selector:sel.
+ (try isMemberOf:String) ifTrue:[
+ self warning:try position:pos to:(tokenPosition + sel size - 1).
+ receiver := UnaryNode receiver:receiver selector:sel fold:false
+ ] ifFalse:[
+ receiver := try
+ ].
+ receiver lineNumber:tokenLineNr.
+ self nextToken.
+ ].
+ ^ receiver
+!
+
+primary
+ "parse a primary-expression; return a node-tree, nil or #Error"
+
+ |val var expr pos name|
+
+ pos := tokenPosition.
+ (tokenType == #Identifier) ifTrue:[
+ var := self variable.
+ (var == #Error) ifTrue:[
+ errorFlag := true
+ ].
+ self nextToken.
+ (tokenType == $_) ifFalse:[
+ ^ var
+ ].
+ (var ~~ #Error) ifTrue:[
+ (var type == #MethodArg) ifTrue:[
+ self parseError:'assignment to method argument' position:pos to:tokenPosition.
+ errorFlag := true
+ ].
+ (var type == #BlockArg) ifTrue:[
+ self parseError:'assignment to block argument' position:pos to:tokenPosition.
+ errorFlag := true
+ ].
+
+ (var type == #InstanceVariable) ifTrue:[
+ modifiedInstVars isNil ifTrue:[
+ modifiedInstVars := OrderedCollection new
+ ].
+ name := prevInstVarNames at:(var index).
+ (modifiedInstVars includes:name) ifFalse:[
+ modifiedInstVars add:name
+ ]
+ ] ifFalse:[
+ (var type == #ClassVariable) ifTrue:[
+ modifiedClassVars isNil ifTrue:[
+ modifiedClassVars := OrderedCollection new
+ ].
+ name := var name.
+ name := name copyFrom:((name indexOf:$:) + 1).
+ (modifiedClassVars includes:name) ifFalse:[
+ modifiedClassVars add:name
+ ]
+ ]
+ ]
+ ].
+
+ self nextToken.
+ expr := self expression.
+ (errorFlag or:[expr == #Error]) ifTrue:[^ #Error].
+ ^ AssignmentNode variable:var expression:expr
+ ].
+ ((tokenType == #Integer) or:
+ [(tokenType == #Character) or:
+ [tokenType == #Float]]) ifTrue:[
+ val := ConstantNode type:tokenType value:tokenValue.
+ self nextToken.
+ (tokenType == $_) ifTrue:[
+ self parseError:'assignment to a constant' position:pos to:tokenPosition.
+ ^ #Error
+ ].
+ ^ val
+ ].
+ (tokenType == #String) ifTrue:[
+ val := ConstantNode type:tokenType value:tokenValue.
+ self nextToken.
+ (tokenType == $_) ifTrue:[
+ self parseError:'assignment to a constant' position:pos to:tokenPosition.
+ ^ #Error
+ ].
+ ^ val
+ ].
+ (tokenType == #Symbol) ifTrue:[
+ val := ConstantNode type:tokenType value:tokenValue.
+ self nextToken.
+ (tokenType == $_) ifTrue:[
+ self parseError:'assignment to a constant' position:pos to:tokenPosition.
+ ^ #Error
+ ].
+ ^ val
+ ].
+ (tokenType == #Nil) ifTrue:[
+ self nextToken.
+ (tokenType == $_) ifTrue:[
+ self parseError:'assignment to nil' position:pos to:tokenPosition.
+ ^ #Error
+ ].
+ ^ ConstantNode type:#Nil value:nil
+ ].
+ (tokenType == #True) ifTrue:[
+ self nextToken.
+ (tokenType == $_) ifTrue:[
+ self parseError:'assignment to true' position:pos to:tokenPosition.
+ ^ #Error
+ ].
+ ^ ConstantNode type:#True value:true
+ ].
+ (tokenType == #False) ifTrue:[
+ self nextToken.
+ (tokenType == $_) ifTrue:[
+ self parseError:'assignment to false' position:pos to:tokenPosition.
+ ^ #Error
+ ].
+ ^ ConstantNode type:#False value:false
+ ].
+ (tokenType == #Self) ifTrue:[
+ self nextToken.
+ (tokenType == $_) ifTrue:[
+ self parseError:'assignment to self' position:pos to:tokenPosition.
+ ^ #Error
+ ].
+ selfNode isNil ifTrue:[
+ selfNode := PrimaryNode type:#Self value:selfValue
+ ].
+ ^ selfNode
+ ].
+ (tokenType == #Super) ifTrue:[
+ self nextToken.
+ (tokenType == $_) ifTrue:[
+ self parseError:'assignment to super' position:pos to:tokenPosition.
+ ^ #Error
+ ].
+ superNode isNil ifTrue:[
+ superNode := PrimaryNode type:#Super value:selfValue
+ ].
+ ^ superNode
+ ].
+ (tokenType == #ThisContext) ifTrue:[
+ self nextToken.
+ (tokenType == $_) ifTrue:[
+ self parseError:'assignment to thisContext' position:pos to:tokenPosition.
+ ^ #Error
+ ].
+ ^ PrimaryNode type:#ThisContext value:nil
+ ].
+ (tokenType == #HashLeftParen) ifTrue:[
+ self nextToken.
+ val := self array.
+ self nextToken.
+ ^ ConstantNode type:#Array value:val
+ ].
+ (tokenType == #HashLeftBrack) ifTrue:[
+ self nextToken.
+ val := self byteArray.
+ self nextToken.
+ ^ ConstantNode type:#Array value:val
+ ].
+ (tokenType == $() ifTrue:[
+ self nextToken.
+ val := self expression.
+ (val == #Error) ifTrue:[^ #Error].
+ (tokenType ~~ $) ) ifTrue:[
+ (tokenType isMemberOf:Character) ifTrue:[
+ self syntaxError:'missing '')'' (i.e. ''' , tokenType asString , ''' unexpected)' withCRs position:pos to:tokenPosition.
+ ] ifFalse:[
+ self syntaxError:'missing '')''' position:pos to:tokenPosition.
+ ].
+ ^ #Error
+ ].
+ self nextToken.
+ ^ val
+ ].
+ (tokenType == $[ ) ifTrue:[
+ val := self block.
+ self nextToken.
+ ^ val
+ ].
+ (tokenType == #Error) ifTrue:[^ #Error].
+ (tokenType isKindOf:Character) ifTrue:[
+ self syntaxError:('error in primary; '
+ , tokenType printString ,
+ ' unexpected') position:tokenPosition to:tokenPosition
+ ] ifFalse:[
+ self syntaxError:('error in primary; '
+ , tokenType printString ,
+ ' unexpected')
+ ].
+ ^ #Error
+!
+
+variableOrError
+ "parse a variable; return a node-tree, nil or #Error"
+
+ |tokenFound var instIndex aClass searchBlock args vars
+ varName tokenSymbol theBlock className
+ runIndex "{ Class: SmallInteger }" |
+
+ varName := tokenName.
+
+ "is it a block-arg or block-var ?"
+ searchBlock := currentBlock.
+ [searchBlock notNil] whileTrue:[
+ runIndex := 1.
+ args := searchBlock arguments.
+ args notNil ifTrue:[
+ args do:[:aBlockArg |
+ (aBlockArg name = varName) ifTrue:[
+ tokenFound := aBlockArg.
+ instIndex := runIndex.
+ theBlock := searchBlock
+ ].
+ runIndex := runIndex + 1
+ ].
+ tokenFound notNil ifTrue:[
+ ^ PrimaryNode type:#BlockArg
+ name:varName
+ token:tokenFound
+ index:instIndex
+ block:theBlock
+ ]
+ ].
+
+ runIndex := 1.
+ vars := searchBlock variables.
+ vars notNil ifTrue:[
+ vars do:[:aBlockVar |
+ (aBlockVar name = varName) ifTrue:[
+ tokenFound := aBlockVar.
+ instIndex := runIndex.
+ theBlock := searchBlock
+ ].
+ runIndex := runIndex + 1
+ ].
+ tokenFound notNil ifTrue:[
+ ^ PrimaryNode type:#BlockVariable
+ name:varName
+ token:tokenFound
+ index:instIndex
+ block:theBlock
+ ]
+ ].
+ searchBlock := searchBlock home
+ ].
+
+ "is it a method-variable ?"
+ methodVars notNil ifTrue:[
+ instIndex := methodVarNames indexOf:varName.
+ (instIndex ~~ 0) ifTrue:[
+ var := methodVars at:instIndex.
+ var used:true.
+ ^ PrimaryNode type:#MethodVariable
+ name:varName
+ token:var
+ index:instIndex
+ ]
+ ].
+
+ "is it a method-argument ?"
+ methodArgs notNil ifTrue:[
+ instIndex := methodArgNames indexOf:varName.
+ (instIndex ~~ 0) ifTrue:[
+ ^ PrimaryNode type:#MethodArg
+ name:varName
+ token:(methodArgs at:instIndex)
+ index:instIndex
+ ]
+ ].
+
+ "is it an instance-variable ?"
+ classToCompileFor notNil ifTrue:[
+ "caching allInstVarNames for next compilation saves time ..."
+
+ (prevInstVarNames isNil or:[prevClass ~~ classToCompileFor]) ifTrue:[
+ prevClass notNil ifTrue:[
+ prevClass removeDependent:Parser
+ ].
+ prevClass := classToCompileFor.
+ prevInstVarNames := classToCompileFor allInstVarNames.
+ prevClassInstVarNames := nil.
+ prevClassVarNames := nil.
+ prevClass addDependent:Parser
+ ].
+
+ instIndex := prevInstVarNames indexOf:varName startingAt:1
+ ifAbsent:[nil].
+ instIndex notNil ifTrue:[
+ usedInstVars isNil ifTrue:[
+ usedInstVars := OrderedCollection new
+ ].
+ (usedInstVars includes:varName) ifFalse:[
+ usedInstVars add:varName
+ ].
+ ^ PrimaryNode type:#InstanceVariable
+ name:varName
+ index:instIndex
+ selfValue:selfValue
+ ]
+ ].
+
+ "is it a class-instance-variable ?"
+ classToCompileFor notNil ifTrue:[
+ prevClassInstVarNames isNil ifTrue:[
+ prevClassInstVarNames := classToCompileFor class allInstVarNames
+ ].
+
+ instIndex := prevClassInstVarNames indexOf:varName startingAt:1
+ ifAbsent:[nil].
+
+ instIndex notNil ifTrue:[
+ aClass := self inWhichClassIsClassInstVar:varName.
+ aClass notNil ifTrue:[
+ ^ PrimaryNode type:#ClassInstanceVariable
+ name:varName
+ index:instIndex
+ selfValue:selfValue
+ ]
+ ]
+ ].
+
+ "is it a class-variable ?"
+ classToCompileFor notNil ifTrue:[
+ prevClassVarNames isNil ifTrue:[
+ aClass := classToCompileFor.
+ classToCompileFor isMeta ifTrue:[
+ className := aClass name.
+ className := className copyFrom:1 to:(className size - 5).
+ aClass := Smalltalk at:(className asSymbol).
+ aClass isNil ifTrue:[
+ aClass := classToCompileFor
+ ]
+ ].
+ prevClassVarNames := aClass allClassVarNames
+ ].
+
+ instIndex := prevClassVarNames indexOf:varName startingAt:1
+ ifAbsent:[nil].
+
+ instIndex notNil ifTrue:[
+ aClass := self inWhichClassIsClassVar:varName.
+ aClass notNil ifTrue:[
+ usedClassVars isNil ifTrue:[
+ usedClassVars := OrderedCollection new
+ ].
+ (usedClassVars includes:varName) ifFalse:[
+ usedClassVars add:varName
+ ].
+ ^ PrimaryNode type:#ClassVariable
+ name:(aClass name , ':' , varName) asSymbol
+ ]
+ ]
+ ].
+
+ "is it a global-variable ?"
+ tokenSymbol := varName asSymbol.
+ (Smalltalk includesKey:tokenSymbol) ifTrue:[
+ ^ PrimaryNode type:#GlobalVariable
+ name:tokenSymbol
+ ].
+ ^ #Error
+!
+
+variable
+ "parse a variable; if undefined, notify error and correct if user wants to"
+
+ |v|
+
+ v := self variableOrError.
+ (v == #Error) ifFalse:[^ v].
+ v := self correctVariable.
+ (v == #Error) ifFalse:[^ v].
+ ^ PrimaryNode type:#GlobalVariable
+ name:tokenName asSymbol
+!
+
+inWhichClassIsClassVar:aString
+ "search class-chain for the classvariable named aString
+ - return the class or nil if not found"
+
+ |aClass className baseClass|
+
+ aClass := classToCompileFor.
+ aClass isMeta ifTrue:[
+ className := aClass name.
+ className := className copyFrom:1 to:(className size - 5).
+ baseClass := Smalltalk at:(className asSymbol).
+ baseClass notNil ifTrue:[
+ aClass := baseClass
+ ]
+ ].
+ [aClass notNil] whileTrue:[
+ (aClass classVarNames includes:aString) ifTrue:[ ^ aClass].
+ aClass := aClass superclass
+ ].
+ ^ nil
+!
+
+inWhichClassIsClassInstVar:aString
+ "search class-chain for the class-instance variable named aString
+ - return the class or nil if not found"
+
+ |aClass|
+
+ aClass := classToCompileFor.
+ [aClass notNil] whileTrue:[
+ (aClass class instVarNames includes:aString) ifTrue:[ ^ aClass].
+ aClass := aClass superclass
+ ].
+ ^ nil
+!
+
+block
+ "parse a block; return a node-tree, nil or #Error"
+
+ |stats node args var vars pos|
+
+ self nextToken.
+ (tokenType == $: ) ifTrue:[
+ [tokenType == $:] whileTrue:[
+ pos := tokenPosition.
+ self nextToken.
+ (tokenType == #Identifier) ifFalse:[
+ self syntaxError:'Identifier expected in block-arg declaration'
+ position:pos to:tokenPosition-1.
+ ^ #Error
+ ].
+ var := Variable name:tokenName.
+ args isNil ifTrue:[
+ args := Array with:var
+ ] ifFalse:[
+ args := args copyWith:var
+ ].
+ self nextToken
+ ].
+ (tokenType ~~ $| ) ifTrue:[
+ "ST-80 allows [:arg ]"
+ (tokenType == $] ) ifTrue:[
+ node := BlockNode arguments:args.
+ node home:currentBlock.
+ ^ node
+ ].
+ self syntaxError:'| expected after block-arg declaration'.
+ ^ #Error
+ ].
+ self nextToken
+ ].
+ (tokenType == $| ) ifTrue:[
+ self nextToken.
+ pos := tokenPosition.
+ [tokenType == $|] whileFalse:[
+ (tokenType == #Identifier) ifFalse:[
+ self syntaxError:'Identifier expected in block-var declaration' position:pos.
+ ^ #Error
+ ].
+ var := Variable name:tokenName.
+ vars isNil ifTrue:[
+ vars := Array with:var
+ ] ifFalse:[
+ vars := vars copyWith:var
+ ].
+ self nextToken
+ ].
+ self nextToken
+ ].
+ node := BlockNode arguments:args.
+ node home:currentBlock.
+ node variables:vars.
+ currentBlock := node.
+ stats := self blockStatementList.
+ node statements:stats.
+ currentBlock := node home.
+ (stats == #Error) ifTrue:[^ #Error].
+ ^ node
+!
+
+blockStatementList
+ "parse a blocks statementlist; return a node-tree, nil or #Error"
+
+ |thisStatement prevStatement firstStatement|
+
+ (tokenType == $] ) ifTrue:[^ nil].
+ thisStatement := self statement.
+ (thisStatement == #Error) ifTrue:[^ #Error].
+ firstStatement := thisStatement.
+ [tokenType == $] ] whileFalse:[
+ (tokenType == $.) ifFalse:[
+ (tokenType == #EOF) ifTrue:[
+ self syntaxError:'missing '']'' in block'
+ ] ifFalse:[
+ self syntaxError:'missing ''.'' in block'
+ ].
+ ^ #Error
+ ] ifTrue:[
+ prevStatement := thisStatement.
+ self nextToken.
+ tokenType == $] ifTrue:[
+"
+ *** I had a warning here (since it was not defined
+ *** in the blue-book; but PD-code contains a lot of
+ *** code with periods at the end so that the warnings
+ *** became annoying
+
+ self warning:'period after last statement in block'.
+"
+ ^ firstStatement
+ ].
+ thisStatement := self statement.
+ (thisStatement == #Error) ifTrue:[^ #Error].
+ prevStatement nextStatement:thisStatement
+ ]
+ ].
+ ^ firstStatement
+!
+
+array
+ |arr elem pos1 pos2|
+
+ pos1 := tokenPosition.
+ arr := OrderedCollection new:200.
+ [tokenType ~~ $) ] whileTrue:[
+ elem := self arrayConstant.
+ (elem == #Error) ifTrue:[
+ (tokenType == #EOF) ifTrue:[
+ self syntaxError:'unterminated array-constant; '')'' expected'
+ position:pos1 to:tokenPosition
+ ].
+ ^ #Error
+ ].
+ arr add:elem.
+ self nextToken
+ ].
+ ^ Array withAll:arr
+!
+
+byteArray
+ "for ST-80 R4 - allow byteArray constants"
+ |arr elem pos1 pos2|
+
+ pos1 := tokenPosition.
+ arr := OrderedCollection new.
+ [tokenType ~~ $] ] whileTrue:[
+ pos2 := tokenPosition.
+ elem := self arrayConstant.
+ (elem == #Error) ifTrue:[
+ (tokenType == #EOF) ifTrue:[
+ self syntaxError:'unterminated bytearray-constant; '']'' expected'
+ position:pos1 to:tokenPosition
+ ].
+ ^ #Error
+ ].
+ ((elem isMemberOf:SmallInteger) and:
+ [(elem >= 0) and:[elem <= 255]]) ifTrue:[
+ arr add:elem
+ ] ifFalse:[
+ self parseError:'invalid ByteArray element' position:pos2 to:tokenPosition - 1
+ ].
+ self nextToken
+ ].
+ ^ ByteArray withAll:arr
+!
+
+arrayConstant
+ (tokenType == #String) ifTrue:[
+ ^ tokenValue
+ ].
+ (tokenType == #Nil) ifTrue:[
+ ^ nil
+ ].
+ (tokenType == #Integer) ifTrue:[
+ ^ tokenValue
+ ].
+ (tokenType == #Character) ifTrue:[
+ ^ tokenValue
+ ].
+ (tokenType == #Float) ifTrue:[
+ ^ tokenValue
+ ].
+ (tokenType == #True) ifTrue:[
+ ^ true
+ ].
+ (tokenType == #False) ifTrue:[
+ ^ false
+ ].
+ (tokenType == #Error) ifTrue:[
+ ^ #Error
+ ].
+ (tokenType == #BinaryOperator) ifTrue:[
+ ^ tokenName asSymbol
+ ].
+ (tokenType == #Keyword) ifTrue:[
+ ^ tokenName asSymbol
+ ].
+ (tokenType == #Identifier) ifTrue:[
+ ^ tokenName asSymbol
+ ].
+ (tokenType == $() ifTrue:[
+ self nextToken.
+ ^ self array
+ ].
+ (tokenType == $[) ifTrue:[
+ self nextToken.
+ ^ self byteArray
+ ].
+ (tokenType == #Symbol) ifTrue:[
+"
+ self warning:'no # for symbols within array-constants'.
+"
+ ^ tokenValue
+ ].
+ (tokenType == #HashLeftParen) ifTrue:[
+"
+ self warning:'no # for arrays within array-constants'.
+"
+ self nextToken.
+ ^ self array
+ ].
+ (tokenType == #HashLeftBrack) ifTrue:[
+"
+ self warning:'no # for arrays within array-constants'.
+"
+ self nextToken.
+ ^ self byteArray
+ ].
+ (tokenType == #EOF) ifTrue:[
+ "just for the better error-hilight; let caller handle error"
+ ^ #Error
+ ].
+ self syntaxError:('error in array-constant; '
+ , tokenType printString
+ , ' unexpected').
+ ^ #Error
+! !
+
+!Parser methodsFor:'error correction'!
+
+correctByDeleting
+ "correct (by deleting token) if user wants to;
+ return #Error if there was no correction or nil"
+
+ (self confirm:'confirm deleting') ifFalse:[^ #Error].
+
+ "tell requestor about the change"
+ requestor deleteSelection.
+ ^ nil
+!
+
+findBestVariableFor:aString
+ "collect known variables with their levenshtein distances to aString;
+ return the 10 best suggestions"
+
+ |names dists searchBlock args vars globalVarName aClass className baseClass n|
+
+ names := VariableArray new.
+ dists := VariableArray new.
+
+ "block arguments"
+ searchBlock := currentBlock.
+ [searchBlock notNil] whileTrue:[
+ args := searchBlock arguments.
+ args notNil ifTrue:[
+ args do:[:aBlockArg |
+ names add:(aBlockArg name).
+ dists add:(aString levenshteinTo:(aBlockArg name))
+ ]
+ ].
+
+ vars := searchBlock variables.
+ vars notNil ifTrue:[
+ vars do:[:aBlockVar |
+ names add:(aBlockVar name).
+ dists add:(aString levenshteinTo:(aBlockVar name))
+ ]
+ ].
+ searchBlock := searchBlock home
+ ].
+
+ "method-variables"
+ methodVars notNil ifTrue:[
+ methodVarNames do:[:methodVarName |
+ names add:methodVarName.
+ dists add:(aString levenshteinTo:methodVarName)
+ ]
+ ].
+
+ "method-arguments"
+ methodArgs notNil ifTrue:[
+ methodArgNames do:[:methodArgName |
+ names add:methodArgName.
+ dists add:(aString levenshteinTo:methodArgName)
+ ]
+ ].
+
+ "instance-variables"
+ classToCompileFor notNil ifTrue:[
+ prevInstVarNames do:[:instVarName |
+ names add:instVarName.
+ dists add:(aString levenshteinTo:instVarName)
+ ]
+ ].
+
+ "class-variables"
+ classToCompileFor notNil ifTrue:[
+ aClass := classToCompileFor.
+ aClass isMeta ifTrue:[
+ className := aClass name.
+ className := className copyFrom:1 to:(className size - 5).
+ baseClass := Smalltalk at:(className asSymbol).
+ baseClass notNil ifTrue:[
+ aClass := baseClass
+ ]
+ ].
+ [aClass notNil] whileTrue:[
+ (aClass classVarNames) do:[:classVarName |
+ names add:classVarName.
+ dists add:(aString levenshteinTo:classVarName)
+ ].
+ aClass := aClass superclass
+ ]
+ ].
+
+ "globals"
+ Smalltalk allKeysDo:[:aKey |
+ globalVarName := aKey asString.
+ "only compare strings where length is about right"
+ ((globalVarName size - aString size) abs < 3) ifTrue:[
+ names add:globalVarName.
+ dists add:(aString levenshteinTo:globalVarName)
+ ]
+ ].
+
+ "misc"
+ #('self' 'super' 'nil') do:[:name |
+ "only compare strings where length is about right"
+ ((name size - aString size) abs < 3) ifTrue:[
+ names add:name.
+ dists add:(aString levenshteinTo:name)
+ ]
+ ].
+
+ (dists size ~~ 0) ifTrue:[
+ dists sortWith:names.
+ n := names size min:10.
+ ^ names copyFrom:1 to:n
+ ].
+ ^ nil
+!
+
+correctVariable
+ "notify error and correct if user wants to;
+ return #Error if there was no correction
+ or a ParseNode as returned by variable"
+
+ |correctIt varName suggestedNames newName pos1 pos2|
+
+ pos1 := tokenPosition.
+ varName := tokenName.
+ pos2 := pos1 + varName size - 1.
+ (varName at:1) isLowercase ifTrue:[
+ correctIt := self undefError:varName position:pos1 to:pos2.
+ correctIt ifFalse:[^ #Error]
+ ] ifFalse:[
+ correctIt := self warning:(varName , ' is undefined') position:pos1 to:pos2.
+ correctIt ifFalse:[
+ ^ PrimaryNode type:#GlobalVariable
+ name:(varName asSymbol)
+ ]
+ ].
+
+ suggestedNames := self findBestVariableFor:varName.
+ suggestedNames notNil ifTrue:[
+ newName := self askForVariable:'correct variable to: ' fromList:suggestedNames.
+ newName isNil ifTrue:[^ #Error].
+"
+ newName := suggestedNames at:1.
+ (self confirm:('confirm correction to: ' , newName)) ifFalse:[^ #Error]
+"
+ ] ifFalse:[
+ self notify:'no good correction found'.
+ ^ #Error
+ ].
+
+ "tell requestor about the change"
+ requestor replaceSelectionBy:newName.
+
+ "redo parse with new value"
+ tokenName := newName.
+ ^ self variableOrError
+!
+
+askForVariable:aString fromList:aList
+ "launch a selection box, which allows user to enter correction.
+ return true for yes, false for no"
+
+ |box|
+
+ ListSelectionBox isNil ifTrue:[
+ ^ self confirm:aString
+ ].
+ box := ListSelectionBox new.
+ box title:aString.
+ box initialText:(aList at:1).
+ box list:aList.
+ box okText:'replace'.
+ box abortText:'abort'.
+ box action:[:aString | ^ aString].
+ box showAtPointer.
+ ^ nil
+! !