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