The Trunk: ShoutCore-ul.46.mcz

Levente Uzonyi uploaded a new version of ShoutCore to project The Trunk:
http://source.squeak.org/trunk/ShoutCore-ul.46.mcz

==================== Summary ====================

Name: ShoutCore-ul.46
Author: ul
Time: 26 April 2015, 8:28:25.9 pm
UUID: d9c495e9-2e94-4c74-bc7c-8ff1448d0afd
Ancestors: ShoutCore-ul.45

SHParserST80 performance improvements:
- store the allowUnderscoreAssignments and allowUnderscoreSelectors preferences in instance variables
- don't honor per class allowUnderscoreAssignments preferences anymore (just like how allowUnderscoreSelectors works)
- ensure that instanceVariables is always an Array
- reordered branches in some methods based on the methods of the Morph class as sample
- use quick returns in frequently used testing methods
- release the errorBlock in #parse, instead of an #ensure: block in #parse:
- decreased the initial size of ranges to 40
- use Symbol >> #lookup: instead of Symbol >> #hasInterned:ifTrue:
- use the fact that classOrMetaClass is nil when it's not a Behavior
- use a fast primitive in #scanComment instead of a loop

=============== Diff against ShoutCore-ul.45 ===============

Item was changed:
  Object subclass: #SHParserST80
+ instanceVariableNames: 'classOrMetaClass source workspace arguments sourcePosition currentToken currentTokenFirst temporaries instanceVariables errorBlock currentTokenSourcePosition blockDepth bracketDepth ranges environment encodedCharSet allowUnderscoreAssignments allowUnderscoreSelectors'
- instanceVariableNames: 'classOrMetaClass source workspace arguments sourcePosition currentToken currentTokenFirst temporaries instanceVariables errorBlock currentTokenSourcePosition blockDepth bracketDepth ranges environment encodedCharSet'
  classVariableNames: ''
  poolDictionaries: ''
  category: 'ShoutCore-Parsing'!
 
  !SHParserST80 commentStamp: 'tween 8/16/2004 15:44' prior: 0!
  I am a Smalltalk method / expression parser.
 
  Rather than creating an Abstract Syntax Tree, I create a sequence of SHRanges (in my 'ranges' instance variable), which represent the tokens within the String I am parsing.
 
  I am used by a SHTextStylerST80 to parse method source strings.
  I am able to parse incomplete / incorrect methods, and so can be used to parse methods that are being edited.
 
  My 'source' instance variable should be set to the string to be parsed.
 
  My 'classOrMetaClass' instance var must be set to the class or metaClass for the method source so that I can correctly resolve identifiers within the source. If this is nil , I parse the source as an expression (i.e. a doIt expression).
 
  My 'workspace' instance variable can be set to a Workspace, so that I can resolve workspace variables.
 
  My 'environment' instance variable is the global namespace (this is initialized to Smalltalk, but can be set to a different environment).
 
  Example 1.
  ranges := SHParserST80 new
  classOrMetaClass: Object;
  source: 'testMethod ^self';
  parse;
  ranges
 
  !

Item was removed:
- ----- Method: SHParserST80>>allowUnderscoreAssignments (in category 'private') -----
- allowUnderscoreAssignments
- "Query class + preference"
- ^(classOrMetaClass ifNotNil: [:c | c allowUnderscoreAssignments])
- ifNil: [Scanner allowUnderscoreAsAssignment ]!

Item was removed:
- ----- Method: SHParserST80>>allowUnderscoreSelectors (in category 'private') -----
- allowUnderscoreSelectors
- ^ Scanner prefAllowUnderscoreSelectors!

Item was changed:
  ----- Method: SHParserST80>>initializeInstanceVariables (in category 'parse support') -----
  initializeInstanceVariables
