src/lib/macro.slate

   1
   2 n@(nodes Node traits) disable
   3 "Expands a textual program element into nothing, effectively commenting it out.
   4 Of course it does nothing to actual run-time configuration of the thing
   5 described."
   6 [n surroundings Literal Nil].
   7
   8 n@(nodes Literal traits) er
   9 "Takes a piece of Symbol/String literal syntax and expands into a block which
  10 can apply it to the number of arguments the Symbol can take as a selector."
  11 [| selector block |
  12   selector: n value.
  13   (selector is: Symbol) ifFalse: [error: '`er may only use a Symbol literal.'].
  14   block: n surroundings Block new.
  15   block statements: {n surroundings Message sending: selector to:
  16     ([n surroundings LoadVariable from: block addInputVariable] reader next: selector arity)}.
  17   block
  18 ].
  19
  20 n@(nodes Pattern traits) er &environment: env
  21 [| block message |
  22   block := n surroundings Block new.
  23   message := n message copy.
  24   message arguments infect:
  25     [| :arg |
  26      ({n surroundings Placeholder. n surroundings ImplicitArgument} includes: arg)
  27        ifTrue: [n surroundings LoadVariable from: block addInputVariable]
  28        ifFalse: [arg]].
  29   block statements := {message}.
  30   block
  31 ].
  32
  33 expr@(nodes Node traits) er &environment: method
  34 [(expr surroundings Literal for: (expr evaluateIn: method)) er].
  35
  36 n@(nodes Literal traits) erOnKey: attribute@(nodes Literal traits)
  37 "Variant on the `er macro which calls the selector on the results of sending
  38 the attribute selector to each argument."
  39 [| selector attribSelector block |
  40   selector := n value.
  41   attribSelector := attribute value.
  42   (selector is: Symbol) /\ [attribSelector is: Symbol]
  43     ifFalse: [error: '`erOnKey: may only use a Symbol literal.'].
  44   n surroundings Block new `>>
  45     [| :block |
  46      statements := {n surroundings Message sending: selector to:
  47                     ([n surroundings UnaryMessage sending: attribSelector to:
  48                         {n surroundings LoadVariable from: block addInputVariable}]
  49                        reader next: selector arity)}. ]
  50 ].
  51
  52 def@(nodes MethodDefinition traits) commutatively
  53 "Expands into a sequence of the original meethod and another having the
  54 same body with the roles reversed."
  55 [
  56   def roles = def roles reversed
  57     ifTrue: [def]
  58     ifFalse:
  59       [{def.
  60         def deepCopy `>>
  61           [| :newDef |
  62            roles := newDef roles reversed.
  63            inputVariables := newDef inputVariables reversed.
  64           ]} parenthesize]
  65 ].
  66
  67 def@(nodes MethodDefinition traits) alias: newName
  68 [
  69   {def. def deepCopy `>> [selector := newName evaluate. ]} parenthesize
  70 ].
  71
  72 expr@(nodes Node traits) suspend
  73 "Expands into a suspension-creating expression for a Block."
  74 [`((nodes Block newFor: expr) `unquote suspend)].
  75
  76 expr@(nodes Node traits) cache &environment: method
  77 "An environment-altering macro that performs no transformation on the argument:
  78 It creates a new local binding with the result of evaluating the expression
  79 when the surrounding method is run. All other uses of an equivalent (=)
  80 expression in the same or deeper lexical context are replaced with an access
  81 of that local."
  82 [| newVar loadExpr macroCall |
  83   "Do nothing outside of a method."
  84   method ifNil: [warn: 'Cannot cache outside of a method'. ^ expr].
  85   "Make the new local, uniquely named."
  86   newVar := method addVariable.
  87   "Replace any equal expression (except this one) with a load of the variable."
  88   loadExpr := newVar load.
  89   macroCall := expr `cache `quote.
  90   method transformBy:
  91     [| :node | node = expr \/ [node = macroCall]
  92        ifTrue: [loadExpr] ifFalse: [node]].
  93   "Expand into a store expression."
  94   newVar store: expr
  95 ].
  96
  97 expr@(nodes Node traits) cacheAs: varName &environment: method
  98 "An environment-altering macro that performs no transformation on the argument:
  99 It creates a new local binding with the result of evaluating the expression
 100 when the surrounding method is run. All other uses of an equivalent (=)
 101 expression in the same or deeper lexical context are replaced with an access
 102 of that local."
 103 [| newVar expressionsToReplace loadExpr |
 104   "Do nothing outside of a method."
 105   method ifNil: [warn: 'Cannot cache outside of a method'. ^ expr].
 106   "Make the new local, uniquely named."
 107   newVar := method addVariableNamed: varName value intern.
 108   "Replace any equal expression (except this one) with a load of the variable."
 109   loadExpr := newVar load.
 110   expressionsToReplace := {
 111     expr.
 112     expr `cache `quote.
 113     nodes UnaryMessage sending: varName value intern to: {nodes ImplicitArgument}
 114   }.
 115   method transformBy:
 116     [| :node | (expressionsToReplace includes: node)
 117        ifTrue: [loadExpr] ifFalse: [node]].
 118   "Expand into a store expression."
 119   newVar store: expr
 120 ].
 121
 122 expr@(nodes Node traits) rememberAs: varName &environment: method
 123 "An environment-altering macro that performs no transformation on the argument:
 124 It creates a new local binding with the result of evaluating the expression
 125 when the surrounding method is run. All other uses of an equivalent (=)
 126 expression in the same or deeper lexical context are replaced with an access
 127 of that local."
 128 [| newVar expressionsToReplace loadExpr |
 129   "Do nothing outside of a method."
 130   method ifNil: [warn: 'Cannot cache outside of a method'. ^ expr].
 131   "Make the new local, uniquely named."
 132   newVar := method addVariableNamed: varName value intern.
 133   "Replace any equal expression (except this one) with a load of the variable."
 134   loadExpr := newVar load.
 135   expressionsToReplace := {
 136     nodes UnaryMessage sending: varName value intern to: {nodes ImplicitArgument}
 137   }.
 138   method transformBy:
 139     [| :node | (expressionsToReplace includes: node)
 140        ifTrue: [loadExpr] ifFalse: [node]].
 141   "Expand into a store expression."
 142   newVar store: expr
 143 ].
 144
 145 x@(Root traits) compareAndHashUsingSlots: relevantSlotNames
 146 "Defines methods for #= and #hash for the simple case of just recursively
 147 calling them on each value of the slots with the given names.
 148 NOTE: This is not a macro but relies on the macro facilities."
 149 [| xLiteral |
 150   relevantSlotNames
 151    isEmpty ifTrue: [error: 'Some slot names must be specified.'].
 152
 153   xLiteral := nodes Literal for: x.
 154   nodes Block new
 155     `>> [statements :=
 156            {nodes MethodDefinition of: #= on: {xLiteral. xLiteral}
 157               from: #{#obj1. #obj2} to:
 158                 [| :obj1 :obj2 |
 159                  "relevantSlotNames collect:
 160          [| :slotName |
 161           (obj1 `load atSlotNamed: slotName `unquote)
 162                 = (obj2 `load atSlotNamed: slotName `unquote)]"
 163                  relevantSlotNames allButFirst
 164                    inject:
 165                      `((obj1 `load atSlotNamed: relevantSlotNames first `unquote)
 166                          = (obj2 `load atSlotNamed: relevantSlotNames first `unquote))
 167                    into: [| :expr :slotName |
 168                           `(expr `unquote /\
 169                               [(obj1 `load atSlotNamed: slotName `unquote)
 170                                  = (obj2 `load atSlotNamed: slotName `unquote)])]]
 171               &linkVariables: True.
 172             nodes MethodDefinition of: #hash on: {xLiteral}
 173               from: #{#obj} to:
 174                 [| :obj |
 175                  relevantSlotNames allButFirst
 176                    inject:
 177                      `((obj `load atSlotNamed: relevantSlotNames first `unquote) hash)
 178                    into: [| :hash :slotName |
 179                           `(hash `unquote bitXor:
 180                               (obj `load atSlotNamed: slotName `unquote) hash)]]
 181               &linkVariables: True}.
 182          compileAndRun].
 183 ].
 184
 185 x@(Root traits) extendCompareAndHashUsingSlots: relevantSlotNames
 186 "Defines methods for #= and #hash for the simple case of just recursively
 187 calling them on each value of the slots with the given names; uses a resend
 188 to re-use the more abstract definition.
 189 NOTE: This is not a macro but relies on the macro facilities."
 190 "FIXME: The resend results in a compilation error."
 191 [| xLiteral |
 192   relevantSlotNames
 193    isEmpty ifTrue: [error: 'Some slot names must be specified.'].
 194
 195   xLiteral := nodes Literal for: x.
 196   nodes Block new
 197     `>> [statements:
 198       {nodes MethodDefinition of: #= on: {xLiteral. xLiteral}
 199         from: #{#obj1. #obj2} to:
 200           [| :obj1 :obj2 |
 201             relevantSlotNames inject: nodes Resend into:
 202               [| :expr :slotName |
 203                 `(expr `unquote /\
 204                    [(obj1 `load atSlotNamed: slotName `unquote)
 205                      = (obj2 `load atSlotNamed: slotName `unquote)])]]
 206           &linkVariables: True.
 207        nodes MethodDefinition of: #hash on: {xLiteral}
 208          from: #{#obj} to:
 209            [| :obj |
 210              relevantSlotNames inject: nodes Resend into:
 211                [| :hash :slotName |
 212                  `(hash `unquote bitXor:
 213                     (obj `load atSlotNamed: slotName `unquote) hash)]]
 214            &linkVariables: True}.
 215       compileAndRun].
 216 ].
 217
 218 "Bootstrap-time fix-ups:" (
 219 ExternalResource traits compareAndHashUsingSlots: #{#locator}.
 220 File Locator traits compareAndHashUsingSlots: #{#name. #path. #version. #fileType}.
 221 File RelativeLocator traits compareAndHashUsingSlots: #{#basePath. #path. #name. #fileType. #version}.
 222 Directory traits compareAndHashUsingSlots: #{#locator}.
 223 nodes Annotation traits compareAndHashUsingSlots: #{#value}.
 224 nodes Comment traits compareAndHashUsingSlots: #{#comment. #value}.
 225 nodes OptionalKeywords traits compareAndHashUsingSlots: #{#message. #keywords. #arguments}.
 226 nodes Literal traits compareAndHashUsingSlots: #{#value}.
 227 nodes Namespace traits compareAndHashUsingSlots: #{#namespace}.
 228 nodes Variable traits compareAndHashUsingSlots: #{#name. #scope}.
 229 nodes LoadVariable traits compareAndHashUsingSlots: #{#variable}.
 230 nodes StoreVariable traits compareAndHashUsingSlots: #{#variable. #value}.
 231 CompiledMethod traits compareAndHashUsingSlots: #{#literals. #selectors. #code}.
 232 Types Not traits compareAndHashUsingSlots: #{#argument}.
 233 Types Member traits compareAndHashUsingSlots: #{#elements}.
 234 Types Block traits compareAndHashUsingSlots: #{#resultType. #argumentTypes}.
 235 Types Range traits compareAndHashUsingSlots: #{#type. #start. #end}.
 236 Types Array traits compareAndHashUsingSlots: #{#type}.
 237 ).
 238
 239 x@(nodes Node traits) swapWith: y@(nodes Node traits) &environment: env
 240 [
 241   TODO: 'Determine how to perform a generic variable swap outside of a Method context without a global.'
 242 ].
 243
 244 x@(nodes LoadVariable traits) swapWith: y@(nodes LoadVariable traits) &environment: env
 245 "A macro that expands into simple code swapping the values of two variables
 246 in the current scope."
 247 [| tmpVar |
 248   env ifNil: [error: 'Cannot swap variables outside of a method'].
 249   tmpVar := env addVariable.
 250   {tmpVar store: x variable load.
 251    x variable store: y variable load.
 252    y variable store: tmpVar load} parenthesize
 253 ].
 254
 255 _@(nodes Node traits) matchAppend: keyword with: val
 256 "Encapsulates the idiom of taking a message and adding a keyword to denote an
 257 additional yet non-optional parameter.
 258 E.g. foo -> fooWith: -> fooWith:with:, fooWith:with:with: ..."
 259 "TODO: Provide a way to call methods with syntactic *rest: parameters instead?"
 260 [overrideThis].
 261
 262 message@(nodes UnaryMessage traits) matchAppend: keyword with: val
 263 [
 264   nodes KeywordMessage sending: (intern: message selector name ; keyword name capitalized)
 265     to: {message arguments first. val}
 266 ].
 267
 268 message@(nodes KeywordMessage traits) matchAppend: keyword with: val
 269 [
 270   nodes KeywordMessage sending: (intern: message selector name ; keyword name)
 271     to: message arguments ; {val}
 272 ].
 273
 274 paren@(nodes Parenthesis traits) matchAppend: keyword with: val
 275 [paren statements first matchAppend: keyword with: val].
 276
 277 collection@(nodes Node traits) match: elements@(nodes Node traits) with: message@(nodes Node traits)
 278   &otherwise: failBlock &append: keyword &environment: env
 279 [| tmpVar cases |
 280   env ifNil: [error: 'Cannot match a collection outside of a method'].
 281   keyword := keyword
 282     ifNil: [#with:]
 283     ifNotNil: [keyword evaluate].
 284   elements := elements evaluate sort.
 285   tmpVar := env addVariable.
 286   cases :=
 287     ((elements first upTo: elements last) collect:
 288       [| :size |
 289         `((size + 1) `literal ->
 290            (elements inject: message into: [| :message :element |
 291               element <= size
 292                 ifTrue:
 293                   [message matchAppend: keyword with: `(tmpVar `load at: element `literal)]
 294                 ifFalse:
 295                   [message]]) `block)]).
 296   failBlock
 297     ifNil:
 298       [`((tmpVar `store: collection) size caseOf: cases `array)]
 299     ifNotNil:
 300       [`((tmpVar `store: collection) size caseOf: cases `array otherwise: failBlock `unquote)]
 301 ].