languages/APL/tools/gen_operator_defs.pl

   1 #! perl
   2
   3 # $Id$
   4
   5 use strict;
   6 use warnings;
   7
   8 print <<"END_OF_HEADER";
   9
  10 # DO NOT EDIT.
  11 # This file generated automatically by '$0'
  12
  13 END_OF_HEADER
  14
  15 my %macros;
  16 $macros{DOMAIN_ERROR} = <<'END_OF_PIR';
  17     die "DOMAIN ERROR\n"
  18 END_OF_PIR
  19
  20 my %scalar = (
  21     '+' => [ 'Add',   '%1 = %1 + %2' ],
  22     '*' => [ 'Power', << 'END_PIR' ],
  23         # XXX This is too restrictive. Need better tests
  24     if %1 >= 0 goto power_ok
  25 %% DOMAIN_ERROR %%
  26 power_ok:
  27     $N1 = %1
  28     $N2 = %2
  29     $N1 = pow $N1, $N2
  30         %1 = $N1
  31
  32 END_PIR
  33
  34     '\x{d7}' => [ 'Multiply', '%1 = %1 * %2' ],
  35     '\x{f7}' => [ 'Divide',   '%1 = %1 / %2' ],
  36     '\u2212' => [ 'Subtract', '%1 = %1 - %2' ],
  37     '\u2308' => [ 'Maximum',  <<'END_PIR' ],
  38     if %1 > %2 goto maximum_done
  39     %1 = %2
  40 maximum_done:
  41 END_PIR
  42
  43     '\u230a' => [ 'Minimum', <<'END_PIR' ],
  44     if %1 < %2 goto minimum_done
  45     %1 = %2
  46 minimum_done:
  47 END_PIR
  48 );
  49
  50 my $template = <<'END_OF_TEMPLATE';
  51
  52 .namespace []
  53
  54 # any registers #'d 100 or higher are used here for temporary conversions
  55 # to other types required by the various opcodes. XXX This should go away
  56 # Once PMI ports his lovely new perl6 code back into APL.
  57
  58 .sub "__load_inlinetable" :load :init
  59     $P0 = new 'Hash'
  60     store_global "APL", "%pirtable", $P0
  61     .local pmc itable
  62     itable = new 'Hash'
  63     set_hll_global ['APL';'Grammar';'Actions'], '%inlinetable', itable
  64
  65     # special-purpose parrot ops here
  66     itable['dyadic:<']         =  <<'END_PIR'
  67     $I1 = islt %0, %1          # dyadic:< (less than)
  68     %t = $I1
  69 END_PIR
  70
  71     itable['dyadic:>']         =  <<'END_PIR'
  72     $I1 = isgt %0, %1          # dyadic:> (greater than)
  73     %t = $I1
  74 END_PIR
  75
  76     itable['dyadic:=']         =  <<'END_PIR'
  77     $I1 = iseq %0, %1          # dyadic:= (equals)
  78     %t = $I1
  79 END_PIR
  80
  81     itable[unicode:"dyadic:\u2227"]  =  <<'END_PIR'
  82     $I0 = %0                   # dyadic:\u2227 (and)
  83     $I1 = %1
  84     $I1 = and $I0, $I1
  85     %t = $I1
  86 END_PIR
  87
  88     itable[unicode:"dyadic:\u2228"]  = <<'END_PIR'
  89     $I0 = %0                   # dyadic:\u2228 (or)
  90     $I1 = %1
  91     $I1 = or $I0, $I1
  92     %t = $I1
  93 END_PIR
  94
  95     itable[unicode:"dyadic:\u2260"]  = <<'END_PIR'
  96     $I1 = isne %0, %1          # dyadic:\u2260 (not equal)
  97     %t = $I1
  98 END_PIR
  99
 100     itable[unicode:"dyadic:\u2264"]  = <<'END_PIR'
 101     $I1 = isle %0, %1          # dyadic:\u2264 (not greater than)
 102     %t = $I1
 103 END_PIR
 104
 105     itable[unicode:"dyadic:\u2265"]  = <<'END_PIR'
 106     $I1 = isge %0, %1          # dyadic:\u2265 (not less than)
 107     %t = $I1
 108 END_PIR
 109
 110     itable[unicode:"dyadic:\u2371"]  = <<'END_PIR'
 111     $I0 = %0                   # dyadic:\u2371 (nor)
 112     $I1 = %1
 113     $I1 = or $I0, $I1
 114     $I1 = not $I1
 115     %t = $I1
 116 END_PIR
 117
 118     itable[unicode:"dyadic:\u2372"]  =  <<'END_PIR'
 119     $I0 = %0                   # dyadic:\u2372 (nand)
 120     $I1 = %1
 121     $I1 = and $I0, $I1
 122     $I1 = not $I1
 123     %t = $I1
 124 END_PIR
 125
 126     itable['monadic:+']      =  "    %r = %0"          # conjugate
 127     itable['monadic:|']      =  "    %t = abs %0"      # magnitude
 128     itable['monadic:!']      =  <<'END_PIR'
 129     $I1 = %0                   # monadic:! (factorial)
 130     $I1 = fact $I1
 131     %t = $I1
 132 END_PIR
 133
 134     itable['monadic:*']      =  "    %t = exp %0"      # exp
 135     itable[unicode:"monadic:\x{d7}"] =  <<'END_PIR'
 136     $N1 = %0                   # monadic:\x{d7} (signum)
 137     $I1 = cmp_num $N1, 0.0
 138     %t = $I1
 139 END_PIR
 140     itable[unicode:"monadic:\x{f7}"] =  <<'END_PIR'
 141     $N1 = %0                   # monadic:\x{f7} (reciprocal)
 142     $N1 = 1.0 / $N1
 143     %t = $N1
 144 END_PIR
 145
 146     itable[unicode:"monadic:\u2212"] =  "    %t = neg %0"      # negate
 147     itable[unicode:"monadic:\u2308"] =  <<'END_PIR'
 148     $N1 = %0                   # monadic:\u2308 (ceiling)
 149     $I1 = ceil $N1
 150     %t = $I1
 151 END_PIR
 152
 153     itable[unicode:"monadic:\u230a"] =  <<'END_PIR'
 154     $N1 = %0                   # monadic:\u230a (floor)
 155     $I1 = floor $N1
 156     %t = $I1
 157 END_PIR
 158
 159     itable[unicode:"monadic:\u235f"] =  "    %t = ln %0"
 160
 161
 162     itable[unicode:"monadic:\u25cb"] =  "    %t = %0 * 3.14159265358979323846"
 163                                       # PI
 164
 165     itable[unicode:"monadic:\u2373"]  =  <<'END_PIR'            # index of
 166     #XXX hack all the _1's need the same, generated unique number.
 167     %r = new 'APLVector'              # monadic:\u2373 (index of)
 168     $I0 = 1
 169     $I1 = 0
 170     $I2 = %0
 171   loop_begin_1:
 172     if $I0 > $I2 goto loop_done_1
 173     %r[$I1] = $I0
 174     inc $I1
 175     inc $I0
 176     goto loop_begin_1
 177   loop_done_1:
 178 END_PIR
 179
 180 .end
 181
 182 .sub 'aplformat'
 183     .param pmc arg
 184
 185     .local string result
 186     result = ''
 187
 188     .local pmc value
 189     $I0 = does arg, 'array'
 190     if $I0 goto print_vector
 191     value = arg
 192     bsr print_value
 193     .return (result)
 194
 195   print_vector:
 196     .local pmc shape, iter
 197     .local string value_type, old_type
 198     value_type = 'String'
 199     iter = new 'Iterator', arg
 200     shape = arg.'get_shape'()
 201     $I0 = shape
 202     if $I0 == 2 goto print_2D
 203     # XXX assume 1d otherwise.
 204     unless iter goto iter_end
 205   iter_loop:
 206     old_type = value_type
 207     value = shift iter
 208     bsr print_value
 209     unless iter goto iter_end
 210     value_type = typeof value
 211     if value_type != 'String' goto print_space
 212     if old_type != value_type goto print_space
 213     goto iter_loop
 214   print_space:
 215     result .= ' '
 216     goto iter_loop
 217   iter_end:
 218     .return (result)
 219
 220   print_2D:
 221     .local int row_size, pos, newline
 222     row_size = shape[1]
 223     pos = 1
 224     iter = new 'Iterator', arg
 225     value_type = 'String'
 226     unless iter goto loop_end_2d
 227   loop_2d:
 228     newline = 0
 229     if pos != row_size goto cont_2d
 230     newline = 1
 231     pos = 0
 232
 233   cont_2d:
 234     old_type = value_type
 235     value = shift iter
 236     bsr print_value
 237     unless iter goto loop_end_2d
 238     value_type = typeof value
 239     if newline goto print_newline
 240     if value_type != 'String' goto print_space_2d
 241     if old_type != value_type goto print_space_2d
 242     goto print_newline
 243
 244   print_space_2d:  # don't print a space if we're about to end a row
 245     if newline goto print_newline
 246     result .= ' '
 247     goto continue_2d
 248
 249   print_newline:
 250     if newline==0 goto continue_2d
 251     result .= "\n"
 252
 253   continue_2d:
 254     inc pos
 255     goto loop_2d
 256   loop_end_2d:
 257    .return(result)
 258
 259   print_value:
 260     if value >= 0.0 goto print_value_1
 261     result .= unicode:"\u207b"
 262     value = abs value
 263   print_value_1:
 264     $S0 = value
 265     result .= $S0
 266     ret
 267 .end
 268
 269 .sub 'aplprint'
 270     .param pmc arg
 271
 272     $S0 = aplformat(arg)
 273     say $S0
 274 .end
 275
 276 .sub 'aplvector'
 277     .param pmc args            :slurpy
 278     .local pmc vector, iter
 279     vector = new 'APLVector'
 280     if null args goto iter_end
 281     iter = new 'Iterator', args
 282   iter_loop:
 283     unless iter goto iter_end
 284     $P0 = shift iter
 285     push vector, $P0
 286     goto iter_loop
 287   iter_end:
 288     .return (vector)
 289 .end
 290
 291 .sub 'aplstring'
 292     .param string s
 293     .local pmc vector
 294     vector = new 'APLVector'
 295     $I1 = length s
 296     $I0 = 0
 297   loop:
 298     unless $I0 < $I1 goto loop_end
 299     $S0 = substr s, $I0, 1
 300     push vector, $S0
 301     inc $I0
 302     goto loop
 303   loop_end:
 304     .return (vector)
 305 .end
 306
 307
 308 # XXX - the first argument to this multi sub should be some variant of
 309 # integer - but if you set it to Integer or int, the program dies with
 310 # 'Method not found.' or dispatches to the wrong method.
 311
 312 .sub unicode:"dyadic:\u2296" :multi(pmc, APLVector) # rotate
 313     .param int op1
 314     .param pmc op2
 315
 316     if op1 == 0 goto nothing
 317     if op1 <  0 goto neg
 318 pos:
 319     unless op1 goto done
 320     # shift off the beginning and push onto the end.
 321     $P1 = shift op2
 322     push op2, $P1
 323     dec op1
 324     goto pos
 325 neg:
 326     unless op1 goto done
 327     # pop off the end and unshift onto the beginning
 328     $P1 = pop op2
 329     unshift op2, $P1
 330     inc op1
 331     goto neg
 332
 333 done:
 334 nothing:
 335     .return(op2)
 336 .end
 337
 338 .sub 'dyadic:!'           # binomial coefficient
 339     .param pmc op1
 340     .param pmc op2
 341     $I1 = op1
 342     $I2 = op2
 343     $I3 = $I2 - $I1
 344
 345     $N1 = fact $I1
 346     $N2 = fact $I2
 347     $N3 = fact $I3
 348
 349     $N2 /= $N3
 350     $N2 /= $N1
 351     .return($N2)
 352 .end
 353
 354 .sub unicode:"dyadic:\u2373" :multi(APLVector, APLVector) # index of
 355     .param pmc op1
 356     .param pmc op2
 357
 358     .local pmc iter_one, iter_two
 359     .local pmc item_one, item_two
 360     .local int pos_one
 361     .local int not_found
 362
 363     not_found = op1
 364     inc not_found
 365
 366     .local pmc result
 367     result = new 'APLVector'
 368
 369     iter_two = new 'Iterator', op2
 370 loop_two:
 371     unless iter_two goto loop_two_end
 372     item_two = shift iter_two
 373     iter_one = new 'Iterator', op1
 374     pos_one = 0 # parrot's 0 == APL's 1
 375 loop_one:
 376     unless iter_one goto loop_one_end
 377     item_one = shift iter_one
 378     inc pos_one
 379     if item_one != item_two goto loop_one
 380     push result, pos_one
 381     # only need to find one, go back to outer loop.
 382     goto loop_two
 383 loop_one_end:
 384     # if we get this far, there was no match.
 385     push result, not_found
 386
 387     goto loop_two
 388 loop_two_end:
 389
 390     .return (result)
 391 .end
 392
 393 .sub unicode:"dyadic:\u2373" :multi(APLVector, Float) # index of
 394     .param pmc op1
 395     .param num op2
 396
 397     .local pmc result
 398     result = new 'APLVector'
 399
 400     .local int pos
 401     pos = 0
 402     .local num value_at
 403     .local int not_there
 404     not_there = op1
 405     inc not_there
 406     .local pmc iter
 407     iter = new 'Iterator', op1
 408 loop_begin:
 409     unless iter goto no_gots
 410     value_at = shift iter
 411     if value_at == op2 goto got_it
 412     inc pos
 413     goto loop_begin
 414 got_it:
 415     inc pos
 416     push result, pos
 417     .return (result)
 418 no_gots:
 419     push result, not_there
 420     .return (result)
 421 .end
 422
 423 .sub unicode:"dyadic:\u25cb"          # circle
 424     .param num op1
 425     .param num op2
 426     $I1 = op1
 427     if $I1 == 0 goto zero
 428     if $I1 == 1 goto one
 429     if $I1 == 2 goto two
 430     if $I1 == 3 goto three
 431     if $I1 == 4 goto four
 432     if $I1 == 5 goto five
 433     if $I1 == 6 goto six
 434     if $I1 == 7 goto seven
 435     if $I1 == -1 goto neg_one
 436     if $I1 == -2 goto neg_two
 437     if $I1 == -3 goto neg_three
 438     if $I1 == -4 goto neg_four
 439     if $I1 == -5 goto neg_five
 440     if $I1 == -6 goto neg_six
 441     if $I1 == -7 goto neg_seven
 442
 443 # XXX this right?
 444 %% DOMAIN_ERROR %%
 445 zero:
 446     $N1 = op2 * op2
 447     $N1 = 1 - $N1
 448     $N1 = sqrt $N1
 449     .return ($N1)
 450 one:
 451     $N1 = sin op2
 452     .return ($N1)
 453 two:
 454     $N1 = cos op2
 455     .return ($N1)
 456 three:
 457     $N1 = tan op2
 458     .return ($N1)
 459 four:
 460     $N1 = op2 * op2
 461     $N1 += 1
 462     $N1 = sqrt $N1
 463     .return ($N1)
 464 five:
 465     $N1 = sinh op2
 466     .return ($N1)
 467 six:
 468     $N1 = cosh op2
 469     .return ($N1)
 470 seven:
 471     $N1 = tanh op2
 472     .return ($N1)
 473 neg_one:
 474     $N1 = asin op2
 475     .return ($N1)
 476 neg_two:
 477     $N1 = acos op2
 478     .return ($N1)
 479 neg_three:
 480     $N1 = atan op2
 481     .return ($N1)
 482 neg_four:
 483     $N1 = op2 * op2
 484     $N1 = 1 - $N1
 485     $N1 = sqrt $N1
 486     .return ($N1)
 487 # These next three are implemented in terms of the available parrot opcodes.
 488 neg_five:  # arcsinh(x) = ln(x+sqrt(x*x+1))
 489     $N1 = op2 * op2
 490     inc $N1
 491     $N1 = sqrt $N1
 492     $N1 += op2
 493     $N1 = ln $N1
 494     .return ($N1)
 495 neg_six:   # arccosh(x) = ln(x+sqrt(x-1)*sqrt(x+1))
 496     $N1 = op2 + 1
 497     $N1 = sqrt $N1
 498     $N2 = op2 - 1
 499     $N2 = sqrt $N2
 500     $N2 *= $N1
 501     $N2 = op2 + $N2
 502     $N2 = ln $N2
 503     .return ($N2)
 504 neg_seven: # arctanh(x) = .5 * (ln (1+x) - ln (1 -x))
 505     $N1 = op2 + 1
 506     $N1 = ln $N1
 507     $N2 = 1 - op2
 508     $N2 = ln $N2
 509     $N1 = $N1 - $N2
 510     $N1 *= 0.5
 511     .return ($N1)
 512 .end
 513
 514 .sub unicode:"dyadic:\u235f"          # logarithm
 515     .param num op1
 516     .param num op2
 517     $N1 = ln op1
 518     $N2 = ln op2
 519     $N3 = $N1 / $N2
 520     .return($N3)
 521 .end
 522
 523 # This somewhat convoluted based the description from the old APL/360 manual
 524 .sub 'dyadic:|'               # logarithm
 525     .param num op1
 526     .param num op2
 527     if op1 == 0 goto zero_LHS
 528     op1 = abs op1
 529     $N1 = op2 / op1
 530     $I1 = floor $N1
 531     $N1 = op1 * $I1
 532     $N2 = op2 - $N1
 533     .return($N2)
 534 zero_LHS:
 535     if op2 < 0 goto neg_RHS
 536     .return(op2)
 537 neg_RHS:
 538     %% DOMAIN_ERROR %%
 539 .end
 540
 541 .sub 'monadic:~'               # not
 542     .param num op1
 543     # XXX is domain only 0,1?
 544     $I1 = op1
 545     if $I1 goto true
 546     .return(1)
 547 true:
 548     .return(0)
 549 .end
 550
 551 .sub unicode:"monadic:\u233d" :multi(APLVector) # reverse
 552     .param pmc op1
 553
 554     .local pmc result,iter
 555     result = new 'APLVector'
 556     iter = new 'Iterator', op1
 557
 558 loop:
 559     unless iter goto done
 560     $P1 = shift iter
 561     unshift result, $P1
 562     goto loop
 563 done:
 564     .return(result)
 565 .end
 566
 567 .sub 'dyadic:~' :multi(APLVector, APLVector) # without
 568     .param pmc op1
 569     .param pmc op2
 570
 571     .local pmc result
 572     result = new 'APLVector'
 573
 574     .local pmc iter1,iter2
 575     iter1 = new 'Iterator', op1
 576
 577 outer_loop:
 578     unless iter1 goto outer_done
 579     $P1 = shift iter1
 580
 581     iter2 = new 'Iterator', op2
 582 inner_loop:
 583     unless iter2 goto inner_done
 584     $P2 = shift iter2
 585     if $P1 == $P2 goto outer_loop # result must be without this.
 586     goto inner_loop
 587
 588 inner_done:
 589     push result, $P1
 590     goto outer_loop
 591
 592 outer_done:
 593     .return(result)
 594 .end
 595
 596 .sub unicode:"monadic:\u2191" # first
 597     .param pmc op1
 598     $P1 = shift op1
 599     .return ($P1)
 600 .end
 601
 602 .sub unicode:"dyadic:\u2191" :multi (Float, APLVector) # take
 603     .param int op1
 604     .param pmc op2
 605
 606     .local pmc result
 607     result = new 'APLVector'
 608
 609     .local pmc iter
 610     iter = new 'Iterator', op2
 611
 612     if op1 >= 0 goto pos_loop
 613     iter = 4 # ITERATE_FROM_END
 614
 615 neg_loop:
 616     if op1 == 0 goto done
 617     unless iter goto done
 618
 619     $P1 = pop op2  # have to pop when iterating from end.
 620     unshift result, $P1
 621
 622     inc op1
 623     goto neg_loop
 624
 625 pos_loop:
 626     if op1 == 0 goto done
 627     unless iter goto done
 628
 629     $P1 = shift iter
 630     push result, $P1
 631
 632     dec op1
 633     goto pos_loop
 634
 635 done:
 636     .return (result)
 637 .end
 638
 639 .sub unicode:"dyadic:\u2193" :multi (Float, APLVector) # drop
 640     .param int op1
 641     .param pmc op2
 642
 643     if op1 < 0 goto neg_loop
 644
 645 pos_loop:
 646     if op1 == 0 goto done
 647     $P1 = shift op2 # ignore p1, we're discarding it
 648     dec op1
 649     goto pos_loop
 650
 651 neg_loop:
 652     if op1 == 0 goto done
 653     $P1 = pop op2 # ignore p1, we're discarding it
 654     inc op1
 655     goto neg_loop
 656
 657 done:
 658     .return (op2)
 659 .end
 660
 661 .sub unicode:"monadic:\u2374" :multi (Float) # shape
 662     .param pmc op1
 663
 664     .local pmc result
 665     result = new 'APLVector'
 666     .return (result)
 667 .end
 668
 669 .sub unicode:"monadic:\u2374" :multi (APLVector) # shape
 670     .param pmc op1
 671     .return op1.'get_shape'()
 672 .end
 673
 674 .sub unicode:"dyadic:\u2374" :multi (APLVector,APLVector) # reshape
 675     .param pmc op1
 676     .param pmc op2
 677
 678     # XXX is a clone needed here?
 679     op2.'set_shape'(op1)
 680     .return (op2)
 681 .end
 682
 683 .sub unicode:"dyadic:\u2374" :multi (APLVector,Float) # reshape
 684     .param pmc op1
 685     .param pmc op2
 686
 687     # Convert the scalar into a vector and reshape it.
 688     $P1 = new 'APLVector'
 689     push $P1, op2
 690     $P1.'set_shape'(op1)
 691     .return ($P1)
 692 .end
 693
 694
 695 .sub unicode:"monadic:\u2355" #format
 696     .param pmc op1
 697
 698     $S0 = aplformat(op1)
 699     .local pmc result
 700     result = new 'APLVector'
 701     $I0 = 0
 702     $I1 = length $S0
 703   loop:
 704     if $I0 >= $I1 goto loop_end
 705     $S1 = substr $S0, $I0, 1
 706     push result, $S1
 707     inc $I0
 708     goto loop
 709   loop_end:
 710     .return(result)
 711 .end
 712
 713 .sub unicode:"monadic:\u2395\u2190" # quad output
 714     .param pmc op1
 715
 716     'aplprint'(op1)
 717     .return(op1)
 718 .end
 719
 720
 721 END_OF_TEMPLATE
 722
 723 # Generate all variants for scalar dyadic ops.
 724 my @type_pairs = (
 725     [ 'Float',     'Float' ],
 726     [ 'Float',     'APLVector' ],
 727     [ 'APLVector', 'Float' ],
 728     [ 'APLVector', 'APLVector' ],
 729 );
 730
 731 foreach my $operator ( keys %scalar ) {
 732     my ( $name, $code ) = @{ $scalar{$operator} };
 733     foreach my $types (@type_pairs) {
 734         my ( $type1, $type2 ) = @$types;
 735
 736         $template .= <<"END_PREAMBLE";
 737
 738
 739 # $name
 740 .sub unicode:"dyadic:$operator" :multi ( $type1, $type2 )
 741     .param pmc op1
 742     .param pmc op2
 743 END_PREAMBLE
 744
 745         if ( $type1 eq "Float" && $type2 eq "Float" ) {
 746
 747             # scalar to scalar..
 748             $template .= interpolate( $code, 'op1', 'op2' );
 749         }
 750         elsif ( $type1 eq "APLVector" && $type2 eq "APLVector" ) {
 751
 752             # vector to vector
 753             $template .= << 'END_PIR';
 754     # Verify Shapes conform.
 755     $I1 = op1
 756     $I2 = op2
 757     if $I1 == $I2 goto good
 758     %% DOMAIN_ERROR %%
 759   good:
 760     # Create a result vector
 761     .local pmc result
 762     result = new 'APLVector'
 763     # Loop through each vector, doing the ops.
 764     .local pmc iter1, iter2
 765     iter1 = new 'Iterator', op1
 766     iter2 = new 'Iterator', op2
 767   loop:
 768     unless iter1 goto loop_done
 769     $P1 = shift iter1
 770     $P2 = shift iter2
 771     $S1 = typeof $P1
 772     if $S1 == 'String' goto bad_args
 773     $S2 = typeof $P2
 774     if $S2 == 'String' goto bad_args
 775     goto got_args
 776   bad_args:
 777     %% DOMAIN_ERROR %%
 778   got_args:
 779 END_PIR
 780
 781             $template .= interpolate( $code, '$P1', '$P2' );
 782
 783             $template .= << 'END_PIR';
 784
 785     push result, $P1
 786     goto loop
 787 loop_done:
 788     # return the result vector
 789     .return (result)
 790 END_PIR
 791
 792         }
 793         else {
 794
 795             # Vector to Scalar
 796             my ( $vector, $scalar, @order );
 797             if ( $type1 eq 'APLVector' ) {
 798                 $vector = "op1";
 799                 $scalar = "op2";
 800                 @order  = qw/ $P1 $P2 /;
 801             }
 802             else {
 803                 $vector = "op2";
 804                 $scalar = "op1";
 805                 @order  = qw/ $P2 $P1 /;
 806             }
 807
 808             $template .= << "END_PIR";
 809     # Create a result vector
 810     .local pmc result
 811     result = new 'APLVector'
 812     # Loop through each vector, doing the ops.
 813     .local pmc iter1
 814     iter1 = new 'Iterator', $vector
 815   loop:
 816     unless iter1 goto loop_done
 817     \$P1 = shift iter1
 818     \$S1 = typeof \$P1
 819     if \$S1 != 'String' goto got_args
 820     %% DOMAIN_ERROR %%
 821   got_args:
 822         \$P2 = clone $scalar
 823 END_PIR
 824
 825             $template .= interpolate( $code, @order );
 826
 827             $template .= 'push result, ' . $order[0] . "\n";
 828
 829             $template .= << 'END_PIR';
 830     goto loop
 831 loop_done:
 832     # return the result vector
 833     .return (result)
 834 END_PIR
 835         }
 836
 837         $template .= <<"END_POSTAMBLE"
 838     .return (op1) # might be pre-empted
 839 .end
 840 END_POSTAMBLE
 841     }
 842 }
 843
 844 # Substitute all macros
 845 foreach my $macro ( keys %macros ) {
 846     $template =~ s/%% \s+ $macro \s+ %%/$macros{$macro}/gx;
 847 }
 848
 849 print $template;
 850
 851 # Given a code snippet, convert it to something usable in the generated file
 852
 853 sub interpolate {
 854     my $code = shift;
 855     my $op1  = shift;
 856     my $op2  = shift;
 857     $code =~ s/%1/$op1/g;
 858     $code =~ s/%2/$op2/g;
 859     $code .= "\n";
 860     return ($code);
 861 }
 862
 863 __END__
 864
 865 =head1 NAME
 866
 867 tools/gen_operator_defs.pl - Generate the definitions for all the various
 868 APL operators in all possible configurations.
 869
 870 =head1 LICENSE
 871
 872 Copyright (C) 2005-2006, The Perl Foundation.
 873
 874 This is free software; you may redistribute it and/or modify
 875 it under the same terms as Parrot.
 876
 877 =cut
 878
 879
 880 # Local Variables:
 881 #   mode: cperl
 882 #   cperl-indent-level: 4
 883 #   fill-column: 100
 884 # End:
 885 # vim: expandtab shiftwidth=4: