SystemOrganization addCategory: #'Shout-Parsing'! SystemOrganization addCategory: #'Shout-Styling'! SystemOrganization addCategory: #'Shout-Text Support'! SystemOrganization addCategory: #'Shout-Windows'! !MessageSet methodsFor: '*Shout-Styling' stamp: 'dp 6/28/2006 20:52'! shoutAboutToStyle: aPluggableShoutMorphOrView "This is a notification that aPluggableShoutMorphOrView is about to re-style its text. Set the classOrMetaClass in aPluggableShoutMorphOrView, so that identifiers will be resolved correctly. Answer true to allow styling to proceed, or false to veto the styling" self shoutIsModeStyleable ifFalse: [^false]. aPluggableShoutMorphOrView classOrMetaClass: self selectedClassOrMetaClass. ^true! ! TextMorphForEditView subclass: #TextMorphForShout instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Shout-Text Support'! !TextMorphForShout methodsFor: 'private' stamp: 'tween 8/29/2004 20:35'! editorClass "Answer the class used to create the receiver's editor" ^TextMorphForShoutEditor! ! !Browser methodsFor: '*Shout-Styling' stamp: 'dp 6/28/2006 20:51'! shoutAboutToStyle: aPluggableShoutMorphOrView "This is a notification that aPluggableShoutMorphOrView is about to re-style its text. Set the classOrMetaClass in aPluggableShoutMorphOrView, so that identifiers will be resolved correctly. Answer true to allow styling to proceed, or false to veto the styling" | type | self shoutIsModeStyleable ifFalse: [^false]. type := self editSelection. (#(newMessage editMessage editClass newClass) includes: type) ifFalse:[^false]. aPluggableShoutMorphOrView classOrMetaClass: (type = #editClass ifFalse:[self selectedClassOrMetaClass]). ^true! ! !Debugger methodsFor: '*Shout-Styling' stamp: 'AndrewTween 11/7/2009 16:30'! shoutAboutToStyle: aPluggableShoutMorphOrView "This is a notification that aPluggableShoutMorphOrView is about to re-style its text. Set the classOrMetaClass in aPluggableShoutMorphOrView, so that identifiers will be resolved correctly. Answer true to allow styling to proceed, or false to veto the styling" self shoutIsModeStyleable ifFalse: [^false]. aPluggableShoutMorphOrView classOrMetaClass: self selectedClassOrMetaClass. ^true! ! !ChangeSorter methodsFor: '*Shout-Styling' stamp: 'dp 6/28/2006 20:51'! shoutAboutToStyle: aPluggableShoutMorphOrView "This is a notification that aPluggableShoutMorphOrView is about to re-style its text. Set the classOrMetaClass in aPluggableShoutMorphOrView, so that identifiers will be resolved correctly. Answer true to allow styling to proceed, or false to veto the styling" self shoutIsModeStyleable ifFalse: [^false]. self currentSelector ifNil: [^false]. aPluggableShoutMorphOrView classOrMetaClass: self selectedClassOrMetaClass. ^true! ! TextMorphEditor subclass: #TextMorphForShoutEditor instanceVariableNames: 'inBackTo' classVariableNames: '' poolDictionaries: '' category: 'Shout-Text Support'! !TextMorphForShoutEditor methodsFor: 'backspace handling' stamp: 'rr 12/10/2007 18:14'! backTo: startIndex "When backspacing, 2 notifications of the userHasEdited are received. This then causes a background process to not terminate correctly. The reason for all this is uncertain, but discarding the superfluous userHasEdited message received while running backTo: seems to cure the problem" | answer | [[inBackTo := true. answer := super backTo: startIndex ] on: Error do: []] ensure:[ inBackTo:=false. ^answer] ! ! !TextMorphForShoutEditor methodsFor: 'parenblinking' stamp: 'tween 3/12/2005 12:38'! blinkParen lastParentLocation ifNotNil: [self text string size >= lastParentLocation ifTrue: [ self text addAttribute: TextEmphasis bold from: lastParentLocation to: lastParentLocation]] ! ! !TextMorphForShoutEditor methodsFor: 'new selection' stamp: 'tween 8/28/2004 00:26'! changeEmphasis: characterStream morph editView styler evaluateWithoutStyling: [^super changeEmphasis: characterStream]! ! !TextMorphForShoutEditor methodsFor: 'parenblinking' stamp: 'tween 3/12/2005 12:38'! clearParens super clearParens. lastParentLocation := nil ! ! !TextMorphForShoutEditor methodsFor: 'backspace handling' stamp: 'tween 3/12/2005 12:46'! userHasEdited "ignore this if generated during backTo: See comment in backTo: " (inBackTo isNil or: [inBackTo not]) ifTrue:[^super userHasEdited]! ! !CodeHolder methodsFor: '*Shout-Styling' stamp: 'tween 8/26/2004 09:47'! shoutAboutToStyle: aPluggableShoutMorphOrView "This is a notification that aPluggableShoutMorphOrView is about to re-style its text. The default is to answer false to veto the styling" ^false! ! !CodeHolder methodsFor: '*Shout-Styling' stamp: 'dp 6/28/2006 20:50'! shoutIsModeStyleable "determine if Shout can style in the current mode" ^ self showingSource or: [self showingPrettyPrint]! ! PluggableTextMorph subclass: #PluggableShoutMorph instanceVariableNames: 'styler unstyledAcceptText' classVariableNames: '' poolDictionaries: '' category: 'Shout-Windows'! !PluggableShoutMorph commentStamp: '' prior: 0! I am a subclass of PluggableTextMorph. Instances of me are usually created using my #on:text:accept:readSelection:menu: class method. In order to colour the text, I use an instance of SHTextStylerST80, which I store in my 'styler' instance variable. When my setText: method is called, I use my styler to ... a) optionally set all assignments to ansi or leftArrow. b) Colour my text (immediately, if the text is less than 4096 chars in length, or in a backgroundProcess otherwise) When my text is changed, my hasUnacceptedEdits: method is called with true, and I ask my styler to re-colour my text. This is performed in a background process so that typing remains responsive regardless of the length of the text. Just before my styler is about to format/style the text, I send #stylerAboutToStyle: to my model. This gives my model a chance to veto the styling (by answering false), or to initialize the styler with information it needs in order to parse the text correctly (e.g. the class to which a method belongs, or the workspace in which I am contained). My styler informs me that it has finished styling by triggering the #stylerStyled: and #stylerStyledInBackground: events which I handle. I then update the textAttributes of my text and refresh the display. My 'unstyledAcceptText' instance variable is used in conjunction with my #acceptTextInModel and #correctFrom:to:with: methods to ensure that when my text is modified during a method compilation (removing unused vars etc), I do not lose those changes. ! !PluggableShoutMorph class methodsFor: 'class initialization' stamp: 'tween 8/27/2004 10:35'! initialize "Register the receiver with MorphicTextEditor in the AppRegistry. If the old default was a plain old PluggableTextMorph, then make the receiver the new default, otherwise make the default nil so that the user is prompted" | current | current := MorphicTextEditor defaultOrNil. (current isNil or: [current = PluggableTextMorph or: [current = self]]) ifTrue:[MorphicTextEditor default: self] ifFalse:[ MorphicTextEditor register: self; default: nil]! ! !PluggableShoutMorph class methodsFor: 'instance creation' stamp: 'tween 8/26/2004 01:30'! on: anObject text: getTextSel accept: setTextSel readSelection: getSelectionSel menu: getMenuSel |styler answer | answer := self new. styler := SHTextStylerST80 new view: answer; yourself. "styler when: #aboutToStyle send: #shoutStylerAboutToStyle: to: anObject with: styler." ^ answer styler: styler; on: anObject text: getTextSel accept: setTextSel readSelection: getSelectionSel menu: getMenuSel! ! !PluggableShoutMorph methodsFor: 'accepting' stamp: 'tween 8/30/2004 11:48'! acceptTextInModel self okToStyle ifFalse:[^super acceptTextInModel]. "#correctFrom:to:with: is sent when the method source is manipulated during compilation (removing unused temps, changing selectors etc). But #correctFrom:to:with: operates on the textMorph's text, and we may be saving an unstyled copy of the text. This means that these corrections will be lost unless we also apply the corrections to the unstyled copy that we are saving. So remember the unstyled copy in unstyledAcceptText, so that when #correctFrom:to:with: is received we can also apply the correction to it" unstyledAcceptText := styler unstyledTextFrom: textMorph asText. [^setTextSelector isNil or: [setTextSelector numArgs = 2 ifTrue: [model perform: setTextSelector with: unstyledAcceptText with: self] ifFalse: [model perform: setTextSelector with: unstyledAcceptText]] ] ensure:[unstyledAcceptText := nil]! ! !PluggableShoutMorph methodsFor: 'styler' stamp: 'tween 8/26/2004 09:57'! classOrMetaClass: aBehavior "set the classOrMetaClass in the receiver's styler to aBehavior" styler classOrMetaClass: aBehavior ! ! !PluggableShoutMorph methodsFor: 'styler' stamp: 'tween 6/28/2004 08:11'! correctFrom: start to: stop with: aString "see the comment in #acceptTextInModel " unstyledAcceptText ifNotNil:[unstyledAcceptText replaceFrom: start to: stop with: aString ]. ^ super correctFrom: start to: stop with: aString! ! !PluggableShoutMorph methodsFor: 'styler' stamp: 'tween 8/26/2004 09:57'! environment: anObject "set the environment in the receiver's styler to anObject" styler environment: anObject ! ! !PluggableShoutMorph methodsFor: 'styler' stamp: 'tween 8/30/2004 11:35'! font: aFont super font: aFont. styler ifNotNil: [styler font: aFont]! ! !PluggableShoutMorph methodsFor: 'styler' stamp: 'tween 8/30/2004 12:34'! hasUnacceptedEdits: aBoolean "re-implemented to re-style the text iff aBoolean is true" super hasUnacceptedEdits: aBoolean. (aBoolean and: [self okToStyle]) ifTrue: [ styler styleInBackgroundProcess: textMorph contents]! ! !PluggableShoutMorph methodsFor: 'styler' stamp: 'lr 8/15/2010 14:31'! okToStyle ^ styler notNil and: [ (SHPreferences enabled) and: [ (model respondsTo: #shoutAboutToStyle:) and: [ (model shoutAboutToStyle: self) ] ] ]! ! !PluggableShoutMorph methodsFor: 'styler' stamp: 'tween 8/30/2004 12:34'! setText: aText self okToStyle ifFalse:[^super setText: aText]. super setText: (styler format: aText asText). aText size < 4096 ifTrue:[ styler style: textMorph contents] ifFalse:[styler styleInBackgroundProcess: textMorph contents]! ! !PluggableShoutMorph methodsFor: 'styler' stamp: 'tween 8/28/2004 00:25'! styler ^styler! ! !PluggableShoutMorph methodsFor: 'styler' stamp: 'tween 8/26/2004 09:44'! styler: anObject styler := anObject! ! !PluggableShoutMorph methodsFor: 'styler' stamp: 'tween 4/13/2007 08:41'! stylerStyled: styledCopyOfText textMorph contents runs: styledCopyOfText runs . "textMorph paragraph recomposeFrom: 1 to: textMorph contents size delta: 0." "caused chars to appear in wrong order esp. in demo mode. remove this line when sure it is fixed" textMorph updateFromParagraph. selectionInterval ifNotNil:[ textMorph editor selectInvisiblyFrom: selectionInterval first to: selectionInterval last; storeSelectionInParagraph; setEmphasisHere]. textMorph editor blinkParen. self scrollSelectionIntoView! ! !PluggableShoutMorph methodsFor: 'styler' stamp: 'tween 4/27/2004 22:02'! stylerStyledInBackground: styledCopyOfText "It is possible that the text string has changed since the styling began. Disregard the styles if styledCopyOfText's string differs with the current textMorph contents string" textMorph contents string = styledCopyOfText string ifTrue: [self stylerStyled: styledCopyOfText] ! ! !PluggableShoutMorph methodsFor: 'private' stamp: 'tween 8/29/2004 20:44'! textMorphClass "Answer the class used to create the receiver's textMorph" ^TextMorphForShout! ! !PluggableShoutMorph methodsFor: 'styler' stamp: 'tween 9/13/2004 11:49'! workspace: anObject "set the workspace in the receiver's styler to anObject" styler workspace: anObject ! ! !FileContentsBrowser methodsFor: '*Shout-Styling' stamp: 'dp 6/28/2006 20:52'! shoutAboutToStyle: aPluggableShoutMorphOrView "This is a notification that aPluggableShoutMorphOrView is about to re-style its text. Set the classOrMetaClass in aPluggableShoutMorphOrView, so that identifiers will be resolved correctly. Answer true to allow styling to proceed, or false to veto the styling" self shoutIsModeStyleable ifFalse: [^false]. aPluggableShoutMorphOrView classOrMetaClass: self selectedClassOrMetaClass. ^true! ! !TextAttribute methodsFor: '*Shout-styling' stamp: 'tween 2/17/2007 13:49'! shoutShouldPreserve "Answer true if Shout should preserve ALL the attributes in the same run as the receiver, false otherwise" ^false ! ! !TextAction methodsFor: '*Shout-styling' stamp: 'tween 2/17/2007 13:50'! shoutShouldPreserve "Answer true if Shout should preserve ALL the attributes in the same run as the receiver, false otherwise" ^true ! ! Object subclass: #SHParserST80 instanceVariableNames: 'classOrMetaClass source workspace arguments sourcePosition currentToken currentTokenFirst temporaries instanceVariables errorBlock currentTokenSourcePosition blockDepth bracketDepth ranges environment' classVariableNames: '' poolDictionaries: '' category: 'Shout-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 ! !SHParserST80 class methodsFor: 'instance creation' stamp: 'tween 5/9/2004 12:44'! new ^super new initialize; yourself! ! !SHParserST80 methodsFor: 'accessing' stamp: 'tween 4/13/2004 20:20'! classOrMetaClass: aClass classOrMetaClass := aClass! ! !SHParserST80 methodsFor: 'scan' stamp: 'tween 4/28/2004 09:42'! currentChar ^source at: sourcePosition ifAbsent: [nil]! ! !SHParserST80 methodsFor: 'parse support' stamp: 'tween 4/28/2004 09:48'! enterBlock blockDepth := blockDepth + 1. bracketDepth := bracketDepth + 1! ! !SHParserST80 methodsFor: 'accessing' stamp: 'tween 5/9/2004 12:43'! environment: anObject environment := anObject! ! !SHParserST80 methodsFor: 'error handling' stamp: 'tween 4/28/2004 10:16'! error self rangeType: #excessCode start: (ranges isEmpty ifTrue: [1] ifFalse: [ranges last end + 1]) end: source size. errorBlock value! ! !SHParserST80 methodsFor: 'error handling' stamp: 'tween 8/7/2005 14:31'! failUnless: aBoolean aBoolean ifFalse:[self error] ! ! !SHParserST80 methodsFor: 'error handling' stamp: 'tween 8/7/2005 14:31'! failWhen: aBoolean aBoolean ifTrue:[self error]! ! !SHParserST80 methodsFor: 'accessing' stamp: 'tween 5/9/2004 12:44'! initialize environment := Smalltalk! ! !SHParserST80 methodsFor: 'parse support' stamp: 'tween 4/28/2004 10:08'! initializeInstanceVariables instanceVariables := classOrMetaClass notNil ifTrue: [classOrMetaClass allInstVarNames asArray] ifFalse: [Set new]! ! !SHParserST80 methodsFor: 'token testing' stamp: 'tween 4/28/2004 09:43'! isAnsiAssignment ^currentToken = ':='! ! !SHParserST80 methodsFor: 'token testing' stamp: 'tween 4/28/2004 09:43'! isAssignment ^currentToken = ':=' or: [currentToken = '_']! ! !SHParserST80 methodsFor: 'character testing' stamp: 'kwl 7/4/2006 06:54'! isBigDigit: aCharacter base: anInteger "Answer true if aCharacter is a digit or a capital letter appropriate for base anInteger" | digitValue | digitValue := aCharacter digitValue. ^digitValue >= 0 and:[digitValue < anInteger]! ! !SHParserST80 methodsFor: 'token testing' stamp: 'tween 2/17/2007 14:31'! isBinary (currentToken isNil or: [self isName or: [self isKeyword]]) ifTrue: [^false]. 1 to: currentToken size do: [:i | | c | c := currentToken at: i. ((self isSelectorCharacter: c) or: [i = 1 and: [c == $-]]) ifFalse: [^false]]. ^true! ! !SHParserST80 methodsFor: 'identifier testing' stamp: 'tween 5/7/2004 06:24'! isBlockArgName: aString "Answer true if aString is the name of a block argument, false otherwise" | temp arg | blockDepth to: 1 by: -1 do: [:level | arg := (arguments at: level ifAbsent: [#()]) includes: aString. arg ifTrue: [^true]. temp := (temporaries at: level ifAbsent: [#()]) includes: aString. temp ifTrue: [^false]]. ^false! ! !SHParserST80 methodsFor: 'identifier testing' stamp: 'tween 5/7/2004 06:24'! isBlockTempName: aString "Answer true if aString is the name of a block temporary. false otherwise" | temp arg | blockDepth to: 1 by: -1 do: [:level | arg := (arguments at: level ifAbsent: [#()]) includes: aString. arg ifTrue: [^false]. temp := (temporaries at: level ifAbsent: [#()]) includes: aString. temp ifTrue: [^true]]. ^false! ! !SHParserST80 methodsFor: 'identifier testing' stamp: 'tween 5/7/2004 06:37'! isIncompleteBlockArgName: aString "Answer true if aString is the start of the name of a block argument, false otherwise" | arg | blockDepth to: 1 by: -1 do: [:level | arg := (arguments at: level ifAbsent: [#()]) anySatisfy: [:each | each beginsWith: aString]. arg ifTrue: [^true]]. ^false! ! !SHParserST80 methodsFor: 'identifier testing' stamp: 'tween 5/7/2004 06:37'! isIncompleteBlockTempName: aString "Answer true if aString is the start of the name of a block temporary. false otherwise" | temp | blockDepth to: 1 by: -1 do: [:level | temp := (temporaries at: level ifAbsent: [#()]) anySatisfy: [:each | each beginsWith: aString]. temp ifTrue: [^true]]. ^false! ! !SHParserST80 methodsFor: 'identifier testing' stamp: 'tween 5/7/2004 06:38'! isIncompleteMethodArgName: aString "Answer true if aString is the start of the name of a method argument, false otherwise. Does not check whether aString is also a blockArgName" ^(arguments at: 0 ifAbsent: [#()]) anySatisfy: [:each | each beginsWith: aString]! ! !SHParserST80 methodsFor: 'identifier testing' stamp: 'tween 5/7/2004 06:39'! isIncompleteMethodTempName: aString "Answer true if aString is the start of then name of a method temporary, false otherwise." ^(temporaries at: 0 ifAbsent: [#()]) anySatisfy: [:each | each beginsWith: aString]! ! !SHParserST80 methodsFor: 'token testing' stamp: 'lr 12/18/2009 11:49'! isKeyword ^(currentTokenFirst isLetter or: [currentTokenFirst == $_]) and: [currentToken last == $:]! ! !SHParserST80 methodsFor: 'identifier testing' stamp: 'tween 5/7/2004 06:26'! isMethodArgName: aString "Answer true if aString is the name of a method argument, false otherwise. Does not check whether aString is also a blockArgName" ^(arguments at: 0 ifAbsent: [#()]) includes: aString! ! !SHParserST80 methodsFor: 'identifier testing' stamp: 'tween 5/7/2004 06:25'! isMethodTempName: aString "Answer true if aString is the name of a method temporary, false otherwise. Does not check whether aString is also a block temporary or argument" ((arguments at: 0 ifAbsent: [#()]) includes: aString) ifTrue: [^false]. ^(temporaries at: 0 ifAbsent: [#()]) includes: aString! ! !SHParserST80 methodsFor: 'token testing' stamp: 'lr 12/18/2009 11:56'! isName ^(currentTokenFirst isLetter or: [currentTokenFirst == $_]) and: [currentToken last isAlphaNumeric or: [currentToken last == $_]]! ! !SHParserST80 methodsFor: 'character testing' stamp: 'tween 2/17/2007 14:37'! isSelectorCharacter: aCharacter aCharacter isAlphaNumeric ifTrue: [^false]. aCharacter isSeparator ifTrue:[^false]. "$- is specified here as NOT being a selector char, but it can appear as the first char in a binary selector. That case is handled specially elsewhere" ('"#$'':().;[]{}^_-' 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 ! ! !SHParserST80 methodsFor: 'token testing' stamp: 'tween 4/28/2004 09:43'! isTokenExternalFunctionCallingConvention | descriptorClass | descriptorClass := Smalltalk at: #ExternalFunction ifAbsent: [nil]. descriptorClass == nil ifTrue: [^false]. ^(descriptorClass callingConventionFor: currentToken) notNil! ! !SHParserST80 methodsFor: 'parse support' stamp: 'tween 4/28/2004 09:48'! leaveBlock arguments removeKey: blockDepth ifAbsent: []. temporaries removeKey: blockDepth ifAbsent: []. blockDepth := blockDepth - 1. bracketDepth := bracketDepth - 1! ! !SHParserST80 methodsFor: 'scan' stamp: 'tween 4/28/2004 09:42'! nextChar sourcePosition := sourcePosition + 1. ^source at: sourcePosition ifAbsent: [$ ]! ! !SHParserST80 methodsFor: 'parse' stamp: 'tween 4/17/2004 11:29'! parse "Parse the receiver's text as a Smalltalk method" ^self parse: (classOrMetaClass notNil) ! ! !SHParserST80 methodsFor: 'parse' stamp: 'tween 7/8/2006 11:08'! 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. sourcePosition := 1. arguments := Dictionary new. temporaries := Dictionary new. blockDepth := bracketDepth := 0. ranges isNil ifTrue: [ranges := OrderedCollection new: 100] ifFalse: [ranges reset]. errorBlock := [^false]. [self scanNext. isAMethod ifTrue: [ self parseMessagePattern. self parsePragmaSequence]. self parseMethodTemporaries. isAMethod ifTrue: [self parsePragmaSequence]. self parseStatementList. currentToken ifNotNil: [self error]] ensure:[errorBlock := nil]. ^true! ! !SHParserST80 methodsFor: 'parse' stamp: 'tween 2/17/2007 14:38'! parseArray [currentTokenFirst == $)] whileFalse: [self parseLiteralArrayElement]. self scanPast: #arrayEnd! ! !SHParserST80 methodsFor: 'parse' stamp: 'tween 5/7/2004 09:31'! parseBinary | binary type | self parseUnary. [self isBinary] whileTrue: [ binary := currentToken. type := #binary. (binary isEmpty or:[Symbol hasInterned: binary ifTrue: [:sym | ]]) ifFalse:[ type := (Symbol thatStartsCaseSensitive: binary skipping: nil) isNil ifTrue: [#undefinedBinary] ifFalse:[#incompleteBinary]]. self scanPast: type. self parseTerm. self parseUnary] ! ! !SHParserST80 methodsFor: 'parse' stamp: 'tween 8/7/2005 14:26'! parseBinaryMessagePattern self scanPast: #patternBinary. self failUnless: self isName. self scanPast: #patternArg. ! ! !SHParserST80 methodsFor: 'parse' stamp: 'tween 2/17/2007 14:39'! parseBlock self enterBlock. self scanPast: #blockStart level: bracketDepth. currentTokenFirst == $: ifTrue: [self parseBlockArguments]. currentTokenFirst == $| ifTrue: [self parseBlockTemporaries]. self parseStatementList. self failUnless: currentTokenFirst == $]. self scanPast: #blockEnd level: bracketDepth. self leaveBlock! ! !SHParserST80 methodsFor: 'parse' stamp: 'tween 2/17/2007 14:39'! parseBlockArguments [currentTokenFirst == $:] whileTrue: [ self scanPast: #blockArgColon. self failUnless: self isName. self scanPast: #blockPatternArg]. currentTokenFirst == $| ifTrue: [^self scanPast: #blockArgsBar]! ! !SHParserST80 methodsFor: 'parse' stamp: 'tween 2/17/2007 14:42'! parseBlockTemporaries currentTokenFirst == $| ifTrue: [ self scanPast: #blockTempBar. [self isName] whileTrue: [self scanPast: #blockPatternTempVar]. self failUnless: currentToken = '|'. self scanPast: #blockTempBar]! ! !SHParserST80 methodsFor: 'parse' stamp: 'tween 2/17/2007 14:40'! parseBraceArray self parseStatementListForBraceArray. self failUnless: currentTokenFirst == $}. self scanPast: #rightBrace! ! !SHParserST80 methodsFor: 'parse' stamp: 'lr 11/8/2009 20:36'! parseByteArray [currentTokenFirst == $]] whileFalse: [ self scanPast: #integer ]. self scanPast: #byteArrayEnd! ! !SHParserST80 methodsFor: 'parse' stamp: 'tween 2/17/2007 14:40'! parseCascade self parseKeyword. [currentTokenFirst == $;] whileTrue: [ self scanPast: #cascadeSeparator. self parseKeyword]! ! !SHParserST80 methodsFor: 'parse' stamp: 'tween 4/28/2004 14:28'! parseCharSymbol | s e | s := sourcePosition - 1. e := sourcePosition. self nextChar. self scanPast: #symbol start: s end: e! ! !SHParserST80 methodsFor: 'parse' stamp: 'tween 4/28/2004 13:51'! parseExpression | assignType | self isName ifTrue: [ self scanPast: (self resolve: currentToken). self isAssignment ifTrue: [ assignType := self isAnsiAssignment ifTrue: [#ansiAssignment] ifFalse: [#assignment]. self scanPast: assignType. self parseExpression] ifFalse: [self parseCascade]] ifFalse: [ self parseTerm. self parseCascade]! ! !SHParserST80 methodsFor: 'parse' stamp: 'tween 2/17/2007 14:41'! parseExternalCall self scanNext. self scanPast: #externalCallType. currentToken = '*' ifTrue: [self scanPast: #externalCallTypePointerIndicator]. currentTokenFirst isDigit ifTrue: [self scanPast: #integer] ifFalse: [ self failUnless: currentTokenFirst == $'. self parseString]. self failUnless: currentTokenFirst == $(. self scanPast: #leftParenthesis. [currentTokenFirst ~~ $)] whileTrue: [ self scanPast: #externalCallType. currentToken = '*' ifTrue: [self scanPast: #externalCallTypePointerIndicator]]. self scanPast: #rightParenthesis. currentToken = 'module:' ifTrue: [ self scanPast: #module. self failUnless: currentTokenFirst == $'. self parseString]. self failUnless: currentToken = '>'. self scanPast: #primitiveOrExternalCallEnd! ! !SHParserST80 methodsFor: 'parse' stamp: 'nice 12/27/2009 03:12'! parseKeyword | keyword rangeIndices | self parseBinary. keyword := ''. rangeIndices := #(). [ [self isKeyword] whileTrue: [ keyword := keyword, currentToken. self rangeType: #keyword. "remember where this keyword token is in ranges" rangeIndices := rangeIndices copyWith: ranges size. self scanNext. self parseTerm. self parseBinary ] ] ensure: [ | type | "do this in an ensure so that it happens even if the errorBlock evaluates before getting here" "patch up the keyword tokens, so that incomplete and undefined ones look different" (keyword isEmpty or:[Symbol hasInterned: keyword ifTrue: [:sym | ]]) ifFalse:[ type := (Symbol thatStartsCaseSensitive: keyword skipping: nil) isNil ifTrue: [#undefinedKeyword] ifFalse:[#incompleteKeyword]. rangeIndices do: [:i | (ranges at: i) type: type]]]! ! !SHParserST80 methodsFor: 'parse' stamp: 'tween 8/7/2005 14:27'! parseKeywordMessagePattern [self isKeyword] whileTrue: [ self scanPast: #patternKeyword. self failUnless: self isName. self scanPast: #patternArg] ! ! !SHParserST80 methodsFor: 'parse' stamp: 'tween 2/17/2007 14:43'! parseLiteral: inArray currentTokenFirst == $$ ifTrue: [ | pos | self failWhen: self currentChar isNil. self rangeType: #'$'. pos := currentTokenSourcePosition + 1. self nextChar. ^self scanPast: #character start: pos end: pos]. currentTokenFirst isDigit ifTrue: [ "do not parse the number, can be time consuming" ^self scanPast: #number]. currentToken = '-' ifTrue: [ | c | c := self currentChar. (inArray and: [c isNil or: [c isDigit not]]) ifTrue: [ "single - can be a symbol in an Array" ^self scanPast: #symbol]. self scanPast: #-. self failWhen: currentToken isNil. "token isNil ifTrue: [self error: 'Unexpected End Of Input']." "do not parse the number, can be time consuming" ^self scanPast: #number]. currentTokenFirst == $' ifTrue: [^self parseString]. currentTokenFirst == $# ifTrue: [^self parseSymbol]. (inArray and: [currentToken notNil]) ifTrue: [^self scanPast: #symbol]. self failWhen: currentTokenFirst == $. . self error ": 'argument missing'"! ! !SHParserST80 methodsFor: 'parse' stamp: 'lr 12/18/2009 11:50'! parseLiteralArrayElement (currentTokenFirst isLetter or: [currentTokenFirst == $_]) ifTrue: [ | type | type := (#('true' 'false' 'nil') includes: currentToken) ifTrue: [currentToken asSymbol] ifFalse: [#symbol]. ^self scanPast: type]. currentTokenFirst == $( ifTrue: [ self scanPast: #arrayStart. ^self parseArray]. currentTokenFirst == $[ ifTrue: [ self scanPast: #byteArrayStart. ^self parseByteArray ]. ^self parseLiteral: true! ! !SHParserST80 methodsFor: 'parse' stamp: 'tween 8/7/2005 14:28'! parseMessagePattern self isName ifTrue: [self parseUnaryMessagePattern] ifFalse: [ self isBinary ifTrue:[self parseBinaryMessagePattern] ifFalse:[ self failUnless: self isKeyword. self parseKeywordMessagePattern]]! ! !SHParserST80 methodsFor: 'parse' stamp: 'tween 2/17/2007 14:44'! parseMethodTemporaries currentTokenFirst == $| ifTrue: [ self scanPast: #methodTempBar. [self isName] whileTrue: [self scanPast: #patternTempVar]. self failUnless: currentToken = '|'. self scanPast: #methodTempBar]! ! !SHParserST80 methodsFor: 'parse' stamp: 'tween 12/29/2006 11:13'! parsePragmaBinary self scanPast: #pragmaBinary. self isName ifTrue:[self scanPast: (self resolvePragmaArgument: currentToken)] ifFalse:[ self parseLiteral: false]. self failUnless: currentToken = '>'. self scanPast: #primitiveOrExternalCallEnd! ! !SHParserST80 methodsFor: 'parse' stamp: 'tween 7/2/2006 12:59'! parsePragmaKeyword [self isKeyword] whileTrue:[ self scanPast: #pragmaKeyword. self isName ifTrue:[self scanPast: (self resolvePragmaArgument: currentToken)] ifFalse:[ self parseLiteral: false]]. self failUnless: currentToken = '>'. self scanPast: #primitiveOrExternalCallEnd! ! !SHParserST80 methodsFor: 'parse' stamp: 'tween 12/29/2006 11:11'! parsePragmaSequence [currentToken = '<' ] whileTrue:[ self scanPast: #primitiveOrExternalCallStart. currentToken = 'primitive:' ifTrue: [ self rangeType: #primitive. self parsePrimitive] ifFalse:[ self isTokenExternalFunctionCallingConvention ifTrue: [ self rangeType: #externalFunctionCallingConvention. self parseExternalCall] ifFalse:[ self isName ifTrue:[ self scanPast: #pragmaUnary. self failUnless: currentToken = '>'. self scanPast: #primitiveOrExternalCallEnd] ifFalse:[ self isKeyword ifTrue:[ self parsePragmaKeyword] ifFalse:[ self isBinary ifTrue:[self parsePragmaBinary] ifFalse:[ self error ": 'Invalid External Function Calling convention'" ]]]]]]! ! !SHParserST80 methodsFor: 'parse' stamp: 'tween 2/17/2007 15:10'! parsePrimitive self scanNext. currentTokenFirst isDigit ifTrue: [self scanPast: #integer] ifFalse: [ self failUnless: currentTokenFirst == $'. self parseString. currentToken = 'module:' ifTrue: [ self scanPast: #module. self failUnless: currentTokenFirst == $'. self parseString]]. self failUnless: currentToken = '>'. self scanPast: #primitiveOrExternalCallEnd! ! !SHParserST80 methodsFor: 'parse' stamp: 'tween 2/17/2007 14:44'! parseStatement currentTokenFirst == $^ ifTrue: [self scanPast: #return]. self parseExpression! ! !SHParserST80 methodsFor: 'parse' stamp: 'tween 2/17/2007 14:45'! parseStatementList [[currentTokenFirst == $.] whileTrue: [self scanPast: #statementSeparator]. (currentToken notNil and: [currentTokenFirst ~~ $]]) ifTrue: [self parseStatement]. currentTokenFirst == $.] whileTrue: [self scanPast: #statementSeparator]! ! !SHParserST80 methodsFor: 'parse' stamp: 'tween 2/17/2007 14:45'! parseStatementListForBraceArray "same as parseStatementList, but does not allow empty statements e.g {...$a...}. A single terminating . IS allowed e.g. {$a.} " [currentTokenFirst ~~ $} ifTrue: [self parseStatement]. currentTokenFirst == $.] whileTrue: [self scanPast: #statementSeparator]! ! !SHParserST80 methodsFor: 'parse' stamp: 'tween 2/17/2007 14:46'! parseString | first c answer last | first := sourcePosition. answer := ''. [(c := self currentChar) isNil ifTrue: [ self rangeType: #unfinishedString start: first - 1 end: source size. self error ": 'unfinished string'"]. (c ~~ $' ifTrue: [answer := answer copyWith: c. true] ifFalse: [false] ) or: [ self peekChar == $' ifTrue: [ sourcePosition := sourcePosition + 1. answer := answer copyWith: $'. true] ifFalse: [false]] ] whileTrue: [sourcePosition := sourcePosition + 1]. last := sourcePosition. self nextChar. self scanPast: #string start: first - 1 end: last. ^answer! ! !SHParserST80 methodsFor: 'parse' stamp: 'lr 11/8/2009 20:33'! 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 nextChar. self scanPast: #byteArrayStart start: currentTokenSourcePosition end: currentTokenSourcePosition + 1. ^self parseByteArray]. c == $' ifTrue: [^self parseSymbolString]. ((self isSelectorCharacter: c) or: [c == $-]) ifTrue: [^self parseSymbolSelector]. (c isLetter or: [c == $:]) ifTrue: [^self parseSymbolIdentifier]. ^self parseCharSymbol! ! !SHParserST80 methodsFor: 'parse' stamp: 'lr 12/18/2009 11:47'! parseSymbolIdentifier | c start end | c := self currentChar. self failUnless: (c isLetter or: [c == $: or: [c == $_]]). start := sourcePosition. [c := self nextChar.. c isAlphaNumeric or: [c == $: or: [c == $_]]] whileTrue: []. end := sourcePosition - 1. c := source copyFrom: start - 1 to: end. self scanPast: #symbol start: start - 1 end: end. ^c! ! !SHParserST80 methodsFor: 'parse' stamp: 'tween 4/28/2004 14:06'! parseSymbolSelector | start end | start := sourcePosition - 1. end := sourcePosition. [self isSelectorCharacter: self nextChar] whileTrue: [end := sourcePosition]. self scanPast: #symbol start: start end: end! ! !SHParserST80 methodsFor: 'parse' stamp: 'tween 2/17/2007 14:47'! parseSymbolString | first c last | first := sourcePosition. self nextChar. [(c := self currentChar) isNil ifTrue: [ self rangeType: #unfinishedString start: first end: source size. self error ": 'unfinished string'"]. c ~~ $' or: [ self peekChar == $' ifTrue: [sourcePosition := sourcePosition + 1.true] ifFalse: [false]] ] whileTrue: [sourcePosition := sourcePosition + 1]. last := sourcePosition. self nextChar. self scanPast: #stringSymbol start: first - 1 end: last! ! !SHParserST80 methodsFor: 'parse' stamp: 'tween 2/17/2007 14:47'! parseTerm self failWhen: currentToken isNil. currentTokenFirst == $( ifTrue: [ bracketDepth := bracketDepth + 1. self scanPast: #leftParenthesis level: bracketDepth. self parseExpression. self failUnless: currentTokenFirst == $). self scanPast: #rightParenthesis level: bracketDepth. ^bracketDepth := bracketDepth - 1]. currentTokenFirst == $[ ifTrue: [^self parseBlock]. currentTokenFirst == ${ ifTrue: [ self scanPast: #leftBrace. ^self parseBraceArray]. self isName ifTrue: [^self scanPast: (self resolve: currentToken)]. self parseLiteral: false! ! !SHParserST80 methodsFor: 'parse' stamp: 'tween 5/7/2004 09:33'! parseUnary | unary type | [self isName] whileTrue: [ unary := currentToken. type := #unary. (unary isEmpty or:[Symbol hasInterned: unary ifTrue: [:sym | ]]) ifFalse:[ type := (Symbol thatStartsCaseSensitive: unary skipping: nil) isNil ifTrue: [#undefinedUnary] ifFalse:[#incompleteUnary]]. self scanPast: type] ! ! !SHParserST80 methodsFor: 'parse' stamp: 'tween 4/17/2004 22:17'! parseUnaryMessagePattern self scanPast: #patternUnary ! ! !SHParserST80 methodsFor: 'scan' stamp: 'tween 4/28/2004 09:42'! peekChar ^source at: sourcePosition + 1 ifAbsent: [$ ]! ! !SHParserST80 methodsFor: 'parse support' stamp: 'tween 4/28/2004 10:03'! pushArgument: aString (arguments at: blockDepth ifAbsentPut: [OrderedCollection new: 10]) add: aString! ! !SHParserST80 methodsFor: 'parse support' stamp: 'tween 4/28/2004 10:05'! pushTemporary: aString (temporaries at: blockDepth ifAbsentPut: [OrderedCollection new: 10]) add: aString! ! !SHParserST80 methodsFor: 'recording ranges' stamp: 'tween 4/28/2004 09:54'! rangeType: aSymbol ^self rangeType: aSymbol start: currentTokenSourcePosition end: currentTokenSourcePosition + currentToken size - 1! ! !SHParserST80 methodsFor: 'recording ranges' stamp: 'tween 4/28/2004 10:20'! rangeType: aSymbol start: s end: e ^ranges add: (SHRange start: s end: e type: aSymbol)! ! !SHParserST80 methodsFor: 'parse' stamp: 'tween 8/26/2004 03:07'! rangesIn: sourceString classOrMetaClass: aBehaviour workspace: aWorkspace environment: anEnvironmentOrNil anEnvironmentOrNil ifNotNil: [environment := anEnvironmentOrNil]. self workspace: aWorkspace; classOrMetaClass: aBehaviour; source: sourceString. self parse. ^ranges! ! !SHParserST80 methodsFor: 'identifier testing' stamp: 'tween 12/21/2005 12:02'! resolve: aString (#('self' 'super' 'true' 'false' 'nil' 'thisContext') includes: aString) ifTrue: [^aString asSymbol]. (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 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]]] ifFalse: [(environment bindingOf: sym) ifNotNil: [^#globalVar]]]. ^self resolvePartial: aString! ! !SHParserST80 methodsFor: 'identifier testing' stamp: 'tween 12/21/2005 12:24'! 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 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]]] ifFalse: [(environment hasBindingThatBeginsWith: aString) ifTrue: [^#incompleteIdentifier]]. ^#undefinedIdentifier! ! !SHParserST80 methodsFor: 'identifier testing' stamp: 'tween 7/2/2006 12:58'! 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 isBehavior ifTrue: [ classOrMetaClass theNonMetaClass withAllSuperclasses do: [:c | (c environment hasBindingThatBeginsWith: aString) ifTrue: [^#incompleteIdentifier]]] ifFalse: [(environment hasBindingThatBeginsWith: aString) ifTrue: [^#incompleteIdentifier]]. ^#undefinedIdentifier! ! !SHParserST80 methodsFor: 'identifier testing' stamp: 'tween 7/2/2006 12:54'! resolvePragmaArgument: aString (#('true' 'false' 'nil') includes: aString) ifTrue: [^aString asSymbol]. "should really check that global is a class?" Symbol hasInterned: aString ifTrue: [:sym | classOrMetaClass isBehavior ifTrue: [ classOrMetaClass theNonMetaClass withAllSuperclasses do: [:c | (c environment bindingOf: sym) ifNotNil: [^#globalVar]]] ifFalse: [(environment bindingOf: sym) ifNotNil: [^#globalVar]]]. ^self resolvePartialPragmaArgument: aString! ! !SHParserST80 methodsFor: 'scan' stamp: 'tween 2/17/2007 14:49'! scanBinary | c d | c := self currentChar. currentTokenSourcePosition := sourcePosition. currentToken := c asString. d := self nextChar. ((self isSelectorCharacter: c) or: [c == $: or: [c == $-]]) ifFalse: [^currentToken]. (c == $: and: [d == $=]) ifTrue: [" := assignment" currentToken := currentToken , d asString. self nextChar. ^currentToken]. c == $| ifTrue:["| cannot precede a longer token" ^currentToken]. [self isSelectorCharacter: d] whileTrue: [ currentToken := currentToken , d asString. d := self nextChar]. ^currentToken! ! !SHParserST80 methodsFor: 'scan' stamp: 'tween 2/17/2007 14:49'! scanComment | 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! ! !SHParserST80 methodsFor: 'scan' stamp: 'lr 12/18/2009 11:49'! scanIdentifier | c start | start := sourcePosition. [(c := self nextChar) isAlphaNumeric or: [c == $_]] whileTrue: []. (c == $: and: [(self isSelectorCharacter: self peekChar) not]) ifTrue: [self nextChar]. currentToken := source copyFrom: start to: sourcePosition - 1. currentTokenSourcePosition := start! ! !SHParserST80 methodsFor: 'scan' stamp: 'lr 12/18/2009 11:50'! scanNext self scanWhitespace. currentTokenFirst := self currentChar. currentTokenFirst isNil ifTrue: [" end of input " currentTokenFirst := $ . currentTokenSourcePosition := nil. currentToken := nil. ^nil]. currentTokenFirst isDigit ifTrue: [^self scanNumber]. (currentTokenFirst isLetter or: [currentTokenFirst == $_]) ifTrue: [^self scanIdentifier]. ^self scanBinary! ! !SHParserST80 methodsFor: 'scan' stamp: 'tween 3/4/2007 13:15'! scanNumber | start c nc base | start := sourcePosition. self skipDigits. c := self currentChar. c == $r ifTrue: [ base := Integer readFrom: (ReadStream on: (source copyFrom: start to: sourcePosition - 1)). self peekChar == $- ifTrue:[self nextChar]. self skipBigDigits: base. c := self currentChar. c == $. ifTrue: [ (self isBigDigit: self nextChar base: base) ifFalse: [sourcePosition := sourcePosition - 1] ifTrue: [self skipBigDigits: base]]. c := self currentChar. ('deq'includes: c) ifTrue: [ ((nc := self nextChar) isDigit or: [nc == $- and:[self peekChar isDigit]]) ifFalse: [sourcePosition := sourcePosition - 1] ifTrue: [self skipDigits]]. c == $s ifTrue: [ self nextChar isDigit ifFalse: [sourcePosition := sourcePosition - 1] ifTrue: [self skipDigits]]. currentToken := source copyFrom: start to: sourcePosition - 1. ^currentTokenSourcePosition := start]. c == $s ifTrue: [ self nextChar isDigit ifFalse: [sourcePosition := sourcePosition - 1] ifTrue: [self skipDigits.]. currentToken := source copyFrom: start to: sourcePosition - 1. ^currentTokenSourcePosition := start]. c == $. ifTrue: [ self nextChar isDigit ifFalse: [ sourcePosition := sourcePosition - 1. currentToken := source copyFrom: start to: sourcePosition - 1. ^currentTokenSourcePosition := start] ifTrue: [self skipDigits]]. c := self currentChar. ('deq' includes: c) ifTrue: [ ((nc := self nextChar) isDigit or: [nc == $- and:[self peekChar isDigit]]) ifFalse: [sourcePosition := sourcePosition - 1] ifTrue: [self skipDigits]]. c == $s ifTrue: [ self nextChar isDigit ifFalse: [sourcePosition := sourcePosition - 1] ifTrue: [self skipDigits]]. currentToken := source copyFrom: start to: sourcePosition - 1. ^currentTokenSourcePosition := start! ! !SHParserST80 methodsFor: 'scan' stamp: 'tween 4/28/2004 10:06'! scanPast: rangeType "record rangeType for current token . record argument and temp declarations. scan and answer the next token" rangeType = #blockPatternArg ifTrue: [self pushArgument: currentToken]. rangeType = #blockPatternTempVar ifTrue: [self pushTemporary: currentToken]. rangeType = #patternArg ifTrue: [self pushArgument: currentToken]. rangeType = #patternTempVar ifTrue: [self pushTemporary: currentToken]. ^self rangeType: rangeType; scanNext! ! !SHParserST80 methodsFor: 'scan' stamp: 'tween 4/28/2004 14:17'! scanPast: rangeType level: level "first level adds no suffix to the rangeType. Suffix from 1 to 7 added in cycles , ((level-2) mod(7) + 1)" | cycle typePlusCycle | cycle := level <= 1 ifTrue: [0] ifFalse:[ ((level - 2) \\ 7) + 1]. typePlusCycle := cycle = 0 ifTrue:[rangeType] ifFalse:[(rangeType, cycle asString) asSymbol]. ^self scanPast: typePlusCycle ! ! !SHParserST80 methodsFor: 'scan' stamp: 'tween 4/28/2004 09:56'! scanPast: rangeType start: startInteger end: endInteger "record rangeType for current token from startInteger to endInteger, and scanNext token" ^self rangeType: rangeType start: startInteger end: endInteger; scanNext ! ! !SHParserST80 methodsFor: 'scan' stamp: 'tween 2/17/2007 14:51'! scanWhitespace | c | [c := self currentChar. c notNil and: [c isSeparator]] whileTrue: [sourcePosition := sourcePosition + 1]. c == $" ifTrue: [self scanComment]! ! !SHParserST80 methodsFor: 'scan' stamp: 'tween 8/6/2005 13:20'! skipBigDigits: baseInteger [self isBigDigit: self nextChar base: baseInteger] whileTrue: [] ! ! !SHParserST80 methodsFor: 'scan' stamp: 'tween 4/28/2004 14:57'! skipDigits [self nextChar isDigit] whileTrue: []! ! !SHParserST80 methodsFor: 'accessing' stamp: 'tween 4/17/2004 22:21'! source ^source! ! !SHParserST80 methodsFor: 'accessing' stamp: 'tween 4/27/2004 18:59'! source: aString source := aString! ! !SHParserST80 methodsFor: 'accessing' stamp: 'tween 4/15/2004 13:18'! workspace: aWorkspace workspace := aWorkspace! ! Object subclass: #SHPreferences instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Shout-Styling'! SHPreferences class instanceVariableNames: 'enabled'! SHPreferences class instanceVariableNames: 'enabled'! !SHPreferences class methodsFor: 'accessing' stamp: 'lr 8/15/2010 14:26'! enabled ^ enabled! ! !SHPreferences class methodsFor: 'accessing' stamp: 'lr 8/15/2010 14:19'! enabled: aBoolean enabled := aBoolean! ! !SHPreferences class methodsFor: 'initialization' stamp: 'lr 8/15/2010 14:19'! initialize enabled := true! ! !SHPreferences class methodsFor: 'settings' stamp: 'lr 8/15/2010 14:34'! settingsOn: aBuilder (aBuilder group: #'Shout: Syntax Highlighting') target: self; parentName: #codeBrowsing; description: 'Syntax Highlighting As You Type'; with: [ (aBuilder setting: #enabled) order: 0; label: 'Enabled'; description: 'Enable or disable syntax highlighting in browsers, debuggers and workspaces.' ]! ! Object subclass: #SHRange instanceVariableNames: 'start end type' classVariableNames: '' poolDictionaries: '' category: 'Shout-Parsing'! !SHRange commentStamp: 'tween 8/16/2004 15:16' prior: 0! I associate a type with a range of characters in a String I have these instance variables... start - the one based index of the first character of the range within the String. end - the one based index of the last character of the range within the String. type - a Symbol describing the type of the range A sequence of instances of me are created by an instance of SHParserST80 which can then used by an instance of SHTextStyler to style Text. ! !SHRange class methodsFor: 'instance creation' stamp: 'tween 2/17/2007 14:04'! start: s end: e type: aSymbol ^self new start: s end: e type: aSymbol; yourself! ! !SHRange methodsFor: 'accessing' stamp: 'tween 4/13/2004 18:55'! end ^end! ! !SHRange methodsFor: 'accessing' stamp: 'tween 4/13/2004 18:55'! end: anInteger end := anInteger! ! !SHRange methodsFor: 'accessing' stamp: 'tween 4/24/2004 15:48'! length ^end - start + 1! ! !SHRange methodsFor: 'accessing' stamp: 'tween 4/13/2004 18:54'! start ^start! ! !SHRange methodsFor: 'accessing' stamp: 'tween 4/13/2004 18:54'! start: anInteger start := anInteger! ! !SHRange methodsFor: 'accessing' stamp: 'tween 2/17/2007 14:03'! start: startInteger end: endInteger type: typeSymbol start := startInteger. end := endInteger. type := typeSymbol! ! !SHRange methodsFor: 'accessing' stamp: 'tween 4/13/2004 18:55'! type ^type! ! !SHRange methodsFor: 'accessing' stamp: 'tween 4/13/2004 18:55'! type: aSymbol type := aSymbol! ! Object subclass: #SHTextStyler instanceVariableNames: 'sem backgroundProcess text monitor view stylingEnabled' classVariableNames: '' poolDictionaries: '' category: 'Shout-Styling'! !SHTextStyler commentStamp: 'tween 8/27/2004 10:54' prior: 0! I am an Abstract class. Subclasses of me can create formatted, coloured, and styled copies of Text that is given to them. They may perform their styling asynchronously, in a background process which I create and manage. My public interface is... view: aViewOrMorph - set the view that will receive notifications when styling has completed. format: aText - modifies aText's string style: aText - modifies the TextAttributes of aText, but does not change the string, then sends #stylerStyled: to the view. styleInBackgroundProcess: aText - performs style: in a background process, then sends #stylerStylednBackground: to the view. styledTextFor: aText - answers a formatted and styled copy of aText unstyledTextFrom: aText - answers a copy of aText with all TextAttributes removed Subclasses of me should re-implement... privateFormat: aText - answer a formatted version of aText; the String may be changed privateStyle: aText - modify the TextAttributes of aText; but do not change the String ! !SHTextStyler class methodsFor: 'as yet unclassified' stamp: 'tween 8/28/2004 00:20'! new ^super new initialize; yourself! ! !SHTextStyler methodsFor: 'styling' stamp: 'lr 4/8/2010 15:56'! evaluateWithoutStyling: aBlock | t | t := stylingEnabled. stylingEnabled := false. ^ aBlock ensure: [stylingEnabled := t]! ! !SHTextStyler methodsFor: 'formatting' stamp: 'tween 8/26/2004 02:19'! format: aText "Answer a copy of which has been reformatted, or if no formatting is to be applied" self terminateBackgroundStylingProcess. ^self privateFormat: aText! ! !SHTextStyler methodsFor: 'styling' stamp: 'tween 8/28/2004 00:21'! initialize stylingEnabled := true ! ! !SHTextStyler methodsFor: 'private' stamp: 'tween 4/9/2004 12:13'! monitor monitor isNil ifTrue: [monitor := Monitor new]. ^monitor! ! !SHTextStyler methodsFor: 'private' stamp: 'tween 8/26/2004 02:26'! privateFormat: aText self shouldBeImplemented! ! !SHTextStyler methodsFor: 'private' stamp: 'tween 8/26/2004 02:25'! privateStyle: aText self shouldBeImplemented! ! !SHTextStyler methodsFor: 'styling' stamp: 'tween 8/30/2004 12:32'! style: aText self terminateBackgroundStylingProcess. stylingEnabled ifTrue:[ text := aText copy. self privateStyle: text. view ifNotNil:[view stylerStyled: text] ]! ! !SHTextStyler methodsFor: 'styling' stamp: 'tween 8/30/2004 12:32'! styleInBackgroundProcess: aText self terminateBackgroundStylingProcess. stylingEnabled ifTrue:[ text := aText copy. self monitor critical: [ sem := Semaphore new. [sem notNil ifTrue: [ sem wait. view ifNotNil:[view stylerStyledInBackground: text]] ] forkAt: Processor activePriority. backgroundProcess := [self privateStyle: text. sem signal] forkAt: Processor userBackgroundPriority] ] ! ! !SHTextStyler methodsFor: 'styling' stamp: 'tween 8/26/2004 02:30'! styledTextFor: aText "Answer a copy of aText that is both formatted and styled" | formattedText | formattedText := self privateFormat: aText. self privateStyle: formattedText. ^formattedText! ! !SHTextStyler methodsFor: 'private' stamp: 'tween 4/9/2004 12:21'! terminateBackgroundStylingProcess self monitor critical: [ backgroundProcess ifNotNil: [ backgroundProcess terminate. backgroundProcess := nil]. sem ifNotNil:[ sem terminateProcess. sem := nil]. ] ! ! !SHTextStyler methodsFor: 'styling' stamp: 'tween 8/26/2004 02:47'! unstyledTextFrom: aText ^Text fromString: aText string! ! !SHTextStyler methodsFor: 'accessing' stamp: 'tween 8/26/2004 00:30'! view: aViewOrMorph view := aViewOrMorph! ! SHTextStyler subclass: #SHTextStylerST80 instanceVariableNames: 'classOrMetaClass workspace font parser environment pixelHeight' classVariableNames: '' poolDictionaries: '' category: 'Shout-Styling'! SHTextStylerST80 class instanceVariableNames: 'styleTable textAttributesByPixelHeight'! !SHTextStylerST80 commentStamp: 'tween 8/27/2004 10:55' prior: 0! I style Smalltalk methods and expressions. My 'styleTable' class instance var holds an array ofArrays which control how each token is styled/coloured. See my defaultStyleTable class method for its structure. My styleTable can be changed by either modifying the defaultStyleTable class method and then executing SHTextStylerST80 initialize ; or by giving me a new styleTable through my #styleTable: class method. My 'textAttributesByPixelSize' class instance var contains a dictionary of dictionaries. The key is a pixelSize and the value a Dictionary from token type Symbol to TextAttribute array. It is created/maintained automatically. I also install these 3 preferences when my class initialize method is executed.... #syntaxHighlightingAsYouType - controls whether methods are styled in browsers #syntaxHighlightingAsYouTypeAnsiAssignment - controls whether assignments are formatted to be := #syntaxHighlightingAsYouTypeLeftArrowAssignment - controls whether assignments are formatted to be _ I reimplement #unstyledTextFrom: so that TextActions are preserved in the unstyled text ! SHTextStylerST80 class instanceVariableNames: 'styleTable textAttributesByPixelHeight'! !SHTextStylerST80 class methodsFor: 'style table' stamp: 'tween 8/29/2004 19:12'! attributeArrayForColor: aColorOrNil emphasis: anEmphasisSymbolOrArrayorNil font: aTextStyleOrFontOrNil "Answer a new Array containing any non nil TextAttributes specified" | answer emphArray | answer := Array new. aColorOrNil ifNotNil: [answer := answer, {TextColor color: aColorOrNil}]. anEmphasisSymbolOrArrayorNil ifNotNil: [ emphArray := anEmphasisSymbolOrArrayorNil isSymbol ifTrue: [{anEmphasisSymbolOrArrayorNil}] ifFalse: [anEmphasisSymbolOrArrayorNil]. emphArray do: [:each | each ~= #normal ifTrue:[ answer := answer, {TextEmphasis perform: each}]]]. aTextStyleOrFontOrNil ifNotNil: [ answer := answer, {TextFontReference toFont: aTextStyleOrFontOrNil}]. ^answer! ! !SHTextStylerST80 class methodsFor: 'style table' stamp: 'tween 2/17/2007 13:59'! attributesFor: aSymbol pixelHeight: aNumber ^(self textAttributesByPixelHeight at: aNumber ifAbsentPut:[self initialTextAttributesForPixelHeight: aNumber]) at: aSymbol ifAbsent:[nil]! ! !SHTextStylerST80 class methodsFor: 'style table' stamp: 'lr 6/30/2010 17:36'! defaultStyleTable "color can be a valid argument to Color class>>colorFrom: , or nil to use the editor text color. Multiple emphases can be specified using an array e.g. #(bold italic). If emphasis is not specified, #normal will be used. if pixel height is not specified , then the editor font size will be used. " ^#( "(symbol color [emphasisSymbolOrArray [textStyleName [pixelHeight]]])" (default ( black ) ) (invalid ( red ) ) (excessCode ( red ) ) (comment ( green muchDarker ) ) (unfinishedComment ( green muchDarker ) ) (#'$' ( magenta muchDarker) ) (character ( magenta muchDarker) ) (integer ( magenta muchDarker) ) (number ( magenta muchDarker) ) (#- ( magenta muchDarker) ) (symbol ( magenta muchDarker) ) (stringSymbol ( magenta muchDarker) ) (literalArray ( magenta muchDarker) ) (string ( magenta muchDarker) ) (unfinishedString ( magenta muchDarker) ) (assignment ( black ) ) (ansiAssignment ( black ) ) (literal ( black ) ) (keyword ( black ) ) (binary ( black ) ) (unary ( black ) ) (incompleteKeyword ( red ) ) (incompleteBinary ( red ) ) (incompleteUnary ( red ) ) (undefinedKeyword ( red ) ) (undefinedBinary ( red ) ) (undefinedUnary ( red ) ) (patternKeyword ( black ) bold ) (patternBinary ( black ) bold ) (patternUnary ( black ) bold ) (#self ( cyan muchDarker ) ) (#super ( cyan muchDarker ) ) (#true ( cyan muchDarker ) ) (#false ( cyan muchDarker ) ) (#nil ( cyan muchDarker ) ) (#thisContext ( cyan muchDarker ) ) (#return ( black ) ) (patternArg ( blue muchDarker ) ) (methodArg ( blue muchDarker ) ) (blockPatternArg ( blue muchDarker ) ) (blockArg ( blue muchDarker ) ) (argument ( blue muchDarker ) ) (blockArgColon black ) (leftParenthesis black ) (rightParenthesis black ) (leftParenthesis1 black ) (rightParenthesis1 black ) (leftParenthesis2 black ) (rightParenthesis2 black ) (leftParenthesis3 black ) (rightParenthesis3 black ) (leftParenthesis4 black ) (rightParenthesis4 black ) (leftParenthesis5 black ) (rightParenthesis5 black ) (leftParenthesis6 black ) (rightParenthesis6 black ) (leftParenthesis7 black ) (rightParenthesis7 black ) (blockStart black ) (blockEnd black ) (blockStart1 black ) (blockEnd1 black ) (blockStart2 black ) (blockEnd2 black ) (blockStart3 black ) (blockEnd3 black ) (blockStart4 black ) (blockEnd4 black ) (blockStart5 black ) (blockEnd5 black ) (blockStart6 black ) (blockEnd6 black ) (blockStart7 black ) (blockEnd7 black ) (arrayStart black ) (arrayEnd black ) (arrayStart1 black ) (arrayEnd1 black ) (byteArrayStart black ) (byteArrayEnd black ) (byteArrayStart1 black ) (byteArrayEnd1 black ) (leftBrace black ) (rightBrace black ) (cascadeSeparator black ) (statementSeparator black ) (externalCallType black ) (externalCallTypePointerIndicator black ) (primitiveOrExternalCallStart black ) (primitiveOrExternalCallEnd black ) (methodTempBar black ) (blockTempBar black ) (blockArgsBar black ) (primitive gray ) (externalFunctionCallingConvention gray ) (module gray ) (blockTempVar ( blue muchDarker ) ) (blockPatternTempVar ( blue muchDarker ) ) (instVar ( blue muchDarker ) ) (workspaceVar ( blue muchDarker ) ) (undefinedIdentifier ( red ) ) (incompleteIdentifier ( red ) ) (tempVar ( blue muchDarker ) ) (patternTempVar ( blue muchDarker ) ) (poolConstant ( blue muchDarker ) ) (classVar ( blue muchDarker ) ) (globalVar ( blue muchDarker ) ) ) ! ! !SHTextStylerST80 class methodsFor: 'style table' stamp: 'nice 12/27/2009 03:12'! initialTextAttributesForPixelHeight: aNumber | d | d := IdentityDictionary new. self styleTable do: [:each | | textStyle element emphasis font pixelHeight attrArray color textStyleName | element := each first. color := each at: 2 ifAbsent:[nil]. color:=color ifNotNil: [Color colorFrom: color]. emphasis := each at: 3 ifAbsent:[nil]. textStyleName := each at: 4 ifAbsent: [nil]. pixelHeight := each at: 5 ifAbsent: [aNumber]. textStyleName ifNil:[pixelHeight := nil]. textStyle := TextStyle named: textStyleName. font := textStyle ifNotNil:[pixelHeight ifNotNil:[textStyle fontOfSize: pixelHeight]]. attrArray := self attributeArrayForColor: color emphasis: emphasis font: font. attrArray notEmpty ifTrue:[ d at: element put: attrArray]]. ^d ! ! !SHTextStylerST80 class methodsFor: 'initialization' stamp: 'lr 8/15/2010 14:32'! initialize "Clear styleTable and textAttributesByPixelSize cache so that they will reinitialize. SHTextStylerST80 initialize " styleTable := nil. textAttributesByPixelHeight := nil! ! !SHTextStylerST80 class methodsFor: 'style table' stamp: 'lr 12/18/2009 11:31'! styleTable ^ styleTable ifNil: [ styleTable := self defaultStyleTable ]! ! !SHTextStylerST80 class methodsFor: 'style table' stamp: 'tween 8/28/2004 16:28'! styleTable: anArray "Set the receiver's styleTable to anArray. Clear textAttributesByPixelSize cache so that it will reinitialize. " styleTable := anArray. textAttributesByPixelHeight := nil! ! !SHTextStylerST80 class methodsFor: 'style table' stamp: 'lr 12/18/2009 11:30'! textAttributesByPixelHeight ^ textAttributesByPixelHeight ifNil: [ textAttributesByPixelHeight := Dictionary new ]! ! !SHTextStylerST80 methodsFor: 'private' stamp: 'tween 4/24/2004 14:04'! attributesFor: aSymbol ^self class attributesFor: aSymbol pixelHeight: self pixelHeight ! ! !SHTextStylerST80 methodsFor: 'accessing' stamp: 'tween 4/9/2004 12:47'! classOrMetaClass: aBehavior classOrMetaClass := aBehavior! ! !SHTextStylerST80 methodsFor: 'accessing' stamp: 'tween 5/9/2004 12:50'! environment: anObject environment := anObject! ! !SHTextStylerST80 methodsFor: 'accessing' stamp: 'tween 4/18/2004 10:32'! font: aFont font := aFont! ! !SHTextStylerST80 methodsFor: 'initialize-release' stamp: 'AndrewTween 11/7/2009 16:28'! initialize super initialize.! ! !SHTextStylerST80 methodsFor: 'private' stamp: 'tween 8/26/2004 02:55'! parseableSourceCodeTemplate ^'messageSelectorAndArgumentNames "comment stating purpose of message" | temporary variable names | statements'! ! !SHTextStylerST80 methodsFor: 'private' stamp: 'tween 2/17/2007 12:47'! pixelHeight "In Morphic the receiver will have been given a code font, in MVC the font will be nil. So when the font is nil, answer the pixelHeight of the MVC Browsers' code font, i.e. TextStyle defaultFont pixelHeight" ^pixelHeight ifNil:[pixelHeight := (font ifNil:[TextStyle defaultFont]) pixelSize]! ! !SHTextStylerST80 methodsFor: 'private' stamp: 'AndrewTween 11/7/2009 16:29'! privateFormat: aText "Perform any formatting of aText necessary and answer either aText, or a formatted copy of aText" aText asString = Object sourceCodeTemplate ifTrue:[ "the original source code template does not parse, replace it with one that does" ^self parseableSourceCodeTemplate asText]. ^aText! ! !SHTextStylerST80 methodsFor: 'private' stamp: 'tween 8/26/2004 03:14'! privateStyle: aText | ranges | ranges := self rangesIn: aText setWorkspace: true. ranges ifNotNil: [self setAttributesIn: aText fromRanges: ranges]! ! !SHTextStylerST80 methodsFor: 'private' stamp: 'tween 8/26/2004 03:13'! rangesIn: aText setWorkspace: aBoolean "Answer a collection of SHRanges by parsing aText. When formatting it is not necessary to set the workspace, and this can make the parse take less time, so aBoolean specifies whether the parser should be given the workspace" parser ifNil: [parser := SHParserST80 new]. ^parser rangesIn: aText asString classOrMetaClass: classOrMetaClass workspace: (aBoolean ifTrue:[workspace]) environment: environment ! ! !SHTextStylerST80 methodsFor: 'private' stamp: 'tween 2/17/2007 15:02'! setAttributesIn: aText fromRanges: ranges | charAttr defaultAttr attr newRuns newValues lastAttr oldRuns lastCount | oldRuns := aText runs. defaultAttr := self attributesFor: #default. charAttr := Array new: aText size. 1 to: charAttr size do: [:i | charAttr at: i put: defaultAttr]. ranges do: [:range | (attr := self attributesFor: range type) == nil ifFalse:[ range start to: range end do: [:i | charAttr at: i put: attr]]]. newRuns := OrderedCollection new: charAttr size // 10. newValues := OrderedCollection new: charAttr size // 10. 1 to: charAttr size do: [:i | attr := charAttr at: i. i = 1 ifTrue: [ newRuns add: 1. lastCount := 1. lastAttr := newValues add: attr] ifFalse:[ attr == lastAttr ifTrue: [ lastCount := lastCount + 1. newRuns at: newRuns size put: lastCount] ifFalse: [ newRuns add: 1. lastCount := 1. lastAttr := newValues add: attr]]]. aText runs: (RunArray runs: newRuns values: newValues). oldRuns withStartStopAndValueDo:[:start :stop :attribs| (attribs detect: [:each | each shoutShouldPreserve] ifNone:[nil]) == nil ifFalse: [ attribs do: [:eachAttrib | aText addAttribute: eachAttrib from: start to: stop]]]. ! ! !SHTextStylerST80 methodsFor: 'accessing' stamp: 'AndrewTween 11/7/2009 16:33'! sourceMap: aSortedCollection "Deprecated. This method stub is left so that classes that used earlier versions of Shout will continue to function"! ! !SHTextStylerST80 methodsFor: 'converting' stamp: 'tween 8/26/2004 02:52'! unstyledTextFrom: aText "Re-implemented so that TextActions are not removed from aText" | answer | answer := super unstyledTextFrom: aText. aText runs withStartStopAndValueDo:[:start :stop :attribs| (attribs detect: [:each | each isKindOf: TextAction] ifNone:[nil]) ifNotNil:[ attribs do: [:eachAttrib | answer addAttribute: eachAttrib from: start to: stop]]]. ^answer! ! !SHTextStylerST80 methodsFor: 'accessing' stamp: 'tween 4/15/2004 13:23'! workspace: aWorkspace workspace := aWorkspace! ! PluggableShoutMorph initialize! SHPreferences initialize! SHTextStylerST80 initialize!