src/core/method.slate

   1
   2 m@(Method traits) do
   3 "Just runs the method without any inputs and answers the result."
   4 [m applyTo: {}].
   5
   6 m@(Method traits) applyWith: x
   7 "Applies the method to the one input."
   8 [m applyTo: {x}].
   9
  10 m@(Method traits) applyWith: x with: y
  11 "Applies the method to 2 inputs."
  12 [m applyTo: {x. y}].
  13
  14 m@(Method traits) applyWith: x with: y with: z
  15 "Applies the method to 3 inputs."
  16 [m applyTo: {x. y. z}].
  17
  18 s@(Symbol traits) sendWith: x
  19 [s sendTo: {x}].
  20
  21 s@(Symbol traits) sendWith: x with: y
  22 [s sendTo: {x. y}].
  23
  24 s@(Symbol traits) sendWith: x with: y with: z
  25 [s sendTo: {x. y. z}].
  26
  27 m@(PrimitiveMethod traits) applyTo: args
  28 [
  29   error: 'The Slate VM currently does not support #applyTo: calls on PrimitiveMethods.'
  30 ].
  31
  32 m@(Method traits) replaceWith: newM on: args
  33 "Uninstall the given method from the arguments, which need to be those holding
  34 the actual role entries pointing to that method for dispatch, and then define
  35 the new Method on those same arguments."
  36 [
  37   m removeFrom: args.
  38   newM asMethod: m selector on: args
  39 ].
  40
  41 _@(Method traits) findNamed: selector on: args
  42 "Answer the method found through dispatch with the given name on the arguments."
  43 [selector findOn: args].
  44
  45 name@(Symbol traits) isFoundOn: args
  46 "Answer whether a method with the given name is applicable to the arguments."
  47 [
  48   (name findOn: args) isNotNil
  49 ].
  50
  51 name@(Symbol traits) removeMethodFrom: args &ifNotFound: block
  52 "Removes the method with the given selector from the arguments."
  53 [
  54   block `defaultsTo: [name notFoundOn: args].
  55   (name findOn: args) ifNil: block ifNotNilDo: [|:method| method removeFrom: args ]
  56 ].
  57
  58 name@(Symbol traits) findsSameMethodOn: args1 asOn: args2
  59 "Answers whether lookup returns the exact same method for two different
  60 signatures.
  61 This also handles failed lookup, where Nil is returned from findOn:."
  62 [
  63   (name findOn: args1)
  64     ifNil: [False]
  65     ifNotNilDo: [| :m1 | (name findOn: args2)
  66                          ifNil: [False] ifNotNilDo: [| :m2 | m1 = m2]]
  67 ].
  68
  69 name@(Symbol traits) alias: selector on: args
  70 "Creates a method that just sends the given selector on the specified
  71 arguments."
  72 [
  73   name arity = selector arity
  74     ifTrue: [(Syntax Literal for: selector) er evaluate asMethod: name on: args]
  75     ifFalse: [error: 'The selector names do not match.']
  76 ].
  77
  78 x@(Root traits) perform: selector
  79 "Included for Smalltalk-80 compatibility and brevity."
  80 [selector sendTo: {x}].
  81
  82 condition@(Method traits) whileTrue: body
  83 "Repeatedly execute the body block after checking each time that the condition
  84 block returns True."
  85 [
  86   [condition do ifFalse: [^ Nil].
  87    body do] loop
  88 ].
  89
  90 condition@(Method traits) whileTrue
  91 "Repeatedly execute the block until it returns False. Naturally the point is
  92 usually that the body before the last statement has some kind of side-effect
  93 or other computation that updates, or relies on external state to affect the
  94 condition."
  95 [
  96   condition whileTrue: []
  97 ].
  98
  99 condition@(Method traits) whileFalse: body
 100 "Repeatedly execute the body block after checking each time that the condition
 101 block returns False."
 102 [
 103   [condition do ifTrue: [^ Nil].
 104    body do] loop
 105 ].
 106
 107 condition@(Method traits) whileFalse
 108 "Repeatedly execute the block until it returns True. Naturally the point is
 109 usually that the body before the last statement has some kind of side-effect
 110 or other computation that updates, or relies on external state to affect the
 111 condition."
 112 [
 113   condition whileFalse: []
 114 ].
 115
 116 body@(Method traits) loop
 117 "Execute the block repeatedly, until control is thrown outside by the block
 118 itself. This relies on the byte-compiler's transformation of loop calls with
 119 methods to a lower-level control-flow implementation."
 120 [[body do. ] loop].
 121
 122 _@(Root traits) if: boolean then: trueBlock
 123 [boolean ifTrue: trueBlock].
 124
 125 _@(Root traits) if: boolean then: trueBlock else: falseBlock
 126 [boolean ifTrue: trueBlock ifFalse: falseBlock].
 127
 128 body@(Method traits) while: testBlock
 129 "Evaluates the body block once, and then again as long as the testBlock
 130 returns True, and returns the last return value of the body."
 131 [| result |
 132   [result: body do.
 133    testBlock do] whileTrue.
 134   result
 135 ].
 136
 137 body@(Method traits) until: testBlock
 138 "Evaluates the body block once, and then again as long as the testBlock
 139 returns False, and returns the last return value of the body."
 140 [| result |
 141   [result: body do.
 142    testBlock do] whileFalse.
 143   result
 144 ].
 145
 146 m@(Method traits) unless: boolean
 147 "Evaluates the block body if the given condition is False."
 148 [boolean ifFalse: [m do]].
 149
 150 m@(Method traits) if: boolean
 151 "Evaluates the block body if the given condition is True."
 152 [boolean ifTrue: [m do]].
 153
 154 count@(Integer traits) timesRepeat: block
 155 "Execute the block the number of times of the count, answering Nil."
 156 [
 157   [count > 0]
 158     whileTrue:
 159       [block do.
 160        count: count - 1]
 161 ].
 162
 163 start@(Integer traits) to: end do: block
 164 "Auto-detects the direction of the progression."
 165 [
 166   start < end
 167     ifTrue: [start upTo: end do: block]
 168     ifFalse: [start downTo: end do: block]
 169 ].
 170
 171 start@(Integer traits) upTo: end do: block
 172 "Executes the block with each Integer from the start ascending by 1 to the end."
 173 [
 174   [start <= end]
 175     whileTrue:
 176       [block applyWith: start.
 177        start: start + 1]
 178 ].
 179
 180 start@(Integer traits) below: end do: block
 181 "Executes the block with each Integer from the start descending by 1 to
 182 just before the end."
 183 [
 184   [start < end]
 185     whileTrue:
 186       [block applyWith: start.
 187        start: start + 1]
 188 ].
 189
 190 start@(Integer traits) downTo: end do: block
 191 "Executes the block with each Integer from the start descending by 1 to the
 192 end."
 193 [
 194   [start >= end]
 195     whileTrue:
 196       [block applyWith: start.
 197        start: start - 1]
 198 ].
 199
 200 start@(Integer traits) above: end do: block
 201 "Executes the block with each Integer from the start ascending by 1 to
 202 just before the end."
 203 [
 204   [start > end]
 205     whileTrue:
 206       [block applyWith: start.
 207        start: start - 1]
 208 ].
 209
 210 start@(Number traits) downTo: end by: inc do: block
 211 "Executes the block with each Integer from the start descending by the
 212 increment to the end."
 213 [
 214   [start >= end]
 215     whileTrue:
 216       [block applyWith: start.
 217        start: start - inc]
 218 ].
 219
 220 start@(Number traits) above: end by: inc do: block
 221 "Executes the block with each Integer from the start descending by the
 222 increment to just before the end."
 223 [
 224   start downTo: end + 1 by: inc do: block
 225 ].
 226
 227 start@(Number traits) upTo: end by: inc do: block
 228 "Executes the block with each Integer from the start ascending by the increment
 229 to the end."
 230 [
 231   [start <= end]
 232     whileTrue:
 233       [block applyWith: start.
 234        start: start + inc]
 235 ].
 236
 237 start@(Number traits) below: end by: inc do: block
 238 "Executes the block with each Integer from the start descending by the increment
 239 to just before the end."
 240 [
 241   start upTo: end - 1 by: inc do: block
 242 ].
 243
 244 m@(Method traits) new
 245 [ m clone ].
 246
 247 _@(Method traits) newAlwaysReturning: obj
 248 "Answers a new block which takes an argument and ignores it, returning the
 249 one (constant) object it was created for."
 250 [
 251   [| *_ | obj]
 252 ].
 253
 254 "Additional overrides for /\ and \/ for lazy-evaluated conditionals:"
 255
 256 _@True /\ block@(Method traits) [block do].
 257 _@False /\ _@(Method traits) [False].
 258 _@True \/ _@(Method traits) [True].
 259 _@False \/ block@(Method traits) [block do].
 260
 261 m@(Method traits) ifCompletes: successBlock ifFails: errorBlock
 262 "Executes the first method, and then executes either the successBlock or the
 263 errorBlock depending on whether there is a non-local exit that prevents the
 264 first from completing normally."
 265 [| exitedNormally result |
 266   exitedNormally: False.
 267   [result: m do. exitedNormally: True. result]
 268     ensure: [exitedNormally ifTrue: [successBlock do] ifFalse: [errorBlock do]]
 269 ].
 270
 271 m@(Method traits) unlessCompletes: errorBlock
 272 "Executes the first Method, and executes the second method only if there
 273 is a non-local exit so that the first does not complete normally."
 274 [m ifCompletes: [] ifFails: errorBlock].
 275
 276 m@(Method traits) ifCompletes: successBlock
 277 "Executes the first Method, and executes the second method only if there
 278 is no non-local exit so that the first completes normally."
 279 [m ifCompletes: successBlock ifFails: []].
 280
 281 _@(Root traits) withBreakerDo: m@(Method traits)
 282 "Allows implementation of single-level block return (as opposed to full
 283 lexical return which is default) by passing as the argument a block which
 284 will return from this wrapper when invoked."
 285 [m applyWith: [^ Nil]].
 286
 287 m@(Method traits) ** n@(Method traits)
 288 "Answers a new Method whose effect is that of calling the first method
 289 on the results of the second method applied to whatever arguments are passed.
 290 This composition is associative, i.e. (a ** b) ** c = a ** (b ** c).
 291 When the second method, n, does not take a *rest option or the first takes
 292 more than one input, then the output is chunked into groups for its
 293 consumption. E.g.:
 294 #; `er ** #; `er applyTo: {'a'. 'b'. 'c'. 'd'} => 'abcd'
 295 #; `er ** #name `er applyTo: {#a. #/}. => 'a/'"
 296 [
 297   n acceptsAdditionalArguments \/ [m arity = 1]
 298     ifTrue:
 299       [[| *args | m applyTo: {n applyTo: args}]]
 300     ifFalse:
 301       [[| *args |
 302         m applyTo:
 303           ([| :stream |
 304              args do: [| *each | stream nextPut: (n applyTo: each)]
 305                   inGroupsOf: n arity] writingAs: {})]]
 306 ].
 307
 308 #**`er asMethod: #compose: on: {Method traits. Method traits}.
 309 "A named alias for **."
 310
 311 i@(Root traits) converge: block
 312 "Apply block to i until it returns the previously returned value or
 313 the original value. In other words, until no change happens anymore or
 314 we're back at the beginning.
 315 NOTE: The originality test is used to avoid endless loop. It's
 316 possible to construct blocks that don't always return the same
 317 value for same input, so should there be another converge without this
 318 test?"
 319 [| current last |
 320   current: (block applyWith: i).
 321   [{i. last} includes: current]
 322     whileFalse: [last: current.
 323                  current: (block applyWith: current)].
 324   current
 325 ].
 326
 327 "Adverb operators:" (
 328
 329 m@(Method traits) reducer
 330 "Over in K"
 331 [[| :arg | arg reduce: m]].
 332
 333 m@(Method traits) collecter
 334 "Each in K"
 335 [[| :arg | arg collect: m]].
 336
 337 m@(Method traits) acrosser
 338 "Rename me"
 339 [[| arg | m across: arg]].
 340
 341 m@(Method traits) tracer
 342 "Scan or trace in K."
 343 [[| :arg | arg trace: m]].
 344
 345 m@(Method traits) selecter
 346 [[| :arg | arg select: m]].
 347
 348 m@(Method traits) injecter
 349 "Over dyad in K"
 350 [[| :arg1 :arg2 | arg2 inject: arg1 into: m]].
 351
 352 m@(Method traits) converger
 353 [[| :arg | arg converge: m]].
 354
 355 m@(Method traits) applier
 356 [[| :arg | m applyTo: arg]].
 357
 358 ).
 359
 360 m@(Method traits) fill: arg with: val
 361 "Answer a new method based on the given one, with the argument at a given index
 362 filled in with a value, essentially currying the method."
 363 [
 364   (arg between: 0 and:
 365     (m acceptsAdditionalArguments ifTrue: [PositiveInfinity] ifFalse: [m arity - 1]))
 366     ifFalse: [error: 'Attempted to fill nonexistent method argument.'].
 367   [| *args | m applyTo: (args copyWith: val at: arg)]
 368 ].
 369
 370 m@(Method traits) <- val
 371 [m fill: 0 with: val].
 372
 373 m@(Method traits) <-1 val
 374 [m fill: 0 with: val].
 375
 376 m@(Method traits) <-2 val
 377 [m fill: 1 with: val].
 378
 379 m@(Method traits) <-3 val
 380 [m fill: 2 with: val].
 381
 382 m@(Method traits) <-4 val
 383 [m fill: 3 with: val].
 384
 385 m@(Method traits) <-5 val
 386 [m fill: 4 with: val].
 387
 388 m@(Method traits) <-* val
 389 [
 390   [| *args | m applyTo: (args copyWith: val)]
 391 ].
 392
 393 Method traits define: #Identity &builder: [[| :x | x]].
 394 "The method Identity does nothing but return its sole argument."
 395
 396 Method traits define: #Y &builder:
 397   [[| :f | [| :x | f applyWith: (x applyWith: x)]
 398            applyWith: [| :x | f applyWith: (x applyWith: x)]]].
 399 "The Y recursion combinator - also known as the fixed-point combinator, since
 400 it computes the fixed point of any single-argument Method it is applied with.
 401 The core property is that (f applyWith: (Y applyWith: f)) = (Y applyWith: f)
 402 for any method f. The practical use is allowing the definition of anonymous
 403 recursive Methods from Methods which define the individual step (and take an
 404 extra argument which is the Method to recurse on when appropriate)."
 405
 406 Method traits define: #SequentialComposition &parents: {Method} &slots: {#methods -> {}}.
 407
 408 "A Method's SequentialComposition takes several methods with compatible
 409 signatures and applies them in order to the same arguments."
 410
 411 mc@(Method SequentialComposition traits) newForAll: c
 412 [mc cloneSettingSlots: #(methods) to: {c as: mc methods}].
 413
 414 mc@(Method SequentialComposition traits) applyTo: args
 415 [mc contents do: #applyTo: `er <-* args].
 416
 417 Method traits define: #Converse &parents: {Method} &slots: {#method -> []}.
 418 "A Method's converse takes the arguments in reverse to produce the same
 419 result. This implementation works on any method arity, but the client needs
 420 to be aware of this arity, naturally."
 421
 422 m@(Method traits) converse
 423 "Answers a new converse of the given method."
 424 [m Converse cloneSettingSlots: #(method) to: {m}].
 425
 426 mc@(Method Converse traits) arity
 427 "The arity is inherited from the inner method."
 428 [mc method arity].
 429
 430 mc@(Method Converse traits) allSelectorsSent
 431 "The selectors sent is inherited from the inner method."
 432 [mc method allSelectorsSent].
 433
 434 mc@(Method Converse traits) converse
 435 "A converse of a converse is the original method."
 436 [mc method].
 437
 438 mc@(Method Converse traits) do
 439 [mc method do].
 440
 441 mc@(Method Converse traits) applyWith: obj
 442 [mc method applyWith: obj].
 443
 444 mc@(Method Converse traits) applyWith: obj1 with: obj2
 445 [mc method applyWith: obj2 with: obj1].
 446
 447 mc@(Method Converse traits) applyWith: obj1 with: obj2 with: obj3
 448 [mc method applyWith: obj3 with: obj2 with: obj1].
 449
 450 mc@(Method Converse traits) applyTo: array
 451 [mc method applyTo: array reversed].
 452
 453 m@(Method traits) swing
 454 "This is a higher-order function which does a reverse distribution of sorts.
 455 It was ported from:
 456 - http://www.haskell.org/hawiki/LicensedPreludeExts
 457 - http://www.haskell.org/haskellwiki/Pointfree#Swing
 458 Example: collect: takes a collection of objects and a method,
 459   #collect:`er swing takes an object and a collection of methods.
 460 TODO: Improve the documentation, and add examples."
 461 [
 462   m arity = 2
 463     ifTrue: [[| :b :a | m applyTo: {a. [| :g | g applyTo: {b}]}]]
 464     ifFalse:
 465       [TODO: 'Implement multi-argument swing.'
 466        "[| *args | m applyTo: {args last} ; args allButLast reversed]"]
 467 ].
 468
 469 m@(PrimitiveMethod traits) method
 470 [
 471   m
 472 ].
 473
 474 m@(PrimitiveMethod traits) literals [#()].
 475 m@(PrimitiveMethod traits) selectors [#()].
 476 m@(PrimitiveMethod traits) code [Nil].
 477 m@(PrimitiveMethod traits) sourceTree [Nil].
 478 m@(PrimitiveMethod traits) registerCount [m arity].
 479 m@(PrimitiveMethod traits) inputVariables [m arity].
 480 m@(PrimitiveMethod traits) restVariable [Nil].
 481 m@(PrimitiveMethod traits) sourceTree [Nil].
 482 m@(PrimitiveMethod traits) heapAllocate [False].
 483
 484 m@(PrimitiveMethod traits) definitionLocation
 485 [
 486   'primitive:' ; m index printString
 487 ].