compilers/imcc/parser_util.c

   1 /*
   2  * parser_util.c
   3  *
   4  * Intermediate Code Compiler for Parrot.
   5  *
   6  * Copyright (C) 2002 Melvin Smith <melvin.smith@mindspring.com>
   7  * Copyright (C) 2002-2008, The Perl Foundation.
   8  *
   9  * parser support functions
  10  *
  11  * $Id$
  12  *
  13  */
  14
  15 #include <string.h>
  16 #include <stdio.h>
  17 #include <stdlib.h>
  18
  19 #define _PARSER
  20
  21 #include "imc.h"
  22 #include "parrot/dynext.h"
  23 #include "parrot/embed.h"
  24 #include "parrot/builtin.h"
  25 #include "pbc.h"
  26 #include "parser.h"
  27 #include "optimizer.h"
  28
  29 /*
  30
  31 =head1 NAME
  32
  33 compilers/imcc/parser_util.c
  34
  35 =head1 DESCRIPTION
  36
  37 ParserUtil - Parser support functions.
  38
  39 =cut
  40
  41 */
  42
  43 /* HEADERIZER HFILE: compilers/imcc/imc.h */
  44
  45 /* HEADERIZER BEGIN: static */
  46 /* Don't modify between HEADERIZER BEGIN / HEADERIZER END.  Your changes will be lost. */
  47
  48 PARROT_WARN_UNUSED_RESULT
  49 static int change_op(PARROT_INTERP,
  50     ARGMOD(IMC_Unit *unit),
  51     ARGMOD(SymReg **r),
  52     int num,
  53     int emit)
  54         __attribute__nonnull__(1)
  55         __attribute__nonnull__(2)
  56         __attribute__nonnull__(3)
  57         FUNC_MODIFIES(*unit)
  58         FUNC_MODIFIES(*r);
  59
  60 PARROT_CANNOT_RETURN_NULL
  61 static void * imcc_compile_file(PARROT_INTERP,
  62     ARGIN(const char *fullname),
  63     ARGOUT(STRING **error_message))
  64         __attribute__nonnull__(1)
  65         __attribute__nonnull__(2)
  66         __attribute__nonnull__(3)
  67         FUNC_MODIFIES(*error_message);
  68
  69 PARROT_WARN_UNUSED_RESULT
  70 static int is_infix(ARGIN(const char *name), int n, ARGIN(SymReg **r))
  71         __attribute__nonnull__(1)
  72         __attribute__nonnull__(3);
  73
  74 PARROT_WARN_UNUSED_RESULT
  75 PARROT_CAN_RETURN_NULL
  76 static Instruction * maybe_builtin(PARROT_INTERP,
  77     ARGIN(const char *name),
  78     ARGIN(SymReg * const *r),
  79     int n)
  80         __attribute__nonnull__(1)
  81         __attribute__nonnull__(2)
  82         __attribute__nonnull__(3);
  83
  84 PARROT_WARN_UNUSED_RESULT
  85 PARROT_CANNOT_RETURN_NULL
  86 static const char * to_infix(PARROT_INTERP,
  87     ARGIN(const char *name),
  88     ARGMOD(SymReg **r),
  89     ARGMOD(int *n),
  90     int mmd_op)
  91         __attribute__nonnull__(1)
  92         __attribute__nonnull__(2)
  93         __attribute__nonnull__(3)
  94         __attribute__nonnull__(4)
  95         FUNC_MODIFIES(*r)
  96         FUNC_MODIFIES(*n);
  97
  98 PARROT_WARN_UNUSED_RESULT
  99 PARROT_CAN_RETURN_NULL
 100 static const char * try_rev_cmp(ARGIN(const char *name), ARGMOD(SymReg **r))
 101         __attribute__nonnull__(1)
 102         __attribute__nonnull__(2)
 103         FUNC_MODIFIES(*r);
 104
 105 PARROT_MALLOC
 106 PARROT_CANNOT_RETURN_NULL
 107 PARROT_WARN_UNUSED_RESULT
 108 static Instruction * var_arg_ins(PARROT_INTERP,
 109     ARGMOD(IMC_Unit *unit),
 110     ARGIN(const char *name),
 111     ARGMOD(SymReg **r),
 112     int n,
 113     int emit)
 114         __attribute__nonnull__(1)
 115         __attribute__nonnull__(2)
 116         __attribute__nonnull__(3)
 117         __attribute__nonnull__(4)
 118         FUNC_MODIFIES(*unit)
 119         FUNC_MODIFIES(*r);
 120
 121 /* Don't modify between HEADERIZER BEGIN / HEADERIZER END.  Your changes will be lost. */
 122 /* HEADERIZER END: static */
 123
 124 /*
 125  * FIXME:
 126  *
 127  * used in -D20 to print files with the output of every PIR compilation
 128  * this can't be attached to the interpreter or packfile because it has to be
 129  * absolutely global to prevent the files from being overwritten.
 130  *
 131  * This is not thread safe as is. A mutex needs to be added.
 132  *
 133  * See RT#40010 for more discussion.
 134  */
 135 static INTVAL eval_nr = 0;
 136
 137 /*
 138
 139 =head2 Functions
 140
 141 =over 4
 142
 143 =item C<Instruction * iNEW>
 144
 145  * P = new type, [init]
 146  * PASM like:
 147  *   new P, 'SomeThing'
 148  * is done in the lexer, this is a mess
 149  * best would be to have a flag in core.ops, where a PMC type is expected
 150
 151 =cut
 152
 153  */
 154
 155 PARROT_WARN_UNUSED_RESULT
 156 PARROT_CAN_RETURN_NULL
 157 Instruction *
 158 iNEW(PARROT_INTERP, ARGMOD(IMC_Unit *unit), ARGMOD(SymReg *r0),
 159         ARGMOD(char *type), ARGIN_NULLOK(SymReg *init), int emit)
 160 {
 161     char fmt[256];
 162     SymReg *regs[3];
 163     SymReg *pmc;
 164     int nargs;
 165     const int pmc_num = pmc_type(interp,
 166             string_from_cstring(interp, *type == '.' ? type + 1 : type, 0));
 167
 168     snprintf(fmt, sizeof (fmt), "%d", pmc_num);
 169     pmc = mk_const(interp, fmt, 'I');
 170
 171     if (pmc_num <= 0)
 172         IMCC_fataly(interp, E_SyntaxError,
 173                 "Unknown PMC type '%s'\n", type);
 174
 175     snprintf(fmt, sizeof (fmt), "%%s, %d\t # .%s", pmc_num, type);
 176
 177     r0->usage |= U_NEW;
 178     if (STREQ(type, "Hash"))
 179         r0->usage |= U_KEYED;
 180
 181     regs[0] = r0;
 182     regs[1] = pmc;
 183
 184     if (init) {
 185         regs[2] = init;
 186         nargs   = 3;
 187     }
 188     else
 189         nargs = 2;
 190
 191     return INS(interp, unit, "new", fmt, regs, nargs, 0, emit);
 192 }
 193
 194 /*
 195
 196 =item C<void op_fullname>
 197
 198 Lookup the full opcode given the short name
 199
 200    set I0, 5  -> set_i_ic
 201    set I0, I1 -> set_i_i
 202
 203 Obviously the registers must be examined before returning the correct
 204 opcode.
 205
 206 NOTE: All this nasty IMC_TRACE is for tracking down equally nasty bugs, so
 207 if you don't like the looks of it, stay out, but please don't remove it. :)
 208 -Mel
 209
 210 =cut
 211
 212  */
 213 void
 214 op_fullname(ARGOUT(char *dest), ARGIN(const char *name),
 215     ARGIN(SymReg * const *args), int narg, int keyvec)
 216 {
 217     int i;
 218
 219 #if IMC_TRACE_HIGH
 220     char *full = dest;
 221     PIO_eprintf(NULL, "op %s", name);
 222 #endif
 223
 224     strcpy(dest, name);
 225
 226     dest += strlen(name);
 227
 228     for (i = 0; i < narg && args[i]; i++) {
 229         *dest++ = '_';
 230         if (args[i]->type == VTADDRESS) {
 231 #if IMC_TRACE_HIGH
 232             PIO_eprintf(NULL, " (address)%s", args[i]->name);
 233 #endif
 234             *dest++ = 'i';
 235             *dest++ = 'c';
 236             continue;
 237         }
 238         /* if one ever wants num keys, they go with 'S' */
 239         if (keyvec & KEY_BIT(i)) {
 240 #if IMC_TRACE_HIGH
 241             PIO_eprintf(NULL, " (key)%s", args[i]->name);
 242 #endif
 243             *dest++ = 'k';
 244             if (args[i]->set=='S' || args[i]->set=='N' || args[i]->set=='K') {
 245                 *dest++ = 'c';
 246                 continue;
 247             }
 248             else if (args[i]->set == 'P')
 249                 continue;
 250         }
 251
 252         if (args[i]->set == 'K')
 253             *dest++ = 'p';
 254         else
 255             *dest++ = (char)tolower((unsigned char)args[i]->set);
 256
 257         if (args[i]->type & (VTCONST|VT_CONSTP)) {
 258 #if IMC_TRACE_HIGH
 259             PIO_eprintf(NULL, " (%cc)%s", tolower((unsigned char)args[i]->set), args[i]->name);
 260 #endif
 261             *dest++ = 'c';
 262         }
 263 #if IMC_TRACE_HIGH
 264         else
 265             PIO_eprintf(NULL, " (%c)%s", tolower((unsigned char)args[i]->set), args[i]->name);
 266 #endif
 267     }
 268     *dest = '\0';
 269 #if IMC_TRACE_HIGH
 270     PIO_eprintf(NULL, " -> %s\n", full);
 271 #endif
 272 }
 273
 274 /*
 275
 276 =item C<int check_op>
 277
 278 Return opcode value for op name
 279
 280 =cut
 281
 282 */
 283
 284 PARROT_WARN_UNUSED_RESULT
 285 int
 286 check_op(PARROT_INTERP, ARGOUT(char *fullname), ARGIN(const char *name),
 287         ARGIN(SymReg * const * r), int narg, int keyvec)
 288 {
 289     op_fullname(fullname, name, r, narg, keyvec);
 290
 291     return interp->op_lib->op_code(fullname, 1);
 292 }
 293
 294 /*
 295
 296 =item C<static Instruction * maybe_builtin>
 297
 298 TODO: Needs to be documented!!!
 299
 300 =cut
 301
 302 */
 303
 304 PARROT_WARN_UNUSED_RESULT
 305 PARROT_CAN_RETURN_NULL
 306 static Instruction *
 307 maybe_builtin(PARROT_INTERP, ARGIN(const char *name),
 308         ARGIN(SymReg * const *r), int n)
 309 {
 310     char sig[16];
 311     SymReg *sub, *meth, *rr[10];
 312     Instruction *ins;
 313     int i, bi, is_class_meth, first_arg, is_void;
 314
 315     PARROT_ASSERT(n < 15);
 316
 317     for (i = 0; i < n; ++i) {
 318         sig[i] = (char)r[i]->set;
 319         rr[i]  = r[i];
 320     }
 321
 322     sig[i] = '\0';
 323     bi     = Parrot_is_builtin(name, sig);
 324
 325     if (bi < 0)
 326         return NULL;
 327
 328     /*
 329      * create a method see imcc.y target = sub_call
 330      * cos Px, Py  => Px = Py.cos()
 331      */
 332     is_class_meth = Parrot_builtin_is_class_method(bi);
 333     is_void       = Parrot_builtin_is_void(bi);
 334     meth          = mk_sub_address(interp, name);
 335
 336     /* ParrotIO.open() */
 337     if (is_class_meth) {
 338         const char * const ns = Parrot_builtin_get_c_namespace(bi);
 339         SymReg * const ns_sym = mk_const(interp, ns, 'S');
 340
 341         ins                   = IMCC_create_itcall_label(interp);
 342         sub                   = ins->symregs[0];
 343
 344         IMCC_itcall_sub(interp, meth);
 345
 346         sub->pcc_sub->object  = ns_sym;
 347         first_arg             = 1;
 348     }
 349     /* method y = x."cos"() */
 350     else {
 351         ins                   = IMCC_create_itcall_label(interp);
 352         sub                   = ins->symregs[0];
 353
 354         IMCC_itcall_sub(interp, meth);
 355
 356         sub->pcc_sub->object  = rr[is_void ? 0 : 1];
 357         first_arg             = 2;
 358     }
 359
 360     sub->pcc_sub->flags |= isNCI;
 361
 362     if (is_void)
 363         first_arg--;
 364
 365     for (i = first_arg; i < n; ++i)
 366         add_pcc_arg(sub, rr[i]);
 367
 368     if (!is_void)
 369         add_pcc_result(sub, rr[0]);
 370
 371     return ins;
 372 }
 373
 374 /*
 375
 376 =item C<int is_op>
 377
 378 Is instruction a parrot opcode?
 379
 380 =cut
 381
 382 */
 383
 384 PARROT_WARN_UNUSED_RESULT
 385 int
 386 is_op(PARROT_INTERP, ARGIN(const char *name))
 387 {
 388     return interp->op_lib->op_code(name, 0) >= 0
 389         || interp->op_lib->op_code(name, 1) >= 0
 390         || ((name[0] == 'n' && name[1] == '_')
 391                 && (interp->op_lib->op_code(name + 2, 0) >= 0
 392                    || interp->op_lib->op_code(name + 2, 1) >= 0))
 393         || Parrot_is_builtin(name, NULL) >= 0;
 394 }
 395
 396 /*
 397
 398 =item C<static const char * to_infix>
 399
 400 sub x, y, z  => infix .MMD_SUBTRACT, x, y, z
 401
 402 =cut
 403
 404 */
 405
 406 PARROT_WARN_UNUSED_RESULT
 407 PARROT_CANNOT_RETURN_NULL
 408 static const char *
 409 to_infix(PARROT_INTERP, ARGIN(const char *name), ARGMOD(SymReg **r),
 410         ARGMOD(int *n), int mmd_op)
 411 {
 412     SymReg *mmd;
 413     int is_n;
 414
 415     PARROT_ASSERT(*n >= 2);
 416
 417     is_n = (IMCC_INFO(interp)->state->pragmas & PR_N_OPERATORS) ||
 418         (name[0] == 'n' && name[1] == '_') ||
 419         (mmd_op == MMD_LOR || mmd_op == MMD_LAND || mmd_op == MMD_LXOR);
 420
 421     if (*n == 3 && r[0] == r[1] && !is_n) {       /* cvt to inplace */
 422         char buf[10];
 423         snprintf(buf, sizeof (buf), "%d", mmd_op + 1);  /* XXX */
 424         mmd = mk_const(interp, buf, 'I');
 425     }
 426     else {
 427         char buf[10];
 428         int i;
 429         for (i = *n; i > 0; --i)
 430             r[i] = r[i - 1];
 431
 432         snprintf(buf, sizeof (buf), "%d", *n == 2 ? (mmd_op + 1) : mmd_op);  /* XXX */
 433         mmd = mk_const(interp, buf, 'I');
 434         (*n)++;
 435     }
 436
 437     r[0] = mmd;
 438
 439     if (is_n && *n == 4)
 440         return "n_infix";
 441     else
 442         return "infix";
 443 }
 444
 445 /*
 446
 447 =item C<static int is_infix>
 448
 449 TODO: Needs to be documented!!!
 450
 451 =cut
 452
 453 */
 454
 455 PARROT_WARN_UNUSED_RESULT
 456 static int
 457 is_infix(ARGIN(const char *name), int n, ARGIN(SymReg **r))
 458 {
 459     if (n < 2 || r[0]->set != 'P')
 460         return -1;
 461
 462     /* TODO use a generic Parrot interface function,
 463      *      which handles user infix extensions too
 464      */
 465     if (STREQ(name, "add"))
 466         return MMD_ADD;
 467     if (STREQ(name, "sub"))
 468         return MMD_SUBTRACT;
 469     if (STREQ(name, "mul"))
 470         return MMD_MULTIPLY;
 471     if (STREQ(name, "div"))
 472         return MMD_DIVIDE;
 473     if (STREQ(name, "fdiv"))
 474         return MMD_FLOOR_DIVIDE;
 475     if (STREQ(name, "mod"))
 476         return MMD_MOD;
 477     if (STREQ(name, "cmod"))
 478         return MMD_CMOD;
 479     if (STREQ(name, "pow"))
 480         return MMD_POW;
 481
 482     if (STREQ(name, "bor"))
 483         return MMD_BOR;
 484     if (STREQ(name, "band"))
 485         return MMD_BAND;
 486     if (STREQ(name, "bxor"))
 487         return MMD_BXOR;
 488     if (STREQ(name, "bors"))
 489         return MMD_SOR;
 490     if (STREQ(name, "bands"))
 491         return MMD_SAND;
 492     if (STREQ(name, "bxors"))
 493         return MMD_SXOR;
 494
 495     if (STREQ(name, "shl"))
 496         return MMD_BSL;
 497     if (STREQ(name, "shr"))
 498         return MMD_BSR;
 499     if (STREQ(name, "lsr"))
 500         return MMD_LSR;
 501
 502     if (STREQ(name, "concat"))
 503         return MMD_CONCAT;
 504     if (STREQ(name, "repeat"))
 505         return MMD_REPEAT;
 506
 507     if (STREQ(name, "or"))
 508         return MMD_LOR;
 509     if (STREQ(name, "and"))
 510         return MMD_LAND;
 511     if (STREQ(name, "xor"))
 512         return MMD_LXOR;
 513
 514     /* now try n_<op> */
 515     if (name[0] == 'n' && name[1] == '_')
 516         return is_infix(name + 2, n, r);
 517
 518     return -1;
 519 }
 520
 521 /*
 522
 523 =item C<static Instruction * var_arg_ins>
 524
 525 TODO: Needs to be documented!!!
 526
 527 =cut
 528
 529 */
 530
 531 PARROT_MALLOC
 532 PARROT_CANNOT_RETURN_NULL
 533 PARROT_WARN_UNUSED_RESULT
 534 static Instruction *
 535 var_arg_ins(PARROT_INTERP, ARGMOD(IMC_Unit *unit), ARGIN(const char *name),
 536         ARGMOD(SymReg **r), int n, int emit)
 537 {
 538     int op;
 539     Instruction *ins;
 540     char fullname[64];
 541
 542     /* in constant */
 543     int dirs       = 1;
 544
 545     r[0]           = mk_const(interp, r[0]->name, 'P');
 546     r[0]->pmc_type = enum_class_FixedIntegerArray;
 547
 548     op_fullname(fullname, name, r, 1, 0);
 549     op = interp->op_lib->op_code(fullname, 1);
 550
 551     PARROT_ASSERT(op >= 0);
 552
 553     ins         = _mk_instruction(name, "", n, r, dirs);
 554     ins->opnum  = op;
 555     ins->opsize = n + 1;
 556
 557     if (emit)
 558         emitb(interp, unit, ins);
 559
 560     return ins;
 561 }
 562
 563 /*
 564
 565 =item C<Instruction * INS>
 566
 567 Make an instruction.
 568
 569 name ... op name
 570 fmt ... optional format
 571 regs ... SymReg **
 572 n ... # of params
 573 keyvec ... s. KEY_BIT()
 574 emit ... if true, append to instructions
 575
 576 s. e.g. imc.c for usage
 577
 578 =cut
 579
 580 */
 581
 582 PARROT_IGNORABLE_RESULT
 583 PARROT_CAN_RETURN_NULL
 584 Instruction *
 585 INS(PARROT_INTERP, ARGMOD(IMC_Unit *unit), ARGIN(const char *name),
 586     ARGIN_NULLOK(const char *fmt), ARGIN(SymReg **r), int n, int keyvec,
 587     int emit)
 588 {
 589     int i, op, len;
 590     int dirs = 0;
 591     Instruction *ins;
 592     op_info_t   *op_info;
 593     char fullname[64], format[128], buf[10];
 594
 595     if ((STREQ(name, "set_args"))
 596     ||  (STREQ(name, "get_results"))
 597     ||  (STREQ(name, "get_params"))
 598     ||  (STREQ(name, "set_returns")))
 599         return var_arg_ins(interp, unit, name, r, n, emit);
 600
 601     op = is_infix(name, n, r);
 602
 603     if (op >= 0) {
 604         /* sub x, y, z  => infix .MMD_SUBTRACT, x, y, z */
 605         name = to_infix(interp, name, r, &n, op);
 606     }
 607     else if ((IMCC_INFO(interp)->state->pragmas & PR_N_OPERATORS)
 608          && ((STREQ(name, "abs"))
 609          ||  (STREQ(name, "neg"))
 610          ||  (STREQ(name, "not"))
 611          ||  (STREQ(name, "bnot"))
 612          ||  (STREQ(name, "bnots")))) {
 613         strcpy(buf, "n_");
 614         strcat(buf, name);
 615         name = buf;
 616     }
 617
 618 #if 0
 619     ins = multi_keyed(interp, unit, name, r, n, keyvec, emit);
 620     if (ins)
 621         return ins;
 622 #endif
 623
 624     op_fullname(fullname, name, r, n, keyvec);
 625     op = interp->op_lib->op_code(fullname, 1);
 626
 627     /* maybe we have a fullname */
 628     if (op < 0)
 629         op = interp->op_lib->op_code(name, 1);
 630
 631     /* still wrong, try reverse compare */
 632     if (op < 0) {
 633         const char * const n_name = try_rev_cmp(name, r);
 634         if (n_name) {
 635             name = n_name;
 636             op_fullname(fullname, name, r, n, keyvec);
 637             op   = interp->op_lib->op_code(fullname, 1);
 638         }
 639     }
 640
 641     /* still wrong, try to find an existing op */
 642     if (op < 0)
 643         op = try_find_op(interp, unit, name, r, n, keyvec, emit);
 644
 645     if (op < 0) {
 646         int ok = 0;
 647
 648         /* check mixed constants */
 649         ins = IMCC_subst_constants_umix(interp, unit, name, r, n + 1);
 650         if (ins)
 651             goto found_ins;
 652
 653         /* and finally multiple constants */
 654         ins = IMCC_subst_constants(interp, unit, name, r, n + 1, &ok);
 655
 656         if (ok) {
 657             if (ins)
 658                 goto found_ins;
 659             else
 660                 return NULL;
 661         }
 662     }
 663     else
 664         strcpy(fullname, name);
 665
 666     if (op < 0 && emit) {
 667         ins = maybe_builtin(interp, name, r, n);
 668         if (ins)
 669             return ins;
 670     }
 671
 672     if (op < 0)
 673         IMCC_fataly(interp, E_SyntaxError,
 674                     "The opcode '%s' (%s<%d>) was not found. "
 675                     "Check the type and number of the arguments",
 676                     fullname, name, n);
 677
 678     op_info = &interp->op_info_table[op];
 679     *format = '\0';
 680
 681     /* info->op_count is args + 1
 682      * build instruction format
 683      * set LV_in / out flags */
 684     if (n != op_info->op_count - 1)
 685         IMCC_fataly(interp, E_SyntaxError,
 686                 "arg count mismatch: op #%d '%s' needs %d given %d",
 687                 op, fullname, op_info->op_count-1, n);
 688
 689     /* XXX Speed up some by keep track of the end of format ourselves */
 690     for (i = 0; i < n; i++) {
 691         switch (op_info->dirs[i]) {
 692             case PARROT_ARGDIR_INOUT:
 693                 dirs |= 1 << (16 + i);
 694                 /* go on */
 695             case PARROT_ARGDIR_IN:
 696                 dirs |= 1 << i ;
 697                 break;
 698
 699             case PARROT_ARGDIR_OUT:
 700                 dirs |= 1 << (16 + i);
 701                 break;
 702
 703             default:
 704                 PARROT_ASSERT(0);
 705         };
 706
 707         if (keyvec & KEY_BIT(i)) {
 708             /* XXX Assert that len > 2 */
 709             len          = strlen(format) - 2;
 710             PARROT_ASSERT(len >= 0);
 711             format[len]  = '\0';
 712             strcat(format, "[%s], ");
 713         }
 714         else if (r[i]->set == 'K')
 715             strcat(format, "[%s], ");
 716         else
 717             strcat(format, "%s, ");
 718     }
 719
 720     len = strlen(format);
 721     if (len >= 2)
 722         len -= 2;
 723
 724     format[len] = '\0';
 725
 726     if (fmt && *fmt) {
 727         strncpy(format, fmt, sizeof (format) - 1);
 728         format[sizeof (format) - 1] = '\0';
 729     }
 730
 731 #if 1
 732     IMCC_debug(interp, DEBUG_PARSER, "%s %s\t%s\n", name, format, fullname);
 733 #endif
 734
 735     /* make the instruction */
 736     ins         = _mk_instruction(name, format, n, r, dirs);
 737     ins->keys  |= keyvec;
 738
 739     /* fill in oplib's info */
 740     ins->opnum  = op;
 741     ins->opsize = n + 1;
 742
 743     /* mark end as absolute branch */
 744     if (STREQ(name, "end") || STREQ(name, "ret")) {
 745         ins->type |= ITBRANCH | IF_goto;
 746     }
 747     else if (STREQ(name, "warningson")) {
 748         /* emit a debug seg, if this op is seen */
 749         PARROT_WARNINGS_on(interp, PARROT_WARNINGS_ALL_FLAG);
 750     }
 751     else if (STREQ(name, "yield")) {
 752         if (!IMCC_INFO(interp)->cur_unit->instructions->symregs[0])
 753             IMCC_fataly(interp, E_SyntaxError,
 754                 "Cannot yield from non-continuation\n");
 755
 756         IMCC_INFO(interp)->cur_unit->instructions->symregs[0]->pcc_sub->calls_a_sub
 757             |= 1 | ITPCCYIELD;
 758     }
 759     else if ((strncmp(name, "invoke", 6) == 0) ||
 760              (strncmp(name, "callmethod", 10) == 0)) {
 761         if (IMCC_INFO(interp)->cur_unit->type & IMC_PCCSUB)
 762             IMCC_INFO(interp)->cur_unit->instructions->symregs[0]->pcc_sub->calls_a_sub |= 1;
 763     }
 764
 765     /* set up branch flags
 766      * mark registers that are labels */
 767     for (i = 0; i < op_info->op_count - 1; i++) {
 768         if (op_info->labels[i])
 769             ins->type |= ITBRANCH | (1 << i);
 770         else {
 771             if (r[i]->type == VTADDRESS)
 772                 IMCC_fataly(interp, E_SyntaxError,
 773                         "undefined identifier '%s'\n", r[i]->name);
 774         }
 775     }
 776
 777     if (op_info->jump && op_info->jump != PARROT_JUMP_ENEXT) {
 778         ins->type |= ITBRANCH;
 779         /* TODO use opnum constants */
 780         if (STREQ(name, "branch")
 781         ||  STREQ(name, "tailcall")
 782         ||  STREQ(name, "returncc"))
 783             ins->type |= IF_goto;
 784         else if (STREQ(fullname, "jump_i")
 785              ||  STREQ(fullname, "jsr_i")
 786              ||  STREQ(fullname, "branch_i")
 787              ||  STREQ(fullname, "bsr_i"))
 788             IMCC_INFO(interp)->dont_optimize = 1;
 789     }
 790     else if (STREQ(name, "set") && n == 2) {
 791         /* set Px, Py: both PMCs have the same address */
 792         if (r[0]->set == r[1]->set && REG_NEEDS_ALLOC(r[1]))
 793             ins->type |= ITALIAS;
 794     }
 795     else if (STREQ(name, "compile"))
 796         ++IMCC_INFO(interp)->has_compile;
 797
 798   found_ins:
 799     if (emit)
 800         emitb(interp, unit, ins);
 801
 802     return ins;
 803 }
 804
 805 extern void* yy_scan_string(const char *);
 806
 807 /*
 808
 809 =item C<int do_yylex_init>
 810
 811 TODO: Needs to be documented!!!
 812
 813 =cut
 814
 815 */
 816
 817 PARROT_API
 818 int
 819 do_yylex_init(PARROT_INTERP, ARGOUT(yyscan_t* yyscanner))
 820 {
 821     const int retval = yylex_init(yyscanner);
 822
 823     /* This way we can get the interpreter via yyscanner */
 824     if (!retval)
 825         yyset_extra(interp, *yyscanner);
 826
 827     return retval;
 828 }
 829
 830 /*
 831
 832 =item C<PMC * imcc_compile>
 833
 834 Compile a pasm or imcc string
 835
 836 FIXME as we have separate constants, the old constants in ghash must be deleted.
 837
 838 =cut
 839
 840 */
 841
 842 PARROT_WARN_UNUSED_RESULT
 843 PARROT_CANNOT_RETURN_NULL
 844 PMC *
 845 imcc_compile(PARROT_INTERP, ARGIN(const char *s), int pasm_file,
 846         ARGOUT(STRING **error_message))
 847 {
 848     /* imcc always compiles to interp->code
 849      * save old cs, make new
 850      */
 851     char name[64];
 852     PackFile_ByteCode     *old_cs, *new_cs;
 853     PMC                   *sub      = NULL;
 854     struct _imc_info_t    *imc_info = NULL;
 855     struct parser_state_t *next;
 856     void                  *yyscanner;
 857     Parrot_Context        *ignored;
 858     INTVAL regs_used[4] = {3, 3, 3, 3};
 859
 860     do_yylex_init(interp, &yyscanner);
 861
 862     /* we create not yet anchored PMCs - e.g. Subs: turn off DOD */
 863     Parrot_block_GC_mark(interp);
 864
 865     if (IMCC_INFO(interp)->last_unit) {
 866         /* a reentrant compile */
 867         imc_info          = mem_allocate_zeroed_typed(imc_info_t);
 868         imc_info->ghash   = IMCC_INFO(interp)->ghash;
 869         imc_info->prev    = IMCC_INFO(interp);
 870         IMCC_INFO(interp) = imc_info;
 871     }
 872
 873     snprintf(name, sizeof (name), "EVAL_" INTVAL_FMT, ++eval_nr);
 874     new_cs = PF_create_default_segs(interp, name, 0);
 875     old_cs = Parrot_switch_to_cs(interp, new_cs, 0);
 876
 877     IMCC_INFO(interp)->cur_namespace = NULL;
 878
 879     /* spit out the sourcefile */
 880     if (Interp_debug_TEST(interp, PARROT_EVAL_DEBUG_FLAG)) {
 881         FILE * const fp = fopen(name, "w");
 882         if (fp) {
 883             fputs(s, fp);
 884             fclose(fp);
 885         }
 886     }
 887
 888     IMCC_push_parser_state(interp);
 889     next = IMCC_INFO(interp)->state->next;
 890
 891     if (imc_info)
 892         IMCC_INFO(interp)->state->next = NULL;
 893
 894     IMCC_INFO(interp)->state->pasm_file = pasm_file;
 895     IMCC_INFO(interp)->state->file      = name;
 896     IMCC_INFO(interp)->expect_pasm      = 0;
 897
 898     ignored = Parrot_push_context(interp, regs_used);
 899     UNUSED(ignored);
 900
 901     compile_string(interp, s, yyscanner);
 902
 903     Parrot_pop_context(interp);
 904
 905     /*
 906      * compile_string NULLifies frames->next, so that yywrap
 907      * doesn't try to continue compiling the previous buffer
 908      * This OTOH prevents pop_parser-state ->
 909      *
 910      * set next here and pop
 911      */
 912     IMCC_INFO(interp)->state->next = next;
 913     IMCC_pop_parser_state(interp, yyscanner);
 914
 915     if (!IMCC_INFO(interp)->error_code) {
 916         Parrot_sub *sub_data;
 917
 918         sub = pmc_new(interp, enum_class_Eval);
 919
 920         PackFile_fixup_subs(interp, PBC_MAIN, sub);
 921
 922         /* restore old byte_code, */
 923         if (old_cs)
 924             (void)Parrot_switch_to_cs(interp, old_cs, 0);
 925
 926         /*
 927          * create sub PMC
 928          *
 929          * TODO if a sub was denoted :main return that instead
 930          */
 931         sub_data             = PMC_sub(sub);
 932         sub_data->seg        = new_cs;
 933         sub_data->start_offs = 0;
 934         sub_data->end_offs   = new_cs->base.size;
 935         sub_data->name       = string_from_cstring(interp, name, 0);
 936     }
 937     else {
 938         *error_message = IMCC_INFO(interp)->error_message;
 939     }
 940
 941     if (imc_info) {
 942         IMCC_INFO(interp)           = imc_info->prev;
 943         mem_sys_free(imc_info);
 944         imc_info                    = IMCC_INFO(interp);
 945         IMCC_INFO(interp)->cur_unit = imc_info->last_unit;
 946
 947         if (IMCC_INFO(interp)->cur_namespace)
 948             free_sym(IMCC_INFO(interp)->cur_namespace);
 949
 950         IMCC_INFO(interp)->cur_namespace = imc_info->cur_namespace;
 951     }
 952     else
 953         imc_cleanup(interp, yyscanner);
 954
 955     Parrot_unblock_GC_mark(interp);
 956
 957     yylex_destroy(yyscanner);
 958
 959     return sub;
 960 }
 961
 962 /*
 963
 964 =item C<PMC * imcc_compile_pasm>
 965
 966 TODO: Needs to be documented!!!
 967
 968  * Note: This function is provided for backward compatibility. This
 969  * function can go away in future.
 970
 971 =cut
 972
 973 */
 974
 975 PARROT_WARN_UNUSED_RESULT
 976 PARROT_CANNOT_RETURN_NULL
 977 PMC *
 978 imcc_compile_pasm(PARROT_INTERP, ARGIN(const char *s))
 979 {
 980     STRING *error_message;
 981     return imcc_compile(interp, s, 1, &error_message);
 982 }
 983
 984 /*
 985
 986 =item C<PMC * imcc_compile_pir>
 987
 988 TODO: Needs to be documented!!!
 989
 990  * Note: This function is provided for backward compatibility. This
 991  * function can go away in future.
 992
 993 =cut
 994
 995 */
 996
 997 PARROT_WARN_UNUSED_RESULT
 998 PARROT_CANNOT_RETURN_NULL
 999 PMC *
