#ifndef __GENC_C__ #define __GENC_C__ 1 // Walk ICode AST and output reconstituted Imp77 source. // (the Imp77 equivalent is in genimp.c) //int reverse_index_order = 1; // This asks for imp-compatible array layout. int reverse_index_order = 0; // This asks for C-compatible array layout. // Future stuff: // look for externals followed by %begin %end %endoffile and translate the // latter as %begin %endofprogram // I haven't talked about this much, but if I have time later, I'ld like to // use the CFG to infer original loops and if/then/else structure. The CFG // is relatively easily created from the AST pretty much by merging any // consecutive instructions that don't change flow control into single blocks. // Then we can move the code in a while or until or if/then/else into the // body field on one of those new AST types. But later. #include static int use_typedef = 0; // 1: "struct fredfm" 0: "fredfm" (not tested recently) static int output_hashline = 1; static int shadow_for_loop = 0; // this can be turned on or off with a command-line option or a %control statement #include "icode2ast.h" #include "icode2ast_data.h" #include "showicode.h" #include "stack.h" #include "genc.h" #include "errorf.h" #include "filter.h" // for reverse_*_list() extern void print_bound_list(FILE *out, IMPAST *result); extern void print_index_list(FILE *out, IMPAST *bound); #define sign(v) ({ __typeof__(v) _v = (v); (_v > 0) - (_v < 0); }) static int access = 1; // 0: not accessible 1: accessible #define MAX_NESTED_FORS 128 char *For_Stack[MAX_NESTED_FORS]; int next_free_for = 0; void Push_For(char *lab) { if (*lab == 0) return; For_Stack[next_free_for++] = lab; } char *Pop_For(void) { if (next_free_for <= 0) return ""; return For_Stack[--next_free_for]; } //FILE *c_out; #define IS_BINOP(icode) ( NOTNULL(icode) != NULL && ( \ (icode)->generic.opcode == OP_OR \ || (icode)->generic.opcode == OP_XOR \ || (icode)->generic.opcode == OP_AND \ || (icode)->generic.opcode == OP_MUL \ || (icode)->generic.opcode == OP_ADD \ || (icode)->generic.opcode == OP_SUB \ || (icode)->generic.opcode == OP_CONCAT \ || (icode)->generic.opcode == OP_QUOT \ || (icode)->generic.opcode == OP_DIVIDE \ || (icode)->generic.opcode == OP_LSH \ || (icode)->generic.opcode == OP_RSH \ || (icode)->generic.opcode == OP_ADDA \ || (icode)->generic.opcode == OP_SUBA)) #define IS_MONOP(icode) ( NOTNULL(icode) != NULL && ( \ (icode)->generic.opcode == OP_NOT \ || (icode)->generic.opcode == OP_NEGATE \ || (icode)->generic.opcode == OP_MOD)) /* not sure this is needed for MOD which translates to a fn call... */ int IS_RECORD_POINTER(IMPAST *this) { // Argument can't be guaranteed to be a DEF (or an ACCESS/INDEX/SELECT) so we // have to use the extra FIXEDFIELD values that we added, though they may not // all currently be in place at the time of writing... //tf, format, ostate int type = NOTNULL(this)->generic.type; // needs work. quick draft. int format = this->generic.format; //IMPAST *special = this->generic.ostate; if (type == T_RECORD) { } else { //warnf("node does not appear to be a %%record?\n"); // should update c_id of SELECT and INDEX nodes with partial value // eg "REC[10]" for better diagnostics return 0; } if (format == F_NAME) return 1; // And probably others such as ARRAYNAME and NAMEARRAY and NAMEARRAYNAME // but F_NAME will do for initial test and the rest should show up in regression tests. return 0; } static const int /*ASSOC_NONE = 0,*/ ASSOC_LEFT = 1, ASSOC_RIGHT = 2; static int C_ASSOCIATIVITY(IMPAST *icode) { return ASSOC_LEFT; } static int C_PRECEDENCE(IMPAST *icode) { // from https://en.cppreference.com/c/language/operator_precedence if (icode == NULL) { warnf("C_PRECEDENCE: parameter was NULL\n"); return 0xDEADBEEF; } switch(NOTNULL(icode)->generic.opcode) { // monops: case OP_NEGATE: return 21-2; // I do need to check with the regression suite case OP_NOT: return 21-2; // that -1 >> 1 in Imp gives the right answer in C. // binops: case OP_OR: return 21-10; case OP_XOR: return 21-9; case OP_AND: return 21-8; case OP_MUL: return 21-3; case OP_ADD: return 21-4; case OP_SUB: return 21-4; case OP_CONCAT: return 21-5; // probably irrelevant case OP_QUOT: return 21-3; case OP_DIVIDE: return 21-3; case OP_LSH: return 21-5; case OP_RSH: return 21-5; case OP_ADDA: return 21-1; // probably irrelevant case OP_SUBA: return 21-1; // probably irrelevant case OP_REXP: return 21-3; case OP_IEXP: return 21-3; default: //warnf("C_PRECEDENCE: parameter was not an operator\n"); return 21; // not a binop } } /* in a = b + c + d - e a = (b + c) + d - e a = b + (c + d) - e a = b + c + (d - e) a = (b + c + d) - e a = b + (c + d - e) a = (b + c) + (d - e) out A = ((B + C) + D) - E A = ((B + C) + D) - E A = (B + (C + D)) - E A = (B + C) + (D - E) A = ((B + C) + D) - E A = B + ((C + D) - E) A = (B + C) + (D - E) */ // ***NOTE*** Imp77 pass1 bug: ^ and ^^ (\ and \\) should be right-associative // according to the language definition (and the Imp80 implementation) but they // are not, in practice! So the IEXP and REXP hacks below which would be needed // if there actually was a right-associative binary operator are in fact not // needed if we intend to reproduce Imp77 behaviour as implemented rather than // as specified. int is_operator(IMPAST *icode) { if (icode == NULL) return 0; switch(NOTNULL(icode)->generic.opcode) { // monops: case OP_NEGATE: return 1; case OP_NOT: return 1; // binops: case OP_OR: return 1; case OP_XOR: return 1; case OP_AND: return 1; case OP_MUL: return 1; case OP_ADD: return 1; case OP_SUB: return 1; case OP_CONCAT: return 1; case OP_QUOT: return 1; case OP_DIVIDE: return 1; case OP_LSH: return 1; case OP_RSH: return 1; case OP_ADDA: return 1; case OP_SUBA: return 1; case OP_REXP: return 1; case OP_IEXP: return 1; default: return 0; } } int ivalue(IMPAST *val); int needs_parentheses(IMPAST *parent, IMPAST *child, int is_right_child) { if (OP(child) == OP_PUSHI && ivalue(child) < 0) return 1; if (!is_operator(child)) return 0; int p_prec = C_PRECEDENCE(parent); int c_prec = C_PRECEDENCE(child); // Case 1: Child has strictly lower precedence (e.g., 2 * (1 + 3)) if (c_prec < p_prec) return 1; // Case 2: Same precedence, handle associativity rules if (c_prec == p_prec) { int p_assoc = C_ASSOCIATIVITY(parent); // Left-associative parent (e.g., + or -) // Right child needs parens: 1 - (2 - 3) if (p_assoc == ASSOC_LEFT && is_right_child) return 1; // Right-associative parent (e.g., exponentiation or unary) // Left child would need parens (not applicable to standard unary) if (p_assoc == ASSOC_RIGHT && !is_right_child) return 1; } return 0; } static int LEFT_NEEDS_BRACKETS(IMPAST *left, IMPAST *op) { return needs_parentheses(op, left, 0); } static int RIGHT_NEEDS_BRACKETS(IMPAST *op, IMPAST *right) { return needs_parentheses(op, right, 1); } int debug_genc = 0; static char *indent(int suppress, int lev) { static char s[256]; char *sp = s; if (!suppress) { *sp = '\0'; lev += 1; if (lev > 64) lev = 64; while (lev --> 0) { *sp++ = ' '; *sp++ = ' '; } } *sp = '\0'; return s; } // -------------------------------------------------------------------------- int ivalue(IMPAST *val) { if (OP(val) != OP_PUSHI) { fatalf("ivalue: parameter was not a PUSHI - it was a %s\n", icode_name[OP(val)]); } return val->pushi.value; } IMPAST *mkiconst(int val) { // *TO DO* these probably need some set_type calls... if (val < 0) { IMPAST *num = new_icode(PUSHI); num->pushi.value = -val; IMPAST *this = new_icode(NEGATE); this->negate.opd = num; return this; } else { IMPAST *this = new_icode(PUSHI); this->pushi.value = val; return this; } } IMPAST *mknegate(IMPAST *val) { if (OP(NOTNULL(val)) == OP_NEGATE) { return val->negate.opd; // undo double negate } else if (OP(val) == OP_PUSHI) { IMPAST *num = new_icode(PUSHI); num->pushi.value = -val->pushi.value; return num; } else if (OP(val) == OP_PUSHR) { IMPAST *num = new_icode(PUSHR); if (val->pushr.value < 0.0 || val->pushr.str[0] == '-') { num->pushr.str = strdup(val->pushr.str+1); } else { num->pushr.str = strdupf("-%s", val->pushr.str); } num->pushr.value = -val->pushr.value; return num; } else { IMPAST *this = new_icode(NEGATE); this->negate.opd = val; return this; } } IMPAST *mkadd(IMPAST *left, IMPAST *right) { IMPAST *this = new_icode(ADD); if (OP(NOTNULL(left))== OP_PUSHI && left->pushi.value == 0) return right; // 0 + right if (OP(NOTNULL(right))== OP_PUSHI && right->pushi.value == 0) return left; // left + 0 if (OP(left)== OP_PUSHI && OP(right)== OP_PUSHI) { return mkiconst(left->pushi.value + right->pushi.value); // left + right } this->add.opd1 = left; this->add.opd2 = right; return this; } IMPAST *mksub(IMPAST *left, IMPAST *right) { IMPAST *this = new_icode(SUB); if (OP(NOTNULL(right))== OP_PUSHI && right->pushi.value == 0) return left; // left - 0 if (OP(NOTNULL(left))== OP_PUSHI && left->pushi.value == 0) { return mknegate(right); // 0 - right } if (OP(left)== OP_PUSH && OP(right)== OP_PUSH) { if (left->push.tag == right->push.tag) return mkiconst(0); // left==right -> 0 } if (OP(left)== OP_PUSHI && OP(right)== OP_PUSHI) { return mkiconst(left->pushi.value - right->pushi.value); // left - right } this->sub.opd1 = left; this->sub.opd2 = right; return this; } IMPAST *mkindirect(IMPAST *arg) { if (OP(NOTNULL(arg)) == ASTOP_ADDRESS_OF) { return arg->address_of.opd; // simplify *&var to var } if (OP(arg) == ASTOP_INDIRECT_THROUGH) { // doesn't appear to have worked warnf("Did get a redundant ASTOP_INDIRECT_THROUGH\n"); return arg; // implement **var as *var We only got here due to %P being given a pointer. This is a hack. Should be handled elsewhere *TO DO* } IMPAST *this = new_iast(INDIRECT_THROUGH); this->indirect_through.opd = arg; // TO DO: TEST copy over the type information from the operand, removing the _NAME info: copy_type(this, arg); inherit_pointed_to_info(this); return this; } IMPAST *mkaddressof(IMPAST *arg) { if (OP(NOTNULL(arg)) == ASTOP_INDIRECT_THROUGH) { return arg->indirect_through.opd; // simplify &*ptr to ptr } if (OP(arg) == ASTOP_ADDRESS_OF) { // doesn't appear to have worked warnf("Did get a redundant ASTOP_ADDRESS_OF!\n"); return arg; // implement &&var as &var We only got here due to %A being given an address. This is a hack. Should be handled elsewhere *TO DO* } IMPAST *this = new_iast(ADDRESS_OF); this->address_of.opd = arg; // (*TO DO*: TEST) copy over the type information from the operand, adding the _NAME info: copy_type(this, arg); make_into_pointer(this); return this; } // -------------------------------------------------------------------------- static int blocklevel = 0; // local copy derived from values stored in AST static int exprdepth = 0; //NEW-STD// #define codegen(format, ...) codegen_inner(__FILE__, __LINE__, format __VA_OPT__() __VA_ARGS__) /*GCC*/ #define codegen(format, ...) codegen_inner(__FILE__, __LINE__, format, ##__VA_ARGS__) static void codegen_inner(char *filename, int lineno, char *format, ...); void output_parameters(char *procname, IMPAST *formal, IMPAST *asspar) { IMPAST *actual; if (debug_genc) fprintf(stderr, "output_parameters(%05d, %05d) (\n", formal->generic.seqno, asspar->generic.seqno); for (;;) { if (formal != NULL) { if (debug_genc) fprintf(stderr, " formal %05d\n", formal->generic.seqno); //show_icode(formal, stderr); } else if (debug_genc) fprintf(stderr, " formal NULL\n"); if (asspar != NULL) { if (OP(asspar) != OP_ASSPAR) { if (debug_genc) fprintf(stderr, " (NOT an ASSPAR: got %s)\n", icode_name[OP(asspar)]); } if (debug_genc) fprintf(stderr, " actual %05d\n", asspar->asspar.param->generic.seqno); //show_icode(asspar->asspar.param, stderr); } else if (debug_genc) fprintf(stderr, " actual NULL\n"); if (formal == NULL && asspar != NULL) { //fatalf("Extra actual parameter\n"); //break; } else if (formal != NULL && asspar == NULL) { //debugf("Extra formal parameter\n"); } else if (formal == NULL && asspar == NULL) { break; } // Now pass actual as-is or by address depending on whether // formal is a name or not. actual = NOTNULL(asspar)->asspar.param; if (actual != NULL) { if (REQUIRES_AUTO_DEREFERENCE(formal)) { //if (FORM(formal) == F_NAME || FORM(formal) == F_ARRAY_NAME || FORM(formal) == F_NAME_ARRAY_NAME // || FORM(formal) == F_MAP /*calls to a MAP may currently be typed as the MAP itself rather than as a RECORDNAME*/ ) { if (TYPE(formal) == T_STRING) { int destmaxlen = formal->generic.maxstring; if (destmaxlen == 0) destmaxlen = 255; int sourcemaxlen = actual->generic.maxstring; if (sourcemaxlen == 0) sourcemaxlen = 255; codegen("(_imp_string%0d *)/*p*/%A", destmaxlen, actual); } else { codegen("%A", actual); // %name parameter } } else { if (TYPE(formal) == T_STRING) { int destmaxlen = formal->generic.maxstring; if (destmaxlen == 0) destmaxlen = 255; int sourcemaxlen = actual->generic.maxstring; if (sourcemaxlen == 0) sourcemaxlen = 255; if (OP(actual) == OP_PUSHS) { actual->pushs.maxstring = destmaxlen; codegen("%V", actual); actual->pushs.maxstring = 0; // undo } else { // NOTE: a %string(*)%array %name will come via this path... if (exprdepth++ == 0) codegen("\n/* clang-format off */\n"); if (FORM(formal) == F_ARRAY_NAME) { codegen("({ __typeof__(_imp_string%0d) tmp = %V/*q*/; (_imp_string%0d *)&tmp; })", sourcemaxlen, actual, destmaxlen); } else { //was:codegen("*(_imp_string%0d *)({_imp_string%0d tmp;/*A*/ tmp = %V; &tmp;})", codegen("*({ __typeof__(_imp_string%0d) tmp = %V/*q*/; (_imp_string%0d *)&tmp; })", sourcemaxlen, actual, destmaxlen); } if (--exprdepth == 0) codegen("\n/* clang-format on */\n"); } } else { codegen("%V", actual); // value parameter } } if (asspar->asspar.next_param != NULL) codegen(", "); } else { fatalf("asspar->asspar.param was NULL\n"); } if (formal != NULL) formal = formal->generic.next_icode; if (asspar != NULL) asspar = asspar->asspar.next_param; } if (debug_genc) fprintf(stderr, ")\n"); } // Not used yet but I'm pretty sure it will be needed... void gen_c_type(IMPAST *this) { // To do: generic "%name" //type=0 () form=2 (name) special=0 (none) if (this == NULL) { codegen("/*BUG: gen_c_type*/void"); } else if (this->generic.type == T_NONE && this->generic.form == F_VOID && this->generic.special == SPECIAL_DEFAULT) { /* *TO DO*: set up the _imp_name type in perms. Not sure if this should be a value or a pointer? (and if so, handled here or elsewhere) */ codegen("struct _imp_name"); } else { switch (this->generic.type) { case T_INTEGER: switch (this->generic.special) { case SPECIAL_BYTE_INT: codegen("unsigned char"); break; case SPECIAL_SHORT_INT: codegen("short int"); break; case SPECIAL_LONG_INT: codegen("long long int"); break; default: codegen("int"); break; } break; case T_REAL: switch (this->generic.special) { case SPECIAL_LONG_REAL: codegen("double"); break; default: codegen("float"); break; } break; case T_STRING: if (this->generic.maxstring == 0) { codegen("_imp_string"); } else { codegen("_imp_string%0d", this->generic.maxstring); } break; case T_RECORD: { IMPAST *def = this->generic.recordformatdef; if (def == NULL || OP(def) != OP_DEF) { codegen("/*BUG: recordformat %s*/ void", icode_name[OP(def)]); warnf("gen_c-type: RECORD object did not have a pointer to its recordformat.\n"); } else { codegen("struct %s", def->def.c_id); } } break; default: break; } // Does this procedure also need the '*' of an indirect object? If so, it goes here. } } static void codegen_inner(char *filename, int lineno, char *format, ...) { va_list ap; char *s = format; char item_format[1024]; va_start(ap, format); for (;;) { int c = *s++; if (c == 0) break; if (c == '%') { int f = *s++; if (f == 0) break; if (f == '%') { fprintf(stdout, "%%"); } else { void *arg = va_arg(ap, void *); // So... this basically passes the format string through to printf, but various types of node // are replaced by us: %N normal node, %V variable (dereferencing a pointer type is automatic), // %A address is needed, %P pointer - dereferencing is forced, %L L-value, %R R-value. // But beware: some of these clash with little-used format codes from C library (eg %A) in which // case our versions are used. Standard C formats are used if they match "%" // Note that if I moved these letter detections down to the loop where ""%" is matched, // I could extend this with options such as %0N vs %1N to pass in the "suppress newline" parameter. // (which now doesn't really mean suppress newline, it's more for whether to add the ";" after a // statement versus "," in a procedure parameter list... For now, working around that issue by // still using gen_c in some cases with gen_c(item,0) rather than using codegen where that // parameter always defaults to 1.) if (f == 'N') { // Raw Node //debugf("Called from %s:%d\n", filename, lineno); gen_c( NOTNULL(arg), 1); // <---------- one of the sources of the address crash } else if (f == 'V') { // Value. Like %N but does an auto-deref if a pointer. if (arg == NULL) { fatalf("NULL arg passed to %%V in \"%s\"\n", format); } /* static inline int REQUIRES_AUTO_DEREF(int tuple) { return ((IS_NAME(tuple) || FORM(tuple) == F_MAP) && (oflags[i].mask != 16)); } // ('no auto deref' was from one of the bits in a,b,c) */ // if oflags[i].mask&16 != 0 don't auto deref else #ifdef NEVER if (FORM((IMPAST *)arg) == F_NAME || FORM((IMPAST *)arg) == F_ARRAY_NAME || FORM((IMPAST *)arg) == F_NAME_ARRAY_NAME || (OP((IMPAST *)arg) == OP_CALL && FORM(((IMPAST *)arg)->call.def) == F_MAP) ) { #else //if (FORM((IMPAST *)arg) == F_ARRAY_NAME) { //gen_c( NOTNULL(arg), 1); //codegen("/*arrayname*/"); //} else if (REQUIRES_AUTO_DEREFERENCE((IMPAST *)arg)) { // this new code is causing an address sanitizer trap here. #endif gen_c( mkindirect(arg), 1); // Adding this to test "record = recordptr". Solution ought to be general across types. *TO DO*: check } else { //debugf("Called from %s:%d\n", filename, lineno); gen_c( NOTNULL(arg), 1); // <---------- one of the sources of the address crash } } else if (f == 'L') { // L-Value: for use when assigning a value to a pointer variable, eg *ptr = 42 rather than ptr = 42 if (FORM((IMPAST *)arg) == F_NAME /*|| FORM((IMPAST *)arg) == F_ARRAY_NAME*/ || FORM((IMPAST *)arg) == F_NAME_ARRAY_NAME || (OP((IMPAST *)arg) == OP_CALL && FORM(((IMPAST *)arg)->call.def) == F_MAP) ) { gen_c( mkindirect(arg), 1); // Adding this to test "record = recordptr". Solution ought to be general across types. *TO DO*: check } else { //debugf("Called from %s:%d\n", filename, lineno); gen_c( NOTNULL(arg), 1); // <---------- one of the sources of the address crash } // } else if (f == 'R') { // R-Value. I'm not sure there's ever a distinction between %R and %V and I probably won't ever need to use %R // gen_c( arg, 1); } else if (f == 'A') { // Address-of if (FORM(NOTNULL(arg)) == F_ARRAY) { codegen("%N", arg); // IAN == IA; (integerarrayname == integerarray, etc.) } else if (FORM(NOTNULL(arg)) == F_NAME_ARRAY) { /* I'm not sure this is the right place to do this? I've noticed that recordnamearrayname == recordnamearray in Imp is being translated to RECORDNAMEARRAYNAME = &RECORDNAMEARRAY; in the output, but C complains about mismatched types, and it seems the correct assignment should have been RECORDNAMEARRAYNAME = RECORDNAMEARRAY; I'm not sure where the optimum place to handle this should be. For now I'm going to do it here but this could be wrong. */ codegen("%N", arg); // } else if (REQUIRES_AUTO_DEREFERENCE(arg)) { codegen("%N", arg); // as long as it doesn't cause recursion... } else { codegen("/*?*/%N", mkaddressof(arg)); } } else if (f == 'P') { // When the LVALUE is a pointer *ONLY USED IN LHS OF ASSREF* (Need to check carefully wherever this is used) gen_c( NOTNULL(arg), 1); } else if ('A' <= f && f <= 'Z') { fatalf("Unknown extended format symbol %%%c\n", f); } else { // Some of the more complex standard C formatting escapes might not be handled properly, // but something like "%03x" should be OK. We look for %, , char *p = item_format; *p++ = '%'; for (;;) { *p++ = f; if (isalpha(f)) break; f = *s++; } *p = '\0'; fprintf(stdout, item_format, arg); } } } else fprintf(stdout, "%c", c); } va_end(ap); } // The interleaving of Imp source (as comments) and generated C is *very* crude. // (I do know how to do this and did it correctly in an earlier version, but that // was as an external utility. It's more useful to be done within the translator, // but it would be a lot of code and for now this quick hack is sufficient. Where // it fails is in handling include files, and also in a few cases where code has been // moved around. This is primarily a debugging aid for me, not a feature for users) FILE *list; void insert_listing_upto(int thisline) { // no special handling of %include files yet #define BIG_BUFFER 100000 static char line[BIG_BUFFER+1]; line[BIG_BUFFER] = 0x80; // tombstone int listline = 0; int ch; if (list == NULL) return; if (ferror(list)) return; if (feof(list)) return; fprintf(stdout, "\n"); for (;;) { int s = 0; //line; int c; for (;;) { c = fgetc(list); if (c == ('K'&31)) continue; if (c == EOF) { c = '\0'; break; } if (c == '\n') break; line[s++] = c; } line[s++] = c; line[s] = '\0'; if (line[0] == '\0') break; ch = line[5]; line[5] = '\0'; if ((line[0] == ' ' || isdigit(line[0])) && (line[1] == ' ' || isdigit(line[1])) && (line[2] == ' ' || isdigit(line[2])) && (line[3] == ' ' || isdigit(line[3])) && (isdigit(line[4]))) { listline = atoi(line); } line[5] = ch; if ((((int)line[BIG_BUFFER])&0xFF) != 0x80U) /*beware byte-int sign extension*/ fatalf("corruption at genc.c:%d s=%d line[%d] = %d\n", __LINE__, s, BIG_BUFFER, line[BIG_BUFFER]); fprintf(stdout, "// %s", line); if (listline >= thisline) break; } fprintf(stdout, "\n"); return; } int lastline, thisline; char *lastfile, *thisfile; IMPAST *line; void generate_c_source(IMPAST *Program, char *list_filename) { IMPAST *this = Program; char *sourcefile = strdup(list_filename); char *ext = strrchr(sourcefile, '.'); if (this == NULL) fatalf("generate_c_source: Program == NULL!\n"); line = this->generic.line; lastfile = ""; lastline = -1; list = fopen(list_filename, "r"); // really only works for .imp files, not so much for .icd files if (strlen(sourcefile) > 4 && strcmp(sourcefile+strlen(sourcefile)-4, ".lis") == 0) { strcpy(ext, ".imp"); } blocklevel = 0; while (this != NULL) { gen_c( NOTNULL(this), 0); this = this->generic.next_icode; } } static int doing_array_init = 0; // > 0 -> use _imp_str_init macro instead of _imp_str_literal for declarations vs assignments static void gen_c_init(char *equals, char *after, IMPAST *init) { doing_array_init += 1; if (init->generic.opcode == OP_INIT) { IMPAST *data = init->init.data; if (data == NULL) { codegen("/*init->init.data == NULL*/"); } else { if (NOTNULL(data)->generic.opcode == OP_PUSHI || data->generic.opcode == OP_PUSHS || data->generic.opcode == OP_PUSHR) { codegen("%s%V", equals, data); // this would have been a bug if gen_c_init() were called for an array, but that // has now been factored out (below) and I *think* gen_c_init() is now only for // scalars, and that the 'repeats' test below can be removed. if (NOTNULL(init)->init.repeats > 1) { fatalf("OOPS. Assumption wrong in genc.c:%d\n", __LINE__-1); for (int rep = 1; rep < init->init.repeats; rep++) { codegen(", %V", data); } } codegen("%s", after); } else { codegen("%s[init.data: %s]", equals, icode_name[NOTNULL(data)->generic.opcode]); } } } else { codegen("%s[init: %s]", equals, icode_name[NOTNULL(init)->generic.opcode]); } doing_array_init -= 1; } static int array_idx = 0; // hacky global. sorry. static void gen_c_init_recurse(IMPAST *init) { // somewhat stack-heavy I'll admit but on a modern machine, not an issue. doing_array_init += 1; if (NOTNULL(init)->init.next_init != NULL) { gen_c_init_recurse( init->init.next_init); codegen(", "); } if (init->init.repeats > 1) { codegen("[%d ... %d] = %V", array_idx, array_idx+init->init.repeats-1, init->init.data); array_idx += init->init.repeats; } else { codegen("%V", init->init.data); array_idx += 1; } doing_array_init -= 1; } static void gen_c_init_array(char *equals, IMPAST *init) { array_idx = 0; doing_array_init += 1; codegen("%s {", equals); gen_c_init_recurse( NOTNULL(init)); codegen(" };\n"); doing_array_init -= 1; array_idx = 0; } static void gen_c_formal_parameter_list(IMPAST *def) { int none = 0; IMPAST *param = NULL; if (def != NULL) { if (OP(def) != OP_DEF) { fatalf("Asked to list formal parameters for a %s\n", icode_name[OP(def)]); } param = NOTNULL(def)->def.formal_params; } codegen("("); for (;;) { if (param == NULL) break; if (NOTNULL(param)->generic.opcode == OP_START) { fprintf(stderr, "? OP_START found in a parameter list\n"); param = param->generic.next_icode; // Shouldn't happen now START/FINISH have been removed. if (param == NULL) break; } if (NOTNULL(param)->generic.opcode == OP_FINISH) { fatalf("OP_FINISH found in a parameter list"); } if (param->generic.opcode != OP_ALTALT) { none += 1; // *** TO DO *** When the parameter to a procedure is itself a function, I am *almost* // outputting it correctly, but where the function name is being output, I should be // generating "(funcname *)" rather than just "funcname". Unfortunately 'param' below // is the entire parameter, so delving into that tree to find the procedure name when // outputting it in this context rather than other contexts (eg procedure definition or // forward declaration) is going to need some care in gen_c()... I may not be able to // use the 'codegen' shortcut to handle it. codegen("%N", param); } param = param->generic.next_icode; if (param == NULL) break; if ( NOTNULL(param)->generic.opcode != OP_FINISH) codegen(", "); } if (none == 0) codegen("void"); codegen(")"); } static void gen_c_recordformat(IMPAST *recordformatdef) { // This was a quick hack to get the Imp output working followed by an even quicker // hack to output C from basically the same code. What *should* be done is to // build up an AST tree of the struct/variant nodes, C-style, and output from // those. With the levels in a structure, it's easier to remove redundant union // or struct keywords from the C output. But since we're not supposed to be // generating readable C anyway, a few redundant union commands won't hurt. They're // anonymous unions and structs anyway, so don't need to be in the reference at // the point where the record field is used. But yes, I will restructure the code // a little, later, to make this cleaner. if (OP(NOTNULL(recordformatdef)) != OP_DEF) fatalf("Not a DEF at genc.c:%d\n", __LINE__); int field_idx = 0; IMPAST *param = recordformatdef->def.recordformat_field_list; codegen(" { union { struct {\n"); for (;;) { IMPAST *next; //int suppress_comma = 0; if (param == NULL) break; if (NOTNULL(param)->generic.opcode == OP_START) param = param->generic.next_icode; if (param == NULL || param->generic.opcode == OP_FINISH) break; if (param->generic.opcode == OP_ALTALT) { if (param->altalt.alttype == '(') { codegen("union { struct {\n"); } else if (param->altalt.alttype == '|') { codegen("}; struct {\n"); } else if (param->altalt.alttype == ')') { codegen("}; };\n"); next = param->altalt.next_icode; if ( next != NULL && ((NOTNULL(next)->generic.opcode == OP_ALTALT && next->altalt.alttype == '(') || next->generic.opcode == OP_DEF)) { codegen("\n"); } else { codegen("\n"); } } else { // error } //suppress_comma = 1; } else { codegen("%N;", param); field_idx += 1; next = NOTNULL(param)->generic.next_icode; //if ( next == NULL || (next->generic.opcode == OP_ALTALT && next->altalt.alttype != '(')) { // codegen(""); //} } param = NOTNULL(param)->generic.next_icode; if (param == NULL) break; if ((NOTNULL(param)->generic.opcode == OP_DEF) || (param->generic.opcode == OP_ALTALT && param->altalt.alttype == '(')) { //if (!suppress_comma) codegen(";"); } //if ( next == NULL || next->generic.opcode == OP_FINISH) { // codegen(""); //} codegen("\n "); } codegen("}; }; };\n"); } void gen_c_boundspair(IMPAST *boundspair) { if (OP(NOTNULL(boundspair)) != OP_BOUNDSPAIR) { debugf("gen_c_boundspair: OP(bounds_list) != OP_BOUNDSPAIR (%s)\n", icode_name[OP(boundspair)]); } if (boundspair == NULL) { codegen("[/*BUG* no bounds*/1]"); } else { codegen("[%V]", mkadd(mksub(boundspair->boundspair.ub, boundspair->boundspair.lb), mkiconst(1))); } } // This outputs the DECLARATION of the bounds of an array (or %namearray). The bounds // will be output in the same order as the accesses ar output, BUT the order in which // they are stored in the formal parameter list may not currently match the order that // the actual parameters are stored in the corresponding list. Clearly the better solution // is to ensure that both the formal and actual parameter lists are stored in the same order! // (and indeed ultimately I would like the actual parameter list to be pairs of // so that they never get out of sync and can be passed to OP_ASSPAR // as a unit. This probably requires the creation of a new IAST_PARAMETER tuple.) void gen_c_boundslist(IMPAST *bounds_list, int reverse_index_order) { if (bounds_list != NULL && OP(bounds_list) == OP_BOUNDSPAIR) { // ------------------------------------------------------------------------------ if (!reverse_index_order) { if (OP(bounds_list) == OP_BOUNDSPAIR) gen_c_boundspair( bounds_list); else fatalf("Assertion #1\n"); } if (bounds_list != NULL) { if (OP(bounds_list) == OP_BOUNDSPAIR) { if (bounds_list->boundspair.next_bound != NULL) { if (OP(bounds_list->boundspair.next_bound) == OP_BOUNDSPAIR) { // Remaining indices are output here: gen_c_boundslist( bounds_list->boundspair.next_bound, reverse_index_order); } else fatalf("Assertion #2.1\n"); } } else fatalf("Assertion #2.2\n"); } else fatalf("Assertion #2.3\n"); if (reverse_index_order) { if (OP(bounds_list) == OP_BOUNDSPAIR) gen_c_boundspair( bounds_list); else fatalf("Assertion #3\n"); } // ------------------------------------------------------------------------------ } else if (bounds_list == NULL) { fatalf("NULL bounds_list passed to gen_c_boundslist\n"); } else { if (OP(bounds_list) == OP_DEF) { fatalf("gen_c_boundslist: parameter was DEF %s\n", bounds_list->def.c_id); } else { fatalf("gen_c_boundslist: parameter was %s\n", icode_name[OP(bounds_list)]); } } } // ================================================================================================== // By adding "#define REVERSE_INDEX_ORDER 1" we can change the row-major/column-major // way that imp arrays are mapped to C arrays! 'REVERSE_INDEX_ORDER' being set actually // correctly mimics the way that original Imp compilers stored arrays. C stores // them the other way. However unless it becomes an issue, I'm going to use the // C layout because reversing the order of array indices in generated C code is // just too weird, and I haven't even yet looked into the way that side-effects // happen when evaluating successive indices (similar to the problems with side- // effects in evaluation of parameter lists, which C does in the opposite direction // from Imp). It might actually end up that the Imp to C translation has to reverse // all the parameters in a parameter list in the translation. Maybe only for // external routines though. The whole area is a mess. // Note I do have an imp test program which determines the actual row-/column-major // ordering at runtime so that the implementation can be checked against original-era // compilers (running under emulation): test119.imp // So if we have BASE[I1][I2][I3] then in terms of this call, // BASE[I1][I2] is the base object, and I3 is the index. // However because of the potential need to output these accesses // in reverse order, the simple implementation of 'output base' // then 'output index' where the base could itself contain indexed // arrays or record fields is not practical and a more complex // interface is needed. // However the base object is one of: // An scalar array (or array name etc) // or // A record field containing an array base object // - in the latter case, the derived/inherited type will be in base_object->select.fielddef // The other complication is that when we step through the indices, we need to // pair them up with the array bounds for each index in order to adjust the base // value of each lower:upper index (remembering that unlike C, imp arrays can // have non-zero lower bounds, not to mention that the indices have to be range-checked) // ================================================================================================== void gen_c(IMPAST *this, int suppress_newline) { IMPAST *opd1, *opd2; static int double_sided = 0; // The primary reason for structuring this as lots of calls on gen_c to output a single opcode at a time // with the caller appending the "\n", was that we wanted to handle: // %integer i // %string(255) s // differently from when they appear as formal parameters, as in: // %routine fred(%integer i, %string(255)s) if (this == NULL) return; //codegen("/*:%p*/", this); line = NOTNULL(this)->generic.line; // if (line != NULL) { if (!nulllike(line)) { thisline = NOTNULL(line)->line.lineno; thisfile = line->line.filename; //if (OP(this) == OP_ASSREF || OP(this) == OP_ASSVAL || OP(this) == OP_CALL|| (OP(this) == OP_DEF && !IS_SPEC(this))) { if (!suppress_newline) { if (line != NULL && (thisline != lastline || strcmp(thisfile, lastfile) != 0)) { insert_listing_upto(thisline); if (output_hashline) { fprintf(stdout, "\n#line %d \"%s\"\n", thisline, thisfile); } lastline = line->line.lineno; lastfile = line->line.filename; } } } int opcode = NOTNULL(this)->generic.opcode; if (opcode < 0 || opcode >= LAST_OP) { fprintf(stderr, "* showicode.c: %05d Bad opcode: %x(0x%08x)\n", this->generic.seqno, opcode, opcode); exit(EXIT_FAILURE); } switch(opcode) { case ASTOP_PERMS: if (opt_perms) { gen_c( this->perms.perms, 0); } else { codegen("#include \n"); //codegen("#define _imp_string(n) _imp_string##n\n"); } break; case ASTOP_RECFMSPEC: // Turns out that in C, unlike Imp, you do not need to forward-declare a record (struct) type // to use a pointer to one before the recordformat is fully defined! codegen("// typedef struct %s %s;\n", this->recfmspec.c_id, this->recfmspec.c_id); DEFTAG[this->recfmspec.tag] = NOTNULL(this->recfmspec.def); /* <-- if recfmspec is inserted here, the DEFTAG[] entry will still be overwritten by something in a following block... %begin %recordformat WRONG(%real R) %end */ //debugf("Setting DEFTAG[0x%04x] = DEF %05d\n", this->recfmspec.tag, this->recfmspec.def->def.seqno); break; case OP_ALTALT: // '~': { int pending = this->altalt.alttype; if ((' ' + 1 <= pending) && (pending <= '~')) { if (pending == 'A' || pending == '(') { codegen("( "); } else if (pending == 'B' || pending == ')') { codegen(" )"); } else if (pending == 'C' || pending == '|') { codegen(" %%OR "); } else { } } else { } } break; case OP_BEGIN: // 'H': /* BEGIN */ /* To handle the %return in a %begin/%end block, the easiest way was to do what IAY & PSR once did, which was make the block into an anonymous procedule and then call it after emitting the block. This surprisingly fits pretty well with Imp semantics, particularly when translated to C, because block scope for an Imp procedure is different from the block scope for something in C between "{ }" brackets. UPDATE: The trick of using anonymous procedures to allow %begin/%end blocks to implement %return by using C's "return;" statement fails when there is a jump from outside the block into the block :-( No way around that other than mapping %begin/%end blocks to "{ ... }" blocks in C, which means that %return has to be mapped to a jump to the %end ... (***TO DO***) (The entry for %return will need to implement the same sort of test as the current code for %end, to see whether it is the return from a %begin/%end block or a routine within one. So the OP_RETURN opcode will need a pointer to blockstart to be added and filled in within icode2ast.c) */ if (blocklevel == 0) { codegen("int main(int argc, char **argv) "); } else { // In Imp77, %begin/%end blocks can have a %return which skips to the end // I think this was an IAY addition, making begin/end into an anonymous procedure // rather than just a syntactical enclosure, so might as well implement it as // such, and the compiler will probably exbed or inline it anyway, making the // implementation equivalent. Not sure if I can use "inline" in C for this? static int next_begin_block = 1000; #ifdef IMPLEMENT_BLOCKS_AS_ANONYMOUS_FUNCTIONS codegen("auto void _imp_block_%0d(void);\n", next_begin_block); // blocks other than main() will be nested by definition. (GCC extnsion) codegen("_imp_block_%0d();\n", next_begin_block); codegen("void _imp_block_%0d(void) ", next_begin_block); #endif this->begin.blockno = next_begin_block; next_begin_block += 1; } codegen("{ /*%%begin*/\n"); if (blocklevel == 0) codegen("_imp_initialise(argc, argv);\n"); blocklevel += 1; IMPAST *begin = this->begin.body; //debugf("***************** BEGIN BODY ******************\n"); while (begin != NULL) { gen_c( NOTNULL(begin), 0); begin = begin->generic.next_icode; } //debugf("***************** END OF BEGIN BODY ******************\n"); blocklevel -= 1; break; case OP_END: // ';': /* END */ { IMPAST *blockstart = this->end.startblock; IMPAST *body; if (blocklevel < 0) { // end of file. codegen("/* %%endoffile */\n"); break; } else if (blockstart == NULL) { //debugf("bad blockstart\n"); break; } else if (OP(blockstart) == OP_BEGIN) { body = blockstart->begin.body; if (blocklevel <= 1) { // main program which has been converted to "int main()" if (access) { codegen(" _imp_stop(0);\n"); codegen("return 0;\n"); //codegen("/* main program is converted into int main() and needs an integer result... */\nADD_STUFF_HERE: ;\n"); access = 0; } } else { // nested %begin/%end block. Treat as an anonymous nested procedure. (Can't just surround the block with plain "{}" brackets due to scoping issues) if (access) { #ifdef IMPLEMENT_BLOCKS_AS_ANONYMOUS_FUNCTIONS codegen("return;\n"); #else if (OP(blockstart) == OP_BEGIN) codegen("goto end_%0d;\n", blockstart->begin.blockno); else codegen("return;\n"); #endif access = 0; } } } else if (OP(blockstart) == OP_DEF) { // rt/fn/map/pred: body = blockstart->def.body; if (FORM(blockstart) == F_ROUTINE) { if (access) { codegen("return;\n"); access = 0; } } else if (FORM(blockstart) == F_FN || FORM(blockstart) == F_MAP || FORM(blockstart) == F_PREDICATE) { if (access) { codegen(" _imp_signal(8, 4, 0, \"result missing\");\n"); access = 0; } } else fatalf("genc.c: Internal error at line %d (blockstart DEF not a RT/FN/MAP/PREDICATE)\n", __LINE__); } else fatalf("genc.c: Internal error at line %d (blockstart not a BEGIN or DEF - got a %s)\n", __LINE__, icode_name[OP(blockstart)]); // There in no user path through the code to this point. while (body != NULL) { if (OP(body) == OP_DEF && FORM(body) == F_SWITCH) { // Output the dispatch table for this switch. Still to add range testing and default/error labels. codegen("\ncase_%s_dispatch:\n", body->def.c_id); codegen(" if (%s_index < %d || %s_index > %d) _imp_signalf(6, 3, %s_index, \"->%s(%%d) out of bounds at %%s line %%d\", %s_index, %s_file, %s_line);\n", body->def.c_id, body->def.lower_bound, body->def.c_id, body->def.upper_bound, body->def.c_id, body->def.c_id, body->def.c_id, body->def.c_id, body->def.c_id ); codegen(" goto *%s[%s_index - %d];\n", NOTNULL(body)->def.c_id, body->def.c_id, body->def.lower_bound); access = 0; // Check the switch_list to see if all were used: int any_missing = FALSE; for (int idx = body->def.lower_bound; idx <= body->def.upper_bound; idx++) { IMPAST *slabel = body->def.switch_list[idx - body->def.lower_bound]; if (slabel == NULL) { if ( body->def.default_switch == NULL) { any_missing = TRUE; break; } } } if (any_missing) { codegen("\ncase_%s_missing: _imp_signalf(8, 2, %s_index, \"switch jump to undefined label %s(%%d): at %%s line %%d\", %s_index, %s_file, %s_line);\n", body->def.c_id, body->def.c_id, body->def.c_id, body->def.c_id, body->def.c_id, body->def.c_id ); access = 0; } } body = body->generic.next_icode; } #ifndef IMPLEMENT_BLOCKS_AS_ANONYMOUS_FUNCTIONS if (OP(blockstart) == OP_BEGIN) codegen("end_%0d:;\n", blockstart->begin.blockno); #endif codegen("}"); if (OP(blockstart) == OP_DEF) codegen(" /* end of %s */", NOTNULL(blockstart)->def.c_id); if (!suppress_newline) codegen("\n"); access = 1; } break; case OP_START: // '{': /* START */ { blocklevel += 1; } break; case OP_ALT: // '|': /* ALT */ // Only relevant to record definitions, not parameter lists. fatalf("OP_ALT unexpected\n"); //codegen(" %%OR {<%s>}", icode_name[this->generic.opcode]); break; case OP_FINISH: // '}': /* FINISH */ { blocklevel -= 1; } break; case OP_DEF: // '$': /*case 'g':*/ /* {RE}DEF TAG TEXT TYPE FORM SIZE SPEC PREFIX */ { int linkage, type, form; int special; access = 1; if (this->def.suppress) break; DEFTAG[this->def.tag] = this; linkage = this->def.linkage; type = this->def.type; form = this->def.form; special = this->def.special; switch (form) { case F_VOID: if (debug_genc) codegen("/*F_VOID*/"); fatalf("I guess case F_VOID: in genc.c actually does get called...\n"); // I'm not sure if the VOID case is ever used, I'm just including it to be safe... if (type == T_RECORD) { if (linkage == L_EXTERNAL && !IS_SPEC(this)) { // Suppress 'extern' for primary instance of external data (usually initialised but doesn't have to be.) } else codegen("%s", clinkagedesc[linkage]); codegen("%s", cspecialdesc[special]); if (!use_typedef) codegen("%s", ctypedesc[type]); int tagidx = this->def.format; IMPAST *tag = DEFTAG[tagidx]; codegen("%s ", NOTNULL(tag)->def.c_id); codegen("%s", cformdesc[form]); } else if (type == T_STRING) { if (linkage == L_EXTERNAL && !IS_SPEC(this)) { // Suppress 'extern' for primary instance of external data (usually initialised but doesn't have to be.) } else codegen("%s", clinkagedesc[linkage]); codegen("%s", cspecialdesc[special]); codegen("%s", ctypedesc[type]); int strlen = this->def.format&255; //if (strlen == 0) codegen("(*) "); else codegen("(%d) ", strlen); if (strlen == 0 /*|| strlen == 255*/) codegen(" "); else codegen("%d ", strlen); codegen("%s", cformdesc[form]); } else if (type == T_INTEGER) { if (linkage == L_EXTERNAL && !IS_SPEC(this)) { // Suppress 'extern' for primary instance of external data (usually initialised but doesn't have to be.) } else codegen("%s", clinkagedesc[linkage]); codegen("%s", cspecialdesc_integer[special]); codegen("%s", ctypedesc[type]); codegen("%s", cformdesc[form]); } else if (type == T_REAL) { if (linkage == L_EXTERNAL && !IS_SPEC(this)) { // Suppress 'extern' for primary instance of external data (usually initialised but doesn't have to be.) } else codegen("%s", clinkagedesc[linkage]); codegen("%s", cspecialdesc_real[special]); codegen("%s", ctypedesc[type]); codegen("%s", cformdesc[form]); } else { if (linkage == L_EXTERNAL && !IS_SPEC(this)) { // Suppress 'extern' for primary instance of external data (usually initialised but doesn't have to be.) // HOWEVER tests/extmain.c containing "%externalroutine main" *IS* printing "extern" in front of the procedure body! Why? ***TO DO*** } else codegen("%s", clinkagedesc[linkage]); codegen("%s", cspecialdesc[special]); codegen("%s", ctypedesc[type]); codegen("%s", cformdesc[form]); } codegen("%s", this->def.c_id); if (this->def.alias != NULL) { // Data can be aliased too. codegen(" __asm__(\"%s\") ", NOTNULL(this->def.alias)->alias.alias); } if (this->def.init != NULL) { // string initialisations may need casting... (unless I can make _imp_str_literal into a void *?) gen_c_init( " = ", "", this->def.init); } break; case F_SIMPLE: if (debug_genc) codegen("/*F_SIMPLE*/"); if (type == T_RECORD) { if (linkage == L_EXTERNAL && !IS_SPEC(this)) { // Suppress 'extern' for primary instance of external data (usually initialised but doesn't have to be.) } else codegen("%s", clinkagedesc[linkage]); codegen("%s", cspecialdesc[special]); if (!use_typedef) codegen("%s", ctypedesc[type]); int tagidx = this->def.format; IMPAST *tag = DEFTAG[tagidx]; codegen("%s ", NOTNULL(tag)->def.c_id); codegen("%s", cformdesc[form]); } else if (type == T_STRING) { if (linkage == L_EXTERNAL && !IS_SPEC(this)) { // Suppress 'extern' for primary instance of external data (usually initialised but doesn't have to be.) } else codegen("%s", clinkagedesc[linkage]); codegen("%s", cspecialdesc[special]); codegen("%s", ctypedesc[type]); int strlen = this->def.format&255; //if (strlen == 0) codegen("(*) "); else codegen("(%d) ", strlen); if (strlen == 0 /*|| strlen == 255*/) codegen(" "); else codegen("%d ", strlen); codegen("%s", cformdesc[form]); } else if (type == T_INTEGER) { if (linkage == L_EXTERNAL && !IS_SPEC(this)) { // Suppress 'extern' for primary instance of external data (usually initialised but doesn't have to be.) } else codegen("%s", clinkagedesc[linkage]); codegen("%s", cspecialdesc_integer[special]); codegen("%s", ctypedesc[type]); codegen("%s", cformdesc[form]); } else if (type == T_REAL) { if (linkage == L_EXTERNAL && !IS_SPEC(this)) { // Suppress 'extern' for primary instance of external data (usually initialised but doesn't have to be.) } else codegen("%s", clinkagedesc[linkage]); codegen("%s", cspecialdesc_real[special]); codegen("%s", ctypedesc[type]); codegen("%s", cformdesc[form]); } else { if (linkage == L_EXTERNAL && !IS_SPEC(this)) { // Suppress 'extern' for primary instance of external data (usually initialised but doesn't have to be.) } else codegen("%s", clinkagedesc[linkage]); codegen("%s", cspecialdesc[special]); codegen("%s", ctypedesc[type]); codegen("%s", cformdesc[form]); } codegen("%s", this->def.c_id); if (this->def.alias != NULL) { // Data can be aliased too. codegen(" __asm__(\"%s\") ", NOTNULL(this->def.alias)->alias.alias); } if (this->def.init != NULL) { // TO DO: If the type is a record (and I suspect the init has to be "0"), // then gen_c_init( " = { ", this->def.init); codegen(" }"); // Note that regular assignments of 0 to a struct (rather than in a declaration init) // must include a cast, eg myrec = (struct myrecfm) { 0 }; if (TYPE(this) == T_RECORD) { gen_c_init( " = { ", " }", this->def.init); } else { // string initialisations may need casting... (unless I can make _imp_str_literal into a void *?) gen_c_init( " = ", "", this->def.init); } } if (!suppress_newline) codegen(";"); // unless in a param list, in which case we want a '.'? break; case F_NAME: if (debug_genc) codegen("/*F_NAME*/"); if (type == T_RECORD) { if (linkage == L_EXTERNAL && !IS_SPEC(this)) { // Suppress 'extern' for primary instance of external data (usually initialised but doesn't have to be.) } else codegen("%s", clinkagedesc[linkage]); codegen("%s", cspecialdesc[special]); if (!use_typedef) codegen("%s", ctypedesc[type]); int tagidx = this->def.format; IMPAST *tag = NOTNULL(DEFTAG[tagidx]); codegen("%s", tag != NULL ? tag->def.c_id : "?"); if (debug_genc) codegen(" {tag=0x%04x}", this->def.format); codegen(" "); codegen("%s", cformdesc[form]); } else if (type == T_STRING) { if (linkage == L_EXTERNAL && !IS_SPEC(this)) { // Suppress 'extern' for primary instance of external data (usually initialised but doesn't have to be.) } else codegen("%s", clinkagedesc[linkage]); codegen("%s", cspecialdesc[special]); codegen("%s", ctypedesc[type]); int strlen = this->def.format&255; //if (strlen == 0) codegen("(*) "); else codegen("(%d) ", strlen); if (strlen == 0 /*|| strlen == 255*/) codegen(" "); else codegen("%d ", strlen); codegen("%s", cformdesc[form]); } else if (type == T_INTEGER) { if (linkage == L_EXTERNAL && !IS_SPEC(this)) { // Suppress 'extern' for primary instance of external data (usually initialised but doesn't have to be.) } else codegen("%s", clinkagedesc[linkage]); codegen("%s", cspecialdesc_integer[special]); codegen("%s", ctypedesc[type]); codegen("%s", cformdesc[form]); } else if (type == T_REAL) { if (linkage == L_EXTERNAL && !IS_SPEC(this)) { // Suppress 'extern' for primary instance of external data (usually initialised but doesn't have to be.) } else codegen("%s", clinkagedesc[linkage]); codegen("%s", cspecialdesc_real[special]); codegen("%s", ctypedesc[type]); codegen("%s", cformdesc[form]); } else { if (linkage == L_EXTERNAL && !IS_SPEC(this)) { // Suppress 'extern' for primary instance of external data (usually initialised but doesn't have to be.) } else codegen("%s", clinkagedesc[linkage]); codegen("%s", cspecialdesc[special]); codegen("%s", ctypedesc[type]); codegen("%s", cformdesc[form]); } codegen("%s", this->def.c_id); if (this->def.alias != NULL) { // Data can be aliased too. codegen(" __asm__(\"%s\") ", NOTNULL(this->def.alias)->alias.alias); } if (this->def.init != NULL) { // string initialisations may need casting... (unless I can make _imp_str_literal into a void *?) gen_c_init( " = ", "", this->def.init); } if (!suppress_newline) codegen(";"); // unless in a param list, in which case we want a '.'? break; case F_LABEL: if (debug_genc) codegen("/*F_LABEL*/"); codegen("%s", clinkagedesc[linkage]); codegen("%s", cspecialdesc[special]); //codegen("%s", ctypedesc[type]); // don't want _imp_name __label__ codegen("%s", cformdesc[form]); codegen("%s", this->def.c_id); codegen(";"); break; case F_RECORDFORMAT: if (debug_genc) codegen("/*F_RECORDFORMAT*/"); // *** TO DO ***: If any of the fields in this recordformat require reinstatement of a missing %recordformatspec, it should be done here! codegen("%s", clinkagedesc[linkage]); codegen("%s", cspecialdesc[special]); codegen("%s", cformdesc[form]); codegen("%s", this->def.c_id); // myself, remember to *not* output the body: if (this->def.recordformat_field_list != NULL /* && !IS_SPEC(this) */) { gen_c_recordformat( this); } else { codegen("; /*CHECKME1*/\n"); } break; case F_SWITCH: if (debug_genc) codegen("/*F_SWITCH*/"); /* e.g: static const void *reason[ 10 ] = { &&reason_0, &&reason_1, &&reason_2, &&reason_3, &&reason_4, &&reason_5, &&reason_6, &&reason_7, &&reason_8, &&reason_9, }; */ /* TO DO: generate an index variable for use at time of dispatch to assist in better error messages when destination label not present Also add sw%d_ prefix to label array as well as the individual labels to help with block scope issues - this will probably have to be done in icode2ast.c as the ICodes are loaded. static int sw1_INS_idx; static const void *sw1_INS[31] */ codegen("int %s_index;\nint %s_line;\nchar *%s_file;\n", this->def.c_id, this->def.c_id, this->def.c_id); codegen("static const void *%s%V", this->def.c_id, this->def.bounds_list); if (this->def.init != NULL) { // string initialisations may need casting... (unless I can make _imp_str_literal into a void *?) gen_c_init_array( " = ", this->def.init); } else { codegen(" = { "); // needs an init list like a const array except output as "&&lab". NULL placeholder during development. for (int idx = this->def.lower_bound; idx <= this->def.upper_bound; idx++) { IMPAST *slabel = this->def.switch_list[idx - this->def.lower_bound]; if (slabel == NULL) { if ( this->def.default_switch != NULL) { codegen("&&case_%s_default", this->def.c_id); } else { codegen("&&case_%s_missing", this->def.c_id); } } else { if (OP(slabel->slabel.index) == OP_PUSHI && slabel->slabel.index->pushi.value < 0) { codegen("&&case_%s_M%0d", this->def.c_id, -slabel->slabel.index->pushi.value); } else { codegen("&&case_%s_%0d", this->def.c_id, slabel->slabel.index->pushi.value); } } if (idx != this->def.upper_bound) codegen(", "); } codegen(" };\n"); // When we get an SLABEL in stack.c, attach that label to the INIT field of the corresponding switch. } break; case F_ROUTINE: if (debug_genc) codegen("/*F_ROUTINE*/"); // TO DO: if (!IS_SPEC(this) && this->def.alias != NULL) then it's a body, so before we start outputting the body, // we need to temporarily set the spec flag, recursively output 'this', then remove the spec flag again and continue! if (linkage == L_AUTO && blocklevel == 0) linkage = L_OWN; // static if (linkage == L_AUTO && IS_SPEC(this) && !suppress_newline) codegen("auto "); if (linkage == L_EXTERNAL && !IS_SPEC(this)) { } else if (!suppress_newline) codegen("%s", clinkagedesc[linkage]); codegen("%s", cspecialdesc[special]); // codegen("%s", ctypedesc[type]); // We don't want _imp_name void procname() !!! codegen("%s", cformdesc[form]); if (suppress_newline) { codegen("(*%s)", this->def.c_id); } else { codegen("%s", this->def.c_id); } gen_c_formal_parameter_list( this); if (IS_SPEC(this) && this->def.alias != NULL) { // TO DO: an alias on a procedure body needs a spec to come first. codegen(" __asm__(\"%s\") ", this->def.alias->alias.alias); } if (IS_SPEC(this)) { codegen(";"); } else { if (!suppress_newline) codegen(" {"); // being used in a parameter list } if (!suppress_newline) codegen("\n"); break; case F_FN: if (debug_genc) codegen("/*F_FN*/"); // TO DO: if (!IS_SPEC(this) && this->def.alias != NULL) then it's a body, so before we start outputting the body, // we need to temporarily set the spec flag, recursively output 'this', then remove the spec flag again and continue! if (linkage == L_AUTO && blocklevel == 0) linkage = L_OWN; // static if (linkage == L_AUTO && IS_SPEC(this) && !suppress_newline) codegen("auto "); if (type == T_RECORD) { if (linkage == L_EXTERNAL && !IS_SPEC(this)) { } else if (!suppress_newline) codegen("%s", clinkagedesc[linkage]); codegen("%s", cspecialdesc[special]); if (!use_typedef) codegen("%s", ctypedesc[type]); int tagidx = this->def.format; IMPAST *tag = NOTNULL(DEFTAG[tagidx]); codegen("%s ", tag->def.c_id); codegen("%s", cformdesc[form]); } else if (type == T_STRING) { if (linkage == L_EXTERNAL && !IS_SPEC(this)) { } else if (!suppress_newline) codegen("%s", clinkagedesc[linkage]); codegen("%s", cspecialdesc[special]); codegen("%s", ctypedesc[type]); int strlen = this->def.format&255; //if (strlen == 0) codegen("(*) "); else codegen("(%d) ", strlen); if (strlen == 0 /*|| strlen == 255*/) codegen(" "); else codegen("%d ", strlen); codegen("%s", cformdesc[form]); } else if (type == T_INTEGER) { if (linkage == L_EXTERNAL && !IS_SPEC(this)) { // Suppress 'extern' for primary instance of external data (usually initialised but doesn't have to be.) } else if (!suppress_newline) codegen("%s", clinkagedesc[linkage]); codegen("%s", cspecialdesc_integer[special]); codegen("%s", ctypedesc[type]); codegen("%s", cformdesc[form]); } else if (type == T_REAL) { if (linkage == L_EXTERNAL && !IS_SPEC(this)) { } else if (!suppress_newline) codegen("%s", clinkagedesc[linkage]); codegen("%s", cspecialdesc_real[special]); codegen("%s", ctypedesc[type]); codegen("%s", cformdesc[form]); } else { if (linkage == L_EXTERNAL && !IS_SPEC(this)) { } else if (!suppress_newline) codegen("%s", clinkagedesc[linkage]); codegen("%s", cspecialdesc[special]); codegen("%s", ctypedesc[type]); codegen("%s", cformdesc[form]); } // Assuming that 'suppress newline' corresponds to passing a fn definition as a procedure parameter, // this hack *might* fix the remaining problem with those. If not, we'll need some global flag to // know when we're in a parameter list already... if (suppress_newline) { codegen("(*%s)", this->def.c_id); /* That worked. Still have these to add: %routine do fn(%integerfn fred(%integer i)) %integer x x = fred(1) %end %routine do proc(%routine fred(%integer i)) fred(1) %end %routine do map(%integermap fred(%integer i)) fred(1) = 1 %end %routine do pred(%predicate fred(%integer i)) %return %if fred(1) %end */ } else { codegen("%s", this->def.c_id); } gen_c_formal_parameter_list( this); if (IS_SPEC(this) && this->def.alias != NULL) { // TO DO: an alias on a procedure body needs a spec to come first. codegen(" __asm__(\"%s\") ", this->def.alias->alias.alias); } if (IS_SPEC(this)) { codegen(";"); } else { if (!suppress_newline) codegen(" {"); // being used in a parameter list } if (!suppress_newline) codegen("\n"); break; case F_MAP: if (debug_genc) codegen("/*F_MAP*/"); // TO DO: if (!IS_SPEC(this) && this->def.alias != NULL) then it's a body, so before we start outputting the body, // we need to temporarily set the spec flag, recursively output 'this', then remove the spec flag again and continue! if (linkage == L_AUTO && blocklevel == 0) linkage = L_OWN; // static if (linkage == L_AUTO && IS_SPEC(this) && !suppress_newline) codegen("auto "); if (type == T_RECORD) { if (linkage == L_EXTERNAL && !IS_SPEC(this)) { } else if (!suppress_newline) codegen("%s", clinkagedesc[linkage]); codegen("%s", cspecialdesc[special]); if (!use_typedef) codegen("%s", ctypedesc[type]); int tagidx = this->def.format; IMPAST *tag = NOTNULL(DEFTAG[tagidx]); codegen("%s ", tag->def.c_id); codegen("%s", cformdesc[form]); } else if (type == T_STRING) { if (linkage == L_EXTERNAL && !IS_SPEC(this)) { } else if (!suppress_newline) codegen("%s", clinkagedesc[linkage]); codegen("%s", cspecialdesc[special]); codegen("%s", ctypedesc[type]); int strlen = this->def.format&255; //if (strlen == 0) codegen("(*) "); else codegen("(%d) ", strlen); if (strlen == 0 /*|| strlen == 255*/) codegen(" "); else codegen("%d ", strlen); codegen("%s", cformdesc[form]); } else if (type == T_INTEGER) { if (linkage == L_EXTERNAL && !IS_SPEC(this)) { // Suppress 'extern' for primary instance of external data (usually initialised but doesn't have to be.) } else if (!suppress_newline) codegen("%s", clinkagedesc[linkage]); codegen("%s", cspecialdesc_integer[special]); codegen("%s", ctypedesc[type]); codegen("%s", cformdesc[form]); } else if (type == T_REAL) { if (linkage == L_EXTERNAL && !IS_SPEC(this)) { } else if (!suppress_newline) codegen("%s", clinkagedesc[linkage]); codegen("%s", cspecialdesc_real[special]); codegen("%s", ctypedesc[type]); codegen("%s", cformdesc[form]); } else { if (linkage == L_EXTERNAL && !IS_SPEC(this)) { } else if (!suppress_newline) codegen("%s", clinkagedesc[linkage]); codegen("%s", cspecialdesc[special]); codegen("%s", ctypedesc[type]); codegen("%s", cformdesc[form]); } if (suppress_newline) { codegen("(*%s)", this->def.c_id); } else { codegen("%s", this->def.c_id); } gen_c_formal_parameter_list( this); if (!suppress_newline) codegen("\n"); if (IS_SPEC(this) && this->def.alias != NULL) { // TO DO: an alias on a procedure body needs a spec to come first. codegen(" __asm__(\"%s\") ", this->def.alias->alias.alias); } if (IS_SPEC(this)) { codegen(";"); } else { if (!suppress_newline) codegen(" {"); // being used in a parameter list } if (!suppress_newline) codegen("\n"); break; case F_PREDICATE: if (debug_genc) codegen("/*F_PREDICATE*/"); // TO DO: if (!IS_SPEC(this) && this->def.alias != NULL) then it's a body, so before we start outputting the body, // we need to temporarily set the spec flag, recursively output 'this', then remove the spec flag again and continue! if (linkage == L_AUTO && blocklevel == 0) linkage = L_OWN; // static if (linkage == L_AUTO && IS_SPEC(this) && !suppress_newline) codegen("auto "); if (linkage == L_EXTERNAL && !IS_SPEC(this)) { } else if (!suppress_newline) codegen("%s", clinkagedesc[linkage]); codegen("%s", cspecialdesc[special]); //codegen("%s", ctypedesc[type]); // don't want _imp_name int Predicate() ! codegen("%s", cformdesc[form]); if (suppress_newline) { codegen("(*%s)", this->def.c_id); } else { codegen("%s", this->def.c_id); } gen_c_formal_parameter_list( this); if (IS_SPEC(this) && this->def.alias != NULL) { // TO DO: an alias on a procedure body needs a spec to come first. codegen(" __asm__(\"%s\") ", this->def.alias->alias.alias); } if (IS_SPEC(this)) { codegen(";"); } else { if (!suppress_newline) codegen(" {"); // being used in a parameter list } if (!suppress_newline) codegen("\n"); break; case F_ARRAY: if (debug_genc) codegen("/*F_ARRAY*/"); if (type == T_RECORD) { if (linkage == L_EXTERNAL && !IS_SPEC(this)) { // Suppress 'extern' for primary instance of external data (usually initialised but doesn't have to be.) } else codegen("%s", clinkagedesc[linkage]); codegen("%s", cspecialdesc[special]); if (!use_typedef) codegen("%s", ctypedesc[type]); int tagidx = this->def.format; IMPAST *tag = NOTNULL(DEFTAG[tagidx]); codegen("%s ", tag->def.c_id); if (debug_genc) codegen(" {tag=0x%04x}", this->def.format); codegen("%s", cformdesc[form]); } else if (type == T_STRING) { if (linkage == L_EXTERNAL && !IS_SPEC(this)) { // Suppress 'extern' for primary instance of external data (usually initialised but doesn't have to be.) } else codegen("%s", clinkagedesc[linkage]); codegen("%s", cspecialdesc[special]); codegen("%s", ctypedesc[type]); int strlen = this->def.format&255; //if (strlen == 0) codegen("(*) "); else codegen("(%d) ", strlen); if (strlen == 0 /*|| strlen == 255*/) codegen(" "); else codegen("%d ", strlen); codegen("%s", cformdesc[form]); } else if (type == T_INTEGER) { if (linkage == L_EXTERNAL && !IS_SPEC(this)) { // Suppress 'extern' for primary instance of external data (usually initialised but doesn't have to be.) } else codegen("%s", clinkagedesc[linkage]); codegen("%s", cspecialdesc_integer[special]); codegen("%s", ctypedesc[type]); codegen("%s", cformdesc[form]); } else if (type == T_REAL) { if (linkage == L_EXTERNAL && !IS_SPEC(this)) { // Suppress 'extern' for primary instance of external data (usually initialised but doesn't have to be.) } else codegen("%s", clinkagedesc[linkage]); codegen("%s", cspecialdesc_real[special]); codegen("%s", ctypedesc[type]); codegen("%s", cformdesc[form]); } else { if (linkage == L_EXTERNAL && !IS_SPEC(this)) { // Suppress 'extern' for primary instance of external data (usually initialised but doesn't have to be.) } else codegen("%s", clinkagedesc[linkage]); codegen("%s", cspecialdesc[special]); codegen("%s", ctypedesc[type]); codegen("%s", cformdesc[form]); } codegen("%s", this->def.c_id); { IMPAST *bounds_list = this->def.bounds_list; if (OP(bounds_list) != OP_BOUNDSPAIR) fatalf("array bounds not OP_BOUNDSPAIR"); // To support the correct row-/column-major layout of arrays in memory, // we would have to declare array bounds in the opposite order (and handle // accesses to them in reverse order as well.) The code for handling // accesses is in place and the code to reverse the declaration order // is currently being implemented by gen_c_boundslist below: //debugf("F_ARRAY: gen_c_boundslist( this);\n"); gen_c_boundslist( bounds_list, reverse_index_order); } if (this->def.alias != NULL) { // Data can be aliased too. codegen(" __asm__(\"%s\") ", NOTNULL(this->def.alias)->alias.alias); } if (this->def.init != NULL) { // string initialisations may need casting... (unless I can make _imp_str_literal into a void *?) gen_c_init_array( " = ", this->def.init); } else { if (!suppress_newline) codegen(";"); // unless in a param list, in which case we want a '.'? } break; case F_ARRAY_NAME: if (debug_genc) codegen("/*F_ARRAY_NAME*/"); if (type == T_RECORD) { if (linkage == L_EXTERNAL && !IS_SPEC(this)) { // Suppress 'extern' for primary instance of external data (usually initialised but doesn't have to be.) } else codegen("%s", clinkagedesc[linkage]); codegen("%s", cspecialdesc[special]); if (!use_typedef) codegen("%s", ctypedesc[type]); int tagidx = this->def.format; IMPAST *tag = NOTNULL(DEFTAG[tagidx]); codegen("%s ", tag->def.c_id); codegen("%s", cformdesc[form]); } else if (type == T_STRING) { if (linkage == L_EXTERNAL && !IS_SPEC(this)) { // Suppress 'extern' for primary instance of external data (usually initialised but doesn't have to be.) } else codegen("%s", clinkagedesc[linkage]); codegen("%s", cspecialdesc[special]); codegen("%s", ctypedesc[type]); int strlen = this->def.format&255; //if (strlen == 0) codegen("(*) "); else codegen("(%d) ", strlen); if (strlen == 0 /*|| strlen == 255*/) codegen(" "); else codegen("%d ", strlen); codegen("%s", cformdesc[form]); } else if (type == T_INTEGER) { if (linkage == L_EXTERNAL && !IS_SPEC(this)) { // Suppress 'extern' for primary instance of external data (usually initialised but doesn't have to be.) } else codegen("%s", clinkagedesc[linkage]); codegen("%s", cspecialdesc_integer[special]); codegen("%s", ctypedesc[type]); codegen("%s", cformdesc[form]); } else if (type == T_REAL) { if (linkage == L_EXTERNAL && !IS_SPEC(this)) { // Suppress 'extern' for primary instance of external data (usually initialised but doesn't have to be.) } else codegen("%s", clinkagedesc[linkage]); codegen("%s", cspecialdesc_real[special]); codegen("%s", ctypedesc[type]); codegen("%s", cformdesc[form]); } else { if (linkage == L_EXTERNAL && !IS_SPEC(this)) { // Suppress 'extern' for primary instance of external data (usually initialised but doesn't have to be.) } else codegen("%s", clinkagedesc[linkage]); codegen("%s", cspecialdesc[special]); codegen("%s", ctypedesc[type]); codegen("%s", cformdesc[form]); } if (this->def.dims > 1) { //codegen("/* %%array (%d) %%name */ ", this->def.dims); } else { //codegen("/* %%array %%name */ "); } codegen("%s", this->def.c_id); if (this->def.alias != NULL) { // Data can be aliased too. codegen(" __asm__(\"%s\") ", NOTNULL(this->def.alias)->alias.alias); } if (!suppress_newline) codegen(";"); // unless in a param list, in which case we want a '.'? break; case F_NAME_ARRAY: if (debug_genc) codegen("/*F_NAME_ARRAY*/"); if (type == T_RECORD) { if (linkage == L_EXTERNAL && !IS_SPEC(this)) { // Suppress 'extern' for primary instance of external data (usually initialised but doesn't have to be.) } else codegen("%s", clinkagedesc[linkage]); codegen("%s", cspecialdesc[special]); if (!use_typedef) codegen("%s", ctypedesc[type]); int tagidx = this->def.format; IMPAST *tag = NOTNULL(DEFTAG[tagidx]); codegen("%s ", tag->def.c_id); codegen("%s", cformdesc[form]); } else if (type == T_STRING) { if (linkage == L_EXTERNAL && !IS_SPEC(this)) { // Suppress 'extern' for primary instance of external data (usually initialised but doesn't have to be.) } else codegen("%s", clinkagedesc[linkage]); codegen("%s", cspecialdesc[special]); codegen("%s", ctypedesc[type]); int strlen = this->def.format&255; //if (strlen == 0) codegen("(*) "); else codegen("(%d) ", strlen); if (strlen == 0 /*|| strlen == 255*/) codegen(" "); else codegen("%d ", strlen); codegen("%s", cformdesc[form]); } else if (type == T_INTEGER) { if (linkage == L_EXTERNAL && !IS_SPEC(this)) { // Suppress 'extern' for primary instance of external data (usually initialised but doesn't have to be.) } else codegen("%s", clinkagedesc[linkage]); codegen("%s", cspecialdesc_integer[special]); codegen("%s", ctypedesc[type]); codegen("%s", cformdesc[form]); } else if (type == T_REAL) { if (linkage == L_EXTERNAL && !IS_SPEC(this)) { // Suppress 'extern' for primary instance of external data (usually initialised but doesn't have to be.) } else codegen("%s", clinkagedesc[linkage]); codegen("%s", cspecialdesc_real[special]); codegen("%s", ctypedesc[type]); codegen("%s", cformdesc[form]); } else { if (linkage == L_EXTERNAL && !IS_SPEC(this)) { // Suppress 'extern' for primary instance of external data (usually initialised but doesn't have to be.) } else codegen("%s", clinkagedesc[linkage]); codegen("%s", cspecialdesc[special]); codegen("%s", ctypedesc[type]); codegen("%s", cformdesc[form]); } codegen("%s", this->def.c_id); if (this->def.alias != NULL) { // Data can be aliased too. codegen(" __asm__(\"%s\") ", NOTNULL(this->def.alias)->alias.alias); } { IMPAST *bounds_list = this->def.bounds_list; if (OP(bounds_list) != OP_BOUNDSPAIR) fatalf("array bounds not OP_BOUNDSPAIR"); // To support the correct row-/column-major layout of arrays in memory, // we would have to declare array bounds in the opposite order (and handle // accesses to them in reverse order as well.) The code for handling // accesses is in place and the code to reverse the declaration order // is currently being implemented by gen_c_boundslist below: //debugf("F_NAME_ARRAY: gen_c_boundslist( bounds_list);\n"); gen_c_boundslist( bounds_list, reverse_index_order); } if (this->def.alias != NULL) { // Data can be aliased too. codegen(" __asm__(\"%s\") ", NOTNULL(this->def.alias)->alias.alias); } if (this->def.init != NULL) { // string initialisations may need casting... (unless I can make _imp_str_literal into a void *?) gen_c_init_array( " = ", this->def.init); } else { if (!suppress_newline) codegen(";"); // unless in a param list, in which case we want a '.'? } break; case F_NAME_ARRAY_NAME: // TO DO: These are coming through as " * " but should they be perhaps " ** " or " * []" ? if (debug_genc) codegen("/*F_NAME_ARRAY_NAME*/"); if (type == T_RECORD) { if (linkage == L_EXTERNAL && !IS_SPEC(this)) { // Suppress 'extern' for primary instance of external data (usually initialised but doesn't have to be.) } else codegen("%s", clinkagedesc[linkage]); codegen("%s", cspecialdesc[special]); if (!use_typedef) codegen("%s", ctypedesc[type]); int tagidx = this->def.format; IMPAST *tag = NOTNULL(DEFTAG[tagidx]); codegen("%s ", tag->def.c_id); codegen("%s", cformdesc[form]); } else if (type == T_STRING) { if (linkage == L_EXTERNAL && !IS_SPEC(this)) { // Suppress 'extern' for primary instance of external data (usually initialised but doesn't have to be.) } else codegen("%s", clinkagedesc[linkage]); codegen("%s", cspecialdesc[special]); codegen("%s", ctypedesc[type]); int strlen = this->def.format&255; //if (strlen == 0) codegen("(*) "); else codegen("(%d) ", strlen); if (strlen == 0 /*|| strlen == 255*/) codegen(" "); else codegen("%d ", strlen); codegen("%s", cformdesc[form]); } else if (type == T_INTEGER) { if (linkage == L_EXTERNAL && !IS_SPEC(this)) { // Suppress 'extern' for primary instance of external data (usually initialised but doesn't have to be.) } else codegen("%s", clinkagedesc[linkage]); codegen("%s", cspecialdesc_integer[special]); codegen("%s", ctypedesc[type]); codegen("%s", cformdesc[form]); } else if (type == T_REAL) { if (linkage == L_EXTERNAL && !IS_SPEC(this)) { // Suppress 'extern' for primary instance of external data (usually initialised but doesn't have to be.) } else codegen("%s", clinkagedesc[linkage]); codegen("%s", cspecialdesc_real[special]); codegen("%s", ctypedesc[type]); codegen("%s", cformdesc[form]); } else { if (linkage == L_EXTERNAL && !IS_SPEC(this)) { // Suppress 'extern' for primary instance of external data (usually initialised but doesn't have to be.) } else codegen("%s", clinkagedesc[linkage]); codegen("%s", cspecialdesc[special]); codegen("%s", ctypedesc[type]); codegen("%s", cformdesc[form]); } // Added '*' to % %name %array %name declarations: if (this->def.dims > 1) { //codegen("/* %%name %%array (%d) %%name */", this->def.dims); codegen(" *"); } else { //codegen("/* %%name %%array %%name */"); codegen(" *"); } codegen("%s", this->def.c_id); if (this->def.alias != NULL) { // Data can be aliased too. codegen(" __asm__(\"%s\") ", NOTNULL(this->def.alias)->alias.alias); } if (this->def.init != NULL) { // string initialisations may need casting... (unless I can make _imp_str_literal into a void *?) gen_c_init( " = ", "", this->def.init); } if (!suppress_newline) codegen(";"); // unless in a param list, in which case we want a '.'? break; case F_EXPR: // not yet used, might never be? If I do, it will be in set_type for type propogation... if (debug_genc) codegen("/*F_EXPR*/"); break; } char extra[1024]; extra[0] = '\0'; if (this->def.alias != NULL) sprintf(extra+strlen(extra), "(LINKAGE: \"%s\") ", NOTNULL(this->def.alias)->alias.alias); if (this->def.formal_params != NULL) sprintf(extra+strlen(extra), "Params=%05d ", NOTNULL(this->def.formal_params)->generic.seqno); if (debug_genc) fprintf(stdout, "\n%s! %s %s %stag=0x%04x (UNIQUE_TAG=0x%04x) a/tf=0x%04x b/format=0x%04x c/ostate=0x%04x" " type=%d (%s) form=%d (%s) special=%d (%s)" " linkage=%d (%s) spec=%d indirect=%d no_unass_check=%d", indent(suppress_newline, blocklevel), icode_name[opcode], this->def.c_id, extra, this->def.tag, this->def.unique_tag, this->def.tf, this->def.format, this->def.ostate, type, typedesc[type], form, formdesc[form], special, specialdesc[special], linkage, linkagedesc[linkage], IS_SPEC(this), IS_INDIRECT(this), NO_UNASS_CHECK(this)); extra[0] = '\0'; //if (IS_PROCEDURE(this) && !IS_SPEC(this)) codegen(" {lev=%d --> %d}", blocklevel-1, blocklevel); // surely should be blocklevel-1, blocklevel but this seems to match whats expected??? if (debug_genc) { if (this->def.init != NULL) codegen(" (INIT=%05d)", this->def.init->generic.seqno ); if (this->def.formal_params != NULL) codegen(" (PARAMS=%05d)", this->def.formal_params->generic.seqno ); if (this->def.body != NULL) codegen(" (BODY=%05d)", this->def.body->generic.seqno ); if (this->def.recordformatdef != NULL) codegen(" (RECORDFORMATDEF=%05d)", this->def.recordformatdef->generic.seqno); if (this->def.recordformat_field_list != NULL) codegen(" (RECORDFORMATFIELDS=%05d)", this->def.recordformat_field_list->generic.seqno); } if (!suppress_newline) codegen("\n"); if (IS_PROCEDURE(this) && !IS_SPEC(this)) { // perhaps also !IS_INDIRECT because of procedure parameters? blocklevel += 1; //debugf("***************** DEF BODY ******************\n"); IMPAST *body = this->def.body; while (body != NULL) { gen_c( body, 0); body = body->generic.next_icode; } //debugf("***************** END OF DEF BODY ******************\n"); blocklevel -= 1; } } break; case OP_JUMPIFD: // '"': /* JUMPIFD cond label */ // TO DO: If the middle term of a double-sided condition has side-effects, we // need to save that middle term to a temporary variable first. double_sided = 1; // could set this conditionally depending on whether // this->jumpifd.opd2 includes any functions or maps. // Note: not just at the top level, they could appear // in array indices which themselves could be deep in // the tree under record fields... if (double_sided) { codegen("{\n"); codegen("// Double-sided test on %N (Part I)\n", this->jumpifd.opd2); gen_c_type(this->jumpifd.opd2); if (TYPE(this->jumpifd.opd2) == T_STRING) codegen(" *"); else codegen(" "); codegen("tmp;\n"); if (TYPE(this->jumpifd.opd1) == T_STRING || TYPE(this->jumpifd.opd2) == T_STRING) { if (exprdepth++ == 0) codegen("\n/* clang-format off */\n"); codegen("if (_imp_strcmp((_imp_string *)%A, (_imp_string *)(tmp=%A)) %s 0) goto %s;\n", this->jumpifd.opd1, this->jumpifd.opd2, c_value_comparision[this->jumpifd.cond], this->jumpifd.printable_label); if (--exprdepth == 0) codegen("\n/* clang-format on */\n"); break; } else { codegen("if (%V %s (tmp=%V)) goto %s;\n", this->jumpifd.opd1, c_value_comparision[this->jumpifd.cond], this->jumpifd.opd2, this->jumpifd.printable_label); } } else { codegen("if (%V %s %V) goto %s;\n", this->jumpifd.opd1, c_value_comparision[this->jumpifd.cond], this->jumpifd.opd2, this->jumpifd.printable_label); } break; case OP_JUMPIF: // '?': /* JUMPIF cond label */ if (TYPE(this->jumpif.opd1) == T_STRING || TYPE(this->jumpif.opd2) == T_STRING) { if (exprdepth++ == 0) codegen("\n/* clang-format off */\n"); if (double_sided) { codegen("// Double-sided test on %N (Part II)\n", this->jumpifd.opd1); codegen("if (_imp_strcmp((_imp_string *)tmp, (_imp_string *)%A) %s 0) goto %s;\n}\n", this->jumpif.opd2, c_value_comparision[this->jumpif.cond], this->jumpif.printable_label); double_sided = 0; } else { codegen("if (_imp_strcmp((_imp_string *)%A, (_imp_string *)%A) %s 0) goto %s;\n", this->jumpif.opd1, this->jumpif.opd2, c_value_comparision[this->jumpif.cond], this->jumpif.printable_label); } if (--exprdepth == 0) codegen("\n/* clang-format on */\n"); } else { if (double_sided) { codegen("// Double-sided test on %N (Part II)\n", this->jumpifd.opd1); codegen("if (tmp %s %V) goto %s;\n}\n", c_value_comparision[this->jumpif.cond], this->jumpif.opd2, this->jumpif.printable_label); double_sided = 0; } else { codegen("if (%V %s %V) goto %s;\n", NOTNULL(this)->jumpif.opd1, c_value_comparision[this->jumpif.cond], this->jumpif.opd2, this->jumpif.printable_label); } } break; case OP_JUMPIFA: // 'C': /* JUMPIFA cond label */ if (exprdepth++ == 0) codegen("\n/* clang-format off */\n"); if (OP(this->jumpifa.opd1) == OP_PUSHI) { codegen("if (%d", this->jumpifa.opd1->pushi.value); } else { codegen("if (_imp_ADDR((void *)(%A))", this->jumpifa.opd1); } codegen(" %s ", c_name_comparision[this->jumpifa.cond]); if (OP(this->jumpifa.opd2) == OP_PUSHI) { codegen("%d) goto %s;\n", this->jumpifa.opd2->pushi.value, this->jumpifa.printable_label); } else { codegen("_imp_ADDR((void *)(%A))) goto %s;\n", this->jumpifa.opd2, this->jumpifa.printable_label); } if (--exprdepth == 0) codegen("\n/* clang-format on */\n"); break; case OP_BF: // 'k': /* BF label */ codegen("if (!(%V)) goto %s;\n", this->bf.opd, this->bf.printable_label); break; case OP_BT: // 't': /* BT label */ codegen("if (%V) goto %s;\n", this->bt.opd, this->bt.printable_label); break; case OP_PUSHS: // '\'': /* PUSHS sconst */ { char *s = this->pushs.string_value; int maxstring = this->pushs.maxstring; if (maxstring == 0) maxstring = 255; if (doing_array_init == 0) { if (maxstring != 255) { codegen("_imp_str_literal_size(%d, \"", maxstring); } else { codegen("_imp_str_literal(\""); } } else { codegen("_imp_str_init(\""); } for (;;) { int c = *s++; if (c == '\0') break; if (c == '"') { codegen("\\%c", '"'); } else if (c == '\n') { codegen("\\n"); } else if (c == '\\') { codegen("\\\\"); } else { codegen("%c", c); } } codegen("\")"); } break; case OP_PUSHR: // 'D': /* PUSHR rconst */ codegen("%s", this->pushr.str); if (this->pushr.exponent != 0) { codegen("E%0d", (int)(signed short)(this->pushr.exponent)); } break; case OP_PUSHI: // 'N': /* PUSHI iconst */ if (this->pushi.value < 0) { //codegen("(%0d)", (int)this->pushi.value); codegen(" %0d", (int)this->pushi.value); } else { codegen("%0d", (int)this->pushi.value); } break; case OP_LOCATE: // ':': /* LOCATE label */ codegen("%s:;", this->locate.printable_label); if (!suppress_newline) codegen("\n"); access = 1; break; case OP_GOTO: // 'F': /* GOTO label */ codegen("goto %s;", this->igoto.printable_label); if (!suppress_newline) codegen("\n"); access = 0; break; case OP_JUMP: // 'J': /* JUMP label */ codegen("goto %s;", this->jump.printable_label); if (!suppress_newline) codegen("\n"); access = 0; break; case OP_LABEL: // 'L': /* LABEL label */ codegen("%s:;", this->label.printable_label); if (!suppress_newline) codegen("\n"); access = 1; break; case OP_FOR: // 'f': /* FOR label (label was missing from thesis description) */ // This might be better handled by modifying the AST rather than doing it on output? { // top-level statement int initial_is_constant = 0, increment_is_constant = 0, final_is_constant = 0; if (this->ifor.control == NULL || this->ifor.initial == NULL || this->ifor.final == NULL || this->ifor.increment == NULL) { fatalf("Incomplete for loop at genc.c:%d\n", __LINE__); } if (OP(this->ifor.initial) == OP_PUSHI) initial_is_constant = 1; if (OP(this->ifor.increment) == OP_PUSHI) increment_is_constant = 1; if (OP(this->ifor.final) == OP_PUSHI) final_is_constant = 1; Push_For(this->ifor.printable_forlab); #ifdef CONCISE codegen("for (%L = %V; %V != %V; %L += %V) {\n", this->ifor.control, this->ifor.initial, this->ifor.control, this->ifor.final, this->ifor.control, this->ifor.increment); #else codegen(" // %%for %L = %V, %V, %V %%cycle\n", this->ifor.control, this->ifor.initial, this->ifor.increment, this->ifor.final); // NOTE: If we add a %control (or %diagnose?) option, or command line PARM, for specifically checking %for loops, we should // make the shadowing of _control optional. (Also to be done for PARM OPT) *TO DO* (For now, just "#define CONCISE 1") {int before = 0; if (shadow_for_loop) { codegen("{ int _control"); before = 1; } else { if (!initial_is_constant || !increment_is_constant || !final_is_constant) codegen("{ int "); else codegen("{ "); } if (!initial_is_constant) { if (before) codegen(","); codegen(" _initial = %V", this->ifor.initial); before = 1; } if (!increment_is_constant) { if (before) codegen(","); codegen(" _increment = %V", this->ifor.increment); before = 1; } if (!final_is_constant) { if (before) codegen(","); codegen(" _final = %V", this->ifor.final); } } if (shadow_for_loop || (!initial_is_constant || !increment_is_constant || !final_is_constant)) codegen(";\n"); if ((initial_is_constant && increment_is_constant && final_is_constant) && ( ( sign(ivalue(this->ifor.final)-ivalue(this->ifor.initial)) == sign(ivalue(this->ifor.increment)) ) // Does the increment not go in right direction? && ( ((ivalue(this->ifor.final)-ivalue(this->ifor.initial)) % ivalue(this->ifor.increment)) == 0 ) // Does the for-loop step skip over the final value? )) { // Saul Goodman! } else { codegen("if (invalid_for_loop("); if (initial_is_constant) codegen("%V", this->ifor.initial); else codegen("_initial"); codegen(", "); if (increment_is_constant) codegen("%V", this->ifor.increment); else codegen("_increment"); codegen(", "); if (final_is_constant) codegen("%V", this->ifor.final); else codegen("_final"); codegen(")) _imp_signal(5,1,0,\"Illegal cycle %L = %V, %V, %V\");\n", this->ifor.control, this->ifor.initial, this->ifor.increment, this->ifor.final); } #ifdef NEVER // Does the increment go in right direction? (and can the for-loop step skip over the final value?) if (initial_is_constant && increment_is_constant && final_is_constant) { // (Can we tell at compile time?) if ( ( sign(ivalue(this->ifor.final)-ivalue(this->ifor.initial)) == sign(ivalue(this->ifor.increment)) ) // Does the increment not go in right direction? && ( ((ivalue(this->ifor.final)-ivalue(this->ifor.initial)) % ivalue(this->ifor.increment)) == 0 ) // Does the for-loop step skip over the final value? ) { // Saul Goodman! } else { // No, so unconditionally output runtime error. It would be nice to warn at compile time as well, // but we can't do this yet, warnf etc does not implement %V from codegen(). It probably should do, // for better compile-time error messages..: // warnf("Illegal cycle %L = %V, %V, %V\n", this->ifor.control, this->ifor.initial, this->ifor.increment, this->ifor.final); codegen(" _imp_signal(5,1,0,\"Illegal cycle %L = %V, %V, %V\");", this->ifor.control, this->ifor.initial, this->ifor.increment, this->ifor.final); } } else { // (have to test at run time) // NEEDS: #define sign(v) ({ __typeof__(v) _v = (v); (_v > 0) - (_v < 0); }) codegen("if ("); codegen("(sign(("); if (final_is_constant) codegen("%V", this->ifor.final); else codegen("_final"); codegen(")-("); if (initial_is_constant) codegen("%V", this->ifor.initial); else codegen("_initial"); codegen(")) != sign("); if (increment_is_constant) codegen("%V", this->ifor.increment); else codegen("_increment"); codegen("))"); // Can the for-loop step skip over the final value? if (!increment_is_constant || abs(ivalue(this->ifor.increment)) != 1) { codegen(" || ((("); if (final_is_constant) codegen("%V", this->ifor.final); else codegen("_final"); codegen("-"); if (initial_is_constant) { if (ivalue(this->ifor.initial) < 0) codegen("(%V)", this->ifor.initial); else codegen("%V", this->ifor.initial); } else codegen("_initial"); codegen(") %% "); if (increment_is_constant) codegen("(%V)", this->ifor.increment); else codegen("_increment"); codegen(") != 0)"); } codegen(")"); codegen(" _imp_signal(5,1,0,\"Illegal cycle %L = %V, %V, %V\");", this->ifor.control, this->ifor.initial, this->ifor.increment, this->ifor.final); } #endif // NEVER #endif // !CONCISE // Initialise actual for-loop control, and also its shadow... if (initial_is_constant && increment_is_constant) { if (shadow_for_loop) codegen(" _control ="); codegen(" %L = %V;\n", this->ifor.control, mksub(this->ifor.initial, this->ifor.increment)); } else { if (shadow_for_loop) codegen(" _control ="); if (initial_is_constant) codegen(" %L = %V", this->ifor.control, this->ifor.initial); else codegen(" %L = _initial", this->ifor.control); if (increment_is_constant) codegen(" - (%V);\n", this->ifor.increment); else codegen(" - _increment;\n"); } codegen("%s:\n", this->ifor.printable_forlab); // <----------------- THIS WOULD BE THE ONE TO PUSH ON A STACK (see OP_REPEAT below) if (shadow_for_loop) codegen(" if (%V != _control) _imp_signal(4,2,0,\"Corrupt control variable %N\");\n", this->ifor.control, this->ifor.control); if (final_is_constant) codegen(" if (%V == %V) goto %s;\n", this->ifor.control, this->ifor.final, this->ifor.printable_exitlab); else codegen(" if (%V == _final) goto %s;\n", this->ifor.control, this->ifor.printable_exitlab); if (increment_is_constant) { if (ivalue(this->ifor.increment) < 0) { if (shadow_for_loop) codegen(" _control -= %V; ", mknegate(this->ifor.increment)); } else { if (shadow_for_loop) codegen(" _control += %V; ", this->ifor.increment); } } else if (shadow_for_loop) codegen(" _control += _increment; "); if (increment_is_constant && ivalue(this->ifor.increment) < 0) { codegen(" %L -= %V;\n", this->ifor.control, mknegate(this->ifor.increment)); // control -= const rather than control += -const ... } else { if (increment_is_constant) codegen(" %L += %V;\n", this->ifor.control, this->ifor.increment); else codegen(" %L += _increment;\n", this->ifor.control); } } break; case OP_REPEAT: // 'B': /* REPEAT label */ codegen(" goto %s;", this->repeat.printable_forlab); char *For_TOS = Pop_For(); if (strcmp(For_TOS, this->repeat.printable_forlab) == 0) { codegen("\n}\n"); } else { // I don't think this will work reliably. What if a for loop contains a while loop, when will the while loop get popped? Push_For(For_TOS); } // ***TO DO*** // *IF* (and only if) this is a FOR loop, codegen(" }"); // Unfortunately a simple "I = I+1 %while I < 10" etc will generate the same label, so I need a better way of detecting it. Have a look at how "flattener" does it? // One way would be to push the repeat label info on a private stack, and then whenever we see a OP_REPEAT, compare it to the pushed label ID... // (popping it off if TOS matches this.) if (!suppress_newline) codegen("\n"); access = 0; break; case OP_LINE: // 'O': /* LINE decimal */ // line info has been moved into fixed fields of all opcodes codegen("#line %d %s\n", this->line.lineno, this->line.filename); //suppress_perms = FALSE; // EXTENSION FOR C-PASS1: /*if (opt_extended_line) fname = this->line.filename; */ break; case OP_PUSH: // '@': /* PUSH tag */ // TO DO: perm routine names should be prefixed by _imp_ - handlle this in icode2ast.c // as the icodes are loaded, modifying the c_id field. if (this->push.tag < 0 || this->push.tag >= MAX_AST_ENTRIES) { errorf("PUSH: this->push.tag = %d\n", this->push.tag); } else if (DEFTAG[this->push.tag] == NULL) { codegen("", this->push.tag); } else { codegen("%s", NOTNULL(DEFTAG[this->push.tag])->def.c_id); } break; case OP_SELECT: // 'n': /* SELECT tag */ { IMPAST *fielddef; if (this->select.use_pointer != 0) { codegen("%N->", this->select.parent_record); } else { codegen("%N.", this->select.parent_record); } fielddef = this->select.fielddef; if (fielddef != NULL) { codegen("%s", fielddef->def.c_id); } else { fatalf("The fielddef field of the SELECT opcode is NULL.\n"); } } break; case OP_DEFSW: // '`': /* defsw */ // EXTENSION FOR C-PASS1: default switch label // Default label should be marked in switch def as having been defined... *TO DO* codegen("case_%s_default: ;\n", NOTNULL(DEFTAG[this->defsw.label])->def.c_id); // parameter could have been better to have been an IMPAST label rather than a tag? access = 1; break; case OP_SJUMP: // 'W': /* SJUMP sd */ { // *TO DO* The SJUMP opcode needs to pass the line number of the location requesting the jump (__LINE__), for better diagnostics. IMPAST *def = NOTNULL(DEFTAG[this->sjump.label]); codegen("%s_line = __LINE__; %s_file = __FILE__; %s_index = %V; goto case_%s_dispatch;\n", def->def.c_id, def->def.c_id, def->def.c_id, this->sjump.index, def->def.c_id); access = 0; } break; case OP_SLABEL: // '_': /* SLABEL sd */ // switch label should be recorded in the switch def if (OP(this->slabel.index) == OP_PUSHI && this->slabel.index->pushi.value < 0) { codegen("case_%s_M%0d: ;\n", NOTNULL(DEFTAG[this->slabel.label])->def.c_id, -this->slabel.index->pushi.value); } else { codegen("case_%s_%V: ;\n", NOTNULL(DEFTAG[this->slabel.label])->def.c_id, this->slabel.index); } access = 1; break; case OP_DEFAULT: // 'Y': /* DEFAULT short */ warnf("OP_DEFAULT?\n"); if (!suppress_newline) codegen("\n"); break; case OP_DIAG: // 'y': /* DIAG short */ // This may only be for setting internal compiler flags and not relevant at runtime? codegen("// _imp_diagnose(0x%04x); /* %%diagnose is a compiler directive and does not generate code */\n", this->diag.data); DIAGNOSE = this->diag.data; break; case OP_CONTROL: // 'z': /* CONTROL short */ // This may only be for setting internal compiler flags and not relevant at runtime? /* Imp77 use of %control (may not be the same as ERCC Imp): (lsb) Bit 0 :: Unassigned variable (%CONTROL X'00000001') 1 :: String capacity (%CONTROL X'00000002') 2 :: %for loop (%CONTROL X'00000004') 3 :: Array bound (%CONTROL X'00000008') 4 :: Integer overflow (%CONTROL X'00000010') 28 :: Decode wanted in listing file (%CONTROL X'10000000') In the ERCC Imp compiler we find: Report = (Dcomp>>1)&1 %and Decode = Dcomp&1 and SW(22): ! '%CONTROL' (CONST) FORCE TRIPS %if PARM_OPT=0 J = FROM AR4(P+2) I = J>>28 PARM_DCOMP = I %unless I=15 I = J>>24&15 PARM_Y = I %unless I=15 I = J>>20&15 PARM_Z = I %unless I=15 I = J&15 PARM_LINE = I %unless I=15 I = J>>4&15 PARM_DIAG = I %unless I=15 ->CSSEXIT though it's not too clear how helpful this is! */ codegen("// _imp_control(0x%04x); /* %%control is a compiler directive and does not generate code. */\n", this->control.data); CONTROL = this->control.data; break; case OP_EVENT: // 'e': /* EVENT short */ codegen("_imp_signal(%d,", this->event.event); if (this->event.subevent == NULL) codegen("0"); else codegen("%V", this->event.subevent); codegen(","); if (this->event.extra == NULL) codegen("0"); else codegen("%V", this->event.extra); codegen(", \"\");\n"); break; case OP_LANG: // 'l': /* LANG short */ codegen(" /* <%s> */", icode_name[this->generic.opcode]); // could actually check the lang and exit if not imp. This should be the first code in the icode file. break; case OP_ON: // 'o': /* ON byte short label */ codegen("if (!_imp_on_event("); static char events[256]; *events = '\0'; for (int shift = 0; shift < 32; shift++) { if ((this->on.mask & (1<on.printable_label); break; case OP_RESOLVE: // 'r': /* RESOLVE m */ { if (this->resolve.conditional == 0) codegen("if (!"); // S -> (T) . U . (V) codegen("_imp_resolve("); // TO DO: The _imp_resolve routine *should* also take max length values for its writable parameters T and V... // Meanwhile we'll assume that the writable parameters allow 255 characters to be written to them. // Without those extra maxlength parameters we can only look at the string after it has been // updated by resolve, by which point data following will have been corrupted. // Also, // The machinations to pass the two values (S and U) as _imp_string (255) could be avoided by // declaring the perm routine as taking void * parameters for those. // S: //codegen("%V", this->resolve.string); //codegen("*(_imp_string255 *)({"); gen_c_type(this->resolve.string); codegen(" tmp = %V; &tmp; }), ", this->resolve.string); codegen("*({"); gen_c_type(this->resolve.string); codegen(" tmp = %V; (_imp_string255 *)&tmp; }), ", this->resolve.string); // T: if (this->resolve.opd1 != NULL) { codegen("(_imp_string255 *)%A, ", this->resolve.opd1); // TO DO: this->resolve.opd1 = address_of(this->resolve.opd1) or something of that nature... } else codegen("0 /*NULL*/, "); // U: //codegen("*(_imp_string255 *)({"); gen_c_type(this->resolve.match); codegen(" tmp = %V; &tmp; }), ", this->resolve.match); codegen("*({"); gen_c_type(this->resolve.match); codegen(" tmp = %V; (_imp_string255 *)&tmp; }), ", this->resolve.match); // V: if (this->resolve.opd2 != NULL) { codegen("(_imp_string255 *)%A", this->resolve.opd2); // TO DO: this->resolve.opd2 = address_of(this->resolve.opd2) or something of that nature... } else codegen("0 /*NULL*/"); codegen(")"); if (this->resolve.conditional == 0) { codegen(") _imp_signal(7,1,0, \"string resolution fails\");"); } // result is tested by BF or BT! } break; case OP_MCODE1: // 'c': /* MCODE */ #ifdef NEVER { int i1; short int h1; for (;;) { p1 = getmcstring(&i1); codegen(" %s", p1); if (i1 == ';') break; p2 = getshort(); codegen(" tag_%s", p2); } } access = 1; #endif break; case OP_ASSPAR: // 'p': /* ASSPAR */ codegen("%N", this->asspar.param); if (this->asspar.next_param != NULL) { codegen(", %N", this->asspar.next_param); // *TO DO* - name vs value parameters, need to look at corresponding formal parameter } break; case OP_CALL: // 'E': /* CALL rt/fn/map/pred */ { IMPAST *def = this->call.def; // There's a huge 'to do' here that I've not even thought about tackling yet, which is that large parameters (strings and maybe records) // that are passed by value, could be passed by address and copied to a local copy in the procedure body *only if* the parameter was // ever written to. This would cut down on a tremendous amount of copying, especially for string parameters. The simple copying // inside the body if done unconditionally would be pretty simple, although to no big advantage apart from saving a few bytes from // having fewer instances of the copying code - but the optimisation of not copying if not needed would be quite hard to add with // the current compiler structure. if (def) { // ASSPAR tuples: codegen("%s(", def->def.c_id); if (this->call.actual_params == NULL) { // This test is still necessary. I'ld like to track down why it's missing and insert the correct values earlier. // The problem might be similar to what was needed for indexing multi-D arrays, where we need to be careful about // calls such as fn(1, fn(2,3,4), 5) - building up the parameters in the call is dangerous. The solution in // the case of array indexing was to treat the list (eg def->def.actual_params here) as a stack... ***TO DO*** this->call.actual_params = def->def.actual_params; } if (this->call.actual_params != NULL) output_parameters(def->def.c_id, this->call.formal_params, this->call.actual_params); codegen(")"); if (FORM(def) == F_ROUTINE) codegen(";\n"); // If a %routine, output as a statement, otherwise, part of an expression. } else fatalf("Internal error in OP_CALL\n"); } break; case OP_ASSVAL: // 'S': /* ASSVAL */ if (TYPE(this->assval.dest) == T_RECORD && (FORM(this->assval.dest) == F_SIMPLE || FORM(this->assval.dest) == F_NAME || FORM(this->assval.dest) == F_MAP)) { if (OP(this->assval.source) == OP_PUSHI /* && this->assval.source->pushi.value == 0 */ ) { /* According to the ISO C Standard (Section 6.7.9 regarding initialization), when an aggregate type (like a struct) is initialized implicitly by a {0} or a compound literal, any remaining arithmetic members are initialized to a type-appropriate (positive) zero. */ IMPAST *dest = this->assval.dest; IMPAST *recfm = dest->generic.recordformatdef; if (this->assval.source->pushi.value != 0) { // Actually this can't happen in an assignment, only in an initialisation, and that // only because pass1 has an error! fatalf("Line %d: Illegal assignment: %%record (%s) %s = %d - only 0 is allowed.\n", this->assval.line->line.lineno, recfm->def.c_id, dest->def.c_id, this->assval.source->pushi.value); } codegen("%L = (struct %s) { %V };\n", // %V should really be a type-appropriate 0, so this will fail if the first field is a %string this->assval.dest, recfm->def.c_id, this->assval.source); } else { // *TO DO* codegen("memcpy(%L, %V, sizeof(struct %s));\n", this->assval.dest, this->assval.source, this->assval.dest->generic.recordformat.c_id); codegen("%L = %V;\n", this->assval.dest, this->assval.source); } } else if (TYPE(this->assval.dest) == T_STRING && FORM(this->assval.dest) == F_SIMPLE) { // Untested: // Note can be optimised by moving only the length of the string, not the max size of the string. Cast to dest type probably needed (or use void * ?) // *TO DO* codegen("memcpy(%L, %V, sizeof(struct %s));\n", this->assval.dest, this->assval.source, this->assval.dest->generic.recordformat.c_id); // strings of the same max length can be assigned with a simple %L = %V although string of longer max length need to be checked for overflow on assignment int dest_max = this->assval.dest->generic.maxstring; if (dest_max == 0) dest_max = 255; int source_max = this->assval.source->generic.maxstring; if (source_max == 0) source_max = 255; // TO DO: (maybe) If the source is a string literal and the length is known at compile time to be shorter than the destination, // then just memmove it without checks. Conversely if known at compile time to be longer than the destination, // then output a warning message at compile time and generate code to issue the signal instead. // Needs the same _imp_check_strvalue checks as in output_parameters() *TO DO* if (exprdepth++ == 0) codegen("\n/* clang-format off */\n"); // WAS: codegen("_imp_strncpy(%A, %A, /*max:*/%d);\n", this->assval.dest, this->assval.source, dest_max); codegen("_imp_strncpy(%A, ({__typeof__(_imp_string%0d) tmp;/*B*/ tmp = %V; (void *)&tmp;}), /*max:*/%d);\n", this->assval.dest, source_max, this->assval.source, dest_max); // m6502.c:2993:60: error: invalid initializer // _imp_strncpy(&HEADER, (_imp_string *)({_imp_string33 tmp = *(_imp_string255 *) // ({_imp_string255 tmp = // _imp_join( // (void *)({_imp_string33 tmp = HEADER; &tmp;}), // (void *)({_imp_string1 tmp = _imp_TOSTRING(LINE[LP - 1]); &tmp;}) // ) // ; &tmp;}) // ; &tmp;}), /*max:*/33); if (--exprdepth == 0) codegen("\n/* clang-format on */\n"); } else { codegen("%L = %V;\n", this->assval.dest, this->assval.source); } break; case OP_ASSREF: // 'Z': /* ASSREF */ //codegen("%P = %A;\n", this->assref.dest, this->assref.source); // TO DO: this->assref.source = address_of(assref.source) or something of that nature... codegen("%P = (", this->assref.dest); gen_c_type(this->assref.dest); codegen(" *) %A;\n", this->assref.source); break; case OP_JAM: // 'j': /* JAM */ // TO DO: Use CAST to cast the RHS to the type of the LHS. if (TYPE(this->assref.dest) == T_STRING) { int dest_max = this->assval.dest->generic.maxstring; if (dest_max == 0) dest_max = 255; int source_max = this->assval.source->generic.maxstring; if (source_max == 0) source_max = 255; //codegen("_imp_strncpy(%A, %A, /*max:*/%d);\n", this->assval.dest, this->assval.source, dest_max); if (exprdepth++ == 0) codegen("\n/* clang-format off */\n"); codegen("_imp_strncpy(%A, ({__typeof__(_imp_string%0d) tmp; /*C*/ tmp = %V; (void *)&tmp;}), /*max:*/%d);\n", // | | | | this->assval.dest, // | | | source_max, // | | this->assval.source, dest_max); if (--exprdepth == 0) codegen("\n/* clang-format on */\n"); if (source_max > dest_max) { codegen(" /* truncated copy of no more than %d chars */ ", dest_max); if (exprdepth++ == 0) codegen("\n/* clang-format off */\n"); codegen("if (*_imp_LENGTH((_imp_string *)%A) > %d) *_imp_LENGTH((_imp_string *)%A) = %d;\n", this->assval.dest, dest_max, this->assval.dest, dest_max); if (--exprdepth == 0) codegen("\n/* clang-format on */\n"); } } else if (TYPE(this->assref.dest) == T_INTEGER) { codegen("%L = (", this->jam.dest); gen_c_type(this->jam.dest); codegen(")(%V);\n", this->jam.source); } else if (TYPE(this->assref.dest) == T_REAL) { codegen("%L = (", this->jam.dest); gen_c_type(this->jam.dest); // presumably double -> float is the only one worth requesting codegen(")(%V);\n", this->jam.source); } else { codegen("%L = /*jam transfer*/ %V;\n", this->jam.dest, this->jam.source); } break; case OP_TRUE: // 'T': /* TRUE */ codegen("return 1 /*TRUE*/;\n"); access = 0; break; case OP_FALSE: // 'K': /* FALSE */ codegen("return 0 /*FALSE*/;\n"); access = 0; break; case OP_RESULT: // 'V': /* RESULT */ // TO DO: type shennanigans when the function returns a string. // However we need to know the result type of this function and I'm not sure if that has been saved in the RESULT tuple. if (TYPE(this->result.opd) == T_STRING) { IMPAST *def = this->result.fndef; codegen("return *("); gen_c_type(def); codegen(" *)%A;\n", this->result.opd); } else { codegen("return %V;\n", NOTNULL(this->result.opd)); } access = 0; break; case OP_MAP: // 'M': /* MAP */ codegen("return %A;\n", NOTNULL(this->map.opd)); // TO DO: this->map.opd = address_of(this->map.opd) or something of that nature... access = 0; break; case OP_RETURN: // 'R': /* RETURN */ { IMPAST *blockstart = this->ireturn.startblock; if (OP(blockstart) == OP_DEF) { codegen("return;\n"); } else if (OP(blockstart) == OP_BEGIN) { #ifdef IMPLEMENT_BLOCKS_AS_ANONYMOUS_FUNCTIONS codegen("return;\n"); #else codegen("goto end_%0d;\n", blockstart->begin.blockno); #endif } else { fatalf("genc.c: OP_RETURN bad block type\n"); } access = 0; } break; case OP_NEGATE: // 'U': /* NEGATE */ if (this->negate.opd == NULL) { codegen("NEGATE_BUG"); warnf("NEGATE Icode has a NULL operand.\n"); // And add any info we can determine as to where this icode came from... } else { opd1 = this->negate.opd; // Should really use the precedence code at parent level, but this will work if (IS_MONOP(opd1) || IS_BINOP(opd1)) { codegen("-(%V)", opd1); } else { // else must be an atom, not an expression... codegen("-%V", opd1); } } break; case OP_NOT: // '\\': /* NOT */ opd1 = this->not.opd; // Should really use the precedence code at parent level, but this will work if (IS_MONOP(opd1) || IS_BINOP(opd1)) { codegen("~(%V)", opd1); } else { codegen("(~%V)", opd1); } break; case OP_MOD: // 'v': /* MOD */ if (TYPE(this) == T_INTEGER) { // *** TO DO *** Not sure this is a valid test! CHECK IT! codegen("_imp_IMOD(%V)", this->mod.opd); } else { codegen("_imp_MOD(%V)", this->mod.opd); } break; case OP_OR: // '!': /* OR */ opd1 = NOTNULL(this->or.opd1); opd2 = NOTNULL(this->or.opd2); if (LEFT_NEEDS_BRACKETS(opd1, this)) { codegen("(%V)", opd1); } else { codegen("%V", opd1); } codegen(" | "); // bitwise, not Boolean. if (RIGHT_NEEDS_BRACKETS(this, opd2)) { codegen("(%V)", opd2); } else { codegen("%V", opd2); } break; case OP_XOR: // '%': /* XOR */ opd1 = NOTNULL(this->xor.opd1); opd2 = NOTNULL(this->xor.opd2); if (LEFT_NEEDS_BRACKETS(opd1, this)) { codegen("(%V)", opd1); } else { codegen("%V", opd1); } codegen(" ^ "); if (RIGHT_NEEDS_BRACKETS(this, opd2)) { codegen("(%V)", opd2); } else { codegen("%V", opd2); } break; case OP_AND: // '&': /* AND */ opd1 = NOTNULL(this->and.opd1); opd2 = NOTNULL(this->and.opd2); if (LEFT_NEEDS_BRACKETS(opd1, this)) { codegen("(%V)", opd1); } else { codegen("%V", opd1); } codegen(" & "); // bitwise, not Boolean. if (RIGHT_NEEDS_BRACKETS(this, opd2)) { codegen("(%V)", opd2); } else { codegen("%V", opd2); } break; case OP_MUL: // '*': /* MUL */ opd1 = NOTNULL(this->mul.opd1); opd2 = NOTNULL(this->mul.opd2); if (LEFT_NEEDS_BRACKETS(opd1, this)) { codegen("(%V)", opd1); } else { codegen("%V", opd1); } codegen(" * "); if (RIGHT_NEEDS_BRACKETS(this, opd2)) { codegen("(%V)", opd2); } else { codegen("%V", opd2); } break; case OP_ADD: // '+': /* ADD */ opd1 = NOTNULL(this->add.opd1); opd2 = NOTNULL(this->add.opd2); if (LEFT_NEEDS_BRACKETS(opd1, this)) { codegen("(%V)", opd1); } else { codegen("%V", opd1); } codegen(" + "); if (RIGHT_NEEDS_BRACKETS(this, opd2)) { codegen("(%V)", opd2); } else { codegen("%V", opd2); } break; case OP_SUB: // '-': /* SUB */ opd1 = NOTNULL(this->sub.opd1); opd2 = NOTNULL(this->sub.opd2); if (LEFT_NEEDS_BRACKETS(opd1, this)) { codegen("(%V)", opd1); } else { codegen("%V", opd1); } if (OP(opd2) == OP_PUSHI && opd2->pushi.value < 0) { codegen(" + %0d", -opd2->pushi.value); } else if (OP(opd2) == OP_NEGATE && OP(opd2->negate.opd) == OP_PUSHI) { codegen(" + %V", opd2->negate.opd); } else { codegen(" - "); if (RIGHT_NEEDS_BRACKETS(this, opd2)) { codegen("(%V)", opd2); } else { codegen("%V", opd2); } } break; case OP_CONCAT: // '.': /* CONCAT */ { int sourcemaxlen; // A little bit of coercion in this early release to work // around the issues of strings of different max lengths. // We'll get around to handling these properly later... // ( stack.c should have set the type of OP_CONCAT node, and set max length to MIN(sum of two params, 255) ) //codegen("({_imp_string255 conc = _imp_join((_imp_string *)%N, (_imp_string *)%N); &conc;})", if (exprdepth++ == 0) codegen("\n/* clang-format off */\n"); //codegen("*(_imp_string255 *)({_imp_string255 tmp = _imp_join("); codegen("*({_imp_string255 tmp = _imp_join("); if ((FORM(this->concat.opd1) == F_SIMPLE || FORM(this->concat.opd1) == F_MAP) && OP(this->concat.opd1) != OP_CALL) { // i.e. something we can take the address of codegen("(_imp_string *)%A", this->concat.opd1); } else { sourcemaxlen = this->concat.opd1->generic.maxstring; if (sourcemaxlen == 0) sourcemaxlen = 255; //codegen("(void *)({_imp_string%0d tmp;/*D*/ tmp = %V; &tmp;})", sourcemaxlen, this->concat.opd1); codegen("({__typeof__(_imp_string%0d) tmp; /*D*/ tmp = %V; (void *)&tmp;})", sourcemaxlen, this->concat.opd1); } codegen(", "); if ((FORM(this->concat.opd2) == F_SIMPLE || FORM(this->concat.opd2) == F_MAP) && OP(this->concat.opd2) != OP_CALL) { // i.e. something we can take the address of codegen("(_imp_string *)%A", this->concat.opd2); } else { sourcemaxlen = this->concat.opd2->generic.maxstring; if (sourcemaxlen == 0) sourcemaxlen = 255; //codegen("(void *)({_imp_string%0d tmp;/*E*/ tmp = %V; &tmp;})", sourcemaxlen, this->concat.opd2); codegen("({__typeof__(_imp_string%0d) tmp; /*E*/ tmp = %V; (void *)&tmp;})", sourcemaxlen, this->concat.opd2); } //codegen("); &tmp;})"); codegen("); (_imp_string255 *)&tmp;})"); if (--exprdepth == 0) codegen("\n/* clang-format on */\n"); } break; case OP_QUOT: // '/': /* QUOT */ opd1 = NOTNULL(this->quot.opd1); opd2 = NOTNULL(this->quot.opd2); codegen("( "); if (LEFT_NEEDS_BRACKETS(opd1, this) || IS_BINOP(opd1)) { codegen("(long)(%V)", opd1); } else { codegen("(long)%V", opd1); } codegen(" / "); //codegen("/* INTEGER DIVISION */ "); if (RIGHT_NEEDS_BRACKETS(this, opd2) || IS_BINOP(opd2)) { codegen("(long)(%V)", opd2); } else { codegen("(long)%V", opd2); } codegen(" )"); break; case OP_DIVIDE: // 'Q': /* DIVIDE */ opd1 = NOTNULL(this->divide.opd1); opd2 = NOTNULL(this->divide.opd2); // The casting to (double) should not be needed if the value // is already a double. codegen("(double)( "); if (LEFT_NEEDS_BRACKETS(opd1, this) || IS_BINOP(opd1)) { codegen("(%V)", opd1); } else { codegen("%V", opd1); } codegen(" / "); if (RIGHT_NEEDS_BRACKETS(this, opd2) || IS_BINOP(opd2)) { codegen("(%V)", opd2); } else { codegen("%V", opd2); } codegen(" )"); break; case OP_REXP: // 'x': /* REXP */ codegen("_imp_REXP(%V, %V)", NOTNULL(this->rexp.opd1), NOTNULL(this->rexp.opd2)); break; case OP_IEXP: // 'X': /* IEXP */ codegen("_imp_IEXP(%V, %V)", NOTNULL(this->iexp.opd1), NOTNULL(this->iexp.opd2)); break; case OP_LSH: // '[': /* LSH */ opd1 = NOTNULL(this->lsh.opd1); opd2 = NOTNULL(this->lsh.opd2); if (LEFT_NEEDS_BRACKETS(opd1, this)) { codegen("(%V)", opd1); } else { codegen("%V", opd1); } codegen(" << "); if (RIGHT_NEEDS_BRACKETS(this, opd2)) { codegen("(%V)", opd2); } else { codegen("%V", opd2); } break; case OP_RSH: // ']': /* RSH */ opd1 = NOTNULL(this->rsh.opd1); opd2 = NOTNULL(this->rsh.opd2); if (LEFT_NEEDS_BRACKETS(opd1, this)) { codegen("(unsigned int)(%V)", opd1); } else { codegen("(unsigned int)%V", opd1); } codegen(" >> "); if (RIGHT_NEEDS_BRACKETS(this, opd2)) { codegen("(%V)", opd2); } else { codegen("%V", opd2); } break; case OP_ADDA: // 'u': /* ADDA */ // Be careful, precedence of this operator might not match normal "+". Needs checks. *TO DO* opd1 = NOTNULL(this->adda.opd1); opd2 = NOTNULL(this->adda.opd2); if (LEFT_NEEDS_BRACKETS(opd1, this)) { codegen("(%N)", opd1); } else { codegen("%N", opd1); } codegen("+"); if (RIGHT_NEEDS_BRACKETS(this, opd2) || IS_BINOP(opd2)) { codegen("(%V)", opd2); } else { codegen("%V", opd2); } break; case OP_SUBA: // 'q': /* SUBA */ // Be careful, precedence of this operator might not match normal "+". Needs checks. *TO DO* opd1 = NOTNULL(this->suba.opd1); opd2 = NOTNULL(this->suba.opd2); if (LEFT_NEEDS_BRACKETS(opd1, this)) { codegen("(%N)", opd1); } else { codegen("%N", opd1); } codegen("-"); if (RIGHT_NEEDS_BRACKETS(this, opd2) || IS_BINOP(opd2)) { codegen("(%V)", opd2); } else { codegen("%V", opd2); } break; case OP_BOUNDSPAIR: // 'b': /* BOUNDS */ // The way this is implemented, this is actually a list of boundspairs // rather than a single pair. // Since most bounds definitions are output in OP_DEF, I'm not sure // why this is still being called... but it is, so don't remove this! gen_c_boundslist( this, reverse_index_order); break; case OP_MONITOR: // 'm': /* MONITOR */ codegen(" /*_imp_monitor(__LINE__, __FILE__, PRETTY_FUNCTION);*/\n"); break; case OP_STOP: // 's': /* STOP */ codegen("_imp_stop(0);\n"); access = 0; break; case ASTOP_INDIRECT_THROUGH: //debugf("ASTOP_INDIRECT_THROUGH was called.\n"); //codegen("/*indirectthrough*/"); codegen("*%N", NOTNULL(this->indirect_through.opd)); // possibly better (albeit uglier) to do (*(%N)) ? TO DO: check. break; case ASTOP_ADDRESS_OF: //debugf("ASTOP_ADDRESS_OF was called.\n"); //codegen("/*addressof*/"); if (OP(this->address_of.opd) == OP_PUSHS) { char *s = this->address_of.opd->pushs.string_value; codegen("_imp_str_literal_ptr(\""); for (;;) { int c = *s++; if (c == '\0') break; if (c == '"') { codegen("\\%c", '"'); } else if (c == '\n') { codegen("\\n"); } else if (c == '\\') { codegen("\\\\"); } else { codegen("%c", c); } } codegen("\")"); } else { codegen("&%N", NOTNULL(this->address_of.opd)); // ditto "(&(%N))" ? } break; case ASTOP_ARRAYINDEX: { extern IMPAST *reverse_arrayindex_list(FILE *out, IMPAST *list); // in filter.c IMPAST *forward_bounds_list = NOTNULL(this->array_index.array_def)->def.bounds_list; // can't call reverse_bound_list() because that is done in-situ which messes up // if it is called again. (can't undo after either, in case of nested array // accesses to the same array) IMPAST *boundstack[MAX_ARRAY_DIMS]; int bound_count = 0; while (!nulllike(forward_bounds_list)) { // we're already getting corrupt data here boundstack[bound_count++] = NOTNULL(forward_bounds_list); forward_bounds_list = forward_bounds_list->boundspair.next_bound; } if ( bound_count == 0) { warnf("ASTOP_ARRAYINDEX: no bound info - unfinished code for arrayname or array parameter or 2-D (or more) array\n"); //codegen("[%V /* no lb? #1 */]", index); gen_c( this->array_index.array_base, 1); codegen("[/*BUG*/%V]", this->array_index.index); break; } if (!reverse_index_order) bound_count = -1; if (!reverse_index_order) this = reverse_arrayindex_list(stderr, this); //codegen("/* %p OP(THIS)=%s*/", this, icode_name[OP(this->array_index.array_base)]); gen_c( this->array_index.array_base, 1); for (;;) { IMPAST *index = this->array_index.index; if (reverse_index_order) bound_count -= 1; else bound_count += 1; if (boundstack[bound_count] != NULL && boundstack[bound_count]->boundspair.lb != NULL) { codegen("[%V]", mksub(NOTNULL(index), NOTNULL(NOTNULL(boundstack[bound_count])->boundspair.lb))); } else { codegen("[%V /* no lb? #2 */]", index); } this = this->array_index.next_index; if (this == NULL) break; } } break; case OP_ALIAS: // 'G': /* ALIAS */ break; case OP_INDEX: // 'i': /* INDEX */ /* Array Index; */ // The INDEX nodes will be children of the ACCESS node so we will not output // anything here. break; case OP_ACCESS: // 'a': /* ACCESS */ // now moved to ASTOP_ARRAYINDEX break; case OP_DIM: // 'd': /* DIM short,short */ break; case OP_INIT: // 'A': /* INIT short */ break; case OP_PROC: // '^': /* PROC tag */ break; case '\n': break; // end of file default: warnf("genc.c: default taken for an OP_%s.\n", icode_name[OP(this)]); break; } } #endif // !__GENC_C__