static char *rcs_version = "i2c.c V$Revision: 1.79 $"; // This is a new portable back-end for Imp77 on linux, 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 neither human-readable // nor maintainable. It is merely a slightly higher level type of // intermediate code. However this will ensure that Imp code can be // run on any linux system which has a GCC C compiler. (which excludes // BSD Unix - sorry Bob. clang in gcc mode does not support gcc's nested // function extension...) // Unfortunately, the real GCC has to be the back-end compiler, because we need // the non-standard GCC extension that supports textually nested procedure // definitions, which none of the other multi-platform 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, writing such a flattener // would be major implementation project, 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). (I did write a prototype flattener in python, // with the help of Claude AI, but it was extremely fragile and although // it worked with small examples, it failed with the real programs I // subjected it to. I do not intend to add that code to this suite.) // Note there is no need to perform optimisations at the source/AST // level, because GCC will do them for us. I did, during the early // stages, make some attempt to keep the C output readable but as more // tweaks had to be made to the generated C, I've had to sacrifice more // and more readability; so by this point readability is no longer a goal. // ****** THE PRIMARY MISSING FUNCTIONALITY NOW IS PROCEDURES AS PARAMETERS! ****** // This is the top priority, currently being worked on. The design of imp77's // pass1 unfortunately precludes the obvious translation of the Imp77 procedure // parameter lists to C, and the only practical solution that has so far // presented itself involves reordering the icode file so that certain bits // of information are made available earlier when they are needed. The // development for that new code is being done first in the separate 'idec' program. // * 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 ) // Everything else sort of works or is at least halfway towards being implemented... // * 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. // some of the following may already be fixed to some extent but not yet checked. // * 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. // But given that imp77 doesn't have the ERCC's ARRAY() map and no existing // code that I know of maps a 2D array over an initialised 1D declaration, // this is a problem that may never surface. // * 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 two variables accessing the same storage will fail. And that's // before we get into the whole C shenannigans about aliasing where the only guaranteed modern // way to alias a location is by using memmove() to access it :-( // (See also the pending issues in ast.c) // ################################################################################################### /* This code converts the ICODE stack machine 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 propagates upwards, being used for type conversion and widening as it goes. 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 added in turn. It's not the carefully designed AST that you would create if designing a new Imp compiler from scratch, but it works well enough with the simplified ICODE output from pass1 - some of the translation tricks we use would not work in a proper "imp to c" high-level translation direct from Imp source code. */ #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 // PARMs affect what ends up in the C code. int PARM_IMP_SOURCE_LINENOS = 1; // issue #line directives for better gdb error reporting int PARM_UNASS = 1; // normally we want unassigned checks unless explicitly suppressed int PARM_CHECK = 1; // other checks with high overhead // bit of both... int PARM_OPT = 0; // implies UNASS=FALSE and CHECK=FALSE and IMP_SOURCE_LINENOS=FALSE - all the ones with run time overhead, plus gcc options // opts affect how the compilation is invoked int opt_stdout = 0; int opt_debug = 0; int opt_verbose = 0; int opt_link = 1; int opt_info = 0; int procedure_parameters_were_used = 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 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 SHOW_STACK(char *after) { fprintf(output_file, "["); for (int i = next_opd - 1; i >= 0; i--) fprintf(output_file, " @%d:%d", i, opdstack[i]); fprintf(output_file, "]%s", after); } int CHECKPOP(void) { if (next_opd <= 0) return 0xDEADBEEF; if (debug_ast) { fprintf(output_file, "// POP() -> %d ", opdstack[next_opd - 1]); SHOW_STACK("\n"); } return opdstack[--next_opd]; } int POPQ(int *ast) { if (next_opd <= 0) return 0; *ast = opdstack[--next_opd]; if (debug_ast) { fprintf(output_file, "// POP() -> %d ", *ast); SHOW_STACK("\n"); } return 1; } 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 POP(void) { ASTIDX astidx = CHECKPOP(); if (astidx == 0xDEADBEEF) { fprintf(stderr, "* STACK UNDERFLOW!\n"); fprintf(output_file, "* STACK UNDERFLOW!\n"); FLUSH_ICODE_STACK(); exit(EXIT_FAILURE); } return astidx; } void PUSH(const ASTIDX node) { if (debug_ast) { fprintf(output_file, "// PUSH(%d) -> ", node); } opdstack[next_opd++] = node; if (debug_ast) SHOW_STACK("\n"); } void PUSH_ICONST(const int iconst) { ASTIDX tuple = mktuple(AST_ICONST, iconst); if (debug_ast) { fprintf(output_file, "// PUSH(#%d) -> ", iconst); } BASE_TYPE(tuple) = T_INTEGER; // BASETYPE_INTEGER; BASE_SIZE_BYTES(tuple) = 4; // actually should be value-dependent FORM(tuple) = F_SIMPLE; opdstack[next_opd++] = tuple; if (debug_ast) SHOW_STACK("\n"); } void PUSH_RCONST(const char *rconst) { ASTIDX tuple = mktuple(AST_RCONST, strtopool(rconst)); if (debug_ast) { fprintf(output_file, "// PUSH(#%s) -> ", rconst); } BASE_TYPE(tuple) = T_REAL; // BASETYPE_REAL; BASE_SIZE_BYTES(tuple) = 8; // Most imp systems work in long real internally and truncate to real on loading and saving FORM(tuple) = F_SIMPLE; opdstack[next_opd++] = tuple; if (debug_ast) SHOW_STACK("\n"); } void PUSH_IMPSTRINGCONST(const char *isconst) { ASTIDX tuple = mktuple(AST_ISTRINGCONST, strtopool(isconst)); if (debug_ast) { fprintf(output_file, "// PUSH(\"%s\") -> ", isconst); } BASE_TYPE(tuple) = T_STRING; // BASETYPE_IMPSTRING; BASE_SIZE_BYTES(tuple) = 255; // or 256? FORM(tuple) = F_SIMPLE; opdstack[next_opd++] = tuple; if (debug_ast) SHOW_STACK("\n"); } 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 systemf(char *s, ...) { extern int system(const char *command); /* Size the string by vfprint'ing it to /dev/null... */ /* then malloc an appropriate area */ char *APPROPRIATE_STRING; va_list ap; static FILE *nullfile = NULL; int string_length; if (nullfile == NULL) nullfile = fopen("/dev/null", "w"); if (nullfile == NULL) { fprintf(stderr, "Major error - cannot open /dev/null\n"); fflush(stderr); exit(1); } va_start(ap, s); string_length = vfprintf(nullfile, s, ap); va_end(ap); /* fclose(nullfile); */ APPROPRIATE_STRING = malloc(string_length+1); va_start(ap, s); vsprintf(APPROPRIATE_STRING, s, ap); va_end(ap); return system(APPROPRIATE_STRING); } 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]; // AST[0] and StringPool[0] etc are created first so that unassigned variables defaulting to 0 are // more easily detected, rather than have them return some legitimate but random object. (void)strtopool(" void /* BUG caused 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 // Also I am considering adding "-fsymbol-case-upper" while changing the C_NAME of all Imp declarations to lower case. // However this is going to have consequences, because of namespace pollution by C headers, which was being easily // avoided when all Imp variables were being converted to upper case in the C translation. Whether it's something // that should only be done for top-level external routines is another question. // Note that C's equivalent of %alias is *not* something we can rely on from Imp: it's very idiosyncratic. // (although for aliased external specs, using asm("aliasname") may be a better solution.) // Also to add: multiple .imp files and also .o files so that the imp command can be used very similarly // to the cc command for building projects that are more than just one source file. // here is $ HELP IMP from Vax/VMS for the options used in that compiler. // We might copy them when we have similar requirements... /* The available options are listed below. Note that all options may be either asserted or negated in use by prefixing "NO" to the option. For example, the "PROFILE" option may appear as either "PROFILE" or "NOPROFILE". In the list below, the convention used is that options which are disabled by default are given in the assertion form, eg "PROFILE", while options which are enabled by default and must be explicitly disabled when required are given in the negated form, eg "NOWARNINGS". Option keywords may be abbreviated as long as they remain unique. PROFILE enables the production of code to support the 3L profiling facility. [note: the 3L profiling facility is not supported with this release of 3L-IMP] DEBUG enables the production of code to support the debugging of the compiled module under the 3L symbolic debugger. [note: the 3L symbolic debugger is not supported with this release of 3L-IMP] Contrast this option with the command qualifier /DEBUG, which enables the generation of the tables required by the VMS native symbolic debugging utility. NOWARNINGS prevents the compiler issuing warning messages. The default is that warning messages are reported to the user. NOASSIGN stops the compiler including code in the object program to check for the use of variables before they have been assigned a value. NOCHARNO disables the production of code to check that the character number argument of the "CHARNO" procedure is within the allowable range as determined by the current size of the string parameter. NOARRAYS disables the production of code to check that array accesses are not performed outside the declared bounds of the array. NOSHADOWFOR disables the production of code to check that %for-loop control variables are not corrupted during execution of the loop. This check is performed by creating a "shadow" copy of the control variable and checking its value against the original variable at each iteration of the loop. NOFOR disables the production of code to check that %for-loops are guaranteed to terminate before they are entered. NOSHIFT disables the production of code to check that the logical shift operators "<<" and ">>" are not used with an illegal value of the shift count, ie a value outside the range 0<=N<=32. NOSTROVERFLOW disables the production of code to check that string expressions do not overflow the maximum possible size of string (255 characters). NOSTRCAPACITY disables the production of code to check that string assignments to not exceed the capacity of the string variable being assigned to. NOSTRINGS shorthand for (NOSTROVERFLOW, NOSTRCAPACITY). NOINTOVER disables run-time checking for integer overflow. This check is normally performed by the hardware and is therefore extremely cheap to perform. Use of the NOINTOVER option is normally resticted to cases in which the program being compiled relies on being able to attempt evaluation of extremely large values without error. Examples of this kind of program might be those involving hashing functions or complex address manipulations. NOCHECKS disables all run-time checks; includes the functions of NOASSIGN, NOCHARNO, NOARRAYS, NOSHADOWFOR, NOFOR, NOSHIFT, NOSTROVERFLOW, NOSTRCAPACITY and NOINTOVER. NOLINES inhibits the production of the object file tables which enable the diagnostic package to discover line numbers in the event of program failure. NOTRACE inhibits the production of the object file tables which enable the diagnostic package to discover procedure names in the event of program failure. Includes the effect of NOLINES. NORECORDS inhibits the generation of the object file tables which enable the diagnostic package to interpret the contents of record variables. NOVARS inhibits the production of the object file tables which enable the diagnostic package to display the names and values of active variables in the event of program failure. This includes the effect of NORECORDS. NODIAGS inhibits the production of all diagnostic tables. Includes the functions of NOLINES, NOTRACE, NORECORDS and NOVARS. */ 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)) { opt_verbose = TRUE; argc -= 1; argv += 1; } else if (argc >= 2 && (strcmp(argv[1], "-d") == 0 || strcmp(argv[1], "--debug") == 0)) { debug_ast = opt_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) { opt_link = FALSE; argc -= 1; argv += 1; } else if (argc >= 2 && strcmp(argv[1], "-O") == 0) { PARM_OPT = TRUE; PARM_UNASS = FALSE; PARM_CHECK = FALSE; 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], "--no-perm") == 0 || strcmp(argv[1], "--noperms") == 0 || strcmp(argv[1], "--noperm") == 0)) { strcpy(perm_filename, "noperms.inc"); argc -= 1; argv += 1; } else if (argc >= 2 && strcmp(argv[1], "--stdout") == 0) { opt_stdout = TRUE; opt_link = FALSE; argc -= 1; argv += 1; } else if (argc >= 2 && (strcmp(argv[1], "-g") == 0 || strcmp(argv[1], "--line") == 0 || strcmp(argv[1], "--lines") == 0)) { PARM_IMP_SOURCE_LINENOS = TRUE; argc -= 1; argv += 1; } else if (argc >= 2 && (strcmp(argv[1], "--no-line") == 0 || strcmp(argv[1], "--no-lines") == 0 || strcmp(argv[1], "--noline") == 0 || strcmp(argv[1], "--nolines") == 0)) { PARM_IMP_SOURCE_LINENOS = FALSE; argc -= 1; argv += 1; } else if (argc >= 2 && (strcmp(argv[1], "--check") == 0 || strcmp(argv[1], "--checks") == 0)) { // enable runtime checks with overhead, eg unassigned checks // and use valgrind etc at runtime. PARM_OPT = FALSE; PARM_UNASS = TRUE; PARM_CHECK = TRUE; argc -= 1; argv += 1; } else if (argc >= 2 && (strcmp(argv[1], "--no-check") == 0 || strcmp(argv[1], "--no-checks") == 0)) { PARM_OPT = TRUE; PARM_UNASS = FALSE; PARM_CHECK = FALSE; argc -= 1; argv += 1; } else if (argc >= 2 && strcmp(argv[1], "--unass") == 0) { PARM_UNASS = TRUE; argc -= 1; argv += 1; } else if (argc >= 2 && strcmp(argv[1], "--no-unass") == 0) { PARM_UNASS = FALSE; argc -= 1; argv += 1; } else if (argc >= 2 && strcmp(argv[1], "--icode") == 0) { suppress_icode = 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 (opt_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"); } // SHORT TERM EXPERIMENT FOR COMPILING IMP THAT PASSES PROCEDURES AS PARAMETERS: if (procedure_parameters_were_used) { systemf("idec --i2c --recode -v %s > %s.recoded.lis; mv ICODE-OUT.icd %s", icode_filename, base_filename, icode_filename); } 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__"); for (int i = 0; i < MAX_DESCRIPTORS; i++) Descriptor[i] = 0; // or would -1 be better? Can a valid ASTIDX be 0? suppress_perms = 1; //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] | | | |-----| | | . . */ 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 (labtag=%04x, lab=L_%04x)\n", opcode, icode_name[opcode], fortag, forlab); ASTIDX initial = POP(); ASTIDX final = POP(); ASTIDX increment = POP(); ASTIDX control = POP(); PUSH(mktuple(AST_FOR, control, initial, increment, final, forlab, exitlab, continuelab, fortag)); } 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; 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 */ //#ifdef NEVER int cond = getbyte(); short int labtag; short int lab = getforwardlab_from_tag(&labtag); dump_comment("%c %s %c (labtag=%04x, lab=L_%04x)\n", opcode, icode_name[opcode], cond, labtag, 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 comparison; int cond = getbyte(); short int labtag; short int lab = getforwardlab_from_tag(&labtag); dump_comment("%c %s %c (labtag=%04x, lab=L_%04x)\n", opcode, icode_name[opcode], cond, labtag, lab); ASTIDX tos = POP(); ASTIDX sos = POP(); tos = mktuple(AST_ADDRESS_OF, tos); sos = mktuple(AST_ADDRESS_OF, sos); 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 '?': /* 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 (labtag=%04x, lab=L_%04x)\n", opcode, icode_name[opcode], cond, labtag, 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); 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 (labtag=%04x, lab=L_%04x)\n", opcode, icode_name[opcode], labtag, lab); ASTIDX condition = POP(); // BIG BIG BIG 'TODO': this may be where the problem is coming from that was spotted in my pdp9 compiler // where the Z0() predicate is jumping on the negated value by accident! More run-time tests need to // be added to the regression suite to catch things like this. // Tentative fix below: (addition of UNLESSGOTO) PUSH(mktuple(opcode == 't' ? AST_IFGOTO : AST_UNLESSGOTO, condition, mktuple(AST_LABEL, lab, 'L', labtag))); } break; case '$': case 'g': /* Define Var; */ /* DEF TAG TEXT TYPE FORM SIZE SPEC PREFIX */ { /* 'g' was unused opcode "Test for NIL" but now being reused as synonymous with '$' *but* not to be printed out in C code */ 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, opcode); last_declare_for_init = decl; // use the other hacky global :-/ if (Descriptor[tag] != 0) { //dump_code("/*DEBUG: Descriptor[tag] = %d (%x)*/", Descriptor[tag], Descriptor[tag]); } 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); C_NAME_IDX(decl) = strtopool(internal); } else if (LINKAGE(decl) == X_SYSTEM) { char internal[512]; sprintf(internal, "%s", ID); char *s = internal; for (;;) { int c = *s; if (c == '\0') break; if (isalpha(c) && isupper(c)) *s = tolower(c); s++; } C_NAME_IDX(decl) = strtopool(internal); } 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) { ASTIDX bounds = POP(); if (OP(bounds) != AST_BOUNDSPAIR) { PUSH(bounds); // put back whatever was popped by accident... 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) { // * 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 ) // I CAN NOW REWRITE ICODE TO SPECIFY PROCEDURE PARAMETERS PROPERLY. HOWEVER THIS CODE NEEDS TO BE UPDATED TO // HANDLE THE NESTED PROCEDURE DEFINITION. A fairly major rewrite might be needed in order to do so, perhaps // by making a recursive 'declare procedure' procedure. // So when the recoding is invoked, this is no longer true: // This is a procedure that is a parameter to another procedure. It is basically just a placeholder as we don't // yet have the parameters to the procedure parameter itself, so mark it, so that when the full definition turns // up later, it will be attached to this procedure and not output as a new procedure. IS_PROC_PARAM(decl) = 1; // or could set it to 'last_declare_for_attaching_fields_or_parameters' as a back-link...? // (if that is valid, which should be checked. Also that field may be pointing to a record, not a param list) dump_code("/* Procedure parameter. probably no args given yet. */"); } else { // This is one of: // a) A regular procedure declaration (where the procedure may or may not have already been spec'd) // b) A forward declaration (spec) of a new regular procedure (possibly duplicated, or even already declared) // c) A procedure parameter to another procedure. The previous reference to this in the parameter list of // that other procedure will have been incomplete. It can now be completed. Both the other procedure and // these updated parameter details should be on the short stack of items between line ('O') directives, // so we do still have an opportunity to update the parameter list to include full details of the procedure // parameter before it is output. This should be the case whether that procedure definition was a spec // or the actual body. // We determine whether this is a procedure parameter by looking at Descriptor[tag] to check for the IS_PROC_PARAM // flag being set. //ASTIDX existing_decl = Descriptor[tag]; 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))); } 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 'q': /* SUBA */ case 'u': /* ADDA */ /* Aop; */ // Occurs in VAX pass1.imp at line 915: current char == current char++1 // and is supported by this pass1, so it *does* need to be implemented... // In C we can probably safely just output "+" and ignore the type checking // that a simple ADD should do. // and drop through: case '+': /* ADD */ /* Operation(ADDx); */ case '-': /* SUB */ /* Operation(SUBx); */ case '!': /* OR */ /* Operation(ORx); */ case '%': /* XOR */ /* Operation(XORx); */ case '&': /* AND */ /* Operation(ANDx); */ case '.': /* CONCAT */ /* Operation(CONCx); */ case '*': /* MUL */ /* Operation(MULx); */ 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); 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! } } 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"); } } 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 == '@') { signed short int exponent = getshort(); cp += sprintf(cp, " @ (signed short)0x%04x\" OPD_STACK = %d\n", exponent, next_opd); rp += sprintf(rp, "E%hd", 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... suppress_perms = 0; //dump_code("\n#else\n\n"); //dump_code("#include \"perms.h\"\n\n"); dump_code("#include \n\n"); //dump_code("#endif // USE_PERMS_INC\n\n"); if (PARM_OPT) { // I think this might be possible to be removed now? dump_code("#define PARM_OPT 1\n"); } if (!PARM_UNASS) { 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); */ { // BIG BIG BIG 'TODO': my pdp9 compiler is getting the Z0 %predicate wrong at the point of generating the jump over the start/finish block! 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; } // 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 */ 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 (labtag=%04x, lab=L_%04x)\n", opcode, icode_name[opcode], eventlist, labtag, lab); PUSH(mktuple(AST_ONGOTO, eventlist, mktuple(AST_LABEL, lab, 'L', labtag))); // NOTE: %signal handling may now require us to insert some code immediately // before the %finish" of the %on %event %start ... %finish block. // That position will be immediately before the