'From VisualWorks(R), Release 2.5.1 of September 26, 1995 on January 26, 2000 at 9:59:06 pm'! Object subclass: #AGBlockClosure instanceVariableNames: 'block outerContext ' classVariableNames: 'MaxArg ' poolDictionaries: '' category: 'Zork_Abstract_Grammar'! AGBlockClosure comment: 'Comment: Instances of AGBlockClosure represent block closure expressions, conform the Smalltalk language (see BlockClosure). In practice, AG block closures are wrapped in regular Smalltalk block closures to ensure (greater) compatibility. Instance variables: block Block whose evaluation gave rise to the closure. outerContext Context for the closure. In certain cases contexts may be shared between a block and nested blocks. Class variables: MaxArg Maximum number of arguments for which we have generated the #asBlockClosure code so far. '! !AGBlockClosure methodsFor: 'converting'! asBlockClosure "Note: this is self-modifying code." | numArgs | (numArgs := block numArgs) = 0 ifTrue: [ ^ [ self value ]]. numArgs = 1 ifTrue: [ ^ [ :arg1 | self value: arg1 ]]. numArgs = 2 ifTrue: [ ^ [ :arg1 :arg2 | self value: arg1 value: arg2 ]]. numArgs = 3 ifTrue: [ ^ [ :arg1 :arg2 :arg3 | self value: arg1 value: arg2 value: arg3 ]]. self generateUpTo: numArgs. ^ self asBlockClosure! ! !AGBlockClosure methodsFor: 'evaluating'! value "Execute the closure without arguments. Answer the result." | numTemps | ^ (numTemps := block numTemps) = 0 ifTrue: [ block valueInContext: outerContext ] ifFalse: [ block valueInContext: (AGBlockContext outerContext: outerContext level: block level + 1 size: numTemps)]! value: arg "Execute the closure with given argument. Answer the result." | numTemps context | numTemps := block numTemps. context := AGBlockContext outerContext: outerContext level: block level + 1 size: numTemps + 1. context at: numTemps + 1 put: arg. ^ block valueInContext: context! value: arg1 value: arg2 "Execute the closure with given arguments. Answer the result." | numTemps context | numTemps := block numTemps. context := AGBlockContext outerContext: outerContext level: block level + 1 size: numTemps + 2. context at: numTemps + 1 put: arg1; at: numTemps + 2 put: arg2. ^ block valueInContext: context! value: arg1 value: arg2 value: arg3 "Execute the closure with given arguments. Answer the result." | numTemps context | numTemps := block numTemps. context := AGBlockContext outerContext: outerContext level: block level + 1 size: numTemps + 3. context at: numTemps + 1 put: arg1; at: numTemps + 2 put: arg2; at: numTemps + 3 put: arg3. ^ block valueInContext: context! valueWithArguments: anArray "Execute the closure with given arguments. Answer the result." | numTemps context | numTemps := block numTemps. context := AGBlockContext outerContext: outerContext level: block level + 1 size: numTemps + anArray size. 1 to: anArray size do: [ :i | context at: numTemps + i put: (anArray at: i)]. ^ block valueInContext: context! ! !AGBlockClosure methodsFor: 'initialize-release'! block: anAGBlock outerContext: anAGContext "Set block and evaluation context." block := anAGBlock. outerContext := anAGContext! ! !AGBlockClosure methodsFor: 'private-compiling'! baseCode "Answer the base code handling the common cases." ^'asBlockClosure "Note: this is self-modifying code." | numArgs | (numArgs := block numArgs) = 0 ifTrue: [ ^ [ self value ]]. numArgs = 1 ifTrue: [ ^ [ :arg1 | self value: arg1 ]]. numArgs = 2 ifTrue: [ ^ [ :arg1 :arg2 | self value: arg1 value: arg2 ]]. numArgs = 3 ifTrue: [ ^ [ :arg1 :arg2 :arg3 | self value: arg1 value: arg2 value: arg3 ]].'! generate: level on: aStream "Generate the code to handle given number of arguments." aStream nextPutAll: ' numArgs = '. level storeOn: aStream. aStream nextPutAll: ' ifTrue: [ ^ [ '. 1 to: level do: [ :i | aStream nextPutAll: ':arg'. i printOn: aStream. aStream space ]. aStream nextPutAll: '| | args | args := Array new: '. level printOn: aStream. aStream nextPutAll: '. '. 1 to: level do: [ :i | aStream nextPutAll: 'args at: '. i printOn: aStream. aStream nextPutAll: ' put: arg'. i printOn: aStream. aStream nextPutAll: '. ' ]. aStream nextPutAll: 'self valueWithArguments: args ]].'! generateUpTo: level "Generate the code handle up to given number of arguments." | stream | stream := WriteStream on: (String new: 1024). stream nextPutAll: self baseCode. MaxArg + 1 to: level do: [ :i | self generate: i on: stream ]. stream nextPutAll: self generatorCode. MaxArg := level. self class compile: stream contents classified: 'converting' notifying: nil! generatorCode "Answer the generator code." ^' self generateUpTo: numArgs. ^ self asBlockClosure'! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! AGBlockClosure class instanceVariableNames: ''! !AGBlockClosure class methodsFor: 'class initialization'! initialize "AGBlockClosure initialize." self initializeLevel. self installDefaultCode! initializeLevel "AGBlockClosure initializeLevel." MaxArg := 3! installDefaultCode "AGBlockClosure installDefaultCode." self compile: 'asBlockClosure "Note: this is self-modifying code." | numArgs | (numArgs := block numArgs) = 0 ifTrue: [ ^ [ self value ]]. numArgs = 1 ifTrue: [ ^ [ :arg1 | self value: arg1 ]]. numArgs = 2 ifTrue: [ ^ [ :arg1 :arg2 | self value: arg1 value: arg2 ]]. numArgs = 3 ifTrue: [ ^ [ :arg1 :arg2 :arg3 | self value: arg1 value: arg2 value: arg3 ]]. self generateUpTo: numArgs. ^ self asBlockClosure' classified: 'converting' notifying: nil! ! !AGBlockClosure class methodsFor: 'instance creation'! block: anAGBlock outerContext: anAGContext "Answer a new block closure on given block in given context. We wrap instances of AGBlockClosure in regular block closures, to make them compatible with the VisualWorks VM and with hard-wired references to class BlockClosure in the image. If it were not for the latter, we could easily reduce the number of wrappers to specific methods only, e.g. specially marked methods in the 'unwinding' protocol." ^ (self new block: anAGBlock outerContext: anAGContext) asBlockClosure! ! Object variableSubclass: #AGCodeContext instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Zork_Abstract_Grammar'! AGCodeContext comment: 'Comment: AGCodeContext is an abstract superclass for block and method contexts. These contexts provide access to receiver, temporary variables and arguments, to the return handler, and to parent contexts. Indexed instance variables: Subclasses store the values of their arguments and temporary arguments in indexed instance variables.'! !AGCodeContext methodsFor: 'accessing'! contextAt: lvl "Answer the context corresponding to given nesting depth." self subclassResponsibility! level "Answer the nesting depth. Derived from the block." self subclassResponsibility! methodClass "Answer the context's home method's method class." self subclassResponsibility! receiver "Answer the receiver." self subclassResponsibility! ! !AGCodeContext methodsFor: 'actions'! return: anObject "Return given object as the value of the currently executing method." self subclassResponsibility! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! AGCodeContext class instanceVariableNames: ''! AGCodeContext variableSubclass: #AGBlockContext instanceVariableNames: 'outerContext level ' classVariableNames: '' poolDictionaries: '' category: 'Zork_Abstract_Grammar'! AGBlockContext comment: 'Comment: Instances of AGBlockContext represent the contexts for block closures. Instance variables: level The nesting depth of the block. outerContext The outer context (cfr. Smalltalk).'! !AGBlockContext methodsFor: 'accessing'! contextAt: lvl "Answer the context corresponding to given nesting depth." ^ level = lvl ifTrue: [ self ] ifFalse: [ outerContext contextAt: lvl ]! level "Answer the nesting depth. Derived from the block." ^ level! methodClass "Answer the context's home method's method class." ^ self methodContext methodClass! receiver "Answer the receiver." ^ self methodContext receiver! ! !AGBlockContext methodsFor: 'actions'! return: anObject "Return given object as the value of the currently executing method." self methodContext return: anObject! ! !AGBlockContext methodsFor: 'initialize-release'! outerContext: anAGContext level: lvl "Initialize the outer context and nesting depth." outerContext := anAGContext. level := lvl! ! !AGBlockContext methodsFor: 'private-accessing'! methodContext "Answer the method context. This is the outer context's method context. If the outer context corresponds to a block closure, this will be called recursively, until a method context is reached." ^ outerContext methodContext! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! AGBlockContext class instanceVariableNames: ''! !AGBlockContext class methodsFor: 'instance creation'! outerContext: anAGCodeContext level: level size: size "Answer a new instance with given outer context and nesting depth, and enough slots to accomodate the values of argument and temporary variable bindings." ^ (self new: size) outerContext: anAGCodeContext level: level! ! AGCodeContext variableSubclass: #AGMethodContext instanceVariableNames: 'receiver method returnHandler ' classVariableNames: '' poolDictionaries: '' category: 'Zork_Abstract_Grammar'! AGMethodContext comment: 'Comment: Instances of AGMethodContext represent the contexts for executing a method. Instance variables: method The method for this context. receiver Receiver of the method invocation. returnHandler If nil, the method contains no return. If a (one-argument) block, used to implement a return (see AGMethod and AGReturn for more details); the return value is the block''s argument. '! !AGMethodContext methodsFor: 'accessing'! contextAt: lvl "Answer the context corresponding to given nesting depth. We should check the level, but assume everything is ok since we came here." ^ self! level "Answer the nesting depth. Is top-level for methods." ^ 1! methodClass "Answer the context's home method's method class." ^ method mclass! methodContext "Answer the method context. This is the receiver." ^ self! receiver "Answer the receiver." ^ receiver! ! !AGMethodContext methodsFor: 'actions'! return: anObject "Return given object as the value of the currently executing method." returnHandler value: anObject! ! !AGMethodContext methodsFor: 'initialize-release'! receiver: anObject method: anAGMethod returnHandler: aBlock "Install the receiver, method and return handler." receiver := anObject. method := anAGMethod. returnHandler := aBlock! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! AGMethodContext class instanceVariableNames: ''! !AGMethodContext class methodsFor: 'instance creation'! receiver: anObject method: anAGMethod size: size returnHandler: aBlock "Answer a new instance with given receiver, method and return handler, with enough slots to accomodate argument and temporary variable bindings." ^ (self new: size) receiver: anObject method: anAGMethod returnHandler: aBlock! ! Object variableSubclass: #AGExpression instanceVariableNames: 'activations ' classVariableNames: '' poolDictionaries: '' category: 'Zork_Abstract_Grammar'! AGExpression comment: 'Comment: Abstract superclass for the grammar expressions. Some of the subclasses use indexed instance variables to store some of their components. Note: The ''thisContext'' pseudo-variable is currently not supported. Instance variables: activations Keeps track of the number of times this expression has been activated.'! !AGExpression methodsFor: 'analysis'! activations "Answer the number of activations." ^ activations! ! !AGExpression methodsFor: 'enumerating'! nodesDo: aBlock "Enumerate the expression tree." aBlock value: self! ! !AGExpression methodsFor: 'evaluating'! eval: anAGContext "Evaluate the expression in given context." ^ self! ! !AGExpression methodsFor: 'initialize-release'! initialize "Initialize the number of activations." activations := 0! ! !AGExpression methodsFor: 'printing'! printOn: aStream "Print the expression on the stream." self printOn: aStream policy: self defaultPrintPolicy! printOn: aStream indent: level policy: anAGPrintPolicy "Print the expression on the stream with given indent and policy." self subclassResponsibility! printOn: aStream indent: level precedence: p policy: anAGPrintPolicy "Print the expression on the stream with given indent, taking into account the precedence ns given policy." self printOn: aStream indent: level policy: anAGPrintPolicy! printOn: aStream policy: anAGPrintPolicy "Print the expression on the stream with given policy." self printOn: aStream indent: 0 policy: anAGPrintPolicy! printText "Answer a textual representation of the expression. Used to carry emphasis." ^ self printText: self defaultPrintPolicy! printText: anAGPrintPolicy "Answer a textual representation of the expression using given policy. Used to carry emphasis." | stream | stream := TextStream on: (String new: 128). self printOn: stream policy: anAGPrintPolicy. ^ stream contents! ! !AGExpression methodsFor: 'private-factory classes'! printPolicyClass "Answer the default policy class." ^ AGPrintPolicy! ! !AGExpression methodsFor: 'private-printing'! defaultPrintPolicy "Answer the default print policy." ^ self printPolicyClass new! ! !AGExpression methodsFor: 'testing'! isBlock "Answer whether we represent block expressions." ^ false! isMessageExpression "Answer whether we represent message expressions." ^ false! isMethod "Answer whether we represent method expressions." ^ false! isReturn "Answer whether we represent return expressions." ^ false! isSelf "Answer whether we represent self sends." ^ false! isSuper "Answer whether we represent super sends." ^ false! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! AGExpression class instanceVariableNames: ''! !AGExpression class methodsFor: 'instance creation'! new ^ super new initialize! new: anInteger ^ (super new: anInteger) initialize! ! AGExpression variableSubclass: #AGAssignment instanceVariableNames: 'variable value ' classVariableNames: '' poolDictionaries: '' category: 'Zork_Abstract_Grammar'! AGAssignment comment: 'Comment: Instances of AGAssignment represent assignment expressions, conform the standard Smalltalk language." Instance variables: variable Variable to be assigned. value Expression specifying value to be assignmed to the variable.'! !AGAssignment methodsFor: 'accessing'! value "Answer the value expression." ^ value! variable "Answer the variable expression." ^ variable! ! !AGAssignment methodsFor: 'enumerating'! nodesDo: aBlock "Enumerate the expression tree. The order may change eventually." super nodesDo: aBlock. variable nodesDo: aBlock. value nodesDo: aBlock! ! !AGAssignment methodsFor: 'evaluating'! eval: anAGContext "Assign the value of the expression in given context to the variable." | answer | answer := variable bind: (value eval: anAGContext) context: anAGContext. activations := activations + 1. ^ answer! ! !AGAssignment methodsFor: 'initialize-release'! variable: anAGVariable value: anAGExpression "Initialize the variable and value expressions." variable := anAGVariable. value := anAGExpression! ! !AGAssignment methodsFor: 'printing'! printOn: aStream indent: level policy: anAGPrintPolicy "Print the assignment expression on the stream with given indent and policy." anAGPrintPolicy printAssignment: self on: aStream indent: level! printOn: aStream indent: level precedence: precedence policy: anAGPrintPolicy "Print the assignment expression on the stream with given indent, precedence and policy." anAGPrintPolicy printAssignment: self on: aStream indent: level precedence: precedence! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! AGAssignment class instanceVariableNames: ''! !AGAssignment class methodsFor: 'instance creation'! variable: anAGVariable value: anAGExpression "Answer a new instance with given variable and expression." ^ self new variable: anAGVariable value: anAGExpression! ! AGExpression variableSubclass: #AGCascadedExpression instanceVariableNames: 'receiver ' classVariableNames: '' poolDictionaries: '' category: 'Zork_Abstract_Grammar'! AGCascadedExpression comment: 'Comment: Instances of AGCascadedExpression represent cascaded message expressions, conform the Smalltalk language. The message expressions are stored in indexed instance variables. Instance variables: receiver Receiver of the cascaded expression. Indexed instance variables: '! !AGCascadedExpression methodsFor: 'accessing'! receiver "Answer the receiver." ^ receiver! ! !AGCascadedExpression methodsFor: 'enumerating'! nodesDo: aBlock "Enumerate the expression tree." super nodesDo: aBlock. receiver nodesDo: aBlock. 1 to: self size do: [ :i | (self at: i) nodesDo: aBlock ]! ! !AGCascadedExpression methodsFor: 'evaluating'! eval: anAGContext "Evaluate all message expression for the receiver in given context. Answer the result of the last expression." | rcvr answer | rcvr := receiver eval: anAGContext. 1 to: self size do: [ :i | answer := (self at: i) eval: anAGContext receiver: rcvr isSuperSend: receiver isSuper ]. activations := activations + 1. ^ answer! ! !AGCascadedExpression methodsFor: 'initialize-release'! receiver: anAGExpression messages: anArray "Initialize the receiver and message expressions. We store the respective message expressions in indexed variables." receiver := anAGExpression. 1 to: self size do: [ :i | self at: i put: (anArray at: i)]! ! !AGCascadedExpression methodsFor: 'printing'! printOn: aStream indent: level policy: anAGPrintPolicy "Print the cascaded message expression on the stream with given indent, using given policy." anAGPrintPolicy printCascadedExpression: self on: aStream indent: level! printOn: aStream indent: level precedence: p "Print the assignment expression on the stream with given indent, taking into account the precedence level. Precedence levels < 4 imply the statement is being used as a receiver or argument expression." p < 4 ifTrue: [aStream nextPut: $(]. self printOn: aStream indent: level. p < 4 ifTrue: [aStream nextPut: $)]! printOn: aStream indent: level precedence: p policy: anAGPrintPolicy "Print the cascaded message expression on the stream with given indent and preference, using given policy." anAGPrintPolicy printCascadedExpression: self on: aStream indent: level precedence: p! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! AGCascadedExpression class instanceVariableNames: ''! !AGCascadedExpression class methodsFor: 'instance creation'! receiver: anAGExpression messages: anArray "Answer an instance with given receiver expression and list of message expressions." ^ (self new: anArray size) receiver: anAGExpression messages: anArray! ! AGExpression variableSubclass: #AGCode instanceVariableNames: 'arguments temporaries ' classVariableNames: '' poolDictionaries: '' category: 'Zork_Abstract_Grammar'! AGCode comment: 'Comment: Abstract superclass for block and compiled method expressions. Both subclasses store their statements in indexed instance variables. Instance variables: arguments Array of arguments. temporaries Array of temporary variables. Indexed instance variables: '! !AGCode methodsFor: 'accessing'! arguments "Answer the list of arguments." ^ arguments! messageExpressions "Answer a list of all the message expressions in the receiver." | messageExpressions | messageExpressions := OrderedCollection new. self nodesDo: [ :exp | exp isMessageExpression ifTrue: [ messageExpressions addLast: exp ]]. ^ messageExpressions! numArgs "Answer the number of arguments." ^ arguments size! numTemps "Answer the number of temporary vaiables." ^ temporaries size! temporaries "Answer the list of temporary variables." ^ temporaries! ! !AGCode methodsFor: 'enumerating'! nodesDo: aBlock "Enumerate the expression tree." super nodesDo: aBlock. 1 to: self size do: [ :i | (self at: i) nodesDo: aBlock ]! ! !AGCode methodsFor: 'evaluating'! valueInContext: anAGContext "Evaluate all statement expressions for side effects. Answer the result of the last expression." | answer | activations := activations + 1. 1 to: self size do: [ :i | answer := (self at: i) eval: anAGContext ]. ^ answer! ! !AGCode methodsFor: 'initialize-release'! arguments: args temporaries: temps statements: stats "Initialize the lists of arguments, temporary variables and statements. Statements are stored in the indexed instance variables." arguments := args. temporaries := temps. 1 to: self size do: [ :i | self at: i put: (stats at: i)]! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! AGCode class instanceVariableNames: ''! !AGCode class methodsFor: 'instance creation'! arguments: args temporaries: temps statements: stats "Answer a new block or method with given lists of arguemnst, temporary variables and statements." ^ (self new: stats size) arguments: args temporaries: temps statements: stats! ! AGCode variableSubclass: #AGBlock instanceVariableNames: 'level ' classVariableNames: '' poolDictionaries: '' category: 'Zork_Abstract_Grammar'! AGBlock comment: 'Comment: Instances of AGBlock represent block expressions, conform the Smalltalk language. Instance variables: level Represents the nesting depth of the block with regards to the enclosing method.'! !AGBlock methodsFor: 'accessing'! level "Answer the nesting depth." ^ level! ! !AGBlock methodsFor: 'evaluating'! eval: anAGContext "Evaluate the blok in given context. This consists in building a block closure with the appropriate context. Answer the block closure." ^ AGBlockClosure block: self outerContext: anAGContext! ! !AGBlock methodsFor: 'initialize-release'! level: lvl "Initialize the nesting depth." level := lvl! ! !AGBlock methodsFor: 'printing'! printOn: aStream indent: level policy: anAGPrintPolicy "Print the block on the stream with given indent, using given policy." anAGPrintPolicy printBlock: self on: aStream indent: level! ! !AGBlock methodsFor: 'testing'! isBlock "Answer whether we represent block expressions." ^ true! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! AGBlock class instanceVariableNames: ''! !AGBlock class methodsFor: 'instance creation'! arguments: args temporaries: temps statements: stats level: level "Answer a new instance with given arguments, temporary variables and statement expressions." ^ (self arguments: args temporaries: temps statements: stats) level: level! ! AGCode variableSubclass: #AGMethod instanceVariableNames: 'mclass selector needsReturnHandler ' classVariableNames: '' poolDictionaries: '' category: 'Zork_Abstract_Grammar'! AGMethod comment: 'Comment: Instances of AGMethod represent the methods, conform the Smalltalk language. Instance Variables mclass The class in which this method was ''compiled''. selector Selector of corresponding with the method. needsReturnHandler Flag indicating if we need a return handler for this method''s execution. '! !AGMethod methodsFor: 'accessing'! mclass "Answer the class in which this compiled code is 'compiled'." ^ mclass! mclass: aBehavior "Set the class in which the method is 'compiled'" mclass := aBehavior! selector "Answer the selector." ^ selector! ! !AGMethod methodsFor: 'analysis'! nodeCount "Answer the numer of nodes in the expression tree." | nodeCount | nodeCount := 0. self nodesDo: [ :exp | nodeCount := nodeCount + 1 ]. ^ nodeCount! visitedNodeCount "Answer the numer of nodes visited." | nodeCount | nodeCount := 0. self nodesDo: [ :exp | exp activations > 0 ifTrue: [ nodeCount := nodeCount + 1 ]]. ^ nodeCount! ! !AGMethod methodsFor: 'evaluating'! valueWithReceiver: anObject arguments: anArray "Evaluate the method with given receiver and arguments. Install a return handler in case we might need it." | context numTemps numArgs | context := AGMethodContext receiver: anObject method: self size: (numTemps := temporaries size) + (numArgs := anArray size) returnHandler: (needsReturnHandler ifTrue: [[ :value | ^ value ]] ifFalse: [ nil ]). 1 to: numArgs do: [ :i | context at: numTemps + i put: (anArray at: i)]. ^ self valueInContext: context! ! !AGMethod methodsFor: 'initialize-release'! arguments: args temporaries: temps statements: stats "Initialize the lists of arguments, temporary variables and statements. Statements are stored in the indexed instance variables. Initialize the return handler test flag." super arguments: args temporaries: temps statements: stats. self initializeReturnHandlerTest! selector: aSymbol "Initialize the selector." selector := aSymbol! ! !AGMethod methodsFor: 'printing'! printOn: aStream indent: level policy: anAGPrintPolicy "Print the method on the stream with given indent, using given policy." anAGPrintPolicy printMethod: self on: aStream indent: level! ! !AGMethod methodsFor: 'private-initialize-release'! initializeReturnHandlerTest "Check whether we need return handlers. Set the flag accordingly." self nodesDo: [ :exp | exp isReturn ifTrue: [ ^ needsReturnHandler := true ]]. needsReturnHandler := false! ! !AGMethod methodsFor: 'testing'! isMethod "Answer whether we represent methods." ^ true! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! AGMethod class instanceVariableNames: ''! !AGMethod class methodsFor: 'instance creation'! selector: sel arguments: args temporaries: temps statements: stats "Answer a new instance with given selector, arguments, temporary variables and statements." ^ (self arguments: args temporaries: temps statements: stats) selector: sel! ! AGExpression variableSubclass: #AGLiteral instanceVariableNames: 'value ' classVariableNames: '' poolDictionaries: '' category: 'Zork_Abstract_Grammar'! AGLiteral comment: 'Comment: Instances of AGLiteral represent literal objects as accumulated by the compiler. Instance variables: value Value of the literal.'! !AGLiteral methodsFor: 'accessing'! value "Answer the value." ^ value! ! !AGLiteral methodsFor: 'evaluating'! eval: anAGContext "Answer the literal." activations := activations + 1. ^ value! ! !AGLiteral methodsFor: 'initialize-release'! value: anObject "Initialize the value of the literal." value := anObject! ! !AGLiteral methodsFor: 'printing'! printOn: aStream indent: level policy: anAGPrintPolicy "Print the literal on the stream with given indent, using given policy." anAGPrintPolicy printLiteral: self on: aStream indent: level! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! AGLiteral class instanceVariableNames: ''! !AGLiteral class methodsFor: 'instance creation'! value: anObject "Answer a new instance with given literal value." ^ self new value: anObject! ! AGExpression variableSubclass: #AGMessageExpression instanceVariableNames: 'receiver selector arguments ' classVariableNames: '' poolDictionaries: '' category: 'Zork_Abstract_Grammar'! AGMessageExpression comment: 'Comment: Instances of AGMessageExpression represent message expressions, conform the Smalltalk language. Instance variables receiver Receiver of the message expression. selector Selector of the message expression. args List of argument expressions. Indexed instance variables: The results of method lookup are stored in the receiver''s indexed instance variables (see #lookupMethod:in: for more details).'! !AGMessageExpression methodsFor: 'accessing'! arguments "Answer the arguments." ^ arguments! receiver "Answer the receiver." ^ receiver! selector "Answer the selector." ^ selector! ! !AGMessageExpression methodsFor: 'analysis'! activations "Sum the number of activations of the respective implementations (see #lookupMethod). Answer the result." | activations | activations := 0. 1 to: self size by: 3 do: [ :i | activations := activations + (self at: i + 1)]. ^ activations! methods "Answer a list of the cached methods." | methods | methods := Set new. 1 to: self size // 3 do: [ :i | methods add: (self at: i * 3)]. ^ methods asOrderedCollection! ! !AGMessageExpression methodsFor: 'enumerating'! nodesDo: aBlock "Enumerate the expression tree." super nodesDo: aBlock. receiver notNil ifTrue: [ receiver nodesDo: aBlock ]. arguments do: [ :arg | arg nodesDo: aBlock ]! ! !AGMessageExpression methodsFor: 'evaluating'! eval: anAGContext "Evaluate the message expression by evaluating receiver and argument expressions, and performing the message send. Many types of optimizations are possible, e.g. to handle special selectors as #ifTrue:ifFalse:, .... The total numer of activations is the sum of the activations for the various implementations. See #activations and #lookupMethod:in: for more details." ^ self perform: selector receiver: (receiver eval: anAGContext) arguments: (self evaluateAll: arguments in: anAGContext) isSuperSend: receiver isSuper methodClass: anAGContext methodClass! ! !AGMessageExpression methodsFor: 'initialize-release'! receiver: anAGExpression selector: aSymbol arguments: arrayOfAGExpression "Initialize the receiver with given receiver expression, selector and argument expressions." receiver := anAGExpression. selector := aSymbol. arguments := arrayOfAGExpression! ! !AGMessageExpression methodsFor: 'printing'! precedence "Answer the precedence for the selector. See class Symbol and the Smalltalk parser for more info." ^ selector precedence! printOn: aStream indent: level policy: anAGPrintPolicy "Print the message expression on the stream with given indent, using given policy." anAGPrintPolicy printMessageExpression: self on: aStream indent: level! printOn: aStream indent: level precedence: p policy: anAGPrintPolicy "Print the message expression on the stream with given indent and preference, using given policy." anAGPrintPolicy printMessageExpression: self on: aStream indent: level precedence: p! ! !AGMessageExpression methodsFor: 'private-evaluating'! evaluateAll: expressions in: anAGContext "Evaluate all elements in the expressions array and return the results." | size answer | (size := expressions size) = 0 ifTrue: [ ^ #()]. answer := Array new: size. 1 to: size do: [ :i | answer at: i put: ((expressions at: i) eval: anAGContext)]. ^ answer! perform: selector receiver: receiver arguments: arguments isSuperSend: aBoolean methodClass: aBehavior "Look up the method. If found, execute it; if not, perform a #doesNotUnderstand:." | method | ^ (method := self lookupMethod: selector in: (aBoolean ifTrue: [ aBehavior superclass ] ifFalse: [ receiver class ])) isNil ifTrue: [ receiver doesNotUnderstand: (Message selector: selector arguments: arguments)] ifFalse: [ method valueWithReceiver: receiver arguments: arguments ]! ! !AGMessageExpression methodsFor: 'private-method lookup'! basicLookupMethod: selector in: aBehavior "Search for a method in the class hierarchy. Answer nil upon failure." | method superclass | (method := aBehavior compiledMethodAt: selector ifAbsent: [ nil ]) isNil ifFalse: [ ^ method ]. ^ (superclass := aBehavior superclass) isNil ifTrue: [ nil ] ifFalse: [ self basicLookupMethod: selector in: superclass ]! grow "Create room for another cache entry. When swizzling the object references, we currently ignore dependents." | newInst | newInst := self class new: self size + 3. 1 to: self class instSize do: [ :i | newInst instVarAt: i put: (self instVarAt: i)]. 1 to: self size do: [ :i | newInst at: i put: (self at: i)]. self primBecome: newInst! lookupMethod: selector in: aBehavior "Search for an appropriate method. First perform a lookup in the local cache. Upon failure do a regular lookup and cache the result. Cached methods are stored in the receiver's indexed instance variables. Each entry takes up three slots: the class (i), the number of activations (i + 1) and the method (i + 2) for that particular entry." | size | 1 to: (size := self size) by: 3 do: [ :i | (self at: i) == aBehavior ifTrue: [ self at: i + 1 put: (self at: i + 1) + 1. ^ self at: i + 2 ]]. ^ self grow at: size + 1 put: aBehavior; at: size + 2 put: 1; at: size + 3 put: (self basicLookupMethod: selector in: aBehavior)! ! !AGMessageExpression methodsFor: 'testing'! isMessageExpression "Answer whether we represent message expressions." ^ true! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! AGMessageExpression class instanceVariableNames: ''! !AGMessageExpression class methodsFor: 'instance creation'! receiver: anAGExpression selector: aSymbol arguments: arrayOfAGExpression "Answer a new instance with given receiver expression, selector and argument expressions." ^ self new receiver: anAGExpression selector: aSymbol arguments: arrayOfAGExpression! ! AGMessageExpression variableSubclass: #AGCascadedMessageExpression instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Zork_Abstract_Grammar'! AGCascadedMessageExpression comment: 'Comment: Instances of AGCascadedMessageExpression represent message expressions used in cascaded expressions. The receiver is ignored.'! !AGCascadedMessageExpression methodsFor: 'evaluating'! eval: anAGContext receiver: rcvr isSuperSend: aBoolean "Evaluate the message expression by evaluating given receiver (ignoring the receiver's receiver) and argument expressions, and performing the message send." activations := activations + 1. ^ self perform: selector receiver: rcvr arguments: (self evaluateAll: arguments in: anAGContext) isSuperSend: aBoolean methodClass: anAGContext methodClass! ! !AGCascadedMessageExpression methodsFor: 'printing'! printOn: aStream indent: level policy: anAGPrintPolicy "Print the message expression on the stream with given indent, using given policy." anAGPrintPolicy printCascadedMessageExpression: self on: aStream indent: level! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! AGCascadedMessageExpression class instanceVariableNames: ''! !AGCascadedMessageExpression class methodsFor: 'instance creation'! selector: aSymbol arguments: anArray "Answer a new instance with given selector and argument expressions." ^ self new receiver: nil selector: aSymbol arguments: anArray! ! AGExpression variableSubclass: #AGPseudoVariable instanceVariableNames: 'isSuper ' classVariableNames: '' poolDictionaries: '' category: 'Zork_Abstract_Grammar'! AGPseudoVariable comment: 'Comment: Instances of AGPseudoVariable represent self or super (sends). Instance variables: isSuper Flag denoting we represent self or super.'! !AGPseudoVariable methodsFor: 'accessing'! name "Answer the name of the pseudo-variable." ^ self isSuper ifTrue: [ 'super' ] ifFalse: [ 'self' ]! ! !AGPseudoVariable methodsFor: 'evaluating'! eval: anAGContext "Answer the receiver." activations := activations + 1. ^ anAGContext receiver! ! !AGPseudoVariable methodsFor: 'initialize-release'! isSuper: aBoolean isSuper := aBoolean! ! !AGPseudoVariable methodsFor: 'printing'! printOn: aStream indent: level policy: anAGPrintPolicy "Print the pseudo variable on the stream with given indent, using given policy." anAGPrintPolicy printPseudoVariable: self on: aStream indent: level! ! !AGPseudoVariable methodsFor: 'testing'! isSelf "Answer whether we represent a self (send)." ^ isSuper not! isSuper "Answer whether we represent a super (send)." ^ isSuper! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! AGPseudoVariable class instanceVariableNames: ''! !AGPseudoVariable class methodsFor: 'instance creation'! self "Answer a 'self' pseudo-variable." ^ self new isSuper: false! super "Answer a 'super' pseudo-variable." ^ self new isSuper: true! ! AGExpression variableSubclass: #AGReturn instanceVariableNames: 'value ' classVariableNames: '' poolDictionaries: '' category: 'Zork_Abstract_Grammar'! AGReturn comment: 'Comment: Instances of AGReturn represent return statements, conform the standard Smalltalk language." Instance variables: value Expression specifying value to be returned.'! !AGReturn methodsFor: 'accessing'! value "Answer the value expression to be returned." ^ value! ! !AGReturn methodsFor: 'enumerating'! nodesDo: aBlock "Enumerate the expression tree." super nodesDo: aBlock. value nodesDo: aBlock! ! !AGReturn methodsFor: 'evaluating'! eval: anAGContext "Evaluate the expression and return the result. As the evaluation of abstract grammar expressions follows a straightforward recusive-descent implementation, returns must be treated in a special way. See AGMethod (#valueWithReceiver:arguments:) more details." | answer | answer := value eval: anAGContext. activations := activations + 1. anAGContext return: answer! ! !AGReturn methodsFor: 'initialize-release'! value: anAGExpression "Set the expression to be returned." value := anAGExpression! ! !AGReturn methodsFor: 'printing'! printOn: aStream indent: level policy: anAGPrintPolicy "Print the return on the stream with given indent, using given policy." anAGPrintPolicy printReturn: self on: aStream indent: level! ! !AGReturn methodsFor: 'testing'! isReturn "Answer whether we represent a return expression." ^ true! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! AGReturn class instanceVariableNames: ''! !AGReturn class methodsFor: 'instance creation'! value: anAGExpression "Answer a new return statement returning the value of given expression." ^ self new value: anAGExpression! ! AGExpression variableSubclass: #AGVariable instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Zork_Abstract_Grammar'! AGVariable comment: 'Comment: Abstract superclass for the various variable types: instance variables, local variables (temporary variables and arguments) and shared variables.'! !AGVariable methodsFor: 'accessing'! name "Answer the name of the variable." self subclassResponsibility! ! !AGVariable methodsFor: 'evaluating'! bind: anObject context: anAGContext "Bind the object to the variable." self subclassResponsibility! eval: anAGContext "Answer the binding of the variable." self subclassResponsibility! ! !AGVariable methodsFor: 'printing'! printOn: aStream indent: level policy: anAGPrintPolicy "Print the variable on the stream with given indent, using given policy." anAGPrintPolicy printVariable: self on: aStream indent: level! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! AGVariable class instanceVariableNames: ''! AGVariable variableSubclass: #AGInstanceVariable instanceVariableNames: 'index class ' classVariableNames: '' poolDictionaries: '' category: 'Zork_Abstract_Grammar'! AGInstanceVariable comment: 'Comment: Instances of AGInstanceVariable represent instance variables, conform the Smalltalk language. Instance variables: class Class containing the instance variable (may be a subclass of the class defining the variable). index Slot of the instance variable in the list of all instance variables.'! !AGInstanceVariable methodsFor: 'accessing'! name "Answer the name of the instance variable." ^ class allInstVarNames at: index! ! !AGInstanceVariable methodsFor: 'evaluating'! bind: anObject context: anAGContext "Bind the object to the variable." activations := activations + 1. ^ anAGContext receiver instVarAt: index put: anObject! eval: anAGContext "Answer the binding of the variable." activations := activations + 1. ^ anAGContext receiver instVarAt: index! ! !AGInstanceVariable methodsFor: 'initialize-release'! index: anInteger class: aBehavior "Initialize the slot and class of the instance variable." index := anInteger. class := aBehavior! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! AGInstanceVariable class instanceVariableNames: ''! !AGInstanceVariable class methodsFor: 'instance creation'! index: anInteger class: aBehavior "Answer the instance variable for given slot in the class." ^ self new index: anInteger class: aBehavior! ! AGVariable variableSubclass: #AGLocalVariable instanceVariableNames: 'name level index ' classVariableNames: '' poolDictionaries: '' category: 'Zork_Abstract_Grammar'! AGLocalVariable comment: 'Comment: Instances of AGLocalVariable represent temporary variables and arguments. Instance variables: name Name of the variable. index: Slot of the variable. Used in contexts during evaluation. level Nesting depth of the variable in the scope.'! !AGLocalVariable methodsFor: 'accessing'! name "Answer the name of the variable." ^ name! ! !AGLocalVariable methodsFor: 'evaluating'! bind: anObject context: anAGContext "Bind the object to the variable." activations := activations + 1. ^ (anAGContext contextAt: level) at: index put: anObject! eval: anAGContext "Answer the binding of the argument." activations := activations + 1. ^ (anAGContext contextAt: level) at: index! ! !AGLocalVariable methodsFor: 'initialize-release'! name: aSymbol level: lvl index: idx "Initialize the name, level and slot of the local variable." name := aSymbol. level := lvl. index := idx! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! AGLocalVariable class instanceVariableNames: ''! !AGLocalVariable class methodsFor: 'instance creation'! name: aSymbol level: level index: index "Answer a new local variable with given name, nesting depth and slot index." ^ self new name: aSymbol level: level index: index! ! AGVariable variableSubclass: #AGSharedVariable instanceVariableNames: 'binding ' classVariableNames: '' poolDictionaries: '' category: 'Zork_Abstract_Grammar'! AGSharedVariable comment: 'Comment: Instances of AGSharedVariable represent shared variables such as globals, class variables and pool dictionary variables. Instance variables: binding The variable binding of the shared variable.'! !AGSharedVariable methodsFor: 'accessing'! name "Answer the name of the variable." ^ binding key! ! !AGSharedVariable methodsFor: 'evaluating'! bind: anObject context: anAGContext "Bind the object to the variable." activations := activations + 1. binding value: anObject. ^ anObject! eval: anAGContext "Answer the binding of the variable." activations := activations + 1. ^ binding value! ! !AGSharedVariable methodsFor: 'initialize-release'! binding: aVariableBinding "Initialize the binding." binding := aVariableBinding! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! AGSharedVariable class instanceVariableNames: ''! !AGSharedVariable class methodsFor: 'instance creation'! binding: aVariableBinding "Answer a new expression representing the shared variable." ^ self new binding: aVariableBinding! ! Object variableSubclass: #AGPrintPolicy instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Zork_Abstract_Grammar'! AGPrintPolicy comment: 'Comment: Smalltalk pretty-printer. Essentially taken over as is from Smalltalk.'! !AGPrintPolicy methodsFor: 'printing'! printAssignment: anAGAssignment on: aStream indent: level "Print the assignment expression on the stream with given indent." anAGAssignment variable printOn: aStream indent: level policy: self. aStream nextPutAll: ' := '. anAGAssignment value printOn: aStream indent: level + 2 policy: self! printAssignment: anAGAssignment on: aStream indent: level precedence: p "Print the assignment expression on the stream with given indent, taking into account the precedence level. Precedence levels < 4 imply the statement is being used as a receiver or argument expression." p < 4 ifTrue: [ aStream nextPut: $( ]. self printAssignment: anAGAssignment on: aStream indent: level. p < 4 ifTrue: [ aStream nextPut: $) ]! printBlock: anAGBlock on: aStream indent: level "Print the block expression on the stream with given indent level." anAGBlock size > 1 ifTrue: [ aStream crtab: level ]. aStream nextPut: $[. self printArguments: anAGBlock on: aStream indent: level. (anAGBlock size > 1 and: [ anAGBlock arguments size > 0 ]) ifTrue: [ aStream crtab: level ]. self printBody: anAGBlock on: aStream indent: level. aStream nextPut: $]! printCascadedExpression: anAGCascadedExpression on: aStream indent: level "Print the cascaded expression on the stream with given indent." anAGCascadedExpression receiver printOn: aStream indent: level precedence: 0 policy: self. 1 to: anAGCascadedExpression size do: [ :i | (anAGCascadedExpression at: i) printOn: aStream indent: level policy: self. i < anAGCascadedExpression size ifTrue: [ aStream nextPut: $; ]]! printCascadedExpression: anAGCascadedExpression on: aStream indent: level precedence: p "Print the cascaded expression on the stream with given indent, taking into account the precedence level. Precedence levels < 4 imply the statement is being used as a receiver or argument expression." p < 4 ifTrue: [ aStream nextPut: $( ]. self printCascadedExpression: anAGCascadedExpression on: aStream indent: level. p < 4 ifTrue: [ aStream nextPut: $) ]! printCascadedMessageExpression: anAGMessageExpression on: aStream indent: level "Print the cascaded message expression on the stream with given indent." self printMessage: anAGMessageExpression on: aStream indent: level! printLiteral: anAGLiteral on: aStream indent: level "Print the literal on the stream with given indent." aStream store: anAGLiteral value! printMessageExpression: anAGMessageExpression on: aStream indent: level "Print the message expression on the stream with given indent." self printReceiver: anAGMessageExpression on: aStream indent: level. self printMessage: anAGMessageExpression on: aStream indent: level! printMessageExpression: anAGMessageExpression on: aStream indent: level precedence: p "Print the message expression on the stream with given indent, taking into account the precedence." | parenthesize | parenthesize := anAGMessageExpression precedence > p or: [ p = 3 and: [ anAGMessageExpression precedence = 3 ]]. parenthesize ifTrue: [ aStream nextPut: $( ]. self printMessageExpression: anAGMessageExpression on: aStream indent: level. parenthesize ifTrue: [ aStream nextPut: $) ]! printMethod: anAGMethod on: aStream indent: level "Print the method on the stream with given indent." | nextLevel | self printSelector: anAGMethod on: aStream indent: level. nextLevel := level + 1. aStream crtab: nextLevel; crtab: nextLevel. self printBody: anAGMethod on: aStream indent: nextLevel! printPseudoVariable: anAGPseudoVariable on: aStream indent: level "Print the name (self or super) of the receiver on the stream with given indent." aStream nextPutAll: anAGPseudoVariable name! printReturn: anAGReturn on: aStream indent: level "Print the return expression on the stream with given indent." aStream nextPutAll: '^ '. anAGReturn value printOn: aStream indent: level policy: self! printVariable: anAGVariable on: aStream indent: level "Print the name of the receiver on the stream with given indent." aStream nextPutAll: anAGVariable name! ! !AGPrintPolicy methodsFor: 'private-printing'! printArguments: anAGBlock on: aStream indent: level "Print the arguments of the block on the stream with given indent level." anAGBlock arguments isEmpty ifFalse: [ anAGBlock arguments do: [ :arg | aStream nextPut: $:; nextPutAll: arg; space ]. aStream nextPutAll: '| ' ]! printBody: anAGCode on: aStream indent: level "Print the temporary variables and body of given method or block on a stream with given indent." | indent | indent := false. anAGCode temporaries isEmpty ifFalse: [ indent ifTrue: [ aStream crtab: level ]. aStream nextPutAll: '| '. anAGCode temporaries do: [ :temp | aStream nextPutAll: temp; space ]. aStream nextPut: $|; crtab: level. indent := true ]. 1 to: anAGCode size do: [ :i | | statement | statement := anAGCode at: i. indent ifTrue: [ aStream crtab: level ]. (i = anAGCode size and: [ statement isSelf ]) ifFalse: [ statement printOn: aStream indent: level policy: self ]. i < anAGCode size ifTrue: [ aStream nextPut: $. ]. indent := true ]! printCode: anAGCode on: aStream indent: level "Print the temporary variables and body of the code on the stream with given indent." aStream crtab: level. anAGCode printOn: aStream indent: level policy: self! printMessage: anAGMessageExpression on: aStream indent: level "Print the selector and arguments of given message expression on the stream with given indent." | prev arg indent thisKey keywords | anAGMessageExpression arguments size = 0 ifTrue: [ aStream space; nextPutAll: anAGMessageExpression selector. ^ self ]. keywords := anAGMessageExpression selector keywords. prev := anAGMessageExpression receiver. 1 to: anAGMessageExpression arguments size do: [ :i | arg := anAGMessageExpression arguments at: i. thisKey := keywords at: i. (prev notNil and: [ prev isBlock or: [(prev isMessageExpression and: [ prev precedence >= 3 ]) or: [(arg isBlock and: [ arg size > 1 and: [ thisKey ~= #do:]]) or: [ anAGMessageExpression arguments size > 2 or: [ anAGMessageExpression selector == #ifTrue:ifFalse: ]]]]]) ifTrue: [ aStream crtab: level+1. indent := 1 ] "newline after big arguments" ifFalse: [ aStream space. indent := 0 ]. aStream nextPutAll: thisKey; space. arg printOn: aStream indent: level + 1 + indent precedence: (anAGMessageExpression precedence = 2 ifTrue: [1] ifFalse: [ anAGMessageExpression precedence ]) policy: self. prev := arg ]! printReceiver: anAGMessageExpression on: aStream indent: level "Print the selector and arguments of given message expression on the stream with given indent." anAGMessageExpression receiver printOn: aStream indent: level precedence: anAGMessageExpression precedence policy: self! printSelector: anAGMethod on: aStream indent: level "Print the method selector on a stream with given indent." anAGMethod selector precedence = 1 ifTrue: [ aStream nextPutAll: anAGMethod selector ] ifFalse: [ anAGMethod selector keywords with: anAGMethod arguments do: [ :keyword :arg | aStream nextPutAll: keyword; space; nextPutAll: arg; space ]]! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! AGPrintPolicy class instanceVariableNames: ''! Compiler subclass: #AGCompiler instanceVariableNames: 'nameScopes ' classVariableNames: '' poolDictionaries: '' category: 'Zork_Abstract_Grammar'! AGCompiler comment: 'Comment: Instances of AGCompiler compile Smalltalk method expressions into an abstract grammar expression tree. It uses the standard smalltalk compiler to generate a parse tree (starting with a MethodNode) and converts it into a corresponding abstract grammar expression tree. Instance Variables: nameScopes Array of temporary variable and argument names in the current scope and the scopes leading up to the method. Each entry represents a scope; the first element of the entry array contains the names of temporary variables, the second element the argument names. '! !AGCompiler methodsFor: 'private'! translate: aStream noPattern: noPattern ifFail: failBlock needSourceMap: mapFlag handler: handler "Translate the source into a parse tree. Do no code generation. Answer the method node tree." | methodNode holder | methodNode := class parserClass new parse: aStream class: class noPattern: noPattern context: context notifying: handler builder: ProgramNodeBuilder new saveComments: mapFlag ifFail: [ ^ failBlock value ]. holder := self newMethodHolder. holder node: methodNode. ^ holder! ! !AGCompiler methodsFor: 'private-accessing'! nameScopes "Answer the current scope stack of temporary variables and arguments." ^ nameScopes! ! !AGCompiler methodsFor: 'private-building'! bindingFor: aSymbol "Answer the binding for given symbol (class variable, pool variable, global variable or undefined). Must be modified when moving to VW5i. Currently 'thisContext' is not recognized." | binding | targetClass withAllSuperclassesDo: [ :cls | (binding := cls bindingFor: aSymbol) notNil ifTrue: [ ^ binding ]]. (binding := Smalltalk bindingFor: aSymbol) notNil ifTrue: [ ^ binding ]. (binding := Undeclared bindingFor: aSymbol) notNil ifTrue: [ ^ binding ]. self error: 'Unknown variable name.'! builderSelectors "Answer a list of selectors to build the various abstract grammar expression." ^ #(buildFromAssignmentNode: buildFromBlockNode: buildFromCascadeNode: buildFromLiteralNode: buildFromMessageNode: buildFromReturnNode: buildFromSequenceNode: buildFromVariableNode: buildFromMethodNode:)! buildFromAssignmentNode: anAssignmentNode "Convert the assignment node into its abstract grammar equivalent." ^ AGAssignment variable: (self buildFromNode: anAssignmentNode variable) value: (self buildFromNode: anAssignmentNode value)! buildFromBlockNode: aBlockNode "Convert the block node into its abstract grammar equivalent." ^ self withBlockNode: aBlockNode do: [ :args :temps :stats | AGBlock arguments: args temporaries: temps statements: stats level: nameScopes size ]! buildFromCascadeNode: aCascadeNode "Convert the cascaded message node into its abstract grammar equivalent." ^ AGCascadedExpression receiver: (self buildFromNode: aCascadeNode receiver) messages: (aCascadeNode messages collect: [ :msg | AGCascadedMessageExpression selector: msg selector arguments: (msg arguments collect: [ :arg | self buildFromNode: arg ])])! buildFromLiteralNode: aLiteralNode "Convert the literal node into its abstract grammar equivalent." ^ AGLiteral value: aLiteralNode value! buildFromMessageNode: aMessageNode "Convert the message send node into its abstract grammar equivalent." ^ AGMessageExpression receiver: (self buildFromNode: aMessageNode receiver) selector: aMessageNode selector arguments: (aMessageNode arguments collect: [ :argument | self buildFromNode: argument ])! buildFromMethodNode: aMethodNode "Convert the method node into its abstract grammar equivalent. Add a 'self'-node if the last statement is not a return (not the most intelligent of tests)." ^ self withBlockNode: aMethodNode block do: [ :args :temps :stats | (stats isEmpty or: [ stats last isReturn not ]) ifTrue: [ stats addLast: AGPseudoVariable self ]. AGMethod selector: aMethodNode selector arguments: args temporaries: temps statements: stats ]! buildFromNode: anObject "Convert the node to into its abstract grammar equivalent." ^ self perform: (self builderSelectors at: (self parseTreeNodeClasses indexOf: anObject class name)) with: anObject! buildFromReturnNode: aReturnNode "Convert the return node into its abstract grammar equivalent." ^ AGReturn value: (self buildFromNode: aReturnNode value)! buildFromSequenceNode: aSequenceNode "Convert the sequence node into a list of equivalent abstract grammar expressions." ^ aSequenceNode statements collect: [ :node | self buildFromNode: node ]! buildFromVariableNode: aVariableNode "Convert the variable node into its abstract grammar equivalent. We currently ignore 'thisContext'. Should be refactored a bit. Note: different references to the same variable are not represented by the same expression. This enables us to store bookkeeping information (number of activations, typing info, ...) in the nodes themselves." | name index | name := aVariableNode name asSymbol. nameScopes size to: 1 by: -1 do: [ :level | | temps args i | temps := (nameScopes at: level) at: 1. args := (nameScopes at: level) at: 2. (i := temps indexOf: name) > 0 ifTrue: [ ^ AGLocalVariable name: name level: level index: i ]. (i := args indexOf: name) > 0 ifTrue: [ ^ AGLocalVariable name: name level: level index: temps size + i ]]. name == #self ifTrue: [ ^ AGPseudoVariable self ]. name == #super ifTrue: [ ^ AGPseudoVariable super ]. (index := targetClass allInstVarNames indexOf: aVariableNode name) > 0 ifTrue: [ ^ AGInstanceVariable index: index class: targetClass ]. ^ AGSharedVariable binding: (self bindingFor: name)! parseTreeNodeClasses "Answer a list of names of parse tree node classes to be converted." ^ #(AssignmentNode BlockNode CascadeNode LiteralNode MessageNode ReturnNode SequenceNode VariableNode MethodNode)! withBlockNode: aBlockOrMethodNode do: aBlock "Convert the block node into its abstract grammar equivalent. Inject the arguments, temporaries and statements into the block and answer the result." | args body temps stats | args := aBlockOrMethodNode arguments isEmpty ifTrue: [ #()] ifFalse: [ aBlockOrMethodNode arguments collect: [ :arg | arg name asSymbol ]]. (body := aBlockOrMethodNode body) class == CascadeNode ifTrue: [ temps := #(). stats := OrderedCollection with: (self withNameScope: (Array with: temps with: args) do: [ self buildFromCascadeNode: body ])] ifFalse: [ temps := body temporaries isEmpty ifTrue: [ #()] ifFalse: [ body temporaries collect: [ :temp | temp name asSymbol ]]. stats := self withNameScope: (Array with: temps with: args) do: [ body statements collect: [ :node | self buildFromNode: node ]]]. ^ aBlock value: args value: temps value: stats! withNameScope: anArray do: aBlock "The array contains the names of temporary variables and arguments for the current scope. Push this scope on the stack while executing the block." | answer | self nameScopes addLast: anArray. answer := aBlock value. self nameScopes removeLast. ^ answer! ! !AGCompiler methodsFor: 'public access'! compile: textOrStream in: aClass notifying: aRequestor ifFail: failBlock "Compile the text or stream and answer a corresponding abstract grammar expression." | method | nameScopes := OrderedCollection new. method := self buildFromNode: (super compile: textOrStream in: aClass notifying: aRequestor ifFail: [ ^ failBlock value ]) node. method mclass: aClass. ^ method! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! AGCompiler class instanceVariableNames: ''! Application subclass: #Zork_Abstract_Grammar instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Zork_Abstract_Grammar'! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Zork_Abstract_Grammar class instanceVariableNames: ''! !Zork_Abstract_Grammar class methodsFor: 'EM-API'! loaded "Reinitialize after loading the class. Envy-specific." AGBlockClosure initializeLevel! ! AGBlockClosure initialize!