'From Croquet1.0beta of 11 April 2006 [latest update: #1] on 22 August 2008 at 10:25:41 am'! VariableNode subclass: #FieldNode instanceVariableNames: 'fieldDef rcvrNode readNode writeNode' classVariableNames: '' poolDictionaries: '' category: 'Compiler-ParseNodes'! !FieldNode commentStamp: '' prior: 0! FileNode handles field access in Tweak, e.g. self fieldName := foo => self fieldName: foo.! ]style[(90)i! VariableNode subclass: #InstanceVariableNode instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Compiler-ParseNodes'! !FieldNode methodsFor: 'testing' stamp: 'eem 5/12/2008 13:40'! assignmentCheck: encoder at: location (encoder cantStoreInto: name) ifTrue: [^location]. fieldDef toSet ifNil:[ encoder interactive ifTrue:[^location]. fieldDef := fieldDef clone assignDefaultSetter. ]. ^-1! ! !FieldNode methodsFor: 'code generation' stamp: 'eem 5/12/2008 13:40'! emitForEffect: stack on: strm ! ! !FieldNode methodsFor: 'code generation' stamp: 'eem 5/12/2008 13:40'! emitForValue: stack on: aStream fieldDef accessKey ifNil:[ rcvrNode emitForValue: stack on: aStream. readNode emit: stack args: 0 on: aStream super: false. ] ifNotNil:[ rcvrNode emitForValue: stack on: aStream. super emitForValue: stack on: aStream. readNode emit: stack args: 1 on: aStream super: false. ]. ! ! !FieldNode methodsFor: 'code generation' stamp: 'eem 5/12/2008 13:40'! emitLoad: stack on: strm rcvrNode emitForValue: stack on: strm. fieldDef accessKey ifNotNil:[ super emitForValue: stack on: strm. ].! ! !FieldNode methodsFor: 'code generation' stamp: 'eem 5/12/2008 13:40'! emitStorePop: stack on: strm self emitStore: stack on: strm. strm nextPut: Pop. stack pop: 1.! ! !FieldNode methodsFor: 'code generation' stamp: 'eem 5/12/2008 13:40'! emitStore: stack on: strm fieldDef accessKey ifNil:[ writeNode emit: stack args: 1 on: strm super: false. ] ifNotNil:[ writeNode emit: stack args: 2 on: strm super: false. ].! ! !FieldNode methodsFor: 'code generation' stamp: 'eem 5/12/2008 13:40'! encodeReceiverOn: encoder "encode the receiver node" rcvrNode := encoder encodeVariable: 'self'.! ! !FieldNode methodsFor: 'code generation' stamp: 'eem 5/12/2008 13:40'! sizeForEffect: encoder ^0! ! !FieldNode methodsFor: 'code generation' stamp: 'eem 5/12/2008 13:40'! sizeForStorePop: encoder ^(self sizeForStore: encoder) + 1! ! !FieldNode methodsFor: 'code generation' stamp: 'eem 5/12/2008 13:40'! sizeForStore: encoder rcvrNode ifNil:[self encodeReceiverOn: encoder]. fieldDef accessKey ifNil:[ writeNode ifNil:[writeNode := encoder encodeSelector: fieldDef toSet]. ^(rcvrNode sizeForValue: encoder) + (writeNode size: encoder args: 1 super: false) ]. writeNode ifNil:[writeNode := encoder encodeSelector: #set:to:]. ^(rcvrNode sizeForValue: encoder) + (super sizeForValue: encoder) + (writeNode size: encoder args: 2 super: false)! ! !FieldNode methodsFor: 'code generation' stamp: 'eem 5/12/2008 13:40'! sizeForValue: encoder rcvrNode ifNil:[self encodeReceiverOn: encoder]. fieldDef accessKey ifNil:[ readNode ifNil:[readNode := encoder encodeSelector: fieldDef toGet]. ^(rcvrNode sizeForValue: encoder) + (readNode size: encoder args: 0 super: false) ]. readNode ifNil:[readNode := encoder encodeSelector: #get:]. ^(rcvrNode sizeForValue: encoder) + (super sizeForValue: encoder) + (readNode size: encoder args: 1 super: false)! ! !FieldNode methodsFor: 'accessing' stamp: 'eem 5/12/2008 13:40'! fieldDef ^fieldDef! ! !FieldNode methodsFor: 'initialize-release' stamp: 'eem 5/12/2008 13:40'! fieldDefinition: fieldDefinition self name: fieldDefinition name key: fieldDefinition index: nil type: LdLitType! ! !FieldNode methodsFor: 'initialize-release' stamp: 'eem 5/12/2008 13:40'! name: varName key: objRef index: i type: type fieldDef := objRef. ^super name: varName key: objRef key index: nil type: LdLitType! ! !InstanceVariableNode methodsFor: 'initialize-release' stamp: 'eem 5/13/2008 10:17'! name: varName index: varIndex ^self name: varName index: varIndex-1 type: LdInstType! ! !Behavior methodsFor: '*Tweak-Core-Proto' stamp: 'eem 5/13/2008 09:56'! allFieldsReverseDo: aBlock "Evaluate aBlock with all field definitions, in superclass preceeding subclass order." "Nothing to do here; CProtoObject introduces field definitions." ^self! ! !ParseNode methodsFor: 'testing' stamp: 'eem 7/18/2008 16:22'! isFutureNode ^false! ! !Encoder methodsFor: 'encoding' stamp: 'eem 6/24/2008 14:23'! doItInContextName ^'_thisContext'! ! !Encoder methodsFor: 'private' stamp: 'ar 3/26/2004 15:44'! interactive ^requestor interactive! ! !Scanner methodsFor: 'multi-character scans' stamp: 'ar 5/10/2005 12:23'! typeTableAt: aCharacter ^typeTable at: aCharacter charCode ifAbsent:[#xLetter]! ! !Parser methodsFor: 'temps' stamp: 'eem 5/13/2008 12:17'! bindTemp: name in: methodSelector ^name! ! !Parser methodsFor: 'error handling' stamp: 'eem 5/14/2008 13:34'! addWarning: aString "ignored by the default compiler."! ! !Behavior methodsFor: 'compiling' stamp: 'eem 5/13/2008 09:50'! instVarNamesAndOffsetsDo: aBinaryBlock "This is part of the interface between the compiler and a class's instance or field names. The class should enumerate aBinaryBlock with the instance variable name strings and their integer offsets. The order is important. Names evaluated later will override the same names occurring earlier." "Nothing to do here; ClassDescription introduces named instance variables" ^self! ! !Behavior methodsFor: 'compiling' stamp: 'eem 6/19/2008 09:08'! variablesAndOffsetsDo: aBinaryBlock "This is the interface between the compiler and a class's instance or field names. The class should enumerate aBinaryBlock with the field definitions (with nil offsets) followed by the instance variable name strings and their integer offsets (1-relative). The order is important; names evaluated later will override the same names occurring earlier." "Only need to do instance variables here. CProtoObject introduces field definitions." self instVarNamesAndOffsetsDo: aBinaryBlock! ! !Compiler methodsFor: 'public access' stamp: 'eem 5/15/2008 15:05'! parserClass ^parser ifNil: [self class parserClass] ifNotNil: [parser class]! ! !Compiler class methodsFor: 'accessing' stamp: 'eem 5/13/2008 11:37'! parserClass "Answer a parser class to use for parsing methods compiled by instances of the receiver." ^Parser! ! !Decompiler methodsFor: 'private' stamp: 'eem 5/13/2008 15:41'! interpretNextInstructionFor: client | code varNames | "Change false here will trace all state in Transcript." true ifTrue: [^ super interpretNextInstructionFor: client]. varNames := self class allInstVarNames. code := (self method at: pc) radix: 16. Transcript cr; cr; print: pc; space; nextPutAll: '<' , (code copyFrom: 4 to: code size), '>'. 8 to: varNames size do: [:i | i <= 10 ifTrue: [Transcript cr] ifFalse: [Transcript space; space]. Transcript nextPutAll: (varNames at: i); nextPutAll: ': '; print: (self instVarAt: i)]. Transcript endEntry. ^ super interpretNextInstructionFor: client! ! !DecompilerConstructor methodsFor: 'constructor' stamp: 'eem 8/21/2008 14:02'! codeInst: index ^InstanceVariableNode new name: (instVars at: index + 1 ifAbsent: ['unknown', index asString]) index: index + 1! ! !Encoder methodsFor: 'initialize-release' stamp: 'eem 6/24/2008 14:24'! init: aClass context: aContext notifying: req requestor := req. class := aClass. nTemps := 0. supered := false. self initScopeAndLiteralTables. class variablesAndOffsetsDo: [:variable "" :offset "" | offset isNil ifTrue: [scopeTable at: variable name put: (FieldNode new fieldDefinition: variable)] ifFalse: [scopeTable at: variable put: (offset >= 0 ifTrue: [InstanceVariableNode new name: variable index: offset] ifFalse: [MaybeContextInstanceVariableNode new name: variable index: offset negated])]]. aContext ~~ nil ifTrue: [| homeNode | homeNode := self bindTemp: self doItInContextName. "0th temp = aContext passed as arg" aContext tempNames withIndexDo: [:variable :index| scopeTable at: variable put: (MessageAsTempNode new receiver: homeNode selector: #namedTempAt: arguments: (Array with: (self encodeLiteral: index)) precedence: 3 from: self)]]. sourceRanges := Dictionary new: 32. globalSourceRanges := OrderedCollection new: 32! ! !Encoder methodsFor: 'private' stamp: 'eem 6/19/2008 13:02'! warnAboutShadowed: name requestor addWarning: name,' is shadowed'. selector ifNotNil: [Transcript cr; show: class name,'>>', selector, '(', name,' is shadowed)']! ! !LeafNode methodsFor: 'initialize-release' stamp: 'eem 5/14/2008 15:56'! key: object index: i type: type key := object. code := (self code: i type: type). index := i! ! !LeafNode methodsFor: 'copying' stamp: 'eem 5/14/2008 11:25'! veryDeepFixupWith: deepCopier "If fields were weakly copied, fix them here. If they were in the tree being copied, fix them up, otherwise point to the originals!!!!" super veryDeepFixupWith: deepCopier. key := (deepCopier references at: key ifAbsent: [key]). ! ! !LiteralNode methodsFor: 'initialize-release' stamp: 'eem 5/14/2008 09:30'! name: literal key: object index: i type: type "For compatibility with Encoder>>name:key:class:type:set:" ^self key: object index: i type: type! ! !MessageNode methodsFor: 'initialize-release' stamp: 'eem 7/18/2008 16:26'! receiver: rcvr selector: selName arguments: args precedence: p from: encoder sourceRange: range "Compile." ((selName == #future) or:[selName == #future:]) ifTrue: [Smalltalk at: #FutureNode ifPresent: [:futureNode| ^futureNode new receiver: rcvr selector: selName arguments: args precedence: p from: encoder sourceRange: range]]. (rcvr isFutureNode and: [rcvr futureSelector == nil]) ifTrue: "Transform regular message into future" [^rcvr futureMessage: selName arguments: args from: encoder sourceRange: range]. encoder noteSourceRange: range forNode: self. ^self receiver: rcvr selector: selName arguments: args precedence: p from: encoder! ! !MethodNode methodsFor: 'printing' stamp: 'eem 5/14/2008 12:13'! printOn: aStream precedence = 1 ifTrue: [(self selector includesSubString: '()/') ifTrue: [aStream nextPutAll: (self selector copyUpTo: $)). arguments do: [:arg| aStream nextPutAll: arg key] separatedBy: [aStream nextPutAll: ', ']. aStream nextPut: $)] ifFalse: [aStream nextPutAll: self selector]] "no node for method selector" ifFalse: [self selector keywords with: arguments do: [:kwd :arg | aStream nextPutAll: kwd; space; nextPutAll: arg key; space]]. comment == nil ifFalse: [aStream crtab: 1. self printCommentOn: aStream indent: 1]. temporaries size > 0 ifTrue: [aStream crtab: 1; nextPut: $|. temporaries do: [:temp | aStream space. temp printOn: aStream indent: 0]. aStream space; nextPut: $|]. primitive > 0 ifTrue: [(primitive between: 255 and: 519) ifFalse: "Dont decompile quick prims e.g, ^ self or ^instVar" [aStream crtab: 1. self printPrimitiveOn: aStream]]. self printPropertiesOn: aStream. aStream crtab: 1. block printStatementsOn: aStream indent: 0! ! !Scanner methodsFor: 'expression types' stamp: 'eem 5/13/2008 12:44'! scanAllTokenPositionsInto: aBlock "Evaluate aBlock with the start and end positions of all separate non-white-space tokens, including comments." | lastMark | lastMark := 1. [currentComment notNil ifTrue: [currentComment do: [:cmnt| | idx | idx := source originalContents indexOfSubCollection: cmnt startingAt: lastMark. (idx > 0 and: [idx < mark]) ifTrue: [aBlock value: idx - 1 value: (lastMark := idx + cmnt size)]]. currentComment := nil]. mark notNil ifTrue: [(token == #- and: [(typeTable at: hereChar charCode) = #xDigit]) ifTrue: [| savedMark | savedMark := mark. self scanToken. token := token negated. mark := savedMark]. "Compensate for the fact that the parser uses two character lookahead. Normally we must remove the extra two chaacters. But this mustn't happen for the last token at the end of stream." aBlock value: mark value: (source atEnd ifTrue: [tokenType := #doIt. "to cause an immediate ^self" source position] ifFalse: [source position - 2])]. (tokenType = #rightParenthesis or: [tokenType == #doIt]) ifTrue: [^self]. tokenType = #leftParenthesis ifTrue: [self scanToken; scanAllTokenPositionsInto: aBlock] ifFalse: [(tokenType = #word or: [tokenType = #keyword or: [tokenType = #colon]]) ifTrue: [self scanLitWord. token = #true ifTrue: [token := true]. token = #false ifTrue: [token := false]. token = #nil ifTrue: [token := nil]] ifFalse: [(token == #- and: [(typeTable at: hereChar charCode) = #xDigit]) ifTrue: [self scanToken. token := token negated]]]. self scanToken. true] whileTrue! ! !Scanner methodsFor: 'expression types' stamp: 'eem 5/13/2008 12:47'! scanLitVec | s | s := WriteStream on: (Array new: 16). [tokenType = #rightParenthesis or: [tokenType = #doIt]] whileFalse: [tokenType = #leftParenthesis ifTrue: [self scanToken; scanLitVec] ifFalse: [(tokenType = #word or: [tokenType = #keyword or: [tokenType = #colon]]) ifTrue: [self scanLitWord. token = #true ifTrue: [token := true]. token = #false ifTrue: [token := false]. token = #nil ifTrue: [token := nil]] ifFalse: [(token == #- and: [(self typeTableAt: hereChar) = #xDigit]) ifTrue: [self scanToken. token := token negated]]]. s nextPut: token. self scanToken]. token := s contents! ! !Scanner methodsFor: 'expression types' stamp: 'ar 5/10/2005 12:24'! scanLitWord "Accumulate keywords and asSymbol the result." | t | [(self typeTableAt: hereChar) = #xLetter] whileTrue: [t := token. self xLetter. token := t , token]. token := token asSymbol! ! !Scanner methodsFor: 'expression types' stamp: 'ar 5/10/2005 12:24'! scanToken [(tokenType := self typeTableAt: hereChar) == #xDelimiter] whileTrue: [self step]. "Skip delimiters fast, there almost always is one." mark := source position - 1. (tokenType at: 1) = $x "x as first letter" ifTrue: [self perform: tokenType "means perform to compute token & type"] ifFalse: [token := self step asSymbol "else just unique the first char"]. ^token! ! !Scanner methodsFor: 'multi-character scans' stamp: 'eem 5/13/2008 13:00'! xBinary tokenType := #binary. token := String with: self step. [hereChar ~~ $- and: [(self typeTableAt: hereChar) == #xBinary]] whileTrue: [token := token, (String with: self step)]. token := token asSymbol! ! !Scanner methodsFor: 'multi-character scans' stamp: 'eem 5/13/2008 13:05'! xLetter "Form a word or keyword." | type | buffer reset. [(type := self typeTableAt: hereChar) == #xLetter or: [type == #xDigit]] whileTrue: ["open code step for speed" buffer nextPut: hereChar. hereChar := aheadChar. aheadChar := source atEnd ifTrue: [30 asCharacter "doit"] ifFalse: [source next]]. tokenType := (type == #colon or: [type == #xColon and: [aheadChar ~~ $=]]) ifTrue: [buffer nextPut: self step. "Allow any number of embedded colons in literal symbols" [(self typeTableAt: hereChar) == #xColon] whileTrue: [buffer nextPut: self step]. #keyword] ifFalse: [type == #leftParenthesis ifTrue: [buffer nextPut: self step; nextPut: $). #positionalMessage] ifFalse:[#word]]. token := buffer contents! ! !Scanner methodsFor: 'multi-character scans' stamp: 'ar 3/26/2004 15:45'! xSingleQuote "String." self step. buffer reset. [hereChar = $' and: [aheadChar = $' ifTrue: [self step. false] ifFalse: [true]]] whileFalse: [buffer nextPut: self step. (hereChar = 30 asCharacter and: [source atEnd]) ifTrue: [^self offEnd: 'Unmatched string quote']]. self step. token := buffer contents. tokenType := #string! ! !Parser methodsFor: 'expression types' stamp: 'eem 7/16/2008 11:06'! method: doit context: ctxt encoder: encoderToUse " pattern [ | temporaries ] block => MethodNode." | sap blk prim temps messageComment methodNode | properties := MethodProperties new. encoder := encoderToUse. sap := self pattern: doit inContext: ctxt. "sap={selector, arguments, precedence}" properties selector: (sap at: 1). encoder selector: (sap at: 1). (sap at: 2) do: [:argNode | argNode isArg: true]. temps := self temporaries. messageComment := currentComment. currentComment := nil. doit ifFalse:[self properties]. prim := 0. properties ifNotNil:[ prim := properties at: #primitiveIndex ifAbsent:[0]. "don't preserve primitive index" properties removeKey: #primitiveIndex ifAbsent:[]. ]. self statements: #() innerBlock: doit. blk := parseNode. doit ifTrue: [blk returnLast] ifFalse: [blk returnSelfIfNoOther: encoder]. hereType == #doIt ifFalse: [^self expected: 'Nothing more']. self interactive ifTrue: [self removeUnusedTemps]. methodNode := self newMethodNode comment: messageComment. ^ methodNode selector: (sap at: 1) arguments: (sap at: 2) precedence: (sap at: 3) temporaries: temps block: blk encoder: encoder primitive: prim properties: properties! ! !Parser methodsFor: 'expression types' stamp: 'eem 7/16/2008 11:05'! pattern: fromDoit inContext: ctxt " unarySelector | binarySelector arg | keyword arg {keyword arg} => {selector, arguments, precedence}." | args selector | doitFlag := fromDoit. fromDoit ifTrue: [^ctxt == nil ifTrue: [{#DoIt. {}. 1}] ifFalse: [{#DoItIn:. {encoder encodeVariable: encoder doItInContextName}. 3}]]. hereType == #word ifTrue: [^ {self advance asSymbol. {}. 1}]. (hereType == #binary or: [hereType == #verticalBar]) ifTrue: [selector := self advance asSymbol. args := Array with: (encoder bindArg: self argumentName). ^ {selector. args. 2}]. hereType == #keyword ifTrue: [selector := WriteStream on: (String new: 32). args := OrderedCollection new. [hereType == #keyword] whileTrue:[ selector nextPutAll: self advance. args addLast: (encoder bindArg: self argumentName). ]. ^ {selector contents asSymbol. args. 3}]. hereType == #positionalMessage ifTrue:[ args := OrderedCollection new. selector := self advance. hereType == #rightParenthesis ifTrue:[self advance. ^{(selector,'/0') asSymbol. args. 1}]. [ args addLast: (encoder bindArg: self argumentName). hereType == #rightParenthesis ifTrue:[ self advance. selector := (selector,'/', args size printString) asSymbol. ^{selector. args. 1}]. here == #, ifFalse:[self expected: 'comma']. self advance. ] repeat. ]. ^self expected: 'Message pattern'! ! !Parser methodsFor: 'expression types' stamp: 'eem 5/13/2008 14:32'! temporariesIn: methodSelector " [ '|' (variable)* '|' ]" | vars theActualText | (self match: #verticalBar) ifFalse: ["no temps" doitFlag ifTrue: [self interactive ifFalse: [tempsMark := 1] ifTrue: [tempsMark := requestor selectionInterval first]. ^ #()]. tempsMark := (prevEnd ifNil: [0]) + 1. tempsMark := hereMark "formerly --> prevMark + prevToken". tempsMark > 0 ifTrue: [theActualText := source contents. [tempsMark < theActualText size and: [(theActualText at: tempsMark) isSeparator]] whileTrue: [tempsMark := tempsMark + 1]]. ^ #()]. vars := OrderedCollection new. [hereType == #word] whileTrue: [vars addLast: (encoder bindTemp: self advance in: methodSelector)]. (self match: #verticalBar) ifTrue: [tempsMark := prevMark. ^ vars]. ^ self expected: 'Vertical bar'! ! !Parser methodsFor: 'error correction' stamp: 'eem 8/21/2008 14:13'! correctVariable: proposedVariable interval: spot "Correct the proposedVariable to a known variable, or declare it as a new variable if such action is requested. We support declaring lowercase variables as temps or inst-vars, and uppercase variables as Globals or ClassVars, depending on whether the context is nil (class=UndefinedObject). Spot is the interval within the test stream of the variable. rr 3/4/2004 10:26 : adds the option to define a new class. " | tempIvar labels actions lines alternatives binding userSelection choice action | "Check if this is an i-var, that has been corrected already (ugly)" (encoder classEncoding allInstVarNames includes: proposedVariable) ifTrue: [ ^InstanceVariableNode new name: proposedVariable index: (encoder classEncoding allInstVarNames indexOf: proposedVariable)]. "If we can't ask the user for correction, make it undeclared" self interactive ifFalse: [ ^encoder undeclared: proposedVariable ]. "First check to see if the requestor knows anything about the variable" tempIvar := proposedVariable first canBeNonGlobalVarInitial. (tempIvar and: [ (binding := requestor bindingOf: proposedVariable) notNil ]) ifTrue: [ ^encoder global: binding name: proposedVariable ]. userSelection := requestor selectionInterval. requestor selectFrom: spot first to: spot last. requestor select. "Build the menu with alternatives" labels := OrderedCollection new. actions := OrderedCollection new. lines := OrderedCollection new. alternatives := encoder possibleVariablesFor: proposedVariable. tempIvar ifTrue: [ labels add: 'declare temp'. actions add: [ self declareTempAndPaste: proposedVariable ]. labels add: 'declare instance'. actions add: [ self declareInstVar: proposedVariable ] ] ifFalse: [ labels add: 'define new class'. actions add: [self defineClass: proposedVariable]. labels add: 'declare global'. actions add: [ self declareGlobal: proposedVariable ]. encoder classEncoding == UndefinedObject ifFalse: [ labels add: 'declare class variable'. actions add: [ self declareClassVar: proposedVariable ] ] ]. lines add: labels size. alternatives do: [ :each | labels add: each. actions add: [ self substituteWord: each wordInterval: spot offset: 0. encoder encodeVariable: each ] fixTemps ]. lines add: labels size. labels add: 'cancel'. "Display the pop-up menu" choice := (UIManager default chooseFrom: labels asArray lines: lines asArray title: 'Unknown variable: ', proposedVariable, ' please correct, or cancel:'). action := actions at: choice ifAbsent: [ ^self fail ]. "Execute the selected action" requestor deselect. requestor selectInvisiblyFrom: userSelection first to: userSelection last. ^action value! ! !Parser methodsFor: 'error correction' stamp: 'eem 8/21/2008 13:56'! declareInstVar: name "Declare an instance variable. Since the variable will get added after any existing inst vars its index is the instSize." encoder classEncoding addInstVarName: name. ^InstanceVariableNode new name: name index: encoder classEncoding instSize ! ! !Parser methodsFor: 'error correction' stamp: 'ar 12/27/2004 09:42'! queryUndefined | varStart varName | varName := parseNode key. varStart := self endOfLastToken + requestorOffset - varName size + 1. requestor selectFrom: varStart to: varStart + varName size - 1; select. (UIManager default chooseFrom: #('yes' 'no') title: ((varName , ' appears to be undefined at this point. Proceed anyway?') asText makeBoldFrom: 1 to: varName size)) = 1 ifFalse: [^ self fail]! ! !Parser methodsFor: 'error correction' stamp: 'eem 6/23/2008 10:42'! removeUnusedTemps "Scan for unused temp names, and prompt the user about the prospect of removing each one found" | str end start madeChanges | madeChanges := false. str := requestor text string. ((tempsMark between: 1 and: str size) and: [(str at: tempsMark) = $|]) ifFalse: [^ self]. encoder unusedTempNames do: [:temp | (UIManager default chooseFrom: #('yes' 'no') title: ((temp , ' appears to be\unused in this method.\OK to remove it?' withCRs) asText makeBoldFrom: 1 to: temp size)) = 1 ifTrue: [(encoder encodeVariable: temp) isUndefTemp ifTrue: [end := tempsMark. ["Beginning at right temp marker..." start := end - temp size + 1. end < temp size or: [temp = (str copyFrom: start to: end) and: [(str at: start-1) isSeparator & (str at: end+1) isSeparator]]] whileFalse: ["Search left for the unused temp" end := requestor nextTokenFrom: end direction: -1]. end < temp size ifFalse: [(str at: start-1) = $ ifTrue: [start := start-1]. requestor correctFrom: start to: end with: ''. str := str copyReplaceFrom: start to: end with: ''. madeChanges := true. tempsMark := tempsMark - (end-start+1)]] ifFalse: [self inform: 'You''ll first have to remove the\statement where it''s stored into' withCRs]]]. madeChanges ifTrue: [ReparseAfterSourceEditing signal]! ! !Scanner class methodsFor: 'instance creation' stamp: 'ar 1/30/2005 11:50'! new ^self basicNew initScanner! ! !Scanner class methodsFor: 'testing' stamp: 'eem 5/13/2008 13:39'! isLiteralSymbol: aSymbol "Test whether a symbol can be stored as # followed by its characters. Symbols created internally with asSymbol may not have this property, e.g. '3' asSymbol." | i ascii type | i := aSymbol size. i = 0 ifTrue: [^ false]. i = 1 ifTrue: [^('$''"()#0123456789' includes: (aSymbol at: 1)) not]. ascii := (aSymbol at: 1) charCode. "TypeTable should have been origined at 0 rather than 1 ..." ascii = 0 ifTrue: [^ false]. type := TypeTable at: ascii ifAbsent: [#xLetter]. (type == #xColon or: [type == #verticalBar or: [type == #xBinary]]) ifTrue: [^i = 1]. type == #xLetter ifTrue: [[i > 1] whileTrue: [ascii := (aSymbol at: i) charCode. ascii = 0 ifTrue: [^false]. type := TypeTable at: ascii ifAbsent: [#xLetter]. (type == #xLetter or: [type == #xDigit or: [type == #xColon]]) ifFalse: [^false]. i := i - 1]. ^true]. ^false! ! !SelectorNode methodsFor: 'initialize-release' stamp: 'eem 5/14/2008 09:30'! name: literal key: object index: i type: type "For compatibility with Encoder>>name:key:class:type:set:" ^self key: object index: i type: type! ! !SyntaxMorph methodsFor: 'node types' stamp: 'eem 8/21/2008 14:07'! isAVariable parseNode isVariableNode ifFalse: [^ false]. ^ (ClassBuilder new reservedNames includes: self decompile string withoutTrailingBlanks) not! ! !SyntaxMorph methodsFor: 'node types' stamp: 'eem 8/21/2008 14:08'! isNoun "Consider these to be nouns: MessageNode with receiver, CascadeNode with receiver, AssignmentNode, TempVariableNode, LiteralNode, VariableNode, LiteralVariableNode, InstanceVariableNode." parseNode isVariableNode ifTrue: [^ true]. (self nodeClassIs: MessageNode) ifTrue: [^ parseNode receiver notNil]. (self nodeClassIs: CascadeNode) ifTrue: [^ parseNode receiver notNil]. (self nodeClassIs: AssignmentNode) ifTrue: [^ submorphs size >= 3]. ^ false! ! !SyntaxMorph methodsFor: 'printing' stamp: 'eem 8/21/2008 14:05'! printOn: strm indent: level | nodeClass | (self hasProperty: #ignoreNodeWhenPrinting) ifFalse: [ parseNode isVariableNode ifTrue: [^self printVariableNodeOn: strm indent: level]. nodeClass := parseNode class. nodeClass == MessageNode ifTrue: [^self printMessageNodeOn: strm indent: level]. nodeClass == BlockNode ifTrue: [^self printBlockNodeOn: strm indent: level]. nodeClass == BlockArgsNode ifTrue: [^self printBlockArgsNodeOn: strm indent: level]. nodeClass == MethodNode ifTrue: [^self printMethodNodeOn: strm indent: level]. nodeClass == MethodTempsNode ifTrue: [^self printMethodTempsNodeOn: strm indent: level]. nodeClass == CascadeNode ifTrue: [^self printCascadeNodeOn: strm indent: level]. nodeClass == AssignmentNode ifTrue: [^self printAssignmentNodeOn: strm indent: level]. ]. self submorphsDoIfSyntax: [ :sub | sub printOn: strm indent: level. strm ensureASpace. ] ifString: [ :sub | self printSimpleStringMorph: sub on: strm ]. ! ! !TilePadMorph methodsFor: 'miscellaneous' stamp: 'eem 8/21/2008 14:10'! isColorConstant: aParseNode "Is this a Color constant, of the form (MessageNode (VariableNode Color->Color) (SelectorNode #r:g:b:) (LiteralNode LiteralNode LiteralNode))" | rec | (rec := aParseNode receiver) isVariableNode ifFalse: [^ false]. rec key isVariableBinding ifFalse: [^ false]. rec key value == Color ifFalse: [^ false]. aParseNode selector key == #r:g:b: ifFalse: [^ false]. aParseNode arguments size = 3 ifFalse: [^ false]. ^ true ! ! !VariableNode methodsFor: 'initialize-release' stamp: 'eem 5/14/2008 09:33'! name: varName index: i type: type "Only used for initting instVar refs" ^self name: varName key: varName index: i type: type! ! !VariableNode methodsFor: 'initialize-release' stamp: 'eem 5/14/2008 16:01'! name: varName key: objRef index: i type: type "Only used for initting global (litInd) variables" ^self name: varName key: objRef code: (self code: (index := i) type: type)! ! !VariableNode methodsFor: 'testing' stamp: 'eem 5/14/2008 09:11'! assignmentCheck: encoder at: location ^(encoder cantStoreInto: name) ifTrue: [location] ifFalse: [-1]! ! !VariableNode methodsFor: 'testing' stamp: 'eem 5/14/2008 09:13'! isSelfPseudoVariable "Answer if this ParseNode represents the 'self' pseudo-variable." ^ key = 'self' or: [name = '{{self}}']! ! !VariableNode methodsFor: 'testing' stamp: 'eem 5/14/2008 09:18'! type "This code attempts to reconstruct the type from its encoding in code. This allows one to test, for instance, (aNode type = LdInstType)." | type | code < 0 ifTrue: [^code negated]. code >= 256 ifTrue: [^code // 256]. type := CodeBases findFirst: [:one | code < one]. ^type = 0 ifTrue: [5] ifFalse: [type - 1]! ! !VariableNode methodsFor: 'code generation' stamp: 'eem 5/14/2008 09:20'! fieldOffset "Return temp or instVar offset for this variable" ^code < 256 ifTrue: [code \\ 16] ifFalse: [code \\ 256]! ! !TempVariableNode methodsFor: 'initialize-release' stamp: 'eem 5/14/2008 09:51'! name: varName index: i type: type scope: level "Only used for initting temporary variables" isAnArg := hasDefs := hasRefs := false. scope := level. ^super name: varName key: varName index: i type: type! ! !TempVariableNode methodsFor: 'testing' stamp: 'eem 5/14/2008 09:11'! assignmentCheck: encoder at: location ^isAnArg ifTrue: [location] ifFalse: [-1]! ! VariableNode removeSelector: #name:! CParser removeSelector: #method:context:encoder:! Parser removeSelector: #keylessMessagePartTest:repeat:! LeafNode removeSelector: #code:! LeafNode removeSelector: #key:! LeafNode removeSelector: #name:key:index:type:! Behavior removeSelector: #variableNodes! Behavior removeSelector: #variableNodesAndOffsetsDo:! !Behavior reorganize! ('initialize-release' emptyMethodDictionary forgetDoIts nonObsoleteClass obsolete superclass:methodDictionary:format:) ('accessing' classDepth compilerClass decompilerClass environment evaluatorClass format methodDict name parserClass sourceCodeTemplate subclassDefinerClass typeOfClass) ('testing' canZapMethodDictionary fullyImplementsVocabulary: implementsVocabulary: instSize instSpec isBehavior isBits isBytes isFixed isMeta isObsolete isPointers isVariable isWeak isWords shouldNotBeRedefined) ('copying' copy copyOfMethodDictionary deepCopy) ('printing' defaultNameStemForInstances literalScannedAs:notifying: longPrintOn: printHierarchy printOnStream: printOn: printWithClosureAnalysisOn: storeLiteral:on:) ('compiling' compileAll compileAllFrom: compile: compile:classified:notifying:trailer:ifFail: compile:notifying: decompile: defaultMethodTrailer instVarNamesAndOffsetsDo: recompileChanges recompileNonResidentMethod:atSelector:from: recompile: recompile:from: variablesAndOffsetsDo:) ('instance creation' basicNew basicNew: initializedInstance new new:) ('accessing class hierarchy' allSubclasses allSubclassesWithLevelDo:startingLevel: allSuperclasses subclasses superclass superclass: withAllSubclasses withAllSuperclasses) ('accessing method dictionary' addSelectorSilently:withMethod: addSelector:withMethod: addSelector:withMethod:notifying: allSelectors changeRecordsAt: compiledMethodAt: compiledMethodAt:ifAbsent: compress compressedSourceCodeAt: firstCommentAt: firstPrecodeCommentFor: formalHeaderPartsFor: formalParametersAt: lookupSelector: methodDictionary methodDictionary: methodHeaderFor: methodsDo: precodeCommentOrInheritedCommentFor: removeSelectorSilently: removeSelector: rootStubInImageSegment: selectorAtMethod:setClass: selectors selectorsAndMethodsDo: selectorsDo: selectorsWithArgs: sourceCodeAt: sourceCodeAt:ifAbsent: sourceMethodAt: sourceMethodAt:ifAbsent: standardMethodHeaderFor: supermostPrecodeCommentFor: zapAllMethods >>) ('accessing instances and variables' allClassVarNames allInstances allInstVarNames allowsSubInstVars allSharedPools allSubInstances classVarNames inspectAllInstances inspectSubInstances instanceCount instVarNames sharedPools someInstance subclassInstVarNames) ('testing class hierarchy' includesBehavior: inheritsFrom: kindOfSubclass) ('testing method dictionary' bindingOf: canUnderstand: classBindingOf: hasMethods includesSelector: scopeHas:ifTrue: thoroughWhichSelectorsReferTo:special:byte: whichClassIncludesSelector: whichSelectorsAccess: whichSelectorsReferTo: whichSelectorsReferTo:special:byte: whichSelectorsStoreInto:) ('enumerating' allInstancesDo: allInstancesEverywhereDo: allSubclassesDoGently: allSubclassesDo: allSubInstancesDo: allSuperclassesDo: selectSubclasses: selectSuperclasses: withAllSubclassesDo: withAllSuperAndSubclassesDoGently: withAllSuperclassesDo:) ('user interface' allLocalCallsOn: allUnreferencedInstanceVariables crossReference unreferencedInstanceVariables withAllSubAndSuperclassesDo:) ('private' basicRemoveSelector: becomeCompact becomeCompactSimplyAt: becomeUncompact flushCache indexIfCompact setFormat: spaceUsed) ('system startup' shutDown shutDown: startUp startUpFrom: startUp:) ('obsolete subclasses' addObsoleteSubclass: obsoleteSubclasses removeAllObsoleteSubclasses removeObsoleteSubclass:) ('deprecated' allSelectorsUnderstood removeSelectorSimply:) ('*system-support' allCallsOn allCallsOn: allUnsentMessages) ('*sunit-preload' sunitAllSelectors sunitSelectors) ('*Islands' howToPassAsArgument) ('*Tweak-Hacks' addUniClass: fieldNamed: findUniClass: printSubclassesOn:level:) ('*Tweak-Core-Proto' allFieldsReverseDo: hiddenSubclasses methodTriggers) ('*Shout-Parser' shoutParserClass) !