Attached is an example of using Presource for writing compiler-macros instead of language extensions (like #condSelect). I don't think the last post of Presource itself will run it, but I'll roll another later.
st> (StringBindWithMacro new expandMessageWithLocalReturn:
(Presrc.CodeTemplate parseExpr:
'''%1 = %2. (%1 %<>|<=>3 0)''
% {expression printString. 2 + 2. 2 + 2 strictlyPositive}'))
printNl!
RBMessageNode(
[| gensym166 formatTmp167 formatTmp168 formatTmp169 |
gensym166 := WriteStream on: (String new: 45).
formatTmp167 := expression.
formatTmp168 := 2 + 2.
formatTmp169 := 2 + 2 strictlyPositive.
formatTmp167 printOn: gensym166.
' = ' displayOn: gensym166.
formatTmp168 displayOn: gensym166.
'. (' displayOn: gensym166.
formatTmp167 printOn: gensym166.
' ' displayOn: gensym166.
(formatTmp169 ifTrue: ['>'] ifFalse: ['<=']) displayOn: gensym166.
' 0)' displayOn: gensym166.
gensym166 contents] value)
Writing this also showed me that I should introduce a #condEvery and a
#condSome macro, variations on the #condSelect theme, which I will
probably want to finish (and do unit tests for all of this) before
posting Presource again.
--
;;; Stephen Compall ** http://scompall.nocandysw.com/blog **
"Peta" is Greek for fifth; a petabyte is 10 to the fifth power, as
well as fifth in line after kilo, mega, giga, and tera.
-- Lee Gomes, performing every Wednesday in his tech column
"Portals" on page B1 of The Wall Street Journal
Namespace current: NoCandy.Presrc!
Object subclass: #BindWithFunction
instanceVariableNames: 'template bindParts streamVar vars
initializers statements constantOut inlineStreamStringSends'
classVariableNames: ''
poolDictionaries: ''
category: 'Presource-message macros'
!
BindWithFunction comment:
'I parse a single template and build a sequence node that invokes
bindWith for it.'
!
MessageMacro subclass: #StringBindWithMacro
instanceVariableNames: 'bindWithClass inlineStreamStringSends'
classVariableNames: 'NoStreamStringOverrides'
poolDictionaries: ''
category: 'Presource-message macros'
!
StringBindWithMacro comment:
'I open-code sends to literal strings of #bindWithArguments: according
to CharacterArray''s #bindWithArguments: protocol.
bindWithClass
I only open-code for literal "strings" of this class.
inlineStreamStringSends
Whether to eliminate sends to #storeString, #displayString,
and #printString in the indexable binding parts; e.g. this can
change the behavior of ''%1'' % {x storeString} if x has an
override for #storeString such that it delivers a different
result than ((WriteStream on: String new) store: x; contents).
NoStreamStringOverrides
The public default value of inlineStreamStringSends. True by
default because overriding any methods such that
inlineStreamStringSends must be false is a terrible idea.'
!
!BindWithFunction class methodsFor: 'instance creation'!
formatTemplate: template withArguments: bindParts on: ostream
inlineStreamStringSends: inlineFlag
^super new template: template readStream
bindParts: bindParts streamVar: ostream
inlineStreamStringSends: inlineFlag;
reinitialize; yourself
! !
!BindWithFunction methodsFor: 'private'!
template: aStream bindParts: aList streamVar: aVariable
inlineStreamStringSends: aBoolean
template := aStream.
bindParts := aList.
streamVar := aVariable.
inlineStreamStringSends := aBoolean.
!
reinitialize
vars := Array new: bindParts size.
initializers := Array new: bindParts size.
statements := OrderedCollection new: 2 * bindParts size.
constantOut := WriteStream on: (template species new: template size).
! !
!BindWithFunction methodsFor: 'building node parts'!
isStreamStringSend: aNode
"Answer whether aNode is a stream-string send that can be
eliminated in a stream-building process."
^{[inlineStreamStringSends].
[aNode isMessage].
[#(#displayString #printString #storeString)
includes: aNode selector]}
allSatisfy: #value sendingBlock
!
streamStringOutputSelector: aSelector
"Answer a 1-arg selector for the unary aSelector, e.g.
#printString -> #printOn:"
^##(LookupTable from: {#printString -> #printOn:.
#displayString -> #displayOn:.
#storeString -> #storeOn:})
at: aSelector
!
bindForm: n
"Answer the nth bound variable, initializing it if needed."
^(vars at: n) ifNil:
[| var bindPart |
var := Presrc.MessageMacro newVariable: 'formatTmp'.
bindPart := bindParts at: n.
"remove sends at init time, must also remove at display time"
(self isStreamStringSend: bindPart)
ifTrue: [bindPart := bindPart receiver].
initializers at: n put:
(STInST.RBAssignmentNode variable: var
value: bindPart).
vars at: n put: var]
!
mustBeBoolean: n
"Signal an error if bindPart n can't be boolean."
(self isStreamStringSend: (bindParts at: n))
ifTrue: [self error: 'expected boolean at %%%1' % {n}].
!
displayConstant
constantOut position = 0 ifFalse:
[statements add:
(STInST.RBMessageNode
receiver: (STInST.RBLiteralNode value: constantOut contents)
selector: #displayOn:
arguments: {streamVar})].
constantOut reset.
!
parseConditional
| trueString falseString n bindPart |
trueString := template upTo: $|.
falseString := template upTo: $>.
bindPart := bindParts at: (n := template next digitValue).
self mustBeBoolean: n.
bindPart isLiteral
ifTrue: [(bindPart value ifTrue: [trueString] ifFalse: [falseString])
displayOn: constantOut]
ifFalse: [| pMap |
self displayConstant.
pMap := LookupTable from:
{'[EMAIL PROTECTED]' -> (self bindForm: n).
'[EMAIL PROTECTED]' -> (STInST.RBLiteralNode value:
trueString).
'[EMAIL PROTECTED]' -> (STInST.RBLiteralNode value:
falseString).
'`stream' -> streamVar}.
statements add:
((Presrc.CodeTemplate fromExpr:
'([EMAIL PROTECTED] ifTrue: [EMAIL PROTECTED]
ifFalse: [EMAIL PROTECTED]) displayOn:
`stream')
expand: pMap)].
!
parseDisplay: n
| dispSelector bindPart |
bindPart := bindParts at: n.
dispSelector := #displayOn:.
(self isStreamStringSend: bindPart)
ifTrue: [dispSelector := self streamStringOutputSelector:
bindPart selector.
bindPart := bindPart receiver].
bindPart isLiteral
ifTrue: [bindPart value perform: dispSelector with: constantOut]
ifFalse: [| message |
self displayConstant.
message := STInST.RBMessageNode
receiver: (self bindForm: n)
selector: dispSelector
arguments: {streamVar}.
statements add: message].
!
sequenceNode
| start percent |
"compile the template"
[constantOut nextPutAll: (template upTo: $%).
template atEnd] whileFalse:
[| control |
control := template next.
{control = ($<) ->[self parseConditional].
control = $% -> [constantOut nextPut: control].
control isAlphaNumeric -> [self parseDisplay: control digitValue].
true -> [self error: 'invalid format control %%%1' % {control}]}
condSelect].
self displayConstant.
"to preserve evaluation semantics, add back any missing
non-literal bindParts during initialization"
"TODO this doesn't work right with #printString sends et al"
initializers keysAndValuesDo: [:n :assign |
(assign isNil and: [(bindParts at: n) isLiteral not])
ifTrue: [initializers at: n put: (bindParts at: n)]].
^(Presrc.CodeTemplate fromExpr:
'| [EMAIL PROTECTED] | [EMAIL PROTECTED] [EMAIL PROTECTED]')
expand: (LookupTable from:
{'[EMAIL PROTECTED]' -> (vars copyWithout: nil).
'[EMAIL PROTECTED]' -> (initializers copyWithout: nil).
'[EMAIL PROTECTED]' -> statements})
! !
!StringBindWithMacro class methodsFor: 'instance creation'!
new
"Answer a new instance initialized in the default manner."
^self onStringClass: Smalltalk.CharacterArray
!
onStringClass: aBehavior
"Answer a new message macro that assumes receivers of kind
aBehavior can have their %-calls open-coded."
^super new bindWithClass: aBehavior
inlineStreamStringSends: NoStreamStringOverrides;
yourself
! !
!StringBindWithMacro class methodsFor: 'private'!
initialize
super initialize.
(self isMemberOf: thisContext method methodClass) ifTrue:
[NoStreamStringOverrides := true].
! !
!StringBindWithMacro methodsFor: 'private'!
bindWithClass: aBehavior inlineStreamStringSends: aBoolean
bindWithClass := aBehavior.
inlineStreamStringSends := aBoolean.
!
formatTemplate: template withArguments: bindParts on: ostream
"Answer a sequence node that applies #bindWithArguments: to
template (a string) and bindParts forms, putting the resulting
characters on ostream, which should be a variable of some kind."
^(BindWithFunction formatTemplate: template
withArguments: bindParts on: ostream
inlineStreamStringSends: inlineStreamStringSends)
sequenceNode
!
formatTemplate: template withArguments: bindParts
| compilation bindings streamVar |
"One possibility might be to detect a #nextPutAll: or #display:
send to a variable in my message's parent, making that the stream
instead. That would unfortunately change error behavior, but
it's an interesting possibility nonetheless."
streamVar := Presrc.MessageMacro newVariable.
compilation := self formatTemplate: template
withArguments: bindParts on: streamVar.
bindings := LookupTable from:
{'`stream' -> streamVar.
'[EMAIL PROTECTED]' -> compilation temporaries.
'[EMAIL PROTECTED]' -> (STInST.RBLiteralNode value: WriteStream).
'[EMAIL PROTECTED]' -> (STInST.RBLiteralNode value: template species).
'`size' -> (STInST.RBLiteralNode value: template size + 20).
'[EMAIL PROTECTED]' -> compilation statements}.
^(Presrc.CodeTemplate fromExpr:
'[| `stream [EMAIL PROTECTED] |
`stream := [EMAIL PROTECTED] on: ([EMAIL PROTECTED] new: `size).
[EMAIL PROTECTED]
`stream contents] value') expand: bindings
! !
!StringBindWithMacro methodsFor: 'expanding parse trees'!
expandMessage: percent to: stringNode withArguments: argList
| template |
({[stringNode isLiteral].
[(template := stringNode value) isKindOf: bindWithClass].
[argList size = 1].
[argList first isLiteral
or: [argList first isKindOf: STInST.RBArrayConstructorNode]]}
allSatisfy: #value sendingBlock)
ifFalse: [self forgoExpansion].
"if trivially constant, partial-evaluate"
^argList first isLiteral
"TODO pretty sure I have to wrap this in a literal node"
ifTrue: [template % argList first value]
ifFalse: [self formatTemplate: template
withArguments: argList first body statements]
! !
StringBindWithMacro initialize!
signature.asc
Description: This is a digitally signed message part
_______________________________________________ help-smalltalk mailing list [email protected] http://lists.gnu.org/mailman/listinfo/help-smalltalk
