[Pkg] Squeak3.10bc: Compiler-kph.63.mcz
squeak-dev-noreply at lists.squeakfoundation.org
squeak-dev-noreply at lists.squeakfoundation.org
Sat Dec 13 04:47:46 UTC 2008
A new version of Compiler was added to project Squeak3.10bc:
http://www.squeaksource.com/310bc/Compiler-kph.63.mcz
==================== Summary ====================
Name: Compiler-kph.63
Author: kph
Time: 13 December 2008, 4:47:42 am
UUID: 4305226f-c184-4103-893e-30c7086dcb6c
Ancestors: Compiler-edc.62
Saved from SystemVersion
==================== Snapshot ====================
SystemOrganization addCategory: #'Compiler-Kernel'!
SystemOrganization addCategory: #'Compiler-ParseNodes'!
SystemOrganization addCategory: #'Compiler-Support'!
SystemOrganization addCategory: #'Compiler-Tests'!
Object subclass: #CompiledMethodWithNode
instanceVariableNames: 'node method'
classVariableNames: ''
poolDictionaries: ''
category: 'Compiler-Support'!
----- Method: CompiledMethodWithNode class>>generateMethodFromNode:trailer: (in category 'instance creation') -----
generateMethodFromNode: aMethodNode trailer: bytes
^ self method: (aMethodNode generate: bytes) node: aMethodNode.!
----- Method: CompiledMethodWithNode class>>method:node: (in category 'instance creation') -----
method: aCompiledMethod node: aMethodNode
^ self new method: aCompiledMethod; node: aMethodNode.!
----- Method: CompiledMethodWithNode>>method (in category 'accessing') -----
method
^ method!
----- Method: CompiledMethodWithNode>>method: (in category 'private') -----
method: aCompiledMethod
method _ aCompiledMethod!
----- Method: CompiledMethodWithNode>>node (in category 'accessing') -----
node
^ node!
----- Method: CompiledMethodWithNode>>node: (in category 'private') -----
node: aMethodNode
node _ aMethodNode!
----- Method: CompiledMethodWithNode>>selector (in category 'accessing') -----
selector
^ self node selector!
Object subclass: #Compiler
instanceVariableNames: 'sourceStream requestor class category context parserClass'
classVariableNames: ''
poolDictionaries: ''
category: 'Compiler-Kernel'!
!Compiler commentStamp: '<historical>' prior: 0!
The compiler accepts Smalltalk source code and compiles it with respect to a given class. The user of the compiler supplies a context so that temporary variables are accessible during compilation. If there is an error, a requestor (usually a kind of StringHolderController) is sent the message notify:at:in: so that the error message can be displayed. If there is no error, then the result of compilation is a MethodNode, which is the root of a parse tree whose nodes are kinds of ParseNodes. The parse tree can be sent messages to (1) generate code for a CompiledMethod (this is done for compiling methods or evaluating expressions); (2) pretty-print the code (for formatting); or (3) produce a map from object code back to source code (used by debugger program-counter selection). See also Parser, Encoder, ParseNode.!
----- Method: Compiler class>>closureDecompilerClass (in category 'accessing') -----
closureDecompilerClass
^self error: 'not installed'.!
----- Method: Compiler class>>closureParserClass (in category 'accessing') -----
closureParserClass
^self error: 'not installed'.!
----- Method: Compiler class>>couldEvaluate: (in category 'accessing') -----
couldEvaluate: anObject
"Answer true if anObject can be passed to my various #evaluate: methods."
^anObject isString or: [ anObject isText or: [ anObject isStream ]]!
----- Method: Compiler class>>decompilerClass (in category 'accessing') -----
decompilerClass
^Decompiler!
----- Method: Compiler class>>evaluate: (in category 'evaluating') -----
evaluate: textOrString
"See Compiler|evaluate:for:notifying:logged:. If a compilation error occurs,
a Syntax Error view is created rather than notifying any requestor.
Compilation is carried out with respect to nil, i.e., no object, and the
invocation is not logged."
^self evaluate: textOrString for: nil logged: false!
----- Method: Compiler class>>evaluate:for:logged: (in category 'evaluating') -----
evaluate: textOrString for: anObject logged: logFlag
"See Compiler|evaluate:for:notifying:logged:. If a compilation error occurs,
a Syntax Error view is created rather than notifying any requestor."
^self evaluate: textOrString for: anObject notifying: nil logged: logFlag!
----- Method: Compiler class>>evaluate:for:notifying:logged: (in category 'evaluating') -----
evaluate: textOrString for: anObject notifying: aController logged: logFlag
"Compile and execute the argument, textOrString with respect to the class
of anObject. If a compilation error occurs, notify aController. If both
compilation and execution are successful then, if logFlag is true, log
(write) the text onto a system changes file so that it can be replayed if
necessary."
^ self new
evaluate: textOrString
in: nil
to: anObject
notifying: aController
ifFail: [^nil]
logged: logFlag.!
----- Method: Compiler class>>evaluate:logged: (in category 'evaluating') -----
evaluate: textOrString logged: logFlag
"See Compiler|evaluate:for:notifying:logged:. If a compilation error occurs,
a Syntax Error view is created rather than notifying any requestor.
Compilation is carried out with respect to nil, i.e., no object."
^self evaluate: textOrString for: nil logged: logFlag!
----- Method: Compiler class>>evaluate:notifying:logged: (in category 'evaluating') -----
evaluate: textOrString notifying: aController logged: logFlag
"See Compiler|evaluate:for:notifying:logged:. Compilation is carried out
with respect to nil, i.e., no object."
^self evaluate: textOrString for: nil notifying: aController logged: logFlag!
----- Method: Compiler class>>format:in:notifying:contentsSymbol: (in category 'evaluating') -----
format: textOrStream in: aClass notifying: aRequestor contentsSymbol: aSymbol
^self new format: textOrStream in: aClass notifying: aRequestor contentsSymbol: aSymbol!
----- Method: Compiler class>>format:in:notifying:decorated: (in category 'evaluating') -----
format: textOrStream in: aClass notifying: aRequestor decorated: aBoolean
^self new format: textOrStream in: aClass notifying: aRequestor decorated: aBoolean!
----- Method: Compiler class>>new (in category 'accessing') -----
new
^ super new parserClass: self parserClass!
----- Method: Compiler class>>parserClass (in category 'accessing') -----
parserClass
"Return a parser class to use for parsing method headers."
^Parser!
----- Method: Compiler class>>recompileAll (in category 'utilities') -----
recompileAll
"Recompile all classes, starting with given name."
Smalltalk forgetDoIts.
Smalltalk allClassesAndTraits do: [:classOrTrait | classOrTrait compileAll] displayingProgress: 'Recompiling all classes and traits'.
!
----- Method: Compiler class>>recompileAllFrom: (in category 'utilities') -----
recompileAllFrom: firstName
"Recompile all classes, starting with given name."
Smalltalk forgetDoIts.
Smalltalk allClassesDo:
[:class | class name >= firstName
ifTrue:
[Transcript show: class name; cr.
class compileAll]]
"Compiler recompileAllFrom: 'AAABodyShop'."
!
----- Method: Compiler>>compile:in:classified:notifying:ifFail: (in category 'public access') -----
compile: textOrStream in: aClass classified: aCategory notifying: aRequestor ifFail: failBlock
"Answer a MethodNode for the argument, textOrStream. If the
MethodNode can not be created, notify the argument, aRequestor; if
aRequestor is nil, evaluate failBlock instead. The MethodNode is the root
of a parse tree. It can be told to generate a CompiledMethod to be
installed in the method dictionary of the argument, aClass."
| methodNode |
self from: textOrStream
class: aClass
classified: aCategory
context: nil
notifying: aRequestor.
methodNode := self translate: sourceStream noPattern: false ifFail: failBlock.
methodNode encoder requestor: requestor.
^methodNode.
!
----- Method: Compiler>>compile:in:notifying:ifFail: (in category 'public access') -----
compile: textOrStream in: aClass notifying: aRequestor ifFail: failBlock
^self compile: textOrStream in: aClass classified: nil notifying: aRequestor ifFail: failBlock !
----- Method: Compiler>>compileNoPattern:in:context:notifying:ifFail: (in category 'public access') -----
compileNoPattern: textOrStream in: aClass context: aContext notifying: aRequestor ifFail: failBlock
"Similar to #compile:in:notifying:ifFail:, but the compiled code is
expected to be a do-it expression, with no message pattern."
self from: textOrStream
class: aClass
context: aContext
notifying: aRequestor.
^self
translate: sourceStream
noPattern: true
ifFail: failBlock!
----- Method: Compiler>>compiledMethodFor:in:to: (in category 'public access') -----
compiledMethodFor: aString in: aContext to: aReceiver
"evaluate aString in the given context, and return the result. 2/2/96 sw"
| result |
result _ self
compiledMethodFor: aString
in: aContext
to: aReceiver
notifying: nil
ifFail: [^#Failed]
logged: false.
^ result!
----- Method: Compiler>>compiledMethodFor:in:to:notifying:ifFail:logged: (in category 'public access') -----
compiledMethodFor: textOrStream in: aContext to: receiver notifying: aRequestor ifFail: failBlock logged: logFlag
"Compiles the sourceStream into a parse tree, then generates code into a
method. This method is then installed in the receiver's class so that it
can be invoked. In other words, if receiver is not nil, then the text can
refer to instance variables of that receiver (the Inspector uses this). If
aContext is not nil, the text can refer to temporaries in that context (the
Debugger uses this). If aRequestor is not nil, then it will receive a
notify:at: message before the attempt to evaluate is aborted. Finally, the
compiled method is invoked from here as DoIt or (in the case of
evaluation in aContext) DoItIn:. The method is subsequently removed
from the class, but this will not get done if the invocation causes an
error which is terminated. Such garbage can be removed by executing:
Smalltalk allBehaviorsDo: [:cl | cl removeSelector: #DoIt; removeSelector:
#DoItIn:]."
| methodNode method |
class _ (aContext == nil ifTrue: [receiver] ifFalse: [aContext receiver]) class.
self from: textOrStream class: class context: aContext notifying: aRequestor.
methodNode _ self translate: sourceStream noPattern: true ifFail:
[^failBlock value].
method _ methodNode generate: #(0 0 0 0).
self interactive ifTrue:
[method _ method copyWithTempNames: methodNode tempNames].
logFlag ifTrue: [SystemChangeNotifier uniqueInstance evaluated: sourceStream contents context: aContext].
^ method.!
----- Method: Compiler>>evaluate:in:to: (in category 'public access') -----
evaluate: aString in: aContext to: aReceiver
"evaluate aString in the given context, and return the result. 2/2/96 sw"
| result |
result _ self
evaluate: aString
in: aContext
to: aReceiver
notifying: nil
ifFail: [^ #failedDoit].
^ result!
----- Method: Compiler>>evaluate:in:to:notifying:ifFail: (in category 'public access') -----
evaluate: textOrStream in: aContext to: receiver notifying: aRequestor ifFail: failBlock
^ self evaluate: textOrStream in: aContext to: receiver notifying: aRequestor ifFail: failBlock logged: false.!
----- Method: Compiler>>evaluate:in:to:notifying:ifFail:logged: (in category 'public access') -----
evaluate: textOrStream in: aContext to: receiver notifying: aRequestor ifFail: failBlock logged: logFlag
"Compiles the sourceStream into a parse tree, then generates code into a method. In other words, if receiver is not nil, then the text can refer to instance variables of that receiver (the Inspector uses this). If aContext is not nil, the text can refer to temporaries in that context (the Debugger uses this). If aRequestor is not nil, then it will receive a notify:at: message before the attempt to evaluate is aborted. Finally, the compiled method is directly invoked without modifying the receiving-class."
| methodNode method value toLog itsSelectionString itsSelection |
class := (aContext isNil
ifTrue: [ receiver ]
ifFalse: [ aContext receiver ])
class.
self from: textOrStream class: class context: aContext notifying: aRequestor.
methodNode := self
translate: sourceStream
noPattern: true
ifFail: [ ^ failBlock value ].
method := methodNode generate.
method selector ifNil: [method selector: #DoIt].
self interactive
ifTrue: [ method := method copyWithTempNames: methodNode tempNames ].
value := receiver
withArgs: (context isNil
ifTrue: [ #() ]
ifFalse: [ Array with: aContext ])
executeMethod: method.
logFlag ifTrue:
[toLog := ((requestor respondsTo: #selection) and:
[(itsSelection := requestor selection) notNil] and:
[(itsSelectionString := itsSelection asString) isEmptyOrNil not] )
ifTrue:
[itsSelectionString]
ifFalse:
[sourceStream contents].
SystemChangeNotifier uniqueInstance evaluated: toLog context: aContext ].
^ value.!
----- Method: Compiler>>format:in:notifying:contentsSymbol: (in category 'public access') -----
format: textOrStream in: aClass notifying: aRequestor contentsSymbol: aSymbol
"Compile a parse tree from the argument, textOrStream. Answer a string containing the original code, formatted nicely. If aSymbol is #colorPrint, then decorate the resulting text with color and hypertext actions"
^self format: textOrStream in: aClass notifying: aRequestor decorated: (aSymbol == #colorPrint)!
----- Method: Compiler>>format:in:notifying:decorated: (in category 'public access') -----
format: textOrStream in: aClass notifying: aRequestor decorated: aBoolean
"Compile a parse tree from the argument, textOrStream. Answer a string containing the original code, formatted nicely. If aBoolean is true, then decorate the resulting text with color and hypertext actions"
| aNode |
self from: textOrStream
class: aClass
context: nil
notifying: aRequestor.
aNode _ self format: sourceStream noPattern: false ifFail: [^ nil].
^ aBoolean
ifTrue: [aNode decompileText]
ifFalse: [aNode decompileString]!
----- Method: Compiler>>format:noPattern:ifFail: (in category 'private') -----
format: aStream noPattern: noPattern ifFail: failBlock
| tree |
tree _
self parserClass new
parse: aStream
class: class
noPattern: noPattern
context: context
notifying: requestor
ifFail: [^ failBlock value].
^ tree!
----- Method: Compiler>>from:class:classified:context:notifying: (in category 'private') -----
from: textOrStream class: aClass classified: aCategory context: aContext notifying: req
(textOrStream isKindOf: PositionableStream)
ifTrue: [sourceStream := textOrStream]
ifFalse: [sourceStream := ReadStream on: textOrStream asString].
class := aClass.
context := aContext.
requestor := req.
category := aCategory
!
----- Method: Compiler>>from:class:context:notifying: (in category 'private') -----
from: textOrStream class: aClass context: aContext notifying: req
(textOrStream isKindOf: PositionableStream)
ifTrue: [sourceStream _ textOrStream]
ifFalse: [sourceStream _ ReadStream on: textOrStream asString].
class _ aClass.
context _ aContext.
requestor _ req!
----- Method: Compiler>>interactive (in category 'error handling') -----
interactive
"this version of the method is necessary to load code from MC else the interactive mode is one.
This method is really bad since it links the compiler package with the Tools
one. The solution would be to have a real SyntaxError exception belonging to the
compiler package and not a subclass of StringHolder - sd Nov 2005"
"the code submitted by PlusTools is ideally the one that should be used
interactive
^requestor ~~ nil "
^ (requestor == nil or: [requestor isKindOf: SyntaxError]) not!
----- Method: Compiler>>notify: (in category 'error handling') -----
notify: aString
"Refer to the comment in Object|notify:."
^self notify: aString at: sourceStream position + 1!
----- Method: Compiler>>notify:at: (in category 'error handling') -----
notify: aString at: location
"Refer to the comment in Object|notify:."
requestor == nil
ifTrue: [^SyntaxErrorNotification
inClass: class
category: category
withCode:
(sourceStream contents
copyReplaceFrom: location
to: location - 1
with: aString)
doitFlag: false]
ifFalse: [^requestor
notify: aString
at: location
in: sourceStream]!
----- Method: Compiler>>parse:in:notifying: (in category 'public access') -----
parse: textOrStream in: aClass notifying: req
"Compile the argument, textOrStream, with respect to the class, aClass,
and answer the MethodNode that is the root of the resulting parse tree.
Notify the argument, req, if an error occurs. The failBlock is defaulted to
an empty block."
self from: textOrStream class: aClass context: nil notifying: req.
^self parserClass new
parse: sourceStream
class: class
noPattern: false
context: context
notifying: requestor
ifFail: []!
----- Method: Compiler>>parserClass (in category 'private') -----
parserClass
^ parserClass!
----- Method: Compiler>>parserClass: (in category 'private') -----
parserClass: aParserClass
parserClass _ aParserClass.
!
----- Method: Compiler>>translate:noPattern:ifFail: (in category 'private') -----
translate: aStream noPattern: noPattern ifFail: failBlock
| tree |
tree :=
self parserClass new
parse: aStream
class: class
category: category
noPattern: noPattern
context: context
notifying: requestor
ifFail: [^ failBlock value].
^ tree
!
----- Method: Compiler>>translate:noPattern:ifFail:parser: (in category 'public access') -----
translate: aStream noPattern: noPattern ifFail: failBlock parser: parser
| tree |
tree := parser
parse: aStream
class: class
noPattern: noPattern
context: context
notifying: requestor
ifFail: [^ failBlock value].
^ tree!
Object subclass: #ParseNode
instanceVariableNames: 'comment pc'
classVariableNames: 'Jmp SendType Store Dup JmpLong EndRemote Send NodeSelf LdTrue BtpLong LdInstLong SendLong StdLiterals StdVariables LdThisContext StorePop SendLimit JmpLimit SendPlus Pop NodeNil LdLitIndType SendLong2 DblExtDoAll LoadLong LdLitType NodeTrue LdNil EndMethod LongLongDoAll LdSelf LdSuper NodeSuper CodeLimits LdMinus1 LdTempType StdSelectors LdFalse CodeBases ShortStoP NodeFalse NodeThisContext LdInstType Bfp'
poolDictionaries: ''
category: 'Compiler-ParseNodes'!
!ParseNode commentStamp: '<historical>' prior: 0!
This superclass of most compiler/decompiler classes declares common class variables, default messages, and the code emitters for jumps. Some of the class variables are initialized here; the rest are initialized in class VariableNode.!
ParseNode subclass: #AssignmentNode
instanceVariableNames: 'variable value'
classVariableNames: ''
poolDictionaries: ''
category: 'Compiler-ParseNodes'!
!AssignmentNode commentStamp: '<historical>' prior: 0!
AssignmentNode comment: 'I represent a (var_expr) construct.'!
----- Method: AssignmentNode>>emitForEffect:on: (in category 'code generation') -----
emitForEffect: stack on: aStream
variable emitLoad: stack on: aStream.
value emitForValue: stack on: aStream.
variable emitStorePop: stack on: aStream.
pc _ aStream position!
----- Method: AssignmentNode>>emitForValue:on: (in category 'code generation') -----
emitForValue: stack on: aStream
variable emitLoad: stack on: aStream.
value emitForValue: stack on: aStream.
variable emitStore: stack on: aStream.
pc _ aStream position!
----- Method: AssignmentNode>>printOn:indent: (in category 'printing') -----
printOn: aStream indent: level
variable printOn: aStream indent: level.
aStream nextPutAll: ' := '.
value printOn: aStream indent: level + 2.!
----- Method: AssignmentNode>>printOn:indent:precedence: (in category 'printing') -----
printOn: aStream indent: level precedence: p
p < 4
ifTrue: [aStream nextPutAll: '('.
self printOn: aStream indent: level.
aStream nextPutAll: ')']
ifFalse: [self printOn: aStream indent: level]!
----- Method: AssignmentNode>>sizeForEffect: (in category 'code generation') -----
sizeForEffect: encoder
^(value sizeForValue: encoder)
+ (variable sizeForStorePop: encoder)!
----- Method: AssignmentNode>>sizeForValue: (in category 'code generation') -----
sizeForValue: encoder
^(value sizeForValue: encoder)
+ (variable sizeForStore: encoder)!
----- Method: AssignmentNode>>toDoIncrement: (in category 'initialize-release') -----
toDoIncrement: var
var = variable ifFalse: [^ nil].
(value isMemberOf: MessageNode)
ifTrue: [^ value toDoIncrement: var]
ifFalse: [^ nil]!
----- Method: AssignmentNode>>value (in category 'initialize-release') -----
value
^ value!
----- Method: AssignmentNode>>variable (in category 'equation translation') -----
variable
^variable!
----- Method: AssignmentNode>>variable:value: (in category 'initialize-release') -----
variable: aVariable value: expression
variable _ aVariable.
value _ expression!
----- Method: AssignmentNode>>variable:value:from: (in category 'initialize-release') -----
variable: aVariable value: expression from: encoder
(aVariable isMemberOf: MessageAsTempNode)
ifTrue: ["Case of remote temp vars"
^ aVariable store: expression from: encoder].
variable _ aVariable.
value _ expression!
----- Method: AssignmentNode>>variable:value:from:sourceRange: (in category 'initialize-release') -----
variable: aVariable value: expression from: encoder sourceRange: range
encoder noteSourceRange: range forNode: self.
^self
variable: aVariable
value: expression
from: encoder!
ParseNode subclass: #BlockArgsNode
instanceVariableNames: 'temporaries'
classVariableNames: ''
poolDictionaries: ''
category: 'Compiler-ParseNodes'!
ParseNode subclass: #BlockNode
instanceVariableNames: 'arguments statements returns nArgsNode size remoteCopyNode temporaries'
classVariableNames: ''
poolDictionaries: ''
category: 'Compiler-ParseNodes'!
!BlockNode commentStamp: '<historical>' prior: 0!
I represent a bracketed block with 0 or more arguments and 1 or more statements. If I am initialized with no statements, I create one. I have a flag to tell whether my last statement returns a value from the enclosing method. My last three fields remember data needed for code generation. I can emit for value in the usual way, in which case I create a literal method (actually a context remotely copied) to be evaluated by sending it value: at run time. Or I can emit code to be evaluated in line; this only happens at the top level of a method and in conditionals and while-loops, none of which have arguments.!
----- Method: BlockNode class>>statements:returns: (in category 'instance creation') -----
statements: statements returns: returns
^ self new statements: statements returns: returns!
----- Method: BlockNode class>>withJust: (in category 'instance creation') -----
withJust: aNode
^ self statements: (OrderedCollection with: aNode) returns: false!
----- Method: BlockNode>>arguments: (in category 'accessing') -----
arguments: argNodes
"Decompile."
arguments _ argNodes!
----- Method: BlockNode>>arguments:statements:returns:from: (in category 'initialize-release') -----
arguments: argNodes statements: statementsCollection returns: returnBool from: encoder
"Compile."
arguments _ argNodes.
statements _ statementsCollection size > 0
ifTrue: [statementsCollection]
ifFalse: [argNodes size > 0
ifTrue: [statementsCollection copyWith: arguments last]
ifFalse: [Array with: NodeNil]].
returns _ returnBool!
----- Method: BlockNode>>arguments:statements:returns:from:sourceRange: (in category 'initialize-release') -----
arguments: argNodes statements: statementsCollection returns: returnBool from: encoder sourceRange: range
"Compile."
encoder noteSourceRange: range forNode: self.
^self
arguments: argNodes
statements: statementsCollection
returns: returnBool
from: encoder!
----- Method: BlockNode>>block (in category 'accessing') -----
block
^ self!
----- Method: BlockNode>>canBeSpecialArgument (in category 'testing') -----
canBeSpecialArgument
"Can I be an argument of (e.g.) ifTrue:?"
^arguments size = 0!
----- Method: BlockNode>>code (in category 'code generation') -----
code
^statements first code!
----- Method: BlockNode>>decompileString (in category 'printing') -----
decompileString
"Answer a string description of the parse tree whose root is the receiver."
^ self decompileText asString
!
----- Method: BlockNode>>decompileText (in category 'printing') -----
decompileText
"Answer a text description of the parse tree whose root is the receiver."
^ ColoredCodeStream contents: [:strm | self printOn: strm indent: 0]
!
----- Method: BlockNode>>emitExceptLast:on: (in category 'code generation') -----
emitExceptLast: stack on: aStream
| nextToLast |
nextToLast _ statements size - 1.
nextToLast < 1 ifTrue: [^ self]. "Only one statement"
1 to: nextToLast do:
[:i | (statements at: i) emitForEffect: stack on: aStream].
!
----- Method: BlockNode>>emitForEvaluatedEffect:on: (in category 'code generation') -----
emitForEvaluatedEffect: stack on: aStream
self returns
ifTrue:
[self emitForEvaluatedValue: stack on: aStream.
stack pop: 1]
ifFalse:
[self emitExceptLast: stack on: aStream.
statements last emitForEffect: stack on: aStream]!
----- Method: BlockNode>>emitForEvaluatedValue:on: (in category 'code generation') -----
emitForEvaluatedValue: stack on: aStream
self emitExceptLast: stack on: aStream.
statements last emitForValue: stack on: aStream.
!
----- Method: BlockNode>>emitForValue:on: (in category 'code generation') -----
emitForValue: stack on: aStream
aStream nextPut: LdThisContext.
stack push: 1.
nArgsNode emitForValue: stack on: aStream.
remoteCopyNode
emit: stack
args: 1
on: aStream.
"Force a two byte jump."
self emitLong: size code: JmpLong on: aStream.
stack push: arguments size.
arguments reverseDo: [:arg | arg emitStorePop: stack on: aStream].
self emitForEvaluatedValue: stack on: aStream.
self returns ifFalse: [
aStream nextPut: EndRemote.
pc _ aStream position.
].
stack pop: 1!
----- Method: BlockNode>>firstArgument (in category 'accessing') -----
firstArgument
^ arguments first!
----- Method: BlockNode>>isComplex (in category 'testing') -----
isComplex
^statements size > 1 or: [statements size = 1 and: [statements first isComplex]]!
----- Method: BlockNode>>isJust: (in category 'testing') -----
isJust: node
returns ifTrue: [^false].
^statements size = 1 and: [statements first == node]!
----- Method: BlockNode>>isJustCaseError (in category 'testing') -----
isJustCaseError
^ statements size = 1 and:
[statements first
isMessage: #caseError
receiver: [:r | r==NodeSelf]
arguments: nil]!
----- Method: BlockNode>>isQuick (in category 'testing') -----
isQuick
^ statements size = 1
and: [statements first isVariableReference
or: [statements first isSpecialConstant]]!
----- Method: BlockNode>>numberOfArguments (in category 'accessing') -----
numberOfArguments
^arguments size!
----- Method: BlockNode>>printArgumentsOn:indent: (in category 'printing') -----
printArgumentsOn: aStream indent: level
arguments size = 0
ifTrue: [^ self].
arguments do: [:arg | aStream
withStyleFor: #blockArgument
do: [aStream nextPutAll: ':';
nextPutAll: arg key;
space
]
].
aStream nextPutAll: '| '.
"If >0 args and >1 statement, put all statements on separate lines"
statements size > 1
ifTrue: [aStream crtab: level]!
----- Method: BlockNode>>printOn:indent: (in category 'printing') -----
printOn: aStream indent: level
aStream nextPut: $[.
self printArgumentsOn: aStream indent: level.
self printTemporariesOn: aStream indent: level.
self printStatementsOn: aStream indent: level.
aStream nextPut: $]!
----- Method: BlockNode>>printStatementsOn:indent: (in category 'printing') -----
printStatementsOn: aStream indent: levelOrZero
| len shown thisStatement level |
level _ 1 max: levelOrZero.
comment == nil
ifFalse:
[self printCommentOn: aStream indent: level.
aStream crtab: level].
len _ shown _ statements size.
(levelOrZero = 0 "top level" and: [statements last isReturnSelf])
ifTrue: [shown _ 1 max: shown - 1]
ifFalse: [(len = 1 and: [((statements at: 1) == NodeNil) & (arguments size = 0)])
ifTrue: [shown _ shown - 1]].
1 to: shown do:
[:i |
thisStatement _ statements at: i.
thisStatement printOn: aStream indent: level.
i < shown ifTrue: [aStream nextPut: $.; crtab: level].
(thisStatement comment ~~ nil and: [thisStatement comment size > 0])
ifTrue:
[i = shown ifTrue: [aStream crtab: level].
thisStatement printCommentOn: aStream indent: level.
i < shown ifTrue: [aStream crtab: level]]]!
----- Method: BlockNode>>printTemporariesOn:indent: (in category 'printing') -----
printTemporariesOn: aStream indent: level
(temporaries == nil or: [temporaries size = 0])
ifFalse:
[aStream nextPut: $|.
temporaries do:
[:arg |
aStream
space;
withStyleFor: #temporaryVariable
do: [aStream nextPutAll: arg key]].
aStream nextPutAll: ' | '.
"If >0 args and >1 statement, put all statements on separate lines"
statements size > 1 ifTrue: [aStream crtab: level]]!
----- Method: BlockNode>>returnLast (in category 'accessing') -----
returnLast
self returns
ifFalse:
[returns _ true.
statements at: statements size put: statements last asReturnNode]!
----- Method: BlockNode>>returnSelfIfNoOther (in category 'accessing') -----
returnSelfIfNoOther
self returns
ifFalse:
[statements last == NodeSelf ifFalse: [statements add: NodeSelf].
self returnLast]!
----- Method: BlockNode>>returns (in category 'testing') -----
returns
^returns or: [statements last isReturningIf]!
----- Method: BlockNode>>sizeExceptLast: (in category 'code generation') -----
sizeExceptLast: encoder
| codeSize nextToLast |
nextToLast _ statements size - 1.
nextToLast < 1 ifTrue: [^ 0]. "Only one statement"
codeSize _ 0.
1 to: nextToLast do:
[:i | codeSize _ codeSize + ((statements at: i) sizeForEffect: encoder)].
^ codeSize!
----- Method: BlockNode>>sizeForEvaluatedEffect: (in category 'code generation') -----
sizeForEvaluatedEffect: encoder
self returns ifTrue: [^self sizeForEvaluatedValue: encoder].
^(self sizeExceptLast: encoder)
+ (statements last sizeForEffect: encoder)!
----- Method: BlockNode>>sizeForEvaluatedValue: (in category 'code generation') -----
sizeForEvaluatedValue: encoder
^(self sizeExceptLast: encoder)
+ (statements last sizeForValue: encoder)!
----- Method: BlockNode>>sizeForValue: (in category 'code generation') -----
sizeForValue: encoder
nArgsNode _ encoder encodeLiteral: arguments size.
remoteCopyNode _ encoder encodeSelector: #blockCopy:.
size _ (self sizeForEvaluatedValue: encoder)
+ (self returns ifTrue: [0] ifFalse: [1]). "endBlock"
arguments _ arguments collect: "Chance to prepare debugger remote temps"
[:arg | arg asStorableNode: encoder].
arguments do: [:arg | size _ size + (arg sizeForStorePop: encoder)].
^1 + (nArgsNode sizeForValue: encoder)
+ (remoteCopyNode size: encoder args: 1 super: false) + 2 + size!
----- Method: BlockNode>>statements (in category 'equation translation') -----
statements
^statements!
----- Method: BlockNode>>statements: (in category 'equation translation') -----
statements: val
statements _ val!
----- Method: BlockNode>>statements:returns: (in category 'initialize-release') -----
statements: statementsCollection returns: returnBool
"Decompile."
| returnLast |
returnLast _ returnBool.
returns _ false.
statements _
(statementsCollection size > 1
and: [(statementsCollection at: statementsCollection size - 1)
isReturningIf])
ifTrue:
[returnLast _ false.
statementsCollection allButLast]
ifFalse: [statementsCollection size = 0
ifTrue: [Array with: NodeNil]
ifFalse: [statementsCollection]].
arguments _ #().
temporaries _ #().
returnLast ifTrue: [self returnLast]!
----- Method: BlockNode>>temporaries: (in category 'accessing') -----
temporaries: aCollection
temporaries _ aCollection!
ParseNode subclass: #BraceNode
instanceVariableNames: 'elements sourceLocations emitNode'
classVariableNames: ''
poolDictionaries: ''
category: 'Compiler-ParseNodes'!
!BraceNode commentStamp: '<historical>' prior: 0!
Used for compiling and decompiling brace constructs.
These now compile into either a fast short form for 4 elements or less:
Array braceWith: a with: b ...
or a long form of indefinfite length:
(Array braceStream: N) nextPut: a; nextPut: b; ...; braceArray.
The erstwhile brace assignment form is no longer supported.!
----- Method: BraceNode class>>example (in category 'examples') -----
example
"Test the {a. b. c} syntax."
| x |
x _ {1. {2. 3}. 4}.
^ {x first. x second first. x second last. x last. 5} as: Set
"BraceNode example Set (0 1 2 3 4 5 )"
!
----- Method: BraceNode>>blockAssociationCheck: (in category 'testing') -----
blockAssociationCheck: encoder
"If all elements are MessageNodes of the form [block]->[block], and there is at
least one element, answer true.
Otherwise, notify encoder of an error."
elements size = 0
ifTrue: [^encoder notify: 'At least one case required'].
elements with: sourceLocations do:
[:x :loc |
(x isMessage: #->
receiver:
[:rcvr |
(rcvr isKindOf: BlockNode) and: [rcvr numberOfArguments = 0]]
arguments:
[:arg |
(arg isKindOf: BlockNode) and: [arg numberOfArguments = 0]])
ifFalse:
[^encoder notify: 'Association between 0-argument blocks required' at: loc]].
^true!
----- Method: BraceNode>>casesForwardDo: (in category 'enumerating') -----
casesForwardDo: aBlock
"For each case in forward order, evaluate aBlock with three arguments:
the key block, the value block, and whether it is the last case."
| numCases case |
1 to: (numCases _ elements size) do:
[:i |
case _ elements at: i.
aBlock value: case receiver value: case arguments first value: i=numCases]!
----- Method: BraceNode>>casesReverseDo: (in category 'enumerating') -----
casesReverseDo: aBlock
"For each case in reverse order, evaluate aBlock with three arguments:
the key block, the value block, and whether it is the last case."
| numCases case |
(numCases _ elements size) to: 1 by: -1 do:
[:i |
case _ elements at: i.
aBlock value: case receiver value: case arguments first value: i=numCases]!
----- Method: BraceNode>>elements: (in category 'initialize-release') -----
elements: collection
"Decompile."
elements _ collection!
----- Method: BraceNode>>elements:sourceLocations: (in category 'initialize-release') -----
elements: collection sourceLocations: locations
"Compile."
elements _ collection.
sourceLocations _ locations!
----- Method: BraceNode>>emitForValue:on: (in category 'code generation') -----
emitForValue: stack on: aStream
^ emitNode emitForValue: stack on: aStream!
----- Method: BraceNode>>matchBraceStreamReceiver:messages: (in category 'initialize-release') -----
matchBraceStreamReceiver: receiver messages: messages
((receiver isMessage: #braceStream: receiver: nil arguments: [:arg | arg isConstantNumber])
and: [messages last isMessage: #braceArray receiver: nil arguments: nil])
ifFalse: [^ nil "no match"].
"Appears to be a long form brace construct"
self elements: (messages allButLast collect:
[:msg | (msg isMessage: #nextPut: receiver: nil arguments: nil)
ifFalse: [^ nil "not a brace element"].
msg arguments first])!
----- Method: BraceNode>>matchBraceWithReceiver:selector:arguments: (in category 'initialize-release') -----
matchBraceWithReceiver: receiver selector: selector arguments: arguments
selector = (self selectorForShortForm: arguments size)
ifFalse: [^ nil "no match"].
"Appears to be a short form brace construct"
self elements: arguments!
----- Method: BraceNode>>numElements (in category 'testing') -----
numElements
^ elements size!
----- Method: BraceNode>>printOn:indent: (in category 'printing') -----
printOn: aStream indent: level
aStream nextPut: ${.
1 to: elements size do:
[:i | (elements at: i) printOn: aStream indent: level.
i < elements size ifTrue: [aStream nextPutAll: '. ']].
aStream nextPut: $}!
----- Method: BraceNode>>selectorForShortForm: (in category 'code generation') -----
selectorForShortForm: nElements
nElements > 4 ifTrue: [^ nil].
^ #(braceWithNone braceWith: braceWith:with:
braceWith:with:with: braceWith:with:with:with:) at: nElements + 1!
----- Method: BraceNode>>sizeForValue: (in category 'code generation') -----
sizeForValue: encoder
emitNode _ elements size <= 4
ifTrue: ["Short form: Array braceWith: a with: b ... "
MessageNode new
receiver: (encoder encodeVariable: #Array)
selector: (self selectorForShortForm: elements size)
arguments: elements precedence: 3 from: encoder]
ifFalse: ["Long form: (Array braceStream: N) nextPut: a; nextPut: b; ...; braceArray"
CascadeNode new
receiver: (MessageNode new
receiver: (encoder encodeVariable: #Array)
selector: #braceStream:
arguments: (Array with: (encoder encodeLiteral: elements size))
precedence: 3 from: encoder)
messages: ((elements collect: [:elt | MessageNode new receiver: nil
selector: #nextPut:
arguments: (Array with: elt)
precedence: 3 from: encoder])
copyWith: (MessageNode new receiver: nil
selector: #braceArray
arguments: (Array new)
precedence: 1 from: encoder))].
^ emitNode sizeForValue: encoder!
ParseNode subclass: #CascadeNode
instanceVariableNames: 'receiver messages'
classVariableNames: ''
poolDictionaries: ''
category: 'Compiler-ParseNodes'!
!CascadeNode commentStamp: '<historical>' prior: 0!
The first message has the common receiver, the rest have receiver == nil, which signifies cascading.!
----- Method: CascadeNode>>emitForValue:on: (in category 'code generation') -----
emitForValue: stack on: aStream
receiver emitForValue: stack on: aStream.
1 to: messages size - 1 do:
[:i |
aStream nextPut: Dup.
stack push: 1.
(messages at: i) emitForValue: stack on: aStream.
aStream nextPut: Pop.
stack pop: 1].
messages last emitForValue: stack on: aStream!
----- Method: CascadeNode>>printOn:indent: (in category 'printing') -----
printOn: aStream indent: level
self printOn: aStream indent: level precedence: 0!
----- Method: CascadeNode>>printOn:indent:precedence: (in category 'printing') -----
printOn: aStream indent: level precedence: p
p > 0 ifTrue: [aStream nextPut: $(].
messages first printReceiver: receiver on: aStream indent: level.
1 to: messages size do:
[:i | (messages at: i) printOn: aStream indent: level.
i < messages size ifTrue:
[aStream nextPut: $;.
messages first precedence >= 2 ifTrue: [aStream crtab: level + 1]]].
p > 0 ifTrue: [aStream nextPut: $)]!
----- Method: CascadeNode>>receiver (in category 'accessing') -----
receiver
^receiver!
----- Method: CascadeNode>>receiver:messages: (in category 'initialize-release') -----
receiver: receivingObject messages: msgs
" Transcript show: 'abc'; cr; show: 'def' "
receiver _ receivingObject.
messages _ msgs!
----- Method: CascadeNode>>sizeForValue: (in category 'code generation') -----
sizeForValue: encoder
| size |
size _ (receiver sizeForValue: encoder) + (messages size - 1 * 2).
messages do: [:aMessage | size _ size + (aMessage sizeForValue: encoder)].
^size!
ParseNode subclass: #CommentNode
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Compiler-ParseNodes'!
ParseNode subclass: #DecompilerConstructor
instanceVariableNames: 'method instVars nArgs literalValues tempVars'
classVariableNames: ''
poolDictionaries: ''
category: 'Compiler-Support'!
!DecompilerConstructor commentStamp: '<historical>' prior: 0!
I construct the node tree for a Decompiler.!
----- Method: DecompilerConstructor>>codeAnyLitInd: (in category 'constructor') -----
codeAnyLitInd: association
^VariableNode new
name: association key
key: association
index: 0
type: LdLitIndType!
----- Method: DecompilerConstructor>>codeAnyLiteral: (in category 'constructor') -----
codeAnyLiteral: value
^LiteralNode new
key: value
index: 0
type: LdLitType!
----- Method: DecompilerConstructor>>codeAnySelector: (in category 'constructor') -----
codeAnySelector: selector
^SelectorNode new
key: selector
index: 0
type: SendType!
----- Method: DecompilerConstructor>>codeArguments:block: (in category 'constructor') -----
codeArguments: args block: block
^block arguments: args!
----- Method: DecompilerConstructor>>codeAssignTo:value: (in category 'constructor') -----
codeAssignTo: variable value: expression
^AssignmentNode new variable: variable value: expression!
----- Method: DecompilerConstructor>>codeBlock:returns: (in category 'constructor') -----
codeBlock: statements returns: returns
^ BlockNode statements: statements returns: returns!
----- Method: DecompilerConstructor>>codeBrace: (in category 'constructor') -----
codeBrace: elements
^BraceNode new elements: elements!
----- Method: DecompilerConstructor>>codeCascade:messages: (in category 'constructor') -----
codeCascade: receiver messages: messages
^ (BraceNode new matchBraceStreamReceiver: receiver messages: messages)
ifNil: [CascadeNode new receiver: receiver messages: messages]!
----- Method: DecompilerConstructor>>codeCascadedMessage:arguments: (in category 'constructor') -----
codeCascadedMessage: selector arguments: arguments
^self
codeMessage: nil
selector: selector
arguments: arguments!
----- Method: DecompilerConstructor>>codeConstants (in category 'constructor') -----
codeConstants
"Answer with an array of the objects representing self, true, false, nil,
-1, 0, 1, 2."
^(Array with: NodeSelf with: NodeTrue with: NodeFalse with: NodeNil)
, ((-1 to: 2) collect: [:i | LiteralNode new key: i code: LdMinus1 + i + 1])!
----- Method: DecompilerConstructor>>codeEmptyBlock (in category 'constructor') -----
codeEmptyBlock
^ BlockNode withJust: NodeNil!
----- Method: DecompilerConstructor>>codeInst: (in category 'constructor') -----
codeInst: index
^VariableNode new
name: (instVars at: index + 1 ifAbsent: ['unknown', index asString])
index: index
type: LdInstType!
----- Method: DecompilerConstructor>>codeMessage:selector:arguments: (in category 'constructor') -----
codeMessage: receiver selector: selector arguments: arguments
| symbol node |
symbol _ selector key.
(node _ BraceNode new
matchBraceWithReceiver: receiver
selector: symbol
arguments: arguments) ifNotNil: [^ node].
(node _ self decodeIfNilWithReceiver: receiver
selector: symbol
arguments: arguments) ifNotNil: [^ node].
^ MessageNode new
receiver: receiver selector: selector
arguments: arguments
precedence: symbol precedence!
----- Method: DecompilerConstructor>>codeMethod:block:tempVars:primitive:class: (in category 'constructor') -----
codeMethod: selector block: block tempVars: vars primitive: primitive class: class
| node methodTemps |
node _ self codeSelector: selector code: nil.
tempVars _ vars.
methodTemps _ tempVars select: [:t | t scope >= 0].
^MethodNode new
selector: node
arguments: (methodTemps copyFrom: 1 to: nArgs)
precedence: selector precedence
temporaries: (methodTemps copyFrom: nArgs + 1 to: methodTemps size)
block: block
encoder: (Encoder new initScopeAndLiteralTables
temps: tempVars
literals: literalValues
class: class)
primitive: primitive
properties: method properties.!
----- Method: DecompilerConstructor>>codeSelector:code: (in category 'constructor') -----
codeSelector: sel code: code
^SelectorNode new key: sel code: code!
----- Method: DecompilerConstructor>>codeSuper (in category 'constructor') -----
codeSuper
^NodeSuper!
----- Method: DecompilerConstructor>>codeTemp: (in category 'constructor') -----
codeTemp: index
^ TempVariableNode new
name: 't' , (index + 1) printString
index: index
type: LdTempType
scope: 0!
----- Method: DecompilerConstructor>>codeTemp:named: (in category 'constructor') -----
codeTemp: index named: tempName
^ TempVariableNode new
name: tempName
index: index
type: LdTempType
scope: 0!
----- Method: DecompilerConstructor>>codeThisContext (in category 'constructor') -----
codeThisContext
^NodeThisContext!
----- Method: DecompilerConstructor>>decodeIfNilWithReceiver:selector:arguments: (in category 'constructor') -----
decodeIfNilWithReceiver: receiver selector: selector arguments: arguments
selector == #ifTrue:ifFalse:
ifFalse: [^ nil].
(receiver isMessage: #==
receiver: nil
arguments: [:argNode | argNode == NodeNil])
ifFalse: [^ nil].
^ (MessageNode new
receiver: receiver
selector: (SelectorNode new key: #ifTrue:ifFalse: code: #macro)
arguments: arguments
precedence: 3)
noteSpecialSelector: #ifNil:ifNotNil:!
----- Method: DecompilerConstructor>>method:class:literals: (in category 'initialize-release') -----
method: aMethod class: aClass literals: literals
method _ aMethod.
instVars _ aClass allInstVarNames.
nArgs _ method numArgs.
literalValues _ literals!
ParseNode subclass: #Encoder
instanceVariableNames: 'scopeTable nTemps supered requestor class literalStream selectorSet litIndSet litSet sourceRanges globalSourceRanges'
classVariableNames: ''
poolDictionaries: ''
category: 'Compiler-Kernel'!
!Encoder commentStamp: '<historical>' prior: 0!
I encode names and literals into tree nodes with byte codes for the compiler. Byte codes for literals are not assigned until the tree-sizing pass of the compiler, because only then is it known which literals are actually needed. I also keep track of sourceCode ranges during parsing and code generation so I can provide an inverse map for the debugger.!
----- Method: Encoder>>allLiterals (in category 'results') -----
allLiterals
(literalStream isKindOf: WriteStream) ifTrue: [
self litIndex: nil.
self litIndex: class binding .
].
^ literalStream contents!
----- Method: Encoder>>autoBind: (in category 'temps') -----
autoBind: name
"Declare a block argument as a temp if not already declared."
| node |
node _ scopeTable
at: name
ifAbsent:
[(self lookupInPools: name ifFound: [:assoc | assoc])
ifTrue: [self notify: 'Name already used in a Pool or Global'].
^ (self reallyBind: name) nowHasDef nowHasRef scope: 1].
node isTemp
ifTrue: [node scope >= 0 ifTrue:
[^ self notify: 'Name already used in this method'].
node nowHasDef nowHasRef scope: 1]
ifFalse: [^ self notify: 'Name already used in this class'].
^node!
----- Method: Encoder>>bindAndJuggle: (in category 'temps') -----
bindAndJuggle: name
| node nodes first thisCode |
node _ self reallyBind: name.
"Declared temps must precede block temps for decompiler and debugger to work right"
nodes _ self tempNodes.
(first _ nodes findFirst: [:n | n scope > 0]) > 0 ifTrue:
[node == nodes last ifFalse: [self error: 'logic error'].
thisCode _ (nodes at: first) code.
first to: nodes size - 1 do:
[:i | (nodes at: i) key: (nodes at: i) key
code: (nodes at: i+1) code].
nodes last key: nodes last key code: thisCode].
^ node!
----- Method: Encoder>>bindArg: (in category 'temps') -----
bindArg: name
"Declare an argument."
| node |
nTemps >= 15
ifTrue: [^self notify: 'Too many arguments'].
node _ self bindTemp: name.
^ node nowHasDef nowHasRef!
----- Method: Encoder>>bindBlockTemp: (in category 'temps') -----
bindBlockTemp: name
"Declare a temporary block variable; complain if it's not a field or class variable."
| node |
node _ scopeTable at: name ifAbsent: [^self reallyBind: name].
node isTemp
ifTrue: [
node scope >= 0 ifTrue: [^ self notify: 'Name already used in this method'].
node scope: 0]
ifFalse: [^self notify: 'Name already used in this class'].
^node
!
----- Method: Encoder>>bindTemp: (in category 'temps') -----
bindTemp: name
"Declare a temporary; error not if a field or class variable."
scopeTable at: name ifPresent:[:node|
"When non-interactive raise the error only if its a duplicate"
(node isTemp or:[requestor interactive])
ifTrue:[^self notify:'Name is already defined']
ifFalse:[Transcript
show: '(', name, ' is shadowed in "' , class printString, '")']].
^self reallyBind: name!
----- Method: Encoder>>bindTemp:in: (in category 'temps') -----
bindTemp: name in: methodSelector
"Declare a temporary; error not if a field or class variable."
scopeTable at: name ifPresent:[:node|
"When non-interactive raise the error only if its a duplicate"
(node isTemp or:[requestor interactive])
ifTrue:[^self notify:'Name is already defined']
ifFalse:[Transcript
show: '(', name, ' is shadowed in "' , class printString , '>>' , methodSelector printString , '")']].
^self reallyBind: name!
----- Method: Encoder>>cantStoreInto: (in category 'encoding') -----
cantStoreInto: varName
^StdVariables includesKey: varName!
----- Method: Encoder>>classEncoding (in category 'private') -----
classEncoding
"This is a hack so that the parser may findout what class it was parsing for when it wants to create a syntax error view."
^ class!
----- Method: Encoder>>encodeLiteral: (in category 'encoding') -----
encodeLiteral: object
^self
name: object
key: (class literalScannedAs: object notifying: self)
class: LiteralNode
type: LdLitType
set: litSet!
----- Method: Encoder>>encodeSelector: (in category 'encoding') -----
encodeSelector: selector
^self
name: selector
key: selector
class: SelectorNode
type: SendType
set: selectorSet!
----- Method: Encoder>>encodeVariable: (in category 'encoding') -----
encodeVariable: name
^ self encodeVariable: name sourceRange: nil ifUnknown: [ self undeclared: name ]!
----- Method: Encoder>>encodeVariable:ifUnknown: (in category 'encoding') -----
encodeVariable: name ifUnknown: action
^self encodeVariable: name sourceRange: nil ifUnknown: action!
----- Method: Encoder>>encodeVariable:sourceRange:ifUnknown: (in category 'encoding') -----
encodeVariable: name sourceRange: range ifUnknown: action
| varNode |
varNode _ scopeTable at: name
ifAbsent:
[(self lookupInPools: name
ifFound: [:assoc | varNode _ self global: assoc name: name])
ifTrue: [varNode]
ifFalse: [action value]].
range ifNotNil: [
name first canBeGlobalVarInitial ifTrue:
[globalSourceRanges addLast: { name. range. false }]. ].
(varNode isTemp and: [varNode scope < 0]) ifTrue: [
OutOfScopeNotification signal ifFalse: [ ^self notify: 'out of scope'].
].
^ varNode!
----- Method: Encoder>>fillDict:with:mapping:to: (in category 'initialize-release') -----
fillDict: dict with: nodeClass mapping: keys to: codeArray
| codeStream |
codeStream _ ReadStream on: codeArray.
keys do:
[:key | dict
at: key
put: (nodeClass new name: key key: key code: codeStream next)]!
----- Method: Encoder>>global:name: (in category 'private') -----
global: ref name: name
^self
name: name
key: ref
class: LiteralVariableNode
type: LdLitIndType
set: litIndSet!
----- Method: Encoder>>globalSourceRanges (in category 'source mapping') -----
globalSourceRanges
^ globalSourceRanges!
----- Method: Encoder>>init:context:notifying: (in category 'initialize-release') -----
init: aClass context: aContext notifying: req
| node n homeNode indexNode |
requestor _ req.
class _ aClass.
nTemps _ 0.
supered _ false.
self initScopeAndLiteralTables.
n _ -1.
class allInstVarNames do:
[:variable |
node _ VariableNode new
name: variable
index: (n _ n + 1)
type: LdInstType.
scopeTable at: variable put: node].
aContext == nil
ifFalse:
[homeNode _ self bindTemp: 'homeContext'.
"first temp = aContext passed as arg"
n _ 0.
aContext tempNames do:
[:variable |
indexNode _ self encodeLiteral: (n _ n + 1).
node _ MessageAsTempNode new
receiver: homeNode
selector: #tempAt:
arguments: (Array with: indexNode)
precedence: 3
from: self.
scopeTable at: variable put: node]].
sourceRanges _ Dictionary new: 32.
globalSourceRanges _ OrderedCollection new: 32.
!
----- Method: Encoder>>initScopeAndLiteralTables (in category 'initialize-release') -----
initScopeAndLiteralTables
scopeTable _ StdVariables copy.
litSet _ StdLiterals copy.
selectorSet _ StdSelectors copy.
litIndSet _ Dictionary new: 16.
literalStream _ WriteStream on: (Array new: 32)!
----- Method: Encoder>>litIndex: (in category 'encoding') -----
litIndex: literal
| p |
p _ literalStream position.
p = 256 ifTrue:
[self notify: 'More than 256 literals referenced.
You must split or otherwise simplify this method.
The 257th literal is: ', literal printString. ^nil].
"Would like to show where it is in the source code,
but that info is hard to get."
literalStream nextPut: literal.
^ p!
----- Method: Encoder>>literals (in category 'results') -----
literals
"Should only be used for decompiling primitives"
^ literalStream contents!
----- Method: Encoder>>lookupInPools:ifFound: (in category 'private') -----
lookupInPools: varName ifFound: assocBlock
Symbol hasInterned: varName ifTrue:[:sym|
(class bindingOf: sym) ifNotNilDo:[:assoc|
assocBlock value: assoc.
^true].
(Preferences valueOfFlag: #lenientScopeForGlobals) "**Temporary**"
ifTrue: [^ Smalltalk lenientScopeHas: sym ifTrue: assocBlock]
ifFalse: [^ false]].
(class bindingOf: varName) ifNotNilDo:[:assoc|
assocBlock value: assoc.
^true].
^false!
----- Method: Encoder>>maxTemp (in category 'temps') -----
maxTemp
^nTemps!
----- Method: Encoder>>nTemps:literals:class: (in category 'initialize-release') -----
nTemps: n literals: lits class: cl
"Decompile."
supered _ false.
class _ cl.
nTemps _ n.
literalStream _ ReadStream on: lits.
literalStream position: lits size.
sourceRanges _ Dictionary new: 32.
globalSourceRanges _ OrderedCollection new: 32.
!
----- Method: Encoder>>name:key:class:type:set: (in category 'private') -----
name: name key: key class: leafNodeClass type: type set: dict
| node |
^dict
at: key
ifAbsent:
[node _ leafNodeClass new
name: name
key: key
index: nil
type: type.
dict at: key put: node.
^node]!
----- Method: Encoder>>newTemp: (in category 'temps') -----
newTemp: name
nTemps _ nTemps + 1.
^ TempVariableNode new
name: name
index: nTemps - 1
type: LdTempType
scope: 0!
----- Method: Encoder>>noteSourceRange:forNode: (in category 'source mapping') -----
noteSourceRange: range forNode: node
sourceRanges at: node put: range!
----- Method: Encoder>>noteSuper (in category 'initialize-release') -----
noteSuper
supered _ true!
----- Method: Encoder>>notify: (in category 'error handling') -----
notify: string
"Put a separate notifier on top of the requestor's window"
| req |
requestor == nil
ifFalse:
[req _ requestor.
self release.
req notify: string].
^false!
----- Method: Encoder>>notify:at: (in category 'error handling') -----
notify: string at: location
| req |
requestor == nil
ifFalse:
[req _ requestor.
self release.
req notify: string at: location].
^false!
----- Method: Encoder>>possibleNamesFor: (in category 'private') -----
possibleNamesFor: proposedName
| results |
results _ class possibleVariablesFor: proposedName continuedFrom: nil.
^ proposedName correctAgainst: nil continuedFrom: results.
!
----- Method: Encoder>>possibleVariablesFor: (in category 'private') -----
possibleVariablesFor: proposedVariable
| results |
results _ proposedVariable correctAgainstDictionary: scopeTable
continuedFrom: nil.
proposedVariable first canBeGlobalVarInitial ifTrue:
[ results _ class possibleVariablesFor: proposedVariable
continuedFrom: results ].
^ proposedVariable correctAgainst: nil continuedFrom: results.
!
----- Method: Encoder>>rawSourceRanges (in category 'source mapping') -----
rawSourceRanges
^ sourceRanges !
----- Method: Encoder>>reallyBind: (in category 'private') -----
reallyBind: name
| node |
node _ self newTemp: name.
scopeTable at: name put: node.
^node!
----- Method: Encoder>>release (in category 'initialize-release') -----
release
requestor _ nil!
----- Method: Encoder>>requestor: (in category 'error handling') -----
requestor: req
"Often the requestor is a BrowserCodeController"
requestor _ req!
----- Method: Encoder>>sharableLitIndex: (in category 'encoding') -----
sharableLitIndex: literal
"Special access prevents multiple entries for post-allocated super send special selectors"
| p |
p _ literalStream originalContents indexOf: literal.
p = 0 ifFalse: [^ p-1].
^ self litIndex: literal
!
----- Method: Encoder>>sourceMap (in category 'source mapping') -----
sourceMap
"Answer with a sorted set of associations (pc range)."
^ (sourceRanges keys collect:
[:key | Association key: key pc value: (sourceRanges at: key)])
asSortedCollection!
----- Method: Encoder>>tempNames (in category 'results') -----
tempNames
^ self tempNodes collect:
[:node | (node isMemberOf: MessageAsTempNode)
ifTrue: [scopeTable keyAtValue: node]
ifFalse: [node key]]!
----- Method: Encoder>>tempNodes (in category 'results') -----
tempNodes
| tempNodes |
tempNodes _ SortedCollection sortBlock: [:n1 :n2 | n1 code <= n2 code].
scopeTable associationsDo:
[:assn | assn value isTemp ifTrue: [tempNodes add: assn value]].
^ tempNodes!
----- Method: Encoder>>temps:literals:class: (in category 'initialize-release') -----
temps: tempVars literals: lits class: cl
"Decompile."
supered _ false.
class _ cl.
nTemps _ tempVars size.
tempVars do: [:node | scopeTable at: node name put: node].
literalStream _ ReadStream on: lits.
literalStream position: lits size.
sourceRanges _ Dictionary new: 32.
globalSourceRanges _ OrderedCollection new: 32.
!
----- Method: Encoder>>tempsAndBlockArgs (in category 'results') -----
tempsAndBlockArgs
| tempNodes var |
tempNodes _ OrderedCollection new.
scopeTable associationsDo:
[:assn | var _ assn value.
((var isTemp and: [var isArg not])
and: [var scope = 0 or: [var scope = -1]])
ifTrue: [tempNodes add: var]].
^ tempNodes!
----- Method: Encoder>>undeclared: (in category 'encoding') -----
undeclared: name
| sym |
requestor interactive ifTrue: [
requestor requestor == #error: ifTrue: [requestor error: 'Undeclared'].
^ self notify: 'Undeclared'].
Transcript show: ' (' , name , ' is Undeclared) '.
sym _ name asSymbol.
Undeclared at: sym put: nil.
^self global: (Undeclared associationAt: sym) name: sym!
----- Method: Encoder>>unusedTempNames (in category 'results') -----
unusedTempNames
| unused name |
unused _ OrderedCollection new.
scopeTable associationsDo:
[:assn | (assn value isUnusedTemp)
ifTrue: [name _ assn value key.
name ~= 'homeContext' ifTrue: [unused add: name]]].
^ unused!
ParseNode subclass: #LeafNode
instanceVariableNames: 'key code'
classVariableNames: ''
poolDictionaries: ''
category: 'Compiler-ParseNodes'!
!LeafNode commentStamp: '<historical>' prior: 0!
I represent a leaf node of the compiler parse tree. I am abstract.
Types (defined in class ParseNode):
1 LdInstType (which uses class VariableNode)
2 LdTempType (which uses class VariableNode)
3 LdLitType (which uses class LiteralNode)
4 LdLitIndType (which uses class VariableNode)
5 SendType (which uses class SelectorNode).
Note that Squeak departs slightly from the Blue Book bytecode spec.
In order to allow access to more than 63 literals and instance variables,
bytecode 132 has been redefined as DoubleExtendedDoAnything:
byte2 byte3 Operation
(hi 3 bits) (lo 5 bits)
0 nargs lit index Send Literal Message 0-255
1 nargs lit index Super-Send Lit Msg 0-255
2 ignored rcvr index Push Receiver Variable 0-255
3 ignored lit index Push Literal Constant 0-255
4 ignored lit index Push Literal Variable 0-255
5 ignored rcvr index Store Receiver Variable 0-255
6 ignored rcvr index Store-pop Receiver Variable 0-255
7 ignored lit index Store Literal Variable 0-255
This has allowed bytecode 134 also to be redefined as a second extended send
that can access literals up to 64 for nargs up to 3 without needing three bytes.
It is just like 131, except that the extension byte is aallllll instead of aaalllll,
where aaa are bits of argument count, and lll are bits of literal index.!
----- Method: LeafNode>>code (in category 'code generation') -----
code
^ code!
----- Method: LeafNode>>code: (in category 'code generation') -----
code: aValue
code := aValue!
----- Method: LeafNode>>code:type: (in category 'private') -----
code: index type: type
index isNil
ifTrue: [^type negated].
(CodeLimits at: type) > index
ifTrue: [^(CodeBases at: type) + index].
^type * 256 + index!
----- Method: LeafNode>>emitForEffect:on: (in category 'code generation') -----
emitForEffect: stack on: strm
^self!
----- Method: LeafNode>>emitLong:on: (in category 'code generation') -----
emitLong: mode on: aStream
"Emit extended variable access."
| type index |
self code < 256
ifTrue:
[self code < 16
ifTrue: [type _ 0.
index _ self code]
ifFalse: [self code < 32
ifTrue: [type _ 1.
index _ self code - 16]
ifFalse: [self code < 96
ifTrue: [type _ self code // 32 + 1.
index _ self code \\ 32]
ifFalse: [self error:
'Sends should be handled in SelectorNode']]]]
ifFalse:
[index _ self code \\ 256.
type _ self code // 256 - 1].
index <= 63 ifTrue:
[aStream nextPut: mode.
^ aStream nextPut: type * 64 + index].
"Compile for Double-exetended Do-anything instruction..."
mode = LoadLong ifTrue:
[aStream nextPut: DblExtDoAll.
aStream nextPut: (#(64 0 96 128) at: type+1). "Cant be temp (type=1)"
^ aStream nextPut: index].
mode = Store ifTrue:
[aStream nextPut: DblExtDoAll.
aStream nextPut: (#(160 0 0 224) at: type+1). "Cant be temp or const (type=1 or 2)"
^ aStream nextPut: index].
mode = StorePop ifTrue:
[aStream nextPut: DblExtDoAll.
aStream nextPut: (#(192 0 0 0) at: type+1). "Can only be inst"
^ aStream nextPut: index].
!
----- Method: LeafNode>>key (in category 'accessing') -----
key
^key!
----- Method: LeafNode>>key: (in category 'initialize-release') -----
key: object
key _ object.
!
----- Method: LeafNode>>key:code: (in category 'initialize-release') -----
key: object code: byte
self key: object.
self code: byte!
----- Method: LeafNode>>key:index:type: (in category 'initialize-release') -----
key: object index: i type: type
self key: object code: (self code: i type: type)!
----- Method: LeafNode>>name:key:code: (in category 'initialize-release') -----
name: ignored key: object code: byte
self key: object.
self code: byte!
----- Method: LeafNode>>name:key:index:type: (in category 'initialize-release') -----
name: literal key: object index: i type: type
self key: object
index: i
type: type!
----- Method: LeafNode>>reserve: (in category 'code generation') -----
reserve: encoder
"If this is a yet unused literal of type -code, reserve it."
self code < 0 ifTrue: [self code: (self code: (encoder litIndex: self key) type: 0 - self code)]!
----- Method: LeafNode>>sizeForEffect: (in category 'code generation') -----
sizeForEffect: encoder
^0!
----- Method: LeafNode>>sizeForValue: (in category 'code generation') -----
sizeForValue: encoder
self reserve: encoder.
self code < 256 ifTrue: [^ 1].
(self code \\ 256) <= 63 ifTrue: [^ 2].
^ 3!
----- Method: LeafNode>>veryDeepFixupWith: (in category 'copying') -----
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.
self key: (deepCopier references at: self key ifAbsent: [self key]).
!
----- Method: LeafNode>>veryDeepInner: (in category 'copying') -----
veryDeepInner: deepCopier
"Copy all of my instance variables. Some need to be not copied at all, but shared. Warning!!!! Every instance variable defined in this class must be handled. We must also implement veryDeepFixupWith:. See DeepCopier class comment."
super veryDeepInner: deepCopier.
"key _ key. Weakly copied"
self code: (self code veryDeepCopyWith: deepCopier).
!
LeafNode subclass: #LiteralNode
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Compiler-ParseNodes'!
!LiteralNode commentStamp: '<historical>' prior: 0!
I am a parse tree leaf representing a literal string or number.!
----- Method: LiteralNode>>emitForValue:on: (in category 'code generation') -----
emitForValue: stack on: strm
code < 256
ifTrue: [strm nextPut: code]
ifFalse: [self emitLong: LoadLong on: strm].
stack push: 1!
----- Method: LiteralNode>>eval (in category 'evaluation') -----
eval
"When everything in me is a constant, I can produce a value. This is only used by the Scripting system (TilePadMorph tilesFrom:in:)"
^ key!
----- Method: LiteralNode>>isConstantNumber (in category 'testing') -----
isConstantNumber
^ key isNumber!
----- Method: LiteralNode>>isLiteral (in category 'testing') -----
isLiteral
^ true!
----- Method: LiteralNode>>isSpecialConstant (in category 'testing') -----
isSpecialConstant
^ code between: LdTrue and: LdMinus1+3!
----- Method: LiteralNode>>literalValue (in category 'testing') -----
literalValue
^key!
----- Method: LiteralNode>>printOn:indent: (in category 'printing') -----
printOn: aStream indent: level
(key isVariableBinding)
ifTrue:
[key key isNil
ifTrue:
[aStream nextPutAll: '###';
nextPutAll: key value soleInstance name]
ifFalse:
[aStream nextPutAll: '##';
nextPutAll: key key]]
ifFalse:
[aStream withStyleFor: #literal
do: [key storeOn: aStream]]!
LeafNode subclass: #SelectorNode
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Compiler-ParseNodes'!
!SelectorNode commentStamp: '<historical>' prior: 0!
I am a parse tree leaf representing a selector.!
SelectorNode subclass: #KeyWordNode
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Compiler-ParseNodes'!
!KeyWordNode commentStamp: '<historical>' prior: 0!
I am a part of a selector. #at:put: is owned by a SelectorNode, and #put: within it is owned by a KeyWordNode.!
----- Method: SelectorNode>>emit:args:on: (in category 'code generation') -----
emit: stack args: nArgs on: strm
self emit: stack
args: nArgs
on: strm
super: false!
----- Method: SelectorNode>>emit:args:on:super: (in category 'code generation') -----
emit: stack args: nArgs on: aStream super: supered
| index |
stack pop: nArgs.
(supered not and: [code - Send < SendLimit and: [nArgs < 3]]) ifTrue:
["short send"
code < Send
ifTrue: [^ aStream nextPut: code "special"]
ifFalse: [^ aStream nextPut: nArgs * 16 + code]].
index _ code < 256 ifTrue: [code - Send] ifFalse: [code \\ 256].
(index <= 31 and: [nArgs <= 7]) ifTrue:
["extended (2-byte) send [131 and 133]"
aStream nextPut: SendLong + (supered ifTrue: [2] ifFalse: [0]).
^ aStream nextPut: nArgs * 32 + index].
(supered not and: [index <= 63 and: [nArgs <= 3]]) ifTrue:
["new extended (2-byte) send [134]"
aStream nextPut: SendLong2.
^ aStream nextPut: nArgs * 64 + index].
"long (3-byte) send"
aStream nextPut: DblExtDoAll.
aStream nextPut: nArgs + (supered ifTrue: [32] ifFalse: [0]).
aStream nextPut: index!
----- Method: SelectorNode>>emitForEffect:on: (in category 'inappropriate') -----
emitForEffect: stack on: strm
self shouldNotImplement!
----- Method: SelectorNode>>emitForValue:on: (in category 'inappropriate') -----
emitForValue: stack on: strm
self shouldNotImplement!
----- Method: SelectorNode>>isPvtSelector (in category 'testing') -----
isPvtSelector
"Answer if this selector node is a private message selector."
^key isPvtSelector!
----- Method: SelectorNode>>printOn:indent: (in category 'printing') -----
printOn: aStream indent: level
aStream withStyleFor: #keyword
do: [key == nil
ifTrue: [aStream nextPutAll: '<key==nil>']
ifFalse: [aStream nextPutAll: key]]!
----- Method: SelectorNode>>size:args:super: (in category 'code generation') -----
size: encoder args: nArgs super: supered
| index |
self reserve: encoder.
(supered not and: [code - Send < SendLimit and: [nArgs < 3]])
ifTrue: [^1]. "short send"
(supered and: [code < Send]) ifTrue:
["super special:"
code _ self code: (encoder sharableLitIndex: key) type: 5].
index _ code < 256 ifTrue: [code - Send] ifFalse: [code \\ 256].
(index <= 31 and: [nArgs <= 7])
ifTrue: [^ 2]. "medium send"
(supered not and: [index <= 63 and: [nArgs <= 3]])
ifTrue: [^ 2]. "new medium send"
^ 3 "long send"!
----- Method: SelectorNode>>sizeForEffect: (in category 'inappropriate') -----
sizeForEffect: encoder
self shouldNotImplement!
----- Method: SelectorNode>>sizeForValue: (in category 'inappropriate') -----
sizeForValue: encoder
self shouldNotImplement!
LeafNode subclass: #VariableNode
instanceVariableNames: 'name'
classVariableNames: ''
poolDictionaries: ''
category: 'Compiler-ParseNodes'!
!VariableNode commentStamp: '<historical>' prior: 0!
I am a parse tree leaf representing a variable. Note that my name and key are different for pool variables: the key is the Object Reference.!
VariableNode subclass: #LiteralVariableNode
instanceVariableNames: 'splNode'
classVariableNames: ''
poolDictionaries: ''
category: 'Compiler-ParseNodes'!
----- Method: LiteralVariableNode>>emitLoad:on: (in category 'code generation') -----
emitLoad: stack on: strm
splNode ifNil:[^super emitLoad: stack on: strm].
self code < 256
ifTrue: [strm nextPut: self code]
ifFalse: [self emitLong: LoadLong on: strm].
stack push: 1.!
----- Method: LiteralVariableNode>>emitStore:on: (in category 'code generation') -----
emitStore: stack on: strm
splNode ifNil:[^super emitStore: stack on: strm].
splNode
emit: stack
args: 1
on: strm
super: false.!
----- Method: LiteralVariableNode>>emitStorePop:on: (in category 'code generation') -----
emitStorePop: stack on: strm
splNode ifNil:[^super emitStorePop: stack on: strm].
self emitStore: stack on: strm.
strm nextPut: Pop.
stack pop: 1.!
----- Method: LiteralVariableNode>>sizeForStore: (in category 'code generation') -----
sizeForStore: encoder
| index |
(self key isVariableBinding and:[self key isSpecialWriteBinding])
ifFalse:[^super sizeForStore: encoder].
self code < 0 ifTrue:[
index _ self index.
self code: (self code: index type: LdLitType)].
splNode _ encoder encodeSelector: #value:.
^ (splNode size: encoder args: 1 super: false) + (super sizeForValue: encoder)!
----- Method: LiteralVariableNode>>sizeForStorePop: (in category 'code generation') -----
sizeForStorePop: encoder
| index |
(self key isVariableBinding and:[self key isSpecialWriteBinding])
ifFalse:[^super sizeForStorePop: encoder].
self code < 0 ifTrue:[
index _ self index.
self code: (self code: index type: LdLitType)].
splNode _ encoder encodeSelector: #value:.
^ (splNode size: encoder args: 1 super: false) + (super sizeForValue: encoder) + 1!
VariableNode subclass: #TempVariableNode
instanceVariableNames: 'isAnArg hasRefs hasDefs scope'
classVariableNames: ''
poolDictionaries: ''
category: 'Compiler-ParseNodes'!
!TempVariableNode commentStamp: '<historical>' prior: 0!
I am a parse tree leaf representing a temporary variable!
----- Method: TempVariableNode>>assignmentCheck:at: (in category 'testing') -----
assignmentCheck: encoder at: location
self isArg ifTrue: [^ location]
ifFalse: [^ -1]!
----- Method: TempVariableNode>>isArg (in category 'testing') -----
isArg
^ isAnArg!
----- Method: TempVariableNode>>isArg: (in category 'initialize-release') -----
isArg: aBoolean
isAnArg _ aBoolean.
isAnArg ifTrue: [hasDefs _ true]!
----- Method: TempVariableNode>>isTemp (in category 'testing') -----
isTemp
^ true!
----- Method: TempVariableNode>>isUndefTemp (in category 'testing') -----
isUndefTemp
^ hasDefs not!
----- Method: TempVariableNode>>isUnusedTemp (in category 'testing') -----
isUnusedTemp
^ hasRefs not!
----- Method: TempVariableNode>>name:index:type:scope: (in category 'initialize-release') -----
name: varName index: i type: type scope: level
"Only used for initting temporary variables"
self name: varName.
self key: varName
index: i
type: type.
self isArg: (hasDefs _ hasRefs _ false).
self scope: level!
----- Method: TempVariableNode>>nowHasDef (in category 'initialize-release') -----
nowHasDef
hasDefs _ true!
----- Method: TempVariableNode>>nowHasRef (in category 'initialize-release') -----
nowHasRef
hasRefs _ true!
----- Method: TempVariableNode>>printOn:indent: (in category 'printing') -----
printOn: aStream indent: level
aStream withStyleFor: #temporaryVariable
do: [aStream nextPutAll: self name]!
----- Method: TempVariableNode>>scope (in category 'testing') -----
scope
^ scope!
----- Method: TempVariableNode>>scope: (in category 'initialize-release') -----
scope: level
"Note scope of temporary variables.
Currently only the following distinctions are made:
0 outer level: args and user-declared temps
1 block args and doLimiT temps
-1 a block temp that is no longer active
-2 a block temp that held limit of to:do:"
scope _ level!
----- Method: VariableNode class>>initialize (in category 'class initialization') -----
initialize "VariableNode initialize. Decompiler initialize"
| encoder |
encoder _ Encoder new.
StdVariables _ Dictionary new: 16.
encoder
fillDict: StdVariables
with: VariableNode
mapping: #('self' 'thisContext' 'super' 'nil' 'false' 'true' )
to: (Array with: LdSelf with: LdThisContext with: LdSuper)
, (Array with: LdNil with: LdFalse with: LdTrue).
StdSelectors _ Dictionary new: 64.
encoder
fillDict: StdSelectors
with: SelectorNode
mapping: ((1 to: Smalltalk specialSelectorSize) collect:
[:i | Smalltalk specialSelectorAt: i])
to: (SendPlus to: SendPlus + 31).
StdLiterals _ LiteralDictionary new: 16.
encoder
fillDict: StdLiterals
with: LiteralNode
mapping: #(-1 0 1 2 )
to: (LdMinus1 to: LdMinus1 + 3).
encoder initScopeAndLiteralTables.
NodeNil _ encoder encodeVariable: 'nil'.
NodeTrue _ encoder encodeVariable: 'true'.
NodeFalse _ encoder encodeVariable: 'false'.
NodeSelf _ encoder encodeVariable: 'self'.
NodeThisContext _ encoder encodeVariable: 'thisContext'.
NodeSuper _ encoder encodeVariable: 'super'!
----- Method: VariableNode>>asStorableNode: (in category 'initialize-release') -----
asStorableNode: encoder
^ self!
----- Method: VariableNode>>assignmentCheck:at: (in category 'testing') -----
assignmentCheck: encoder at: location
(encoder cantStoreInto: self name)
ifTrue: [^ location]
ifFalse: [^ -1]
!
----- Method: VariableNode>>canBeSpecialArgument (in category 'testing') -----
canBeSpecialArgument
"Can I be an argument of (e.g.) ifTrue:?"
^ self code < LdNil!
----- Method: VariableNode>>emitForReturn:on: (in category 'code generation') -----
emitForReturn: stack on: strm
(self code >= LdSelf and: [self code <= LdNil])
ifTrue:
["short returns"
strm nextPut: EndMethod - 4 + (self code - LdSelf).
stack push: 1 "doesnt seem right"]
ifFalse:
[super emitForReturn: stack on: strm]!
----- Method: VariableNode>>emitForValue:on: (in category 'code generation') -----
emitForValue: stack on: strm
self code < 256
ifTrue:
[strm nextPut: (self code = LdSuper ifTrue: [LdSelf] ifFalse: [self code]).
stack push: 1]
ifFalse:
[self emitLong: LoadLong on: strm.
stack push: 1]!
----- Method: VariableNode>>emitLoad:on: (in category 'code generation') -----
emitLoad: stack on: strm
"Do nothing"!
----- Method: VariableNode>>emitStore:on: (in category 'code generation') -----
emitStore: stack on: strm
self emitLong: Store on: strm!
----- Method: VariableNode>>emitStorePop:on: (in category 'code generation') -----
emitStorePop: stack on: strm
(self code between: 0 and: 7)
ifTrue:
[strm nextPut: ShortStoP + self code "short stopop inst"]
ifFalse:
[(self code between: 16 and: 23)
ifTrue: [strm nextPut: ShortStoP + 8 + self code - 16 "short stopop temp"]
ifFalse: [(self code >= 256 and: [self code \\ 256 > 63 and: [self code // 256 = 4]])
ifTrue: [self emitLong: Store on: strm. strm nextPut: Pop]
ifFalse: [self emitLong: StorePop on: strm]]].
stack pop: 1!
----- Method: VariableNode>>fieldOffset (in category 'code generation') -----
fieldOffset "Return temp or instVar offset for this variable"
self code < 256
ifTrue:
[^ self code \\ 16]
ifFalse:
[^ self code \\ 256]!
----- Method: VariableNode>>index (in category 'testing') -----
index
"This code attempts to reconstruct the index from its encoding in code."
self code < 0 ifTrue:[^ nil].
self code > 256 ifTrue:[^ self code \\ 256].
^self code - self type!
----- Method: VariableNode>>isSelfPseudoVariable (in category 'testing') -----
isSelfPseudoVariable
"Answer if this ParseNode represents the 'self' pseudo-variable."
^ (self key = 'self') | (self name = '{{self}}')!
----- Method: VariableNode>>isVariableReference (in category 'testing') -----
isVariableReference
^true!
----- Method: VariableNode>>name (in category 'accessing') -----
name
^ name!
----- Method: VariableNode>>name: (in category 'initialize-release') -----
name: string
"Change name"
name _ string.
!
----- Method: VariableNode>>name:index:type: (in category 'initialize-release') -----
name: varName index: i type: type
"Only used for initting instVar refs"
self name: varName.
self key: varName
index: i
type: type!
----- Method: VariableNode>>name:key:code: (in category 'initialize-release') -----
name: string key: object code: byte
"Only used for initting std variables, nil, true, false, self, etc."
self name: string.
self key: object.
self code: byte!
----- Method: VariableNode>>name:key:index:type: (in category 'initialize-release') -----
name: varName key: objRef index: i type: type
"Only used for initting global (litInd) variables"
self name: varName.
self key: objRef
index: i
type: type!
----- Method: VariableNode>>printOn:indent: (in category 'printing') -----
printOn: aStream indent: level
aStream withStyleFor: #variable
do: [aStream nextPutAll: self name].
!
----- Method: VariableNode>>sizeForReturn: (in category 'code generation') -----
sizeForReturn: encoder
(self code >= LdSelf and: [self code <= LdNil])
ifTrue: ["short returns" ^1].
^super sizeForReturn: encoder!
----- Method: VariableNode>>sizeForStore: (in category 'code generation') -----
sizeForStore: encoder
self reserve: encoder.
self code < 256 ifTrue: [^ 2].
(self code \\ 256) <= 63 ifTrue: [^ 2].
^ 3!
----- Method: VariableNode>>sizeForStorePop: (in category 'code generation') -----
sizeForStorePop: encoder
self reserve: encoder.
(self code < 24 and: [self code noMask: 8]) ifTrue: [^ 1].
self code < 256 ifTrue: [^ 2].
self code \\ 256 <= 63 ifTrue: [^ 2]. "extended StorePop"
self code // 256 = 1 ifTrue: [^ 3]. "dbl extended StorePopInst"
self code // 256 = 4 ifTrue: [^ 4]. "dbl extended StoreLitVar , Pop"
self halt. "Shouldn't get here"!
----- Method: VariableNode>>type (in category 'testing') -----
type
"This code attempts to reconstruct the type from its encoding in code.
This allows one to test, for instance, (aNode type = LdInstType)."
| type |
self code < 0 ifTrue: [^ self code negated].
self code < 256 ifFalse: [^ self code // 256].
type _ CodeBases findFirst: [:one | self code < one].
type = 0
ifTrue: [^ 5]
ifFalse: [^ type - 1]!
ParseNode subclass: #MessageNode
instanceVariableNames: 'receiver selector precedence special arguments sizes equalNode caseErrorNode'
classVariableNames: 'MacroEmitters ThenFlag MacroPrinters MacroSelectors MacroTransformers MacroSizers StdTypers'
poolDictionaries: ''
category: 'Compiler-ParseNodes'!
!MessageNode commentStamp: '<historical>' prior: 0!
I represent a receiver and its message.
Precedence codes:
1 unary
2 binary
3 keyword
4 other
If special>0, I compile special code in-line instead of sending messages with literal methods as remotely copied contexts.!
MessageNode subclass: #MessageAsTempNode
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Compiler-ParseNodes'!
!MessageAsTempNode commentStamp: '<historical>' prior: 0!
This node represents accesses to temporary variables for do-its in the debugger. Since they execute in another context, they must send a message to the original context to access the value of the temporary variable in that context.!
----- Method: MessageAsTempNode>>asStorableNode: (in category 'access to remote temps') -----
asStorableNode: encoder
"This node is a message masquerading as a temporary variable.
It currently has the form {homeContext tempAt: offset}.
We need to generate code for {expr storeAt: offset inTempFrame: homeContext},
where the expr, the block argument, is already on the stack.
This, in turn will get turned into {homeContext tempAt: offset put: expr}
at runtime if nobody disturbs storeAt:inTempFrame: in Object (not clean)"
^ MessageAsTempNode new
receiver: nil "suppress code generation for reciever already on stack"
selector: #storeAt:inTempFrame:
arguments: (arguments copyWith: receiver)
precedence: precedence
from: encoder!
----- Method: MessageAsTempNode>>code (in category 'access to remote temps') -----
code
"Allow synthetic temp nodes to be sorted by code"
^ arguments first literalValue!
----- Method: MessageAsTempNode>>emitStorePop:on: (in category 'access to remote temps') -----
emitStorePop: stack on: codeStream
"This node has the form {expr storeAt: offset inTempFrame: homeContext},
where the expr, the block argument, is already on the stack."
^ self emitForEffect: stack on: codeStream!
----- Method: MessageAsTempNode>>isTemp (in category 'access to remote temps') -----
isTemp
"Masquerading for debugger access to temps."
^ true!
----- Method: MessageAsTempNode>>nowHasDef (in category 'access to remote temps') -----
nowHasDef
"For compatibility with temp scope protocol"
!
----- Method: MessageAsTempNode>>nowHasRef (in category 'access to remote temps') -----
nowHasRef
"For compatibility with temp scope protocol"
!
----- Method: MessageAsTempNode>>scope (in category 'access to remote temps') -----
scope
"For compatibility with temp scope protocol"
^ -1!
----- Method: MessageAsTempNode>>scope: (in category 'access to remote temps') -----
scope: ignored
"For compatibility with temp scope protocol"
!
----- Method: MessageAsTempNode>>sizeForStorePop: (in category 'access to remote temps') -----
sizeForStorePop: encoder
"This node has the form {expr storeAt: offset inTempFrame: homeContext},
where the expr, the block argument, is already on the stack."
^ self sizeForEffect: encoder!
----- Method: MessageAsTempNode>>store:from: (in category 'access to remote temps') -----
store: expr from: encoder
"ctxt tempAt: n -> ctxt tempAt: n put: expr (see Assignment).
For assigning into temps of a context being debugged."
selector key ~= #tempAt:
ifTrue: [^self error: 'cant transform this message'].
^ MessageAsTempNode new
receiver: receiver
selector: #tempAt:put:
arguments: (arguments copyWith: expr)
precedence: precedence
from: encoder!
----- Method: MessageNode class>>initialize (in category 'class initialization') -----
initialize "MessageNode initialize"
MacroSelectors _
#(ifTrue: ifFalse: ifTrue:ifFalse: ifFalse:ifTrue:
and: or:
whileFalse: whileTrue: whileFalse whileTrue
to:do: to:by:do:
caseOf: caseOf:otherwise:
ifNil: ifNotNil: ifNil:ifNotNil: ifNotNil:ifNil:).
MacroTransformers _
#(transformIfTrue: transformIfFalse: transformIfTrueIfFalse: transformIfFalseIfTrue:
transformAnd: transformOr:
transformWhile: transformWhile: transformWhile: transformWhile:
transformToDo: transformToDo:
transformCase: transformCase:
transformIfNil: transformIfNil: transformIfNilIfNotNil: transformIfNotNilIfNil:).
MacroEmitters _
#(emitIf:on:value: emitIf:on:value: emitIf:on:value: emitIf:on:value:
emitIf:on:value: emitIf:on:value:
emitWhile:on:value: emitWhile:on:value: emitWhile:on:value: emitWhile:on:value:
emitToDo:on:value: emitToDo:on:value:
emitCase:on:value: emitCase:on:value:
emitIfNil:on:value: emitIfNil:on:value: emitIf:on:value: emitIf:on:value:).
MacroSizers _
#(sizeIf:value: sizeIf:value: sizeIf:value: sizeIf:value:
sizeIf:value: sizeIf:value:
sizeWhile:value: sizeWhile:value: sizeWhile:value: sizeWhile:value:
sizeToDo:value: sizeToDo:value:
sizeCase:value: sizeCase:value:
sizeIfNil:value: sizeIfNil:value: sizeIf:value: sizeIf:value: ).
MacroPrinters _
#(printIfOn:indent: printIfOn:indent: printIfOn:indent: printIfOn:indent:
printIfOn:indent: printIfOn:indent:
printWhileOn:indent: printWhileOn:indent: printWhileOn:indent: printWhileOn:indent:
printToDoOn:indent: printToDoOn:indent:
printCaseOn:indent: printCaseOn:indent:
printIfNil:indent: printIfNil:indent: printIfNilNotNil:indent: printIfNilNotNil:indent:)!
----- Method: MessageNode>>arguments (in category 'equation translation') -----
arguments
^arguments!
----- Method: MessageNode>>arguments: (in category 'equation translation') -----
arguments: list
arguments _ list!
----- Method: MessageNode>>asMorphicCaseOn:indent: (in category 'printing') -----
asMorphicCaseOn: parent indent: ignored
"receiver caseOf: {[key]->[value]. ...} otherwise: [otherwise]"
| braceNode otherwise |
braceNode _ arguments first.
otherwise _ arguments last.
((arguments size = 1) or: [otherwise isJustCaseError]) ifTrue: [
self morphFromKeywords: #caseOf: arguments: {braceNode} on: parent indent: nil.
^parent
].
self morphFromKeywords: #caseOf:otherwise: arguments: arguments on: parent indent: nil.
^parent
!
----- Method: MessageNode>>canCascade (in category 'testing') -----
canCascade
^(receiver == NodeSuper or: [special > 0]) not!
----- Method: MessageNode>>cascadeReceiver (in category 'cascading') -----
cascadeReceiver
"Nil out rcvr (to indicate cascade) and return what it had been."
| rcvr |
rcvr _ receiver.
receiver _ nil.
^rcvr!
----- Method: MessageNode>>checkBlock:as:from: (in category 'private') -----
checkBlock: node as: nodeName from: encoder
node canBeSpecialArgument ifTrue: [^node isMemberOf: BlockNode].
((node isKindOf: BlockNode) and: [node numberOfArguments > 0])
ifTrue: [^encoder notify: '<- ', nodeName , ' of ' ,
(MacroSelectors at: special) , ' must be a 0-argument block']
ifFalse: [^encoder notify: '<- ', nodeName , ' of ' ,
(MacroSelectors at: special) , ' must be a block or variable']!
----- Method: MessageNode>>emitCase:on:value: (in category 'code generation') -----
emitCase: stack on: strm value: forValue
| braceNode sizeStream thenSize elseSize |
forValue not
ifTrue: [^super emitForEffect: stack on: strm].
braceNode _ arguments first.
sizeStream _ ReadStream on: sizes.
receiver emitForValue: stack on: strm.
braceNode casesForwardDo:
[:keyNode :valueNode :last |
thenSize _ sizeStream next.
elseSize _ sizeStream next.
last ifFalse: [strm nextPut: Dup. stack push: 1].
keyNode emitForEvaluatedValue: stack on: strm.
equalNode emit: stack args: 1 on: strm.
self emitBranchOn: false dist: thenSize pop: stack on: strm.
last ifFalse: [strm nextPut: Pop. stack pop: 1].
valueNode emitForEvaluatedValue: stack on: strm.
last ifTrue: [stack pop: 1].
valueNode returns ifFalse: [self emitJump: elseSize on: strm]].
arguments size = 2
ifTrue:
[arguments last emitForEvaluatedValue: stack on: strm] "otherwise: [...]"
ifFalse:
[NodeSelf emitForValue: stack on: strm.
caseErrorNode emit: stack args: 0 on: strm]!
----- Method: MessageNode>>emitForEffect:on: (in category 'code generation') -----
emitForEffect: stack on: strm
"For #ifTrue:ifFalse: and #whileTrue: / #whileFalse: style messages, the pc is set to the jump instruction, so that mustBeBoolean exceptions can be shown correctly."
special > 0
ifTrue:
[pc _ 0.
self perform: (MacroEmitters at: special) with: stack with: strm with: false]
ifFalse:
[super emitForEffect: stack on: strm]!
----- Method: MessageNode>>emitForValue:on: (in category 'code generation') -----
emitForValue: stack on: strm
"For #ifTrue:ifFalse: and #whileTrue: / #whileFalse: style messages, the pc is set to the jump instruction, so that mustBeBoolean exceptions can be shown correctly."
special > 0
ifTrue:
[pc _ 0.
self perform: (MacroEmitters at: special) with: stack with: strm with: true]
ifFalse:
[receiver ~~ nil ifTrue: [receiver emitForValue: stack on: strm].
arguments do: [:argument | argument emitForValue: stack on: strm].
selector
emit: stack
args: arguments size
on: strm
super: receiver == NodeSuper.
pc _ strm position]!
----- Method: MessageNode>>emitIf:on:value: (in category 'code generation') -----
emitIf: stack on: strm value: forValue
| thenExpr thenSize elseExpr elseSize |
thenSize _ sizes at: 1.
elseSize _ sizes at: 2.
(forValue not and: [(elseSize*thenSize) > 0])
ifTrue: "Two-armed IFs forEffect share a single pop"
[^ super emitForEffect: stack on: strm].
thenExpr _ arguments at: 1.
elseExpr _ arguments at: 2.
receiver emitForValue: stack on: strm.
forValue
ifTrue: "Code all forValue as two-armed"
[self emitBranchOn: false dist: thenSize pop: stack on: strm.
pc _ strm position.
thenExpr emitForEvaluatedValue: stack on: strm.
stack pop: 1. "then and else alternate; they don't accumulate"
thenExpr returns not
ifTrue: "Elide jump over else after a return"
[self emitJump: elseSize on: strm].
elseExpr emitForEvaluatedValue: stack on: strm]
ifFalse: "One arm is empty here (two-arms code forValue)"
[thenSize > 0
ifTrue:
[self emitBranchOn: false dist: thenSize pop: stack on: strm.
pc _ strm position.
thenExpr emitForEvaluatedEffect: stack on: strm]
ifFalse:
[self emitBranchOn: true dist: elseSize pop: stack on: strm.
pc _ strm position.
elseExpr emitForEvaluatedEffect: stack on: strm]]!
----- Method: MessageNode>>emitIfNil:on:value: (in category 'code generation') -----
emitIfNil: stack on: strm value: forValue
| theNode theSize theSelector |
theNode _ arguments first.
theSize _ sizes at: 1.
theSelector _ #ifNotNil:.
receiver emitForValue: stack on: strm.
forValue ifTrue: [strm nextPut: Dup. stack push: 1].
strm nextPut: LdNil. stack push: 1.
equalNode emit: stack args: 1 on: strm.
self
emitBranchOn: (selector key == theSelector)
dist: theSize
pop: stack
on: strm.
pc _ strm position.
forValue
ifTrue:
[strm nextPut: Pop. stack pop: 1.
theNode emitForEvaluatedValue: stack on: strm]
ifFalse: [theNode emitForEvaluatedEffect: stack on: strm].!
----- Method: MessageNode>>emitToDo:on:value: (in category 'code generation') -----
emitToDo: stack on: strm value: forValue
" var _ rcvr. L1: [var <= arg1] Bfp(L2) [block body. var _ var + inc] Jmp(L1) L2: "
| loopSize initStmt limitInit test block incStmt blockSize |
initStmt _ arguments at: 4.
limitInit _ arguments at: 7.
test _ arguments at: 5.
block _ arguments at: 3.
incStmt _ arguments at: 6.
blockSize _ sizes at: 1.
loopSize _ sizes at: 2.
limitInit == nil
ifFalse: [limitInit emitForEffect: stack on: strm].
initStmt emitForEffect: stack on: strm.
test emitForValue: stack on: strm.
self emitBranchOn: false dist: blockSize pop: stack on: strm.
pc _ strm position.
block emitForEvaluatedEffect: stack on: strm.
incStmt emitForEffect: stack on: strm.
self emitJump: 0 - loopSize on: strm.
forValue ifTrue: [strm nextPut: LdNil. stack push: 1]!
----- Method: MessageNode>>emitWhile:on:value: (in category 'code generation') -----
emitWhile: stack on: strm value: forValue
" L1: ... Bfp(L2)|Btp(L2) ... Jmp(L1) L2: "
| cond stmt stmtSize loopSize |
cond _ receiver.
stmt _ arguments at: 1.
stmtSize _ sizes at: 1.
loopSize _ sizes at: 2.
cond emitForEvaluatedValue: stack on: strm.
self emitBranchOn: (selector key == #whileFalse:) "Bfp for whileTrue"
dist: stmtSize pop: stack on: strm. "Btp for whileFalse"
pc _ strm position.
stmt emitForEvaluatedEffect: stack on: strm.
self emitJump: 0 - loopSize on: strm.
forValue ifTrue: [strm nextPut: LdNil. stack push: 1]!
----- Method: MessageNode>>eval (in category 'equation translation') -----
eval
"When everything in me is a constant, I can produce a value. This is only used by the Scripting system (TilePadMorph tilesFrom:in:)"
| rec args |
(receiver isKindOf: VariableNode) ifFalse: [^ #illegal].
rec _ receiver key value.
args _ arguments collect: [:each | each eval].
^ rec perform: selector key withArguments: args!
----- Method: MessageNode>>ifNilReceiver (in category 'private') -----
ifNilReceiver
^receiver!
----- Method: MessageNode>>isComplex (in category 'testing') -----
isComplex
^(special between: 1 and: 10) or: [arguments size > 2 or: [receiver isComplex]]!
----- Method: MessageNode>>isMessage (in category 'testing') -----
isMessage
^true!
----- Method: MessageNode>>isMessage:receiver:arguments: (in category 'testing') -----
isMessage: selSymbol receiver: rcvrPred arguments: argsPred
"Answer whether selector is selSymbol, and the predicates rcvrPred and argsPred
evaluate to true with respect to receiver and the list of arguments. If selSymbol or
either predicate is nil, it means 'don't care'. Note that argsPred takes numArgs
arguments. All block arguments are ParseNodes."
^(selSymbol isNil or: [selSymbol==selector key]) and:
[(rcvrPred isNil or: [rcvrPred value: receiver]) and:
[(argsPred isNil or: [argsPred valueWithArguments: arguments])]]!
----- Method: MessageNode>>isReturningIf (in category 'testing') -----
isReturningIf
^(special between: 3 and: 4)
and: [arguments first returns and: [arguments last returns]]!
----- Method: MessageNode>>macroPrinter (in category 'printing') -----
macroPrinter
special > 0 ifTrue: [^MacroPrinters at: special].
^nil
!
----- Method: MessageNode>>morphFromKeywords:arguments:on:indent: (in category 'tiles') -----
morphFromKeywords: key arguments: args on: parent indent: ignored
^parent
messageNode: self
receiver: receiver
selector: selector
keywords: key
arguments: args
!
----- Method: MessageNode>>noteSpecialSelector: (in category 'macro transformations') -----
noteSpecialSelector: selectorSymbol
" special > 0 denotes specially treated messages. "
"Deconvert initial keywords from SQ2K"
special _ #(:Test:Yes: :Test:No: :Test:Yes:No: :Test:No:Yes:
and: or:
:Until:do: :While:do: whileFalse whileTrue
:Repeat:to:do: :Repeat:to:by:do:
) indexOf: selectorSymbol.
special > 0 ifTrue: [^ self].
special _ MacroSelectors indexOf: selectorSymbol.
!
----- Method: MessageNode>>precedence (in category 'printing') -----
precedence
^precedence!
----- Method: MessageNode>>printCaseOn:indent: (in category 'printing') -----
printCaseOn: aStream indent: level
"receiver caseOf: {[key]->[value]. ...} otherwise: [otherwise]"
| braceNode otherwise extra |
braceNode _ arguments first.
otherwise _ arguments last.
(arguments size = 1 or: [otherwise isJustCaseError])
ifTrue: [otherwise _ nil].
receiver
printOn: aStream
indent: level
precedence: 3.
aStream nextPutAll: ' caseOf: '.
braceNode isVariableReference ifTrue: [braceNode printOn: aStream indent: level]
ifFalse:
[aStream nextPutAll: '{';
crtab: level + 1.
braceNode
casesForwardDo:
[:keyNode :valueNode :last |
keyNode printOn: aStream indent: level + 1.
aStream nextPutAll: ' -> '.
valueNode isComplex
ifTrue:
[aStream crtab: level + 2.
extra _ 1]
ifFalse: [extra _ 0].
valueNode printOn: aStream indent: level + 1 + extra.
last ifTrue: [aStream nextPut: $}]
ifFalse: [aStream nextPut: $.;
crtab: level + 1]]].
otherwise isNil
ifFalse:
[aStream crtab: level + 1;
nextPutAll: ' otherwise: '.
otherwise isComplex
ifTrue:
[aStream crtab: level + 2.
extra _ 1]
ifFalse: [extra _ 0].
otherwise printOn: aStream indent: level + 1 + extra.]!
----- Method: MessageNode>>printIfNil:indent: (in category 'printing') -----
printIfNil: aStream indent: level
self printReceiver: receiver on: aStream indent: level.
^self printKeywords: selector key
arguments: (Array with: arguments first)
on: aStream indent: level!
----- Method: MessageNode>>printIfNilNotNil:indent: (in category 'printing') -----
printIfNilNotNil: aStream indent: level
self printReceiver: receiver ifNilReceiver on: aStream indent: level.
(arguments first isJust: NodeNil) ifTrue:
[^ self printKeywords: #ifNotNil:
arguments: { arguments second }
on: aStream indent: level].
(arguments second isJust: NodeNil) ifTrue:
[^ self printKeywords: #ifNil:
arguments: { arguments first }
on: aStream indent: level].
^ self printKeywords: #ifNil:ifNotNil:
arguments: arguments
on: aStream indent: level!
----- Method: MessageNode>>printIfOn:indent: (in category 'printing') -----
printIfOn: aStream indent: level
receiver ifNotNil: [
receiver printOn: aStream indent: level + 1 precedence: precedence.
].
(arguments last isJust: NodeNil) ifTrue:
[^ self printKeywords: #ifTrue: arguments: (Array with: arguments first)
on: aStream indent: level].
(arguments last isJust: NodeFalse) ifTrue:
[^ self printKeywords: #and: arguments: (Array with: arguments first)
on: aStream indent: level].
(arguments first isJust: NodeNil) ifTrue:
[^ self printKeywords: #ifFalse: arguments: (Array with: arguments last)
on: aStream indent: level].
(arguments first isJust: NodeTrue) ifTrue:
[^ self printKeywords: #or: arguments: (Array with: arguments last)
on: aStream indent: level].
self printKeywords: #ifTrue:ifFalse: arguments: arguments
on: aStream indent: level!
----- Method: MessageNode>>printKeywords:arguments:on:indent: (in category 'printing') -----
printKeywords: key arguments: args on: aStream indent: level
^ self printKeywords: key arguments: args on: aStream indent: level prefix: false
!
----- Method: MessageNode>>printKeywords:arguments:on:indent:prefix: (in category 'printing') -----
printKeywords: key arguments: args on: aStream indent: level prefix: isPrefix
| keywords indent arg kwd doCrTab |
args size = 0 ifTrue: [aStream space; nextPutAll: key. ^ self].
keywords _ key keywords.
doCrTab _ args size > 2 or:
[{receiver} , args
inject: false
into: [:was :thisArg |
was or: [(thisArg isKindOf: BlockNode)
or: [(thisArg isKindOf: MessageNode) and: [thisArg precedence >= 3]]]]].
1 to: (args size min: keywords size) do:
[:i | arg _ args at: i. kwd _ keywords at: i.
doCrTab
ifTrue: [aStream crtab: level+1. indent _ 1] "newline after big args"
ifFalse: [aStream space. indent _ 0].
aStream nextPutAll: kwd; space.
arg printOn: aStream indent: level + 1 + indent
precedence: (precedence = 2 ifTrue: [1] ifFalse: [precedence]).
]!
----- Method: MessageNode>>printOn:indent: (in category 'printing') -----
printOn: aStream indent: level
| leadingKeyword |
"may not need this check anymore - may be fixed by the #receiver: change"
special ifNil: [^aStream nextPutAll: '** MessageNode with nil special **'].
(special > 0)
ifTrue: [self perform: self macroPrinter with: aStream with: level]
ifFalse: [selector key first = $:
ifTrue: [leadingKeyword _ selector key keywords first.
aStream nextPutAll: leadingKeyword; space.
self printReceiver: receiver on: aStream indent: level.
self printKeywords: (selector key allButFirst: leadingKeyword size + 1) arguments: arguments
on: aStream indent: level]
ifFalse: [self printReceiver: receiver on: aStream indent: level.
self printKeywords: selector key arguments: arguments
on: aStream indent: level]]!
----- Method: MessageNode>>printOn:indent:precedence: (in category 'printing') -----
printOn: strm indent: level precedence: outerPrecedence
| parenthesize |
parenthesize _ precedence > outerPrecedence
or: [outerPrecedence = 3 and: [precedence = 3 "both keywords"]].
parenthesize
ifTrue: [strm nextPutAll: '('.
self printOn: strm indent: level.
strm nextPutAll: ')']
ifFalse: [self printOn: strm indent: level]!
----- Method: MessageNode>>printParenReceiver:on:indent: (in category 'printing') -----
printParenReceiver: rcvr on: aStream indent: level
(rcvr isKindOf: BlockNode) ifTrue:
[^ rcvr printOn: aStream indent: level].
aStream nextPutAll: '('.
rcvr printOn: aStream indent: level.
aStream nextPutAll: ')'
!
----- Method: MessageNode>>printReceiver:on:indent: (in category 'printing') -----
printReceiver: rcvr on: aStream indent: level
rcvr ifNil: [^ self].
"Force parens around keyword receiver of kwd message"
rcvr printOn: aStream indent: level precedence: precedence.
!
----- Method: MessageNode>>printToDoOn:indent: (in category 'printing') -----
printToDoOn: aStream indent: level
| limitNode |
self printReceiver: receiver on: aStream indent: level.
(arguments last == nil or: [(arguments last isMemberOf: AssignmentNode) not])
ifTrue: [limitNode _ arguments first]
ifFalse: [limitNode _ arguments last value].
(selector key = #to:by:do:
and: [(arguments at: 2) isConstantNumber
and: [(arguments at: 2) key = 1]])
ifTrue: [self printKeywords: #to:do:
arguments: (Array with: limitNode with: (arguments at: 3))
on: aStream indent: level prefix: true]
ifFalse: [self printKeywords: selector key
arguments: (Array with: limitNode) , arguments allButFirst
on: aStream indent: level prefix: true]!
----- Method: MessageNode>>printWhileOn:indent: (in category 'printing') -----
printWhileOn: aStream indent: level
self printReceiver: receiver on: aStream indent: level.
(arguments isEmpty not and: [ arguments first isJust: NodeNil]) ifTrue:
[selector _ SelectorNode new
key: (selector key == #whileTrue:
ifTrue: [#whileTrue] ifFalse: [#whileFalse])
code: #macro.
arguments _ Array new].
self printKeywords: selector key arguments: arguments
on: aStream indent: level.!
----- Method: MessageNode>>pvtCheckForPvtSelector: (in category 'private') -----
pvtCheckForPvtSelector: encoder
"If the code being compiled is trying to send a private message (e.g. 'pvtCheckForPvtSelector:') to anyone other than self, then complain to encoder."
selector isPvtSelector ifTrue:
[receiver isSelfPseudoVariable ifFalse:
[encoder notify: 'Private messages may only be sent to self']].!
----- Method: MessageNode>>receiver (in category 'equation translation') -----
receiver
^receiver!
----- Method: MessageNode>>receiver: (in category 'equation translation') -----
receiver: val
"14 feb 2001 - removed return arrow"
receiver _ val!
----- Method: MessageNode>>receiver:arguments:precedence: (in category 'private') -----
receiver: rcvr arguments: args precedence: p
receiver _ rcvr.
arguments _ args.
sizes _ Array new: arguments size.
precedence _ p!
----- Method: MessageNode>>receiver:selector:arguments:precedence: (in category 'initialize-release') -----
receiver: rcvr selector: selNode arguments: args precedence: p
"Decompile."
self receiver: rcvr
arguments: args
precedence: p.
self noteSpecialSelector: selNode key.
selector _ selNode.
"self pvtCheckForPvtSelector: encoder"
"We could test code being decompiled, but the compiler should've checked already. And where to send the complaint?"!
----- Method: MessageNode>>receiver:selector:arguments:precedence:from: (in category 'initialize-release') -----
receiver: rcvr selector: aSelector arguments: args precedence: p from: encoder
"Compile."
| theSelector |
self receiver: rcvr
arguments: args
precedence: p.
aSelector = #':Repeat:do:'
ifTrue: [theSelector _ #do:]
ifFalse: [theSelector _ aSelector].
self noteSpecialSelector: theSelector.
(self transform: encoder)
ifTrue:
[selector isNil
ifTrue: [selector _ SelectorNode new
key: (MacroSelectors at: special)
code: #macro]]
ifFalse:
[selector _ encoder encodeSelector: theSelector.
rcvr == NodeSuper ifTrue: [encoder noteSuper]].
self pvtCheckForPvtSelector: encoder!
----- Method: MessageNode>>receiver:selector:arguments:precedence:from:sourceRange: (in category 'initialize-release') -----
receiver: rcvr selector: selName arguments: args precedence: p from: encoder sourceRange: range
"Compile."
encoder noteSourceRange: range forNode: self.
^self
receiver: rcvr
selector: selName
arguments: args
precedence: p
from: encoder!
----- Method: MessageNode>>selector (in category 'equation translation') -----
selector
^selector!
----- Method: MessageNode>>selector: (in category 'initialize-release') -----
selector: sel
selector _ sel!
----- Method: MessageNode>>sizeCase:value: (in category 'code generation') -----
sizeCase: encoder value: forValue
| braceNode sizeIndex thenSize elseSize |
forValue not
ifTrue: [^super sizeForEffect: encoder].
equalNode _ encoder encodeSelector: #=.
braceNode _ arguments first.
sizes _ Array new: 2 * braceNode numElements.
sizeIndex _ sizes size.
elseSize _ arguments size = 2
ifTrue:
[arguments last sizeForEvaluatedValue: encoder] "otherwise: [...]"
ifFalse:
[caseErrorNode _ encoder encodeSelector: #caseError.
1 + (caseErrorNode size: encoder args: 0 super: false)]. "self caseError"
braceNode casesReverseDo:
[:keyNode :valueNode :last |
sizes at: sizeIndex put: elseSize.
thenSize _ valueNode sizeForEvaluatedValue: encoder.
last ifFalse: [thenSize _ thenSize + 1]. "Pop"
valueNode returns ifFalse: [thenSize _ thenSize + (self sizeJump: elseSize)].
sizes at: sizeIndex-1 put: thenSize.
last ifFalse: [elseSize _ elseSize + 1]. "Dup"
elseSize _ elseSize + (keyNode sizeForEvaluatedValue: encoder) +
(equalNode size: encoder args: 1 super: false) +
(self sizeBranchOn: false dist: thenSize) + thenSize.
sizeIndex _ sizeIndex - 2].
^(receiver sizeForValue: encoder) + elseSize
!
----- Method: MessageNode>>sizeForEffect: (in category 'code generation') -----
sizeForEffect: encoder
special > 0
ifTrue: [^self perform: (MacroSizers at: special) with: encoder with: false].
^super sizeForEffect: encoder!
----- Method: MessageNode>>sizeForValue: (in category 'code generation') -----
sizeForValue: encoder
| total argSize |
special > 0
ifTrue: [^self perform: (MacroSizers at: special) with: encoder with: true].
receiver == NodeSuper
ifTrue: [selector _ selector copy "only necess for splOops"].
total _ selector size: encoder args: arguments size super: receiver == NodeSuper.
receiver == nil
ifFalse: [total _ total + (receiver sizeForValue: encoder)].
sizes _ arguments collect:
[:arg |
argSize _ arg sizeForValue: encoder.
total _ total + argSize.
argSize].
^total!
----- Method: MessageNode>>sizeIf:value: (in category 'code generation') -----
sizeIf: encoder value: forValue
| thenExpr elseExpr branchSize thenSize elseSize |
thenExpr _ arguments at: 1.
elseExpr _ arguments at: 2.
(forValue
or: [(thenExpr isJust: NodeNil)
or: [elseExpr isJust: NodeNil]]) not
"(...not ifTrue: avoids using ifFalse: alone during this compile)"
ifTrue: "Two-armed IFs forEffect share a single pop"
[^ super sizeForEffect: encoder].
forValue
ifTrue: "Code all forValue as two-armed"
[elseSize _ elseExpr sizeForEvaluatedValue: encoder.
thenSize _ (thenExpr sizeForEvaluatedValue: encoder)
+ (thenExpr returns
ifTrue: [0] "Elide jump over else after a return"
ifFalse: [self sizeJump: elseSize]).
branchSize _ self sizeBranchOn: false dist: thenSize]
ifFalse: "One arm is empty here (two-arms code forValue)"
[(elseExpr isJust: NodeNil)
ifTrue:
[elseSize _ 0.
thenSize _ thenExpr sizeForEvaluatedEffect: encoder.
branchSize _ self sizeBranchOn: false dist: thenSize]
ifFalse:
[thenSize _ 0.
elseSize _ elseExpr sizeForEvaluatedEffect: encoder.
branchSize _ self sizeBranchOn: true dist: elseSize]].
sizes _ Array with: thenSize with: elseSize.
^ (receiver sizeForValue: encoder) + branchSize
+ thenSize + elseSize!
----- Method: MessageNode>>sizeIfNil:value: (in category 'code generation') -----
sizeIfNil: encoder value: forValue
| theNode theSize theSelector |
equalNode _ encoder encodeSelector: #==.
sizes _ Array new: 1.
theNode _ arguments first.
theSelector _ #ifNotNil:.
forValue
ifTrue:
[sizes at: 1 put: (theSize _ (1 "pop" + (theNode sizeForEvaluatedValue: encoder))).
^(receiver sizeForValue: encoder) +
2 "Dup. LdNil" +
(equalNode size: encoder args: 1 super: false) +
(self
sizeBranchOn: (selector key == theSelector)
dist: theSize) +
theSize]
ifFalse:
[sizes at: 1 put: (theSize _ (theNode sizeForEvaluatedEffect: encoder)).
^(receiver sizeForValue: encoder) +
1 "LdNil" +
(equalNode size: encoder args: 1 super: false) +
(self
sizeBranchOn: (selector key == theSelector)
dist: theSize) +
theSize]
!
----- Method: MessageNode>>sizeToDo:value: (in category 'code generation') -----
sizeToDo: encoder value: forValue
" var _ rcvr. L1: [var <= arg1] Bfp(L2) [block body. var _ var + inc] Jmp(L1) L2: "
| loopSize initStmt test block incStmt blockSize blockVar initSize limitInit |
block _ arguments at: 3.
blockVar _ block firstArgument.
initStmt _ arguments at: 4.
test _ arguments at: 5.
incStmt _ arguments at: 6.
limitInit _ arguments at: 7.
initSize _ initStmt sizeForEffect: encoder.
limitInit == nil
ifFalse: [initSize _ initSize + (limitInit sizeForEffect: encoder)].
blockSize _ (block sizeForEvaluatedEffect: encoder)
+ (incStmt sizeForEffect: encoder) + 2. "+2 for Jmp backward"
loopSize _ (test sizeForValue: encoder)
+ (self sizeBranchOn: false dist: blockSize)
+ blockSize.
sizes _ Array with: blockSize with: loopSize.
^ initSize + loopSize
+ (forValue ifTrue: [1] ifFalse: [0]) " +1 for value (push nil) "!
----- Method: MessageNode>>sizeWhile:value: (in category 'code generation') -----
sizeWhile: encoder value: forValue
"L1: ... Bfp(L2) ... Jmp(L1) L2: nil (nil for value only);
justStmt, wholeLoop, justJump."
| cond stmt stmtSize loopSize branchSize |
cond _ receiver.
stmt _ arguments at: 1.
stmtSize _ (stmt sizeForEvaluatedEffect: encoder) + 2.
branchSize _ self sizeBranchOn: (selector key == #whileFalse:) "Btp for whileFalse"
dist: stmtSize.
loopSize _ (cond sizeForEvaluatedValue: encoder)
+ branchSize + stmtSize.
sizes _ Array with: stmtSize with: loopSize.
^ loopSize " +1 for value (push nil) "
+ (forValue ifTrue: [1] ifFalse: [0])!
----- Method: MessageNode>>test (in category 'printing') -----
test
3 > 4 ifTrue: [4+5 between: 6 and: 7]
ifFalse: [4 between: 6+5 and: 7-2]!
----- Method: MessageNode>>toDoFromWhileWithInit: (in category 'macro transformations') -----
toDoFromWhileWithInit: initStmt
"Return nil, or a to:do: expression equivalent to this whileTrue:"
| variable increment limit toDoBlock body test |
(selector key == #whileTrue:
and: [(initStmt isMemberOf: AssignmentNode) and:
[initStmt variable isTemp]])
ifFalse: [^ nil].
body _ arguments last statements.
variable _ initStmt variable.
increment _ body last toDoIncrement: variable.
(increment == nil or: [receiver statements size ~= 1])
ifTrue: [^ nil].
test _ receiver statements first.
"Note: test chould really be checked that <= or >= comparison
jibes with the sign of the (constant) increment"
((test isMemberOf: MessageNode)
and: [(limit _ test toDoLimit: variable) notNil])
ifFalse: [^ nil].
toDoBlock _ BlockNode statements: body allButLast returns: false.
toDoBlock arguments: (Array with: variable).
^ MessageNode new
receiver: initStmt value
selector: (SelectorNode new key: #to:by:do: code: #macro)
arguments: (Array with: limit with: increment with: toDoBlock)
precedence: precedence!
----- Method: MessageNode>>toDoIncrement: (in category 'testing') -----
toDoIncrement: variable
(receiver = variable and: [selector key = #+])
ifFalse: [^ nil].
arguments first isConstantNumber
ifTrue: [^ arguments first]
ifFalse: [^ nil]!
----- Method: MessageNode>>toDoLimit: (in category 'testing') -----
toDoLimit: variable
(receiver = variable and: [selector key = #<= or: [selector key = #>=]])
ifTrue: [^ arguments first]
ifFalse: [^ nil]!
----- Method: MessageNode>>transform: (in category 'macro transformations') -----
transform: encoder
special = 0 ifTrue: [^false].
(self perform: (MacroTransformers at: special) with: encoder)
ifTrue:
[^true]
ifFalse:
[special _ 0. ^false]!
----- Method: MessageNode>>transformAnd: (in category 'macro transformations') -----
transformAnd: encoder
(self transformBoolean: encoder)
ifTrue:
[arguments _
Array
with: (arguments at: 1)
with: (BlockNode withJust: NodeFalse).
^true]
ifFalse:
[^false]!
----- Method: MessageNode>>transformBoolean: (in category 'macro transformations') -----
transformBoolean: encoder
^self
checkBlock: (arguments at: 1)
as: 'argument'
from: encoder!
----- Method: MessageNode>>transformCase: (in category 'private') -----
transformCase: encoder
| caseNode |
caseNode _ arguments first.
(caseNode isKindOf: BraceNode)
ifTrue:
[^(caseNode blockAssociationCheck: encoder) and:
[arguments size = 1 or:
[self checkBlock: arguments last as: 'otherwise arg' from: encoder]]].
(caseNode canBeSpecialArgument and: [(caseNode isMemberOf: BlockNode) not])
ifTrue:
[^false]. "caseOf: variable"
^encoder notify: 'caseOf: argument must be a brace construct or a variable'!
----- Method: MessageNode>>transformIfFalse: (in category 'macro transformations') -----
transformIfFalse: encoder
(self transformBoolean: encoder)
ifTrue:
[arguments _
Array
with: (BlockNode withJust: NodeNil)
with: (arguments at: 1).
^true]
ifFalse:
[^false]!
----- Method: MessageNode>>transformIfFalseIfTrue: (in category 'macro transformations') -----
transformIfFalseIfTrue: encoder
((self checkBlock: (arguments at: 1) as: 'False arg' from: encoder)
and: [self checkBlock: (arguments at: 2) as: 'True arg' from: encoder])
ifTrue:
[selector _ #ifTrue:ifFalse:.
arguments swap: 1 with: 2.
^true]
ifFalse:
[^false]!
----- Method: MessageNode>>transformIfNil: (in category 'macro transformations') -----
transformIfNil: encoder
(self transformBoolean: encoder) ifFalse: [^ false].
(MacroSelectors at: special) = #ifNotNil:
ifTrue:
[(self checkBlock: arguments first as: 'ifNotNil arg' from: encoder) ifFalse: [^ false].
"Transform 'ifNotNil: [stuff]' to 'ifNil: [nil] ifNotNil: [stuff]'.
Slightly better code and more consistent with decompilation."
self noteSpecialSelector: #ifNil:ifNotNil:.
selector _ SelectorNode new key: (MacroSelectors at: special) code: #macro.
arguments _ {BlockNode withJust: NodeNil. arguments first}.
(self transform: encoder) ifFalse: [self error: 'compiler logic error'].
^ true]
ifFalse:
[^ self checkBlock: arguments first as: 'ifNil arg' from: encoder]
!
----- Method: MessageNode>>transformIfNilIfNotNil: (in category 'macro transformations') -----
transformIfNilIfNotNil: encoder
((self checkBlock: (arguments at: 1) as: 'Nil arg' from: encoder)
and: [self checkBlock: (arguments at: 2) as: 'NotNil arg' from: encoder])
ifTrue:
[selector _ SelectorNode new key: #ifTrue:ifFalse: code: #macro.
receiver _ MessageNode new
receiver: receiver
selector: #==
arguments: (Array with: NodeNil)
precedence: 2
from: encoder.
^true]
ifFalse:
[^false]!
----- Method: MessageNode>>transformIfNotNilIfNil: (in category 'macro transformations') -----
transformIfNotNilIfNil: encoder
((self checkBlock: (arguments at: 1) as: 'NotNil arg' from: encoder)
and: [self checkBlock: (arguments at: 2) as: 'Nil arg' from: encoder])
ifTrue:
[selector _ SelectorNode new key: #ifTrue:ifFalse: code: #macro.
receiver _ MessageNode new
receiver: receiver
selector: #==
arguments: (Array with: NodeNil)
precedence: 2
from: encoder.
arguments swap: 1 with: 2.
^true]
ifFalse:
[^false]!
----- Method: MessageNode>>transformIfTrue: (in category 'macro transformations') -----
transformIfTrue: encoder
(self transformBoolean: encoder)
ifTrue:
[arguments _
Array
with: (arguments at: 1)
with: (BlockNode withJust: NodeNil).
^true]
ifFalse:
[^false]!
----- Method: MessageNode>>transformIfTrueIfFalse: (in category 'macro transformations') -----
transformIfTrueIfFalse: encoder
^(self checkBlock: (arguments at: 1) as: 'True arg' from: encoder)
and: [self checkBlock: (arguments at: 2) as: 'False arg' from: encoder]!
----- Method: MessageNode>>transformOr: (in category 'macro transformations') -----
transformOr: encoder
(self transformBoolean: encoder)
ifTrue:
[arguments _
Array
with: (BlockNode withJust: NodeTrue)
with: (arguments at: 1).
^true]
ifFalse:
[^false]!
----- Method: MessageNode>>transformToDo: (in category 'macro transformations') -----
transformToDo: encoder
" var _ rcvr. L1: [var <= arg1] Bfp(L2) [block body. var _ var + inc]
Jmp(L1) L2: "
| limit increment block initStmt test incStmt limitInit blockVar myRange blockRange |
"First check for valid arguments"
((arguments last isMemberOf: BlockNode)
and: [arguments last numberOfArguments = 1])
ifFalse: [^ false].
arguments last firstArgument isVariableReference
ifFalse: [^ false]. "As with debugger remote vars"
arguments size = 3
ifTrue: [increment _ arguments at: 2.
(increment isConstantNumber and:
[increment literalValue ~= 0]) ifFalse: [^ false]]
ifFalse: [increment _ encoder encodeLiteral: 1].
arguments size < 3 ifTrue: "transform to full form"
[selector _ SelectorNode new key: #to:by:do: code: #macro].
"Now generate auxiliary structures"
myRange _ encoder rawSourceRanges at: self ifAbsent: [1 to: 0].
block _ arguments last.
blockRange _ encoder rawSourceRanges at: block ifAbsent: [1 to: 0].
blockVar _ block firstArgument.
initStmt _ AssignmentNode new variable: blockVar value: receiver.
limit _ arguments at: 1.
limit isVariableReference | limit isConstantNumber
ifTrue: [limitInit _ nil]
ifFalse: "Need to store limit in a var"
[limit _ encoder autoBind: blockVar key , 'LimiT'.
limit scope: -2. "Already done parsing block"
limitInit _ AssignmentNode new
variable: limit
value: (arguments at: 1)].
test _ MessageNode new receiver: blockVar
selector: (increment key > 0 ifTrue: [#<=] ifFalse: [#>=])
arguments: (Array with: limit)
precedence: precedence from: encoder
sourceRange: (myRange first to: blockRange first).
incStmt _ AssignmentNode new
variable: blockVar
value: (MessageNode new
receiver: blockVar selector: #+
arguments: (Array with: increment)
precedence: precedence from: encoder)
from: encoder
sourceRange: (myRange last to: myRange last).
arguments _ (Array with: limit with: increment with: block)
, (Array with: initStmt with: test with: incStmt with: limitInit).
^ true!
----- Method: MessageNode>>transformWhile: (in category 'macro transformations') -----
transformWhile: encoder
(self checkBlock: receiver as: 'receiver' from: encoder)
ifFalse: [^ false].
arguments size = 0 "transform bodyless form to body form"
ifTrue: [selector _ SelectorNode new
key: (special = 10 ifTrue: [#whileTrue:] ifFalse: [#whileFalse:])
code: #macro.
arguments _ Array with: (BlockNode withJust: NodeNil).
^ true]
ifFalse: [^ self transformBoolean: encoder]!
ParseNode subclass: #MethodNode
instanceVariableNames: 'selectorOrFalse precedence arguments block literals primitive encoder temporaries properties sourceText'
classVariableNames: ''
poolDictionaries: ''
category: 'Compiler-ParseNodes'!
!MethodNode commentStamp: '<historical>' prior: 0!
I am the root of the parse tree.!
----- Method: MethodNode>>block (in category 'initialize-release') -----
block
^ block!
----- Method: MethodNode>>body (in category 'accessing') -----
body
^block!
----- Method: MethodNode>>decompileString (in category 'printing') -----
decompileString
"Answer a string description of the parse tree whose root is the receiver."
^ self decompileText asString
!
----- Method: MethodNode>>decompileText (in category 'printing') -----
decompileText
"Answer a text description of the parse tree whose root is the receiver."
^ ColoredCodeStream contents: [:strm | self printOn: strm]!
----- Method: MethodNode>>encoder (in category 'code generation') -----
encoder
^ encoder!
----- Method: MethodNode>>generate (in category 'code generation') -----
generate
"The receiver is the root of a parse tree. Answer a CompiledMethod. The
argument, trailer, is the references to the source code that is stored with
every CompiledMethod."
^self generate: #(0 0 0 0)!
----- Method: MethodNode>>generate: (in category 'code generation') -----
generate: trailer
^self generateWith: trailer using: CompiledMethod!
----- Method: MethodNode>>generate:ifQuick: (in category 'code generation') -----
generate: trailer ifQuick: methodBlock
| v |
(primitive = 0 and: [arguments size = 0 and: [block isQuick]])
ifFalse: [^ self].
v _ block code.
v < 0
ifTrue: [^ self].
v = LdSelf
ifTrue: [^ methodBlock value: (CompiledMethod toReturnSelfTrailerBytes: trailer)].
(v between: LdTrue and: LdMinus1 + 3)
ifTrue: [^ methodBlock value: (CompiledMethod toReturnConstant: v - LdSelf trailerBytes: trailer)].
v < ((CodeBases at: LdInstType) + (CodeLimits at: LdInstType))
ifTrue: [^ methodBlock value: (CompiledMethod toReturnField: v trailerBytes: trailer)].
v // 256 = 1
ifTrue: [^ methodBlock value: (CompiledMethod toReturnField: v \\ 256 trailerBytes: trailer)]!
----- Method: MethodNode>>generateWith:using: (in category 'code generation') -----
generateWith: trailer using: aCompiledMethodClass
"The receiver is the root of a parse tree. Answer a CompiledMethod. The
argument, trailer, is the references to the source code that is stored with
every CompiledMethod."
| blkSize nLits stack strm nArgs method |
self generate: trailer ifQuick:
[:m | method _ m.
method properties: properties.
^ method].
nArgs _ arguments size.
blkSize _ block sizeForEvaluatedValue: encoder.
literals _ encoder allLiterals.
nLits _ literals size.
method _ aCompiledMethodClass "Dummy to allocate right size"
newBytes: blkSize
trailerBytes: trailer
nArgs: nArgs
nTemps: encoder maxTemp
nStack: 0
nLits: nLits
primitive: primitive.
strm _ ReadWriteStream with: method.
strm position: method initialPC - 1.
stack _ ParseStack new init.
block emitForEvaluatedValue: stack on: strm.
stack position ~= 1 ifTrue: [^self error: 'Compiler stack
discrepancy'].
strm position ~= (method size - trailer size)
ifTrue: [^self error: 'Compiler code size discrepancy'].
method needsFrameSize: stack size.
1 to: nLits do: [:lit | method literalAt: lit put: (literals at: lit)].
method properties: properties.
^ method!
----- Method: MethodNode>>methodClass (in category 'printing') -----
methodClass
^ encoder classEncoding!
----- Method: MethodNode>>parserClass (in category 'code generation') -----
parserClass
"Which parser produces this class of parse node"
^ Parser!
----- Method: MethodNode>>printOn: (in category 'printing') -----
printOn: aStream
precedence = 1
ifTrue:
[aStream nextPutAll: self selector]
ifFalse:
[self selector keywords with: arguments do:
[:kwd :arg |
aStream nextPutAll: kwd; space.
aStream withStyleFor: #methodArgument
do: [aStream nextPutAll: arg key].
aStream space]].
comment == nil ifFalse:
[aStream crtab: 1.
self printCommentOn: aStream indent: 1].
temporaries size > 0 ifTrue:
[aStream crtab: 1.
aStream nextPutAll: '|'.
aStream withStyleFor: #temporaryVariable
do: [temporaries do:
[:temp | aStream space; nextPutAll: temp key]].
aStream nextPutAll: ' |'].
properties ifNotNil: [
properties pragmas do: [ :each |
"Don't decompile basic primitives that return self, i-vars, etc."
each keyword = #primitive:
ifFalse: [ aStream crtab: 1. each printOn: aStream ]
ifTrue: [
( (each argumentAt: 1) isNumber and: [(each argumentAt: 1) between: 255 and: 519])
ifFalse: [ aStream crtab: 1. self printPrimitiveOn: aStream ] ] ] ].
aStream crtab: 1.
^ block printStatementsOn: aStream indent: 0!
----- Method: MethodNode>>printPrimitiveOn: (in category 'printing') -----
printPrimitiveOn: aStream
"Print the primitive on aStream"
| primIndex primDecl |
primIndex _ primitive.
primIndex = 0
ifTrue: [^ self].
primIndex = 120
ifTrue: ["External call spec"
^ aStream print: encoder literals first].
aStream nextPutAll: '<primitive: '.
primIndex = 117
ifTrue: [primDecl _ encoder literals at: 1.
aStream nextPut: $';
nextPutAll: (primDecl at: 2);
nextPut: $'.
(primDecl at: 1) notNil
ifTrue: [aStream nextPutAll: ' module:';
nextPut: $';
nextPutAll: (primDecl at: 1);
nextPut: $']]
ifFalse: [aStream print: primIndex].
aStream nextPut: $>.
Smalltalk at: #Interpreter ifPresent:[:cls|
aStream nextPutAll: ' "'
, ((cls classPool at: #PrimitiveTable)
at: primIndex + 1) , '" '].!
----- Method: MethodNode>>properties (in category 'code generation') -----
properties
^ properties!
----- Method: MethodNode>>rawSourceRanges (in category 'tiles') -----
rawSourceRanges
self generate.
^encoder rawSourceRanges!
----- Method: MethodNode>>selector (in category 'code generation') -----
selector
"Answer the message selector for the method represented by the receiver."
(selectorOrFalse isSymbol)
ifTrue: [^selectorOrFalse].
^selectorOrFalse key.
!
----- Method: MethodNode>>selector: (in category 'initialize-release') -----
selector: symbol
selectorOrFalse _ symbol!
----- Method: MethodNode>>selector:arguments:precedence:temporaries:block:encoder:primitive: (in category 'initialize-release') -----
selector: selOrFalse arguments: args precedence: p temporaries: temps block: blk encoder: anEncoder primitive: prim
self
selector: selOrFalse
arguments: args
precedence: p
temporaries: temps
block: blk encoder:
anEncoder
primitive: prim
properties: MethodProperties new.!
----- Method: MethodNode>>selector:arguments:precedence:temporaries:block:encoder:primitive:properties: (in category 'initialize-release') -----
selector: selOrFalse arguments: args precedence: p temporaries: temps block: blk encoder: anEncoder primitive: prim properties: propDict
"Initialize the receiver with respect to the arguments given."
encoder _ anEncoder.
selectorOrFalse _ selOrFalse.
precedence _ p.
arguments _ args.
temporaries _ temps.
block _ blk.
primitive _ prim.
properties _ propDict.!
----- Method: MethodNode>>sourceMap (in category 'code generation') -----
sourceMap
"Answer a SortedCollection of associations of the form: pc (byte offset in me) -> sourceRange (an Interval) in source text."
| methNode |
methNode _ self.
sourceText ifNil: [
"No source, use decompile string as source to map from"
methNode _ self parserClass new
parse: self decompileString
class: self methodClass
].
methNode generate. "set bytecodes to map to"
^ methNode encoder sourceMap!
----- Method: MethodNode>>sourceText (in category 'printing') -----
sourceText
^ sourceText ifNil: [self printString]!
----- Method: MethodNode>>sourceText: (in category 'initialize-release') -----
sourceText: stringOrText
sourceText _ stringOrText!
----- Method: MethodNode>>tempNames (in category 'printing') -----
tempNames
^ encoder tempNames!
ParseNode subclass: #MethodTempsNode
instanceVariableNames: 'temporaries'
classVariableNames: ''
poolDictionaries: ''
category: 'Compiler-ParseNodes'!
----- Method: ParseNode class>>blockReturnCode (in category 'class initialization') -----
blockReturnCode
^ EndRemote!
----- Method: ParseNode class>>initialize (in category 'class initialization') -----
initialize
"ParseNode initialize. VariableNode initialize"
LdInstType _ 1.
LdTempType _ 2.
LdLitType _ 3.
LdLitIndType _ 4.
SendType _ 5.
CodeBases _ #(0 16 32 64 208 ).
CodeLimits _ #(16 16 32 32 16 ).
LdSelf _ 112.
LdTrue _ 113.
LdFalse _ 114.
LdNil _ 115.
LdMinus1 _ 116.
LoadLong _ 128.
Store _ 129.
StorePop _ 130.
ShortStoP _ 96.
SendLong _ 131.
DblExtDoAll _ 132.
SendLong2 _ 134.
LdSuper _ 133.
Pop _ 135.
Dup _ 136.
LdThisContext _ 137.
EndMethod _ 124.
EndRemote _ 125.
Jmp _ 144.
Bfp _ 152.
JmpLimit _ 8.
JmpLong _ 164. "code for jmp 0"
BtpLong _ 168.
SendPlus _ 176.
Send _ 208.
SendLimit _ 16!
----- Method: ParseNode class>>popCode (in category 'class initialization') -----
popCode
^ Pop!
----- Method: ParseNode>>asReturnNode (in category 'converting') -----
asReturnNode
^ReturnNode new expr: self!
----- Method: ParseNode>>assignmentCheck:at: (in category 'testing') -----
assignmentCheck: encoder at: location
"For messageNodes masquerading as variables for the debugger.
For now we let this through - ie we allow stores ev
into args. Should check against numArgs, though."
^ -1!
----- Method: ParseNode>>canBeSpecialArgument (in category 'testing') -----
canBeSpecialArgument
"Can I be an argument of (e.g.) ifTrue:?"
^false!
----- Method: ParseNode>>canCascade (in category 'testing') -----
canCascade
^false!
----- Method: ParseNode>>comment (in category 'comment') -----
comment
^comment!
----- Method: ParseNode>>comment: (in category 'comment') -----
comment: newComment
comment _ newComment!
----- Method: ParseNode>>emitBranchOn:dist:pop:on: (in category 'code generation') -----
emitBranchOn:
condition dist: dist pop: stack on: strm
stack pop: 1.
dist = 0 ifTrue: [^ strm nextPut: Pop].
condition
ifTrue: [self emitLong: dist code: BtpLong on: strm]
ifFalse: [self emitShortOrLong: dist code: Bfp on: strm]!
----- Method: ParseNode>>emitForEffect:on: (in category 'code generation') -----
emitForEffect: stack on: strm
self emitForValue: stack on: strm.
strm nextPut: Pop.
stack pop: 1!
----- Method: ParseNode>>emitForReturn:on: (in category 'code generation') -----
emitForReturn: stack on: strm
self emitForValue: stack on: strm.
strm nextPut: EndMethod!
----- Method: ParseNode>>emitJump:on: (in category 'code generation') -----
emitJump: dist on: strm
dist = 0 ifFalse: [self emitShortOrLong: dist code: Jmp on: strm]!
----- Method: ParseNode>>emitLong:code:on: (in category 'code generation') -----
emitLong: dist code: longCode on: aStream
"Force a two-byte jump."
| code distance |
code _ longCode.
distance _ dist.
distance < 0
ifTrue:
[distance _ distance + 1024.
code _ code - 4]
ifFalse:
[distance > 1023 ifTrue: [distance _ -1]].
distance < 0
ifTrue:
[self error: 'A block compiles more than 1K bytes of code']
ifFalse:
[aStream nextPut: distance // 256 + code.
aStream nextPut: distance \\ 256]!
----- Method: ParseNode>>emitShortOrLong:code:on: (in category 'code generation') -----
emitShortOrLong: dist code: shortCode on: strm
(1 <= dist and: [dist <= JmpLimit])
ifTrue: [strm nextPut: shortCode + dist - 1]
ifFalse: [self emitLong: dist code: shortCode + (JmpLong-Jmp) on: strm]!
----- Method: ParseNode>>encodeSelector: (in category 'encoding') -----
encodeSelector: selector
^nil!
----- Method: ParseNode>>ifNilReceiver (in category 'private') -----
ifNilReceiver
"assuming this object is the receiver of an ifNil:, what object is being asked about?"
^self!
----- Method: ParseNode>>isArg (in category 'testing') -----
isArg
^false!
----- Method: ParseNode>>isComplex (in category 'testing') -----
isComplex
"Used for pretty printing to determine whether to start a new line"
^false!
----- Method: ParseNode>>isConstantNumber (in category 'testing') -----
isConstantNumber "Overridden in LiteralNode"
^false!
----- Method: ParseNode>>isDoIt (in category 'testing') -----
isDoIt
"polymorphic with RBNodes; called by debugger"
^ false!
----- Method: ParseNode>>isJust: (in category 'testing') -----
isJust: node
^false!
----- Method: ParseNode>>isLiteral (in category 'testing') -----
isLiteral
^ false!
----- Method: ParseNode>>isMessage (in category 'testing') -----
isMessage
^false!
----- Method: ParseNode>>isMessage:receiver:arguments: (in category 'testing') -----
isMessage: selSymbol receiver: rcvrPred arguments: argsPred
"See comment in MessageNode."
^false!
----- Method: ParseNode>>isReturnSelf (in category 'testing') -----
isReturnSelf
^false!
----- Method: ParseNode>>isReturningIf (in category 'testing') -----
isReturningIf
^false!
----- Method: ParseNode>>isSelfPseudoVariable (in category 'testing') -----
isSelfPseudoVariable
"Overridden in VariableNode."
^false!
----- Method: ParseNode>>isSpecialConstant (in category 'testing') -----
isSpecialConstant
^ false!
----- Method: ParseNode>>isTemp (in category 'testing') -----
isTemp
^ false!
----- Method: ParseNode>>isUndefTemp (in category 'testing') -----
isUndefTemp
^ false!
----- Method: ParseNode>>isUnusedTemp (in category 'testing') -----
isUnusedTemp
^ false!
----- Method: ParseNode>>isVariableReference (in category 'testing') -----
isVariableReference
^false!
----- Method: ParseNode>>nextWordFrom:setCharacter: (in category 'private') -----
nextWordFrom: aStream setCharacter: aBlock
| outStream char |
outStream _ WriteStream on: (String new: 16).
[(aStream peekFor: Character space)
or: [aStream peekFor: Character tab]] whileTrue.
[aStream atEnd
or:
[char _ aStream next.
char = Character cr or: [char = Character space]]]
whileFalse: [outStream nextPut: char].
aBlock value: char.
^ outStream contents!
----- Method: ParseNode>>nodePrintOn:indent: (in category 'printing') -----
nodePrintOn: aStrm indent: nn
| var aaStrm myLine |
"Show just the sub nodes and the code."
(aaStrm _ aStrm) ifNil: [aaStrm _ WriteStream on: (String new: 500)].
nn timesRepeat: [aaStrm tab].
aaStrm nextPutAll: self class name; space.
myLine _ self printString copyWithout: Character cr.
myLine _ myLine copyFrom: 1 to: (myLine size min: 70).
aaStrm nextPutAll: myLine; cr.
1 to: self class instSize do: [:ii |
var _ self instVarAt: ii.
(var respondsTo: #asReturnNode) ifTrue: [var nodePrintOn: aaStrm indent: nn+1]].
1 to: self class instSize do: [:ii |
var _ self instVarAt: ii.
(var isKindOf: SequenceableCollection) ifTrue: [
var do: [:aNode |
(aNode respondsTo: #asReturnNode) ifTrue: [
aNode nodePrintOn: aaStrm indent: nn+1]]]].
^ aaStrm
!
----- Method: ParseNode>>nowHasDef (in category 'testing') -----
nowHasDef "Ignored in all but VariableNode"!
----- Method: ParseNode>>nowHasRef (in category 'testing') -----
nowHasRef "Ignored in all but VariableNode"!
----- Method: ParseNode>>pc (in category 'code generation') -----
pc
"Used by encoder source mapping."
^pc ifNil: [ 0 ]
!
----- Method: ParseNode>>printCommentOn:indent: (in category 'printing') -----
printCommentOn: aStream indent: indent
| thisComment |
self comment == nil ifTrue: [^ self].
aStream withStyleFor: #comment
do: [1 to: self comment size do:
[:index |
index > 1 ifTrue: [aStream crtab: indent].
aStream nextPut: $".
thisComment _ self comment at: index.
self printSingleComment: thisComment
on: aStream
indent: indent.
aStream nextPut: $"]].
self comment: nil!
----- Method: ParseNode>>printOn: (in category 'printing') -----
printOn: aStream
"Refer to the comment in Object|printOn:."
aStream nextPutAll: '{'.
aStream nextPutAll: ((ColoredCodeStream contents: [:strm | self printOn: strm indent: 0])
asString).
aStream nextPutAll: '}'!
----- Method: ParseNode>>printOn:indent: (in category 'printing') -----
printOn: aStream indent: anInteger
"If control gets here, avoid recursion loop."
super printOn: aStream!
----- Method: ParseNode>>printOn:indent:precedence: (in category 'printing') -----
printOn: aStream indent: level precedence: p
self printOn: aStream indent: level!
----- Method: ParseNode>>printSingleComment:on:indent: (in category 'private') -----
printSingleComment: aString on: aStream indent: indent
"Print the comment string, assuming it has been indented indent tabs.
Break the string at word breaks, given the widths in the default
font, at 450 points."
| readStream word position lineBreak font wordWidth tabWidth spaceWidth lastChar |
readStream _ ReadStream on: aString.
font _ TextStyle default defaultFont.
tabWidth _ TextConstants at: #DefaultTab.
spaceWidth _ font widthOf: Character space.
position _ indent * tabWidth.
lineBreak _ 450.
[readStream atEnd]
whileFalse:
[word _ self nextWordFrom: readStream setCharacter: [:lc | lastChar _ lc].
wordWidth _ word inject: 0 into: [:width :char | width + (font widthOf: char)].
position _ position + wordWidth.
position > lineBreak
ifTrue:
[aStream skip: -1; crtab: indent.
position _ indent * tabWidth + wordWidth + spaceWidth.
lastChar = Character cr
ifTrue: [[readStream peekFor: Character tab] whileTrue].
word isEmpty ifFalse: [aStream nextPutAll: word; space]]
ifFalse:
[aStream nextPutAll: word.
readStream atEnd
ifFalse:
[position _ position + spaceWidth.
aStream space].
lastChar = Character cr
ifTrue:
[aStream skip: -1; crtab: indent.
position _ indent * tabWidth.
[readStream peekFor: Character tab] whileTrue]]]!
----- Method: ParseNode>>shortPrintOn: (in category 'printing') -----
shortPrintOn: aStream
self printOn: aStream indent: 0!
----- Method: ParseNode>>sizeBranchOn:dist: (in category 'code generation') -----
sizeBranchOn: condition dist: dist
dist = 0 ifTrue: [^1].
^ condition
ifTrue: [2] "Branch on true is always 2 bytes"
ifFalse: [self sizeShortOrLong: dist]!
----- Method: ParseNode>>sizeForEffect: (in category 'code generation') -----
sizeForEffect: encoder
^(self sizeForValue: encoder) + 1!
----- Method: ParseNode>>sizeForReturn: (in category 'code generation') -----
sizeForReturn: encoder
^(self sizeForValue: encoder) + 1!
----- Method: ParseNode>>sizeJump: (in category 'code generation') -----
sizeJump: dist
dist = 0 ifTrue: [^0].
^self sizeShortOrLong: dist!
----- Method: ParseNode>>sizeShortOrLong: (in category 'code generation') -----
sizeShortOrLong: dist
(1 <= dist and: [dist <= JmpLimit])
ifTrue: [^1].
^2!
----- Method: ParseNode>>toDoIncrement: (in category 'testing') -----
toDoIncrement: ignored
"Only meant for Messages or Assignments - else return nil"
^ nil!
ParseNode subclass: #ReturnNode
instanceVariableNames: 'expr'
classVariableNames: ''
poolDictionaries: ''
category: 'Compiler-ParseNodes'!
!ReturnNode commentStamp: '<historical>' prior: 0!
I represent an expression of the form ^expr.!
----- Method: ReturnNode>>asReturnNode (in category 'converting') -----
asReturnNode!
----- Method: ReturnNode>>code (in category 'code generation') -----
code
^expr code!
----- Method: ReturnNode>>emitForReturn:on: (in category 'code generation') -----
emitForReturn: stack on: strm
expr emitForReturn: stack on: strm.
pc _ strm position!
----- Method: ReturnNode>>emitForValue:on: (in category 'code generation') -----
emitForValue: stack on: strm
expr emitForReturn: stack on: strm.
pc _ strm position!
----- Method: ReturnNode>>expr (in category 'printing') -----
expr
^ expr.
!
----- Method: ReturnNode>>expr: (in category 'initialize-release') -----
expr: e
expr _ e!
----- Method: ReturnNode>>expr:encoder:sourceRange: (in category 'initialize-release') -----
expr: e encoder: encoder sourceRange: range
expr _ e.
encoder noteSourceRange: range forNode: self!
----- Method: ReturnNode>>isReturnSelf (in category 'testing') -----
isReturnSelf
^expr == NodeSelf!
----- Method: ReturnNode>>isSpecialConstant (in category 'testing') -----
isSpecialConstant
^expr isSpecialConstant!
----- Method: ReturnNode>>isVariableReference (in category 'testing') -----
isVariableReference
^expr isVariableReference!
----- Method: ReturnNode>>printOn:indent: (in category 'printing') -----
printOn: aStream indent: level
aStream nextPutAll: '^ '.
expr printOn: aStream indent: level.
expr printCommentOn: aStream indent: level.
!
----- Method: ReturnNode>>sizeForReturn: (in category 'code generation') -----
sizeForReturn: encoder
^expr sizeForReturn: encoder!
----- Method: ReturnNode>>sizeForValue: (in category 'code generation') -----
sizeForValue: encoder
^expr sizeForReturn: encoder!
Object subclass: #ParseStack
instanceVariableNames: 'position length'
classVariableNames: ''
poolDictionaries: ''
category: 'Compiler-Support'!
!ParseStack commentStamp: '<historical>' prior: 0!
I keep track of the current and high position of the stack that will be needed by code being compiled.!
----- Method: ParseStack>>init (in category 'initialize-release') -----
init
length _ position _ 0!
----- Method: ParseStack>>pop: (in category 'accessing') -----
pop: n
(position _ position - n) < 0
ifTrue: [self error: 'Parse stack underflow']!
----- Method: ParseStack>>position (in category 'results') -----
position
^position!
----- Method: ParseStack>>printOn: (in category 'printing') -----
printOn: aStream
super printOn: aStream.
aStream nextPutAll: ' at '; print: position; nextPutAll: ' of '; print: length!
----- Method: ParseStack>>push: (in category 'accessing') -----
push: n
(position _ position + n) > length
ifTrue: [length _ position]!
----- Method: ParseStack>>size (in category 'accessing') -----
size
^length!
Object subclass: #PrimitiveNode
instanceVariableNames: 'primitiveNum spec'
classVariableNames: ''
poolDictionaries: ''
category: 'Compiler-ParseNodes'!
!PrimitiveNode commentStamp: 'ajh 3/24/2003 21:35' prior: 0!
I represent a primitive. I am more than just a number if I am a named primitive.
Structure:
num <Integer> Primitive number.
spec <Object> Stored in first literal when num is 117 or 120.
!
----- Method: PrimitiveNode class>>null (in category 'as yet unclassified') -----
null
^ self new num: 0!
----- Method: PrimitiveNode>>num (in category 'as yet unclassified') -----
num
^ primitiveNum!
----- Method: PrimitiveNode>>num: (in category 'as yet unclassified') -----
num: n
primitiveNum _ n!
----- Method: PrimitiveNode>>printOn: (in category 'as yet unclassified') -----
printOn: aStream
aStream nextPutAll: 'primitive '; print: primitiveNum!
----- Method: PrimitiveNode>>printPrimitiveOn: (in category 'as yet unclassified') -----
printPrimitiveOn: aStream
"Print the primitive on aStream"
| primIndex primDecl |
primIndex _ primitiveNum.
primIndex = 0 ifTrue: [^ self].
primIndex = 120 ifTrue: [
"External call spec"
^ aStream print: spec].
aStream nextPutAll: '<primitive: '.
primIndex = 117 ifTrue: [
primDecl _ spec.
aStream nextPut: $';
nextPutAll: (primDecl at: 2);
nextPut: $'.
(primDecl at: 1) ifNotNil: [
aStream nextPutAll: ' module: ';
nextPut: $';
nextPutAll: (primDecl at: 1);
nextPut: $'].
] ifFalse: [aStream print: primIndex].
aStream nextPut: $>.
(primIndex ~= 117 and: [primIndex ~= 120]) ifTrue: [
Smalltalk at: #Interpreter ifPresent: [:cls |
aStream nextPutAll: ' "',
((cls classPool at: #PrimitiveTable) at: primIndex + 1) , '" '
].
].
!
----- Method: PrimitiveNode>>sourceText (in category 'as yet unclassified') -----
sourceText
^ String streamContents: [:stream |
self printPrimitiveOn: stream]!
----- Method: PrimitiveNode>>spec (in category 'as yet unclassified') -----
spec
^ spec!
----- Method: PrimitiveNode>>spec: (in category 'as yet unclassified') -----
spec: literal
spec _ literal!
Object subclass: #Scanner
instanceVariableNames: 'source mark hereChar aheadChar token tokenType currentComment buffer typeTable'
classVariableNames: 'TypeTable'
poolDictionaries: ''
category: 'Compiler-Kernel'!
!Scanner commentStamp: '<historical>' prior: 0!
I scan a string or text, picking out Smalltalk syntactic tokens. I look one character ahead. I put each token found into the instance variable, token, and its type (a Symbol) into the variable, tokenType. At the end of the input stream, I pretend to see an endless sequence of special characters called doits.!
Scanner subclass: #Parser
instanceVariableNames: 'here hereType hereMark hereEnd prevMark prevEnd encoder requestor parseNode failBlock requestorOffset tempsMark doitFlag properties category'
classVariableNames: ''
poolDictionaries: ''
category: 'Compiler-Kernel'!
!Parser commentStamp: '<historical>' prior: 0!
I parse Smalltalk syntax and create a MethodNode that is the root of the parse tree. I look one token ahead.!
----- Method: Parser>>addComment (in category 'private') -----
addComment
parseNode ~~ nil
ifTrue:
[parseNode comment: currentComment.
currentComment _ nil]!
----- Method: Parser>>addPragma: (in category 'pragmas') -----
addPragma: aPragma
self properties addPragma: aPragma!
----- Method: Parser>>advance (in category 'scanning') -----
advance
| this |
prevMark _ hereMark.
prevEnd _ hereEnd.
this _ here.
here _ token.
hereType _ tokenType.
hereMark _ mark.
hereEnd _ source position - (source atEnd ifTrue: [hereChar == 30 asCharacter ifTrue: [0] ifFalse: [1]] ifFalse: [2]).
self scanToken.
"Transcript show: 'here: ', here printString, ' mark: ', hereMark printString, ' end: ', hereEnd printString; cr."
^this!
----- Method: Parser>>allocateLiteral: (in category 'primitives') -----
allocateLiteral: lit
encoder litIndex: lit!
----- Method: Parser>>argumentName (in category 'expression types') -----
argumentName
hereType == #word
ifFalse: [^self expected: 'Argument name'].
^self advance!
----- Method: Parser>>assignment: (in category 'expression types') -----
assignment: varNode
" var '_' expression => AssignmentNode."
| loc start |
(loc _ varNode assignmentCheck: encoder at: prevMark + requestorOffset) >= 0
ifTrue: [^self notify: 'Cannot store into' at: loc].
start _ self startOfNextToken.
varNode nowHasDef.
self advance.
self expression ifFalse: [^self expected: 'Expression'].
parseNode _ AssignmentNode new
variable: varNode
value: parseNode
from: encoder
sourceRange: (start to: self endOfLastToken).
^true!
----- Method: Parser>>bindArg: (in category 'temps') -----
bindArg: name
^ self bindTemp: name!
----- Method: Parser>>bindTemp: (in category 'temps') -----
bindTemp: name
^name!
----- Method: Parser>>bindTemp:in: (in category 'temps') -----
bindTemp: name in: methodSelector
^self bindTemp: name!
----- Method: Parser>>blockExpression (in category 'expression types') -----
blockExpression
"[ ({:var} |) (| {temps} |) (statements) ] => BlockNode."
| variableNodes temporaryBlockVariables start |
variableNodes _ OrderedCollection new.
start _ prevMark + requestorOffset.
"Gather parameters."
[self match: #colon] whileTrue: [variableNodes addLast: (encoder autoBind: self argumentName)].
(variableNodes size > 0 & (hereType ~~ #rightBracket) and: [(self match: #verticalBar) not]) ifTrue: [^self expected: 'Vertical bar'].
temporaryBlockVariables _ self temporaryBlockVariables.
self statements: variableNodes innerBlock: true.
parseNode temporaries: temporaryBlockVariables.
(self match: #rightBracket) ifFalse: [^self expected: 'Period or right bracket'].
encoder noteSourceRange: (self endOfLastToken to: self endOfLastToken) forNode: parseNode.
"The scope of the parameters and temporary block variables is no longer active."
temporaryBlockVariables do: [:variable | variable scope: -1].
variableNodes do: [:variable | variable scope: -1]!
----- Method: Parser>>braceExpression (in category 'expression types') -----
braceExpression
" { elements } => BraceNode."
| elements locations loc more |
elements _ OrderedCollection new.
locations _ OrderedCollection new.
self advance.
more _ hereType ~~ #rightBrace.
[more]
whileTrue:
[loc _ hereMark + requestorOffset.
self expression
ifTrue:
[elements addLast: parseNode.
locations addLast: loc]
ifFalse:
[^self expected: 'Variable or expression'].
(self match: #period)
ifTrue: [more _ hereType ~~ #rightBrace]
ifFalse: [more _ false]].
parseNode _ BraceNode new elements: elements sourceLocations: locations.
(self match: #rightBrace)
ifFalse: [^self expected: 'Period or right brace'].
^true!
----- Method: Parser>>cascade (in category 'expression types') -----
cascade
" {; message} => CascadeNode."
| rcvr msgs |
parseNode canCascade
ifFalse: [^self expected: 'Cascading not'].
rcvr _ parseNode cascadeReceiver.
msgs _ OrderedCollection with: parseNode.
[self match: #semicolon]
whileTrue:
[parseNode _ rcvr.
(self messagePart: 3 repeat: false)
ifFalse: [^self expected: 'Cascade'].
parseNode canCascade
ifFalse: [^self expected: '<- No special messages'].
parseNode cascadeReceiver.
msgs addLast: parseNode].
parseNode _ CascadeNode new receiver: rcvr messages: msgs!
----- Method: Parser>>correctSelector:wordIntervals:exprInterval:ifAbort: (in category 'error correction') -----
correctSelector: proposedKeyword wordIntervals: spots exprInterval: expInt ifAbort: abortAction
"Correct the proposedKeyword to some selector symbol, correcting the original text if such action is indicated. abortAction is invoked if the proposedKeyword couldn't be converted into a valid selector. Spots is an ordered collection of intervals within the test stream of the for each of the keyword parts."
| alternatives aStream choice correctSelector userSelection lines firstLine |
"If we can't ask the user, assume that the keyword will be defined later"
self interactive ifFalse: [ ^ proposedKeyword asSymbol ].
userSelection _ requestor selectionInterval.
requestor selectFrom: spots first first to: spots last last.
requestor select.
alternatives _ Symbol possibleSelectorsFor: proposedKeyword.
self flag: #toBeFixed.
"alternatives addAll: (MultiSymbol possibleSelectorsFor: proposedKeyword)."
aStream _ WriteStream on: (String new: 200).
aStream nextPutAll: (proposedKeyword contractTo: 35); cr.
firstLine _ 1.
alternatives do:
[:sel | aStream nextPutAll: (sel contractTo: 35); nextPut: Character cr].
aStream nextPutAll: 'cancel'.
lines _ Array with: firstLine with: (alternatives size + firstLine).
choice _ (UIManager default
chooseFrom: (aStream contents substrings)
lines: lines
title: 'Unknown selector, please\confirm, correct, or cancel' withCRs).
(choice = 0) | (choice > (lines at: 2))
ifTrue: [ ^ abortAction value ].
requestor deselect.
requestor selectInvisiblyFrom: userSelection first to: userSelection last.
choice = 1 ifTrue: [ ^ proposedKeyword asSymbol ].
correctSelector _ alternatives at: choice - 1.
self substituteSelector: correctSelector keywords wordIntervals: spots.
((proposedKeyword last ~= $:) and: [correctSelector last == $:]) ifTrue: [
^ abortAction value].
^ correctSelector.
!
----- Method: Parser>>correctVariable:interval: (in category 'error correction') -----
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: [
^LiteralVariableNode new
name: proposedVariable index: (encoder classEncoding allInstVarNames indexOf: proposedVariable) - 1 type: 1;
yourself ].
"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!
----- Method: Parser>>declareClassVar: (in category 'error correction') -----
declareClassVar: name
| sym class |
sym _ name asSymbol.
class _ encoder classEncoding.
class _ class theNonMetaClass. "not the metaclass"
class addClassVarName: name.
^ encoder global: (class classPool associationAt: sym)
name: sym!
----- Method: Parser>>declareGlobal: (in category 'error correction') -----
declareGlobal: name
| sym |
sym _ name asSymbol.
Smalltalk at: sym put: nil.
^ encoder global: (Smalltalk associationAt: sym) name: sym!
----- Method: Parser>>declareInstVar: (in category 'error correction') -----
declareInstVar: name
" rr 3/6/2004 16:06 : adds the line to correctly compute the index. uncommented the option in
the caller."
| index |
encoder classEncoding addInstVarName: name.
index _ encoder classEncoding instVarNames indexOf: name.
encoder classEncoding allSuperclassesDo: [:cls | index := index + cls instVarNames size].
^LiteralVariableNode new
name: name index: index - 1 type: 1;
yourself
!
----- Method: Parser>>declareTempAndPaste: (in category 'error correction') -----
declareTempAndPaste: name
| insertion delta theTextString characterBeforeMark |
theTextString _ requestor text string.
characterBeforeMark _ theTextString at: tempsMark-1 ifAbsent: [$ ].
(theTextString at: tempsMark) = $| ifTrue: [
"Paste it before the second vertical bar"
insertion _ name, ' '.
characterBeforeMark isSeparator ifFalse: [ insertion _ ' ', insertion].
delta _ 0.
] ifFalse: [
"No bars - insert some with CR, tab"
insertion _ '| ' , name , ' |',String cr.
delta _ 2. "the bar and CR"
characterBeforeMark = Character tab ifTrue: [
insertion _ insertion , String tab.
delta _ delta + 1. "the tab"
].
].
tempsMark _ tempsMark +
(self substituteWord: insertion
wordInterval: (tempsMark to: tempsMark-1)
offset: 0) - delta.
^ encoder bindAndJuggle: name!
----- Method: Parser>>defineClass: (in category 'error correction') -----
defineClass: className
"prompts the user to define a new class,
asks for it's category, and lets the users edit further
the definition"
| sym cat def d2 |
sym := className asSymbol.
cat := UIManager default request: 'Enter class category : ' initialAnswer: self encoder classEncoding theNonMetaClass category.
cat
ifEmpty: [cat := 'Unknown'].
def := 'Object subclass: #' , sym , '
instanceVariableNames: ''''
classVariableNames: ''''
poolDictionaries: ''''
category: ''' , cat , ''''.
d2 := UIManager default request: 'Edit class definition : ' initialAnswer: def.
d2
ifEmpty: [d2 := def].
Compiler evaluate: d2.
^ encoder
global: (Smalltalk associationAt: sym)
name: sym!
----- Method: Parser>>encoder (in category 'public access') -----
encoder
^ encoder!
----- Method: Parser>>endOfLastToken (in category 'scanning') -----
endOfLastToken
^ prevEnd ifNil: [mark]!
----- Method: Parser>>expected: (in category 'error handling') -----
expected: aString
"Notify a problem at token 'here'."
tokenType == #doIt ifTrue: [hereMark _ hereMark + 1].
hereType == #doIt ifTrue: [hereMark _ hereMark + 1].
^ self notify: aString , ' expected' at: hereMark + requestorOffset!
----- Method: Parser>>expression (in category 'expression types') -----
expression
(hereType == #word and: [tokenType == #leftArrow])
ifTrue: [^ self assignment: self variable].
hereType == #leftBrace
ifTrue: [self braceExpression]
ifFalse: [self primaryExpression ifFalse: [^ false]].
(self messagePart: 3 repeat: true)
ifTrue: [hereType == #semicolon ifTrue: [self cascade]].
^ true!
----- Method: Parser>>externalFunctionDeclaration (in category 'primitives') -----
externalFunctionDeclaration
"Parse the function declaration for a call to an external library."
| descriptorClass callType retType externalName args argType module fn |
descriptorClass _ Smalltalk at: #ExternalFunction ifAbsent:[nil].
descriptorClass == nil ifTrue:[^false].
callType _ descriptorClass callingConventionFor: here.
callType == nil ifTrue:[^false].
"Parse return type"
self advance.
retType _ self externalType: descriptorClass.
retType == nil ifTrue:[^self expected:'return type'].
"Parse function name or index"
externalName _ here.
(self match: #string)
ifTrue:[externalName _ externalName asSymbol]
ifFalse:[(self match:#number) ifFalse:[^self expected:'function name or index']].
(self matchToken:'(' asSymbol) ifFalse:[^self expected:'argument list'].
args _ WriteStream on: Array new.
[here == ')' asSymbol] whileFalse:[
argType _ self externalType: descriptorClass.
argType == nil ifTrue:[^self expected:'argument'].
argType isVoid & argType isPointerType not ifFalse:[args nextPut: argType].
].
(self matchToken:')' asSymbol) ifFalse:[^self expected:')'].
(self matchToken: 'module:') ifTrue:[
module _ here.
(self match: #string) ifFalse:[^self expected: 'String'].
module _ module asSymbol].
Smalltalk at: #ExternalLibraryFunction ifPresent:[:xfn|
fn _ xfn name: externalName
module: module
callType: callType
returnType: retType
argumentTypes: args contents.
self allocateLiteral: fn.
].
self addPragma: (Pragma keyword: #primitive: arguments: #(120)).
^true!
----- Method: Parser>>externalType: (in category 'primitives') -----
externalType: descriptorClass
"Parse an return an external type"
| xType |
xType _ descriptorClass atomicTypeNamed: here.
xType == nil ifTrue:["Look up from class scope"
Symbol hasInterned: here ifTrue:[:sym|
xType _ descriptorClass structTypeNamed: sym]].
xType == nil ifTrue:[
"Raise an error if user is there"
self interactive ifTrue:[^nil].
"otherwise go over it silently"
xType _ descriptorClass forceTypeNamed: here].
self advance.
(self matchToken:#*)
ifTrue:[^xType asPointerType]
ifFalse:[^xType]!
----- Method: Parser>>fail (in category 'error handling') -----
fail
| exitBlock |
encoder == nil
ifFalse: [encoder release. encoder _ nil]. "break cycle"
exitBlock _ failBlock.
failBlock _ nil.
^exitBlock value!
----- Method: Parser>>init:notifying:failBlock: (in category 'private') -----
init: sourceStream notifying: req failBlock: aBlock
requestor _ req.
failBlock _ aBlock.
super scan: sourceStream.
prevMark _ hereMark _ mark.
requestorOffset _ 0.
self advance!
----- Method: Parser>>initPattern:notifying:return: (in category 'private') -----
initPattern: aString notifying: req return: aBlock
| result |
self
init: (ReadStream on: aString asString)
notifying: req
failBlock: [^nil].
encoder _ self.
result _ aBlock value: (self pattern: false inContext: nil).
encoder _ failBlock _ nil. "break cycles"
^result!
----- Method: Parser>>interactive (in category 'error handling') -----
interactive
"this version of the method is necessary to load code from MC else the interactive mode is one.
This method is really bad since it links the compiler package with the Tools
one. The solution would be to have a real SyntaxError exception belonging to the
compiler package and not a subclass of StringHolder - sd Nov 2005"
"the code submitted by PlusTools is ideally the one that should be used
interactive
^requestor ~~ nil "
^ (requestor == nil or: [requestor isKindOf: SyntaxError]) not!
----- Method: Parser>>keylessMessagePartTest:repeat: (in category 'expression types') -----
keylessMessagePartTest: level repeat: repeat
!
----- Method: Parser>>match: (in category 'scanning') -----
match: type
"Answer with true if next tokens type matches."
hereType == type
ifTrue:
[self advance.
^true].
^false!
----- Method: Parser>>matchReturn (in category 'scanning') -----
matchReturn
^ self match: #upArrow!
----- Method: Parser>>matchToken: (in category 'scanning') -----
matchToken: thing
"Matches the token, not its type."
here = thing ifTrue: [self advance. ^true].
^false!
----- Method: Parser>>messagePart:repeat: (in category 'expression types') -----
messagePart: level repeat: repeat
| start receiver selector args precedence words keywordStart |
[receiver _ parseNode.
(hereType == #keyword and: [level >= 3])
ifTrue:
[start _ self startOfNextToken.
selector _ WriteStream on: (String new: 32).
args _ OrderedCollection new.
words _ OrderedCollection new.
[hereType == #keyword]
whileTrue:
[keywordStart _ self startOfNextToken + requestorOffset.
selector nextPutAll: self advance.
words addLast: (keywordStart to: self endOfLastToken + requestorOffset).
self primaryExpression ifFalse: [^self expected: 'Argument'].
self messagePart: 2 repeat: true.
args addLast: parseNode].
(Symbol hasInterned: selector contents ifTrue: [ :sym | selector _ sym])
ifFalse: [ selector _ self correctSelector: selector contents
wordIntervals: words
exprInterval: (start to: self endOfLastToken)
ifAbort: [ ^ self fail ] ].
precedence _ 3]
ifFalse: [((hereType == #binary or: [hereType == #verticalBar])
and: [level >= 2])
ifTrue:
[start _ self startOfNextToken.
selector _ self advance asOctetString asSymbol.
self primaryExpression ifFalse: [^self expected: 'Argument'].
self messagePart: 1 repeat: true.
args _ Array with: parseNode.
precedence _ 2]
ifFalse: [hereType == #word
ifTrue:
[start _ self startOfNextToken.
selector _ self advance.
args _ #().
words _ OrderedCollection with: (start + requestorOffset to: self endOfLastToken + requestorOffset).
(Symbol hasInterned: selector ifTrue: [ :sym | selector _ sym])
ifFalse: [ selector _ self correctSelector: selector
wordIntervals: words
exprInterval: (start to: self endOfLastToken)
ifAbort: [ ^ self fail ] ].
precedence _ 1]
ifFalse: [^args notNil]]].
parseNode _ MessageNode new
receiver: receiver
selector: selector
arguments: args
precedence: precedence
from: encoder
sourceRange: (start to: self endOfLastToken).
repeat]
whileTrue: [].
^true!
----- Method: Parser>>method:context:encoder: (in category 'expression types') -----
method: doit context: ctxt encoder: encoderToUse
" pattern [ | temporaries ] block => MethodNode."
| sap blk prim temps messageComment methodNode |
encoder _ encoderToUse.
sap _ self pattern: doit inContext: ctxt.
"sap={selector, arguments, precedence}"
(sap at: 2) do: [:argNode | argNode isArg: true].
doit ifFalse: [ self pragmaSequence ].
temps _ self temporariesIn: (sap at: 1)..
messageComment _ currentComment.
currentComment _ nil.
doit ifFalse: [ self pragmaSequence ].
prim := self pragmaPrimitives.
self statements: #() innerBlock: doit.
blk _ parseNode.
doit ifTrue: [blk returnLast]
ifFalse: [blk returnSelfIfNoOther].
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!
----- Method: Parser>>newMethodNode (in category 'expression types') -----
newMethodNode
^ MethodNode new!
----- Method: Parser>>notify: (in category 'error handling') -----
notify: aString
"Notify problem at token before 'here'."
^self notify: aString at: prevMark + requestorOffset!
----- Method: Parser>>notify:at: (in category 'error handling') -----
notify: string at: location
requestor isNil
ifTrue: [(encoder == self or: [encoder isNil]) ifTrue: [^ self fail "failure setting up syntax error"].
SyntaxErrorNotification
inClass: encoder classEncoding
category: encoder classEncoding category
withCode:
(source contents
copyReplaceFrom: location
to: location - 1
with: string , ' ->')
doitFlag: doitFlag]
ifFalse: [requestor
notify: string , ' ->'
at: location
in: source].
^self fail!
----- Method: Parser>>offEnd: (in category 'error handling') -----
offEnd: aString
"Notify a problem beyond 'here' (in lookAhead token). Don't be offEnded!!"
requestorOffset == nil
ifTrue: [^ self notify: aString at: mark]
ifFalse: [^ self notify: aString at: mark + requestorOffset]
!
----- Method: Parser>>parse:class: (in category 'public access') -----
parse: sourceStreamOrString class: behavior
^ self parse: sourceStreamOrString readStream class: behavior
noPattern: false context: nil notifying: nil ifFail: [self parseError]!
----- Method: Parser>>parse:class:category:noPattern:context:notifying:ifFail: (in category 'public access') -----
parse: sourceStream class: class category: aCategory noPattern: noPattern context: ctxt notifying: req ifFail: aBlock
"Answer a MethodNode for the argument, sourceStream, that is the root of
a parse tree. Parsing is done with respect to the argument, class, to find
instance, class, and pool variables; and with respect to the argument,
ctxt, to find temporary variables. Errors in parsing are reported to the
argument, req, if not nil; otherwise aBlock is evaluated. The argument
noPattern is a Boolean that is true if the the sourceStream does not
contain a method header (i.e., for DoIts)."
category := aCategory.
^ self parse: sourceStream class: class noPattern: noPattern context: ctxt notifying: req ifFail: aBlock
!
----- Method: Parser>>parse:class:noPattern:context:notifying:ifFail: (in category 'public access') -----
parse: sourceStream class: class noPattern: noPattern context: ctxt notifying: req ifFail: aBlock
"Answer a MethodNode for the argument, sourceStream, that is the root of
a parse tree. Parsing is done with respect to the argument, class, to find
instance, class, and pool variables; and with respect to the argument,
ctxt, to find temporary variables. Errors in parsing are reported to the
argument, req, if not nil; otherwise aBlock is evaluated. The argument
noPattern is a Boolean that is true if the the sourceStream does not
contain a method header (i.e., for DoIts)."
| methNode repeatNeeded myStream s p |
myStream _ sourceStream.
[repeatNeeded _ false.
p _ myStream position.
s _ myStream upToEnd.
myStream position: p.
self init: myStream notifying: req failBlock: [^ aBlock value].
doitFlag _ noPattern.
failBlock_ aBlock.
[methNode _ self method: noPattern context: ctxt
encoder: (Encoder new init: class context: ctxt notifying: self)]
on: ParserRemovedUnusedTemps
do:
[ :ex | repeatNeeded _ (requestor isKindOf: TextMorphEditor) not.
myStream _ ReadStream on: requestor text string.
ex resume].
repeatNeeded] whileTrue.
encoder _ failBlock _ requestor _ parseNode _ nil. "break cycles & mitigate refct overflow"
methNode sourceText: s.
^ methNode!
----- Method: Parser>>parse:class:noPattern:notifying:ifFail: (in category 'public access') -----
parse: sourceStream class: class noPattern: noPattern notifying: req ifFail: aBlock
^ self parse: sourceStream class: class noPattern: noPattern context: nil notifying: req ifFail: aBlock!
----- Method: Parser>>parseArgsAndTemps:notifying: (in category 'public access') -----
parseArgsAndTemps: aString notifying: req
"Parse the argument, aString, notifying req if an error occurs. Otherwise,
answer a two-element Array containing Arrays of strings (the argument
names and temporary variable names)."
aString == nil ifTrue: [^#()].
doitFlag _ false. "Don't really know if a doit or not!!"
^self initPattern: aString
notifying: req
return: [:pattern | (pattern at: 2) , (self temporariesIn: (pattern at: 1))]!
----- Method: Parser>>parseMethodComment:setPattern: (in category 'public access') -----
parseMethodComment: aString setPattern: aBlock
"Answer the method comment for the argument, aString. Evaluate aBlock
with the message pattern in the form #(selector, arguments, precedence)."
self
initPattern: aString
notifying: nil
return: aBlock.
currentComment==nil
ifTrue: [^OrderedCollection new]
ifFalse: [^currentComment]!
----- Method: Parser>>parseSelector: (in category 'public access') -----
parseSelector: aString
"Answer the message selector for the argument, aString, which should
parse successfully up to the temporary declaration or the end of the
method header."
^self
initPattern: aString
notifying: nil
return: [:pattern | pattern at: 1]!
----- Method: Parser>>pattern:inContext: (in category 'expression types') -----
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: 'homeContext'}. 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}].
^ self expected: 'Message pattern'!
----- Method: Parser>>pragmaLiteral (in category 'pragmas') -----
pragmaLiteral
"Read a pragma literal."
(hereType == #string or: [ hereType == #literal or: [ hereType == #number ] ])
ifTrue: [ ^ self advance ].
(here == $# and: [ tokenType == #word ])
ifTrue: [ ^ self advance ].
(here == #- and: [ tokenType == #number ])
ifTrue: [ ^ (self advance; advance) negated ].
(here = 'true' or: [ here = 'false' or: [ here = 'nil' ] ])
ifTrue: [ ^ Compiler evaluate: self advance ].
^ self expected: 'Literal constant'!
----- Method: Parser>>pragmaPrimitives (in category 'pragmas') -----
pragmaPrimitives
| pragmas primitives |
self properties pragmas isEmpty
ifTrue: [ ^ 0 ].
pragmas := Pragma allNamed: #primitive from: self class to: Parser.
primitives := self properties pragmas select: [ :prim |
pragmas anySatisfy: [ :prag |
prag selector = prim keyword ] ].
primitives isEmpty
ifTrue: [ ^ 0 ].
primitives size = 1
ifFalse: [ ^ self notify: 'Ambigous primitives' ].
^ primitives first message sendTo: self!
----- Method: Parser>>pragmaSequence (in category 'pragmas') -----
pragmaSequence
"Parse a sequence of method pragmas."
[ true ] whileTrue: [
(self matchToken: #<)
ifFalse: [ ^ self ].
self pragmaStatement.
(self matchToken: #>)
ifFalse: [ ^ self expected: '>' ] ]!
----- Method: Parser>>pragmaStatement (in category 'pragmas') -----
pragmaStatement
"Read a single pragma statement. Parse all generic pragmas in the form of: <key1: val1 key2: val2 ...> and remember them, including primitives."
| selector arguments words index keyword |
(hereType = #keyword or: [ hereType = #word or: [ hereType = #binary ] ])
ifFalse: [ ^ self expected: 'pragma declaration' ].
" This is a ugly hack into the compiler of the FFI package. FFI should be changed to use propre pragmas that can be parsed with the code here. "
(here = #apicall: or: [ here = #cdecl: ])
ifTrue: [ ^ self externalFunctionDeclaration ].
selector := String new.
arguments := OrderedCollection new.
words := OrderedCollection new.
[ hereType = #keyword or: [ (hereType = #word or: [ hereType = #binary ]) and: [ selector isEmpty ] ] ] whileTrue: [
index := self startOfNextToken + requestorOffset.
selector := selector , self advance.
words add: (index to: self endOfLastToken + requestorOffset).
(selector last = $: or: [ selector first isLetter not ])
ifTrue: [ arguments add: self pragmaLiteral ] ].
selector numArgs ~= arguments size
ifTrue: [ ^ self expected: 'pragma argument' ].
(Symbol hasInterned: selector
ifTrue: [ :value | keyword := value])
ifFalse: [
keyword := self
correctSelector: selector wordIntervals: words
exprInterval: (words first first to: words last last)
ifAbort: [ ^ self fail ] ].
self addPragma: (Pragma keyword: keyword arguments: arguments asArray).
^ true!
----- Method: Parser>>primaryExpression (in category 'expression types') -----
primaryExpression
hereType == #word
ifTrue:
[parseNode _ self variable.
(parseNode isUndefTemp and: [self interactive])
ifTrue: [self queryUndefined].
parseNode nowHasRef.
^ true].
hereType == #leftBracket
ifTrue:
[self advance.
self blockExpression.
^true].
hereType == #leftBrace
ifTrue:
[self braceExpression.
^true].
hereType == #leftParenthesis
ifTrue:
[self advance.
self expression ifFalse: [^self expected: 'expression'].
(self match: #rightParenthesis)
ifFalse: [^self expected: 'right parenthesis'].
^true].
(hereType == #string or: [hereType == #number or: [hereType == #literal]])
ifTrue:
[parseNode _ encoder encodeLiteral: self advance.
^true].
(here == #- and: [tokenType == #number])
ifTrue:
[self advance.
parseNode _ encoder encodeLiteral: self advance negated.
^true].
^false!
----- Method: Parser>>primitive: (in category 'primitives') -----
primitive: anIntegerOrString
"Create indexed primitive."
<primitive>
^ anIntegerOrString isInteger
ifTrue: [ anIntegerOrString ]
ifFalse: [
anIntegerOrString isString
ifTrue: [ self primitive: anIntegerOrString module: nil ]
ifFalse: [ self expected: 'Indexed primitive' ] ]!
----- Method: Parser>>primitive:module: (in category 'primitives') -----
primitive: aNameString module: aModuleStringOrNil
"Create named primitive."
<primitive>
(aNameString isString and: [ aModuleStringOrNil isNil or: [ aModuleStringOrNil isString ] ])
ifFalse: [ ^ self expected: 'Named primitive' ].
self allocateLiteral: (Array
with: (aModuleStringOrNil isNil
ifFalse: [ aModuleStringOrNil asSymbol ])
with: aNameString asSymbol
with: 0 with: 0).
^ 117!
----- Method: Parser>>properties (in category 'pragmas') -----
properties
^ properties ifNil: [ properties := MethodProperties new ]!
----- Method: Parser>>queryUndefined (in category 'error correction') -----
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?')
withCRs asText makeBoldFrom: 1 to: varName size))
= 1) ifFalse: [^ self fail]!
----- Method: Parser>>removeUnusedTemps (in category 'error correction') -----
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 |
(encoder encodeVariable: temp) isUndefTemp
ifTrue:
[(UIManager default
confirm: (temp , ' appears to be\unused in this method.\OK to remove it?') withCRs)
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) isAlphaNumeric not & (str at: end+1) isAlphaNumeric not]]]
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)]]]].
madeChanges ifTrue: [ParserRemovedUnusedTemps signal]!
----- Method: Parser>>startOfNextToken (in category 'scanning') -----
startOfNextToken
"Return starting position in source of next token."
hereType == #doIt ifTrue: [^source position + 1].
^hereMark!
----- Method: Parser>>statements:innerBlock: (in category 'expression types') -----
statements: argNodes innerBlock: inner
| stmts returns start more blockComment |
stmts _ OrderedCollection new.
"give initial comment to block, since others trail statements"
blockComment _ currentComment.
currentComment _ nil.
returns _ false.
more _ hereType ~~ #rightBracket.
[more]
whileTrue:
[start _ self startOfNextToken.
(returns _ self matchReturn)
ifTrue:
[self expression
ifFalse: [^self expected: 'Expression to return'].
self addComment.
stmts addLast: (parseNode isReturningIf
ifTrue: [parseNode]
ifFalse: [ReturnNode new
expr: parseNode
encoder: encoder
sourceRange: (start to: self endOfLastToken)])]
ifFalse:
[self expression
ifTrue:
[self addComment.
stmts addLast: parseNode]
ifFalse:
[self addComment.
stmts size = 0
ifTrue:
[stmts addLast:
(encoder encodeVariable:
(inner ifTrue: ['nil'] ifFalse: ['self']))]]].
returns
ifTrue:
[self match: #period.
(hereType == #rightBracket or: [hereType == #doIt])
ifFalse: [^self expected: 'End of block']].
more _ returns not and: [self match: #period]].
parseNode _ BlockNode new
arguments: argNodes
statements: stmts
returns: returns
from: encoder.
parseNode comment: blockComment.
^ true!
----- Method: Parser>>substituteSelector:wordIntervals: (in category 'error correction') -----
substituteSelector: selectorParts wordIntervals: spots
"Substitute the correctSelector into the (presuamed interactive) receiver."
| offset |
offset _ 0.
selectorParts with: spots do:
[ :word :interval |
offset _ self substituteWord: word wordInterval: interval offset: offset ]
!
----- Method: Parser>>substituteWord:wordInterval:offset: (in category 'error correction') -----
substituteWord: correctWord wordInterval: spot offset: o
"Substitute the correctSelector into the (presuamed interactive) receiver."
requestor correctFrom: (spot first + o)
to: (spot last + o)
with: correctWord.
requestorOffset _ requestorOffset + correctWord size - spot size.
^ o + correctWord size - spot size!
----- Method: Parser>>temporaries (in category 'expression types') -----
temporaries
" [ '|' (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)].
(self match: #verticalBar) ifTrue:
[tempsMark _ prevMark.
^ vars].
^ self expected: 'Vertical bar'
!
----- Method: Parser>>temporariesIn: (in category 'expression types') -----
temporariesIn: methodSelector
" [ '|' (variable)* '|' ]"
| vars theActualText |
(self match: #verticalBar) ifFalse:
["no temps"
doitFlag ifTrue: [requestor
ifNil: [tempsMark _ 1]
ifNotNil: [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'!
----- Method: Parser>>temporaryBlockVariables (in category 'expression types') -----
temporaryBlockVariables
"Scan and answer temporary block variables."
| variables |
(self match: #verticalBar) ifFalse: [
"There are't any temporary variables."
^#()].
variables _ OrderedCollection new.
[hereType == #word] whileTrue: [variables addLast: (encoder bindBlockTemp: self advance)].
(self match: #verticalBar) ifTrue: [^variables].
^self expected: 'Vertical bar'!
----- Method: Parser>>variable (in category 'expression types') -----
variable
| varName varStart varEnd |
varStart _ self startOfNextToken + requestorOffset.
varName _ self advance.
varEnd _ self endOfLastToken + requestorOffset.
^ encoder encodeVariable: varName
sourceRange: (varStart to: varEnd)
ifUnknown: [self correctVariable: varName interval: (varStart to: varEnd)]!
----- Method: Scanner class>>initialize (in category 'class initialization') -----
initialize
| newTable |
newTable _ Array new: 256 withAll: #xBinary. "default"
newTable atAll: #(9 10 12 13 32 ) put: #xDelimiter. "tab lf ff cr space"
newTable atAll: ($0 asciiValue to: $9 asciiValue) put: #xDigit.
1 to: 255
do: [:index |
(Character value: index) isLetter
ifTrue: [newTable at: index put: #xLetter]].
newTable at: 30 put: #doIt.
newTable at: $" asciiValue put: #xDoubleQuote.
newTable at: $# asciiValue put: #xLitQuote.
newTable at: $$ asciiValue put: #xDollar.
newTable at: $' asciiValue put: #xSingleQuote.
newTable at: $: asciiValue put: #xColon.
newTable at: $( asciiValue put: #leftParenthesis.
newTable at: $) asciiValue put: #rightParenthesis.
newTable at: $. asciiValue put: #period.
newTable at: $; asciiValue put: #semicolon.
newTable at: $[ asciiValue put: #leftBracket.
newTable at: $] asciiValue put: #rightBracket.
newTable at: ${ asciiValue put: #leftBrace.
newTable at: $} asciiValue put: #rightBrace.
newTable at: $^ asciiValue put: #upArrow.
newTable at: $_ asciiValue put: #leftArrow.
newTable at: $| asciiValue put: #verticalBar.
TypeTable _ newTable "bon voyage!!"
"Scanner initialize"!
----- Method: Scanner class>>inviolateInstanceVariableNames (in category 'testing') -----
inviolateInstanceVariableNames
"Answer a list of instance variable names not to be used. (Place holder for real list)"
^ #('thisContext' 'self')!
----- Method: Scanner class>>isLegalInstVarName: (in category 'testing') -----
isLegalInstVarName: aString
"Answer whether aString is a legal instance variable name."
^ ((self isLiteralSymbol: aString) and: [(aString includes: $:) not]) and:
[(self inviolateInstanceVariableNames includes: aString) not]!
----- Method: Scanner class>>isLiteralSymbol: (in category 'testing') -----
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))
ifTrue: [^ false] ifFalse: [^ true]].
ascii _ (aSymbol at: 1) asciiValue.
"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 ifTrue: [^ true] ifFalse: [^ false]
].
type == #xLetter ifTrue:
[[i > 1]
whileTrue:
[ascii _ (aSymbol at: i) asciiValue.
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!
----- Method: Scanner class>>new (in category 'instance creation') -----
new
^super new initScanner!
----- Method: Scanner class>>wellFormedInstanceVariableNameFrom: (in category 'testing') -----
wellFormedInstanceVariableNameFrom: aString
"Answer a legal instance variable name, derived from aString"
| cleansedString |
cleansedString _ aString select: [:ch | ch isDigit or: [ch isLetter]].
(cleansedString isEmpty or: [cleansedString first isDigit])
ifTrue: [cleansedString _ 'a', cleansedString]
ifFalse: [cleansedString _ cleansedString withFirstCharacterDownshifted].
[self isLegalInstVarName: cleansedString] whileFalse:
[cleansedString _ cleansedString, 'x'].
^ cleansedString
"Scanner wellFormedInstanceVariableNameFrom: '234 xx\ Uml /ler42342380-4'"!
----- Method: Scanner>>advance (in category 'expression types') -----
advance
| prevToken |
prevToken _ token.
self scanToken.
^prevToken!
----- Method: Scanner>>checkpoint (in category 'expression types') -----
checkpoint
"Return a copy of all changeable state. See revertToCheckpoint:"
^ {self clone. source clone. currentComment copy}!
----- Method: Scanner>>errorMultibyteCharacter (in category 'error handling') -----
errorMultibyteCharacter
self error: 'multi-byte character is found at unexpected place'.
!
----- Method: Scanner>>initScanner (in category 'initialize-release') -----
initScanner
buffer _ WriteStream on: (String new: 40).
typeTable _ TypeTable!
----- Method: Scanner>>nextLiteral (in category 'expression types') -----
nextLiteral
"Same as advance, but -4 comes back as a number instead of two tokens"
| prevToken |
prevToken _ self advance.
(prevToken == #- and: [token isKindOf: Number])
ifTrue:
[^self advance negated].
^prevToken!
----- Method: Scanner>>notify: (in category 'error handling') -----
notify: string
"Refer to the comment in Object|notify:."
self error: string!
----- Method: Scanner>>offEnd: (in category 'error handling') -----
offEnd: aString
"Parser overrides this"
^self notify: aString!
----- Method: Scanner>>revertToCheckpoint: (in category 'expression types') -----
revertToCheckpoint: checkpoint
"Revert to the state when checkpoint was made."
| myCopy |
myCopy _ checkpoint first.
1 to: self class instSize do:
[:i | self instVarAt: i put: (myCopy instVarAt: i)].
source _ checkpoint second.
currentComment _ checkpoint third!
----- Method: Scanner>>scan: (in category 'initialize-release') -----
scan: inputStream
"Bind the input stream, fill the character buffers and first token buffer."
source _ inputStream.
self step.
self step.
self scanToken!
----- Method: Scanner>>scanFieldNames: (in category 'public access') -----
scanFieldNames: stringOrArray
"Answer an Array of Strings that are the identifiers in the input string,
stringOrArray. If passed an Array, just answer with that Array, i.e.,
assume it has already been scanned."
| strm |
(stringOrArray isMemberOf: Array)
ifTrue: [^stringOrArray].
self scan: (ReadStream on: stringOrArray asString).
strm _ WriteStream on: (Array new: 10).
[tokenType = #doIt]
whileFalse:
[tokenType = #word ifTrue: [strm nextPut: token].
self scanToken].
^strm contents
"Scanner new scanFieldNames: 'abc def ghi' ('abc' 'def' 'ghi' )"!
----- Method: Scanner>>scanLitVec (in category 'expression types') -----
scanLitVec
| s |
s _ WriteStream on: (Array new: 16).
[tokenType = #rightParenthesis or: [tokenType = #doIt]]
whileFalse:
[tokenType = #leftParenthesis
ifTrue:
[self scanToken; scanLitVec]
ifFalse:
[tokenType = #word | (tokenType = #keyword) | (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 ifAbsent: [#xLetter])) = #xDigit])
ifTrue:
[self scanToken.
token _ token negated]]].
s nextPut: token.
self scanToken].
token _ s contents!
----- Method: Scanner>>scanLitWord (in category 'expression types') -----
scanLitWord
"Accumulate keywords and asSymbol the result."
| t |
[(typeTable at: hereChar asciiValue ifAbsent: [#xLetter]) = #xLetter] whileTrue: [
t _ token.
self xLetter.
token _ t , token
].
token _ token asSymbol.
!
----- Method: Scanner>>scanMessageParts: (in category 'public access') -----
scanMessageParts: sourceString
"Return an array of the form (comment keyword comment arg comment keyword comment arg comment) for the message pattern of this method. Courtesy of Ted Kaehler, June 1999"
| coll nonKeywords |
coll _ OrderedCollection new.
self scan: (ReadStream on: sourceString asString).
nonKeywords _ 0.
[tokenType = #doIt] whileFalse:
[(currentComment == nil or: [currentComment isEmpty])
ifTrue: [coll addLast: nil]
ifFalse: [coll addLast: currentComment removeFirst.
[currentComment isEmpty] whileFalse:
[coll at: coll size put: (coll last, ' ', currentComment removeFirst)]].
(token numArgs < 1 or: [(token = #|) & (coll size > 1)])
ifTrue: [(nonKeywords _ nonKeywords + 1) > 1 ifTrue: [^ coll]]
"done with header"
ifFalse: [nonKeywords _ 0].
coll addLast: token.
self scanToken].
(currentComment == nil or: [currentComment isEmpty])
ifTrue: [coll addLast: nil]
ifFalse: [coll addLast: currentComment removeFirst.
[currentComment isEmpty] whileFalse: [
coll at: coll size put: (coll last, ' ', currentComment removeFirst)]].
^ coll!
----- Method: Scanner>>scanStringStruct (in category 'expression types') -----
scanStringStruct
| s |
s _ WriteStream on: (Array new: 16).
[tokenType = #rightParenthesis or: [tokenType = #doIt]]
whileFalse:
[tokenType = #leftParenthesis
ifTrue:
[self scanToken; scanStringStruct]
ifFalse:
[tokenType = #word ifFalse:
[^self error: 'only words and parens allowed']].
s nextPut: token.
self scanToken].
token _ s contents!
----- Method: Scanner>>scanStringStruct: (in category 'public access') -----
scanStringStruct: textOrString
"The input is a string whose elements are identifiers and parenthesized
groups of identifiers. Answer an array reflecting that structure, representing
each identifier by an uninterned string."
self scan: (ReadStream on: textOrString asString).
self scanStringStruct.
^token
"Scanner new scanStringStruct: 'a b (c d) (e f g)'"!
----- Method: Scanner>>scanToken (in category 'expression types') -----
scanToken
[(tokenType _ typeTable at: hereChar asciiValue ifAbsent: [#xLetter]) == #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.
!
----- Method: Scanner>>scanTokens: (in category 'public access') -----
scanTokens: textOrString
"Answer an Array that has been tokenized as though the input text,
textOrString, had appeared between the array delimitors #( and ) in a
Smalltalk literal expression."
self scan: (ReadStream on: textOrString asString).
self scanLitVec.
^token
"Scanner new scanTokens: 'identifier keyword: 8r31 ''string'' .'"!
----- Method: Scanner>>step (in category 'expression types') -----
step
| c |
c _ hereChar.
hereChar _ aheadChar.
source atEnd
ifTrue: [aheadChar _ 30 asCharacter "doit"]
ifFalse: [aheadChar _ source next].
^c!
----- Method: Scanner>>xBinary (in category 'multi-character scans') -----
xBinary
tokenType _ #binary.
token _ self step asSymbol.
[| type |
type _ typeTable at: hereChar asciiValue ifAbsent: [#xLetter].
type == #xBinary and: [hereChar ~= $-]] whileTrue: [
token _ (token, (String with: self step)) asSymbol].
!
----- Method: Scanner>>xColon (in category 'multi-character scans') -----
xColon "Allow := for assignment by converting to #_ "
aheadChar = $= ifTrue:
[self step.
tokenType _ #leftArrow.
self step.
^ token _ #'_'].
"Otherwise, just do what normal scan of colon would do"
tokenType _ #colon.
^ token _ self step asSymbol!
----- Method: Scanner>>xDelimiter (in category 'multi-character scans') -----
xDelimiter
"Ignore blanks, etc."
self scanToken!
----- Method: Scanner>>xDigit (in category 'multi-character scans') -----
xDigit
"Form a number."
tokenType _ #number.
(aheadChar = 30 asCharacter and: [source atEnd
and: [source skip: -1. source next ~= 30 asCharacter]])
ifTrue: [source skip: -1 "Read off the end last time"]
ifFalse: [source skip: -2].
token _ [Number readFrom: source] ifError: [:err :rcvr | self offEnd: err].
self step; step!
----- Method: Scanner>>xDollar (in category 'multi-character scans') -----
xDollar
"Form a Character literal."
self step. "pass over $"
token _ self step.
tokenType _ #number "really should be Char, but rest of compiler doesn't know"!
----- Method: Scanner>>xDoubleQuote (in category 'multi-character scans') -----
xDoubleQuote
"Collect a comment."
"wod 1/10/98: Allow 'empty' comments by testing the first character
for $"" rather than blindly adding it to the comment being collected."
| aStream stopChar |
stopChar _ 30 asCharacter.
aStream _ WriteStream on: (String new: 200).
self step.
[hereChar = $"]
whileFalse:
[(hereChar = stopChar and: [source atEnd])
ifTrue: [^self offEnd: 'Unmatched comment quote'].
aStream nextPut: self step.].
self step.
currentComment == nil
ifTrue: [currentComment _ OrderedCollection with: aStream
contents]
ifFalse: [currentComment add: aStream contents].
self scanToken.
!
----- Method: Scanner>>xLetter (in category 'multi-character scans') -----
xLetter
"Form a word or keyword."
| type c |
buffer reset.
[c _ hereChar asciiValue.
(type _ typeTable at: c ifAbsent: [#xLetter]) == #xLetter or: [type == #xDigit]]
whileTrue: ["open code step for speed"
buffer nextPut: hereChar.
hereChar _ aheadChar.
source atEnd
ifTrue: [aheadChar _ 30 asCharacter
"doit"]
ifFalse: [aheadChar _ source next]].
(type == #colon or: [type == #xColon and: [aheadChar ~= $=]])
ifTrue: [buffer nextPut: self step.
["Allow any number of embedded colons in literal symbols"
(typeTable at: hereChar asciiValue ifAbsent: [#xLetter])
== #xColon]
whileTrue: [buffer nextPut: self step].
tokenType _ #keyword]
ifFalse: [tokenType _ #word].
token _ buffer contents.
token isOctetString ifTrue: [token _ token asOctetString].
!
----- Method: Scanner>>xLitQuote (in category 'multi-character scans') -----
xLitQuote
"Symbols and vectors: #(1 (4 5) 2 3) #ifTrue:ifFalse: #'abc'."
| start |
start _ mark.
self step. "litQuote"
self scanToken.
tokenType = #leftParenthesis
ifTrue:
[self scanToken; scanLitVec.
mark _ start+1.
tokenType == #doIt
ifTrue: [self offEnd: 'Unmatched parenthesis']]
ifFalse:
[(#(word keyword colon ) includes: tokenType)
ifTrue:
[self scanLitWord]
ifFalse:
[(tokenType==#literal)
ifTrue:
[(token isSymbol)
ifTrue: "##word"
[token _ token "May want to move toward ANSI here"]]
ifFalse:
[tokenType==#string ifTrue: [token _ token asSymbol]]]].
mark _ start.
tokenType _ #literal
" #(Pen)
#Pen
#'Pen'
##Pen
###Pen
"!
----- Method: Scanner>>xSingleQuote (in category 'multi-character scans') -----
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.
token isOctetString ifTrue: [token _ token asOctetString].
tokenType _ #string.
!
Object subclass: #SyntaxAttribute
instanceVariableNames: 'color emphasis attributeList'
classVariableNames: ''
poolDictionaries: ''
category: 'Compiler-Support'!
!SyntaxAttribute commentStamp: '<historical>' prior: 0!
Represents a color and possibly a style attribute to be applied to a syntactic element for pretty-printing. The attributeList inst var is a cache.!
----- Method: SyntaxAttribute class>>color:emphasis: (in category 'as yet unclassified') -----
color: aColor emphasis: anEmphasis
^ self new color: aColor; emphasis: anEmphasis; yourself!
----- Method: SyntaxAttribute>>attributeList (in category 'accessing') -----
attributeList
"Answer a list of text attributes that characterize the receiver"
attributeList ifNil:
[attributeList _ OrderedCollection new: 2.
color ifNotNil: [attributeList add: (TextColor color: color)].
emphasis ifNotNil: [attributeList add: (TextEmphasis perform: emphasis)]].
^ attributeList!
----- Method: SyntaxAttribute>>color (in category 'accessing') -----
color
^ color!
----- Method: SyntaxAttribute>>color: (in category 'accessing') -----
color: aTextColor
color _ aTextColor.
attributeList _ nil!
----- Method: SyntaxAttribute>>emphasis (in category 'accessing') -----
emphasis
^ emphasis!
----- Method: SyntaxAttribute>>emphasis: (in category 'accessing') -----
emphasis: aTextEmphasis
emphasis _ aTextEmphasis.
attributeList _ nil!
TextStream subclass: #ColoredCodeStream
instanceVariableNames: 'dialect colorTable'
classVariableNames: 'ST80ColorTable'
poolDictionaries: ''
category: 'Compiler-Kernel'!
----- Method: ColoredCodeStream class>>contents: (in category 'instance creation') -----
contents: blockWithArg
"Evaluate blockWithArg on a DialectStream of the given description"
| stream |
stream _ self on: (Text new: 400).
blockWithArg value: stream.
^ stream contents!
----- Method: ColoredCodeStream class>>initialize (in category 'class initialization') -----
initialize
"Initialize the colors that characterize the ST80 dialect"
ST80ColorTable _ IdentityDictionary new.
#( (temporaryVariable blue italic)
(methodArgument blue normal)
(methodSelector black bold)
(blockArgument red normal)
(comment brown normal)
(variable magenta normal)
(literal orange normal)
(keyword darkGray bold)
(prefixKeyword veryDarkGray bold)
(setOrReturn black bold)) do:
[:aTriplet |
ST80ColorTable at: aTriplet first put: aTriplet allButFirst]
"ColoredCodeStream initialize"!
----- Method: ColoredCodeStream>>colorTable (in category 'color/style') -----
colorTable
"Answer the table to use to determine colors"
^ colorTable ifNil: [colorTable _ ST80ColorTable]!
----- Method: ColoredCodeStream>>withColor:emphasis:do: (in category 'color/style') -----
withColor: colorSymbol emphasis: emphasisSymbol do: aBlock
"Evaluate the given block with the given color and style text attribute"
^ self withAttributes: {TextColor color: (Color perform: colorSymbol).
TextEmphasis perform: emphasisSymbol}
do: aBlock!
----- Method: ColoredCodeStream>>withStyleFor:do: (in category 'color/style') -----
withStyleFor: elementType do: aBlock
"Evaluate aBlock with appropriate emphasis and color for the given elementType"
| colorAndStyle |
colorAndStyle _ self colorTable at: elementType.
^ self withColor: colorAndStyle first emphasis: colorAndStyle second do: aBlock!
TestCase subclass: #ArrayLiteralTest
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Compiler-Tests'!
----- Method: ArrayLiteralTest>>tearDown (in category 'initialize-release') -----
tearDown
self class removeSelector: #array!
----- Method: ArrayLiteralTest>>testReservedIdentifiers (in category 'tests') -----
testReservedIdentifiers
self class compile: 'array ^ #(nil true false)'.
self assert: self array = {nil. true. false}.!
----- Method: ArrayLiteralTest>>testSymbols (in category 'tests') -----
testSymbols
self class compile: 'array ^ #(#nil #true #false #''nil'' #''true'' #''false'')'.
self assert: self array = {#nil. #true. #false. #nil. #true. #false}.!
----- Method: Dictionary>>bindingOf: (in category '*Compiler') -----
bindingOf: varName
^self associationAt: varName ifAbsent:[nil]!
----- Method: Dictionary>>bindingsDo: (in category '*Compiler') -----
bindingsDo: aBlock
^self associationsDo: aBlock!
Dictionary subclass: #LiteralDictionary
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Compiler-Support'!
!LiteralDictionary commentStamp: '<historical>' prior: 0!
A LiteralDictionary, like an IdentityDictionary, has a special test for equality. In this case it is simple equality between objects of like class. This allows equal Float or String literals to be shared without the possibility of erroneously sharing, say, 1 and 1.0!
----- Method: LiteralDictionary>>arrayEquality:and: (in category 'as yet unclassified') -----
arrayEquality: x and: y
x size = y size ifFalse: [^ false].
x with: y do: [:e1 :e2 |
(self literalEquality: e1 and: e2) ifFalse: [^ false]
].
^true.
!
----- Method: LiteralDictionary>>literalEquality:and: (in category 'as yet unclassified') -----
literalEquality: x and: y
^ (x class = Array and: [y class = Array]) ifTrue: [
self arrayEquality: x and: y.
] ifFalse: [
(x class == y class) and: [x = y]
].
!
----- Method: LiteralDictionary>>scanFor: (in category 'as yet unclassified') -----
scanFor: anObject
"Scan the key array for the first slot containing either a nil (indicating an empty slot) or an element that matches anObject. Answer the index of that slot or zero if no slot is found. This method will be overridden in various subclasses that have different interpretations for matching elements."
| element start finish |
finish _ array size.
start _ (anObject hash \\ finish) + 1.
"Search from (hash mod size) to the end."
start to: finish do:
[:index | ((element _ array at: index) == nil
or: [self literalEquality: element key and: anObject])
ifTrue: [^ index ]].
"Search from 1 to where we started."
1 to: start-1 do:
[:index | ((element _ array at: index) == nil
or: [self literalEquality: element key and: anObject])
ifTrue: [^ index ]].
^ 0 "No match AND no empty slot"!
InstructionStream subclass: #Decompiler
instanceVariableNames: 'constructor method instVars tempVars constTable stack statements lastPc exit caseExits lastJumpPc lastReturnPc limit hasValue blockStackBase'
classVariableNames: 'ArgumentFlag CascadeFlag IfNilFlag CaseFlag'
poolDictionaries: ''
category: 'Compiler-Kernel'!
!Decompiler commentStamp: 'ls 1/28/2004 13:31' prior: 0!
I decompile a method in three phases:
Reverser: postfix byte codes -> prefix symbolic codes (nodes and atoms)
Parser: prefix symbolic codes -> node tree (same as the compiler)
Printer: node tree -> text (done by the nodes)
instance vars:
constructor
method
instVars
tempVars
constTable
stack
statements
lastPc
exit
caseExits - stack of exit addresses that have been seen in the branches of caseOf:'s
lastJumpPc
lastReturnPc
limit
hasValue
blockStackBase!
----- Method: Decompiler class>>initialize (in category 'class initialization') -----
initialize
CascadeFlag _ 'cascade'. "A unique object"
CaseFlag _ 'case'. "Ditto"
ArgumentFlag _ 'argument'. "Ditto"
IfNilFlag _ 'ifNil'. "Ditto"
"Decompiler initialize"!
----- Method: Decompiler class>>recompileAllTest (in category 'testing') -----
recompileAllTest
"[self recompileAllTest]"
"decompile every method and compile it back; if the decompiler is correct then the system should keep running. :)"
| decompiled ast compiled |
SystemNavigation default allBehaviorsDo: [ :behavior |
Utilities informUser: (behavior printString) during: [
behavior selectors do: [ :sel |
decompiled := Decompiler new decompile: sel in: behavior.
ast := Compiler new compile: decompiled in: behavior notifying: nil ifFail: [ self error: 'failed' ].
compiled := ast generate: (behavior compiledMethodAt: sel) trailer.
behavior addSelector: sel withMethod: compiled. ] ] ]!
----- Method: Decompiler>>blockForCaseTo: (in category 'control') -----
blockForCaseTo: end
"Decompile a range of code as in statementsForCaseTo:, but return a block node."
| exprs block oldBase |
oldBase _ blockStackBase.
blockStackBase _ stack size.
exprs _ self statementsForCaseTo: end.
block _ constructor codeBlock: exprs returns: lastReturnPc = lastPc.
blockStackBase _ oldBase.
lastReturnPc _ -1. "So as not to mislead outer calls"
^block!
----- Method: Decompiler>>blockReturnTop (in category 'instruction decoding') -----
blockReturnTop
"No action needed"!
----- Method: Decompiler>>blockTo: (in category 'control') -----
blockTo: end
"Decompile a range of code as in statementsTo:, but return a block node."
| exprs block oldBase |
oldBase _ blockStackBase.
blockStackBase _ stack size.
exprs _ self statementsTo: end.
block _ constructor codeBlock: exprs returns: lastReturnPc = lastPc.
blockStackBase _ oldBase.
lastReturnPc _ -1. "So as not to mislead outer calls"
^block!
----- Method: Decompiler>>case: (in category 'instruction decoding') -----
case: dist
"statements = keyStmts CascadeFlag keyValueBlock ... keyStmts"
| nextCase thenJump stmtStream elements b node cases otherBlock myExits |
nextCase _ pc + dist.
"Now add CascadeFlag & keyValueBlock to statements"
statements addLast: stack removeLast.
stack addLast: CaseFlag. "set for next pop"
statements addLast: (self blockForCaseTo: nextCase).
stack last == CaseFlag
ifTrue: "Last case"
["ensure jump is within block (in case thenExpr returns wierdly I guess)"
stack removeLast. "get rid of CaseFlag"
stmtStream _ ReadStream on: (self popTo: stack removeLast).
elements _ OrderedCollection new.
b _ OrderedCollection new.
[stmtStream atEnd] whileFalse:
[(node _ stmtStream next) == CascadeFlag
ifTrue:
[elements addLast: (constructor
codeMessage: (constructor codeBlock: b returns: false)
selector: (constructor codeSelector: #-> code: #macro)
arguments: (Array with: stmtStream next)).
b _ OrderedCollection new]
ifFalse: [b addLast: node]].
b size > 0 ifTrue: [self error: 'Bad cases'].
cases _ constructor codeBrace: elements.
"try find the end of the case"
myExits := caseExits removeLast: elements size.
myExits := myExits reject: [ :e | e isNil or: [ e < 0 or: [ e > method size ] ] ].
myExits isEmpty
ifTrue: [ thenJump := nextCase ]
ifFalse: [ thenJump := myExits min ].
otherBlock _ self blockTo: thenJump.
stack addLast:
(constructor
codeMessage: stack removeLast
selector: (constructor codeSelector: #caseOf:otherwise: code: #macro)
arguments: (Array with: cases with: otherBlock)).
myExits isEmpty ifTrue:[
"all branches returned; pop off the statement"
statements addLast: stack removeLast. ] ].!
----- Method: Decompiler>>checkForBlock: (in category 'control') -----
checkForBlock: receiver
"We just saw a blockCopy: message. Check for a following block."
| savePc jump args argPos block |
receiver == constructor codeThisContext ifFalse: [^false].
savePc _ pc.
(jump _ self interpretJump) notNil
ifFalse:
[pc _ savePc. ^nil].
"Definitely a block"
jump _ jump + pc.
argPos _ statements size.
[self willStorePop]
whileTrue:
[stack addLast: ArgumentFlag. "Flag for doStore:"
self interpretNextInstructionFor: self].
args _ Array new: statements size - argPos.
1 to: args size do: "Retrieve args"
[:i | args at: i put: statements removeLast.
(args at: i) scope: -1 "flag args as block temps"].
block _ self blockTo: jump.
stack addLast: (constructor codeArguments: args block: block).
^true!
----- Method: Decompiler>>convertToDoLoop (in category 'private') -----
convertToDoLoop
"If statements contains the pattern
var _ startExpr.
[var <= limit] whileTrue: [...statements... var _ var + incConst]
then replace this by
startExpr to: limit by: incConst do: [:var | ...statements...]"
| initStmt toDoStmt limitStmt |
statements size < 2 ifTrue: [^ self].
initStmt _ statements at: statements size-1.
(toDoStmt _ statements last toDoFromWhileWithInit: initStmt)
== nil ifTrue: [^ self].
initStmt variable scope: -1. "Flag arg as block temp"
statements removeLast; removeLast; addLast: toDoStmt.
"Attempt further conversion of the pattern
limitVar _ limitExpr.
startExpr to: limitVar by: incConst do: [:var | ...statements...]
to
startExpr to: limitExpr by: incConst do: [:var | ...statements...]"
statements size < 2 ifTrue: [^ self].
limitStmt _ statements at: statements size-1.
((limitStmt isMemberOf: AssignmentNode)
and: [limitStmt variable isTemp
and: [limitStmt variable == toDoStmt arguments first
and: [self methodRefersOnlyOnceToTemp: limitStmt variable fieldOffset]]])
ifFalse: [^ self].
toDoStmt arguments at: 1 put: limitStmt value.
limitStmt variable scope: -2. "Flag limit var so it won't print"
statements removeLast; removeLast; addLast: toDoStmt.
!
----- Method: Decompiler>>decompile:in: (in category 'public access') -----
decompile: aSelector in: aClass
"See Decompiler|decompile:in:method:. The method is found by looking up
the message, aSelector, in the method dictionary of the class, aClass."
^self
decompile: aSelector
in: aClass
method: (aClass compiledMethodAt: aSelector)!
----- Method: Decompiler>>decompile:in:method: (in category 'public access') -----
decompile: aSelector in: aClass method: aMethod
"Answer a MethodNode that is the root of the parse tree for the
argument, aMethod, which is the CompiledMethod associated with the
message, aSelector. Variables are determined with respect to the
argument, aClass."
^self
decompile: aSelector
in: aClass
method: aMethod
using: DecompilerConstructor new!
----- Method: Decompiler>>decompile:in:method:using: (in category 'private') -----
decompile: aSelector in: aClass method: aMethod using: aConstructor
| block |
constructor _ aConstructor.
method _ aMethod.
self initSymbols: aClass. "create symbol tables"
method isQuick
ifTrue: [block _ self quickMethod]
ifFalse:
[stack _ OrderedCollection new: method frameSize.
caseExits _ OrderedCollection new.
statements _ OrderedCollection new: 20.
super method: method pc: method initialPC.
block _ self blockTo: method endPC + 1.
stack isEmpty ifFalse: [self error: 'stack not empty']].
^constructor
codeMethod: aSelector
block: block
tempVars: tempVars
primitive: method primitive
class: aClass!
----- Method: Decompiler>>decompileBlock: (in category 'public access') -----
decompileBlock: aBlock
"Decompile aBlock, returning the result as a BlockNode.
Show temp names from source if available."
| startpc end homeClass blockNode home |
(home := aBlock home) ifNil: [^ nil].
(homeClass := home methodClass) ifNil: [^ nil].
method := home method.
constructor := DecompilerConstructor new.
self withTempNames: method methodNode tempNames.
self initSymbols: homeClass.
startpc _ aBlock startpc.
end _ aBlock endPC.
stack _ OrderedCollection new: method frameSize.
caseExits _ OrderedCollection new.
statements _ OrderedCollection new: 20.
super method: method pc: startpc - 5.
blockNode _ self blockTo: end.
stack isEmpty ifFalse: [self error: 'stack not empty'].
^ blockNode statements first
"Decompiler new decompileBlock: [3 + 4]"!
----- Method: Decompiler>>doDup (in category 'instruction decoding') -----
doDup
stack last == CascadeFlag
ifFalse:
["Save position and mark cascade"
stack addLast: statements size.
stack addLast: CascadeFlag].
stack addLast: CascadeFlag!
----- Method: Decompiler>>doPop (in category 'instruction decoding') -----
doPop
stack isEmpty ifTrue:
["Ignore pop in first leg of ifNil for value"
^ self].
stack last == CaseFlag
ifTrue: [stack removeLast]
ifFalse: [statements addLast: stack removeLast].!
----- Method: Decompiler>>doStore: (in category 'instruction decoding') -----
doStore: stackOrBlock
"Only called internally, not from InstructionStream. StackOrBlock is stack
for store, statements for storePop."
| var expr |
var _ stack removeLast.
expr _ stack removeLast.
stackOrBlock addLast: (expr == ArgumentFlag
ifTrue: [var]
ifFalse: [constructor codeAssignTo: var value: expr])!
----- Method: Decompiler>>initSymbols: (in category 'initialize-release') -----
initSymbols: aClass
| nTemps namedTemps |
constructor method: method class: aClass literals: method literals.
constTable _ constructor codeConstants.
instVars _ Array new: aClass instSize.
nTemps _ method numTemps.
namedTemps _ tempVars ifNil: [method tempNames].
tempVars _ (1 to: nTemps) collect:
[:i | i <= namedTemps size
ifTrue: [constructor codeTemp: i - 1 named: (namedTemps at: i)]
ifFalse: [constructor codeTemp: i - 1]]!
----- Method: Decompiler>>interpretNextInstructionFor: (in category 'private') -----
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, '>'.
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!
----- Method: Decompiler>>jump: (in category 'instruction decoding') -----
jump: dist
exit _ pc + dist.
lastJumpPc _ lastPc!
----- Method: Decompiler>>jump:if: (in category 'instruction decoding') -----
jump: dist if: condition
| savePc elseDist sign elsePc elseStart end cond ifExpr thenBlock elseBlock thenJump
elseJump condHasValue b isIfNil saveStack |
stack last == CascadeFlag ifTrue: [^ self case: dist].
elsePc _ lastPc.
elseStart _ pc + dist.
end _ limit.
"Check for bfp-jmp to invert condition.
Don't be fooled by a loop with a null body."
sign _ condition.
savePc _ pc.
((elseDist _ self interpretJump) notNil and: [elseDist >= 0 and: [elseStart = pc]])
ifTrue: [sign _ sign not. elseStart _ pc + elseDist].
pc _ savePc.
ifExpr _ stack removeLast.
(stack size > 0 and: [stack last == IfNilFlag])
ifTrue: [stack removeLast. isIfNil _ true]
ifFalse: [isIfNil _ false].
saveStack _ stack.
stack _ OrderedCollection new.
thenBlock _ self blockTo: elseStart.
condHasValue _ hasValue or: [isIfNil].
"ensure jump is within block (in case thenExpr returns)"
thenJump _ exit <= end ifTrue: [exit] ifFalse: [elseStart].
"if jump goes back, then it's a loop"
thenJump < elseStart
ifTrue:
["Must be a while loop...
thenJump will jump to the beginning of the while expr. In the case of
while's with a block in the condition, the while expr
should include more than just the last expression: find all the
statements needed by re-decompiling."
stack _ saveStack.
pc _ thenJump.
b _ self statementsTo: elsePc.
"discard unwanted statements from block"
b size - 1 timesRepeat: [statements removeLast].
statements addLast: (constructor
codeMessage: (constructor codeBlock: b returns: false)
selector: (constructor codeSelector: (sign ifTrue: [#whileFalse:] ifFalse: [#whileTrue:]) code: #macro)
arguments: (Array with: thenBlock)).
pc _ elseStart.
self convertToDoLoop]
ifFalse:
["Must be a conditional..."
elseBlock _ self blockTo: thenJump.
elseJump _ exit.
"if elseJump is backwards, it is not part of the elseExpr"
elseJump < elsePc
ifTrue: [pc _ lastPc].
isIfNil
ifTrue: [cond _ constructor
codeMessage: ifExpr ifNilReceiver
selector: (sign
ifTrue: [constructor codeSelector: #ifNotNil: code: #macro]
ifFalse: [constructor codeSelector: #ifNil: code: #macro])
arguments: (Array with: thenBlock)]
ifFalse: [cond _ constructor
codeMessage: ifExpr
selector: (constructor codeSelector: #ifTrue:ifFalse: code: #macro)
arguments:
(sign
ifTrue: [Array with: elseBlock with: thenBlock]
ifFalse: [Array with: thenBlock with: elseBlock])].
stack _ saveStack.
condHasValue
ifTrue: [stack addLast: cond]
ifFalse: [statements addLast: cond]]!
----- Method: Decompiler>>methodRefersOnlyOnceToTemp: (in category 'private') -----
methodRefersOnlyOnceToTemp: offset
| nRefs byteCode extension scanner |
nRefs _ 0.
offset <= 15
ifTrue:
[byteCode _ 16 + offset.
(InstructionStream on: method) scanFor:
[:instr | instr = byteCode ifTrue: [nRefs _ nRefs + 1].
nRefs > 1]]
ifFalse:
[extension _ 64 + offset.
scanner _ InstructionStream on: method.
scanner scanFor:
[:instr | (instr = 128 and: [scanner followingByte = extension])
ifTrue: [nRefs _ nRefs + 1].
nRefs > 1]].
^ nRefs = 1
!
----- Method: Decompiler>>methodReturnConstant: (in category 'instruction decoding') -----
methodReturnConstant: value
self pushConstant: value; methodReturnTop!
----- Method: Decompiler>>methodReturnReceiver (in category 'instruction decoding') -----
methodReturnReceiver
self pushReceiver; methodReturnTop!
----- Method: Decompiler>>methodReturnTop (in category 'instruction decoding') -----
methodReturnTop
| last |
last _ stack removeLast "test test" asReturnNode.
stack size > blockStackBase "get effect of elided pop before return"
ifTrue: [statements addLast: stack removeLast].
exit _ method size + 1.
lastJumpPc _ lastReturnPc _ lastPc.
statements addLast: last!
----- Method: Decompiler>>popIntoLiteralVariable: (in category 'instruction decoding') -----
popIntoLiteralVariable: value
self pushLiteralVariable: value; doStore: statements!
----- Method: Decompiler>>popIntoReceiverVariable: (in category 'instruction decoding') -----
popIntoReceiverVariable: offset
self pushReceiverVariable: offset; doStore: statements!
----- Method: Decompiler>>popIntoTemporaryVariable: (in category 'instruction decoding') -----
popIntoTemporaryVariable: offset
self pushTemporaryVariable: offset; doStore: statements!
----- Method: Decompiler>>popTo: (in category 'private') -----
popTo: oldPos
| t |
t _ Array new: statements size - oldPos.
(t size to: 1 by: -1) do:
[:i | t at: i put: statements removeLast].
^t!
----- Method: Decompiler>>pushActiveContext (in category 'instruction decoding') -----
pushActiveContext
stack addLast: constructor codeThisContext!
----- Method: Decompiler>>pushConstant: (in category 'instruction decoding') -----
pushConstant: value
| node |
node _ value == true ifTrue: [constTable at: 2]
ifFalse: [value == false ifTrue: [constTable at: 3]
ifFalse: [value == nil ifTrue: [constTable at: 4]
ifFalse: [constructor codeAnyLiteral: value]]].
stack addLast: node!
----- Method: Decompiler>>pushLiteralVariable: (in category 'instruction decoding') -----
pushLiteralVariable: assoc
stack addLast: (constructor codeAnyLitInd: assoc)!
----- Method: Decompiler>>pushReceiver (in category 'instruction decoding') -----
pushReceiver
stack addLast: (constTable at: 1)!
----- Method: Decompiler>>pushReceiverVariable: (in category 'instruction decoding') -----
pushReceiverVariable: offset
| var |
(var _ instVars at: offset + 1 ifAbsent: []) == nil
ifTrue:
["Not set up yet"
var _ constructor codeInst: offset.
instVars size < (offset + 1) ifTrue: [
instVars _ (Array new: offset + 1)
replaceFrom: 1 to: instVars size with: instVars; yourself ].
instVars at: offset + 1 put: var].
stack addLast: var!
----- Method: Decompiler>>pushTemporaryVariable: (in category 'instruction decoding') -----
pushTemporaryVariable: offset
stack addLast: (tempVars at: offset + 1)!
----- Method: Decompiler>>quickMethod (in category 'private') -----
quickMethod
| |
method isReturnSpecial
ifTrue: [^ constructor codeBlock:
(Array with: (constTable at: method primitive - 255)) returns: true].
method isReturnField
ifTrue: [^ constructor codeBlock:
(Array with: (constructor codeInst: method returnField)) returns: true].
self error: 'improper short method'!
----- Method: Decompiler>>send:super:numArgs: (in category 'instruction decoding') -----
send: selector super: superFlag numArgs: numArgs
| args rcvr selNode msgNode messages |
args _ Array new: numArgs.
(numArgs to: 1 by: -1) do:
[:i | args at: i put: stack removeLast].
rcvr _ stack removeLast.
superFlag ifTrue: [rcvr _ constructor codeSuper].
(selector == #blockCopy: and: [self checkForBlock: rcvr])
ifFalse:
[selNode _ constructor codeAnySelector: selector.
rcvr == CascadeFlag
ifTrue:
["May actually be a cascade or an ifNil: for value."
self willJumpIfFalse
ifTrue: "= generated by a case macro"
[selector == #= ifTrue:
[" = signals a case statement..."
statements addLast: args first.
stack addLast: rcvr. "restore CascadeFlag"
^ self].
selector == #== ifTrue:
[" == signals an ifNil: for value..."
stack removeLast; removeLast.
rcvr _ stack removeLast.
stack addLast: IfNilFlag;
addLast: (constructor
codeMessage: rcvr
selector: selNode
arguments: args).
^ self].
self error: 'bad case: ', selector]
ifFalse:
[(self willJumpIfTrue and: [selector == #==]) ifTrue:
[" == signals an ifNotNil: for value..."
stack removeLast; removeLast.
rcvr _ stack removeLast.
stack addLast: IfNilFlag;
addLast: (constructor
codeMessage: rcvr
selector: selNode
arguments: args).
^ self].
msgNode _ constructor codeCascadedMessage: selNode
arguments: args].
stack last == CascadeFlag
ifFalse:
["Last message of a cascade"
statements addLast: msgNode.
messages _ self popTo: stack removeLast. "Depth saved by first dup"
msgNode _ constructor
codeCascade: stack removeLast
messages: messages]]
ifFalse:
[msgNode _ constructor
codeMessage: rcvr
selector: selNode
arguments: args].
stack addLast: msgNode]!
----- Method: Decompiler>>statementsForCaseTo: (in category 'control') -----
statementsForCaseTo: end
"Decompile the method from pc up to end and return an array of
expressions. If at run time this block will leave a value on the stack,
set hasValue to true. If the block ends with a jump or return, set exit
to the destination of the jump, or the end of the method; otherwise, set
exit = end. Leave pc = end.
Note that stack initially contains a CaseFlag which will be removed by
a subsequent Pop instruction, so adjust the StackPos accordingly."
| blockPos stackPos |
blockPos _ statements size.
stackPos _ stack size - 1. "Adjust for CaseFlag"
[pc < end]
whileTrue:
[lastPc _ pc. limit _ end. "for performs"
self interpretNextInstructionFor: self].
"If there is an additional item on the stack, it will be the value
of this block."
(hasValue _ stack size > stackPos)
ifTrue:
[stack last == CaseFlag
ifFalse: [ statements addLast: stack removeLast] ].
lastJumpPc = lastPc ifFalse: [exit _ pc].
caseExits add: exit.
^self popTo: blockPos!
----- Method: Decompiler>>statementsTo: (in category 'control') -----
statementsTo: end
"Decompile the method from pc up to end and return an array of
expressions. If at run time this block will leave a value on the stack,
set hasValue to true. If the block ends with a jump or return, set exit
to the destination of the jump, or the end of the method; otherwise, set
exit = end. Leave pc = end."
| blockPos stackPos t |
blockPos _ statements size.
stackPos _ stack size.
[pc < end]
whileTrue:
[lastPc _ pc. limit _ end. "for performs"
self interpretNextInstructionFor: self].
"If there is an additional item on the stack, it will be the value
of this block."
(hasValue _ stack size > stackPos)
ifTrue:
[statements addLast: stack removeLast].
lastJumpPc = lastPc ifFalse: [exit _ pc].
^self popTo: blockPos!
----- Method: Decompiler>>storeIntoLiteralVariable: (in category 'instruction decoding') -----
storeIntoLiteralVariable: assoc
self pushLiteralVariable: assoc; doStore: stack!
----- Method: Decompiler>>storeIntoReceiverVariable: (in category 'instruction decoding') -----
storeIntoReceiverVariable: offset
self pushReceiverVariable: offset; doStore: stack!
----- Method: Decompiler>>storeIntoTemporaryVariable: (in category 'instruction decoding') -----
storeIntoTemporaryVariable: offset
self pushTemporaryVariable: offset; doStore: stack!
----- Method: Decompiler>>tempAt: (in category 'public access') -----
tempAt: offset
"Needed by BraceConstructor<PopIntoTemporaryVariable"
^tempVars at: offset + 1!
----- Method: Decompiler>>withTempNames: (in category 'initialize-release') -----
withTempNames: tempNameArray
tempVars _ tempNameArray!
More information about the Packages
mailing list