// This is a new portable back-end for Imp77, which uses GCC to create // the object files from the imp source code. It does this by outputing // C rather than assembly code from the ICODE. Note that this does not // make it an imp to C translator - the C is not human-readable, nor is // it maintainable. It is merely a slightly higher level type of // intermediate code. However this will ensure that Imp code can be run // on any system which has a GCC C compiler. // Unfortunately, GCC is the required back-end compiler, because it has // a non-standard extension that supports textually nested procedure // calls, which none of the other portable C compilers do. So for now, // clang et al are not an option. Although in principle the nested // procedures can be exbedded and the code flattened, this is a major // implementation project to handle, and the resulting C code is not // going to be as efficient as code compiled for a language that uses // a display to access enclosing scopes. C's mechanism for nested // procedure handling is made complicated by the need to support // procedure variables, which Imp (and languages like Pascal, Algol, // etc do not need). // Note there is no need to perform optimisations at the AST level // because GCC will do them for us. Similarly things like folding // const expressions or removing superfluous parentheses (although // I did make an attempt at just that, with the --tidy option!) // TO DO: (there are cuurently >= 83 statements marked as "TO DO" // ( fgrep "TO DO" ast.[ch] i2c.[ch] icode.[ch] stringpool.[ch]|wc -l ) // * Default %switch statements (SW(*):) are broken! // * After sorting out a big problem with user labels, I have one // very minor problem remaining. C does not allow a __label__ // declaration to come after code in a block. However there // will be at least one occurence of this in most programs // because I'm inserting _imp_initialise(argc, argv) at // the head of main(). Although a workaround for this is // possible (by not calling the main program main() and // invoking _imp_main() from perms.c), it's ugly and has // its own problems. And this is all assuming that the // programmer hasn't also inserted some of their own code // before a %label declaration, which I think (pending a test) // is OK to do in Imp77... Unfortunately barring some clever // trick that I haven't yet thought of, fixing this minor // problem is going to be nasty, requiring a major change // in the way that the C code is stored and output. // * DAMNIT! Previous problem with user labels was only reduced, // not fixed. See test-junk/allimpc1-77.imp for more cases // where label ids are erroneously re-used. And note that // in that code, there aren't even any %label declarations, // so the problem is more basic and should never have happened :-( // // It *is* looking like I'll need to keep a scope stack of // labels created in each block and reset their user_label_id[] // lookup table entry to 0 on the end of the scope. Whether // I do this again ad-hoc as I've done once already, or instead // break out the big guns and use my scope module that I created // for imptoc where I can invoke callbacks etc on the end of a // scope block, I've yet to decide. The former is ugly, the // latter is a huge amount of extra work if this is the only // thing it's going to be used for. // * When doing ACCESS on something that was the result of a SELECT // (i.e. an array that is a record field) such as this: // @ PUSH #V_00ae (P) OPD_STACK = 4 // n SELECT field #1 OPD_STACK = 4 // @ PUSH #V_00cf (INN) OPD_STACK = 5 // a ACCESS // // (this example was p_tab(inn) in soap80-a.imp) the ACCESS code messes up. // * still some small issues around automatic dereferencing etc. // See gcc12 -O -ftrivial-auto-var-init=pattern -Wa,-adhln -g -o test/draft4 test/draft4.c perms.c > test/draft4.lis // for remaining examples. Most of these ones look like they happen // when assigning to a %name or in an index or parameter to a // top-level RHS or at the top level of a comparison. // (i.e. one of the too-many cases which skips the checks done for BINOPs etc) // * name variable not being automatically dereferenced. This may be the same // problem as the one detected above where the top-level expression in an // assignment or a parameter pass is not handled the same as in a BINOP etc: // 4151 %ROUTINE POP(%SHORTINTEGERNAME CELL,%INTEGERNAME S1,S2) // void POP( short *CELL, int *S1, int *S2 ) // { // __label__ _imp_endofblock; // 4152 %INTEGER P,Q // int P; // int Q; // 4153 Q=ADDR(ASLIST(CELL)) // Q = _imp_ADDR(&ASLIST[CELL]); // ^^^^ // | // Should be *CELL // (note: adding REQUIRES_AUTO_DEREF(tuple) macro to ast.h to help with this.) // * Cache the array bounds in the dopevector at the point of // declaration of a dynamic array in case a variable used in the // bounds declaration is changed before an array member is accessed. // * Handle Imps row or column major layout of array data. I forget which // is which but I'm fairly sure Imp and C use opposite conventions. // * Procedure parameters: // 2 %routine do(%integerfn fn(%integer p,q,r)) // O LINE 2 OPD_STACK = 0 file=test/testprocparam.imp // $ DEF V_006f ID=DO a=7 b=0 c=0 // { START ( // $ DEF V_0070 ID=FN a=24 b=1 c=16 // } FINISH ) // $ DEF V_0070 ID=FN a=24 b=1 c=24 // { START ( // $ DEF V_0071 ID=P a=17 b=1 c=0 // $ DEF V_0072 ID=Q a=17 b=1 c=0 // $ DEF V_0073 ID=R a=17 b=1 c=0 // } FINISH ) // * Type casting for %map RECORD(). (Don't think imp77 supports %map ARRAY(addr, format)? // - instead of rec = *RECORD(addr) we should have rec = *(rec fm *)RECORD(addr) // * Variant record formats not yet properly supported. The extra fields are present so the // sources do compile but the record fields are not overlaid over each other to save space // and any code that relies on data being shared between two variables will fail. // ################################################################################################### /* This phase converts the ICODE into a more modern AST. Each AST tuple also holds the type information of its object, so when an expression is constructed, the type information percolates upwards, being used for type conversion and widening as it goes. The info could also be used for catching type errors but that won't be necessary here since the Imp front end has already made those checks. The type and form information is used primarily for handling automatic dereferencing of pointers and pointer functions - %name and %map in Imp terms. Note that the AST_* types rather grew on the fly as each statement type was gradually refined. It's not the carefully designed AST that it should be, but it seems to be sufficient. It does rely somewhat on the output of pass1 being in a particular format - some of the translation tricks would not work in the proper "imp to c" high-level translator project. */ #define _POSIX_C_SOURCE 200809L #define _XOPEN_SOURCE 500 #include #include #include #include #include #include #include // wasn't worth a header file for one line...: extern int pass1(char *source, char *perm, char *icode, char *list); #include "i2c.h" #include "ast.h" #include "icode.h" extern void COPY_FIXED_FIELDS_to_from(ASTIDX new, ASTIDX old); // move to ast.h int PARM_C_IO = 0; // output standard C I/O calls like printf rather than use IMP I/O names like PRINTSTRING int PARM_IMP_SOURCE_LINENOS = 0; // issue #line directives for better gdb error reporting int PARM_LINK = 1; int PARM_VERBOSE = 0; int PARM_TIDY = 1; // --tidy will try to reduce the number of parentheses in expressions (now reliable enough to leave turned on) int PARM_STDOUT = 0; int PARM_DEBUG = 0; int PARM_OPT = 0; int opt_info = 0; // A couple of hacky globals to get me out of a tight spot... static char *last_alias = NULL; static ASTIDX last_declare_for_init = -1; static ASTIDX last_declare_for_attaching_fields_or_parameters = -1; static int last_was_doublesided = 0; static int IN_START_FINISH_GROUP = 0; // Hack for %switch left,middle,right(low:high) ... static ASTIDX last_bounds_pair = -1; extern short get_next_label_id(void); extern int NEXT_AST; //#define MAX_NESTED_BLOCKS 1024 // More than Imp ever allowed... int /*StringpoolIDX*/ blockname[MAX_NESTED_BLOCKS]; int blocklevel = 0; int want_extra_info = FALSE; int suppress_perms = TRUE; int in_perms = TRUE; int suppress_icode = TRUE; FILE *icode_file; FILE *output_file; FILE *source_file; #define MAX_LINE 1024 char line[MAX_LINE + 1]; // Diagnostic check to remind me of unimplemented calls. static int unimplemented[256]; // (Not really unimplemented, more a case of not having been // seen in a test, so potentially causing a stack imbalance) void FLUSH_ICODE_STACK(void) { // By the time this is called, every item on the stack is a top-level source statement, and // the entire stack, if popped and executed, would generate code in reverse order! // However because each item on the stack is a complete statement, it's actually safe for // us to cycle through the stack and execute each AST item in sequential order! if (suppress_perms && in_perms) { // don't. } else { fprintf(output_file, "%s", commentbuff); } cbp = commentbuff; for (int sp = 0; sp < next_opd; sp++) { ASTIDX code = opdstack[sp]; if (OP(code) != AST_IMP_LINE) fprintf(output_file, "%s", hashline); // #line set up by LINE ('O') opcode. codegen(code); } next_opd = 0; // empty the stack! } int sysnprintf(char *out, int maxlen, char *command) { FILE *pipe; pipe = popen(command, "r"); for (int i = 0; i < maxlen - 1; i++) { int c = fgetc(pipe); if (c == EOF) { out[i] = '\0'; pclose(pipe); return i; } out[i] = c; } return 0; } int main(int argc, char **argv) { //char *p1, *p2; int opcode, d; char list_filename[256], icode_filename[256], output_filename[256], source_filename[256], object_filename[512], base_filename[256], perm_filename[256]; (void)strtopool(" BUG /* casused by a pooltostr(0) call? */ "); char *PROGNAME = argv[0]; object_filename[0] = '\0'; sprintf(perm_filename, "perms.inc"); while (argc >= 2 && *argv[1] == '-') { // options must come before the filename // TO DO: -h/--help if (argc >= 2 && (strcmp(argv[1], "-h") == 0 || strcmp(argv[1], "--help") == 0)) { fprintf(stderr, "syntax: i2c [options] file.imp\n"); fprintf(stderr, "\n"); fprintf(stderr, "Options:\n"); fprintf(stderr, " --verbose/-v Show AST tuple generation\n"); fprintf(stderr, " --debug/-d Debug icode stack usage\n"); fprintf(stderr, " -O Optimise run-time performance. Default is full checks\n"); fprintf(stderr, " --icode Decode the intermediate code to the C file as comments\n"); fprintf(stderr, " -c Compile to .o file only. Don't link.\n"); fprintf(stderr, " --stdout Output the C code to stdout instead of a .c file\n"); fprintf(stderr, " -o binary[.o] When generating a binary use this filename\n"); fprintf(stderr, " --tidy Output C code with fewer redundant brackets\n"); fprintf(stderr, " --perms perm.inc Use alternative perms.inc file\n"); fprintf(stderr, " --no-perms Use the empty \"noperms.inc\" file.\n"); fprintf(stderr, " --show-perms Print the translated C of the perms.inc file\n"); fprintf(stderr, " --[no-]gdb Generate #line statements in the C\n"); fprintf(stderr, " --[no-]check Add runtime checking. Small runtime overhead.\n"); fprintf(stderr, " (Code runs under valgrind when checks are enabled.)\n"); fprintf(stderr, "\n"); exit(0); } else if (argc >= 2 && (strcmp(argv[1], "-v") == 0 || strcmp(argv[1], "--verbose") == 0)) { PARM_VERBOSE = TRUE; argc -= 1; argv += 1; } else if (argc >= 2 && (strcmp(argv[1], "-d") == 0 || strcmp(argv[1], "--debug") == 0)) { debug_ast = PARM_DEBUG = TRUE; argc -= 1; argv += 1; } else if (argc >= 2 && strcmp(argv[1], "--info") == 0) { opt_info = TRUE; argc -= 1; argv += 1; } else if (argc >= 2 && strcmp(argv[1], "-c") == 0) { PARM_LINK = FALSE; argc -= 1; argv += 1; } else if (argc >= 2 && strcmp(argv[1], "-O") == 0) { PARM_OPT = TRUE; PARM_IMP_SOURCE_LINENOS = FALSE; argc -= 1; argv += 1; } else if (argc >= 3 && strcmp(argv[1], "--perms") == 0) { if (argv[2] == NULL || argv[2][0] == '-') { fprintf(stderr, "i2c: --perms option requires a filename parameter\n"); exit(1); } strcpy(perm_filename, argv[2]); argc -= 2; argv += 2; } else if (argc >= 3 && strcmp(argv[1], "-o") == 0) { if (argv[2] == NULL || argv[2][0] == '-') { fprintf(stderr, "i2c: -o option requires a filename parameter\n"); exit(1); } strcpy(object_filename, argv[2]); argc -= 2; argv += 2; } else if (argc >= 2 && (strcmp(argv[1], "--no-perms") == 0 || strcmp(argv[1], "--noperms") == 0)) { strcpy(perm_filename, "noperms.inc"); argc -= 1; argv += 1; } else if (argc >= 2 && strcmp(argv[1], "--stdout") == 0) { PARM_STDOUT = TRUE; PARM_LINK = FALSE; argc -= 1; argv += 1; } else if (argc >= 2 && strcmp(argv[1], "--line") == 0) { PARM_IMP_SOURCE_LINENOS = TRUE; argc -= 1; argv += 1; } else if (argc >= 2 && strcmp(argv[1], "--no-line") == 0) { PARM_IMP_SOURCE_LINENOS = FALSE; argc -= 1; argv += 1; } else if (argc >= 2 && strcmp(argv[1], "--check") == 0) { // enable runtime checks with overhead, eg unassigned checks // and use valgrind etc at runtime. PARM_OPT = FALSE; argc -= 1; argv += 1; } else if (argc >= 2 && strcmp(argv[1], "--no-check") == 0) { PARM_OPT = TRUE; argc -= 1; argv += 1; } else if (argc >= 2 && strcmp(argv[1], "--icode") == 0) { suppress_icode = FALSE; argc -= 1; argv += 1; } else if (argc >= 2 && strcmp(argv[1], "--tidy") == 0) { PARM_TIDY = TRUE; argc -= 1; argv += 1; } else if (argc >= 2 && strcmp(argv[1], "--no-tidy") == 0) { PARM_TIDY = FALSE; argc -= 1; argv += 1; } else if (argc >= 2 && strcmp(argv[1], "--show-perms") == 0) { suppress_perms = FALSE; argc -= 1; argv += 1; } else if (argc >= 2 && argv[1][0] == '-') { fprintf(stderr, "i2c: unrecognised option '%s'\n", argv[1]); exit(EXIT_FAILURE); } } if (argc != 2) { fprintf(stderr, "syntax: i2c [options] file.imp\n"); exit(1); } strcpy(base_filename, argv[1]); if (strcmp(&base_filename[strlen(base_filename) - 4], ".imp") == 0) { base_filename[strlen(base_filename) - 4] = '\0'; } sprintf(source_filename, "%.250s.imp", base_filename); if (PARM_STDOUT) { sprintf(output_filename, "/dev/stdout"); } else { sprintf(output_filename, "%.250s.c", base_filename); } sprintf(icode_filename, "%.250s.icd", base_filename); sprintf(list_filename, "%.250s.lis", base_filename); int rc = pass1(source_filename, perm_filename, icode_filename, list_filename); (void)rc; output_file = fopen(output_filename, "w"); if (output_file == NULL) { fprintf(stderr, "i2c: cannot create '%s' - %s\n", output_filename, strerror(errno)); exit(2); } source_file = fopen(source_filename, "r"); if (source_file == NULL) { fprintf(stderr, "i2c: Cannot open \"%s\" - %s\n", source_filename, strerror(errno)); exit(3); } else { dump_comment("%s\n\n\n", "Edinburgh IMP77 Compiler - Version 8.4\n"); } icode_file = fopen(icode_filename, "rb"); if (icode_file == NULL) { fprintf(stderr, "i2c: cannot open '%s' - %s\n", icode_filename, strerror(errno)); exit(4); } ASTIDX NULL_TUPLE = mktuple(AST_ASTCODE_WAS_ZERO); // for catching unassigned variables... short NULL_LABEL = get_next_label_id(); blockname[0] = strtopool("__LEVEL_0__"); dump_code("#ifdef USE_PERMS_INC\n"); for (;;) { opcode = get_icode(icode_file); if (opcode == EOF) break; switch (opcode) { case '\n': break; // There's a \n at the end of the icode file... //case '\r': break; // Shouldn't get this but there might be one in a Windows port? case ':': /* Define Compiler Label(Tag); */ /* LOCATE label */ { // NOTE: *USER* labels do *not* come through this path - they are placed using 'L' (Define User Label(Tag)) int lab, labtag = getshort(); //lab = (label_id[labtag] != 0 ? setforwardlab_from_tag(labtag) : setbackwardlab_from_tag(labtag)); if (label_id[labtag] == 0) { lab = label_id[labtag] = get_next_label_id(); dump_comment("%c %s (labtag=%04x, lab=L_%04x)\n", opcode, icode_name[opcode], labtag, lab); PUSH(mktuple(AST_DEFLAB, mktuple(AST_LABEL, lab, 'L', labtag))); // start of cycle label_id[labtag + 1] = get_next_label_id(); label_id[labtag + 2] = get_next_label_id(); } else { lab = label_id[labtag]; PUSH(mktuple(AST_DEFLAB, mktuple(AST_LABEL, lab, 'L', labtag))); // continue or exit label of cycle dump_comment("%c %s (labtag=%04x, lab=L_%04x)\n", opcode, icode_name[opcode], labtag, lab); label_id[labtag] = 0; } // These will be freed up on the REPEAT opcode. } break; case 'B': /* Jump Backward(Tag); */ /* REPEAT label */ { int labtag = getshort(); int forlab = label_id[labtag]; dump_comment("%c %s (labtag=%04x, lab=L_%04x)\n", opcode, icode_name[opcode], labtag, forlab); PUSH(mktuple(AST_GOTO, mktuple(AST_LABEL, forlab, 'L', labtag))); // After a REPEAT, that label tag will not be used again to represent // that same label: label_id[labtag] = 0; // free it up for reuse. } break; case 'f': /* Compile For(Tag); */ /* FOR label (label was missing from thesis description) */ { /* The descriptors on the top of the stack are:- +-----+ | | INITIAL VALUE | [F] | | | |-----| | | FINAL VALUE | [L] | | | |-----| | | INCREMENT | [I] | | | |-----| | | CONTROL VARIABLE | [C] | | | |-----| | | . . *** NOTE *** TO DO: Final should be evaluated once and saved in a temporary which is to be used instead, if final can potentially have side-effects, i.e. the terminating value is the value of final on entry to the for loop - it is not to be recalculated on every loop. Classic example of the problem: %CYCLE NP=1,1,NP Also we might want to detect changes to the control variable. There should be a check on entry that the loop will terminate. (Imp's for loop ends in an '==' test, not a >= or <= ...) */ short int fortag; short int forlab; short int exitlab; short int continuelab; fortag = gettag(); forlab = label_id[fortag] = get_next_label_id(); exitlab = label_id[fortag + 1] = get_next_label_id(); continuelab = label_id[fortag + 2] = get_next_label_id(); (void)continuelab; // forlab is at the top of the loop, continuelab is just before the repeat // (where a %until could possibly be tested). exitlab is after the loop //dump_comment("// FOR tag:lab %d:%d %d:%d %d:%d\n", fortag,forlab, fortag+1,exitlab, fortag+2,continuelab); dump_comment("%c %s L_%04x\n", opcode, icode_name[opcode], forlab); ASTIDX initial = POP(); ASTIDX final = POP(); ASTIDX increment = POP(); ASTIDX control = POP(); // Could optimise but as a start this basic logic will suffice: // = - ASTIDX stmnt1 = mktuple(AST_ASSIGN, 'S', control, mktuple(AST_BINOP, '-', initial, increment)); // order for '-'? // LABEL: ASTIDX stmnt2 = mktuple(AST_DEFLAB, mktuple(AST_LABEL, forlab, 'L', fortag)); // if ( == ) goto ASTIDX done = mktuple(AST_COMPARE, control, '=', final); // TO DO: swap order here and in ast.c ASTIDX exit_ast = mktuple(AST_LABEL, exitlab, 'L', fortag + 1); // try (and fail) to generate exit label ASTIDX stmnt3 = mktuple(AST_IFGOTO, done, exit_ast); // = + ASTIDX stmnt4 = mktuple(AST_ASSIGN, 'S', control, mktuple(AST_BINOP, '+', control, increment)); // Ensure all the above are executed in sequence! PUSH(mktuple(AST_SEQ, stmnt1, mktuple(AST_SEQ, stmnt2, mktuple(AST_SEQ, stmnt3, stmnt4)))); } break; case 'F': /* Jump Forward(Tag, Always); */ /* GOTO label */ { short int labtag; short int lab = getforwardlab_from_tag(&labtag); dump_comment("%c %s (labtag=%04x, lab=L_%04x)\n", opcode, icode_name[opcode], labtag, lab); PUSH(mktuple(AST_GOTO, mktuple(AST_LABEL, lab, 'L', labtag))); } break; case 'L': /* Define User Label(Tag); */ /* LABEL label */ { short int ulabtag = gettag(); short int ulab; // It would appear that the second time we see a U_nnnn: label appearing, that's when we need to update the descriptor with a new label id ***TO DO*** // Unfortunately the scheme of noticing that this is the second definition of a label tag // implies a new label id fails if I set up the label id when I see a %label declaration. // - some more thought required. And testing. :-( if (user_label_id[ulabtag] == 0) user_label_id[ulabtag] = get_next_user_label(); ulab = user_label_id[ulabtag]; // user labels are described by tags, can be stacked as params! dump_comment("%c %s (labtag=%04x, lab=U_%04x)\n", opcode, icode_name[opcode], ulabtag, ulab); PUSH(mktuple(AST_DEFLAB, mktuple(AST_LABEL, ulab, 'U', ulabtag))); //fprintf(stderr, "USER LABEL: LABEL U_%04x: (tag=%04x)\n", ulab, ulabtag); } break; case 'J': /* User Jump(Tag); */ /* JUMP label */ { short int ulabtag = gettag(); short int ulab; ulab = user_label_id[ulabtag]; if (ulab == 0) { user_label_id[ulabtag] = get_next_user_label(); ulab = user_label_id[ulabtag]; } // user labels are described by tags, can be stacked as params! dump_comment("%c %s (labtag=%04x, lab=U_%04x)\n", opcode, icode_name[opcode], ulabtag, ulab); //fprintf(stderr, "USER LABEL: JUMP U_%04x (tag=%04x)\n", ulab, ulabtag); PUSH(mktuple(AST_GOTO, mktuple(AST_LABEL, ulab, 'U', ulabtag))); } break; case '"': /* Compare Double; */ /* FORWARD-JUMPIFD cond label */ { // NOTE!!! 'Compare double' refers to double-sided condition, // not to C's double reals /* // O LINE 5 OPD_STACK = 0 file=test/dscond2.imp // @ PUSH #V_0001 (A) OPD_STACK = 2 // @ PUSH #V_0002 (B) OPD_STACK = 3 // " JUMPIFD > L_0002 // @ PUSH #V_0003 (C) OPD_STACK = 4 // ? JUMPIF > L_0002 Three pushes and a jumpifd would have been so much easier :-( Looking at pass1 it's clear the ICODE was designed this way to make pass1 simpler, not pass2! So maybe the way to handle this is to just leave the jumpifd on the stack so that when the jumpif comes, it sees the two stacked objects and can examine SOS to determine if it was a single object or a jumpifd pair. *Or* just simply remove the jumpifd and let jumpif pull 3 variables instead of 2 if a new 'jumpifd_pending' flag is set. But if that's the method we use, I need to check what happens with multiple tests - I *think* we're OK because it's not possible for an *operand* of a comparison to be a comparison itself (eg if ((a < b) < c) ...) but some testing will be needed just to be sure. */ /* leaves tos on the stack */ /* TO DO: if the middle value can potentially have side-effects, e.g. in %if 'A' <= getsymbol <= 'Z' ... then it should be saved to a temporary when it is first evaluated and that temporary used in the second test. Also if the first value can have side-effects remember that in Imp they are evaluated left to right so you cannot simply load the middle value first, in case some idiot has written code akin to %if getsymbol <= getsymbol <= 999 ... The C code we need to generate is: if ( ({int tmp1 = a, tmp2 = b, tmp3 = c; tmp1 < tmp2 && tmp2 < tmp3;}) ) goto ; */ //#ifdef NEVER int cond = getbyte(); short int labtag; short int lab = getforwardlab_from_tag(&labtag); dump_comment("%c %s %c L_%04x\n", opcode, icode_name[opcode], cond, lab); ASTIDX tos = POP(); ASTIDX sos = POP(); ASTIDX comparison = mktuple(AST_COMPARE, sos, cond, tos); // TO DO: swap order here and in ast.c PUSH(mktuple(AST_IFGOTO, comparison, mktuple(AST_LABEL, lab, 'L', labtag))); PUSH(tos); //#endif last_was_doublesided = TRUE; } break; case 'C': /* Compare Addresses; */ /* FORWARD-JUMPIFA cond label */ { // ( Interestingly, due to the way pass1 was written to handle double-sided conditions, // you can't do: %if a == b == c %then ... ) ASTIDX tos = POP(); ASTIDX sos = POP(); tos = mktuple(AST_ADDRESS_OF, tos); sos = mktuple(AST_ADDRESS_OF, sos); PUSH(sos); PUSH(tos); // ***AND DROP THROUGH!!!*** } case '?': /* Compare Values; */ /* FORWARD-JUMPIF cond label */ /* if you have the JUMPIF first then the LOCATE clears it. */ /* if you have the LOCATE first then the REPEAT clears it. */ { ASTIDX comparison; int cond = getbyte(); short int labtag; short int lab = getforwardlab_from_tag(&labtag); dump_comment("%c %s %c L_%04x\n", opcode, icode_name[opcode], cond, lab); ASTIDX tos = POP(); ASTIDX sos = POP(); if (last_was_doublesided) { ASTIDX prev_ifgoto, prev_condition, prev_jumpdest, sos1, cond1, tos1, check_op; prev_ifgoto = POP(); detuple(prev_ifgoto, &check_op, &prev_condition, &prev_jumpdest); detuple(prev_condition, &check_op, &sos1, &cond1, &tos1); // NOTE: assuming the jump destinations for both are the same. However we can actually check, // and if they're not, it's easy enough to just generate the two separate IFGOTO's... // ALSO: check that tos1 is the same as sos... ***TO DO*** comparison = mktuple(AST_COMPARE2, sos1, cond1, sos, cond, tos); // TO DO: swap order here and in ast.c last_was_doublesided = FALSE; } else { comparison = mktuple(AST_COMPARE, sos, cond, tos); // TO DO: swap order here and in ast.c } PUSH(mktuple(AST_IFGOTO, comparison, mktuple(AST_LABEL, lab, 'L', labtag))); } break; case 't': /* Jump Forward(Tag, TT); */ /* BT label */ case 'k': /* Jump Forward(Tag, FF); */ /* BF label */ { // This might be for C/Pascal booleans and not used in Imp where we // have short-cut evaluation of conditions, and if so, it may need // a boolean to be popped off the compiler stack. // I.e. this implements if (cond) goto lab, and if (!cond) goto lab. // Oh - wait - they're also for testing the results of string resolution, and // also %predicate results (%true, %false). Need to create tests for those. short int labtag; short int lab = getforwardlab_from_tag(&labtag); dump_comment("%c %s L_%04x\n", opcode, icode_name[opcode], lab); ASTIDX condition = POP(); PUSH(mktuple(AST_IFGOTO, condition, mktuple(AST_LABEL, lab, 'L', labtag))); } break; case '$': /* Define Var; */ /* DEF TAG TEXT TYPE FORM SIZE SPEC PREFIX */ { char *alias = last_alias; // now we have it, still need to do something with it... last_alias = NULL; // Instruction: Define [id] int tag; char *ID; short int a, b, cX, i; tag = gettag(); ID = getname(); assert(get_icode(icode_file) == ','); a = gettag() & 0xFFFF; assert(get_icode(icode_file) == ','); b = gettag() & 0xFFFF; assert(get_icode(icode_file) == ','); cX = gettag() & 0xFFFF; if (tag == 0) { tag = NEW_INTERNAL_TAG(); // Invented tag so that record fields can be looked up to handle SELECT // We should be able to use the extended field option in the AST to store these. // Record fields are numbered from 1 in SELECT. } dump_comment("%c %s %s (%c_%04x) a=%d b=%d c=%d \n", opcode, icode_name[opcode], ID, tag >= next_free_private_tag ? 'S' : 'V', tag, a, b, cX); ASTIDX decl = mktuple(AST_DECLARE, tag); last_declare_for_init = decl; // use the other hacky global :-/ Descriptor[tag] = decl; // tag_declaration; // // Currently when outputting %result == mapresult (where mapresult is a %integermap), codegen is seeing FORM=0 // rather than FORM=9 (F_MAP) as expected. Trying to find out why... // // $ DEF V_0071 ID=MAPRESULT a=25 b=1 c=0 <--- 25&15 == 9 // BASE_TYPE(decl) = (a >> 4) & 0xF; FORM(decl) = a & 0xF; /* handle bizarre type encoding scheme: */ SPECIAL(decl) = 0; if (BASE_TYPE(decl) == T_INTEGER && b == 2) SPECIAL(decl) = 1; /* integer-oid */ else if (BASE_TYPE(decl) == T_INTEGER && b == 3) SPECIAL(decl) = 2; /* integer-oid */ else if (BASE_TYPE(decl) == T_REAL && b == 4) SPECIAL(decl) = 3; LINKAGE(decl) = cX & 7; if (FORM(decl) == F_ARRAY || FORM(decl) == F_NAME_ARRAY) IS_ARRAY(decl) = TRUE; if (FORM(decl) == F_NAME || FORM(decl) == F_NAME_ARRAY || FORM(decl) == F_NAME_ARRAY_NAME) IS_BASE_NAME(decl) = TRUE; if (FORM(decl) == F_ARRAY_NAME || FORM(decl) == F_NAME_ARRAY_NAME) IS_ARRAY_NAME(decl) = TRUE; if (SPECIAL(decl)) { } else if (BASE_TYPE(decl) == T_STRING) { if (b == 0) { STRING_CAPACITY(decl) = -1; // '*'. Maybe should use 0 since %string(0) fred is pretty stupid and probably caught by pass1? // (note: -1 & 255 == 255, which we take advantage of later. } else { STRING_CAPACITY(decl) = b; } } else if (BASE_TYPE(decl) == T_INTEGER) { const int datasize[4] = {8, 4, 1, 2}; BASE_SIZE_CODE(decl) = b & 3; BASE_SIZE_BYTES(decl) = datasize[BASE_SIZE_CODE(decl)]; } else if (BASE_TYPE(decl) == T_REAL) { const int datasize[8] = {4, 4, 4, 4, 8, 4, 4, 4}; BASE_SIZE_CODE(decl) = b & 7; // NOTE: 8 values for reals, 4 for integers! BE CAREFUL! BASE_SIZE_BYTES(decl) = datasize[BASE_SIZE_CODE(decl)]; } else if (BASE_TYPE(decl) == T_RECORD) { if (b == 0) { RECORD_FORMAT(decl) = 0; // %const %record(*) %name nil == 0 } else { RECORD_FORMAT(decl) = Descriptor[b]; //debug_types(decl); } } for (i = 0; i < sizeof(oflags) / sizeof(oflags[0]); i++) { if (cX & oflags[i].mask) { if (oflags[i].mask == 8) IS_SPEC_ONLY(decl) = TRUE; // { 8, " spec" }, // S=1 if (oflags[i].mask == 16) NO_AUTO_DEREF(decl) = TRUE; // { 16, " {indirect-no-auto-deref, I=1}" } if (oflags[i].mask == 32) NO_UNASS(decl) = TRUE; // { 32, " {NO UNASSIGNED CHECKS, U=1}" } } } EXTERNAL_NAME_IDX(decl) = C_NAME_IDX(decl) = IMP_NAME_IDX(decl) = strtopool(ID); if ((LINKAGE(decl) == X_PERM || LINKAGE(decl) == X_PRIM)) { char internal[512]; sprintf(internal, "_imp_%s", ID); // maybe also tolower(ID)... C_NAME_IDX(decl) = strtopool(internal); // lets see how many instances of prims are displayed using the wrong string... } if (FORM(decl) == F_MAP) { // Needs to be marked so that if assigning to a scalar with '=', it isindirected through '*' // but not if assigning to a pointer with '==' // Test minmap.imp (minimal map test) is not yet working. } if (alias != NULL) EXTERNAL_NAME_IDX(decl) = strtopool(alias); // Now handle declarations which have other parameters already on the internal stack: if (FORM(decl) == F_SWITCH) { /* Multiple switch declarations with only the last being given the bounds are not being handled properly. This construct works OK for arrays so need to use or copy that mechanism for switches too: // O LINE 3 OPD_STACK = 0 file=test/test164a.imp // N PUSHI #1 OPD_STACK = 2 // N PUSHI #3 OPD_STACK = 3 // b BOUNDS // $ DEF V_0074 ID=MIDDLE a=6 b=0 c=0 // $ DEF V_0075 ID=RIGHT a=6 b=0 c=0 // $ DEF V_0076 ID=LEFT a=6 b=0 c=0 // 3 %switch middle,right,left(1:3) static const void * / *SWITCH* / LEFT static const void * / *SWITCH* / RIGHT static const void * / *SWITCH* / MIDDLE[(3)-(1)+1] = { &&MIDDLE_1, &&MIDDLE_2, &&MIDDLE_3, }; = { }; = { }; Nope... that syntax for arrays only works for auto arrays (potentially n-dimensional), not for %own or %external arrays etc with fixed 1-D bounds! // O LINE 3 OPD_STACK = 0 file=test/threearrays.imp // $ DEF V_0074 ID=LEFT a=27 b=1 c=256 // Auto-array decl 13163 requires following DIM for bounds // $ DEF V_0075 ID=MIDDLE a=27 b=1 c=256 // Auto-array decl 13192 requires following DIM for bounds // $ DEF V_0076 ID=RIGHT a=27 b=1 c=256 // Auto-array decl 13221 requires following DIM for bounds // N PUSHI #20 OPD_STACK = 5 // N PUSHI #20 OPD_STACK = 6 // d DIM 1 3 // creating a 1D array dopevector // Dimension 0: low 13250 high 13279 // assigning a dopevector 13338 to array declaration 13221 // assigning a dopevector 13368 to array declaration 13192 // assigning a dopevector 13398 to array declaration 13163 // 2 // 3 %integerarray left, middle, right(20:20) int LEFT[(20)-(20)+1]; int MIDDLE[(20)-(20)+1]; int RIGHT[(20)-(20)+1]; So it looks like a special hack is going to be needed to remember the last bounds pair handled. *TO DO* */ ASTIDX bounds = POP(); if (OP(bounds) != AST_BOUNDSPAIR) { PUSH(bounds); // put back whatever was popped by accident... // TO DO: at what point do we know that we're done reusing 'last_bounds_pair' and can reset it to -1? I guess on a 'O' (LINE) would be a safe place? if (last_bounds_pair == -1) { fprintf(stderr, "Cannot determine bounds for %%switch %s\n", pooltostr(C_NAME_IDX(decl))); exit(1); } // otherwise, use remembered value from preceding switch decl as in: %SWITCH S,SW(0:3) BOUNDS1D(decl) = bounds = last_bounds_pair; } else { BOUNDS1D(decl) = bounds; } last_bounds_pair = bounds; // gets reset on next 'O' (LINE) opcode. // keep an array of switch indices that have been defined // for this switch variable, and record this switch variable on a // stack at the current block level. When we reach the end of the // current block level, output the code to handle any undefined // switch labels. ASTIDX lowidx, highidx; int low, high; ASTIDX AST_check_op; detuple(bounds, &AST_check_op, &lowidx, &highidx); detuple(lowidx, &AST_check_op, &low); detuple(highidx, &AST_check_op, &high); // space to record array of flags(low:high) switches_set[swstack_nextfree] = (char *)calloc((high-low+1), sizeof(char)); switch_low[swstack_nextfree] = low; switch_high[swstack_nextfree] = high; switch_tag[swstack_nextfree] = tag; //switch_decl[swstack_nextfree] = decl; swstack_nextfree += 1; STRING_CAPACITY(decl) = 0; // overloading an unused field to make a note // that a sw(*): default has not yet been given... PUSH(decl); break; } else if (IS_ARRAY(decl)) { // NOTE!!! Bounds for auto arrays are added afterwards in a DIM code, // but bounds for own or external arrays (which must be constant and // 1 dimensional) are below the $DEF on the stack. if (LINKAGE(decl) == X_AUTO) { dump_comment(" Auto-array decl %d requires following DIM for dynamic bounds for this auto array\n", decl); } else { // Pick up 1D arraybounds and attach to decl ASTIDX bounds = POP(); dump_comment(" Attaching AST_BOUNDSPAIR %d to decl %d, This should NOT be a dynamic bounds auto array\n", bounds, decl); BOUNDS1D(decl) = bounds; } } else if (IS_PROCEDURE(decl)) { // callable? if (!IN_START_FINISH_GROUP) last_declare_for_attaching_fields_or_parameters = decl; } else if (FORM(decl) == F_RECORDFORMAT) { if (!IN_START_FINISH_GROUP) last_declare_for_attaching_fields_or_parameters = decl; } else { // MAY BE MORE TO BE HANDLED? } if (IN_START_FINISH_GROUP) { // This is actually a recordformat field declaration, so has to // be attached to the currently active recordformat. (Not sure // yet about record subfields within a record format. **CHECK** // These declarations are pushed back on the stack and are gathered // up when the ALTEND code is issued, which will collect all the // record fields between ALTBEG and ALTEND off the stack, and then // attach them to the RECORDFORMAT definition which will have been // immediately below them on the stack. // NOTE: The ALT structure of a recordformat only has to be preserved // until we've output the declaration. It's not actually needed when // accessing a field with SELECT which basically just passes the // field name and type info to C and which doesn't care that there // are other variables sharing the same space. So - although I // haven't worked out the details yet - I think we'll be able to // get away with a relatively cheap hack. At least I hope so because // I really don't have any infrastructure in place to handle // struct unions at this point :-( PUSH(decl); } else { PUSH(decl); if (IS_PROCEDURE(decl) && !IS_SPEC_ONLY(decl)) { // Making a change to the AST handling: The decl just prints // the procedure heading - the start of the procedure body // will come from a second AST node that is a blockstart // Start of a rt/fn/pred/map causing a new blocklevel: swbase[blocklevel] = swstack_nextfree; int BLOCKTYPE = 0; if (FORM(decl) == F_ROUTINE) BLOCKTYPE = BLOCKTYPE_ROUTINE; else if (FORM(decl) == F_FN) BLOCKTYPE = BLOCKTYPE_FN; else if (FORM(decl) == F_MAP) BLOCKTYPE = BLOCKTYPE_MAP; else if (FORM(decl) == F_PREDICATE) BLOCKTYPE = BLOCKTYPE_PREDICATE; PUSH(mktuple(AST_BLOCKSTART, blocklevel+1, BLOCKTYPE, C_NAME_IDX(decl))); } } if (FORM(decl) == F_LABEL) { int ulabtag = tag; // I believe that a label declaration will always need a new label id. user_label_id[ulabtag] = get_next_user_label(); //int ulab = user_label_id[ulabtag]; //fprintf(stderr, "USER LABEL: DEFINE user label tag = %04x, user label = U_%04x\n", ulabtag, ulab); } } break; case '(': /* Jump Forward(Tag, LE); */ case ')': /* Jump Forward(Tag, GE); */ case '<': /* Jump Forward(Tag, LT); */ case '>': /* Jump Forward(Tag, GT); */ case '=': /* Jump Forward(Tag, EQ); */ case '#': /* Jump Forward(Tag, NE); */ /* BNE */ unimplemented[opcode] = TRUE; dump_comment("%c %s %d\n", opcode, icode_name[opcode], getshort()); break; case 'W': /* Switch Jump(Tag); */ /* SJUMP sd */ { // The (constant) index of this switch jump is on the internal stack. int tag = gettag(); dump_comment("%c %s V_%04x\n", opcode, icode_name[opcode], tag); ASTIDX index_ast = POP(); ASTIDX sw = Descriptor[tag]; PUSH(mktuple(AST_GOTO_SWLAB, sw, index_ast)); } break; case '`': /* DEFSWLABEL sd - GT extension - default switch label */ { int tag = gettag(); dump_comment("%c %s %s (tag=%04x)\n", opcode, icode_name[opcode], pooltostr(C_NAME_IDX(Descriptor[tag])), tag); PUSH(mktuple(AST_DEF_DEFAULTSWLAB, mktuple(AST_VAR, tag))); // TO DO! We need to a) have a location associated with this switch's declaration which is // initialised to 'a default has not yet been supplied' // and B) set that to 'a default *has* been supplied' on this icode. // It will be tested on the end of the block, where we have 3 options: // 1) there are unset labels in the switch's range and no default - output an error message // 2) there are unset labels in the switch's range and there is a default - so jump to it // 3) there are no unset labels, the range was already fully used: don't generate any epilog code } break; case '_': /* Switch Label(Tag); */ /* SLABEL sd */ { // ***NOTE*** If a sw(*) is given, pass1 generates all the missing labels. // *but* if no sw(*) is present, no extra labels are generated // and no explicit icode is issued either. So when the switch // label was declared, it's up to the icode handler to pre-fill // the array with a label that points to code which will issue // a run-time error message! (Which will have to be created) // ***UPDATE*** if sw(*) is given but is followed later by explicit missing // switch labels, the later ones will occur twice! It's not at // all clear how those duplicated labels should be eliminated // from the default switch destination without major code movement. // If the default had been implemented by a single 'default' icode // it would have been easy to output a sw_default: label, but what // pass1 is actually doing is outputting multiple labels for every // switch value not yet seen, even though any of those values can // appear later when given explicitly! This is a weird choice to // have made in the design of icode if intended for sequential // code generation without holding large parts of code in memory. // The (constant) index of this switch label is on the internal stack. int tag = gettag(); ASTIDX const_switch_index_ast = POP(); dump_comment("%c %s %s (tag=%04x)\n", opcode, icode_name[opcode], pooltostr(C_NAME_IDX(Descriptor[tag])), tag); PUSH(mktuple(AST_DEF_SWLAB, mktuple(AST_VAR, tag), const_switch_index_ast)); // record the existence of this switch label to help with handling // defaults that are to be dumped at the end of a block. // locate the switch definition in the stack... int swstack_idx = swstack_nextfree; for (;;) { swstack_idx -= 1; if (swstack_idx < 0) break; if (switch_tag[swstack_idx] == tag) { int low = switch_low[swstack_idx]; //int high = switch_high[swstack_idx]; int switch_index = USERFIELD(const_switch_index_ast, 0); char *switch_flag = switches_set[swstack_idx]; switch_flag[switch_index-low] = 1; // MARK AS USED! break; } } } break; case 'Z': /* ASSREF */ /* Assign(EqualsEquals); */ case 'j': /* JAM */ /* Assign(Jam); */ case 'S': /* ASSVAL */ /* Assign(Equals); */ { ASTIDX tos = POP(); ASTIDX sos = POP(); dump_comment("%c %s\n", opcode, icode_name[opcode]); PUSH(mktuple(AST_ASSIGN, opcode, sos, tos /*order?*/)); // and push } break; case '!': /* OR */ /* Operation(ORx); */ case '%': /* XOR */ /* Operation(XORx); */ case '&': /* AND */ /* Operation(ANDx); */ case '.': /* CONCAT */ /* Operation(CONCx); */ case '+': /* ADD */ /* Operation(ADDx); */ case '*': /* MUL */ /* Operation(MULx); */ case '-': /* SUB */ /* Operation(SUBx); */ case 'Q': /* DIVIDE - real divide */ /* Operation(RDIVx); */ case '/': /* QUOT - integer divide */ /* Operation(DIVx); */ case '[': /* LSH */ /* Operation(LSHx); */ case ']': /* RSH */ /* Operation(RSHx); */ case 'X': /* IEXP */ /* Operation(EXPx); */ case 'x': /* REXP */ /* Operation(REXPx); */ { ASTIDX tos = POP(); ASTIDX sos = POP(); dump_comment("%c %s\n", opcode, icode_name[opcode]); PUSH(mktuple(AST_BINOP, opcode, sos, tos /*order?*/)); // and push } break; case 'v': /* MOD */ /* Operate(ABSx, Stack, Nil); */ // Depending on the type of the operand, call one of: // double fabs(double x); // float fabsf(float x); // long double fabsl(long double x); case '\\': /* NOT */ /* Operate(NOTx, Stack, Nil); */ case 'U': /* NEGATE */ /* Operate(NEGx, Stack, Nil); */ { ASTIDX tos = POP(); dump_comment("%c %s\n", opcode, icode_name[opcode]); PUSH(mktuple(AST_MONOP, opcode, tos)); // and push } break; case 'H': /* BEGIN */ /* Compile Begin; */ { int BLOCKTYPE; static int unique_blockno = 0; char tmpname[128]; // nested scope. Important if we're using imp names for variables. //dump_comment("%c %s blocklevel=%d before incrementing\n", opcode, icode_name[opcode], blocklevel); dump_comment("%c %s\n", opcode, icode_name[opcode]); if (blocklevel == 0) { // a %begin at the outer level... either %begin/%endofprogram or %begin/%end/%endoffile (which is identical) BLOCKTYPE = BLOCKTYPE_BEGIN_ENDOFPROGRAM; sprintf(tmpname, "_imp_main"); } else { BLOCKTYPE = BLOCKTYPE_BEGIN_END; sprintf(tmpname, "_BLOCK_%d_LEVEL_%d_", ++unique_blockno, blocklevel); } PUSH(mktuple(AST_BLOCKSTART, blocklevel+1, BLOCKTYPE, strtopool(tmpname))); // enter a new block level } break; case ';': /* END */ /* End of Block; */ { //dump_comment("%c %s blocklevel=%d for the block ending now\n", opcode, icode_name[opcode], blocklevel); dump_comment("%c %s\n", opcode, icode_name[opcode]); PUSH(mktuple(AST_BLOCKEND, blocklevel)); // pass the *current* level } break; case 'Y': /* DEFAULT short */ unimplemented[opcode] = TRUE; dump_comment("%c %s %d\n", opcode, icode_name[opcode], getshort()); break; case 'A': /* Init(Tag); */ /* INIT short */ /* Effect: copies of the init-value are added to the list of values associated with the init-variable. The init-value is either the default value (unassigned) if the stack is empty, the value of TOS (possibly converted to real) if TOS is a constant, or the address of TOS if TOS is a variable. The init-variable is the last static object to have been defined using Define. Error: 1. TOS, if it exists, is not of the same type as the init-variable. PLEASE NOTE: unlike EMAS imp, 2-D (and higher) arrays cannot be initialised! (nor can records) */ { int n_copies = getshort(); ASTIDX init_val = -1; ASTIDX var; dump_comment("%c %s %d\n", opcode, icode_name[opcode], n_copies); /* // N PUSHI #0 OPD_STACK = 2 // $ DEF V_0101 ID=LASTDEF a=17 b=1 c=33 // A INIT 1 0static int LASTDEF; */ if (POPQ(&var)) { if (OP(var) == AST_DECLARE) { // Scalar initialisation if (POPQ(&init_val)) { //init_val = POP(); if (OP(init_val) == AST_ICONST || OP(init_val) == AST_RCONST || OP(init_val) == AST_ISTRINGCONST) { //attach. but drop for now. } else { // same as 'not found' - so initialise to unassigned pattern! And replace the item under the stack PUSH(init_val); } } else { // not found - so initialise to unassigned pattern! } // TO DO: Attach this init_val to var. Will definitely need more work for array elements, but scalars should be OK. } else { // if (OP(var) == AST_ICONST || OP(var) == AST_RCONST || OP(var) == AST_ISTRINGCONST) { // Must be an array initialisation NO! Not true. eg %ownreal R1 = -1.23@4 comes through here. init_val = var; var = POP(); if (OP(var) != AST_DECLARE) { dump_comment(" *** UNEXPECTED TYPE IN INIT (array) ***\n"); } // TO DO: Attach this init_val to var. Will definitely need more work for array elements, but scalars should be OK. } PUSH(var); // replace the AST_DECLARE but not the init value. } else { // stack is empty dump_comment(" Did not find anything on the stack.\n"); } if ((n_copies > 1) && (init_val != -1)) { // This is really a *very dirty* hack! INIT n where n != 1 broke the initialisation // hack that relied on all the init values having been created by mktuple sequentially. // But it was just *so worth it* to avoid duplicating all the init values that I couldn't // say no to myself. Although it was a rather heated argument and the little devil on // my left should did almost come to blows with the little angel on my right shoulder. for (int i = 1; i < n_copies; i++) { ASTIDX throwaway = mktuple(OP(init_val), USERFIELD(init_val, 0)); // DUP() COPY_FIXED_FIELDS_to_from(throwaway, init_val); init_val = throwaway; // I can feel the bile rising in my throat as I write this. // The last item has to be the one most recently assigned to the init var } // Search ast.c for /*GASTRICREFLUX*/ to find the corresponding code. } // index into a InitValues[] array of AST indexes. // Let's say we have an array fred(10:12) and the // init values are AST tuples whose index values // are stored in Initvalues[34], Initvalues[35], // and Initvalues[36]; then INITVALUES(array) // would be 34 and we would assign them in the // declaration to fred[10], fred[11] and fred[12] // by extracting LB=10, UB=12 from the BOUNDS1D(array) // An Initvalues[n] of -1 means unassigned. // NOTE: // If I can guarantee that INIT statements are all // handled in order, I should be able to use the AST[] array // directly rather than have to duplicate the init data // in a separate InitValues[] array... // What's more, if I just assign the most recent init_val to the var // *and* if they are always sequential, then when printing the declaration // I can just work backwards from the saved index and magically find all // the previous inits (but in reverse order!) So a cheap solution if it works! Let's try it and see... INITVALUES(var) = init_val; } break; case 'p': /* ASSPAR */ /* AssignParameter; */ { // ***NOTE*** TO DO: array bound info is not yet being passed dynamically when // an array is passed as an arrayname parameter. At a very minimum we must ensure // that it is the address of the zeroth element that is passed as the array's base // address so that accesses will work out correctly assuming the correct index // values are given within the procedure. Other than in strings and records, // I don't recall that whole arrays can be passed in Imp77 by value - only by address. // However I do need to check that (possibly against the Vax/VMS Imp77 implementation) // as my memory on these things is no longer 100% trustworthy! // Note that arrayname parameters for both 1-D arrays and higher will require a // dopevector to be passed. ASTIDX param; /* Attach this parameter in TOS to the procedure descriptor in SOS */ dump_comment("%c %s\n", opcode, icode_name[opcode]); param = POP(); //debug_types(param); PUSH(mktuple(AST_ACTUAL_PARAMETER, param)); // leave it for the CALL to find... } break; case '@': /* PUSH tag */ /* Stack Var(Tag); */ { int tag = gettag(); //ASTIDX decl = Descriptor[tag]; ASTIDX var = mktuple(AST_VAR, tag); // If the var is an array, we need to reserve space for the indices that will follow: // MAX_DIMS == 7 ... if (IS_ARRAY(var) && (INDEX_LIST(var) == 0)) { // Reserve space so we can attach the array indices as they are later // presented to us...: // Currently I have two separate places where array info is placed - the // BOUNDS1D() location and the INDEX_LIST() locations. Although this is // fine and there's good reasons for it being that way, I am going to // duplicate the final array index supplied by the ACCESS opcode in the // INDEX_LIST even though it is also being saved in BOUNDS1D - just in case // at some later point we find ourselves wanting to simplify the array // indexing code by conflating the two. INDEX_LIST(var) = mktuple(AST_INDEX_LIST, 0/* count of dims assigned so far */, /* easier to just add extras: */ 0/*dim 1*/, 0/*dim 2*/, 0/*dim 3*/, 0/*dim 4*/, 0/*dim 5*/, 0/*dim 6*/, 0/*dim 7*/); // The declaration should already contain the dopevector info describing // the number and bounds of dynamic arrays when declared. // (and remember, arrays with dynamic bounds had to save the actual // runtime value in that dopevector at runtime. We don't know what it // is at the point of the declaration, usually. So some extra code // generation needed for that in cdecl()...) } PUSH(var); dump_comment("%c %s %s (tag=V_%04x) OPD_STACK = %d\n", opcode, icode_name[opcode], pooltostr(C_NAME_IDX(var)), tag, next_opd); } break; case '^': /* PROC tag */ /* Stack_Format = -Tag; */ { int tag = gettag(); unimplemented[opcode] = TRUE; // warn. I'ld like to see where this is used. // I don't think it *is* used, and for now I'm going to remove the AST_PROC // AST entry because I think it is confusing. Easy enough to add back in // if it turns out to be needed after all... dump_comment("%c %s tag V_%04x (I THOUGHT THIS WAS AN UNUSED OPCODE!)\n", opcode, icode_name[opcode], tag); } break; case 'E': /* CALL */ /* Call(0); */ { dump_comment("%c %s\n", opcode, icode_name[opcode]); ASTIDX actual_parameters; //ASTIDX formal_parameters; ASTIDX tos; ASTIDX fn; int result; int param_count; ASTIDX params[32]; param_count = 0; for (;;) { tos = POP(); if (OP(tos) != AST_ACTUAL_PARAMETER) break; params[param_count++] = tos; } fn = tos; //debug_types(fn); // This is where we could force left-to-right evaluation of parameters in external calls to match // C/Unix calling conventions where the last parameter is pushed first. We could assign each // parameter to a local temporary variable in left to right order, then call the procedure // using those pre-evaluated temporaries, so that it would not matter what order the parameters // were pushed in. // proc(a,b,c) -> " { typeof(a) tmp1 = a; typeof(b) tmp2 = b; typeof(c) tmp3 = c; proc(tmp1, tmp2, tmp3); } " actual_parameters = mktuple(AST_ACTUAL_PARAMETER_LIST, param_count); NEXT_AST += param_count; for (int i = 0; i < param_count; i++) { EXTRAFIELD(actual_parameters, (param_count - 1) - i) = params[i]; // reversed back to left-right order } EXTENDED_FIELD_COUNT(actual_parameters) = param_count; ACTUAL_PARAM_LIST(fn) = actual_parameters; //FORMAL_PARAM_LIST(fn) = formal_parameters; - should be in place already // fn is an AST_DECLARE tuple which if // passed to codegen would output the declaration. //debug_types(fn); result = mktuple(AST_CALL, fn); PUSH(result); break; } case 'G': /* ALIAS */ /* Get String(Alias); */ { // can get the same effect in C using __attribute__((alias("target"))) or __attribute__((weak, alias("target"))) // although I'm not sure of the details or what the 'weak' is for. // ***NOTE*** This opcode *precedes* the '$'DEF and is optional, so there is no last_alias = getimpstring(); // Hacky but works dump_comment("%c %s %s\n", opcode, icode_name[opcode], last_alias); } break; case 'M': /* MAP */ /* Return(Map); */ { // %result == atom dump_comment("%c %s\n", opcode, icode_name[opcode]); // AST_ADDRESS_OF should return &location, or pointer, depending on the form of the parameter ASTIDX result = POP(); dump_comment(" /* %%map result: */"); debug_types(result); ASTIDX address = mktuple(AST_ADDRESS_OF, result); PUSH(mktuple(AST_RESULT, address)); } break; case '\'': /* Input String Value; */ /* PUSHS sconst */ { char *string_value = getimpstring(); // shouldn't use C string since an IMP // string can potentially contain a \0 character! But it'll do for now. PUSH_IMPSTRINGCONST(string_value); dump_comment("%c %s %s OPD_STACK = %d\n", opcode, icode_name[opcode], string_value, next_opd); } break; case 'N': /* Input Integer Value(0); */ /* PUSHI iconst */ { int iconst = getwordconst(); PUSH_ICONST(iconst); dump_comment("%c %s #%d OPD_STACK = %d\n", opcode, icode_name[opcode], iconst, next_opd); } break; case 'D': /* Input Real Value; */ /* PUSHR rconst */ { int i, c, byte, len; char comment[1024]; char realstr[1024]; char *cp = &comment[0]; char *rp = realstr; byte = get_icode(icode_file); assert(byte != EOF); len = get_icode(icode_file); assert(len != EOF); cp += sprintf(comment, "%c %s code=%d len=%d \"", opcode, icode_name[opcode], byte, len); c = get_icode(icode_file); assert(c != EOF); for (i = 1; i <= len; i++) { c = get_icode(icode_file); assert(c != EOF); if (c == '@') break; cp += sprintf(cp, "%c", c); rp += sprintf(rp, "%c", c); } if (c == '@') { int exponent = getshort(); cp += sprintf(cp, " @ (signed short)0x%04x\" OPD_STACK = %d\n", exponent, next_opd); rp += sprintf(rp, "E%d", exponent); } else { cp += sprintf(cp, "\" OPD_STACK = %d\n", next_opd); } PUSH_RCONST(realstr); dump_comment(comment); } break; case 'O': /* Update Line(Tag); */ /* LINE decimal */ { // LINE is only called when there is nothing on the stack, so may be used // as a suitable place to output C code. // LINE will not occur in the middle of a multi-line statement, or between // lines which generate no ICODEs, including comments and %constinteger declarations. // Note that this code relies on unix file system semantics, where it is possible // to have two separate input streams open on the same file at the same time. // I don't know if Windows now supports this - in the early days when I first // did some C coding for Windows, only one input stream could be opened on a // file at a time. So if the listing is messed up should this program ever be // run on Windows, that'll be why. It can be worked around but it'll be ugly. FLUSH_ICODE_STACK(); last_bounds_pair = -1; /* (NB Also a reasonably safe place to reset this state) */ if (in_perms) { // This should be moved to ast.c too... but first I need a better way of suppressing the translated perms... dump_code("\n#else\n\n"); dump_code("#include \"perms.h\"\n\n"); dump_code("#endif // USE_PERMS_INC\n\n"); if (PARM_OPT) { dump_code("#define PARM_OPT 1\n"); dump_code("#ifdef _U // Don't do unassigned checks...\n"); dump_code("#undef _U\n"); dump_code("#define _U(x) (x)\n"); dump_code("#endif\n"); } } in_perms = FALSE; d = getshort(); // Target line to display up to. char *fname = getrawstring(); // DIRTY HACK. I redefined the 'LINE' ICODE to add // this extra string parameter. But since pass1 is built-in here, it's safe. dump_comment("%c %s %d OPD_STACK = %d file=%s\n", opcode, icode_name[opcode], d, next_opd, fname); PUSH(mktuple(AST_IMP_LINE, d, strtopool(fname))); } break; case 'P': /* PLANT */ /* Dump Byte(Popped Value&255); */ unimplemented[opcode] = TRUE; dump_comment("%c %s\n", opcode, icode_name[opcode]); break; case 'T': /* TRUE */ /* Return(True); */ case 'K': /* FALSE */ /* Return(False); */ { dump_comment("%c %s\n", opcode, icode_name[opcode]); PUSH_ICONST(opcode == 'T' ? 1 : 0); PUSH(mktuple(AST_RESULT, POP())); } break; case 'R': /* RETURN */ /* Return(Routine); */ { dump_comment("%c %s\n", opcode, icode_name[opcode]); PUSH(mktuple(AST_RETURN)); } break; case 'V': /* RESULT */ /* Return(Fn); */ { dump_comment("%c %s\n", opcode, icode_name[opcode]); PUSH(mktuple(AST_RESULT, POP())); } break; case 'I': /* Select Input(Icode In2); Readsymbol(Pending); */ unimplemented[opcode] = TRUE; dump_comment("%c %s\n", opcode, icode_name[opcode]); break; case 'a': /* ACCESS */ /* Array Access; */ { dump_comment("%c %s\n", opcode, icode_name[opcode]); // A small note in case I forget: a *dopevector* is stored as dims in a userfield but the bounds in extra fields. // Whereas the INDEX_LIST (the array of actual indices used to index a specific instance of an array access) is // stored entirely in user fields: 0 being the dimensions, then 1:n being the indices. // Yes, in hindsight both objects should have been stored the same way, and in fact the sensible change to make // would be to alter the dopevector to put all the boundspairs in the user fields following the dimension count. // The reason I did the other scheme initially was that I was allowing for an unbounded number of dimensions and // also to save space by not allocating extra fixed slots that wouldn't be used in most instances. I realised // later that the extra space overhead doesn't matter a bit, and I read in a document that Imp limits the number // of array bounds to 7. So at some point I'll rationalise the code and be more consistent. ASTIDX this_index = POP(); ASTIDX the_array = POP(); int dimensions = 0; ASTIDX static_bounds = BOUNDS1D(the_array); ASTIDX dopevector = DOPEVECTOR(the_array); if (dopevector != 0) { dimensions = USERFIELD(dopevector, 0); if (dimensions != EXTENDED_FIELD_COUNT(dopevector)) { dump_code("/* BUG WARNING: dimensions = %d extended_field_count = %d */", dimensions, EXTENDED_FIELD_COUNT(dopevector)); } } ASTIDX indexed_array; // replace the_array[this_index] on the stack once applied debug_types(the_array); debug_types(this_index); if (IS_ARRAY_NAME(the_array)) { // An array with implied lower bound of 0 indexed_array = mktuple(AST_ARRAYACCESS, the_array, this_index); } else if (dopevector == 0 && static_bounds == 0) { // Shouldn't happen but if it does, probably same as above? indexed_array = mktuple(AST_ARRAYACCESS, the_array, this_index); } else if (static_bounds != 0) { // statically bound array debug_types(static_bounds); indexed_array = mktuple(AST_ARRAYACCESS, the_array, this_index); } else if (dopevector != 0) { // dynamically bound array //debug_types(dopevector); dump_code("/*dims:%d*/", dimensions); // INDEX_LIST is an AST tuple comtaining the number of dims and room for 7 actual indices into this array *var* (note: not array *decl*) ASTIDX indices = INDEX_LIST(the_array); if (indices == 0) { dump_comment("\n/* C: BUG: DON'T KNOW WHY THE ARRAY VAR DIDN'T HAVE SPACE RESERVED FOR THE INDICES. ADDING IT NOW. */\n"); // could be because the array info was copied from the record field definition // but the extra info fields were not also copied? INDEX_LIST(the_array) = indices = mktuple(AST_INDEX_LIST, 0/* count of dims assigned so far */, 0/*dim 1*/, 0/*dim 2*/, 0/*dim 3*/, 0/*dim 4*/, 0/*dim 5*/, 0/*dim 6*/, 0/*dim 7*/); } USERFIELD(indices, 0) += 1; // count of assigned indices USERFIELD(indices, USERFIELD(indices, 0)) = this_index; // attach this index debug_types(indices); indexed_array = mktuple(AST_DYNAMICARRAYACCESS, the_array); // the indices and the dopevector are applied. We now push the updated object } else { // Error? dump_comment("/* BUG: unexpected situation with the ACCESS opcode */"); } PUSH(indexed_array); // now updated with all the indexes } break; #ifdef NEVER // * When doing ACCESS on something that was the result of a SELECT // (i.e. an array that is a record field) such as this: // @ PUSH #V_00ae (P) OPD_STACK = 4 // n SELECT field #1 OPD_STACK = 4 // @ PUSH #V_00cf (INN) OPD_STACK = 5 // a ACCESS // // (this example was p_tab(inn) in soap80-a.imp) the ACCESS code messes up. /* Add this index in TOS to the base address in SOS. This is for the last index of any array and currently works OK for 1-D arrays.. For multi-D arrays, the preceding indices are handle by INDEX, which is not yet implemented! */ { // ***TO DO*** for n-D arrays, there will be indices on the stack! // not quite sure at this point how to do this. Obviously the way it is // intended to work is that the indices are added one-by-one and the // underlying array is pushed back on the stack as each index is added, // but clearly that is not currently how the opcodes are being handled. /* for: x = threed(i, j, k) ... // O LINE 8 OPD_STACK = 0 file=test/3Darray.imp // @ PUSH #V_0005 (X) OPD_STACK = 2 // @ PUSH #V_0001 (THREED) OPD_STACK = 3 // @ PUSH #V_0002 (I) OPD_STACK = 4 // i INDEX // @ PUSH #V_0003 (J) OPD_STACK = 5 // i INDEX // @ PUSH #V_0004 (K) OPD_STACK = 6 // a ACCESS // S ASSVAL for: x = oned(i) ... // @ PUSH #V_0003 (X) OPD_STACK = 2 // @ PUSH #V_0001 (ONED) OPD_STACK = 3 // @ PUSH #V_0002 (I) OPD_STACK = 4 // a ACCESS // S ASSVAL */ dump_comment("%c %s\n", opcode, icode_name[opcode]); ASTIDX this_index = POP(); ASTIDX the_array = POP(); ASTIDX indexed_array; // the array element after applying the indices to the array. if (BASE_TYPE(this_index) != T_INTEGER) { dump_comment("\n/* UNEXPECTED TYPE OF WHAT SHOULD BE AN ARRAY INDEX: BASE_TYPE() = %d */\n", BASE_TYPE(this_index)); debug_types(this_index); // remember to use -v to see this } if (OP(the_array) != AST_VAR && OP(the_array != AST_FIELDSELECT)) { dump_comment("\n/* A: INDEX OPERATION BEING APPLIED TO SOMETHING THAT MAY NOT BE A VAR */\n"); } if (!IS_ARRAY(the_array) && !IS_ARRAY_NAME(the_array)) { dump_comment("\n/* B: INDEX OPERATION BEING APPLIED TO SOMETHING THAT MAY NOT BE AN ARRAY VAR */\n"); } if (IS_ARRAY_NAME(the_array)) { // We're not going to have a BOUNDS1D *or* a dopevector for an arrayname // so we treat it as being a 1D array with a 0 lower bound and no range checking... indexed_array = mktuple(AST_ARRAYACCESS, the_array, this_index); // to do: may need to add AST_INDIRECT_THROUGH - or not - as we want the generated // access to read (*NAME)[idx] ... maybe add an AST_ARRAYNAMEACCESS tuple type? } else if (BOUNDS1D(the_array) != 0) { // statically bound array indexed_array = mktuple(AST_ARRAYACCESS, the_array, this_index); } else { // dynamically bound array // 40 sheila(i) = i * 10 // @ PUSH SHEILA (tag=V_007b) OPD_STACK = 2 // 23656: mktuple(AST_VAR, 123) // 23686: mktuple(AST_INDEX_LIST, 0, 0, 0, 0, 0, 0, 0, 0) // @ PUSH I (tag=V_0079) OPD_STACK = 3 // 23723: mktuple(AST_VAR, 121) // a ACCESS // 23753: mktuple(AST_DYNAMICARRAYACCESS, 23656) // @ PUSH I (tag=V_0079) OPD_STACK = 3 // 23783: mktuple(AST_VAR, 121) // N PUSHI #10 OPD_STACK = 4 // 23813: mktuple(AST_ICONST, 10) // * MUL // 23843: mktuple(AST_BINOP, 42, 23783, 23813) // S ASSVAL // 23875: mktuple(AST_ASSIGN, 83, 23753, 23843) // (*SHEILA)[0/*BUG: MISSING INDEX*/] = ((I)) * ((10)); // ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ /* array 23656: AST_VAR 'SHEILA' -> BASE_TYPE: %integer (1) FORM: %array (11) BASE_SIZE_CODE: 1 BASE_SIZE_BYTES: 4 LINKAGE: (0) SPECIAL: 0 BASE_%NAME? N ARRAY? Y ARRAY_NAME? N SPEC? N NO_AUTO_DEREF: 0 STRLEN: 0 RECFM: 0 FORMAL_PARAMS: 0 ACTUAL_PARAMS: 0 BOUNDS: 23686 DOPEVECTOR: 0 UFC=1 [ 123 ] XFC=0 [] in "ast.c":2662 */ ASTIDX indices = INDEX_LIST(the_array); if (indices == 0) { dump_comment("\n/* C: THE ARRAY VAR DOESN'T SEEM TO HAVE SPACE RESERVED FOR THE INDICES? */\n"); indexed_array = mktuple(AST_ARRAYACCESS, the_array, this_index); // TO DO: this is a short term hack just to get some cases working. It is not a solution. // This is caused by an array as a record field. Currently trying to trace propogation of type information. } else { USERFIELD(indices, 0) += 1; // count of assigned indices USERFIELD(indices, USERFIELD(indices, 0)) = this_index; // attach this index indexed_array = mktuple(AST_DYNAMICARRAYACCESS, the_array); // the indices and the dopevector are } } PUSH(indexed_array); // now updated with all the indexes } break; #endif case 'n': /* SELECT tag */ /* Select(Tag); */ { int field = gettag(); ASTIDX OLD_DECL_AST_TAG = POP(); // the record *** an AST_TAG *** debug_types(OLD_DECL_AST_TAG); ASTIDX RECFM_AST_TAG = RECORD_FORMAT(OLD_DECL_AST_TAG); ASTIDX parameterlist = FORMAL_PARAM_LIST(RECFM_AST_TAG); // TO DO: have a RECORD_FIELD_LIST instead? ASTIDX subfield = EXTRAFIELD(parameterlist, field - 1); dump_comment("%c %s %s (field #%d) OPD_STACK = %d\n", opcode, icode_name[opcode], pooltostr(C_NAME_IDX(subfield)), field, next_opd); debug_types(subfield); OP(subfield) = AST_VAR; // *VERY* HACKY! debug_types(subfield); // All the type information for 'record with field' should be set from subfield. PUSH(mktuple(AST_FIELDSELECT, OLD_DECL_AST_TAG, subfield)); } break; // PLEASE NOTE!!! 'DIM' is only used for auto arrays, which cannot be initialised in Imp77. // whereas 'BOUNDS' is used for external, own, and const arrays (no matter // where they appear) (and switches) - however those must be only one-dimensional. // The 'BOUNDS' code *precedes* the $DEF but the 'DIM' code follows it. case 'b': /* BOUNDS */ /* Constant Bounds; */ { ASTIDX lower, upper; dump_comment("%c %s\n", opcode, icode_name[opcode]); upper = POP(); lower = POP(); PUSH(mktuple(AST_BOUNDSPAIR, lower, upper)); // When a $DEF of the appropriate type follows, it will pop the BOUNDS } break; case 'd': /* DIM short,short */ /* D = Tag; N = Tag; Dimension(D, N); */ { /* Instruction: Dimension Effect: pairs of integer values on the stack are used to define the bounds of the last arrays to have been defined. Code is generated, if necessary, to allocate the arrays and the definitions are adjusted to reference the appropriate storage. Notes: The pairs of values are stacked in order of the declaration, that is, first dimension first. In each pair of values the lower bound is stacked before the upper bound. The last tags must have had consecutive index values. Errors: 1. The stack contains less than 2* items. 2. The last definitions were not all arrays. Example: integerarray A, B, C(1:2, Low:4) Define A...... Define B...... Define C...... Byte 1; Byte 2 Stack Low; Byte 4 Dimension 3 2 */ int num_dimensions = getshort(); assert(get_icode(icode_file) == ','); int num_decls = getshort(); // $ DEF V_0070 id=27 a=1 b=256 c=4 // $ DEF V_0071 id=27 a=1 b=256 c=4 // $ DEF V_0072 id=27 a=1 b=256 c=4 // N PUSHI #1 OPD_STACK = 4 // N PUSHI #2 OPD_STACK = 5 // @ PUSH #V_006f OPD_STACK = 6 // N PUSHI #4 OPD_STACK = 7 // d DIM 3 2 dump_comment("%c %s %d %d\n", opcode, icode_name[opcode], num_dimensions, num_decls); ASTIDX boundarray[num_dimensions]; dump_comment(" creating a %dD array dopevector\n", num_dimensions); for (int dim = 0; dim < num_dimensions; dim++) { ASTIDX high = POP(); ASTIDX low = POP(); // TO DO ***IMPORTANT*** don't store the actual variables that were used to declare the dymnamically-bounded array - // save their values into temporaries (eg _low[dims] and _high[dims] so that // changing those variables doesn't mess up subsequent array accesses where the lower bound is subtracted // from the index. // This is the point where we need to have that function to declare a new temporary... // The actual assignment can be done in the cdecl code in ast.c // e.g. // %integer i = 1, j, k // %integerarray threed(0:i, i:2, -i:i) // // not clear yet if I should just invent cached indexes for all bounds including ones known to be constant, or whether // to only cache bounds containing variables in the expressions. The latter may not be as complicated as I first feared. // // dynarray_high_1 = i; dynarray_low_2 = i; dynarray_low_3 = -i; dynarray_high_3 = i; // int dynarray[0:dynarray_high_1][dynarray_low_2:2][dynarray_low_3:dynarray_high_3]; // boundarray[dim] = mktuple(AST_BOUNDSPAIR, low, high); dump_comment(" Dimension %d: low %d high %d\n", dim, low, high); } int tmpdecl[num_decls]; // number of $DEF declarations on stack that these boundss should be assigned to for (int decls = 0; decls < num_decls; decls++) { ASTIDX decl = POP(); tmpdecl[decls] = decl; ASTIDX dopevector = mktuple(AST_DOPEVECTOR, num_dimensions); NEXT_AST += num_dimensions; // allocate extra space for bounds for each dimension dump_comment(" assigning a dopevector %d to array declaration %d\n", dopevector, decl); for (int dim = 0; dim < num_dimensions; dim++) { EXTRAFIELD(dopevector, dim) = boundarray[dim]; } EXTENDED_FIELD_COUNT(dopevector) = num_dimensions; DOPEVECTOR(decl) = dopevector; // if non-zero, the array in the $DEF has a dopevector, otherwise use BOUNDS1D(tuple). Or add a HAS_DOPEVECTOR flag? debug_types(decl); // diagnose changes to declaration caused by adding dopevector dump_comment(" The dopevector field in decl %d above should *NOT be 0!\n", decl); debug_types(dopevector); // diagnose changes to declaration caused by adding dopevector } for (int decls = num_decls - 1; decls >= 0; decls--) { PUSH(tmpdecl[decls]); // restore the declarations that were on the stack... (in the same order as they were) } break; } case 'g': /* Test for NIL; */ unimplemented[opcode] = TRUE; dump_comment("%c %s\n", opcode, icode_name[opcode]); break; // NOTE: these might have been replaced! // 'q' in pass2-arm.imp handles include files: // c('h'): Special Call(Tag); %continue // c('q'): Process Include File; %continue case 'h': /* ALTBEG */ case '|': /* ALT */ case 'q': /* ALTEND */ unimplemented[opcode] = TRUE; dump_comment("%c %s\n", opcode, icode_name[opcode]); break; case 'i': /* INDEX */ /* Array Index; */ { // This is only used with the extra dimensions of N-D arrays. // - 1D arrays are handled by the ACCESS opcode. /* for: x = threed(i, j, k) ... // O LINE 8 OPD_STACK = 0 file=test/3Darray.imp // @ PUSH #V_0005 (X) OPD_STACK = 2 // @ PUSH #V_0001 (THREED) OPD_STACK = 3 // @ PUSH #V_0002 (I) OPD_STACK = 4 // i INDEX // @ PUSH #V_0003 (J) OPD_STACK = 5 // i INDEX // @ PUSH #V_0004 (K) OPD_STACK = 6 // a ACCESS // S ASSVAL NOTE: the INDEX opcode is currently not implemented!!! for: x = oned(i) ... // @ PUSH #V_0003 (X) OPD_STACK = 2 // @ PUSH #V_0001 (ONED) OPD_STACK = 3 // @ PUSH #V_0002 (I) OPD_STACK = 4 // a ACCESS // S ASSVAL So, conclusion: it's INDEX that is broken, not ACCESS. */ dump_comment("%c %s\n", opcode, icode_name[opcode]); // ***TO DO*** ASTIDX this_index = POP(); ASTIDX the_array = POP(); if (BASE_TYPE(this_index) != T_INTEGER) { dump_comment("\n/* UNEXPECTED TYPE OF WHAT SHOULD BE AN ARRAY INDEX */\n"); } if (OP(the_array) != AST_VAR) { dump_comment("\n/* A: INDEX OPERATION BEING APPLIED TO SOMETHING THAT MAY NOT BE A VAR */\n"); } if (!IS_ARRAY(the_array)) { dump_comment("\n/* B: INDEX OPERATION BEING APPLIED TO SOMETHING THAT MAY NOT BE AN ARRAY VAR */\n"); } ASTIDX indices = INDEX_LIST(the_array); if (indices == 0) { dump_comment("\n/* C: THE ARRAY VAR DOESN'T SEEM TO HAVE SPACE RESERVED FOR THE INDICES? */\n"); } USERFIELD(indices, 0) += 1; // count of assigned indices USERFIELD(indices, USERFIELD(indices, 0)) = this_index; // attach this index PUSH(the_array); // updated with the partially-applied indexes so far... } break; case 'm': /* MONITOR */ /* Do(Monitor Id, Monitor Ep, 0); */ { dump_comment("%c %s\n", opcode, icode_name[opcode]); PUSH(mktuple(AST_MONITOR, 0)); } break; case 'o': /* Event Trap(Tag); */ /* ON byte short label */ { short int eventlist = getshort(); assert(get_icode(icode_file) == ','); short int labtag; short int lab = getforwardlab_from_tag(&labtag); dump_comment("%c %s MASK=%04x L_%04x\n", opcode, icode_name[opcode], eventlist, lab); PUSH(mktuple(AST_ONGOTO, eventlist, mktuple(AST_LABEL, lab, 'L', labtag))); } break; case 'r': /* RESOLVE m */ /* Resolve(Tag); */ { /* r flag String Resolution. Flag is a three bit number, the bits representing: 4 - conditional resolution. 2 - first destination present. 1 - second destination present. The resolution sets the condition code to true for successful resolution, and false for failure. The various operands are on the top of the stack. e.g. S -> A.(B).C @s@a@b@c r3 S -> A.(B) @s@a@b r1 stop if S -> (B).C @s@b@c r5k4s:4 */ // result is tested by BF or BT! int flags = getshort(); dump_comment("%c %s flags=%d\n", opcode, icode_name[opcode], flags); int CONDITIONAL = FALSE, OPD1 = FALSE, OPD2 = FALSE; ASTIDX opd1 = 0, opd2 = 0, sourcestring = 0, strtomatch = 0; if (flags & 1) OPD2 = TRUE; if (flags & 2) OPD1 = TRUE; if (flags & 4) CONDITIONAL = TRUE; if (OPD2) opd2 = POP(); strtomatch = POP(); if (OPD1) opd1 = POP(); sourcestring = POP(); ASTIDX resolve = mktuple(AST_RESOLVE, strtomatch, sourcestring, OPD1, OPD2, opd1, opd2); if (CONDITIONAL) { PUSH(mktuple(AST_CONDITIONAL_RESOLVE, resolve)); } else { // TO DO: replace AST_CONDITIONAL_RESOLVE and // AST_UNCONDITIONAL_RESOLVE // with more generic calls. PUSH(mktuple(AST_UNCONDITIONAL_RESOLVE, resolve)); } } break; case 's': /* STOP */ /* To Store(Tag); */ dump_comment("%c %s\n", opcode, icode_name[opcode]); //dump_code("exit(0);\n"); PUSH(mktuple(AST_STOP)); // a call to exit(0) would be better, but // 1) namespace pollution and // 2) not sure how to construct that call :-) break; case 'u': /* ADDA */ /* Aop; */ unimplemented[opcode] = TRUE; dump_comment("%c %s\n", opcode, icode_name[opcode]); break; case 'c': /* Section = 1; Get String(Section Id); */ unimplemented[opcode] = TRUE; dump_comment("%c %s\n", opcode, icode_name[opcode]); break; case 'w': /* MCODE */ /* Machine Code; Forget Everything; */ { int i1; char comment[1024]; char *cp = &comment[0]; unimplemented[opcode] = TRUE; cp += sprintf(cp, "%c %s ", opcode, icode_name[opcode]); for (;;) { char *p1 = getmcstring(&i1); cp += sprintf(cp, " %s", p1); if (i1 == ';') break; int p2 = getshort(); cp += sprintf(cp, " tag_%d", p2); } cp += sprintf(cp, "\n"); dump_comment(comment); } break; // I think these just set internal flags for the compiler? It's documented somewhere. case 'y': /* DIAG short */ /* Set CD(Tag, Diag); */ { int diag = getshort(); dump_comment("%c %s %d\n", opcode, icode_name[opcode], diag); break; PUSH(mktuple(AST_DIAGNOSE, diag)); } break; case 'z': /* CONTROL short */ /* Set CD(Tag, Control); */ { int ctrl = getshort(); dump_comment("%c %s %d\n", opcode, icode_name[opcode], ctrl); break; PUSH(mktuple(AST_CONTROL, ctrl)); } break; case 'e': /* EVENT short */ /* Signal Event(Tag); */ { int eventno = getshort(); dump_comment("%c %s %d\n", opcode, icode_name[opcode], eventno); // first value is in the tag. optional second and third values // can be stacked expressions. So we have to heuristally guess when // we've found the optional second or third parameters. Fortunately (?) // due to the nature of the generated icode, %signal can only happen in // a stand-alone icode statement, so we can stop examining the stack // when we see the 'O' (LINE) directive. UNFORTUNATELY THIS IS NOT // ENOUGH: See examples below: /* // O LINE 5 OPD_STACK = 0 file=test/signal.imp // @ PUSH I (tag=V_0001) OPD_STACK = 2 // N PUSHI #0 OPD_STACK = 3 // ? JUMPIF # L_0002 // e EVENT 15 // : LOCATE (labtag=0004, lab=L_0002) // 4 // 5 %signal 15 %if i = 0 _imp_signal(15, if (( I ) != ( 0 )) goto L_0002; , 0, ""); L_0002: // O LINE 7 OPD_STACK = 0 file=test/signal.imp // @ PUSH I (tag=V_0001) OPD_STACK = 2 // N PUSHI #0 OPD_STACK = 3 // ? JUMPIF # L_0003 // @ PUSH I (tag=V_0001) OPD_STACK = 3 // e EVENT 15 // : LOCATE (labtag=0004, lab=L_0003) // 6 // 7 %signal 15,i %if i = 0 _imp_signal(15, if (( I ) != ( 0 )) goto L_0003; , I, ""); L_0003: // O LINE 9 OPD_STACK = 0 file=test/signal.imp // @ PUSH I (tag=V_0001) OPD_STACK = 2 // N PUSHI #0 OPD_STACK = 3 // ? JUMPIF # L_0004 // @ PUSH I (tag=V_0001) OPD_STACK = 3 // @ PUSH I (tag=V_0001) OPD_STACK = 4 // e EVENT 15 // : LOCATE (labtag=0004, lab=L_0004) // 8 // 9 %signal 15,i,i %if i = 0 if (( I ) != ( 0 )) goto L_0004; _imp_signal(15, I, I, ""); L_0004: */ ASTIDX event, subevent, extra; event = mktuple(AST_ICONST, eventno & 15); if (POPQ(&subevent)) { // Is it best to check for what is allowed or what is not allowed? // Not allowed: AST_IMP_LINE, JUMPIF // Allowed: ICONST MONOP BINOP VAR // I'll split the baby and do both... with a warning if something else happens... if (OP(subevent) == AST_ICONST || OP(subevent) == AST_VAR || OP(subevent) == AST_BINOP || OP(subevent) == AST_MONOP) { if (POPQ(&extra)) { if (OP(extra) == AST_IMP_LINE || OP(extra) == AST_IFGOTO) { PUSH(extra); extra = mktuple(AST_ICONST, 0); } else if (OP(extra) == AST_ICONST || OP(extra) == AST_VAR || OP(extra) == AST_BINOP || OP(extra) == AST_MONOP) { ASTIDX tmp = extra; extra = subevent; subevent = tmp; } else { fprintf(stderr, "* Unexpected tuple preceding EVENT (%%signal n,n) - needs a source change in i2c around line %d\n", __LINE__); } } else { extra = mktuple(AST_ICONST, 0); } } else { //if (OP(subevent) == AST_IMP_LINE || OP(subevent) == AST_IFGOTO) { PUSH(subevent); subevent = mktuple(AST_ICONST, 0); extra = mktuple(AST_ICONST, 0); //} } #ifdef NEVER else { fprintf(stderr, "* Unexpected tuple preceding EVENT (%%signal n) - needs a source change in i2c around line %d\n", __LINE__); PARM_VERBOSE = TRUE; debug_types(subevent); exit(1); } #endif } else { subevent = mktuple(AST_ICONST, 0); extra = mktuple(AST_ICONST, 0); } PUSH(mktuple(AST_SIGNAL, event, subevent, extra)); } break; case 'l': /* LANG short */ /* Language Flags = Tag; */ // We're not going to support any language other than Imp77! //if ((opcode == 'l') && no_perms) suppress_perms = TRUE; // <-- now handled in 'O' (LINE) dump_comment("%c %s %d\n", opcode, icode_name[opcode], getshort()); break; // Unfortunately START and END can be *either* // A: a record format definition *or* // B: a formal parameter list case '{': /* START */ { dump_comment("%c %s %c\n", opcode, icode_name[opcode], opcode == '{' ? '(' : ')'); PUSH(mktuple(AST_START_PARAMLIST)); IN_START_FINISH_GROUP = TRUE; } break; case '}': /* FINISH */ { IN_START_FINISH_GROUP = FALSE; ASTIDX params[32]; int param_count = 0; dump_comment("%c %s %c\n", opcode, icode_name[opcode], opcode == '{' ? '(' : ')'); param_count = 0; for (;;) { ASTIDX prev = POP(); if (OP(prev) == AST_START_PARAMLIST) break; params[param_count++] = prev; } // formal parameters are attached to the AST_DECLARE, // actual parameter to the AST_CALL ... ASTIDX paramlist = mktuple(AST_FORMAL_PARAMETER_LIST, param_count); NEXT_AST += param_count; for (int i = 0; i < param_count; i++) { OP(params[i]) = AST_DECLARE_FP; EXTRAFIELD(paramlist, (param_count - 1) - i) = params[i]; // (reversed back to left-right order) } EXTENDED_FIELD_COUNT(paramlist) = param_count; if (last_declare_for_attaching_fields_or_parameters == -1) { fprintf(stderr, "START/FINISH group but no 'last_declare_for_attaching_fields_or_parameters' on record?\n"); } else { // TO DO: check that last_declare_for_attaching_fields_or_parameters was a procedure or a record format... FORMAL_PARAM_LIST(last_declare_for_attaching_fields_or_parameters) = paramlist; last_declare_for_attaching_fields_or_parameters = -1; } } break; case '~': // Used in a recordformat with a variant record, much like ALT? // NOTE: This may be a newer ICODE format version! { int pending = getbyte(); if ((' ' + 1 <= pending) && (pending <= '~')) { if (pending == 'A') { dump_comment("%c%c %s\n", opcode, pending, "ALTBEG"); //PUSH_icode('h'); /* ALTBEG */ } else if (pending == 'B') { dump_comment("%c%c %s\n", opcode, pending, "ALTEND"); //PUSH_icode('q'); /* ALTEND */ } else if (pending == 'C') { dump_comment("%c%c %s\n", opcode, pending, "ALT"); //PUSH_icode('|'); /* ALT */ } else { dump_comment("%c %s pending=%d ('%c')\n", opcode, "UNKNOWN", pending, pending); } } else { dump_comment("%c %s pending=%d\n", opcode, icode_name[opcode], pending); } } break; /* TODO */ // Details of codes >= 128 can be found in // https://history.dcs.ed.ac.uk/archive/languages/imp77-acorn-tmp/3l/COMPILERS/bend/imp/pass2 // Since none of them are used here they've been removed from the switch statement. default: if (opcode < 0 || opcode > 255 || icode_name[opcode] == NULL) { dump_comment("? OPCODE %d\n", opcode); break; } else { dump_comment("? %s\n", icode_name[opcode]); break; } } //if (PARM_VERBOSE) { ASTIDX tos; if (POPQ(&tos)) { debug_types(tos); PUSH(tos); } } } FLUSH_ICODE_STACK(); char *valgrind = ""; static char now_go_compile_it[1024]; { char vg[512]; int rc = sysnprintf(vg, sizeof(vg), "which valgrind"); if (rc && (strlen(vg) > 3)) { valgrind = "-DVALGRIND_AVAILABLE"; } } if (strcmp(output_filename, "/dev/stdout") == 0) PARM_STDOUT = TRUE; // Blech. Accidentally duplicated these tests.... clean this up...: char *runtime_unassigned_check = " -ftrivial-auto-var-init=pattern"; char *cc = "cc"; { char ccc[512]; int rc = sysnprintf(ccc, sizeof(ccc), "which gcc12"); if (rc && (strlen(ccc) > 3)) { cc = "gcc12"; // private hack for my own system } else { rc = sysnprintf(ccc, sizeof(ccc), "which gcc"); if (rc && (strlen(ccc) > 3)) { cc = "gcc"; rc = sysnprintf(ccc, sizeof(ccc), "gcc -dumpversion"); if (rc) { char *s = strchr(ccc, '.'); if (s) *s = '\0'; // 12.3.0 -> 12 int vsn = atoi(ccc); if (vsn < 12) { // check gcc version is new enough to support -ftrivial-auto-var-init=pattern fprintf(stderr, "? Warning: gcc is version %d - to support runtime unassigned variable checking, please install version 12 or later.\n", vsn); runtime_unassigned_check = ""; } } } } } // Can get a list of options that a program was compiled with when using -frecord-gcc-switches by: // readelf -p .GCC.command.line program (preferable option) // ... or ... objdump -s -j .GCC.command.line program (fallback option) // running under valgrind invokes /snap/bin/valgrind --track-origins=yes --leak-check=full --show-leak-kinds=all --exit-on-first-error=yes -q --error-exitcode=1 // unless the first argument is "-nv" (no valgrind). Later, might add --merge-recursive-frames=3 // pipe output through? ... grep -E "^(....:.*\.imp\ \*\*\*\*|...[0-9]......[0-9A-F][0-9A-F])" test/testfor.asm|ecce - - -command "f/1:/l0k-0;m0f-/%end/mk0;%c" #ifdef PENDING_REMOVAL int version = -1; char gcc[1024] = {0}; char *GCC = "cc"; sysnprintf(gcc, 1024, "gcc -dumpversion"); if (*gcc != '\0') { char *s = strchr(gcc, '.'); if (s) *s = '\0'; version = atoi(gcc); GCC = "gcc"; } if (version < 0) { sysnprintf(gcc, 1024, "cc -dumpversion"); if (*gcc != '\0') { char *s = strchr(gcc, '.'); if (s) *s = '\0'; version = atoi(gcc); GCC = "cc"; } } if (version < 12) { // this one's just for me and my non-standard installation sysnprintf(gcc, 1024, "gcc12 -dumpversion"); if (*gcc != '\0') { char *s = strchr(gcc, '.'); if (s) *s = '\0'; version = atoi(gcc); GCC = "gcc12"; } } int old_gcc = (version < 12); #endif if (object_filename[0] == '\0') { if (PARM_LINK) { sprintf(object_filename, "%s", base_filename); } else { sprintf(object_filename, "%s.o", base_filename); } } // i2c -O and cc -DPARM_OPT -O2 with no -g and running with --nv is the fastest. char *s = now_go_compile_it; s += sprintf(s, "%s", cc); if (*valgrind) s += sprintf(s, " %s", valgrind); // if valgrind is available and we want error checking, tell the application to use it. (perms.c) if (PARM_OPT) s += sprintf(s, " -DPARM_OPT"); // -D_FORTIFY_SOURCE=1 [123] 1 - compile time 2 - run time 3 - extra features is using gcc v12 s += sprintf(s, " -O"); // fairly safe, needed for some error detection, especially compile-time unassigned checks s += sprintf(s, " -g"); // Needed for most error catching and backtracing // reduce size of file caused by many identical _imp_current_file = "..." strings... s += sprintf(s, "%s", runtime_unassigned_check); s += sprintf(s, " -fmerge-constants"); s += sprintf(s, " -fno-strict-aliasing"); // is probably required to ensure Imp-like semantics for // Imp expressions like I = INTEGER(ADDR(realvar)) which // cause "Undefined Behaviour" when literally translated // into equivalent C... (needed when using -O2 and above) s += sprintf(s, " -Wall"); s += sprintf(s, " -Wno-unused-but-set-variable -Wno-unused-variable -Wno-unused-label -Wno-unused-function -Wno-frame-address"); // short term expendiency s += sprintf(s, " -Wno-maybe-uninitialized -Wno-uninitialized"); // These *are* wanted, but we want i2c to scrape this info from GCC and insert _U() tests instead. if (PARM_TIDY) s += sprintf(s, " -Wno-parentheses"); // gcc warns about lack of brackets around operands of "<<", ">>", and "&" because it doesn't trust C programmers s += sprintf(s, " -frecord-gcc-switches"); s += sprintf(s, " -fsanitize=undefined"); s += sprintf(s, " -fsanitize=float-divide-by-zero"); s += sprintf(s, " -fsanitize-undefined-trap-on-error"); s += sprintf(s, " -fsanitize=float-cast-overflow"); s += sprintf(s, " -fno-sanitize-recover=all"); // NO: causes runtime error from insufficient stack space... s += sprintf(s, " -fsplit-stack"); s += sprintf(s, " -fstack-protector"); s += sprintf(s, " -Wno-return-type"); s += sprintf(s, " -Wno-comment"); s += sprintf(s, " -ftrapv"); s += sprintf(s, " -ggdb3"); // extra debugging for gdb including macro definitions if (!PARM_LINK) s += sprintf(s, " -c"); s += sprintf(s, " -o %s", object_filename); s += sprintf(s, " %s.c", base_filename); if (PARM_LINK) s += sprintf(s, " perms.c"); //s += sprintf(s, " -Wa,-adhln"); s += sprintf(s, " -lm"); // must come last //s += sprintf(s, " > %s.lis", base_filename); { int i, any = 0; for (i = 0; i < 128; i++) if (unimplemented[i]) any = 1; if (any) { // fairly sure that apart from INDEX the only ones left are from other languages // and a different version od icode. fprintf(stderr, "? WARNING: These icodes may need to be implemented to compile this program correctly:\n "); for (i = 0; i < 128; i++) { if (unimplemented[i]) fprintf(stderr, " %s", icode_name[i]); } fprintf(stderr, "\n"); } if (PARM_STDOUT) fprintf(output_file, "// COMPILE WITH: %s\n", now_go_compile_it); fflush(output_file); fclose(output_file); // critical to flush before invoking compiler! if (PARM_STDOUT || any) { // just print. if --stdout was used, there was no output file generated that could be compiled. if (opt_info) fprintf(stderr, "# %s\n", now_go_compile_it); } else { if (opt_info) fprintf(stderr, "$ %s\n", now_go_compile_it); system(now_go_compile_it); } } exit(0); return (0); (void)NULL_LABEL; (void)NULL_TUPLE; (void)PROGNAME; }