hg/stx-libcomp: comparison Parser.st

equal deleted inserted replaced

-:0cd4e7480440
+:6c2bc76f0b8f
 usedInstVars usedClassVars usedVars
 modifiedInstVars modifiedClassVars
 localVarDefPosition
 evalExitBlock
 selfNode superNode primNr logged
-			      warnedUndefVars'
+warnedUndefVars'
 classVariableNames:'prevClass prevInstVarNames
 prevClassVarNames prevClassInstVarNames'
 poolDictionaries:''
 category:'System-Compiler'
 !
 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 $
+$Header: /cvs/stx/stx/libcomp/Parser.st,v 1.4 1993-12-11 01:09:03 claus Exp $
 '!
 !Parser class methodsFor:'evaluating expressions'!
 evaluate:aString
 ^ parser
 ! !
 !Parser class methodsFor:'parsing'!
+selectorInExpression:aString
+"parse an expression - return the selector. Used for
+SystemBrowsers implementors/senders query-box initial text"
+|tree parser|
+(aString isNil or:[aString isEmpty]) ifTrue:[^ nil].
+tree := self withSelf:nil parseExpression:aString notifying:nil ignoreErrors:true.
+(tree notNil and:[tree ~~ #Error]) ifTrue:[
+	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'
+"
+!
 parseExpression:aString
 "parse aString as an expression; return the parseTree"
-^ self withSelf:nil parseExpression:aString notifying:nil
+^ self withSelf:nil parseExpression:aString notifying:nil ignoreErrors:false
 !
 withSelf:anObject parseExpression:aString notifying:someOne
+"parse aString as an expression with self set to anObject;
+return the parseTree"
+^ self withSelf:anObject parseExpression:aString notifying:someOne ignoreErrors:false
+!
+withSelf:anObject parseExpression:aString notifying:someOne ignoreErrors:ignore
 "parse aString as an expression with self set to anObject;
 return the parseTree"
 |parser tree|
 aString isNil ifTrue:[^ nil].
 parser := self for:(ReadStream on:aString).
 parser setSelf:anObject.
 parser notifying:someOne.
+ignore ifTrue:[parser ignoreErrors].
 parser nextToken.
 tree := parser expression.
 (parser errorFlag or:[tree == #Error]) ifTrue:[^ #Error].
 ^ tree
 !
 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'!
 setClassToCompileFor:aClass
 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 notNil ifTrue:[
-	    (warnedUndefVars includes:aName) ifTrue:[
+(warnedUndefVars includes:aName) ifTrue:[
-		"already warned about this one"
+"already warned about this one"
-		^ false
+^ false
-	    ].
+].
-	].
+].
-	self showErrorMessage:('Error: ' , aName , ' is undefined') position:pos1.
+self showErrorMessage:('Error: ' , aName , ' is undefined') position:pos1.
-	warnedUndefVars isNil ifTrue:[
+warnedUndefVars isNil ifTrue:[
-	    warnedUndefVars := Set new.
+warnedUndefVars := Set new.
-	].
+].
-	warnedUndefVars add:aName.
+warnedUndefVars add:aName.
-	^ false
+^ false
 ].
 ^ self correctableError:('Error: ' , aName , ' is undefined')
 position:pos1 to:pos2
 !
 |stats|
 ((tokenType == #BinaryOperator) and:[tokenName = '<']) ifTrue:[
 "an ST-80 primitive - parsed but ignored"
 self nextToken.
-primNr := self parsePrimitive.
+primNr := self parseST80Primitive.
 (primNr == #Error) ifTrue:[^ #Error].
 self warning:'ST-80 primitives not supported - ignored'
 ].
 (self parseMethodBodyVarSpec == #Error) ifTrue:[^ #Error].
 self nextToken
 ].
 ^ nil
 !
-parsePrimitive
+parseST80Primitive
-"parse an ST-80 type primitive;
+"parse an ST-80 type primitive as '< primitive: nr >';
 return primitive number or #Error"
 |primNumber|
 ((tokenType == #Keyword) and:[tokenName = 'primitive:']) ifFalse:[
 receiver lineNumber:lno
 ].
 ^ receiver
 !
+degeneratedKeywordExpressionForSelector
+"parse a keyword-expression without receiver - for the selector
+only. return the selector or nil"
+|receiver sel arg args pos1 pos2 try lno note|
+(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|
 ].
 "is it a method-variable ?"
 methodVars notNil ifTrue:[
 instIndex := methodVarNames indexOf:varName.
-(instIndex ~~ 0) ifTrue:[
+instIndex ~~ 0 ifTrue:[
 var := methodVars at:instIndex.
 var used:true.
 ^ PrimaryNode type:#MethodVariable
 name:varName
 token:var
 ].
 "is it a method-argument ?"
 methodArgs notNil ifTrue:[
 instIndex := methodArgNames indexOf:varName.
-(instIndex ~~ 0) ifTrue:[
+instIndex ~~ 0 ifTrue:[
 ^ PrimaryNode type:#MethodArg
 name:varName
 token:(methodArgs at:instIndex)
 index:instIndex
 ]
 prevClassInstVarNames := nil.
 prevClassVarNames := nil.
 prevClass addDependent:Parser
 ].
-instIndex := prevInstVarNames indexOf:varName startingAt:1
+instIndex := prevInstVarNames indexOf:varName startingAt:1.
-ifAbsent:[nil].
+instIndex ~~ 0 ifTrue:[
-instIndex notNil ifTrue:[
 usedInstVars isNil ifTrue:[
 usedInstVars := OrderedCollection new
 ].
 (usedInstVars includes:varName) ifFalse:[
 usedInstVars add:varName
 classToCompileFor notNil ifTrue:[
 prevClassInstVarNames isNil ifTrue:[
 prevClassInstVarNames := classToCompileFor class allInstVarNames
 ].
-instIndex := prevClassInstVarNames indexOf:varName startingAt:1
+instIndex := prevClassInstVarNames indexOf:varName startingAt:1.
-ifAbsent:[nil].
+instIndex ~~ 0 ifTrue:[
-instIndex notNil ifTrue:[
 aClass := self inWhichClassIsClassInstVar:varName.
 aClass notNil ifTrue:[
 usedVars isNil ifTrue:[
 usedVars := OrderedCollection new
 ].
 ]
 ].
 prevClassVarNames := aClass allClassVarNames
 ].
-instIndex := prevClassVarNames indexOf:varName startingAt:1
+instIndex := prevClassVarNames indexOf:varName startingAt:1.
-ifAbsent:[nil].
+instIndex ~~ 0 ifTrue:[
-instIndex notNil ifTrue:[
 aClass := self inWhichClassIsClassVar:varName.
 aClass notNil ifTrue:[
 usedClassVars isNil ifTrue:[
 usedClassVars := OrderedCollection new
 ].
 !
 block
 "parse a block; return a node-tree, nil or #Error"
-|stats node args var vars pos|
+|stats node args var vars pos lno b|
+lno := tokenLineNr.
 self nextToken.
 (tokenType == $: ) ifTrue:[
 [tokenType == $:] whileTrue:[
 pos := tokenPosition.
 self nextToken.
 self nextToken
 ].
 (tokenType ~~ $| ) ifTrue:[
 "ST-80 allows [:arg ]"
 (tokenType == $] ) ifTrue:[
-^ BlockNode arguments:args home:currentBlock variables:nil.
+b := BlockNode arguments:args home:currentBlock variables:nil.
+b lineNumber:lno.
+^ b
 ].
 self syntaxError:'| expected after block-arg declaration'.
 ^ #Error
 ].
 self nextToken
 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].
 ].
 ^ firstStatement
 !
 array
-|arr elem pos1 pos2|
+|arr elem pos1|
 pos1 := tokenPosition.
 arr := OrderedCollection new:200.
 [tokenType ~~ $) ] whileTrue:[
 elem := self arrayConstant.
 ].
 ^ Array withAll:arr
 !
 byteArray
-"for ST-80 R4 - allow byteArray constants"
+"started with ST-80 R4 - allow byteArray constants as #[ ... ]"
 |arr elem pos1 pos2|
 pos1 := tokenPosition.
 arr := OrderedCollection new.
 [tokenType ~~ $] ] whileTrue:[
 [searchBlock notNil] whileTrue:[
 args := searchBlock arguments.
 args notNil ifTrue:[
 args do:[:aBlockArg |
 names add:(aBlockArg name).
-dists add:(aString levenshteinTo:(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 levenshteinTo:(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 levenshteinTo:methodVarName)
+dists add:(aString spellAgainst: "levenshteinTo:"methodVarName)
 ]
 ].
 "method-arguments"
 methodArgs notNil ifTrue:[
 methodArgNames do:[:methodArgName |
 names add:methodArgName.
-dists add:(aString levenshteinTo:methodArgName)
+dists add:(aString spellAgainst: "levenshteinTo:"methodArgName)
 ]
 ].
 "instance-variables"
 classToCompileFor notNil ifTrue:[
 prevInstVarNames do:[:instVarName |
 names add:instVarName.
-dists add:(aString levenshteinTo: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 copyFrom:1 to:(className size - 5).
 baseClass := Smalltalk at:(className asSymbol).
 ]
 ].
 [aClass notNil] whileTrue:[
 (aClass classVarNames) do:[:classVarName |
 names add:classVarName.
-dists add:(aString levenshteinTo: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 levenshteinTo:globalVarName)
+dists add:(aString spellAgainst: "levenshteinTo:"globalVarName)
 ]
 ].
 "misc"
-#('self' 'super' 'nil') do:[:name |
+#('self' 'super' 'nil' 'thisContext') do:[:name |
 "only compare strings where length is about right"
-((name size - aString size) abs < 3) ifTrue:[
+names add:name.
-names add:name.
+dists add:(aString spellAgainst: "levenshteinTo:"name)
-dists add:(aString levenshteinTo:name)
-]
 ].
 (dists size ~~ 0) ifTrue:[
 dists sortWith:names.
+dists := dists reverse.
+names := names reverse.
 n := names size min:10.
 ^ names copyFrom:1 to:n
 ].
 ^ nil
 !

changeset 7	6c2bc76f0b8f
parent 4	f6fd83437415
child 9	a855c33612fb