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