+
+ instanceVariables := classOrMetaClass
+ ifNil: [ #() ]
+ ifNotNil: [ classOrMetaClass allInstVarNames asArray ]!
- instanceVariables := classOrMetaClass notNil
- ifTrue: [classOrMetaClass allInstVarNames asArray]
- ifFalse: [Set new]!

Item was changed:
  ----- Method: SHParserST80>>isAssignment (in category 'token testing') -----
  isAssignment
+
+ self isAnsiAssignment ifTrue: [ ^true ].
+ ^allowUnderscoreAssignments and: [ currentToken = '_' ]!
- ^self isAnsiAssignment or: [self allowUnderscoreAssignments and: [currentToken = '_']]!

Item was changed:
  ----- Method: SHParserST80>>isBinary (in category 'token testing') -----
  isBinary
+
+ currentToken ifNil: [ ^false ].
+ self isName ifTrue: [ ^false ].
+ self isKeyword ifTrue: [ ^false ].
+ 1 to: currentToken size do: [ :i |
+ (self isSelectorCharacter: (currentToken at: i)) ifFalse: [ ^false ] ].
- (currentToken isNil or: [self isName or: [self isKeyword]])
- ifTrue: [^false].
- 1 to: currentToken size do: [:i | | c |
- c := currentToken at: i.
- (self isSelectorCharacter: c)
- ifFalse: [^false]].
  ^true!

Item was changed:
  ----- Method: SHParserST80>>isKeyword (in category 'token testing') -----
  isKeyword
  "This method assumes that currentTokenFirst is a non-letter character when currentToken is nil."
 
+ (encodedCharSet isLetter: currentTokenFirst) ifTrue: [
+ ^currentToken last == $: ].
+ ^allowUnderscoreSelectors
+ and: [ currentTokenFirst == $_
+ and: [ currentToken notNil
+ and: [ currentToken size > 1
+ and: [ currentToken last == $: ] ] ] ]!
- ^((encodedCharSet isLetter: currentTokenFirst) or: [
- currentTokenFirst == $_ and: [
- currentToken notNil and: [
- currentToken size > 1 and: [
- self allowUnderscoreSelectors ] ] ] ]) and: [
- currentToken last == $: ]!

Item was changed:
  ----- Method: SHParserST80>>isName (in category 'token testing') -----
  isName
  "This method assumes that currentTokenFirst is a non-letter character when currentToken is nil."
 
  ^((encodedCharSet isLetter: currentTokenFirst)
+ or: [ allowUnderscoreSelectors
+ and: [ currentTokenFirst == $_
- or: [ currentTokenFirst == $_
  and: [ currentToken notNil
+ and: [ currentToken size > 1 ] ] ] ])
- and: [ currentToken size > 1
- and: [ self allowUnderscoreSelectors ] ] ] ])
  and: [ (encodedCharSet isAlphaNumeric: currentToken last)
+ or: [ allowUnderscoreSelectors
+ and: [ currentToken last == $_ ] ] ] !
- or: [ currentToken last == $_
- and: [ self allowUnderscoreSelectors ] ] ] !

Item was changed:
  ----- Method: SHParserST80>>isSelectorCharacter: (in category 'character testing') -----
  isSelectorCharacter: aCharacter
 
+ | asciiValue |
+ ('"#$'':().;[]{}^_'  includes: aCharacter) ifTrue: [ ^false ].
+ aCharacter isSeparator ifTrue:[ ^false ].
+ (encodedCharSet isAlphaNumeric: aCharacter) ifTrue: [ ^false ].
+ (asciiValue := aCharacter asciiValue) = 30 ifTrue: [ ^false "the doIt char" ].
+ ^asciiValue ~= 0 "Any other char, but 0 is ok as a binary selector char."
- (encodedCharSet isAlphaNumeric: aCharacter) ifTrue: [^false].
- aCharacter isSeparator ifTrue:[^false].
- ('"#$'':().;[]{}^_'  includes: aCharacter)
- ifTrue:[^false].
- aCharacter asciiValue = 30 ifTrue: [^false "the doIt char"].
- aCharacter asciiValue = 0 ifTrue: [^false].
- "Any other char is ok as a binary selector char."
- ^true
  !

Item was changed:
  ----- Method: SHParserST80>>nextChar (in category 'scan') -----
  nextChar
+
+ ^source at: (sourcePosition := sourcePosition + 1) ifAbsent: $ !
- sourcePosition := sourcePosition + 1.
- ^source at: sourcePosition ifAbsent: $ !

Item was changed:
  ----- Method: SHParserST80>>parse (in category 'parse') -----
  parse
+ "Parse the receiver's text as a Smalltalk method"
-     "Parse the receiver's text as a Smalltalk method"
 
+ self parse: classOrMetaClass notNil.
+ errorBlock := nil!
-     ^self parse: (classOrMetaClass notNil) !

Item was changed:
  ----- Method: SHParserST80>>parse: (in category 'parse') -----
  parse: isAMethod
  "Parse the receiver's text. If isAMethod is true
      then treat text as a method, if false as an
      expression with no message pattern"
 
  self initializeInstanceVariables.