1000 imcc_compile_pir(PARROT_INTERP, ARGIN(const char *s))
1001 {
1002     STRING *error_message;
1003     return imcc_compile(interp, s, 0, &error_message);
1004 }
1005
1006 /*
1007
1008 =item C<PMC * IMCC_compile_pir_s>
1009
1010 TODO: Needs to be documented!!!
1011
1012 =cut
1013
1014 */
1015
1016 PARROT_WARN_UNUSED_RESULT
1017 PARROT_CANNOT_RETURN_NULL
1018 PMC *
1019 IMCC_compile_pir_s(PARROT_INTERP, ARGIN(const char *s),
1020         ARGOUT(STRING **error_message))
1021 {
1022     return imcc_compile(interp, s, 0, error_message);
1023 }
1024
1025 /*
1026
1027 =item C<PMC * IMCC_compile_pasm_s>
1028
1029 TODO: Needs to be documented!!!
1030
1031 =cut
1032
1033 */
1034
1035 PARROT_WARN_UNUSED_RESULT
1036 PARROT_CANNOT_RETURN_NULL
1037 PMC *
1038 IMCC_compile_pasm_s(PARROT_INTERP, ARGIN(const char *s),
1039         ARGOUT(STRING **error_message))
1040 {
1041     return imcc_compile(interp, s, 1, error_message);
1042 }
1043
1044 /*
1045
1046 =item C<PMC * imcc_compile_pasm_ex>
1047
1048 TODO: Needs to be documented!!!
1049
1050 =cut
1051
1052 */
1053
1054 PARROT_WARN_UNUSED_RESULT
1055 PARROT_CANNOT_RETURN_NULL
1056 PMC *
1057 imcc_compile_pasm_ex(PARROT_INTERP, ARGIN(const char *s))
1058 {
1059     STRING *error_message;
1060
1061     PMC * const sub = imcc_compile(interp, s, 1, &error_message);
1062
1063     if (sub)
1064         return sub;
1065
1066     real_exception(interp, NULL, E_Exception, "%Ss", error_message);
1067 }
1068
1069 /*
1070
1071 =item C<PMC * imcc_compile_pir_ex>
1072
1073 TODO: Needs to be documented!!!
1074
1075 =cut
1076
1077 */
1078
1079 PARROT_WARN_UNUSED_RESULT
1080 PARROT_CANNOT_RETURN_NULL
1081 PMC *
1082 imcc_compile_pir_ex(PARROT_INTERP, ARGIN(const char *s))
1083 {
1084     STRING *error_message;
1085
1086     PMC * const sub = imcc_compile(interp, s, 0, &error_message);
1087     if (sub)
1088         return sub;
1089
1090     real_exception(interp, NULL, E_Exception, "%Ss", error_message);
1091 }
1092
1093 /*
1094
1095 =item C<static void * imcc_compile_file>
1096
1097 Compile a file by filename (can be either PASM or IMCC code)
1098
1099 =cut
1100
1101 */
1102
1103 PARROT_CANNOT_RETURN_NULL
1104 static void *
1105 imcc_compile_file(PARROT_INTERP, ARGIN(const char *fullname),
1106         ARGOUT(STRING **error_message))
1107 {
1108     PackFile_ByteCode  * const cs_save  = interp->code;
1109     PackFile_ByteCode         *cs       = NULL;
1110     struct _imc_info_t        *imc_info = NULL;
1111     const char                *ext;
1112     FILE                      *fp;
1113     STRING                    *fs;
1114     Parrot_Context            *ignored;
1115
1116     /* need at least 3 regs for compilation of constant math e.g.
1117      * add_i_ic_ic - see also IMCC_subst_constants() */
1118     INTVAL regs_used[4] = {3, 3, 3, 3};
1119
1120     if (IMCC_INFO(interp)->last_unit) {
1121         /* a reentrant compile */
1122         imc_info          = mem_allocate_zeroed_typed(imc_info_t);
1123         imc_info->prev    = IMCC_INFO(interp);
1124         imc_info->ghash   = IMCC_INFO(interp)->ghash;
1125         IMCC_INFO(interp) = imc_info;
1126     }
1127
1128     fs = string_make(interp, fullname, strlen(fullname), NULL, 0);
1129
1130     if (Parrot_stat_info_intval(interp, fs, STAT_ISDIR))
1131         real_exception(interp, NULL, E_IOError,
1132                 "imcc_compile_file: '%s' is a directory\n", fullname);
1133
1134     fp = fopen(fullname, "r");
1135     if (!fp)
1136         IMCC_fatal(interp, E_IOError,
1137                 "imcc_compile_file: couldn't open '%s'\n", fullname);
1138
1139 #if IMC_TRACE
1140     fprintf(stderr, "parser_util.c: imcc_compile_file '%s'\n", fullname);
1141 #endif
1142
1143     IMCC_INFO(interp)->cur_namespace = NULL;
1144     interp->code                     = NULL;
1145
1146     IMCC_push_parser_state(interp);
1147     IMCC_INFO(interp)->state->file = fullname;
1148     ext                            = strrchr(fullname, '.');
1149     IMCC_INFO(interp)->line        = 1;
1150
1151     /*
1152      * the string_compare() called from pmc_type() triggers DOD
1153      * which can destroy packfiles under construction
1154      */
1155     Parrot_block_GC_mark(interp);
1156     ignored = Parrot_push_context(interp, regs_used);
1157     UNUSED(ignored);
1158
1159     if (ext && STREQ(ext, ".pasm")) {
1160         void *yyscanner;
1161         do_yylex_init(interp, &yyscanner);
1162
1163         IMCC_INFO(interp)->state->pasm_file = 1;
1164         /* see imcc.l */
1165         compile_file(interp, fp, yyscanner);
1166
1167         yylex_destroy(yyscanner);
1168     }
1169     else {
1170         void *yyscanner;
1171         do_yylex_init(interp, &yyscanner);
1172
1173         IMCC_INFO(interp)->state->pasm_file = 0;
1174         compile_file(interp, fp, yyscanner);
1175
1176         yylex_destroy(yyscanner);
1177     }
1178
1179     Parrot_unblock_GC_mark(interp);
1180     Parrot_pop_context(interp);
1181
1182     imc_cleanup(interp, NULL);
1183     fclose(fp);
1184
1185     if (!IMCC_INFO(interp)->error_code)
1186         cs = interp->code;
1187     else
1188         *error_message = IMCC_INFO(interp)->error_message;
1189
1190     if (cs_save)
1191         (void)Parrot_switch_to_cs(interp, cs_save, 0);
1192
1193     if (imc_info) {
1194         IMCC_INFO(interp) = imc_info->prev;
1195         mem_sys_free(imc_info);
1196     }
1197
1198     return cs;
1199 }
1200
1201 /*
1202
1203 =item C<void * IMCC_compile_file>
1204
1205 TODO: Needs to be documented!!!
1206
1207  * Note: This function is provided for backward compatibility. This
1208  * function can go away in future.
1209
1210 =cut
1211
1212 */
1213
1214 PARROT_CANNOT_RETURN_NULL
1215 void *
1216 IMCC_compile_file(PARROT_INTERP, ARGIN(const char *s))
1217 {
1218     STRING *error_message;
1219     return imcc_compile_file(interp, s, &error_message);
1220 }
1221
1222 /*
1223
1224 =item C<void * IMCC_compile_file_s>
1225
1226 TODO: Needs to be documented!!!
1227
1228 =cut
1229
1230 */
1231
1232 PARROT_CANNOT_RETURN_NULL
1233 void *
1234 IMCC_compile_file_s(PARROT_INTERP, ARGIN(const char *s),
1235         ARGOUT(STRING **error_message))
1236 {
1237     return imcc_compile_file(interp, s, error_message);
1238 }
1239
1240 /*
1241
1242 =item C<void register_compilers>
1243
1244 Register additional compilers with the interpreter
1245
1246 =cut
1247
1248 */
1249
1250 void
1251 register_compilers(PARROT_INTERP)
1252 {
1253     Parrot_compreg(interp, const_string(interp, "PASM"), imcc_compile_pasm_ex);
1254     Parrot_compreg(interp, const_string(interp, "PIR"),  imcc_compile_pir_ex);
1255
1256     /* It looks like this isn't used anywhere yet */
1257     /* TODO: return a Eval PMC, instead of a packfile */
1258     /* Parrot_compreg(interp,
1259                       const_string(interp, "FILE"),
1260                       imcc_compile_file ); */
1261 }
1262
1263 /*
1264
1265 =item C<static int change_op>
1266
1267 TODO: Needs to be documented!!!
1268
1269 =cut
1270
1271 */
1272
1273 PARROT_WARN_UNUSED_RESULT
1274 static int
1275 change_op(PARROT_INTERP, ARGMOD(IMC_Unit *unit), ARGMOD(SymReg **r), int num, int emit)
1276 {
1277     int changed = 0;
1278
1279     if (r[num]->type & (VTCONST|VT_CONSTP)) {
1280         /* make a number const */
1281         const SymReg *c = r[num];
1282
1283         if (c->type & VT_CONSTP)
1284             c = c->reg;
1285
1286         r[num]  = mk_const(interp, c->name, 'N');
1287         changed = 1;
1288     }
1289     else if (emit) {
1290         /* emit
1291         *   set $N0, Iy
1292         *   op  Nx, $N0
1293         * or
1294         *   op  Nx, ..., $N0
1295         */
1296         SymReg *rr[2];
1297
1298         rr[0]   = mk_temp_reg(interp, 'N');
1299         rr[1]   = r[num];
1300
1301         INS(interp, unit, "set", NULL, rr, 2, 0, 1);
1302
1303         r[num]  = rr[0];
1304         changed = 1;
1305
1306         /* need to allocate the temp - run reg_alloc */
1307         IMCC_INFO(interp)->optimizer_level |= OPT_PASM;
1308     }
1309
1310     return changed;
1311 }
1312
1313 /*
1314
1315 =item C<int try_find_op>
1316
1317 Try to find valid op doing the same operation e.g.
1318
1319    add_n_i_n  => add_n_n_i
1320    div_n_ic_n => div_n_nc_n
1321    div_n_i_n  => set_n_i ; div_n_n_n
1322    ge_n_ic_ic => ge_n_nc_ic
1323    acos_n_i   => acos_n_n
1324
1325 =cut
1326
1327 */
1328
1329 PARROT_WARN_UNUSED_RESULT
1330 int
1331 try_find_op(PARROT_INTERP, ARGMOD(IMC_Unit *unit), ARGIN(const char *name),
1332         ARGMOD(SymReg **r), int n, int keyvec, int emit)
1333 {
1334     char fullname[64];
1335     int changed = 0;
1336     /*
1337      * eq_str, eq_num => eq
1338      * ...
1339      */
1340     if (n == 3 && r[2]->type == VTADDRESS) {
1341         if (STREQ(name, "eq_str") || STREQ(name, "eq_num")) {
1342             name    = "eq";
1343             changed = 1;
1344         }
1345         else if (STREQ(name, "ne_str") || STREQ(name, "ne_num")) {
1346             name    = "ne";
1347             changed = 1;
1348         }
1349         else if (STREQ(name, "le_str") || STREQ(name, "le_num")) {
1350             name    = "le";
1351             changed = 1;
1352         }
1353         else if (STREQ(name, "lt_str") || STREQ(name, "lt_num")) {
1354             name    = "lt";
1355             changed = 1;
1356         }
1357         else if (STREQ(name, "ge_str") || STREQ(name, "ge_num")) {
1358             name    = "ge";
1359             changed = 1;
1360         }
1361         else if (STREQ(name, "gt_str") || STREQ(name, "gt_num")) {
1362             name    = "gt";
1363             changed = 1;
1364         }
1365     }
1366     else if (n == 3 && (STREQ(name, "cmp_str") || STREQ(name, "cmp_num"))) {
1367         name     = "cmp";
1368         changed = 1;
1369     }
1370     if (n == 3 && r[0]->set == 'N') {
1371         if (r[1]->set == 'I') {
1372             const SymReg * const r1 = r[1];
1373             changed |= change_op(interp, unit, r, 1, emit);
1374
1375             /* op Nx, Iy, Iy: reuse generated temp Nz */
1376             if (r[2]->set == 'I' && r[2]->type != VTADDRESS && r[2] == r1)
1377                 r[2] = r[1];
1378         }
1379
1380         if (r[2]->set == 'I' && r[2]->type != VTADDRESS)
1381             changed |= change_op(interp, unit, r, 2, emit);
1382     }
1383
1384     /* handle eq_i_n_ic */
1385     else if (n == 3 && r[1]->set == 'N' && r[0]->set == 'I' &&
1386             r[2]->type == VTADDRESS) {
1387         changed |= change_op(interp, unit, r, 0, emit);
1388     }
1389     else if (n == 2 && r[0]->set == 'N' && r[1]->set == 'I') {
1390         /*
1391          * transcendentals  e.g. acos N, I
1392          */
1393         if (!STREQ(name, "fact"))
1394             changed = change_op(interp, unit, r, 1, emit);
1395     }
1396
1397     if (changed) {
1398         op_fullname(fullname, name, r, n, keyvec);
1399         return interp->op_lib->op_code(fullname, 1);
1400     }
1401
1402     return -1;
1403 }
1404
1405 /*
1406
1407 =item C<static const char * try_rev_cmp>
1408
1409 TODO: Needs to be documented!!!
1410
1411 =cut
1412
1413 */
1414
1415 PARROT_WARN_UNUSED_RESULT
1416 PARROT_CAN_RETURN_NULL
1417 static const char *
1418 try_rev_cmp(ARGIN(const char *name), ARGMOD(SymReg **r))
1419 {
1420     static struct br_pairs {
1421         ARGIN(const char * const op);
1422         ARGIN(const char * const nop);
1423         const int to_swap;
1424     } br_pairs[] = {
1425         { "gt",   "lt",   0 },
1426         { "ge",   "le",   0 },
1427         { "isgt", "islt", 1 },
1428         { "isge", "isle", 1 },
1429     };
1430
1431     unsigned int i;
1432
1433     for (i = 0; i < N_ELEMENTS(br_pairs); i++) {
1434         if (STREQ(name, br_pairs[i].op)) {
1435             const int to_swap = br_pairs[i].to_swap;
1436             SymReg *t;
1437
1438             if (r[to_swap + 1]->set == 'P')
1439                 return NULL;
1440
1441             t              = r[to_swap];
1442             r[to_swap]     = r[to_swap + 1];
1443             r[to_swap + 1] = t;
1444
1445             return br_pairs[i].nop;
1446         }
1447     }
1448
1449     return NULL;
1450 }
1451
1452 /*
1453
1454 =item C<Instruction * multi_keyed>
1455
1456 TODO: Needs to be documented!!!
1457
1458 =cut
1459
1460 */
1461
1462 PARROT_CAN_RETURN_NULL
1463 Instruction *
1464 multi_keyed(PARROT_INTERP, ARGMOD(IMC_Unit *unit), ARGIN(const char *name),
1465             ARGIN(SymReg **r), int nr, int keyvec, int emit)
1466 {
1467     int i, keyf, n;
1468     SymReg      *preg[3];    /* px, py, pz */
1469     SymReg      *nreg[3];
1470     Instruction *ins       = 0;
1471     Instruction *unused_ins = 0;
1472     static      int p       = 0;
1473
1474     /* count keys in keyvec */
1475     int kv = keyvec;
1476
1477     for (i = keyf = 0; i < nr; i++, kv >>= 1)
1478         if (kv & 1)
1479             keyf++;
1480
1481     if (keyf <= 1)
1482         return NULL;
1483
1484     /* XXX what to do, if we don't emit instruction? */
1485     PARROT_ASSERT(emit);
1486     UNUSED(emit);
1487
1488     /* OP  _p_k    _p_k_p_k =>
1489      * set      py, p_k
1490      * set      pz,     p_k
1491      * new px, .Undef
1492      * OP  px, py, pz
1493      * set _p_k_px
1494      */
1495
1496     kv = keyvec;
1497     for (i = n = 0; i < nr; i++, kv >>= 1, n++) {
1498         char buf[16];
1499
1500         if (kv & 1)
1501             IMCC_fataly(interp, E_SyntaxError, "illegal key operand\n");
1502
1503         /* make a new P symbol */
1504         do {
1505             snprintf(buf, sizeof (buf), "$P%d", ++p);
1506         } while (get_sym(interp, buf));
1507
1508         preg[n] = mk_symreg(interp, buf, 'P');
1509         kv    >>= 1;
1510
1511         if (kv & 1) {
1512             /* we have a keyed operand */
1513             if (r[i]->set != 'P')
1514                 IMCC_fataly(interp, E_SyntaxError, "not an aggregate\n");
1515
1516             /* don't emit LHS yet */
1517             if (i == 0) {
1518                 nreg[0] = r[i];
1519                 nreg[1] = r[i+1];
1520                 nreg[2] = preg[n];
1521
1522                 /* set p_k px */
1523                 ins     = INS(interp, unit, "set", 0, nreg, 3, KEY_BIT(1), 0);
1524             }
1525             else {
1526                 nreg[0] = preg[n];
1527                 nreg[1] = r[i];
1528                 nreg[2] = r[i+1];
1529
1530                 /* set py|z p_k */
1531                 INS(interp, unit, "set", 0, nreg, 3, KEY_BIT(2), 1);
1532             }
1533
1534             i++;
1535         }
1536         /* non keyed */
1537         else {
1538             if (i == 0) {
1539                 nreg[0] = r[i];
1540                 nreg[1] = preg[n];
1541
1542                 /* set n, px */
1543                 ins     = INS(interp, unit, "set", 0, nreg, 2, 0, 0);
1544             }
1545             else {
1546                 nreg[0] = preg[n];
1547                 nreg[1] = r[i];
1548
1549                 /* set px, n */
1550                 INS(interp, unit, "set", 0, nreg, 2, 0, 1);
1551             }
1552         }
1553     }
1554     /* make a new undef */
1555     unused_ins = iNEW(interp, unit, preg[0], str_dup("Undef"), NULL, 1);
1556     UNUSED(unused_ins);
1557
1558     /* emit the operand */
1559     INS(interp, unit, name, 0, preg, 3, 0, 1);
1560
1561     /* emit the LHS op */
1562     emitb(interp, unit, ins);
1563
1564     return ins;
1565 }
1566
1567 /*
1568
1569 =item C<int imcc_fprintf>
1570
1571 TODO: Needs to be documented!!!
1572
1573 =cut
1574
1575 */
1576
1577 int
1578 imcc_fprintf(PARROT_INTERP, ARGMOD(FILE *fd), ARGIN(const char *fmt), ...)
1579 {
1580     va_list ap;
1581     int len;
1582
1583     va_start(ap, fmt);
1584     len = imcc_vfprintf(interp, fd, fmt, ap);
1585     va_end(ap);
1586
1587     return len;
1588 }
1589
1590 /*
1591
1592 =item C<int imcc_vfprintf>
1593
1594 TODO: Needs to be documented!!!
1595
1596 =cut
1597
1598 */
1599
1600 int
1601 imcc_vfprintf(PARROT_INTERP, ARGMOD(FILE *fd), ARGIN(const char *format), va_list ap)
1602 {
1603     int len = 0;
1604     const char *fmt = format;
1605     char buf[128];
1606
1607     for (;;) {
1608         const char *cp = fmt;
1609         int         ch = 0;
1610         int         n;
1611
1612         for (n = 0; (ch = *fmt) && ch != '%'; fmt++, n++);
1613
1614         /* print prev string */
1615         if (n) {
1616             fwrite(cp, 1, n, fd);
1617             len += n;
1618             continue;
1619         }
1620
1621         /* finished? */
1622         if (!ch)
1623             break;
1624
1625         /* ok, we have a format spec */
1626         /* % */
1627         ch = *++fmt;
1628
1629         /* print it */
1630         if (ch == '%') {
1631             fwrite(fmt, 1, 1, fd);
1632             len += 1;
1633             ++fmt;
1634             continue;
1635         }
1636
1637         /* look for end of format spec */
1638         for (; ch && strchr("diouxXeEfFgGcspI", ch) == NULL; ch = *++fmt)
1639             ;
1640
1641         if (!ch) {
1642             /* no fatal here, else we get recursion */
1643             fprintf(stderr, "illegal format at %s\n", cp);
1644             exit(EXIT_FAILURE);
1645         }
1646
1647         /* ok, we have a valid format char */
1648         ++fmt;
1649         switch (ch) {
1650             case 'd':
1651             case 'i':
1652             case 'o':
1653             case 'u':
1654             case 'x':
1655             case 'X':
1656             case 'p':
1657             case 'c':
1658                 {
1659                 const int _int = va_arg(ap, int);
1660                 memcpy(buf, cp, n = (fmt - cp));
1661                 buf[n] = '\0';
1662                 len += fprintf(fd, buf, _int);
1663                 }
1664                 break;
1665             case 'e':
1666             case 'E':
1667             case 'f':
1668             case 'F':
1669             case 'g':
1670             case 'G':
1671                 {
1672                 const double _double = va_arg(ap, double);
1673                 memcpy(buf, cp, n = (fmt - cp));
1674                 buf[n] = '\0';
1675                 len += fprintf(fd, buf, _double);
1676                 }
1677                 break;
1678             case 's':
1679                 {
1680                 const char * const _string = va_arg(ap, char *);
1681                 memcpy(buf, cp, n = (fmt - cp));
1682                 PARROT_ASSERT(n<128);
1683                 buf[n] = '\0';
1684                 len += fprintf(fd, buf, _string);
1685                 }
1686                 break;
1687             /* this is the reason for the whole mess */
1688             case 'I':
1689                 {
1690                 Instruction * const _ins = va_arg(ap, Instruction *);
1691                 len += fprintf(fd, "%s ", _ins->opname);
1692                 len += ins_print(interp, fd, _ins);
1693                 }
1694                 break;
1695             default:
1696                 break;
1697         }
1698     }
1699
1700     return len;
1701 }
1702
1703 /* Utility functions */
1704
1705 /*
1706
1707 =item C<void imcc_init>
1708
1709 TODO: Needs to be documented!!!
1710
1711 =cut
1712
1713 */
1714
1715 PARROT_API
1716 void
1717 imcc_init(PARROT_INTERP)
1718 {
1719     PARROT_ASSERT(IMCC_INFO(interp) == NULL);
1720
1721     IMCC_INFO(interp) = mem_allocate_zeroed_typed(imc_info_t);
1722     /* register PASM and PIR compilers to parrot core */
1723     register_compilers(interp);
1724 }
1725
1726 /*
1727
1728 =item C<void imcc_destroy>
1729
1730 TODO: Needs to be documented!!!
1731
1732 =cut
1733
1734 */
1735
1736 PARROT_API
1737 void
1738 imcc_destroy(PARROT_INTERP)
1739 {
1740     Hash * const macros = IMCC_INFO(interp)->macros;
1741
1742     if (macros)
1743         parrot_chash_destroy(interp, macros);
1744
1745     mem_sys_free(IMCC_INFO(interp));
1746     IMCC_INFO(interp) = NULL;
1747 }
1748
1749 /*
1750
1751 =back
1752
1753 =cut
1754
1755 */
1756
1757
1758 /*
1759  * Local variables:
1760  *   c-file-style: "parrot"
1761  * End:
1762  * vim: expandtab shiftwidth=4:
1763  */