PK
69 Presource.stUT dF)eFUx "Presource.st: Smalltalk syntax extension through 'message expansion'.
Copyright (C) 2006, 2007 Stephen Compall.
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program. If not, see ."
"Commentary
This is a glue of the ParseTreeRewriter to STCompiler, as previously
integrated into GST by the 'Compiler' package. We principally use it
to introduce 'special form' messages, through the pseudo-message macro
expansion performed.
The easiest way, and hence standard way, to start using Presource in
your code is to choose ``Backstage story'' when creating a story in
No Candy Backstage's Neptune exploration program.
If you are not using Backstage, or chose ``Smalltalk story'', the
easiest way is to add a prologue saying:
Namespace current
at: #Compiler put: NoCandy.Presrc.RewritingCompiler.
NoCandy.Presrc.CodeMindset new installIn: Namespace current.
Transformations of parse trees to final trees passed to the compiler
are performed by a CodeMindset object -- most of this story is devoted
to either providing new transformation abilities to a CodeMindset, or
telling GST to use a CodeMindset in the proper places.
As this story modifies the Smalltalk language through the
RewritingCompiler, it is designed to avoid globally modifying the
system compiler. As such, it expects subspaces of Smalltalk to be
used as Common Lisp packages -- Behavior>>#codeMindset carries this
further by searching for the current set of message macros by way of
the enclosing class's namespace, unless this method is overridden. To
do this, simply use a class method #codeMindset.
In short, if you are looking for fine-grained, class-by-class
CodeMindset selection, override #codeMindset. Otherwise, stick with
the standard way described above.
Many simple transformations can be written using PatternMacro. To use
it, write an RB pattern -- as described in the Backstage manual --
that matches the expression to be expanded, then write another pattern
for the expansion. PatternMacro can also generate a fixed-length set
of generated variables for use in the expansion.
If PatternMacro is not sufficiently powerful to express your macro,
its matching and expansion functionality is also available in
CodeTemplate for your convenience.
The use of a dynamically-bound cancelBlock makes MessageMacro's
expander, and therefore compilation in general, NOT THREAD SAFE.
Notes:
* Features for conditional expansion should be part of CodeMindset -
RewritingCompiler should remain a simple pass-through class that
delegates all other decisions to a CodeMindset. This is anyway far
more extensible, because CodeMindsets are easily extensible on the
instance level."
"Code"
Namespace current: NoCandy.Presrc!
Object subclass: #CodeMindset
instanceVariableNames: 'messageMacroDictionary rewriters
directUnderMindsets mindsetPrecedenceList
overMindsets'
classVariableNames: ''
poolDictionaries: ''
category: 'Presource-source code transformation'
!
CodeMindset comment:
'Each group of Lisp code develops its own "mindset", defined by the
general-purpose macros and reader macros the writers have agreed upon.
As such, when looking at each group of code, the Lisper must absorb
the idioms used and acceptable in that code.
Some would say that you can completely describe this mindset by the
imported and available macros ("Environment") and reader macros
("Readtable"). Though we initially desire a simple mapping from
pseudo-message selectors to objects that can expand those pseudo-sends
into concrete code, we would like future expansion to be possible.
As such, I am the "mindset" of the code that I am responsible for
transforming into concrete code suitable to be passed to a parse tree
compiler STCompiler.
messageMacroDictionary
Exported dictionary of selectors to MessageMacros
rewriters
Exported, settable collection of other ParseTreeRewriters to
apply after the macroRewriter
directUnderMindsets
Private list of other CodeMindsets, used strictly for parse
tree expansion and installing in namespaces and classes.
mindsetPrecedenceList
The memoized result of computeMindsetList.
overMindsets
A WeakIdentitySet of CodeMindsets that include me in their
directUnderMindsets.'
!
Object subclass: #MessageMacro
instanceVariableNames: 'selector cancelBlock'
classVariableNames: 'NewVariableNumber'
poolDictionaries: ''
category: 'Presource-source code transformation'
!
MessageMacro comment:
'I represent a single message macro, which applies an in-place source
code tree transformation to an RBMessageNode.
"selector" is the selector for message sends that I match in source
code. Expansion is implemented by way of sending
#expandMessageInPlace: to me, with the RBMessageNode as an argument.
See the docstring for my version of that method for more details.
I can also produce an RBReplaceRule that will perform the expansion in
the context of a ParseTreeRewriter; see #replaceRuleOnSelector:.
selector
A temporary selector Symbol saved for printing/debugging
purposes, or nil'
!
Object subclass: #PatternBySelector
instanceVariableNames: 'selector'
classVariableNames: ''
poolDictionaries: ''
category: 'Presource-source code transformation'
!
PatternBySelector comment:
'I am a pattern node that responds to #match:inContext:, thus allowing
RBParseTreeRule>>#performOn: to match me against any RBMessageNode
matching my selector.
I am not a full RBProgramNode, and should never appear in a node
tree.
selector
A selector Symbol; described above.'
!
MessageMacro subclass: #BlockMessageMacro
instanceVariableNames: 'expandBlock'
classVariableNames: ''
poolDictionaries: ''
category: 'Presource-source code transformation'
!
BlockMessageMacro comment:
'I am a pseudo-message macro whose expansion is governed by a block
that receives the arguments to expandMessage:to:withArguments:.
expandBlock
Said BlockClosure.'
!
MessageMacro subclass: #PatternMacro
instanceVariableNames: 'sourceTemplate expansionTemplate
newVariables'
classVariableNames: ''
poolDictionaries: ''
category: 'Presource-source code transformation'
!
PatternMacro comment:
'I am a pseudo-message macro that expands by applying a pattern
expression to the original source tree (forgoing expansion if this
pattern does not match the source), and replacing the pattern
variables matched in another pattern expression.
sourceTemplate
The CodeTemplate to match against the original expression.
expansionTemplate
The CodeTemplate to copy using the pattern variables from
sourceTemplate.
newVariables
A collection of pattern variable names, used in the expansion
but *not* in the source, that will be replaced by generated,
unique variable names in the expansion.'
!
STInST.STCompiler subclass: #RewritingCompiler
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Presource-source code compilation'
!
RewritingCompiler comment:
'I am a compilerClass that transforms input, in the form of parsed
trees, to "final" compilable trees using a CodeMindset. This
CodeMindset is retrieved as an attribute of the for: aBehavior
argument.
Point of note: this compiler *destroys* its input MethodNode.
Therefore, you shouldn''t reuse such things; the current STInST
compiler framework, my main expandTree: client, does not reuse parsed
trees.'
!
CodeMindset subclass: #EnvironmentCodeMindset
instanceVariableNames: 'homeEnvironment'
classVariableNames: ''
poolDictionaries: ''
category: 'Presource-source code transformation'
!
EnvironmentCodeMindset comment:
'I am a mindset for writing Smalltalk code that has special
integration features for Smalltalk environments, including Namespaces
and Classes.
homeEnvironment
The Environment on whose behalf I affect Smalltalk code
semantics.'
!
STInST.ParseTreeRewriter subclass: #ParseTreeTrampolineRewriter
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Presource-source code transformation'
!
ParseTreeTrampolineRewriter comment:
'I am a ParseTreeRewriter that behaves differently during ProgramNode
rewriting in two major ways:
* When a RBReplaceRule successfully matches and answers a different
ProgramNode at a particular point in the tree, I immediately place
the new node in the tree, stop rewriting the old node, and resume
rewriting with the new node. This is called "trampolining".
* As would naturally follow from this, replacing a ProgramNode does
not imply that I won''t rewrite anything within the replacement.
Instead, when all trampolining rewrites at a particular point in
the tree are finished, I start rewriting the components of the
final node, be it the original or a replacement.
In addition, I don''t count "rewrites" that don''t answer a new
ProgramNode as successful matches.'
!
Object subclass: #CodeTemplate
instanceVariableNames: 'template'
classVariableNames: ''
poolDictionaries: ''
category: 'Presource-direct source manipulation'
!
CodeTemplate comment:
'I wrap STInST.RBParseNode to perform two distinct operations on
Smalltalk code using the ''template'', a pivot: I can either match the
pivot to concrete code and offer the results based on pattern
variables therein, or answer concrete code given the pivot and a set
of values for its pattern variables. The two primitive RBParseNode
operations reflecting these are match:inContext: and copyInContext:
respectively.
The values of pattern variables are communicated to and by me in the
form of "pattern maps", which are dictionaries like this:
Dictionary(
#''`@selector:'' -> #at:put:.
''`x'' -> RBVariableNode(abc).
''`@y'' -> OrderedCollection(RBVariableNode(b)
RBMessageNode(c at: d)).
)
where `x is a "pattern variable" that should be present in my
template. In this example, if this pattern map is answered by
#match:, it means that every ''`x'' in the template matched ''abc'' in
#match:''s source argument. If you give this pattern map to #expand:,
it will answer code in which every ''`x'' in the template is replaced
with ''abc''.
Also, if `@selector: appears in the template where you would expect a
selector, it will be replaced with #at:put:. It''s your job to use
@-forms correctly so that the resulting message will have the right
number of arguments.
Tangentially, if you have ever wondered what "context" in the
RBParseNode or ParseTreeSearcher source code means, my source is a
direct introduction.
template
An RBParseNode used as the pivot source for both match: and
expand:; see those methods.'
!
"TODO: I believe a correct MessageMacro>>#expandMessageInPlace:
extension interface demands that RBProgramNode's
copyInContext:/copyList:inContext: methods actually #copy values
pulled from the expansion bindings. Come up with a test (repeating
expansion of pattern values?) for this."
!CodeMindset class methodsFor: 'instance creation'!
new
"Answer a new instance that treats input source trees as final
compilable code."
^self nullOverMindsets: #()
!
nullOverMindsets: mindsets
"Answer a new instance that, after transforming parse trees
myself, uses each of the mindsets in turn to further transform
the trees.
You'll want to use this if you want a new mindset that behaves
just like one you already have, and you don't want changes to the
new one to affect the old one."
^super new
messageMacroDictionary: IdentityDictionary new
directUnderMindsets: mindsets
overMindsets: (WeakIdentitySet new);
rewriters: OrderedCollection new;
recomputeAllMindsetLists;
yourself
! !
!CodeMindset methodsFor: 'activation'!
installIn: aNamespace
"Configure aNamespace for use with this CodeMindset. See
Behavior's methods #compilerClass and #codeMindset to see why
this works."
| newUnderMindsets bindingName |
((aNamespace at: #Compiler ifAbsent: [STInST.STCompiler])
includesBehavior: RewritingCompiler)
ifFalse: [aNamespace at: #Compiler put: RewritingCompiler].
newUnderMindsets := OrderedCollection with: self.
bindingName := self environmentMindsetClass defaultName.
(aNamespace hereAt: bindingName ifAbsent: [nil]) "wants ifPresent:!"
ifNotNil: [:oldSet | oldSet installMindset: self.
^oldSet].
^aNamespace at: bindingName
put: (self environmentMindsetClass
nullInEnvironment: aNamespace
overMindsets: newUnderMindsets asArray).
!
installMindset: newMindset
"Add newMindset's expansions to myself by adding it to my list of
under-Mindsets. Answer newMindset."
self == newMindset ifTrue: [^self].
(directUnderMindsets identityIncludes: newMindset)
ifFalse: [directUnderMindsets := directUnderMindsets
copyWith: newMindset.
self recomputeAllMindsetLists].
^newMindset
!
environmentMindsetClass
"Answer the class that can create CodeMindsets for use in
environments."
^EnvironmentCodeMindset
! !
!CodeMindset class methodsFor: 'activation'!
defaultName
"Answer the Symbol that names the binding searched for by the
RewritingCompiler to find a CodeMindset to preprocess Smalltalk
sources with."
^#MyCodeMindset
! !
!CodeMindset methodsFor: 'extending Smalltalk'!
expandTree: aProgramNode
"Apply the expansions of pseudo-messages based on the message
macros indexed in my messageMacroDictionary, and
ParseTreeRewriters registered with my rewriters property."
"Do all macros first, then all rewriters starting with mine."
^self withInferiorMindsets
inject: (self macroRewriter executeTree: aProgramNode; tree)
into: [:tree :mindset | mindset expandWithRewriters: tree]
!
messageMacroDictionary
"Answer a Dictionary mapping each selector symbol key to a
MessageMacro used for expanding each apparent message with that
selector."
^messageMacroDictionary
! !
!CodeMindset methodsFor: 'rewriting parse trees'!
rewriters
"Answer a Collection of parse tree rewriters (executeTree: tree)
that will be applied to each parse tree by expandTree:. This
collection does not include the special rewriter used for
expanding the message macros in messageMacroDictionary."
^rewriters
!
rewriters: aCollection
"Change the answer of rewriters."
rewriters := aCollection
! !
!CodeMindset methodsFor: 'printing'!
printOn: aStream
super printOn: aStream.
aStream nextPutAll: ' with ';
display: self messageMacroDictionary size;
nextPutAll: ' message macros and ';
display: self withInferiorMindsets size - 1;
nextPutAll: ' other CodeMindsets included (';
display: self allMessageMacros size;
nextPutAll: ' macros total)'.
! !
!CodeMindset methodsFor: 'private'!
macroRewriterClass
"Answer a class-y object that will produce a new ParseTreeRewriter
(addRule: executeTree: tree) implementing the rewriting
RBProgramNode walker for me."
^ParseTreeTrampolineRewriter
!
messageMacroDictionary: aDictionary directUnderMindsets: mindsets
overMindsets: omSet
"Used for initialization."
messageMacroDictionary := aDictionary.
directUnderMindsets := mindsets.
overMindsets := omSet.
!
directUnderMindsets
"Answer the list of CodeMindsets containing further message macros
and rewriters that I should use."
^directUnderMindsets
!
directOverMindsets
"Answer the list of CodeMindsets that should include me in their
answer to directUnderMindsets."
^overMindsets
!
registerOverMindset: aMindset
"Inform me that aMindset has me as a direct under-mindset."
overMindsets add: aMindset
!
withInferiorMindsets
"Answer the collection of all mindsets to use for rewriting
expansion and macro-binding search. This is memoized; use
computeMindsetList to change behavior instead."
^mindsetPrecedenceList
ifNil: [mindsetPrecedenceList := self computeMindsetList]
!
computeMindsetList
"Calculate a precedence list for withInferiorMindsets that places
all mindsets before those on which they depend."
| newList seenMindsetStates addWithInferiors |
newList := OrderedCollection new.
seenMindsetStates := IdentityDictionary new.
(addWithInferiors := [:mindset | | mState |
mState := seenMindsetStates at: mindset ifAbsent: [nil].
"detect infinite recursion"
#visiting == mState
ifTrue: [SystemExceptions.InvalidValue
signalOn: mindset
reason: 'mutually-dependent code mindsets'].
"This 'topological sort' algorithm finds a linear ordering for
which it is never the case that a mindset in the list will
never depend on one before it."
#visited == mState ifFalse:
[seenMindsetStates at: mindset put: #visiting.
mindset directUnderMindsets reverseDo: addWithInferiors.
newList addLast: mindset.
seenMindsetStates at: mindset put: #visited]]) value: self.
^newList reverse
!
recomputeAllMindsetLists
"Force my mindset precedence list and all those that include me to
be recomputed. Don't override this method; override
recomputeMindsetListInState: instead."
^self recomputeAllMindsetListsInState: IdentityDictionary new
!
recomputeMindsetList
"Force my inferior CodeMindset precedence list to be recomputed."
mindsetPrecedenceList := nil.
!
canRecomputeAllMindsetLists: seenMindsetStates
"Check whether I should perform a recomputation of my inferior
CodeMindset precedence list. Signal an error if this is infinite
recursion, and answer whether I should proceed."
| mState |
mState := seenMindsetStates at: self ifAbsent: [nil].
"detect infinite recursion"
#visiting == mState
ifTrue: [SystemExceptions.InvalidValue
signalOn: self
reason: 'mutually-dependent code mindsets'].
^#visited ~~ mState
!
recomputeAllMindsetListsInState: seenMindsetStates
"Helper for recomputeAllMindsetLists; seenMindsetStates is a
dictionary of CodeMindsets to symbols, where #visited means
recomputeMindsetListInState: has completed on that mindset, and
#visiting means its recomputeMindsetListInState: method is
currently executing with it as receiver."
(self canRecomputeAllMindsetLists: seenMindsetStates) ifFalse:
[seenMindsetStates at: self put: #visiting.
self recomputeMindsetList.
self directOverMindsets do: [:ms |
ms recomputeAllMindsetListsInState: seenMindsetStates].
seenMindsetStates at: self put: #visited].
!
expandWithRewriters: aProgramNode
"Use all my rewriters, but the macroRewriter, on aProgramNode in
sequence."
^self rewriters
inject: aProgramNode
into: [:tree :rewriter | rewriter executeTree: tree; tree].
!
allMessageMacros
"Answer a composite messageMacroDictionary, containing macros from
me and inherited from my underMindsets."
| compositeDictionary |
compositeDictionary := self messageMacroDictionary class new.
self withInferiorMindsets do: [:mindset |
mindset messageMacroDictionary keysAndValuesDo: [:s :m |
compositeDictionary at: s ifAbsentPut: [m]]].
^compositeDictionary
!
macroRewriter
"Answer a parse tree rewriter (executeTree: tree)."
| rewriteWalker compositeDictionary |
rewriteWalker := self macroRewriterClass new.
self allMessageMacros keysAndValuesDo: [:selector :macro |
rewriteWalker addRule:
(macro replaceRuleOnSelector: selector)].
^rewriteWalker
! !
!MessageMacro class methodsFor: 'generating variables'!
initialize
super initialize.
NewVariableNumber isNil ifTrue: [NewVariableNumber := 120].
!
newVariable
"Answer a new RBVariableNode with a generated name."
^self newVariable: 'gensym' "from Lisp tradition, really 'G'"
!
newVariable: prefix
"Answer a new RBVariableNode with a generated name starting with
'prefix', a String."
^STInST.RBVariableNode named:
((WriteStream with: prefix)
display: (NewVariableNumber := 1 + NewVariableNumber);
contents)
! !
!MessageMacro methodsFor: 'tree rewriting'!
expandMessageInPlace: aMessageNode
"Answer an RBValueNode to replace aMessageNode in the expanded
source code. This method is used by an RBBlockReplaceRule
directly to implement expansion. This implementation calls
expandMessage: to: withArguments: appropriately; extenders may
choose which one to override."
^self expandMessage: aMessageNode selector
to: aMessageNode receiver
withArguments: aMessageNode arguments
!
expandMessage: selector to: receiver withArguments: arguments
"Like expandMessageInPlace:, but with the parts of the message
send broken out."
^MessageMacro == (self class whichClassIncludesSelector:
#expandMessageInPlace:)
ifTrue: [self subclassResponsibility]
ifFalse: [self shouldNotImplement]
!
forgoExpansion
"Return from my innermost invocation (on this instance) to the
tree rewriter without modifying the tree."
cancelBlock value "hooray for lexical closures!"
!
replaceRuleOnSelector: aSelector
"Answer a new STInST.RBReplaceRule that performs the
pseudo-message expansion I represent on MessageNodes with
selector aSelector."
selector := aSelector. "for printOn:"
^STInST.RBBlockReplaceRule
searchForTree: (PatternBySelector forSelector: aSelector)
replaceWith: [:aMessageNode |
self expandMessageWithLocalReturn: aMessageNode]
! !
!MessageMacro methodsFor: 'private'!
expandMessageWithLocalReturn: aMessageNode
"Sets up forgoExpansion before entering the expand protocol,
forgoing if aMessageNode's parent is a cascade."
| oldCancelBlock |
aMessageNode parent isCascade ifTrue: [^aMessageNode].
oldCancelBlock := cancelBlock.
^[cancelBlock := [^aMessageNode].
self expandMessageInPlace: aMessageNode]
ensure: [cancelBlock := oldCancelBlock]
! !
!MessageMacro class methodsFor: 'common mistakes'!
replaceRuleOnSelector: aSelector
"Signal an error. CodeMindset expects instances, not subclasses."
^SystemExceptions.WrongClass signalOn: self mustBe: self
! !
MessageMacro initialize!
!PatternBySelector class methodsFor: 'instance creation'!
forSelector: aSymbol
"Answer a new instance who matches RBMessageNodes with selector
aSymbol."
^self new selector: aSymbol; yourself
! !
!PatternBySelector methodsFor: 'matching'!
match: aNode inContext: aDictionary
"Answer whether I match aNode."
^aNode class == self matchingClass
and: [selector == aNode selector]
!
matchingClass
"Answer the class of nodes I match with match:inContext:."
^STInST.RBMessageNode
! !
!PatternBySelector methodsFor: 'private'!
selector: aSymbol
selector := aSymbol
! !
!BlockMessageMacro class methodsFor: 'instance creation'!
expandingWith: aBlock
"Answer a new instance expanding received message nodes by asking
aBlock."
^self new expandBlock: aBlock; yourself
! !
!BlockMessageMacro methodsFor: 'tree rewriting'!
expandMessage: selector to: receiver withArguments: arguments
"Implement the protocol described in my super by calling the
expandWith: block with these arguments."
^expandBlock value: selector value: receiver value: arguments
! !
!BlockMessageMacro methodsFor: 'private'!
expandBlock: aBlock
expandBlock := aBlock
! !
!PatternMacro class methodsFor: 'instance creation'!
given: sourceString use: expansionString
"Answer a new instance who matches sourceString and, if the match
is successful, expands to expansionString, replacing patterns
therein with the matched pieces."
^self given: sourceString use: expansionString
withExtraVariables: #()
!
given: sourceString use: expansionString withExtraVariables: variableNames
^self new
given: (CodeTemplate fromExpr: sourceString)
use: (CodeTemplate fromExpr: expansionString)
withExtraVariables: variableNames;
yourself
! !
!PatternMacro methodsFor: 'tree rewriting'!
expandMessageInPlace: messageNode
"Answer an expansion of messageNode, created by applying
sourceTemplate to it, then using those matches and extra bindings
created from the usingVariables: instance creation argument, copy
the expansionPattern, inserting the results where appropriate."
| expansionBindings |
"Even though I appear to be doing the work of
replaceRuleOnSelector:'s answered rule, this is more of a
'refined' match done after the initial selector-based match."
expansionBindings := sourceTemplate match: messageNode.
expansionBindings ifNil: [^self forgoExpansion].
"add extra newVariables to expansionBindings"
expansionBindings := self addNewVariablesTo: expansionBindings.
^(expansionTemplate expand: expansionBindings)
copyCommentsFrom: messageNode;
yourself
!
addNewVariablesTo: expansionBindings
"Make new variables from newVariables and add them to
expansionBindings, the argument to CodeTemplate>>#expand:.
Answer expansionBindings."
newVariables isEmpty ifFalse: [ | patternChars |
patternChars := self patternMetaCharacters.
newVariables do: [:varPatternName | | varName |
varName := varPatternName reject: [:char |
patternChars includes: char].
expansionBindings
at: varPatternName
put: (self class newVariable: varName)]].
^expansionBindings
! !
!PatternMacro methodsFor: 'private'!
patternMetaCharacters
"Answer a list of the special characters used to identify features
of pattern variables to the parser, so they can be removed,
making a pattern variable suitable for use as a normal variable.
I currently use the expansionPattern to derive this, as this tree
is where the variables we are generating replacements for should
appear."
^expansionTemplate patternMetaCharacters
!
given: source use: expansion withExtraVariables: variables
"Slightly different argument meanings than the class method; see
source of that."
sourceTemplate := source.
expansionTemplate := expansion.
newVariables := variables.
! !
!RewritingCompiler class methodsFor: 'compiling'!
compile: methodNode asMethodOf: aBehavior classified: aString
parser: aParser environment: aNamespace
"As with super, but translate methodNode first according to
aBehavior's current CodeMindset."
^super compile: (aBehavior codeMindset expandTree: methodNode)
asMethodOf: aBehavior
classified: aString
parser: aParser
environment: aNamespace
! !
!EnvironmentCodeMindset class methodsFor: 'instance creation'!
new
"Signal an error, saying to use nullInEnvironment:overMindsets:
instead."
^SystemExceptions.WrongMessageSent
signalOn: #new useInstead: #nullInEnvironment:overMindsets:
!
nullInEnvironment: aNamespace overMindsets: mindsets
"Answer a new mindset transforming code using CodeMindsets in
mindsets *and* super-environments of aNamespace."
^(self nullOverMindsets: mindsets)
homeEnvironment: aNamespace; yourself
! !
!EnvironmentCodeMindset methodsFor: 'accessing'!
environment
"Answer the environment on whose behalf I transform Smalltalk
code."
^homeEnvironment
! !
!EnvironmentCodeMindset methodsFor: 'printing'!
printOn: aStream
aStream nextPutAll: 'Installed in ';
print: self environment;
nextPutAll: ': '.
super printOn: aStream.
! !
!EnvironmentCodeMindset methodsFor: 'private'!
homeEnvironment: environment
homeEnvironment := environment.
!
directUnderMindsets
| explicitMindsets |
explicitMindsets := super directUnderMindsets.
homeEnvironment allSuperspacesDo: [:ss | | superMindset |
superMindset := ss hereAt: self class defaultName
ifAbsent: [nil].
(superMindset isNil
or: [explicitMindsets identityIncludes: superMindset])
ifFalse: [^explicitMindsets copyWith: superMindset]].
^explicitMindsets
!
directOverMindsets
| superAnswer findShallowestCMs |
superAnswer := super directOverMindsets copy.
"add the 1-step-away environment CMs in subspaces"
self environment subspacesDo: (findShallowestCMs := [:subspace |
(subspace hereAt: self class defaultName ifAbsent: [nil])
ifNil: [subspace subspacesDo: findShallowestCMs]
ifNotNil: [:subCM | superAnswer add: subCM]]).
^superAnswer
! !
!ParseTreeTrampolineRewriter methodsFor: 'changing ProgramNodes'!
performSearches: aSearchCollection on: aNode
"As with super, but consider performOn: answering its node
argument to be equivalent to it answering nil."
aSearchCollection do: [:search | | searchResult |
searchResult := search performOn: aNode.
searchResult notNil & (aNode ~~ searchResult)
ifTrue: [self foundMatch. ^searchResult]].
^nil
!
visitNode: programNode searches: aSearchCollection onMatch: aBlock
"Visit programNode using aSearchCollection, and then its
resultant, repeatedly until visiting fails to replace the node.
On each replacement, pass the new node to aBlock."
| testNode nextNode |
testNode := programNode.
[nextNode := self performSearches: aSearchCollection on: testNode.
nextNode isNil] whileFalse:
[aBlock value: (testNode := nextNode)].
testNode acceptVisitor: self.
^testNode
!
visitNodes: aNodeList searches: aSearchCollection onMatch: aBlock
"Answer aNodeList but with each element replaced by the result of
sending visitNode:searches:onMatch to me with said element,
aSearchCollection, (and a block of my own). As each match
occurs, I'll call aBlock immediately with the replacement of
aNodeList before answering it."
| replacementList |
replacementList := nil.
aNodeList keysAndValuesDo: [:idx :eltNode |
self visitNode: eltNode searches: aSearchCollection onMatch:
[:newElt |
"create/fix the new list and send it (again)"
replacementList isNil
ifTrue: [replacementList := aNodeList copy].
replacementList at: idx put: newElt.
aBlock value: replacementList]].
^replacementList ifNil: [aNodeList]
! !
!ParseTreeTrampolineRewriter methodsFor: 'changing ProgramNode fields'!
acceptCascadeNode: cascadeNode
"Multiple strategies available:
Just visit the messages, and verify that all receivers are equal.
Doesn't work with indeterminate matching, as macros that use
MessageMacro>>#newVariable: are. Not using at this time.
Visit the first message, install its replacement everywhere, and
visit all the arguments. Has the drawback that cascade messages
can't be replaced, but that doesn't matter for the message
macroRewriter. Currently using this."
self visitNode: cascadeNode messages first receiver
onMatch: [:newRecv | cascadeNode messages
do: [:msg | msg receiver: newRecv]].
cascadeNode messages do: [:msg |
self visitNodes: msg arguments
onMatch: [:newArgs | msg arguments: newArgs]].
!
recusivelySearchInContext
"This message is normally sent to me by an RBParseTreeRule to
allow rewriting of matched pattern variables that answer 'true'
to #recurseInto. Only the values that match those variables are
rewritten; after the rule's foundMatchFor: answers a rewrite of
the matched ProgramNode, I leave that new node alone.
As my strategy is not to do that, but instead to always rewrite
every element of a replacement ProgramNode, this message is not
only unnecessary, but expands MessageMacros in the wrong order --
a MessageMacro expects pre-order expansion, where a message is
expanded before its receiver and argument expressions are
searched for expansions. Therefore, I do nothing in response to
this message."
! !
!CodeTemplate class methodsFor: 'converting Smalltalk forms'!
parseExpr: aString
"Answer a parsed RBProgramNode for aString. Signal an error if
the syntax is invalid."
^STInST.RBParser parseRewriteExpression: aString
!
unparseExpr: aNode
"Answer a string containing Smalltalk from parsed form aNode."
^aNode formattedCode
! !
!CodeTemplate class methodsFor: 'instance creation'!
fromExpr: aSmalltalkExpr
"Answer an instance of me using aSmalltalkExpr, a string
containing a complete Smalltalk pattern expression, as the pivot
for match: and expand:."
^self fromParsed: (self parseExpr: aSmalltalkExpr)
!
fromParsed: anRBProgramNode
"Answer an instance of me using anRBProgramNode, which should be the
parsed form of a Smalltalk expression or method."
^self new template: anRBProgramNode; yourself
! !
!CodeTemplate methodsFor: 'matching other code'!
contextToPatternMap: context
"Answer a pattern map based on the RBProgramNode context."
| stringMap |
stringMap := LookupTable new: context size.
context keysAndValuesDo: [:variable :code |
"some other stuff gets stuck in context as well; ignore it"
((variable isKindOf: STInST.RBProgramNode)
and: [variable isVariable])
ifTrue: [stringMap at: variable name put: code]
ifFalse: [variable isString
ifTrue: [stringMap at: variable asSymbol put: code]]].
^stringMap
!
match: aParseNode
"If my pattern template matches the Smalltalk represented in
aParseNode, answer a pattern map for the match. Otherwise,
answer nil.
For pattern variables using '@', the associated value may be a
list instead."
| context |
context := STInST.RBSmallDictionary new.
(template match: aParseNode inContext: context)
ifFalse: [^nil].
"RB's context format is wrong for my interface"
^self contextToPatternMap: context
! !
!CodeTemplate methodsFor: 'combining patterns and variable mappings'!
contextFromPatternMap: aDictionary
"Convert a pattern map to RBProgramNode's context format."
| context |
context := STInST.RBSmallDictionary new: aDictionary size.
"FIXME: support partial selector parts. Also, I think the idea of
representing selector patterns as symbols came when I mixed up
some ideas about how to differentiate them from variables with
how contexts actually represent them (as strings). Maybe there
is something better e.g. a trailing colon."
aDictionary keysAndValuesDo: [:varName :code |
context at: (varName isSymbol
ifTrue: [varName asString]
ifFalse: [STInST.RBVariableNode named: varName])
put: code].
^context
!
patternMetaCharacters
"Answer a list of the special characters used to identify features
of pattern variables to the parser. Every variable/key in a
pattern map should have at least one of these characters. (I was
originally added to support PatternMacro.)"
^{template listCharacter.
template literalCharacter.
template recurseIntoCharacter.
template statementCharacter.
STInST.RBScanner patternVariableCharacter}
!
expand: aDictionary
"Expand my template pivot using the given pattern map. Signal an
error if the pattern map is missing a needed variable; extra
variables are ignored."
^template copyInContext:
(self contextFromPatternMap: aDictionary)
! !
!CodeTemplate methodsFor: 'private'!
template: aNode
template := aNode
! !
"Putting expansion into environment's Compiler"
!Smalltalk.Behavior methodsFor: 'compiling'!
codeMindset
"Answer the CodeMindset representing the syntactic and semantic
idiosyncracies of code compiled for this class."
^self environment at: NoCandy.Presrc.EnvironmentCodeMindset defaultName
ifAbsent: [##(NoCandy.Presrc.CodeMindset new)]
!
compilerClass
"This method is present for symmetry with #parserClass. It
specifies the class that will be used to compile the parse nodes
into bytecodes."
"Behavior>>#codeMindset must be compiled before this may ever
answer RewritingCompiler in place of STCompiler"
^self environment at: #Compiler
ifAbsent: [STInST.STCompiler]
! !
!Smalltalk.Metaclass methodsFor: 'delegation'!
codeMindset
"Delegate to instanceClass; see Behavior."
^self instanceClass codeMindset
!
compilerClass
"Delegate to instanceClass. While this override changes the
meaning of 'current compiler' somewhat, I think users will expect
class methods to compile with the same compilerClass as instance
methods."
^self instanceClass compilerClass
! !
"Presource.st ends here"
PK
̌6-) ) PresourceLib.stUT dF)eFUx "PresourceLib.st: Basic useful macros included with Presource.
Copyright (C) 2007 Stephen Compall.
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program. If not, see ."
"Commentary
These are some useful message macros that are useful in a wide variety
of circumstances. Their raison d'etre is to fill some ``holes'' in
the Smalltalk language.
CondSelectMacro is a general-purpose conditional combiner designed to
make deeply-nested conditional messages using blocks, such as
#ifTrue:ifFalse: and #ifNotNil:ifNil:, easier to read and understand.
It is useful if you ever find yourself with code that looks like this:
aCondition ifTrue: [aResult]
ifFalse: [anotherCondition ifTrue: [anotherResult]
ifFalse: [...]]
CondSelectMacro provides the #condSelect pseudo-message,
which translates a flat brace-form into a nested conditional. See
`CondSelectMacro comment' for more information.
ShortCircuitMacro provides something similar for nested #and: and #or:
invocations. It effectively allows #and: and #or: expressions with
any number of arguments, so you can simplify code like:
aCondition and: [another and: [yetAnother and: [still]]]"
"Code"
Namespace current: NoCandy.Presrc!
MessageMacro subclass: #CondSelectMacro
instanceVariableNames: 'branches'
classVariableNames: 'MessageWrap'
poolDictionaries: ''
category: 'Presource-useful macros'
!
CondSelectMacro comment:
'I nest a linear series of conditional tests into a short-circuiting
series of conditional tests on behalf of a CodeMindset. For example:
{"case combiner: consequent."
a -> [b].
c -> [d].
e -> [f]} condSelect
-> a ifTrue: [b] ifFalse: [c ifTrue: [d] ifFalse: [e ifTrue: [f]]]
The combiner that links each case to its consequent, "->" in the
above, can be anything in `branches'', a dictionary you can get by
sending #branches. The key is the combiner as a symbol (e.g. #->),
and the value is the real two-argument message selector, a symbol
(e.g. #ifTrue:ifFalse:), where the first argument is the consequent,
and the second is a block I invent to contain the remaining cases.
Here are the defaults:
{#-> -> #ifTrue:ifFalse:.
#ifTrue: -> #ifTrue:ifFalse:.
#ifFalse: -> #ifFalse:ifTrue:.
#ifNotNil: -> #ifNotNil:ifNil:}
For the last case, I do not use the entire real message, but instead
split it and only use the first keyword for the message
(e.g. #ifTrue:). As such, the above default requires that case
expressions accept the messages #ifTrue:, #ifFalse:, and #ifNotNil: as
appropriate.
`#ifNil: -> #ifNil:ifNotNil:'' is not provided, as the block I provide
for the second argument does not take an argument. Keep this natural
limitation in mind when adding combiners to `branches''. At the same
time, note that I do no transformation of the consequent, so it can be
something other than a block where appropriate.
You should expect that the matching case answers whatever the
consequent answers, unless you are doing something particularly
strange with #condSelect.
If you want an unconditional last case, as is common, just use `true
-> ["last case statements"]''.
Another example:
{a ifNotNil: [:val | val].
b -> [c].
d ifFalse: [self error: ''what?'']} condSelect
-> a ifNotNil: [:val | val]
ifNil: [b ifTrue: [c]
ifFalse: [d ifFalse: [self error: ''what?'']]]
I''ll also revisit the first example, just to give you another
perspective on how this works. Watch how the #condSelect expression
shrinks and moves deeper:
{a -> [b].
c -> [d].
e -> [f]} condSelect
-> a ifTrue: [b]
ifFalse: [{c -> [d].
e -> [f]} condSelect]
-> a ifTrue: [b]
ifFalse: [c ifTrue: [d]
ifFalse: [{e -> [f]} condSelect]]
-> a ifTrue: [b]
ifFalse: [c ifTrue: [d]
ifFalse: [e ifTrue: [f]]]
branches
A dictionary as described above.
MessageWrap
A CodeTemplate for a conditional message.'
!
MessageMacro subclass: #ShortCircuitMacro
instanceVariableNames: 'binaryCombiner'
classVariableNames: 'ShortCircuit'
poolDictionaries: ''
category: 'Presource-useful macros'
!
ShortCircuitMacro comment:
'I nest a linear series of conditional tests using a short-circuiting
binary message that takes a block as its argument. For example:
{a. b. c. d} condBinary: #and:
-> a and: [b and: [c and: [d]]]
I am useful when you want to indicate a series of tests. Installed
with the default Backstage set of macros are #condEvery and #condSome,
which are like invoking me with #and: and #or:, respectively.
{e. f. g. h} condSome
-> e or: [f or: [g or: [h]]]
binaryCombiner
If not nil, the combiner to use when one isn''t provided as an
argument.
ShortCircuit
A CodeTemplate that sends a short-circuit message with a block.'
!
!CondSelectMacro class methodsFor: 'instance creation'!
initialize
super initialize.
(self isMemberOf: thisContext method methodClass) ifTrue:
[MessageWrap := CodeTemplate fromExpr:
'`@test `@selector: `@consequent selector: [`@alternate]'].
!
new
"Answer a macro with no message branch combiners provided."
^super new branches: (IdentityDictionary new: 4); yourself
!
default
"Answer a macro with default branches provided as described in the
class comment."
| newInstance |
newInstance := self new.
newInstance branches
at: #-> put: #ifTrue:ifFalse:;
at: #ifTrue: put: #ifTrue:ifFalse:;
at: #ifFalse: put: #ifFalse:ifTrue:;
at: #ifNotNil: put: #ifNotNil:ifNil:.
^newInstance
! !
!CondSelectMacro class methodsFor: 'testing structure'!
isClauseSeries: aProgramNode
"Answer whether aProgramNode is a valid series of cond-clauses."
^(aProgramNode isKindOf: STInST.RBArrayConstructorNode)
and: [aProgramNode body statements allSatisfy: [:stmt |
CondSelectMacro isClause: stmt]]
!
isClause: aProgramNode
"Answer whether aProgramNode is a valid cond-clause."
^aProgramNode isMessage and: [aProgramNode arguments size = 1]
! !
!CondSelectMacro methodsFor: 'choosing branches'!
branches
"Answer the dictionary I use to calculate real two-argument
messages from case combiners."
^branches
!
branchFor: combiner
"Answer a selector for the real message called for by the given
case combiner. Signal an error if combiner is unrecognized."
^self branches at: combiner
! !
!CondSelectMacro methodsFor: 'expanding macros'!
expandMessage: selector to: receiver withArguments: arguments
"Expand the given message as described in class comment."
| condCases nextForm lastCase |
(CondSelectMacro isClauseSeries: receiver)
ifFalse: [SystemExceptions.InvalidArgument
signalOn: receiver
reason: ('%1 receiver must be a brace-form of one-argument messages; see class comment'
bindWith: selector)].
condCases := receiver body statements.
lastCase := condCases last.
nextForm := STInST.RBMessageNode
receiver: lastCase receiver
selector: (self branchFor: lastCase selector) keywords first
arguments: lastCase arguments.
"Now do the rest backwards to deepen the last case and so on. I
set nextForm repeatedly to simulate a backwards reduction."
condCases size - 1 to: 1 by: -1 do: [:idx | | condCase |
condCase := condCases at: idx.
nextForm := MessageWrap expand:
(LookupTable from:
{'`@test' -> condCase receiver.
#'`@selector:' -> (self branchFor: condCase selector).
'`@consequent' -> condCase arguments first.
'`@alternate' -> nextForm})].
^nextForm
! !
!CondSelectMacro methodsFor: 'private'!
branches: aDictionary
branches := aDictionary
! !
CondSelectMacro initialize!
!ShortCircuitMacro class methodsFor: 'instance creation'!
initialize
(self isMemberOf: thisContext method methodClass) ifTrue:
[ShortCircuit := CodeTemplate fromExpr:
'`@consequent `selector: [`@alternate]'].
!
new
"Answer a macro that can short-circuit expressions given an
argument, but not independently."
^self combining: nil
!
combining: aSelector
"Answer a new macro that will use aSelector to combine each
expression with a block representing the remainder, if not given
one as a literal argument."
^super new binaryCombiner: aSelector; yourself
! !
!ShortCircuitMacro methodsFor: 'private'!
binaryCombiner: aSelector
binaryCombiner := aSelector.
!
combine: statements using: combiner
"Answer a message node short-circuiting statements with combiner,
a one-arg selector."
| form |
"FIXME: deal with 0 stmts"
statements size < 1 ifTrue: [self error: 'can''t default short-circuit yet'].
form := statements last.
statements size - 1 to: 1 by: -1 do: [:idx |
form := ShortCircuit expand:
(LookupTable from:
{'`@consequent' -> (statements at: idx).
#'`selector:' -> combiner.
'`@alternate' -> form})].
^form
! !
!ShortCircuitMacro methodsFor: 'expanding macros'!
expandMessage: ignoreSelector to: arrayList withArguments: expCombiner
((arrayList isKindOf: STInST.RBArrayConstructorNode) and:
[(binaryCombiner isNil
ifTrue: [expCombiner size = 1]
ifFalse: [expCombiner size between: 0 and: 1]) and:
[expCombiner isEmpty or:
[expCombiner first isLiteral and:
[expCombiner first value isSymbol]]]]) ifFalse:
[self error: 'short-circuits must have the form {...} selector: #combiner:'].
^self combine: arrayList body statements
using: (expCombiner isEmpty
ifTrue: [binaryCombiner]
ifFalse: [expCombiner first value])
! !
ShortCircuitMacro initialize!
"Install NoCandy's mindset with these macros"
NoCandy at: EnvironmentCodeMindset defaultName ifAbsentPut:
[| mindset |
mindset := EnvironmentCodeMindset nullInEnvironment: NoCandy
overMindsets: #().
mindset messageMacroDictionary
at: #condSelect put: CondSelectMacro default;
at: #condBinary: put: ShortCircuitMacro new;
at: #condEvery put: (ShortCircuitMacro combining: #and:);
at: #condSome put: (ShortCircuitMacro combining: #or:).
mindset]
! !
"PresourceLib.st ends here"
PK
65RJ RJ Test-Presource.stUT dF)eFUx "Test-Presource.st: Unit tests for Presource.st.
Copyright (C) 2006, 2007 Stephen Compall.
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program. If not, see ."
"Commentary
This is an SUnit test suite for Presource, the No Candy Backstage
Smalltalk compiler extension utility.
Quick test script, with NoCandy as current namespace:
{Presrc.Tests.TestCodeTemplate.
Presrc.Tests.TestMessageMacroExpansion.
Presrc.Tests.TestCodeMindsetInstall.
Presrc.Tests.TestCompiling.
Presrc.Tests.TestStandardMacros} do: [:testClass | | suite |
suite := testClass buildSuiteFromSelectors.
suite tests do: [:test | test logPolicy:
(TestVerboseLog on: test failureLog)].
suite run]
TODO major features before (after) special Presource-only release:
* hierarchical macro-dictionary -- DONE
* test for real copy in copyInContext:
* few more tests, including compilation/execution
* manual for using major features
* manual for the RB pattern syntax
"
"Code"
Namespace current: NoCandy.Presrc.Tests!
MessageMacro subclass: #SendingBlockMacro
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Presource-misc macros'
!
SendingBlockMacro comment:
'I am a unary message-macro that converts a symbol, its receiver, into
a block. This block sends the symbol to its first argument, passing
the remaining block arguments as message arguments. The number of
arguments is determined with "symbol numArgs".
Examples:
#+ asMessagingBlock
-> [:var1 :var2 | var1 + var2]
#first asMessagingBlock
-> [:var1 | var1 first]'
!
MessageMacro subclass: #ValueWithAsMacro
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Presource-misc macros'
!
ValueWithAsMacro comment:
'I am a pseudo-message on BlockClosures that temporarily sets its
valueWith: argument, a variable, to its as: argument, an expression,
while executing the receiver, an expression that evaluates to a
BlockClosure.
Examples:
aBlock valueWith: currentState as: State new
-> [| var1 |
var1 := currentState.
[currentState := State new.
aBlock value] ensure: [currentState := var1]] value
TODO: Define a "places" construct, so you can have accessors and x at:
i constructs. Or maybe this won''t work so well without a more
elaborate setf-expansion system, which might be more effort than this
is worth.'
!
"A replacement for 'ValueWithAsMacro new', using PatternMacro."
Namespace current
at: #PatternValueWithAsMacro
put: (PatternMacro
"we pattern out the selector because we use a different
selector in testing. `stateVar's var-only pattern is
also used for testPreorderTraversal, so leave it alone"
given: '`@aBlock `valueWith: `stateVar `as: `@newValue'
use: '[| `oldValue |
`oldValue := `stateVar.
[`stateVar := `@newValue.
`@aBlock value] ensure: [`stateVar := `oldValue]] value'
withExtraVariables: #('`oldValue'))
!
"An identity macro, for testing expansion order"
Namespace current
at: #IdentityMacro
put: (PatternMacro given: '`@anExpr identity'
use: '`@anExpr')
!
TestCase subclass: #TestCodeTemplate
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Presource-tests'
!
TestCodeTemplate comment:
'I test CodeTemplate, a tool wrapping RBProgramNode''s pattern
matching and expansion operations for convenience.'
!
TestCase subclass: #TestMessageMacroExpansion
instanceVariableNames: 'codeMindset'
classVariableNames: ''
poolDictionaries: ''
category: 'Presource-tests'
!
TestMessageMacroExpansion comment:
'I test the message-macro expansion mechanism managed by CodeMindset
in Presource.st.'
!
TestCase subclass: #TestCodeMindsetInstall
instanceVariableNames: 'baseCM extensionCM'
classVariableNames: ''
poolDictionaries: ''
category: 'Presource-tests'
!
TestCodeMindsetInstall comment:
'I test CodeMindset environment installation and interdependencies.'
!
TestCase subclass: #TestCompiling
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Presource-tests'
!
TestCompiling comment:
'I test RewritingCompiler and its interaction with Behaviors and
AbstractNamespaces.'
!
TestCase subclass: #TestStandardMacros
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Presource-tests'
!
TestStandardMacros comment:
'I test the macros in the No Candy mindset.'
!
!SendingBlockMacro methodsFor: 'tree rewriting'!
expandMessage: selector to: receiver withArguments: arguments
"Answer expansion-see class comment."
| receiverGensym argsGensyms messageNode |
receiverGensym := MessageMacro newVariable: 'receiver'.
argsGensyms := (1 to: receiver value numArgs)
collect: [:num | MessageMacro newVariable: 'arg'].
messageNode := STInST.RBMessageNode
receiver: receiverGensym
selector: receiver value
arguments: argsGensyms.
^STInST.RBBlockNode
arguments: (argsGensyms copyReplaceFrom: 1 to: 0
withObject: receiverGensym)
body: (STInST.RBSequenceNode
statements: (OrderedCollection with: messageNode))
! !
!ValueWithAsMacro methodsFor: 'tree rewriting'!
expandMessage: selector to: receiver withArguments: arguments
"Answer expansion-see class comment."
^STInST.RBMessageNode
receiver: (STInST.RBBlockNode
body: (self bindingSequenceNodeWith: (arguments at: 1)
as: (arguments at: 2)
during: receiver))
selector: #value
!
bindingSequenceNodeWith: place as: newValue during: receiverBlockExp
"Answer a sequence node that 'binds' place to newValue."
| oldValueVar ensureReceiver placeReset |
oldValueVar := MessageMacro newVariable: 'oldValue'.
ensureReceiver := STInST.RBSequenceNode
statements: (OrderedCollection
with: (STInST.RBAssignmentNode
variable: place
value: newValue)
with: (STInST.RBMessageNode
receiver: receiverBlockExp
selector: #value)).
placeReset := STInST.RBSequenceNode
statements: (OrderedCollection
with: (STInST.RBAssignmentNode
variable: place
value: oldValueVar)).
^STInST.RBSequenceNode
temporaries: (OrderedCollection with: oldValueVar)
statements:
(OrderedCollection
with: (STInST.RBAssignmentNode
variable: oldValueVar
value: place)
with: (STInST.RBMessageNode
receiver: (STInST.RBBlockNode
body: ensureReceiver)
selector: #ensure:
arguments: (OrderedCollection
with: (STInST.RBBlockNode
body: placeReset))))
! !
!TestCodeTemplate methodsFor: 'testing pattern matching'!
testMatchResults
| expectedMap actualMap |
self assert:
((LookupTable from: {'`a' -> 'x'. '`b' -> 'y'. '`c' -> 'z'})
collect: [:vName | STInST.RBVariableNode named: vName])
= ((CodeTemplate fromExpr: '`a at: `b put: `c')
match: (CodeTemplate parseExpr: 'x at: y put: z')).
actualMap := (CodeTemplate fromExpr: 'z `@at: `@a')
match: (CodeTemplate parseExpr: 'z at: x put: y').
self assert:
((actualMap includesKey: #'`@at:')
and: [#at:put: == (actualMap at: #'`@at:')]).
self assert:
((actualMap includesKey: '`@a')
and: [((actualMap at: '`@a') asArray
collect: [:v | v name]) = #('x' 'y')]).
! !
!TestCodeTemplate methodsFor: 'testing pattern expansion'!
testExpansionMapMismatch
| pxTemplate extraVarsPMap |
pxTemplate := CodeTemplate fromExpr: '`x'.
self should: [pxTemplate expand: (LookupTable new: 0)]
raise: Error
description: 'missing vars in expand:''s pattern map fails'.
extraVarsPMap := (LookupTable from: {'`x' -> 'a'. '`y' -> 'b'})
collect: [:v | STInST.RBVariableNode named: v].
self shouldnt: [pxTemplate expand: extraVarsPMap]
raise: Error
description: 'extra vars in expand:''s pattern map are ignored'.
self should: [(CodeTemplate fromExpr: 'x `@send: `@args')
expand: (LookupTable from: {'`@args' -> #()})]
raise: Error
description: 'missing selectors in expand:''s pattern map fails'.
!
testPatternCode
self assert:
((CodeTemplate fromExpr: '`x at: `y') expand:
((LookupTable from: {'`x' -> 'a'. '`y' -> 'b'})
collect: [:v | STInST.RBVariableNode named: v]))
= (CodeTemplate parseExpr: 'a at: b').
! !
!TestMessageMacroExpansion class methodsFor: 'testing expansion results'!
doesPresource: sourceString expandTo: outputString in: codeMindset
"Answer whether expanding sourceString as Smalltalk using
codeMindset matches RB pattern outputString."
^(STInST.RBParser parseRewriteMethod: 'test ' , outputString)
match: (codeMindset expandTree:
(STInST.RBParser parseMethod: 'test ' , sourceString))
inContext: STInST.RBSmallDictionary new
! !
!TestMessageMacroExpansion methodsFor: 'initialize-release'!
setUp
codeMindset := CodeMindset new.
codeMindset messageMacroDictionary
at: #sendingBlock
put: SendingBlockMacro new;
at: #valueWith:as:
put: ValueWithAsMacro new;
at: #patternValueWith:as:
put: PatternValueWithAsMacro; "not a class"
at: #identity
put: IdentityMacro "also not a class"
! !
!TestMessageMacroExpansion methodsFor: 'unit testing'!
testArgumentedExpansion
self assertThat: 'aBlock valueWith: currentState as: State new'
expandsTo: '[| `var1 |
`var1 := currentState.
[currentState := State new.
aBlock value] ensure: [currentState := `var1]] value'
!
testUnaryExpansion
self assertThat: '#(1 2 3) fold: #+ sendingBlock'
expandsTo: '#(1 2 3) fold: [:`recv :`arg | `recv + `arg]';
assertThat: '#first sendingBlock'
expandsTo: '[:`recv | `recv first]';
assertThat: '#at:put: sendingBlock'
expandsTo: '[:`recv :`arg1 :`arg2 | `recv at: `arg1 put: `arg2]'.
!
testPatternExpansion
self assertThat: 'aBlock patternValueWith: currentState as: State new'
expandsTo: '[| `var1 |
`var1 := currentState.
[currentState := State new.
aBlock value] ensure: [currentState := `var1]] value'.
!
testPreorderTraversal
"This test may have to change if the semantics of PatternMacro's
forgo-on-no-pattern-match feature change. Currently, it just
forgoes expansion without any error. This test assumes
trampolining behavior in testExpanderTrampolines."
self assertThat: 'aBlock patternValueWith: currentState identity
as: State new'
expandsTo: 'aBlock patternValueWith: currentState
as: State new'
description: 'Outer expressions expand before inner ones'.
!
testExpanderTrampolines
"Trampolining should happen iff expansion is not forgone by the
MessageMacro."
self assertThat: 'aBlock identity identity'
expandsTo: 'aBlock';
assertThat: 'aBlock patternValueWith: currentState first
as: State new'
expandsTo: 'aBlock patternValueWith: currentState first
as: State new'.
! !
!TestMessageMacroExpansion methodsFor: 'expansion testing'!
doesPresource: aPresourceString expandTo: aPattern
"Answer whether aPresourceString, parsed as an expression and
expanded using codeMindset, matches against aPattern when
expanded."
^self class doesPresource: aPresourceString
expandTo: aPattern
in: codeMindset
!
assertThat: aPresourceString expandsTo: aPattern
^self assertThat: aPresourceString
expandsTo: aPattern
description: ((WriteStream on: (String new: 50))
print: aPresourceString;
nextPutAll: ' expands to ';
print: aPattern;
contents)
!
assertThat: aPresourceString expandsTo: aPattern description: description
^self assert: (self doesPresource: aPresourceString expandTo: aPattern)
description: description
! !
!TestCodeMindsetInstall methodsFor: 'checking common relationships'!
setUp
baseCM := CodeMindset new.
extensionCM := CodeMindset new.
baseCM messageMacroDictionary
at: #identity put: IdentityMacro;
at: #valueWith:as: put: PatternValueWithAsMacro.
extensionCM messageMacroDictionary
at: #identity
put: (PatternMacro given: '`@recv identity'
use: '`@recv ifNotNil: [:`var | `var]'
withExtraVariables: #('`var')).
!
checkBase: aBaseCM andExtension: anExtensionCM
"Assert some common properties of aBaseCM and anExtensionCM; see
source for details on what those are."
self assert: (TestMessageMacroExpansion
doesPresource: 'x identity'
expandTo: 'x ifNotNil: [:`var | `var]'
in: anExtensionCM)
description: 'self is first in CM precedence list'.
self deny: (TestMessageMacroExpansion
doesPresource: 'aBlock valueWith: q as: r'
expandTo: '`aBlock valueWith: `q as: `r'
in: anExtensionCM)
description: 'over-CMs can apply under-CMs'' expansions'.
self assert: (TestMessageMacroExpansion
doesPresource: 'x identity'
expandTo: 'x'
in: aBaseCM)
description: 'over-CMs don''t affect expansion in under-CMs'.
!
checkBaseAndExtension
"Assert some common properties of baseCM and extensionCM; see
source for details on what those are."
^self checkBase: baseCM andExtension: extensionCM
!
!TestCodeMindsetInstall methodsFor: 'temporary namespaces'!
addSubspaceWithMindset: aCodeMindset in: aNamespace
"Answer a new subspace of aNamespace with aCodeMindset installed
as its current CodeMindset."
| nsNameIdx nsName newNamespace |
"find a unique name for the test namespace"
nsNameIdx := 0.
[nsNameIdx := 1 + nsNameIdx.
nsName := 'TestNS%1' bindWith: nsNameIdx.
"includes, not defines, is right here, as I don't want to wipe
out functionality for *any* code in aNamespace"
aNamespace includesGlobalNamed: nsName] whileTrue.
"create the NS and install aCodeMindset in it"
newNamespace := aNamespace addSubspace: nsName.
[aCodeMindset installIn: newNamespace]
ifCurtailed: [self deleteNamespace: newNamespace].
^newNamespace
!
prepareNamespaceWith: aCodeMindset
"Answer a new namespace under NoCandy.Presrc.Tests with
aCodeMindset set as its current environment CodeMindset."
^self addSubspaceWithMindset: aCodeMindset
in: thisContext methodClass environment
!
deleteNamespace: aNamespace
"Make the namespace hierarchy forget about aNamespace. This
method relies on a recent feature in GST."
^aNamespace superspace removeSubspace: aNamespace name
! !
!TestCodeMindsetInstall methodsFor: 'testing deps w/o environment'!
testOverMindsets
| extension extensionMMD |
extension := CodeMindset nullOverMindsets: {baseCM}.
extensionMMD := extension messageMacroDictionary.
extensionCM messageMacroDictionary
associationsDo: [:a | extensionMMD add: a].
extensionCM := extension.
self checkBaseAndExtension.
!
testSingleInstall
extensionCM installMindset: baseCM.
self checkBaseAndExtension.
!
testMultiInstall
| m3 |
extensionCM installMindset: baseCM.
m3 := CodeMindset nullOverMindsets: {baseCM}.
extensionCM installMindset: m3.
m3 messageMacroDictionary
at: #identity put: (PatternMacro given: '`@x identity'
use: '[`@x] value').
self checkBaseAndExtension.
self assert: (TestMessageMacroExpansion
doesPresource: 'fq identity'
expandTo: '[fq] value'
in: m3)
description: 'CM within hierarchy holds its position'.
!
testCircularDeps
self assert:
([extensionCM installMindset: baseCM.
baseCM installMindset: extensionCM.
self checkBaseAndExtension.
false]
on: SystemExceptions.InvalidValue
do: [:e | (e value == baseCM) | (e value == extensionCM)
ifTrue: [true] ifFalse: [e pass]])
description: 'circular dependency detected'.
! !
!TestCodeMindsetInstall methodsFor: 'testing environment installs'!
testPackagedInstall
| environment environmentCM extensionEnv extensionEnvCM |
environment := self prepareNamespaceWith: baseCM.
[environmentCM := environment at: CodeMindset defaultName.
self assert: (TestMessageMacroExpansion
doesPresource: 'qq identity'
expandTo: 'qq'
in: environmentCM)
description: 'simple installation works'.
extensionEnv := self addSubspaceWithMindset: extensionCM
in: environment.
extensionEnvCM := extensionEnv at: CodeMindset defaultName.
self assert: (TestMessageMacroExpansion
doesPresource: 'qq identity'
expandTo: 'qq ifNotNil: [:`v | `v]'
in: extensionEnvCM)
description: 'environment hereAt: #MyCodeMindset is primary'.
self checkBase: environmentCM andExtension: extensionEnvCM.]
"clean up temp namespaces"
ensure: [self deleteNamespace: environment].
!
testCombiningInstall
| environment newXtn |
environment := self prepareNamespaceWith: extensionCM.
[newXtn := environment at: CodeMindset defaultName.
baseCM installIn: environment.
self checkBase: baseCM andExtension: newXtn.]
ensure: [self deleteNamespace: environment].
! !
!TestCompiling methodsFor: 'configuring Behaviors'!
testCodeMindsetLookup
| fakeMindset mKey |
self assert: (Smalltalk.Object codeMindset isKindOf: CodeMindset).
mKey := EnvironmentCodeMindset defaultName.
[fakeMindset := CodeMindset new installIn: Smalltalk.
self assert: fakeMindset == (Smalltalk at: mKey).
self assert: fakeMindset == Smalltalk.Object codeMindset]
ensure: [Smalltalk removeKey: mKey].
! !
!TestStandardMacros methodsFor: 'testing'!
assertThat: presource expandsTo: expansion
"FIXME: this duplicates TestMessageMacroExpansion>>#assertThat:expandsTo:."
self assert: (TestMessageMacroExpansion
doesPresource: presource expandTo: expansion
in: self mindset)
description: ('%1 -> %2' % {presource. expansion}).
!
mindset
^NoCandy at: EnvironmentCodeMindset defaultName
!
testCondSelect
self assertThat: '{a -> [b]. c -> [d]} condSelect'
expandsTo: 'a ifTrue: [b] ifFalse: [c ifTrue: [d]]';
assertThat: '{a -> [b]} condSelect'
expandsTo: 'a ifTrue: [b]';
assertThat: '{a -> [b]. c ifNotNil: [:each | d].
e ifNotNil: [:x | f]} condSelect'
expandsTo: 'a ifTrue: [b]
ifFalse: [c ifNotNil: [:each | d]
ifNil: [e ifNotNil: [:x | f]]]'.
!
testShortCircuit
self assertThat: '{a. b. c} condEvery'
expandsTo: 'a and: [b and: [c]]';
assertThat: '{d. e. f} condSome'
expandsTo: 'd or: [e or: [f]]';
assertThat: '{g. h} condSome'
expandsTo: 'g or: [h]';
assertThat: '{i. j. k} condBinary: #xor:'
expandsTo: 'i xor: [j xor: [k]]'.
! !
"Testsuite.st ends here"
PK
Ҍ6 package.xmlUT dF)eFUx
NoCandyPresource
NoCandy.Presrc
Compiler
Presource
NoCandy.Presrc.Tests
NoCandy.Presrc.Tests.TestCodeTemplate
NoCandy.Presrc.Tests.TestMessageMacroExpansion
NoCandy.Presrc.Tests.TestCodeMindsetInstall
NoCandy.Presrc.Tests.TestCompiling
NoCandy.Presrc.Tests.TestStandardMacros
Test-Presource.st
Presource.st
PresourceLib.st
Presource.st
PresourceLib.st
Test-Presource.st
PK 36Nb/ COPYINGUT zFmcFUx }[sG֯ώ5,H.IYm Dؾ_f֥ ؗ8'"~kof~l_fWť?y7״E] W3^ֻ}SFǩ l5-mO4n8fHѵoi% a 2zOPNP~Ƿ%J",ڹqm }j =Cݦfֽ]e߰
cK)Us7 x k5
Ș08ͮ3ў7Pmi6ٓHBB gG!Zak5E9- +WY=`|\H4 F > |#"td+ uYPKA,WG${/ߏPJʶ෮5` jbHBX3 J +Q==>{{ys~Ǯ_[L 2o͏sNݲPp'bbo]FuYY%ѴЛ2LUѹm3B}Ep[ܑǸMY 6XWR/hyF# 9rZNHN詉 $1mHLpVEeMD "`lrʳ s˚_1%DY EbB{mVn!o%
w:w_J`
wY
x&
IPxW
@ɒ]*<ӧ3;Yմ=MP^vP2W^3Vu0Lt
ȍhdmajsDCg
, *de= NT
MVF;1A ' ^^&;VWж kh
iI{?.EY"aHn \ %XzَWIz B_(*f#, -ea)X5x(^HK#}Tg|xWRDD d@"w, ql?V0NЇ^i
Lo.1`oަWw#"G?orCZ)SA),˱`n/
=Ӭ#- RQrGZ+0*z 3fH: /XL=*WaV,:$fU_f!J2J3{mME͒Uŋ_"={4DP&PvT Ѡ>T[)y.uϲs ۹GBECrA[(BS_KWu?T&mq9i cKZ` _ GExVuR{P(%1j< Hc&#(&J6`6RR%c /o䘺"I*!4^V䒱Y2؟C#Ep\v*v /JxO@=爋"
{XӇiB/FB{9A3'pM&*ERYQ,,! Zge1}at3>*$Yc_p.ˋv]09ٕ:+#\ GۨU #&I۲\b;®gr КBX4 OY)(]>!_0.|a|F@J1pCFh:˔$#rM$LGB]-K EٷKtŐd!H2ZBU9J(էI'#L+؉ SG.[M!jQEW9
[m@.Q%Q&%n7Ib;aC2eFI44qoe/12II
; D9> 4+6NTɴzZ_ͪ?bFi Mk\[b#~P1V'on ہPq`. rħ:>KC;a@όK_zx].Hd =Mn >,& UXm Lȷ8sq/IL7tG} aoxeq{|Z3'cn{BvIO/\*zQ|$Р 69TJI>g@iJ4(6Y L
P/fU0H> Cr6cUUNu3,Vdq`fO, &?
ҕH0SmQ2WL=YE·K HowTU;0iD C"ք= lE2hM/u$wBX/@vjGTF U6Ɓsj)^؋TE3DWcy.i6Ud?DflJ~E'AƣD
{ULq ȸf UU] ]; ~gW^!ǎ4LC
3уcYaYEk'D !b lEqÉ/u/ bl tAD4ǑBh#TxfzPC 3-dotW5yRR<j@>XK&^1B#YkS\".d\:\乯a.ksT[7YB0JgI~*'/o/
x'=PLk%]Dg|`LJmqؑ8 0~ s5U30+I4(5:,߇+`K 눹Ef$Dp"5TVI!"ot7se&#yCQć$K UBn|UL3VRE `WZlDPѯWW *vَ] gŘ*%!R!>b)թd:@sB%GA02Q$TIBoKIO,FFMEJ'QaQ0
r{H۰ ;eX+xN8BS*|\IP_X+Fg~uYP4Iz+L ̙{%VԲk0\]H6yD4gNU#UՂȔ5QȜ@z9 u2WխF)dr
\B0_ۊO/'PBv8=A >Cʖjm- 5"kJ N$/4Ԟѯ`3U
9V{|d :Z]h)='u]W Ʌ ңE>i(
^ؼ(Z T@qZe-[f" RT rZ~ |ѡy )''@iToYH/3H*>Ŵ (ur/^zT d9S
5
v:.?Cw#8ATr!Q/9NO0T {!$2$ 9s^
6-J"߉ .R!^0JAxUAWH$v w7-#=LS
@냛bl eL M6ʈy,vM5$ 9_)
% ü /*H"qQH&|JX t"m04[k$"hF}DLJڅ( >& O@"
{C89wq!)0)CB0 ~tAI44V ~;:tSӵ#
o3Iti%;EЦ}gCʛsk7Iqz&+sTAlN+Y
- vj_vz6f jIΞj.[d#{
6iohk+=S; jPWmmZ舼B6>o܇vV qGE,=j⡔+r#Ϛy' ;KʎCQ0#}d
$ &PykZP(r@+^mrE@5㠦͜0z pBvA^A)%[:VSH LK+7+^Iw^ :nz@&;x_@i{*dcWT=A_ U7,AtQCD HH%9\:v Pe.LDA:i( }Ҫ6Њb7%־4ko3UZ1NχmmE+ L;ڹ/}Kx\rv49eH"Kؙ*L=o{r(qRoO{M ᘎ!RņjI 'v q$`SѤY=8r4jtA w7CR
G:a^fFKx.K.=lG.G#&~Fhy6MC Eo)TI 'PsGBQ(3'Ps?w y Au( I1k+1u,oD<uɽw|=n۬Wn\2Uu٪6]HK4^
'[ KGG:[ ͏Qa3.Sߕw# i g L"m4WHp J-~PO ;y1vƥ7q>o3ЬHGqaq^Ŕۅ9iJsMlBrb>f$I&aLf4Ӥi kPڿ%$'Tˎn$ڐϦ Ȧ|'/$kKpG$Ҿ`CP<'
NHXi iE!\6>uڢ1 $mg'DfnWEA1<*/cC,*;ָ{LÜӇ~{}ݴn5r'/}3x| 8 sd| X# [.520t'+ ,LЯ(%^ L7XT4ǎc)(Ns^y-ȅs-ҫN(`&:Lp&J0Aa gߎ[i1Ï6jirDƕ
%s)W.AER~U+ri)% gYOqL&K&:| XJa^pt0z(-@ Rs>jtډ- Ixn#0 `\#ө]
+eܐRyͧ1~&b"4_/p yNZ
*Tep&ڈ;
ւDVd `k!/@Ғ͢$}cmBX2 26Q<8O13?#2* %&` >sJ-Ppk ry_,NѱècU[=m!9jɇS`4:&?r,6>+5SV'%tҽaqj>=1MQf&jXz-mr\ZJ{J>{NI u}8
A.n" 1R~6ǪF+ƨX
^ *]j'SSs
<u/:Ö$k3kMF-AIsr"L&AY 9b n U |aV(\(ZR"LmO0arُai*̟Hea$6mm
Ql. ͤ,1頕 Jz-euE% R7Ԑۢ' 8c
>ص L0\ؼ0!ytOWG脿!(-ĬA +-P8p5YgcVL i
V*ucC$S'tIԆO̗vuƱ^q(%!
RO!Ck Ua5:PMub vQڃ0[<@`l F2xOs:ou ]D}W9z n4ON*gCv=φFbAF`ϭֱ!/V0oq,P7DN{
PV4C%:7Ŷ/ Fjfs
~HC _SrO@
>\O"/ZŬﯓV% CT'FPh 6O³ mͨSTu
hoJ,'S
L,Jm>3zjOSC/}U
LJ$ 8Pxm4V Ƌ[m( qk:~a 9^L0KuB݁5W[ tSRo?rE5R~Wp V_% { \Qh:Bmd_B1->B3$t 8/8$ PaFҮhϫu!
2BMx%#$ɓp#Qx 5tt܋1Z0~P^U E°k+3Dhq1G Zj%QQۗTyMP>1SB D9, 6 ;MBl}/ 9_B^ \ Q{"7e|/ Y /,헻W^ ;ڝ_ px?Oa==_ o>?Z_w{^|"{ej
7jA' n~u C]~-/|Yᚶ`W;s~~a!nqOK'PYXKk|]_αWrfCׄگ7"WHa|'iϟZ̮}lq,]ak!.<<|ݲHkP7+`n 鬠;?nΈNh|Y`@Vcʯ0O7 p-J87Ϳޛ+Hw7@;d}Bgv~DD W{:+1V q= kO87{>$J{us
4g35!ylvy
O
3qZne_ܽ7ɘn?WƄoX 0 y|jpvf~x7f[0;>BqBB}TR^倐c~!3~b5 H
g 7LII% cbJٳȴ*kEk l <:YSQ& $6X,% tւ!"bó@
,p~q(ogcCj | WhkKu6IG|_ IiM(ȏؒ5ҷFҩANJoPI3Oc/dwѸ l
L~R}R 9G'i^>xie2p8W%lfQoL2_P WT-P ݒjwH^6[#]ID EGy~ x">X} \ryO $t<}AWB{NS Dbф
{K ;r#SFކ&Z|3%YS66ֽ+rlx~DR)]2au\2x,Rb
lCei:Sj? /P03Ngo>?̯N[SN@".7:XH rpsAvW) |6 "ᓃ >!F5mZ{f#d[-_Vx*_?/cfsXN6"XֿOB̅] uG'\s\peIpȷ8qG2˓K4&1g fcJLJ@ 2|9c:ЁembRL*A$MHY[:Dz?2&l;hƈD.gkj,~ku2㗛8 \F$ f-MqG
uq>t%| E*@jS<,? nA0^^U6YnyMh~]>ʋM-q; PK
69
Presource.stUT dFUx PK
̌6-) )
Ԑ PresourceLib.stUT dFUx PK
65RJ RJ
Test-Presource.stUT dFUx PK
Ҍ6
package.xmlUT dFUx PK 36Nb/
COPYINGUT zFUx PK e :;