+ allowUnderscoreAssignments := Scanner allowUnderscoreAsAssignment.
+ allowUnderscoreSelectors := Scanner prefAllowUnderscoreSelectors.
  sourcePosition := 1.
  arguments := Dictionary new.
  temporaries := Dictionary new.
  blockDepth := bracketDepth := 0.
  ranges
+ ifNil: [ ranges := OrderedCollection new: 40 "Covers over 80% of all methods." ]
+ ifNotNil: [ ranges reset ].
- ifNil: [ranges := OrderedCollection new: 100]
- ifNotNil: [ranges reset].
  errorBlock := [^false].
+ self scanNext.
+ isAMethod ifTrue: [
+ self
+ parseMessagePattern;
+ parsePragmaSequence ].
- [self scanNext.
- isAMethod
- ifTrue: [
- self parseMessagePattern.
- self parsePragmaSequence].
  self parseMethodTemporaries.
+ isAMethod ifTrue: [ self parsePragmaSequence ].
- isAMethod ifTrue: [self parsePragmaSequence].
  self parseStatementList.
+ currentToken ifNotNil: [ self error ].
- currentToken ifNotNil: [self error]]
- ensure:[errorBlock := nil].
  ^true!

Item was changed:
  ----- Method: SHParserST80>>parseSymbol (in category 'parse') -----
  parseSymbol
  | c |
  currentToken = '#'
  ifTrue: [
  "if token is just the #, then scan whitespace and comments
  and then process the next character.
  Squeak allows space between the # and the start of the symbol
  e.g. # (),  #  a, #  'sym' "
  self rangeType: #symbol.
  self scanWhitespace].
  c := self currentChar.
  self failWhen: (c isNil or: [c isSeparator]).
  c == $(
  ifTrue: [
  self nextChar.
  self scanPast: #arrayStart start: currentTokenSourcePosition end: currentTokenSourcePosition + 1.
  ^self parseArray].
  c == $' ifTrue: [^self parseSymbolString].
  c == $[ ifTrue: [
  self nextChar.
  self scanPast: #byteArrayStart start: currentTokenSourcePosition end: currentTokenSourcePosition + 1.
  ^self parseByteArray].
  ((self isSelectorCharacter: c) or: [c == $-])
  ifTrue: [^self parseSymbolSelector].
+ ((encodedCharSet isLetter: c)
+ or: [ c == $:
+ or: [ allowUnderscoreSelectors and: [ c == $_ ] ] ])
- ((encodedCharSet isLetter: c) or: [
- c == $: or: [
- c == $_ and: [self allowUnderscoreSelectors] ] ])
  ifTrue: [^self parseSymbolIdentifier].
  ^self parseCharSymbol!

Item was changed:
  ----- Method: SHParserST80>>parseSymbolIdentifier (in category 'parse') -----
  parseSymbolIdentifier
+
  | c start end |
  c := self currentChar.
+ self failUnless: (
+ (encodedCharSet isLetter: c)
+ or: [ c == $:
+ or: [ allowUnderscoreSelectors and: [ c == $_ ] ] ]).
- self failUnless: ((encodedCharSet isLetter: c) or: [c == $: or: [c == $_ and: [self allowUnderscoreSelectors]]]).
  start := sourcePosition.
+ [
+ c := self nextChar.
+ (encodedCharSet isAlphaNumeric: c)
+ or: [ c == $:
+ or: [ allowUnderscoreSelectors and: [ c == $_] ] ] ] whileTrue.
- [c := self nextChar.
- (encodedCharSet isAlphaNumeric: c) or: [c == $: or: [c == $_ and: [self allowUnderscoreSelectors]]]] whileTrue.
  end := sourcePosition - 1.
  c := source copyFrom: start - 1 to: end.
  self scanPast: #symbol start: start - 1 end: end.
  ^c!

Item was changed:
  ----- Method: SHParserST80>>peekChar (in category 'scan') -----
  peekChar
+
  ^source at: sourcePosition + 1 ifAbsent: $ !

Item was changed:
  ----- Method: SHParserST80>>pushTemporary: (in category 'parse support') -----
+ pushTemporary: aString
+
+ (temporaries at: blockDepth ifAbsentPut: [ OrderedCollection new ])
- pushTemporary: aString
- (temporaries at: blockDepth ifAbsentPut: [OrderedCollection new: 10])
  add: aString!

Item was changed:
  ----- Method: SHParserST80>>resolve: (in category 'identifier testing') -----
  resolve: aString
 
  aString = #self ifTrue: [ ^#self ].
  aString = #true ifTrue: [ ^#true ].
  aString = #false ifTrue: [ ^#false ].
  aString = #nil ifTrue: [ ^#nil ].
  aString = #super ifTrue: [ ^#super ].
  aString = #thisContext ifTrue: [ ^#thisContext ].
  (self isBlockTempName: aString) ifTrue: [^#blockTempVar].
  (self isBlockArgName: aString) ifTrue: [^#blockArg].
  (self isMethodTempName: aString) ifTrue: [^#tempVar].
  (self isMethodArgName: aString) ifTrue: [^#methodArg].
  (instanceVariables includes: aString) ifTrue: [^#instVar].
  workspace
  ifNotNil: [(workspace hasBindingOf: aString) ifTrue: [^#workspaceVar]].
+ (Symbol lookup: aString) ifNotNil: [:sym |
+ classOrMetaClass
+ ifNotNil: [
+ classOrMetaClass theNonMetaClass withAllSuperclassesDo: [:c |
- Symbol hasInterned: aString ifTrue: [:sym |
- classOrMetaClass isBehavior
- ifTrue: [
- classOrMetaClass theNonMetaClass withAllSuperclasses do: [:c |
  (c classPool bindingOf: sym) ifNotNil: [^#classVar].
  c sharedPools do: [:p | (p bindingOf: sym) ifNotNil: [^#poolConstant]].
  (c environment bindingOf: sym) ifNotNil: [^#globalVar]]]
+ ifNil: [(environment bindingOf: sym) ifNotNil: [^#globalVar]]].
- ifFalse: [(environment bindingOf: sym) ifNotNil: [^#globalVar]]].
  ^self resolvePartial: aString!

Item was changed:
  ----- Method: SHParserST80>>resolvePartial: (in category 'identifier testing') -----
  resolvePartial: aString
  "check if any identifier begins with aString"
 
  (#('self' 'super' 'true' 'false' 'nil' 'thisContext') anySatisfy: [:each | each beginsWith: aString])
  ifTrue: [^#incompleteIdentifier].
  (self isIncompleteBlockTempName: aString) ifTrue: [^#incompleteIdentifier].
  (self isIncompleteBlockArgName: aString) ifTrue: [^#incompleteIdentifier].
  (self isIncompleteMethodTempName: aString) ifTrue: [^#incompleteIdentifier].
  (self isIncompleteMethodArgName: aString) ifTrue: [^#incompleteIdentifier].
  (instanceVariables anySatisfy: [:each | each beginsWith: aString]) ifTrue: [^#incompleteIdentifier].
  workspace
  ifNotNil: [(workspace hasBindingThatBeginsWith: aString) ifTrue: [^#incompleteIdentifier]].
+ classOrMetaClass
+ ifNotNil: [
- classOrMetaClass isBehavior
- ifTrue: [
  classOrMetaClass theNonMetaClass withAllSuperclasses do: [:c |
  (c classPool hasBindingThatBeginsWith: aString) ifTrue: [^#incompleteIdentifier].
  c sharedPools do: [:p | (p hasBindingThatBeginsWith: aString) ifTrue: [^#incompleteIdentifier]].
  (c environment hasBindingThatBeginsWith: aString) ifTrue: [^#incompleteIdentifier]]]
+ ifNil: [(environment hasBindingThatBeginsWith: aString) ifTrue: [^#incompleteIdentifier]].
- ifFalse: [(environment hasBindingThatBeginsWith: aString) ifTrue: [^#incompleteIdentifier]].
  ^#undefinedIdentifier!

Item was changed:
  ----- Method: SHParserST80>>resolvePartialPragmaArgument: (in category 'identifier testing') -----
  resolvePartialPragmaArgument: aString
  "check if any valid pragma argument begins with aString"
 
  (#('true' 'false' 'nil') anySatisfy: [:each | each beginsWith: aString])
  ifTrue: [^#incompleteIdentifier].
  "should really check that a matching binding is for a Class?"
+ classOrMetaClass
+ ifNotNil: [
- classOrMetaClass isBehavior
- ifTrue: [
  classOrMetaClass theNonMetaClass withAllSuperclasses do: [:c |
  (c environment hasBindingThatBeginsWith: aString) ifTrue: [^#incompleteIdentifier]]]
+ ifNil: [(environment hasBindingThatBeginsWith: aString) ifTrue: [^#incompleteIdentifier]].
- ifFalse: [(environment hasBindingThatBeginsWith: aString) ifTrue: [^#incompleteIdentifier]].
  ^#undefinedIdentifier!

Item was changed:
  ----- Method: SHParserST80>>resolvePragmaArgument: (in category 'identifier testing') -----
  resolvePragmaArgument: aString
  (#('true' 'false' 'nil') includes: aString) ifTrue: [^aString asSymbol].
  "should really check that global is a class?"
+ (Symbol lookup: aString) ifNotNil: [:sym |
+ classOrMetaClass
+ ifNotNil: [
- Symbol hasInterned: aString ifTrue: [:sym |
- classOrMetaClass isBehavior
- ifTrue: [
  classOrMetaClass theNonMetaClass withAllSuperclasses do: [:c |
  (c environment bindingOf: sym) ifNotNil: [^#globalVar]]]
+ ifNil: [(environment bindingOf: sym) ifNotNil: [^#globalVar]]].
- ifFalse: [(environment bindingOf: sym) ifNotNil: [^#globalVar]]].
  ^self resolvePartialPragmaArgument: aString!

Item was changed:
  ----- Method: SHParserST80>>scanComment (in category 'scan') -----
  scanComment
+
+ | start |
+ start := sourcePosition.
+ (sourcePosition := source indexOf: $" startingAt: start + 1) = 0 ifTrue: [
+ sourcePosition := source size + 1.
+ self rangeType: #unfinishedComment start: start end: source size.
+ ^self error ].
+ start < sourcePosition ifTrue: [
+ self rangeType: #comment start: start end: sourcePosition ].
+ self
+ nextChar;
+ scanWhitespace!
- | c s e |
- s := sourcePosition.
-
- [sourcePosition := sourcePosition + 1.
- (c := self currentChar)
- ifNil: [
- self rangeType: #unfinishedComment start: s end: source size.
- ^self error ": 'unfinished comment'"].
- c == $"]
- whileFalse: [].
- e := sourcePosition.
- s < e ifTrue: [self rangeType: #comment start: s end: e].
- self nextChar.
- self scanWhitespace!

Item was changed:
  ----- Method: SHParserST80>>scanIdentifier (in category 'scan') -----
  scanIdentifier
+
  | c start |
  start := sourcePosition.
+ [
+ (encodedCharSet isAlphaNumeric: (c := self nextChar))
+ or: [ allowUnderscoreSelectors and: [ c == $_ ] ] ] whileTrue.
+ (c == $: and: [ (self isSelectorCharacter: self peekChar) not ])
+ ifTrue: [ self nextChar ].
- [(encodedCharSet isAlphaNumeric: (c := self nextChar)) or: [c == $_ and: [self allowUnderscoreSelectors]]] whileTrue.
- (c == $: and: [(self isSelectorCharacter: self peekChar) not])
- ifTrue: [self nextChar].
  currentToken := source copyFrom: start to: sourcePosition - 1.
  currentTokenSourcePosition := start!

Item was changed:
  ----- Method: SHParserST80>>scanNext (in category 'scan') -----
  scanNext
+
  self scanWhitespace.
+ currentTokenFirst := self currentChar ifNil: [
+ " end of input "
+ currentTokenFirst := $ .
+ currentTokenSourcePosition := nil.
+ currentToken := nil.
+ ^nil ].
+ (encodedCharSet isDigit: currentTokenFirst) ifTrue: [ ^self scanNumber ].
- currentTokenFirst := self currentChar.
- currentTokenFirst
- ifNil: [" end of input "
- currentTokenFirst := $ .
- currentTokenSourcePosition := nil.
- currentToken := nil.
- ^nil].
- (encodedCharSet isDigit: currentTokenFirst) ifTrue: [^self scanNumber].
  ((encodedCharSet isLetter: currentTokenFirst) or: [
+ allowUnderscoreSelectors and: [ currentTokenFirst == $_ ] ])
+ ifTrue: [ ^self scanIdentifier ].
- currentTokenFirst == $_ and: [ self allowUnderscoreSelectors ] ])
- ifTrue: [^self scanIdentifier].
  ^self scanBinary!