#define _POSIX_C_SOURCE 200809L #define _XOPEN_SOURCE 500 #include // This module is called from i2c to perform actions based on each ICODE. #include #include #include #include #include "i2c.h" #include "ast.h" #include "icode.h" #include "flex.h" #include "stringpool.h" extern FILE *output_file; char hashline[1024] = {'\0'}; int Descriptor[MAX_DESCRIPTORS]; int next_free_private_tag = MAX_DESCRIPTORS; int NEW_INTERNAL_TAG(void) { return --next_free_private_tag; } #ifndef TRUE #define TRUE (0 == 0) #define FALSE (0 != 0) #endif int _imp_diagnose = 0; int _imp_control = 0; static int accessible = 1; // duplicates a variable in pass1 for convenience // We *only* use this to suppress the extra code // that is planted to detect a missing %result //----------------------------------------------------------------------- static char *source_indent = " // "; static char *comment_indent = " // "; //static char *code_indent = " "; void dump(char *s, ...) { va_list ap; // if (suppress_perms) return; va_start(ap, s); vfprintf(output_file, s, ap); va_end(ap); fflush(output_file); } // just to make the source call intentions clearer. They all do the same, // apart from a different indentation level for each. static char buffer[4096] = {'\0'}; // ***WARNING*** I think this code is still slightly broken in that it is not // consistently and fully re-entrant as sometimes it wrongly prints the same // parameter twice when in fact it was given two different parameters as inputs. // For instance "%N %N" or "%s %s". // That's not to say however that the problem may be elsewhere, such as in pooltostr for example, // which I'll be checking first... right now... *TO DO* *doing!* void dump_code(char *format, ...) { va_list ap; char *s = format; char item_format[1024]; //fprintf(stderr, "[%s]\n", format); va_start(ap, format); for (;;) { int c = *s++; if (c == 0) break; if (c == '%') { int f = *s++; if (f == 0) break; if (f == '%') { fprintf(output_file, "%%"); } else { void *arg = va_arg(ap, void *); if (f == 'N') { codegen((int)((intptr_t)arg)); } else { char *p = item_format; *p++ = '%'; for (;;) { *p++ = f; if (isalpha(f)) break; f = *s++; } *p = '\0'; //fprintf(stderr, " [%s]\n", item_format); fprintf(output_file, item_format, arg); } } } else fprintf(output_file, "%c", c); } va_end(ap); } char commentbuff[1024 * 1024]; char *cbp = commentbuff; void dump_comment(char *s, ...) { va_list ap; if (suppress_icode) return; // Doesn't make sense to save these in the stack, but maybe saving them to an // array indexed by source line would work, which could be output along with // the actual source line. cbp += sprintf(cbp, "%s", comment_indent); va_start(ap, s); cbp += vsprintf(cbp, s, ap); va_end(ap); //cbp += sprintf(cbp, "%s", hashline); } void dump_imp_source(char *s, ...) { // insert the #line directive before every generated line. va_list ap; // if (suppress_perms) return; fprintf(output_file, "%s", source_indent); va_start(ap, s); vsprintf(buffer, s, ap); va_end(ap); char *p = buffer; for (;;) { int c = *p++; if (c == '\0') break; fputc(c, output_file); //if (c == '\n') fprintf(output_file, "%s", hashline); } fflush(output_file); buffer[0] = '\0'; } void dump_imp_to_c_string(char *impstr) { fputc('"', output_file); for (int i = 0; i < strlen(impstr); i++) { int c = impstr[i]; if (c == '"') { fputc('\\', output_file); fputc('"', output_file); } else if (c == '\n') { fputc('\\', output_file); fputc('n', output_file); } else if (c == '\b') { fputc('\\', output_file); fputc('b', output_file); } else if (c == '\f') { fputc('\\', output_file); fputc('f', output_file); } else if (c == '\r') { fputc('\\', output_file); fputc('r', output_file); } else if (c == '\t') { fputc('\\', output_file); fputc('t', output_file); } else if (c == '\v') { fputc('\\', output_file); fputc('v', output_file); } else if (c < 32 || c >= 127) { fprintf(output_file, "\\x%02X", ((unsigned char)c&255U)); } else if (c == '\\') { fputc(c, output_file); fputc(c, output_file); } else { fputc(c, output_file); } } fputc('"', output_file); } void show_source_code(int target_line, char *fname) { static char *source_file_name[128]; static FILE *source_file[128]; static int next_free_source_fileno = 0; static int source_line[128]; int this_file = -1; for (int i = 0; i < next_free_source_fileno; i++) { if (strcmp(fname, source_file_name[i]) == 0) { this_file = i; break; } } if (this_file < 0) { // Could also be detected on LINE 0 (d == 0)? // New file just now included? this_file = next_free_source_fileno++; source_file_name[this_file] = strdup(fname); source_file[this_file] = fopen(fname, "r"); if (source_file[this_file] == NULL) { fprintf(stderr, "Warning: cannot reopen listing file \"%s\" = %s\n", fname, strerror(errno)); } source_line[this_file] = 0; // start of new file. } if (source_file[this_file] != NULL) { /* Now output the source file lines up to line %d (first line is line 1.) */ for (;;) { #define MAX_LINE 1024 extern char line[MAX_LINE + 1]; int end; if (source_line[this_file] >= target_line) break; if (fgets(line, MAX_LINE, source_file[this_file]) == NULL) break; source_line[this_file] += 1; dump_imp_source("%6d ", source_line[this_file]); line[MAX_LINE] = '\0'; end = strlen(line); while (--end >= 0) { if (line[end] == '\r' || line[end] == '\n') line[end] = '\0'; else break; } dump("%s\n", line); } } } //----------------------------------------------------------------------- // remember to update typedef enum { ... } ASTCODE in ast.h // (you can't include arrays in header files that might be included // in multiple source files and you will then get multiple copies // of the array data which will fail at link time.) #define A(NAME) [AST_##NAME] = "AST_" #NAME const char *astname[ASTCODES] = { A(ASTCODE_WAS_ZERO), A(ICONST), A(RCONST), A(ISTRINGCONST), A(MONOP), A(BINOP), A(VAR), A(RESULT), A(CALL), A(RETURN), A(DECLARE_FP), A(DECLARE), A(START_PARAMLIST), A(CONDITIONAL_RESOLVE), A(UNCONDITIONAL_RESOLVE), A(COMPARE), A(COMPARE2), A(GOTO), A(IFGOTO), A(ONGOTO), A(DEFLAB), A(ASSIGN), A(LABEL), A(RESOLVE), A(DEF_SWLAB), A(DEF_DEFAULTSWLAB), A(GOTO_SWLAB), A(BOUNDSPAIR), A(SEQ), A(BLOCKSTART), A(BLOCKEND), A(COMMENT), // Experimental A(STOP), A(ADDRESS_OF), A(INDIRECT_THROUGH), A(FIELDSELECT), A(ARRAYACCESS), A(DYNAMICARRAYACCESS), A(FORMAL_PARAMETER_LIST), A(ACTUAL_PARAMETER), A(ACTUAL_PARAMETER_LIST), A(INDEX_LIST), A(PASS_PARAMETER), A(IMP_LINE), A(DOPEVECTOR), A(DIAGNOSE), A(CONTROL), A(MONITOR), A(SIGNAL), A(LVALUE), A(RVALUE), }; #undef A //----------------------------------------------------------------------- // temporary for debugging... const char *tag_fields[] = { "tag", "BASE_TYPE", // T_* eg T_INTEGER, T_REAL "FORM", // F_* eg F_FN "BASE_SIZE_CODE", "BASE_SIZE_BYTES", "LINKAGE", // X_* eg X_OWN, X_CONST etc "SPECIAL", // SPECIAL_* "IMP_NAME_IDX", "C_NAME_IDX", "EXTERNAL_NAME_IDX", "IS_BASE_NAME", "IS_ARRAY", "IS_ARRAY_NAME", "IS_SPEC_ONLY", // { 8, " spec" }, // S=1 "NO_AUTO_DEREF", // { 16, " {indirect-no-auto-deref, I=1}" } "NO_UNASS", // { 32, " {NO UNASSIGNED CHECKS, U=1}" } "STRING_CAPACITY", "RECORD_FORMAT", }; //----------------------------------------------------------------------- const char *operator[128] = { ['<'] = "<", ['>'] = ">", ['('] = "<=", [')'] = ">=", ['='] = "==", ['#'] = "!=", ['!'] = "|", ['%'] = "^", ['&'] = "&", ['.'] = "ERROR-.", ['*'] = "*", ['/'] = "/", // QUOT: integer divide ['+'] = "+", ['-'] = "-", ['Q'] = "/", // DIVIDE: real divide ['['] = "<<", [']'] = ">>", ['X'] = "ERROR-X", // IEXP ['x'] = "ERROR-x", // REXP ['S'] = "=", // but be careful re ASSVAL ASSREF }; /* DefineCAST(C_BINMINUS, 4, " - ", "BINMINUS" ,"") DefineCAST(C_BINPLUS, 4, " + ", "BINPLUS" ,"") DefineCAST(C_IDIV, 3, " / ", "IDIV" ,"") DefineCAST(C_BITNOT, 2, " ~", "BITNOT" ,"") DefineCAST(C_BITAND, 8, " & ", "BITAND" ,"") DefineCAST(C_BITEXOR, 9, "^", "BITEXOR" ,"") DefineCAST(C_BITOR, 10, "|", "BITOR" ,"") DefineCAST(C_MUL, 3, "*", "MUL" ,"") DefineCAST(C_RDIV, 13, " / ", "RDIV" ,"") DefineCAST(C_SHL, 5, "<<", "SHL" ,"") DefineCAST(C_SHR, 5, ">>", "SHR" ,"") DefineCAST(C_UNARY_MINUS, 2, " -", "UNARY_MINUS" ,"") DefineCAST(C_UNARY_PLUS, 2, " +", "UNARY_PLUS" ,"") DefineCAST(C_LOGNOT, 2, " !", "LOGNOT" ,"") DefineCAST(C_LOGAND, 11, " && ", "LOGAND" ,"") DefineCAST(C_LOGOR, 12, " || ", "LOGOR" ,"") DefineCAST(C_COMP_LT_EQ, 6, "<=", "COMP_LT_EQ" ,"") DefineCAST(C_COMP_LT, 6, " < ", "COMP_LT" ,"") DefineCAST(C_COMP_GT_EQ, 6, ">=", "COMP_GT_EQ" ,"") DefineCAST(C_COMP_GT, 6, " > ", "COMP_GT" ,"") DefineCAST(C_COMP_EQ, 7, "==", "COMP_EQ" ,"") DefineCAST(C_COMP_NOTEQ, 7, "!=", "COMP_NOTEQ" ,"") DefineCAST(C_COMP_EQ_ADDRESS, 7, "==", "COMP_EQ_ADDRESS" ,"") DefineCAST(C_COMP_NOTEQ_ADDRESS, 7, "!=", "COMP_NOTEQ_ADDRESS" ,"") */ /* ***WARNING*** *TO DO* goodbye.c:2489:35: warning: right shift count >= width of type [-Wshift-count-overflow] ATOM1 = (unsigned int)ATOM1 - 106 >> 1 + 91; ^~ My inference from this gcc warning message is that + binds tighter than >> and that my binop code (at least the '--tidy' version) got it wrong! */ // New table from https://www.geeksforgeeks.org/c/operator-precedence-and-associativity-in-c/ int c_binprio[128] = { // not yet debugged. Also, note that the numerical values from the table above // are the inverse of the normal convention. Lower numbers bind tighter here: ['X'] = -1, // "ERROR", // IEXP ['x'] = -1, // "ERROR", // REXP ['.'] = -1, // "ERROR", // *** NOTE *** Unary operations not handled here. // Multiplicative ['*'] = 3, // "*", ['/'] = 3, // "/", // QUOT: integer divide ['Q'] = 3, // "/", // DIVIDE: real divide // Additive ['+'] = 4, // "+", ['-'] = 4, // "-", // Bitwise shift ['['] = 5, // "<<", [']'] = 5, // ">>", // Relational ['<'] = 6, // "<", ['>'] = 6, // ">", ['('] = 6, // "<=", [')'] = 6, // ">=", // Equality ['='] = 7, // "==", ['#'] = 7, // "!=", // Bitwise AND ['&'] = 8, // "&", // An example in 'goodbye.imp' generates // "if (7 > DECL & 15) goto L_00b4;" without // bracketing "DECL & 15", which is wrong. // ">" is higher priority (binds tighter) // than "&". I'm still trying to track it // down, in COMPARE, COMPARE2, or BINOP. // Imp source line was: // %if 7 <= decl&15 %and decl&15 <= 10 %and decl&spec = 0 %start // Bitwise XOR ['%'] = 9, // "^", // Bitwise OR ['!'] = 10, // "|", // Assignment ['S'] = 14, // "=", // but be careful re ASSVAL ASSREF. Not used in imp }; int c_monprio[128] = { // not yet debugged ['\\'] = 2, // bitwise NOT ['U'] = 2, // unary '-' }; const char *translate_imp[4] = { /* translate 'special' codes below. Really not sure what these are used for yet. */ /* 0: */ "", #define SPECIAL_DEFAULT 0 /* 1: */ "%byte %integer ", #define SPECIAL_BYTE_INT 1 /* 2: */ "%short %integer ", #define SPECIAL_SHORT_INT 2 /* 3: */ "%long %real ", #define SPECIAL_LONG_REAL 3 }; const char *types_imp[16] = { /* 0: */ "TYPE=0 ", /* 1: */ "%integer ", #define T_INTEGER 1 /* If T is INTEGER takes the following meanings: = 1, full range 2, range 0..255 3, range -32768..32767 */ /* 2: */ "%real ", #define T_REAL 2 /* If T is REAL takes the following meanings: = 1, normal precision 4, double precision */ /* 3: */ "%string ", #define T_STRING 3 /* If T is STRING gives the maximum length of the string. */ /* 4: */ "%record ", #define T_RECORD 4 /* If T is RECORD gives the tag of the corresponding recordformat. */ /* 5: */ "Boolean ", #define T_BOOLEAN 5 // Pascal /* 6: */ "set ", #define T_SET 6 // Pascal /* 7: */ "byte-enumerated {format } ", #define T_BYTE_ENUMERATED 7 /* 8: */ "short-enumerated {format } ", #define T_SHORT_ENUMERATED 8 /* If T is enumerated gives the tag of the dummy format used to identify the enumerated value identifiers. */ /* 9: */ "%name ", // "pointer" #define T_POINTER 9 // for C? /* 10: */ "%byte ", #define T_CHAR 10 // for C? /* 11: */ "ERROR(T=11)", /* 12: */ "ERROR(T=12)", /* 13: */ "ERROR(T=13)", /* 14: */ "ERROR(T=14)", /* 15: */ "general-area" #define T_GENERAL 15 // ??? Maybe imp's generic %name parameter perhaps? }; const char *types_c[16] = { /* 0: */ "TYPE=0 ", /* 1: */ "int ", #define T_INTEGER 1 /* If T is INTEGER takes the following meanings: = 1, full range 2, range 0..255 3, range -32768..32767 */ /* 2: */ "float ", #define T_REAL 2 /* If T is REAL takes the following meanings: = 1, normal precision 4, double precision */ /* 3: */ "String ", // ONLY WITH ARRAYS for %string #define T_STRING 3 /* If T is STRING gives the maximum length of the string. */ /* 4: */ "struct ", #define T_RECORD 4 /* If T is RECORD gives the tag of the corresponding recordformat. */ /* 5: */ "Boolean ", #define T_BOOLEAN 5 // Pascal /* 6: */ "set ", #define T_SET 6 // Pascal /* 7: */ "byte-enumerated {format } ", #define T_BYTE_ENUMERATED 7 /* 8: */ "short-enumerated {format } ", #define T_SHORT_ENUMERATED 8 /* If T is enumerated gives the tag of the dummy format used to identify the enumerated value identifiers. */ /* 9: */ " * /*pointer*/", // "pointer" #define T_POINTER 9 // for C? /* 10: */ " char ", #define T_CHAR 10 // for C? /* 11: */ "ERROR(T=11)", /* 12: */ "ERROR(T=12)", /* 13: */ "ERROR(T=13)", /* 14: */ "ERROR(T=14)", /* 15: */ "general-area" #define T_GENERAL 15 // ??? Maybe imp's generic %name parameter perhaps? }; const char *forms_imp[16] = { /* 0: */ "(void F=0) ", // "void" #define F_VOID 0 /* 1: */ "(scalar F=1) ", // "simple" #define F_SIMPLE 1 /* 2: */ "%name ", #define F_NAME 2 /* 3: */ "%label ", #define F_LABEL 3 /* 4: */ "%record %format ", #define F_RECORDFORMAT 4 /* 5: */ "ERROR(F=5)", /* 6: */ "%switch ", #define F_SWITCH 6 /* 7: */ "%routine ", #define F_ROUTINE 7 /* 8: */ "%function ", #define F_FN 8 /* 9: */ "%map ", #define F_MAP 9 /* 10: */ "%predicate ", #define F_PREDICATE 10 /* 11: */ "%array ", #define F_ARRAY 11 /* 12: */ "%array %name ", #define F_ARRAY_NAME 12 /* 13: */ "%name %array ", #define F_NAME_ARRAY 13 /* 14: */ "%name %array %name ", #define F_NAME_ARRAY_NAME 14 /* 15: */ "ERROR(F=15)", }; const char *forms_c[16] = { /* 0: */ "void ", #define F_VOID 0 /* 1: */ "", // "simple" #define F_SIMPLE 1 /* 2: */ "", #define F_NAME 2 /* 3: */ "label ", #define F_LABEL 3 /* 4: */ "typedef struct ", #define F_RECORDFORMAT 4 /* 5: */ "ERROR(F=5)", /* 6: */ "switch ", #define F_SWITCH 6 /* 7: */ "void ", #define F_ROUTINE 7 /* 8: */ "", #define F_FN 8 /* 9: */ "", #define F_MAP 9 /* 10: */ "int ", #define F_PREDICATE 10 /* 11: */ "", #define F_ARRAY 11 /* 12: */ "", #define F_ARRAY_NAME 12 /* 13: */ "", #define F_NAME_ARRAY 13 /* 14: */ "", #define F_NAME_ARRAY_NAME 14 /* 15: */ "ERROR(F=15)", }; /* is a two-byte value: U<<5+I<<4+S<<3+X where: U is 1 check the object for unassigned 0 otherwise I is 1 if the object is an indirect object, 0 otherwise S is 1 if this is a spec, 0 otherwise X = 0 :: automatic (stack) allocation 1 :: own 2 :: constant 3 :: external 4 :: system 5 :: dynamic 6 :: primitive 7 :: permanent An indirect object (I=1) differs from F=2 in that F=2 implies that the actual object created will be a pointer and will be dereferenced whenever used unless explicit action is taken (e.g. use of Assign-Reference). If I=1 a pointer will be created (usually as an integer) and will be treated as an integer (or address) with no automatic dereferencing taking place. */ const char *ostates_imp[8] = { /* 0: */ "", #define X_AUTO 0 /* 1: */ "%own ", #define X_OWN 1 /* 2: */ "%constant ", #define X_CONST 2 /* 3: */ "%external ", #define X_EXTERNAL 3 /* 4: */ "%system ", #define X_SYSTEM 4 /* 5: */ "%dynamic ", #define X_DYNAMIC 5 /* 6: */ "%prim ", #define X_PRIM 6 /* 7: */ "%perm " #define X_PERM 7 }; const char *ostates_c[8] = { /* 0: */ "", #define X_AUTO 0 /* 1: */ "static ", #define X_OWN 1 /* 2: */ "const ", #define X_CONST 2 /* 3: */ "extern ", #define X_EXTERNAL 3 /* 4: */ "extern ", #define X_SYSTEM 4 /* 5: */ "extern ", #define X_DYNAMIC 5 /* 6: */ "static inline ", #define X_PRIM 6 /* 7: */ "extern " #define X_PERM 7 }; /* An indirect object (I=1) differs from F=2 in that F=2 implies that the actual object created will be a pointer and will be dereferenced whenever used unless explicit action is taken (e.g. use of Assign-Reference). If I=1 a pointer will be created (usually as an integer) and will be treated as an integer (or address) with no automatic dereferencing taking place. */ const OSPECIAL oflags[3] = { {8, "%spec "}, // S=1 {16, ""}, //" /*indirect-no-auto-deref, I=1*/"}, // <--- I=1 Object is indirect but should not be automatically indirected through like a %NAME variable. {32, ""}, //" /*NO UNASSIGNED CHECKS, U=1*/"}, }; int debug_ast = FALSE; // TRUE; const char *safe_astname(int idx) { if (idx >= 0 && idx < ASTCODES) return astname[idx]; return "INVALID"; } void debug_types_inner(char *name, int ast, char *file, int line) { if (!PARM_VERBOSE) return; // recfm 13161: AST_DECLARE 'SIMPLE' -> BASE_TYPE: %record (4) dump_code("/* %s %d: %s", name, ast, safe_astname(OP(ast))); /*if (OP(ast) == AST_DECLARE || OP(ast) == AST_VAR)*/ dump_code(" C_NAME: '%s'", C_NAME_IDX(ast) == 0 ? "" : pooltostr(C_NAME_IDX(ast))); dump_code( " -> BASE_TYPE: %s (%d)\n" " FORM: %s (%d)\n" " BASE_SIZE_CODE: %d BASE_SIZE_BYTES: %d\n" " LINKAGE: %s (%d)\n" " SPECIAL: %d\n" " BASE_%%NAME? %c ARRAY? %c ARRAY_NAME? %c SPEC? %c\n" " NO_AUTO_DEREF: %d STRLEN: %d RECFM: %d\n" " FORMAL_PARAMS: %d ACTUAL_PARAMS: %d\n" " BOUNDS: %d DOPEVECTOR: %d\n" " INDEX_LIST: %d\n", types_imp[BASE_TYPE(ast) & 15], BASE_TYPE(ast), forms_imp[FORM(ast) & 15], FORM(ast), BASE_SIZE_CODE(ast), BASE_SIZE_BYTES(ast), ostates_imp[LINKAGE(ast)], LINKAGE(ast), SPECIAL(ast), IS_BASE_NAME(ast) ? 'Y' : 'N', IS_ARRAY(ast) ? 'Y' : 'N', IS_ARRAY_NAME(ast) ? 'Y' : 'N', IS_SPEC_ONLY(ast) ? 'Y' : 'N', NO_AUTO_DEREF(ast), STRING_CAPACITY(ast), RECORD_FORMAT(ast), FORMAL_PARAM_LIST(ast), ACTUAL_PARAM_LIST(ast), BOUNDS1D(ast), DOPEVECTOR(ast), INDEX_LIST(ast) ); // we need both a holder for the record format *and* the formal param list in case there is a record function with params... dump_code(" UFC=%d [", USER_FIELD_COUNT(ast)); for (int i = 0; i < USER_FIELD_COUNT(ast); i++) { dump_code(" %d ", USERFIELD(ast, i)); } dump_code("] XFC=%d [", EXTENDED_FIELD_COUNT(ast)); for (int i = 0; i < EXTENDED_FIELD_COUNT(ast); i++) { dump_code(" %d", EXTRAFIELD(ast, i)); } dump_code("] in \"%s\":%d\n */\n", file, line); } int END_MARKER = UNASSIGNED; // Do not use. It's magic. int NEXT_AST = 0; // hackily shared with i2c.c int AST[MAX_AST]; // Ast entries are stored in here. // Ast entries must never include pointers to memory, // only integer data or indexes into arrays. // (Among other reasons, this allows us to relocate // the AST data which will be stored as a flex array) // Application-specific data int next_opd = 0; ASTIDX opdstack[MAX_ICODE_INSTRS]; // An AST entry is: (lower bounds inclusive, upper bounds exclusive) // 0..F: fixed fields (#F) common to all AST types, plus user fields (#U) which are // fixed for any specific AST type, which includes info such as the number of // fields in a specific ast type, plus the number of entries (#V) for variable- // length fields, which must follow the user fields and be located by the // contents of a user field. // F+1..U: user fields specific to each ast type // F+U+1..F+U+V: variable fields for this ast type (may be none) // void debug_tuple(ASTIDX tuple, char *mess) { fprintf(stderr, "%s AST TUPLE %d: OP=%d user fields: %d extended fields: %d\n", mess, tuple, OP(tuple), USER_FIELD_COUNT(tuple), EXTENDED_FIELD_COUNT(tuple)); fprintf(output_file, "%s AST TUPLE %d: OP=%d user fields: %d extended fields: %d\n", mess, tuple, OP(tuple), USER_FIELD_COUNT(tuple), EXTENDED_FIELD_COUNT(tuple)); if (OP(tuple) > ASTCODES) { fprintf(output_file, "* BAD tuple!\n"); fprintf(stderr, "* BAD tuple!\n"); exit(1); } } int IS_ICONST(const ASTIDX node) { return OP(node) == AST_ICONST; } int IS_RCONST(const ASTIDX node) { return OP(node) == AST_RCONST; } int IS_ZERO(const ASTIDX node) { return IS_ICONST(node) && USERFIELD(node, 0) == 0; } int IS_ATOMIC(const ASTIDX node) { if (OP(node) == AST_BINOP) return FALSE; if (OP(node) == AST_MONOP) return FALSE; if (OP(node) == AST_INDIRECT_THROUGH) return FALSE; if (OP(node) == AST_ADDRESS_OF) return FALSE; if (OP(node) == AST_RESOLVE) return FALSE; // Add any more that might mess up bracket removal... return TRUE; } // OK, THIS IS VERY IMPORTANT!!!! // The propogation upwards of type information has to be done at the point of creating the tuple! // It can either be done immedately after every call to mktuple, or it can be done here on the // fly in mktuple itself. The latter may cause some code duplication but may end up being a // cleaner interface. The sort of propogation I'm talking about is, for example, when a BINOP // is constructed, and the type of the binop is determined by the type of the operands. Or it // could be an array access, or a record field access, with the resulting types requiring some // local knowlege in order to be handled correctly. void COPY_FIXED_FIELDS_to_from(ASTIDX new, ASTIDX old) { // defaults, but need to be overridden depending on the operation // **** NOTE **** userfields and extended fields are NOT copied over by default! // This is primarily for propogating type info. I can probably avoid copying // a bunch of the fields. BASE_TYPE(new) = BASE_TYPE(old); // T_* eg T_INTEGER, T_REAL FORM(new) = FORM(old); // F_* eg F_FN BASE_SIZE_CODE(new) = BASE_SIZE_CODE(old); BASE_SIZE_BYTES(new) = BASE_SIZE_BYTES(old); LINKAGE(new) = LINKAGE(old); // X_* eg X_OWN, X_CONST etc SPECIAL(new) = SPECIAL(old); // SPECIAL_* IMP_NAME_IDX(new) = IMP_NAME_IDX(old); C_NAME_IDX(new) = C_NAME_IDX(old); EXTERNAL_NAME_IDX(new) = EXTERNAL_NAME_IDX(old); IS_BASE_NAME(new) = IS_BASE_NAME(old); IS_ARRAY(new) = IS_ARRAY(old); IS_ARRAY_NAME(new) = IS_ARRAY_NAME(old); IS_SPEC_ONLY(new) = IS_SPEC_ONLY(old); // { 8, " spec" }, // S=1 NO_AUTO_DEREF(new) = NO_AUTO_DEREF(old); // { 16, " {indirect-no-auto-deref, I=1}" } NO_UNASS(new) = NO_UNASS(old); // { 32, " {NO UNASSIGNED CHECKS, U=1}" } STRING_CAPACITY(new) = STRING_CAPACITY(old); RECORD_FORMAT(new) = RECORD_FORMAT(old); FORMAL_PARAM_LIST(new) = FORMAL_PARAM_LIST(old); ACTUAL_PARAM_LIST(new) = ACTUAL_PARAM_LIST(old); INDEX_LIST(new) = INDEX_LIST(old); // n-D arrays BOUNDS1D(new) = BOUNDS1D(old); // static etc 1-D arrays DOPEVECTOR(new) = DOPEVECTOR(old); // These two lines *ought* to have handled the case where an array is a field within a record but that does not yet seem to be working. *TO DO* INITVALUES(new) = INITVALUES(old); // index into a InitValues[] array of AST indexes. See INIT code. } ASTIDX mktuple_inner(StrpoolIDX file, int line, ASTCODE AST_code, ...) { va_list ap; int count = 0; int tuple = NEXT_AST; if (NEXT_AST >= MAX_AST) { fprintf(stderr, "* Either bump up MAX_AST or move to flex arrays.\n"); exit(EXIT_FAILURE); } int user_field_no = 0; for (int i = 0; i < FIXED_FIELDS; i++) AST[tuple + i] = (int)(/*1234000*/0x80808000U + (unsigned int)i); SOURCE_FILE(tuple) = file; SOURCE_LINE(tuple) = line; EXTENDED_FIELD_COUNT(tuple) = 0; OP(tuple) = AST_code; NEXT_AST += FIXED_FIELDS; count = 0; va_start(ap, AST_code); for (;;) { int i = va_arg(ap, int); if (i == END_MARKER) break; USERFIELD(tuple, user_field_no) = i; user_field_no += 1; count += 1; NEXT_AST += 1; // (a little redundancy was needed while debugging. can be cleaned up now)) if (NEXT_AST >= MAX_AST) { fprintf(stderr, "* Either bump up MAX_AST or move to flex arrays.\n"); exit(EXIT_FAILURE); } } va_end(ap); assert(count <= MAX_USER_FIELDS); USER_FIELD_COUNT(tuple) = count; // so the default *currently* (before I sort this out everywhere) is to set all those // fields to 0, which almost always signals to the programmer (once detected) that the // field is essentially unassigned. (although above you may have noticed an alternative // hint of setting a value to 1234000+n to be even more helpful in tracking down which // field we forgot to initialise!) // So just after these assignments is where we might do some of the simpler examples // of type promotion. BASE_TYPE(tuple) = 0; // T_* eg T_INTEGER, T_REAL FORM(tuple) = 0; // F_* eg F_FN BASE_SIZE_CODE(tuple) = 0; BASE_SIZE_BYTES(tuple) = 0; LINKAGE(tuple) = 0; // X_* eg X_OWN, X_CONST etc SPECIAL(tuple) = 0; // SPECIAL_* IMP_NAME_IDX(tuple) = 0; C_NAME_IDX(tuple) = 0; EXTERNAL_NAME_IDX(tuple) = 0; IS_BASE_NAME(tuple) = 0; IS_ARRAY(tuple) = 0; IS_ARRAY_NAME(tuple) = 0; IS_SPEC_ONLY(tuple) = 0; // { 8, " spec" }, // S=1 NO_AUTO_DEREF(tuple) = 0; // { 16, " {indirect-no-auto-deref, I=1}" } NO_UNASS(tuple) = 0; // { 32, " {NO UNASSIGNED CHECKS, U=1}" } STRING_CAPACITY(tuple) = 0; RECORD_FORMAT(tuple) = 0; FORMAL_PARAM_LIST(tuple) = 0; ACTUAL_PARAM_LIST(tuple) = 0; INDEX_LIST(tuple) = 0; BOUNDS1D(tuple) = 0; DOPEVECTOR(tuple) = 0; switch (OP(tuple)) { case AST_INDIRECT_THROUGH: COPY_FIXED_FIELDS_to_from(tuple, USERFIELD(tuple, 0)); // TO DO: remove %name part that causes dereferencing from the type information now that it has actually been dereferenced if (FORM(tuple) == F_NAME_ARRAY_NAME) { FORM(tuple) = F_NAME_ARRAY; } else if (FORM(tuple) == F_NAME) { FORM(tuple) = F_SIMPLE; } else if (FORM(tuple) == F_ARRAY_NAME) { FORM(tuple) = F_ARRAY; } else if (FORM(tuple) == F_MAP) { FORM(tuple) = F_SIMPLE; } break; case AST_FIELDSELECT: // mktuple(AST_FIELDSELECT, OLD_DECL_AST_TAG, subfield); COPY_FIXED_FIELDS_to_from(tuple, USERFIELD(tuple, 1)/*subfield*/); // So the resulting object *ought* to have all the properties of the subfield!?... break; case AST_ARRAYACCESS: case AST_DYNAMICARRAYACCESS: COPY_FIXED_FIELDS_to_from(tuple, USERFIELD(tuple, 0) /* the array */); switch (FORM(tuple)) { case F_ARRAY: case F_ARRAY_NAME: FORM(tuple) = F_SIMPLE; break; case F_NAME_ARRAY: case F_NAME_ARRAY_NAME: FORM(tuple) = F_NAME; break; default: break; } break; case AST_CALL: COPY_FIXED_FIELDS_to_from(tuple, USERFIELD(tuple, 0) /* the fn */); break; case AST_RESULT: COPY_FIXED_FIELDS_to_from(tuple, USERFIELD(tuple, 0)); break; case AST_VAR: // creating a var from a saved Descriptor[tag]. Done at the start of icode '@' COPY_FIXED_FIELDS_to_from(tuple, Descriptor[USERFIELD(tuple, 0)]); break; case AST_MONOP: { int opsym = USERFIELD(tuple, 0); int param1 = USERFIELD(tuple, 1); if (opsym == 'U' && IS_ICONST(param1)) { USERFIELD(param1,0) = -USERFIELD(param1,0); // (-(n)) => -n tuple = param1; // elide the unary '-' operation ('U') entirely. } else if (opsym == 'U' && IS_RCONST(param1)) { StrpoolIDX real = USERFIELD(param1, 0); char tmp[64]; sprintf(tmp, "%s", pooltostr(real)); // elide the unary '-' operation ('U') entirely: if (*tmp == '-') { // REMOVE THE MINUS tuple = mktuple(AST_RCONST, strtopool(tmp+1)); } else { // ADD A MINUS sprintf(tmp, "-%s", pooltostr(real)); tuple = mktuple(AST_RCONST, strtopool(tmp)); } } } break; case AST_BINOP: { // detuple(tuple, &AST_check_op, 0: &opsym, 1: ¶m1, 2: ¶m2); // using the info from the first operand is a short-term hack. Ideally // (TO DO) the result should reflect the widening of the two operands when combined. BASE_TYPE(tuple) = BASE_TYPE(USERFIELD(tuple, 1)); int opsym = USERFIELD(tuple, 0); int param1 = USERFIELD(tuple, 1); int param2 = USERFIELD(tuple, 2); // We'll also do a trivial bit of constant folding just to make the listings a smidgeon more readable. if ((opsym == '+' || opsym == '-') && IS_ICONST(param1) && IS_ICONST(param2)) { // fold const expression if (IS_ZERO(param2)) { tuple = param1; } else { int result; if (opsym == '+') result = USERFIELD(param1,0) + USERFIELD(param2,0); else result = USERFIELD(param1,0) - USERFIELD(param2,0); tuple = mktuple(AST_ICONST, result); } } else if ((opsym == '-') && IS_ICONST(param2) && (USERFIELD(param2,0) < 0)) { // x - (-n) => x+n tuple = mktuple(AST_BINOP, '+', param1, mktuple(AST_ICONST, -USERFIELD(param2,0))); } else if ((opsym == '+' || opsym == '-') && IS_ZERO(param2)) { tuple = param1; } } break; default: break; } if (PARM_VERBOSE) { (void)dump_code("// %d: mktuple(%s", tuple, astname[AST_code]); for (int i = 0; i < count; i++) { (void)dump_code(", %d", USERFIELD(tuple, i)); } (void)dump_code(")\n"); } return tuple; } // Note: any destination may be passed as NULL and value will be skipped. void detuple_inner(StrpoolIDX file, int line, ASTIDX tuple, void *AST_code, ...) { va_list ap; int count = 0; int *ptr; *(ASTCODE *)AST_code = OP(tuple); va_start(ap, AST_code); for (;;) { ptr = va_arg(ap, int *); if (ptr == &END_MARKER) break; if (ptr) *ptr = USERFIELD(tuple, count); // Don't write to a NULL field count += 1; } va_end(ap); } // USER APPLICATION-SPECIFIC PROCEDURES FOLLOW: void SHOW_STACK(char *after) { fprintf(output_file, "["); for (int i = next_opd - 1; i >= 0; i--) fprintf(output_file, " @%d:%d", i, opdstack[i]); fprintf(output_file, "]%s", after); } int CHECKPOP(void) { if (next_opd <= 0) return 0xDEADBEEF; if (debug_ast) { fprintf(output_file, "// POP() -> %d ", opdstack[next_opd - 1]); SHOW_STACK("\n"); } return opdstack[--next_opd]; } int POPQ(int *ast) { if (next_opd <= 0) return 0; *ast = opdstack[--next_opd]; if (debug_ast) { fprintf(output_file, "// POP() -> %d ", *ast); SHOW_STACK("\n"); } return 1; } extern void FLUSH_ICODE_STACK(void); int POP(void) { ASTIDX astidx = CHECKPOP(); if (astidx == 0xDEADBEEF) { fprintf(stderr, "* STACK UNDERFLOW!\n"); fprintf(output_file, "* STACK UNDERFLOW!\n"); FLUSH_ICODE_STACK(); exit(EXIT_FAILURE); } return astidx; } void PUSH(const ASTIDX node) { if (debug_ast) { fprintf(output_file, "// PUSH(%d) -> ", node); } opdstack[next_opd++] = node; if (debug_ast) SHOW_STACK("\n"); } void PUSH_ICONST(const int iconst) { ASTIDX tuple = mktuple(AST_ICONST, iconst); if (debug_ast) { fprintf(output_file, "// PUSH(#%d) -> ", iconst); } BASE_TYPE(tuple) = T_INTEGER; // BASETYPE_INTEGER; BASE_SIZE_BYTES(tuple) = 4; // actually should be value-dependent FORM(tuple) = F_SIMPLE; opdstack[next_opd++] = tuple; if (debug_ast) SHOW_STACK("\n"); } void PUSH_RCONST(const char *rconst) { ASTIDX tuple = mktuple(AST_RCONST, strtopool(rconst)); if (debug_ast) { fprintf(output_file, "// PUSH(#%s) -> ", rconst); } BASE_TYPE(tuple) = T_REAL; // BASETYPE_REAL; BASE_SIZE_BYTES(tuple) = 8; // Most imp systems work in long real internally and truncate to real on loading and saving FORM(tuple) = F_SIMPLE; opdstack[next_opd++] = tuple; if (debug_ast) SHOW_STACK("\n"); } void PUSH_IMPSTRINGCONST(const char *isconst) { ASTIDX tuple = mktuple(AST_ISTRINGCONST, strtopool(isconst)); if (debug_ast) { fprintf(output_file, "// PUSH(\"%s\") -> ", isconst); } BASE_TYPE(tuple) = T_STRING; // BASETYPE_IMPSTRING; BASE_SIZE_BYTES(tuple) = 255; // or 256? FORM(tuple) = F_SIMPLE; opdstack[next_opd++] = tuple; if (debug_ast) SHOW_STACK("\n"); } // unfortunately we are mirroring some info that actually is available in pass1: int switch_tag[MAX_SWITCHES]; int switch_low[MAX_SWITCHES]; int switch_high[MAX_SWITCHES]; //ASTIDX switch_decl[MAX_SWITCHES]; char *switches_set[MAX_SWITCHES]; // points to dynamic array of flags per switch index // This would have been better to have been stored in INDEX_LIST(ast) for the switch // declaration but I don't feel like going back to reimplement it since the current // hack actually works. 20:20 hindsight :-( int swstack_nextfree; int swbase[MAX_NESTED_BLOCKS]; // false bottom on stack of switches indexed by blocklevel // set by swbase[blocklevel] = swstack_nextfree just before // incrementing blocklevel, and swstack_nextfree = swbase[blocklevel] // whenever blocklevel is decremented int block_type[MAX_NESTED_BLOCKS]; // codegen by default evaluates the values of the objects it is given, so if a map call appears // withing a BINOP tuple for example, it is the value of the mapped object that is evaluated. // When we need the address of the object, e.g. for the ASSREF opcode ('==' assignment) that // will be pulled out as a special case. Same will apply for name parameters and the built-in // ADDR() function. void cdecl(ASTCODE AST_op, ASTIDX decltag) { ASTCODE AST_check_op; int tag; detuple(decltag, &AST_check_op, &tag); assert(AST_op == AST_check_op); accessible = TRUE; // ------------------------------------------------------------------------------------------------ // external etc: if ((LINKAGE(decltag) /*& 7*/) == X_AUTO) { if ((blocklevel > 0) && (IS_PROCEDURE(decltag)) && IS_SPEC_ONLY(decltag)) dump_code("auto "); // nested forward references using GCC must be declared 'auto'. The actual procedure doesn't have to be. } else if ((LINKAGE(decltag) /*& 7*/) == X_EXTERNAL) { // %external %integer fred -> int FRED; // %external %integer %spec fred -> extern int FRED; if (IS_SPEC_ONLY(decltag)) { dump_code("extern "); } } else { // Assuming for now that a %begin/%endofprogram is not going to skip the enclosing _imp_main // procedure, and make all procedures at that level global statics... dump_code("%s", ostates_c[LINKAGE(decltag) & 7]); } // ------------------------------------------------------------------------------------------------ // record format definitions are a special case. They can't be assigned or passed as // parameters. So relatively simple... if (FORM(decltag) == F_RECORDFORMAT) { // TO DO: alternative record fields (%or) dump_code( "typedef struct %s %s; // forward declaration to allow a 'next' pointer to a struct within that struct...\n", pooltostr(C_NAME_IDX(decltag)), pooltostr(C_NAME_IDX(decltag))); dump_code("struct %s {\n", pooltostr(C_NAME_IDX(decltag))); ASTIDX parameterlist = FORMAL_PARAM_LIST(decltag); ASTIDX field_op; int num_fields; //debug_types(parameterlist); detuple(parameterlist, &field_op, &num_fields); //dump_code(" tuple: %d;\n", num_fields); for (int field = 0; field < num_fields; field++) { dump_code(" %N;\n", EXTRAFIELD(parameterlist, field)); } dump_code("};\n"); return; } // ------------------------------------------------------------------------------------------------ // Regular cases follow... switch (BASE_TYPE(decltag)) { case T_INTEGER: { const char *datasize_name[4] = {"long long int " /*64 bits*/, "int " /*32 bits*/, "unsigned char " /*8 bits*/, "short " /*16 bits*/}; if (SPECIAL(decltag)) { const char *translate_c[4] = { /* translate 'special' codes below. */ /* 0: */ "", #define SPECIAL_DEFAULT 0 /* 1: */ "unsigned char ", #define SPECIAL_BYTE_INT 1 /* 2: */ "short ", #define SPECIAL_SHORT_INT 2 /* 3: */ "double ", #define SPECIAL_LONG_REAL 3 }; //dump_code("/*special*/ "); dump_code("%s", translate_c[SPECIAL(decltag) & 3]); } else { dump_code("%s", datasize_name[BASE_SIZE_CODE(decltag) & 3]); } } break; case T_REAL: if (BASE_SIZE_BYTES(decltag) == 4) dump_code("float "); else dump_code("double "); break; case T_RECORD: { // Let's handle record stuff separately too, it's not as awkward but still not completely regular... ASTIDX format_idx = RECORD_FORMAT(decltag); if (format_idx == 0) { dump_code(" void "); // %const %record (*) %name NIL == 0 / const void * NIL = 0; } else { StrpoolIDX formatstr = C_NAME_IDX(format_idx); dump_code(" %s ", pooltostr(formatstr)); } } break; default: if (FORM(decltag) == F_ROUTINE) { dump_code("void "); } else if (FORM(decltag) == F_PREDICATE) { dump_code("int /*Boolean*/ "); } else if (FORM(decltag) == F_SWITCH) { dump_code("static int %s_idx;\n", pooltostr(C_NAME_IDX(decltag))); dump_code( "static const void * /*SWITCH*/ "); // static const void *reason[10] = { &&reason_0, &&reason_1, ... &&reason_9 }; } else if (BASE_TYPE(decltag) == T_STRING) { // (move these two BASE_TYPE tests up into the switch statement above?) dump_code("_imp_string /*%%string(%d)*/ ", STRING_CAPACITY(decltag) & 255); } else if (BASE_TYPE(decltag) == 0 || FORM(decltag) == F_VOID) { if (!IS_A_POINTER(decltag)) { // Fortunate we can distinguish between the two rather hackily // TO DO: // The _imp_initialise(argc, char **argv) at the top of int main() makes a following // %label declaration fail because imperative code cannot come before a __label__ declaration. // (also the conditional test below isn't needed in externalroutines - just for the main begin/endofprogram block) if (blocklevel > 1) dump_code("__label__ U_%04X;\n", user_label_id[tag]); // %label ? return; // break; } else { dump_code("void "); // generic %name variable! %real fred; %name jim; jim == fred } } else { // Everything else (the default case) dump_code("/*TO DO: DEFAULT TYPE*/ %s ", types_c[BASE_TYPE(decltag)]); // placeholder } break; } // ------------------------------------------------------------------------------------------------ if (IS_BASE_NAME(decltag)) dump_code("/*name*/*"); // %name else if (FORM(decltag) == F_MAP) dump_code("/*map*/*"); // %map if (IS_ARRAY_NAME(decltag)) dump_code("/*arrayname*/*"); // %arrayname // either int *fred[] or int **fred ? NO! (was "**", now "*") See AST_PASS_PARAMETER: when param is an arrayname... // ------------------------------------------------------------------------------------------------ char *pname; dump_code("%s", pname = pooltostr(C_NAME_IDX(decltag))); if (IS_ARRAY(decltag) || (FORM(decltag) == F_SWITCH)) { if (LINKAGE(decltag) == X_AUTO) { // TO DO: check that DOPEVECTOR() is not 0 and BOUNDS1D() is 0 if (DOPEVECTOR(decltag) != 0) { dump_code("%N", DOPEVECTOR(decltag)); } else if (BOUNDS1D(decltag) != 0) { dump_code("%N", BOUNDS1D(decltag)); } else { dump_code("[/*missing array bounds*/]"); } if (FORM(decltag) == F_SWITCH) { // We don't need to wait until the switch labels are set (unlike in imptoc) as they are predictable! ASTIDX Lower, Upper; ASTCODE tag_check_op; ASTIDX bounds = BOUNDS1D(decltag); detuple(bounds, &tag_check_op, &Lower, &Upper); int LB, UB; LB = USERFIELD(Lower, 0); UB = USERFIELD(Upper, 0); dump_code(" = { "); for (int idx = LB; idx <= UB; idx++) { if (idx < 0) { dump_code("&&%s_M_%d, ", pname, -idx); } else { dump_code("&&%s_%d, ", pname, idx); } } dump_code(" }"); } } else { ASTIDX bounds = BOUNDS1D(decltag); // TO DO: check that BOUNDS1D() is not 0 and DOPEVECTOR() is 0 if (bounds != 0) { dump_code("%N", bounds); } else { dump_code("[/*missing N-D array bounds*/]"); } } } // ------------------------------------------------------------------------------------------------ // Note: %switch is effectively a const %label array with non-standard initialisation // and remember the C syntax is a bit weird if using the gcc extension, i.e. // the array elements need "&&". Probably simpler just to add some dispatch code // at the foot of the procedure, and jump to that whenever there's a '->sw(n)'... /* Also remember trick for negative labels. And default. if ((n < 0) || (n > 9)) BADSWITCH(n, __LINE__, __FILE__); #ifdef USE_GCC_EXTENSIONS goto *reason[n]; #else switch (n) { case 0: goto reason_0; case 1: goto reason_1; case 2: goto reason_2; case 3: goto reason_3; case 4: goto reason_4; case 5: goto reason_5; case 6: goto reason_6; case 7: goto reason_7; case 8: goto reason_8; case 9: goto reason_9; } #endif reason_0: // 0 printstring("compiler error!"); goto more; reason_1: // 1 printstring("switch vector too large"); goto more; */ // ------------------------------------------------------------------------------------------------ if (IS_PROCEDURE(decltag)) { dump_code("( %N )", FORMAL_PARAM_LIST(decltag)); if (IS_SPEC_ONLY(decltag)) { if ((LINKAGE(decltag) == X_EXTERNAL) && (EXTERNAL_NAME_IDX(decltag) != C_NAME_IDX(decltag))) { //dump_code(" __attribute__((weak, alias(%s)))", pooltostr(EXTERNAL_NAME_IDX(decltag))); /* Unfortunately no combination of weak, weakref, and alias works to simulate Imp-style %alias. The best workaround I can come up with is a wrapper procedure... static inline float FLOATYSQRT(float N) { extern float sqrtf(float); // Hide from rest of Imp program return sqrt(N); } Hooking that into this code is going to be tricky. Another alternative is even uglier, which is to use the dlopen mechanism for dynamic linking. But it ought to work and it should also enable calling of procedures whose linker names are not valid C identifiers. */ } if (AST_op == AST_DECLARE) dump_code(";\n"); } else { dump_code("\n"); // '}' now being added by AST_BLOCKSTART node. } } else { if (AST_op == AST_DECLARE) { ASTIDX init_var = INITVALUES(decltag); //if (init_var != -1) { // the constant tests below should not be necessary but remove the line below causes a cascade of errors. // I tried removing this to handle real = -literal, but it didn't work, so to fix a syntax error caused by initialisation // with a negative real constant, I've tweaked the 'U' - monop to fold negated real literals. if (init_var != -1 && (OP(init_var) == AST_ICONST || (OP(init_var) == AST_RCONST || (OP(init_var) == AST_ISTRINGCONST)))) { ASTIDX bounds = BOUNDS1D(decltag); if (bounds != 0) { // yes, putting an entire array on one line *is* messy, but it does preserve the #line numbering slightly better. ASTIDX Lower, Upper; ASTCODE tag_check_op; detuple(bounds, &tag_check_op, &Lower, &Upper); int LB, UB; LB = USERFIELD(Lower, 0); UB = USERFIELD(Upper, 0); // this is rather hacky and depends on all const tuple types having exactly 1 user field. int stride = FIXED_FIELDS + 1; /*GASTRICREFLUX*/ // (see elsewhere) int num_vals = UB - LB + 1; dump_code(" = { "); for (int idx = num_vals - 1; idx >= 0; idx--) { dump_code("%N, ", INITVALUES(decltag) - idx * stride); } dump_code(" }"); } else { // scalar initialisation dump_code(" = %N", INITVALUES(decltag)); } } dump_code(";\n"); } } // ------------------------------------------------------------------------------------------------ // } else { // // I don't think this can happen any more. // dump_code("/* ERROR? */ %s {T=%d} %s", ostates_c[LINKAGE(decltag)], BASE_TYPE(decltag), forms_c[FORM(decltag)]); // if (RECORD_FORMAT(decltag)) dump_code(" {format=%04x}", RECORD_FORMAT(decltag)); // } //if (IS_SPEC_ONLY(decltag)) dump_code("/*spec*/ "); //if (NO_AUTO_DEREF(decltag)) dump_code("/*no-auto-deref*/ "); //if (NO_UNASS(decltag)) dump_code("/*no-unass-check*/ "); } void codegen_inner(char *file, int line, int tuple) { ASTCODE AST_op, AST_check_op; if (tuple / 100000 == 100) { fprintf(stderr, "i2c: codegen was called in %s (line %d) with a tuple which was created as a placeholder at line %d\n", file, line, tuple % 100000); exit(EXIT_FAILURE); } AST_op = OP(tuple); switch (AST_op) { #ifdef NOT_YET case AST_RECORD_FORMAT: { // Just output the name of the record format... } break; #endif case AST_DECLARE_FP: // Identical to AST_DECLARE except we don't want the ";\n" after everything! // (the commas between parameters will be inserted by AST_FORMAL_PARAMETER_LIST) case AST_DECLARE: { cdecl(AST_op, tuple); debug_types(tuple); } break; // The start of a procedure body increases the level same as a BLOCKSTART (%begin). // Both are terminated by a BLOCKEND (%end). There are some housekeeping actions // that will need to be performed on a BLOCKEND: // 1) Place any missing switch labels, and have them output a 'missing switch label' // error message. This code will also be branched to by the range test to be // added to the ->sw(n) jumps when n is outside the range of the switch labels. // Note that the 'blocklevel' variable that tracks the current scope level is // currently being handled by i2c.c but probably should be moved to this unit instead. // (See the code for Define Var ('$'), Begin ('H') and End (';') in i2c.c) case AST_BLOCKSTART: { swbase[blocklevel] = swstack_nextfree; blocklevel += 1; int BLOCKTYPE, name, level = 0; // level of the block we are about to go into. detuple(tuple, &AST_check_op, &level, &BLOCKTYPE, &name); if (level != blocklevel) { dump_code("/*BUG:blocklevel=%d level=%d*/", blocklevel, level); blocklevel = level; } blockname[blocklevel] = name; block_type[blocklevel] = BLOCKTYPE; if (BLOCKTYPE == BLOCKTYPE_BEGIN_ENDOFPROGRAM) { dump_code("int main(int argc, char **argv) {\n", level); dump_code(" __label__ _imp_endofblock;\n"); dump_code(" _imp_initialise(argc, argv);\n", level); } else { // dump_code("{ // Start of block %s at level %d\n", pooltostr(blockname[level]), level); dump_code("{\n"); dump_code(" __label__ _imp_endofblock;\n"); } } break; case AST_BLOCKEND: { int level = 0; // level of the block being ended detuple(tuple, &AST_check_op, &level); int BLOCKTYPE = block_type[level]; //dump_code("\n/*AST_BLOCKEND: level=%d BLOCKTYPE=%d blockname=%s */\n", level, BLOCKTYPE, pooltostr(blockname[level])); if (blocklevel == 0) { dump_code("// End of file\n"); } else { if (BLOCKTYPE == BLOCKTYPE_BEGIN_ENDOFPROGRAM) { // %endofprogram dump_code("return 0;\n"); accessible = FALSE; } else { // TO DO: possibly handle missing %result etc for fn/map/pred, plus a "return;" for %routines switch (BLOCKTYPE) { case BLOCKTYPE_BEGIN_END: dump_code("goto _imp_endofblock;\n"); break; // btw Imp77 allows %return but C does not. accessible = FALSE; break; case BLOCKTYPE_ROUTINE: dump_code("return;\n"); accessible = FALSE; break; // not an error case BLOCKTYPE_FN: case BLOCKTYPE_MAP: case BLOCKTYPE_PREDICATE: if (accessible) { dump_code("/*_imp_signal(8, 0, (_imp_current_line != 0 ? _imp_current_line : __LINE__));*/\n"); dump_code("fprintf(stderr, \"%%%%RESULT missing in %%s in file %%s:%%d\\n\", __PRETTY_FUNCTION__, (_imp_current_file != 0 ? _imp_current_file : __FILE__), (_imp_current_line != 0 ? _imp_current_line : __LINE__));\n"); dump_code("exit(1);\n"); accessible = FALSE; } break; } } int sw_at_this_level = swstack_nextfree; // locate the switch definition in the stack... (we keep a redundant copy of data that could probably be got from pass1, for convenience) for (;;) { if (sw_at_this_level == swbase[blocklevel-1]) break; // or should that be if (sw_at_this_level == swbase[blocklevel]) break; ?/? if (sw_at_this_level == 0) break; sw_at_this_level -= 1; int missing=0; int switchtag = switch_tag[sw_at_this_level]; int swstack_idx = sw_at_this_level; for (;;) { if (swstack_idx < 0) break; if (switch_tag[swstack_idx] == switchtag) { int low = switch_low[swstack_idx]; int high = switch_high[swstack_idx]; char *switch_flag = switches_set[swstack_idx]; for (int idx = low; idx <= high; idx++) { if (switch_flag[idx-low] == 0) { // MARK AS USED! int index_ast = mktuple(AST_ICONST, idx); missing += 1; codegen(mktuple(AST_DEF_SWLAB, mktuple(AST_VAR, switchtag), index_ast)); // use 'codegen()', not 'dump_code()', otherwise it comes out after the '}' is printed! } } break; } swstack_idx -= 1; } if (missing) { // TO DO! We need to a) have a location associated with this switch's declaration which is // initialised to 'a default has not yet been supplied' // and B) set that to 'a default *has* been supplied' on this icode. // It will be tested on the end of the block, where we have 3 options: // 1) there are unset labels in the switch's range and no default - output an error message // 2) there are unset labels in the switch's range and there is a default - so jump to it // 3) there are no unset labels, the range was already fully used: don't generate any epilog code // (note we have a new opcode, '`', to define the default switch label) int default_supplied = STRING_CAPACITY(Descriptor[switchtag]); // TO DO. StrpoolIDX switchname = C_NAME_IDX(Descriptor[switchtag]); if (default_supplied) { dump_code("goto %s_default;\n", pooltostr(switchname)); } else { dump_code("/*_imp_signal(8,%s_idx,(_imp_current_line != 0 ? _imp_current_line : __LINE__),\"SWITCH LABEL NOT SET - %s\");*/\n", pooltostr(switchname), pooltostr(switchname)); // or %signal 6, 3, SW_idx ? dump_code("fprintf(stderr, \"%%%%SWITCH LABEL NOT SET - %s(%%d): at line %%s:%%d\", %s_idx, (_imp_current_file != 0 ? _imp_current_file : __FILE__), (_imp_current_line != 0 ? _imp_current_line : __LINE__));\n", pooltostr(switchname), pooltostr(switchname)); dump_code("exit(1);\n"); } accessible = FALSE; } } swstack_nextfree = swbase[blocklevel-1]; // this might fix the bug mentioned above..? // The ';' before the '}' is to keep C happy re no labels before '}' // - a problem which goes away when an appropriate return is added... dump_code("_imp_endofblock: ;\n} // End of block %s at level %d\n", pooltostr(blockname[level]), level); } //dump_code("\n/* Blocklevel was %d */\n", blocklevel); if (blocklevel > 0) { // blocklevel is the global describing the current block level blocklevel -= 1; } //dump_code("\n/* Blocklevel is now %d */\n", blocklevel); accessible = TRUE; } break; case AST_RESULT: { int rslt; detuple(tuple, &AST_check_op, &rslt); assert(AST_op == AST_check_op); //if (IS_A_POINTER(rslt)) { // by which I should have said IS_SOMETHING_THAT_SHOULD_BE_AUTOMATICALLY_DEREFERENCED_IN_IMP(rslt) ... if (REQUIRES_AUTO_DEREF(rslt)) { rslt = mktuple(AST_INDIRECT_THROUGH, rslt); } dump_code("return %N;\n", rslt); accessible = FALSE; } break; case AST_RETURN: { detuple(tuple, &AST_check_op); assert(AST_op == AST_check_op); // TO DO: *** Note *** in a %begin/%end block which Imp77 treats as an anonymous %routine, issuing // a %return causes a jump to the end of the block. I either have to substitute a jump // when this happens, *or* change the implementation of blocks to match Imp77's concept. // If I do that, best to make it an inline procedure to closer simulate Imp77's behaviour. dump_code("return;\n"); // so for the moment, this obscure case is broken :-( accessible = FALSE; } break; case AST_ICONST: { int iconst; detuple(tuple, &AST_check_op, &iconst); /*GASTRICREFLUX*/ assert(AST_op == AST_check_op); if (iconst < 0) { dump_code("(%d)", iconst); } else { dump_code("%d", iconst); } } break; case AST_ISTRINGCONST: { StrpoolIDX isconstIDX; detuple(tuple, &AST_check_op, &isconstIDX); /*GASTRICREFLUX*/ assert(AST_op == AST_check_op); if (0) dump_code("_imp_str_literal(%s)", pooltostr(isconstIDX)); /* TO DO !!!! escape '\' chars in literal strings which are already between " chars... (and handle other chars that C escapes with '\' such as \n etc.) Also handle doubled " characters inside the string */ dump_code("_imp_str_literal("); dump_imp_to_c_string(pooltostr(isconstIDX)); dump_code(")"); } break; case AST_RCONST: { StrpoolIDX rconstIDX; detuple(tuple, &AST_check_op, &rconstIDX); /*GASTRICREFLUX*/ assert(AST_op == AST_check_op); char *reals = pooltostr(rconstIDX); if (*reals == '-') { dump_code("(%s)", reals); } else { dump_code("%s", reals); } } break; case AST_CALL: { // procedure call or fn/predicate call or map call - in all cases the required // value is the actual data, not the address of a pointer. So we automatically // dereference pointers, which in this case can only be a %map call. // TO DO: *Note* we need to match the actual parameters with the formal // parameters so that type conversions (widening, narrowing etc) can be done if needed. // We also need to look at calls to see if they are perm calls, and if so, we can // mess about with them, such as substituting C scanf calls for READ etc, or using // the C '%' operator for Imp's REM() call. /* TO DO: Imp defines left to right order of evaluation of parameters to procedures, but it's only relevant if any of the parameters is a function call with potential side-effects: int proc(int a, char *b, float c, int *d) { } float getfloat(void) { return 3.141592653589793; } int intfun(void) { return 42; } int main(int argc, char **argv) { int res, d; // Standard C calling which in practise evaluates in right-to-left order, although // the C standard does not in fact define any sequence points or an order of evaluation... res = proc(intfun()+1,"literal",getfloat(),&d); // Imp-safe version of call: function calls replaced with locals declared and sequenced in left-to-right order: res = ( {int tmp1 = intfun()+1; float tmp2 = getfloat(); proc(tmp1,"literal",tmp2,&d);} ); return 0; } */ ASTIDX proc, actualparameterlist, formalparameterlist; detuple(tuple, &AST_check_op, &proc); formalparameterlist = FORMAL_PARAM_LIST(proc); actualparameterlist = ACTUAL_PARAM_LIST(proc); // a tuple of type AST_ACTUAL_PARAMETER_LIST if (!IS_PROCEDURE(proc)) { dump_code("/* BAD FORM %s (%d) - NOT CALLABLE!*/", forms_imp[FORM(proc) & 15], FORM(proc)); break; } // *** TO DO *** - loop over the two parameter lists in parallel here, // construct a AST_PASS_PARAMETER tuple for each pair // and have that do the actual output of the actual parameter, // using the info from the formal parameter to ensure // that indirection is handled properly. /* // 5 // 6 %integername pointer int *POINTER; // 7 %integer i int I; // 8 // 9 do(3, i) DO(3, I); // 10 do(3, pointer) DO(3, *POINTER); */ if ((FORM(proc) == F_MAP) && ((LINKAGE(proc) == X_PERM || LINKAGE(proc) == X_PRIM) && (strcmp(pooltostr(C_NAME_IDX(proc)), "RECORD")==0))) { // special case handling for recordname == RECORD(0) dump_code("/*F_MAP2*/*(char *)"); // Well, it's ugly, but it seems to have done the trick... } dump_code("%s(", pooltostr(C_NAME_IDX(proc))); { int count; detuple(actualparameterlist, &AST_check_op, &count); if (count != 0) { for (int i = 0; i < count; i++) { ASTIDX actualparam = EXTRAFIELD(actualparameterlist, i); ASTIDX formalparam = EXTRAFIELD(formalparameterlist, i); ASTIDX pass_parameter = mktuple(AST_PASS_PARAMETER, actualparam, formalparam); dump_code("%N", pass_parameter); if (i < count - 1) dump_code(", "); } } } dump_code(")"); if (FORM(proc) == F_ROUTINE) dump_code(";\n"); } break; case AST_RVALUE: { extern int PARM_OPT; int tag; detuple(tuple, &AST_check_op, &tag); if (0 && (!PARM_OPT) && (BASE_TYPE(Descriptor[tag]) == T_INTEGER) && (!IS_A_POINTER(Descriptor[tag]))) { // can't do this yet while these can still turn up on the LHS of an assignment dump_code("_U(%s)", pooltostr(C_NAME_IDX(Descriptor[tag]))); } else { // if (IS_A_POINTER(Descriptor[tag])) dump_code("*"); // not yet sure where the correct place is to determine if // an object is a pointer and to indirect through it. // It *might* be at the top level assval/pass_actual_parameter? dump_code("%s", pooltostr(C_NAME_IDX(Descriptor[tag]))); } } break; case AST_LVALUE: case AST_VAR: { // In my quest to simplify this program, I'm currently rewriting the many places that handle // indirection, to have them apply REQUIRES_AUTO_DEREF() to their arguments. I'm thinking that // this tuple and a few key choice ones such as ACCESS/SELECT may be all that are needed // and that places like binop etc are a red herring ***TO DO*** // I've already successfully removed TAG and modified PUSH(Var) to wrap the tag in AST_VAR int tag; detuple(tuple, &AST_check_op, &tag); // *** TO DO ***!!!!! // if used in an expression, if this is a %name type with automatic de-referencing, // we need to apply a '*' before the name (which may need to be bracketed?) in order // to dereference it. However a VAR can also be used on the LHS of an ASREF ('==') // assignment or be passed as a %name parameter, in which case the '* should not be // added! // I think the ideal way to handle these is to insert AST_DEREFERENCE nodes in front // of vars, and fold any that come in pairs with AST_ADDRESS_OF nodes. // Oh.. of course... I also need to do what I did in imptoc which was to have // separate AST types for AST_LVALUE and AST_RVALUE !!! OK, underway now... //if (IS_A_POINTER(Descriptor[tag])) dump_code("*"); // <--------------------------------------------------------------------------------------------- dump_code("%s", pooltostr(C_NAME_IDX(Descriptor[tag]))); } break; case AST_RESOLVE: { /* if (_imp_resolve(S, A, _imp_str_literal("xxx"), 0)) goto L_0004; ^ | ... needs '&'... // 25 newline NEWLINE(); // 26 %finish L_0004: // 27 // 28 %endofprogram return 0; _imp_endofblock: ; } // End of block _imp_main at level 1 // End of file cc -O -Wa,-adhln -g -DPARM_OPT -fmerge-constants -o test-junk/restests test-junk/restests.c perms.c > test-junk/restests.lis ( you might prefer to compile with ./i2c --check --gdb test-junk/restests.imp ) gtoal@linux:~/src/i2c$ fgrep _imp_resolve perms.h extern int _imp_resolve (_imp_string s, _imp_string *left, _imp_string match, _imp_string *right); gtoal@linux:~/src/i2c$ */ ASTIDX strtomatch, sourcestring, opd1, opd2; int OPD1, OPD2; detuple(tuple, &AST_check_op, &strtomatch, &sourcestring, &OPD1, &OPD2, &opd1, &opd2); // int _imp_resolve(_imp_string s, _imp_string *left, _imp_string match, _imp_string *right) // if C strings, use strstr? // This is probably the wrong place to do this indirection. The default output of a variable // should be the value of the variable with automatic dereferencing applied. So it's whereever // a %strigname variable is output that really should be fixed, I suspect. But for now I'll // let this quick hack stand. //if (IS_A_POINTER(sourcestring)) sourcestring = mktuple(AST_INDIRECT_THROUGH, sourcestring); if (REQUIRES_AUTO_DEREF(sourcestring)) sourcestring = mktuple(AST_INDIRECT_THROUGH, sourcestring); dump_code("_imp_resolve(%N, ", sourcestring); if (OPD1) { dump_code("%N", mktuple(AST_ADDRESS_OF, opd1)); // ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ ought to have made it work. I guess it depends on what opd1 is? } else { dump_code("0 /*NULL*/"); } dump_code(", %N, ", strtomatch); if (OPD2) { dump_code("%N)", mktuple(AST_ADDRESS_OF, opd2)); // ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ and opd2... } else { dump_code("0 /*NULL*/)"); } } break; case AST_CONDITIONAL_RESOLVE: { ASTIDX resolve; detuple(tuple, &AST_check_op, &resolve); dump_code("%N", resolve); } break; case AST_UNCONDITIONAL_RESOLVE: { ASTIDX resolve; detuple(tuple, &AST_check_op, &resolve); // https://gtoal.com/history.dcs.ed.ac.uk/archive/docs/EMAS_Manuals/IMP/Edinburgh_IMP_Language_Manual.pdf P144 dump_code("if (!%N) _imp_signal(7,1,0, \"string resolution fails\");\n", resolve); } break; case AST_ONGOTO: { ASTIDX eventlist; int lab; int count = 0; detuple(tuple, &AST_check_op, &eventlist, &lab); // note eventlist is a raw 16 bit value, not an ICONST dump_code("if (!_imp_on_event("); for (int evno = 0; evno < 16; evno++) { if ((eventlist & (1<> 1 breaks. // I added a precedence table for monops but with full bracketing // I don't think I need it now. (It was to handle the stupid -1 >> 1 problem) //if (IS_A_POINTER(param1)) dump_code("*"); // <--------------------------------------------------------------------------------------------- if (IS_ATOMIC(param1)) { dump_code("(%c%N)", opsym == '\\' ? '~' : '-', param1); } else { dump_code("(%c(%N))", opsym == '\\' ? '~' : '-', param1); } } } break; case AST_COMPARE2: { // First iteration at handing double-sided conditions better: just do what we did before... ASTIDX param1, param2, param3; int opsym1, opsym2; detuple(tuple, &AST_check_op, ¶m1, &opsym1, ¶m2, &opsym2, ¶m3); int needs_cache = (IS_PROCEDURE(param1) || IS_PROCEDURE(param2) || IS_PROCEDURE(param3)); if (REQUIRES_AUTO_DEREF(param1)) param1 = mktuple(AST_INDIRECT_THROUGH, param1); if (REQUIRES_AUTO_DEREF(param2)) param2 = mktuple(AST_INDIRECT_THROUGH, param2); if (REQUIRES_AUTO_DEREF(param3)) param3 = mktuple(AST_INDIRECT_THROUGH, param3); // TO DO: current bug. After adding COPY code to mktuple(AST_INDIRECT_THROUGH), // most of the problems went away, but this new one appeared: // 2395 ->INGLA %IF 0<=LDISP<=2;! THESE 3 ALWAYS IN THE GLA // which showed up in the C output as **LDISP, i.e. double deref'd. (LDISP is an integername) if (needs_cache) { // potential side-effects, so ensure the functions are called in left-to-right order and not called twice for the middle value // Unfortunately we need to get the type info from Imp rather than using C's typeof() hack, because // the C mechanism does not work with literals, only variables, so either we don't cache variables // (which is doable but awkward) or we look at the type information of the params and use that // explicitly in the declarations. (which is doable but awkward). // For now I'll just make an approximate solution using integer, real and string... int basetype = BASE_TYPE(param2); // for now ignore precision... /* TO DO */ char *usetype; if (basetype == T_INTEGER || basetype == T_REAL) { if (basetype == T_INTEGER) usetype = "int"; else usetype = "double"; /* test/soap80-a.c: In function 'STOI': test/soap80-a.c:4488:29: warning: initialization of 'int' from 'unsigned char *' makes integer from pointer without a cast [-Wint-conversion] 4488 | if (({int tmp1 = 48, tmp2 = _imp_CHARNO(&SNUM, 1), tmp3 = 57; (tmp1 > tmp2) || (tmp2 <= tmp3);})) goto L_025d; | ^~~~~~~~~~~ Why didn't the call to the CHARNO map get automatically dereferenced? If I add dereferencing here do I need to check all 3 operands? */ dump_code("({%s tmp1 = %N, tmp2 = %N, tmp3 = %N; (tmp1 %s tmp2) || (tmp2 %s tmp3);})", usetype, param1, param2, param3, operator[opsym1], operator[opsym2]); } else if (basetype == T_STRING) { dump_code("({_imp_string tmp1, tmp2, tmp3; _imp_strcpy(tmp1, %N); _imp_strcpy(tmp2, %N); _imp_strcpy(tmp3, %N); _imp_strcmp(tmp1, tmp2) %s 0) || _imp_strcmp(tmp2, tmp3) %s 0;})", param1, param2, param3, operator[opsym1], operator[opsym2]); } else { // fallback code. Hope this doesn't happen, but at least I've marked to in case it does... // TO DO: I think this one was caused by param2 having auto deref applied, and the resulting tuple must not have had its BASETYPE copied over correctly? dump_code("/*BUG@%d? basetype=%d*/ (%N) || (%N)", __LINE__, basetype, mktuple(AST_COMPARE, param1, opsym1, param2), mktuple(AST_COMPARE, param2, opsym2, param3)); } } else { // No need - no side-effects... let GCC optimise the 2 accesses to param2... dump_code("(%N) || (%N)", mktuple(AST_COMPARE, param1, opsym1, param2), mktuple(AST_COMPARE, param2, opsym2, param3)); } } break; // Although I should really merge COMPARE with BINOP, there's no need to, // since it is not possible in imp to mix arithmetic operations with // comparisons, other than the single comparison in the simplified 'if' // statement as output by pass1 to icode. // NOTE that AST_COMPARE is (currently) OPD opsym OPD // but AST_BINOP is opsym OPD OPD. This caused problems // in an earlier revision of this code... case AST_COMPARE: { ASTIDX param1, param2; int comparison_opsym; detuple(tuple, &AST_check_op, ¶m1, &comparison_opsym, ¶m2); //if (IS_NAME(param1)) param1 = mktuple(AST_INDIRECT_THROUGH, param1); if (REQUIRES_AUTO_DEREF(param1)) param1 = mktuple(AST_INDIRECT_THROUGH, param1); //if (IS_NAME(param2)) param2 = mktuple(AST_INDIRECT_THROUGH, param2); if (REQUIRES_AUTO_DEREF(param2)) param2 = mktuple(AST_INDIRECT_THROUGH, param2); if (IS_STRING(param1) || IS_STRING(param2)) { // should be both! :) dump_code("_imp_strcmp(%N, %N) %s 0", param1, param2, operator[comparison_opsym]); } else { int FULLY_BRACKETED = !PARM_TIDY; if (FULLY_BRACKETED) { dump_code("(%N)", param1); } else if (IS_ATOMIC(param1)) { dump_code("%N", param1); } else if (IS_BINOP(param1)) { int binop_opsym = USERFIELD(param1, 0); if (c_binprio[comparison_opsym] < c_binprio[binop_opsym]) { dump_code("(%N)", param1); } else { dump_code("%N", param1); } } else { dump_code("(/*why?*/%N)", param1); } dump_code(" %s ", operator[comparison_opsym]); // An example in 'goodbye.imp' generates "if (7 > DECL & 15) goto L_00b4;" without bracketing "DECL & 15", which is wrong. ">" is higher priority than "&". if (FULLY_BRACKETED) { dump_code("(%N)", param2); } else if (IS_ATOMIC(param2)) { dump_code("%N", param2); } else if (IS_BINOP(param2)) { int binop_opsym = USERFIELD(param2, 0); if (c_binprio[comparison_opsym] < c_binprio[binop_opsym]) { dump_code("(%N)", param2); } else { if (0) dump_code("/*8: c_binprio[comparison_opsym='%c'] = %d, c_binprio[binop_opsym = '%c'] = %d */", comparison_opsym, c_binprio[comparison_opsym], binop_opsym, c_binprio[binop_opsym]); dump_code("%N", param2); } } else { dump_code("(/*why?*/%N)", param2); } } } break; case AST_BINOP: { // We don't *need* to remove superfluous parentheses as gcc would have handled it for us, // and indeed doing so does marginally increase the risk of a coding error in the translation, // but by goodness, it does look so much better! (ar least when #line is turned off and some // of the intrusive checks such as _U() and _R()...) // The big area of code still to be handled is that whenever we are evaluating an RVALUE, /*TO DO*/ // we need to indirect *WHERE APPROPRIATE* when the value is a pointer, and then *remove* // the pointer status from the result in most cases. At this time in the wee small hours // I'm unwilling to say if the same applies to LVALUEs... // I think this applies mostly to array accesses and record field selects. I don't think // it's relevant to the results of binops which I think are always scalars but may not // yet be getting marked as such. It does also have to be handled by %result's as well // as assignment to a procedure's parameters. int opsym; ASTIDX param1, param2; // for MOD, depending on the type of the operand, call one of: // int abs(int j); // long int labs(long int j); // long long int llabs(long long int j); // double fabs(double x); // float fabsf(float x); // long double fabsl(long double x); // ... similar options for other operations. IEXP/REXP? // This might need to use the Descriptor[] array... detuple(tuple, &AST_check_op, &opsym, ¶m1, ¶m2); //if (IS_NAME(param1)) param1 = mktuple(AST_INDIRECT_THROUGH, param1); // hopefully %map has been taken care of elsewhere if (REQUIRES_AUTO_DEREF(param1)) param1 = mktuple(AST_INDIRECT_THROUGH, param1); // hopefully %map has been taken care of elsewhere //if (IS_NAME(param2)) param2 = mktuple(AST_INDIRECT_THROUGH, param2); if (REQUIRES_AUTO_DEREF(param2)) param2 = mktuple(AST_INDIRECT_THROUGH, param2); // Can reduce the extra brackets using the precedence of the operators in param1,param2 vs opsym // however since this C is not fit for human consumption anyway, why bother? if (opsym == '.') { /* // 678 reason(9): printstring("Included file ".include file." does not exist") REASON_9: PRINTSTRING(_imp_strcat(&_imp_strcat(&_imp_str_literal("Included file "), INCLUDEFILE), _imp_str_literal(" does not exist"))); */ // TO DO: set type information in the AST_BINOP '.' node. Strcat appends to its first parameter, the // address of which it returns as its result. Calls such as PRINTSTRING which take a string value // parameter have to add a '*' (AST_DEREFERENCE) in order to pass a string that is formed by concatenation. dump_code("_imp_join((_imp_string)%N,(_imp_string)%N)", param1, param2); //dump_code("%N", mktuple(AST_ADDRESS_OF, param1)); //dump_code(", %N)", param2); } else if (opsym == 'X') { // IEXP // TO DO: more dump_code("_imp_IEXP(%N, %N)", param1, param2); // to do: add to perms properly. Should be _imp_iexp to avoid potential user name clash *TO DO* } else if (opsym == 'x') { // REXP // TO DO: more dump_code("_imp_REXP(%N, %N)", param1, param2); // to do: add to perms properly. Should be _imp_rexp to avoid potential user name clash *TO DO* } else { // wrong. reals long / reals normal is not passed on to the icode - code generation works by // pass1 marking the descriptor with the data size as it is created. So for real division we // need to examine both operands. // Also TO DO: casting is bypassing the cprio stuff. Brackets were needed here: // 2624 n = (n+15)>>4; ! slots needed (includes zero) // N = (int)((unsigned int)N + 15 >> 4); // ^^^^^^ // ^^^^^^^^^^^^^ char *cast = "", *LB = "", *RB = ""; if (opsym == '/') { cast = "(int)"; /*TO DO - can't assume int. could be long long int. etc.*/ LB = "("; RB = ")"; } else if (opsym == 'Q') { cast = 0 /*TO DO*/ ? "(double)" : "(float)"; LB = "("; RB = ")"; } int FULLY_BRACKETED = !PARM_TIDY; if (FULLY_BRACKETED) { LB = "("; RB = ")"; } char *lcast = cast; if (opsym == ']') { lcast = "(unsigned int)"; // right shift (>>) must be unsigned in imp! (It is usually signed in C with ints) dump_code("(int)("); /*TO DO - can't assume int. could be long long int. etc.*/ } // *TO DO*: does "(unsigned int) fred >> signedvalue" return an unsigned result in C or a signed one? If the former, we *should* // cast and bracket the whole expression to guarantee safe evaluation, but in practice we don't need to unless the right shift // operand was 0 which is the only case where the result might be negative. (or the right shift value was less than zero, which // I doubt is even valid in Imp never mind C). Hmmm. Maybe I should just bracket and cast all shifts regardless. // Also some validity/range checking could be added here too, such as overflow of addition, etc etc. // NOTE: gcc is a bit of a pain and frequently suggests adding unnecessary brackets around the operands of "<<", ">>", and "&". // I will probably add those here in --tidy mode just to shut gcc up :-( if ((IS_BINOP(param1) && c_binprio[opsym] < c_binprio[USERFIELD(param1, 0)]) || FULLY_BRACKETED) dump_code("(%s%s%N%s)", lcast, LB, param1, RB); else dump_code("%s%s%N%s", lcast, LB, param1, RB); dump_code(" %s ", operator[opsym]); if ((IS_BINOP(param2) && c_binprio[opsym] < c_binprio[USERFIELD(param2, 0)]) || FULLY_BRACKETED) dump_code("(%s%s%N%s)", cast, LB, param2, RB); else dump_code("%s%s%N%s", cast, LB, param2, RB); if (opsym == ']') { dump_code(")"); } } } break; case AST_PASS_PARAMETER: { // TO DO same as assign/assval etc!!!!!!!!!!!!!!!!!!!! ASTIDX paramop, actop, actualparam, source, formalparam, tagop, formalparamtag; detuple(tuple, ¶mop, &actualparam, &formalparam); // for now, duplicating some of the code from AST_ASSIGN below, but // once I have it working, the common code needs to be refactored. // perhaps by having the code below test opsym detuple(actualparam, &actop, &source); //debug_types(actualparam); detuple(formalparam, &tagop, &formalparamtag); //debug_types(formalparam); /* // 5 // 6 %integername pointer int *POINTER; // 7 %integer i int I; // 8 // 9 do(3, i) DO(3, I); // 10 do(3, pointer) DO(3, *POINTER); */ if (IS_ARRAY_NAME(formalparam)) { // This is only going to work for 1D arrays with fixed bounds. 2-D arrays and auto arrays need work. // Even with that, still need to handle actual arrays vs arraynames, either as variables or as arrays // already passed to an enclosing procedure so their bounds were lost. (REQUIRES_AUTO_DEREF(source)) *TO DO* ASTIDX boundspair = BOUNDS1D(source); ASTIDX dopevector = DOPEVECTOR(source); ASTIDX LB, UB; int /*check_dv_op,*/ check_bounds_op; if (boundspair != 0) { // pass 1-D array with static bounds as a parameter detuple(boundspair, &check_bounds_op, &LB, &UB); // TO DO! Add something like this when passing an arrayname: if (REQUIRES_AUTO_DEREF(source)) source = mktuple(AST_INDIRECT_THROUGH, source); if (IS_ZERO(LB)) { dump_code("&%N[0]", source); } else if (IS_ICONST(LB)) { if (USERFIELD(LB, 0) < 0) { dump_code("/*is_array_name4*/ &((%N+%d)[0])", source, -USERFIELD(LB, 0)); } else { dump_code("/*is_array_name3*/ &((%N-%d)[0])", source, USERFIELD(LB, 0)); } } else { // shouldn't happen with 1D arrays and constant bounds dump_code("/*is_array_name2 BUG UNHANDLED EDGE CASE? */ &(%N[0])", mktuple(AST_BINOP, '-', source, LB)); } } else if (dopevector != 0) { // NEW CODE UNDER TEST TO PASS DYNAMIC ARRAYS AS A PARAMETER: debug_types(source); int dims = USERFIELD(dopevector, 0); if (dims != 1) { fprintf(stderr, "* IMPLEMENTATION RESTRICTION: cannot pass arrays of %d dimensions as a parameter.\n", dims); } if (IS_ARRAY_NAME(source)) { dump_code("%s", pooltostr(C_NAME_IDX(source))); } else { dump_code("&%s", pooltostr(C_NAME_IDX(source))); } for (int dim = 1; dim <= dims; dim++) { ASTIDX boundspair = EXTRAFIELD(dopevector, dim-1); // '-1' to be tidied up ASTIDX LB, UB; int check_op; detuple(boundspair, &check_op, &LB, &UB); if (IS_ATOMIC(LB)) { dump_code("[-%N]", LB); } else { dump_code("[-(%N)]", LB); } } } else { // Might be an arrayname parameter so based at 0 but still requires proper checking if (REQUIRES_AUTO_DEREF(source)) { dump_code("/*is_array_name_param2 BUG? */ &%N[0]", source); } else { dump_code("/*is_array_name_param1 BUG? */ &%N[0]", source); } } } else if (IS_NAME(formalparam) /*FP is a %name*/) { // changed from IS_A_POINTER //dump_code("/*fp:%%name*/"); if (IS_NAME(source) /*source is a %name*/) { // name dump_code(/*is_name1*/ "%N", source); } else if (FORM(source) == F_MAP) { // map dump_code(/*map*/ "%N", source); } else { // scalar dump_code(/*is_name2*/ "%N", mktuple(AST_ADDRESS_OF, source)); } } else { /*FP is scalar*/ if (REQUIRES_AUTO_DEREF(source)) source = mktuple(AST_INDIRECT_THROUGH, source); dump_code(/*scalar value*/"%N", source); } } break; case AST_ASSIGN: // TO DO: strings, records, type conversions int to real, etc { // rather than have separate AST types for ASSREF/JAM/ASSVAL, all assignments // come through AST_ASSIGN, and the special cases are handled by looking at the // 'opsym' field which is the original ICODE operation symbol: ASSVAL='S', // ASSREF='Z', JAM='j'. ASTIDX assop; int opsym; ASTIDX dest, source; detuple(tuple, &assop, &opsym, &dest, &source); if ((opsym == 'S') || (opsym == 'j')) { /* ASSVAL, JAM: DEST is mapcall, SOURCE is %name: *dest() = *source DEST is mapcall, SOURCE is scalar: *dest = source DEST is %name, SOURCE is %name: *dest = *source DEST is %name, SOURCE is scalar: *dest = source DEST is scalar, SOURCE is %name: dest = *source DEST is scalar, SOURCE is scalar: dest = source */ //if (IS_NAME(source)) { // fixed: was IS_A_POINTER. Should this just apply to F_NAME not F_ARRAYNAME which might need to be handled elsewhere as in (*NAME)[INDEX] ? if (REQUIRES_AUTO_DEREF(source)) { // fixed: was IS_A_POINTER. Should this just apply to F_NAME not F_ARRAYNAME which might need to be handled elsewhere as in (*NAME)[INDEX] ? source = mktuple(AST_INDIRECT_THROUGH, source); // TO DO: check that a %map is handled correctly. } //dump_code("/*CHECKING LHS (%s) IS %%name or %%map?", astname[OP(dest)]); //if (IS_NAME(dest)) { // TO DO: check that a %map is handled correctly. I suspect it is *NOT* ... so, changed... if (REQUIRES_AUTO_DEREF(dest)) { // TO DO: check that a %map is handled correctly. I suspect it is *NOT* ... so, changed... //dump_code(" - yes*/"); dest = mktuple(AST_INDIRECT_THROUGH, dest); // TO DO: check that a %map is handled correctly. } else { //dump_code(" - no*/"); } // It appears not to be for a %staring(255)%name S; S = S . '?' - the LHS is not indirected. Don't yet know why. dump_code("%N = ", dest); // currently an implementation bug: code to handle %N is not reentrant so cannot have two of them in the same call :-( ***TO DO*** ***FIX*** ***URGENT*** (might be fixed now but still needs confirmation/testing) if (BASE_TYPE(dest) == T_RECORD && OP(source) == AST_ICONST) { char *dest_struct_name; ASTIDX recfm = RECORD_FORMAT(dest); StrpoolIDX formatstr = C_NAME_IDX(recfm); dest_struct_name = pooltostr(formatstr); dump_code("(%s){ %N } /* Assign 0's to all fields of record */;\n", dest_struct_name, source); } else { dump_code("%N;\n", source); } } else if (opsym == 'Z') { /* ASSREF: DEST is mapcall, SOURCE is %name: ILLEGAL COMBINATION DEST is mapcall, SOURCE is scalar: ILLEGAL COMBINATION DEST is %name, SOURCE is %name: dest = source DEST is %name, SOURCE is scalar: dest = &source DEST is scalar, SOURCE is %name: ILLEGAL COMBINATION DEST is scalar, SOURCE is scalar: ILLEGAL COMBINATION */ // Don't automatically deference LHS of == address assignment. dump_code("%N = ", dest); /* TO DO: Assigning an array to an arrayname *should* (but currently doesn't) adjust the base so that the address of element 0 is assigned. There are several places now where the offset into an array is calculated, they really need to be made into common code. As well as accessing array elements, we need to handle passing arrays and array names as parameters (this AST_ASSIGN, and also AST_ACCESS, AST_INDEX, and AST_PASS_PARAMETER) // 30 %ownintegerarrayname pointer static int / *arrayname* / *POINTER; // 31 // 32 pointer == bert POINTER = BERT; */ if ((LINKAGE(source) == X_PERM || LINKAGE(source) == X_PRIM) && (strcmp(pooltostr(C_NAME_IDX(source)), "RECORD")==0)) { // How do we handle %record (recfm) %name rp == RECORD(address)? Can RECORD() ever be used in any other context than in a '==' assignment? // (or as a parameter to a procedure, which is amost the same thing) // In an assignment to a record pointer: // R==RECORD(ADDR(A(0))) // When used as NIL (NULL) by giving a 0 parameter: // fredp == RECORD(0) // Note that when used in an assignment, the location it is being assigned to can be complex: // A(x'ff')_LINK==RECORD(0) // In an "==" (or "\==") comparison: // %WHILE RN_LINK\==RECORD(0) %CYCLE // As a parameter: // WRITE DA (PAGING FILE,J,RECORD(BUFFER)) // My suspicion is that it cannot be used arbitrarily in expressions, so catching uses of RECORD() // at the top level of AST_ASSIGN or AST_CALL where the type of the target is known will get us // through all cases that will come up in practice. char *dest_struct_name; ASTIDX recfm = RECORD_FORMAT(dest); StrpoolIDX formatstr = C_NAME_IDX(recfm); dest_struct_name = pooltostr(formatstr); //dump_code(" /*(recfm=%s) See %s:%d */ ", dest_struct_name, __FILE__, __LINE__); dump_code(" (%s *) &", dest_struct_name); } // This is basically the opposite of REQUIRES_AUTO_DEREF... switch (FORM(source)) { case F_VOID: dump_code("/*F_VOID*/%N;\n", source); break; case F_SIMPLE: dump_code(/*F_SIMPLE*/"%N;\n", mktuple(AST_ADDRESS_OF, source)); break; case F_NAME: dump_code(/*F_NAME*/"%N;\n", source); break; case F_MAP: dump_code(/*F_MAP*/"%N;\n", source); break; case F_ARRAY: { // This is effectively the same code as passing an array as a parameter to a procedure. (some code-sharing required) //dump_code("/*F_ARRAY*/ &%N[0/*ADJUST BASE*/];\n", source); ASTIDX boundspair = BOUNDS1D(source); ASTIDX dopevector = DOPEVECTOR(source); ASTIDX LB, UB; int /*check_dv_op,*/ check_bounds_op; if (boundspair != 0) { // pass 1-D array with static bounds as a parameter detuple(boundspair, &check_bounds_op, &LB, &UB); // TO DO! Add something like this when passing an arrayname: if (REQUIRES_AUTO_DEREF(source)) source = mktuple(AST_INDIRECT_THROUGH, source); if (IS_ZERO(LB)) { dump_code("&%N[0]", source); } else if (IS_ICONST(LB)) { if (USERFIELD(LB, 0) < 0) { dump_code("/*is_array_name6*/ &((%N+%d)[0])", source, -USERFIELD(LB, 0)); } else { dump_code("/*is_array_name5*/ &((%N-%d)[0])", source, USERFIELD(LB, 0)); } } else { // shouldn't happen with 1D arrays and constant bounds dump_code("/*is_array_name3 BUG UNHANDLED EDGE CASE? */ &(%N[0])", mktuple(AST_BINOP, '-', source, LB)); } } else if (dopevector != 0) { // NEW CODE UNDER TEST TO PASS DYNAMIC ARRAYS AS A PARAMETER: debug_types(source); int dims = USERFIELD(dopevector, 0); if (dims != 1) { fprintf(stderr, "* IMPLEMENTATION RESTRICTION: cannot assign arrays of %d dimensions to an arrayname variable.\n", dims); } if (IS_ARRAY_NAME(source)) { dump_code("%s", pooltostr(C_NAME_IDX(source))); } else { dump_code("&%s", pooltostr(C_NAME_IDX(source))); } for (int dim = 1; dim <= dims; dim++) { ASTIDX boundspair = EXTRAFIELD(dopevector, dim-1); // '-1' to be tidied up ASTIDX LB, UB; int check_op; detuple(boundspair, &check_op, &LB, &UB); if (IS_ATOMIC(LB)) { dump_code("[-%N]", LB); } else { dump_code("[-(%N)]", LB); } } } else { // Might be an arrayname parameter so based at 0 but still requires proper checking if (REQUIRES_AUTO_DEREF(source)) { dump_code("/*is_array_name_param4 BUG? */ &%N[0]", source); } else { dump_code("/*is_array_name_param3 BUG? */ &%N[0]", source); } } dump_code(";"); } break; case F_ARRAY_NAME: dump_code("/*F_ARRAY_NAME*/%N;\n", source); break; case F_NAME_ARRAY: dump_code(/*F_NAME_ARRAY*/"%N;\n", source); break; case F_NAME_ARRAY_NAME: dump_code("/*F_NAME_ARRAY_NAME*/%N;\n", source); break; default: break; } } } break; case AST_LABEL: { int labtag; int imp_labno, labtype; detuple(tuple, &AST_check_op, &imp_labno, &labtype, &labtag); dump_code("%c_%04x", labtype, imp_labno); } break; case AST_GOTO: { int lab; detuple(tuple, &AST_check_op, &lab); dump_code("goto %N;\n", lab); accessible = FALSE; } break; case AST_DEFLAB: { int lab; detuple(tuple, &AST_check_op, &lab); dump_code("%N:\n", lab); accessible = TRUE; } break; case AST_DEF_DEFAULTSWLAB: { // new icode added by GT ASTIDX sw; detuple(tuple, &AST_check_op, &sw); int tag = USERFIELD(sw, 0); STRING_CAPACITY(Descriptor[tag]) = 1; // Make a note that this switch // has had it's default set. dump_code("%N_default:\n", sw); accessible = TRUE; } break; case AST_DEF_SWLAB: { ASTIDX tag, const_switch_index_ast; detuple(tuple, &AST_check_op, &tag, &const_switch_index_ast); // Note: no special handling needed at this level for SW(*): - handled in i2c.c (eventually) if (OP(const_switch_index_ast) == AST_ICONST) { ASTIDX checkop; int iconst; detuple(const_switch_index_ast, &checkop, &iconst); if (iconst < 0) { dump_code("%N_M_%d:\n", tag, -iconst); } else { dump_code("%N_%d:\n", tag, iconst); } } else { dump_code("%N_%N: /*SHOULD NOT HAPPEN*/\n", tag, const_switch_index_ast); } accessible = TRUE; } break; case AST_GOTO_SWLAB: { ASTIDX tag_check_op; ASTIDX tag, switch_index_ast, bounds; ASTIDX Lower, Upper; detuple(tuple, &AST_check_op, &tag, &switch_index_ast); if (REQUIRES_AUTO_DEREF(switch_index_ast)) switch_index_ast = mktuple(AST_INDIRECT_THROUGH, switch_index_ast); bounds = BOUNDS1D(tag); detuple(bounds, &tag_check_op, &Lower, &Upper); int LB, UB; LB = USERFIELD(Lower, 0); UB = USERFIELD(Upper, 0); char *swname = pooltostr(C_NAME_IDX(tag)); dump_code("%s_idx = %N; if ((%d <= %s_idx) && (%s_idx <= %d)) ", swname, switch_index_ast, LB, swname, swname, UB); if (LB == 0) { dump_code("goto *%s[%s_idx];", swname, swname); } else if (LB > 0) { dump_code("goto *(%s-%d)[%s_idx]; /* Bounds=%d:%d */\n", swname, LB, swname, LB, UB); } else { dump_code("goto *(%s+%d)[%s_idx]; /* Bounds=%d:%d */\n", swname, -LB, swname, LB, UB); } dump_code(" else {\n" " /*_imp_signal(6, %s_idx, _imp_current_line);*/\n" /* 6 -> RANGE ERROR */ " fprintf(stderr, \"%%%%SWITCH index %s(%%d) " "not in range %d:%d " "at %%s:%%d\\n\",\n %s_idx, " "(_imp_current_file != 0 ? _imp_current_file : __FILE__),\n " "(_imp_current_line != 0 ? _imp_current_line : __LINE__));\n " "exit(1);\n" "}\n", swname, swname, LB, UB, swname); accessible = FALSE; } break; case AST_SEQ: { // Execute two statements sequentially. ASTIDX stmnt1, stmnt2; detuple(tuple, &AST_check_op, &stmnt1, &stmnt2); dump_code("%N%N", stmnt1, stmnt2); } break; case AST_COMMENT: { StrpoolIDX comment; detuple(tuple, &AST_check_op, &comment); dump_code("%s%s", comment_indent, pooltostr(comment)); } break; case AST_STOP: { dump_code("exit(0);\n"); // or _exit(0) or _imp_signal(0,0,0,"%stop")? accessible = FALSE; } break; case AST_ADDRESS_OF: { //int tag_op; ASTIDX var; //, tag; detuple(tuple, &AST_check_op, &var); //detuple(var, &tag_op, &tag); // X is the raw tag. if (IS_A_POINTER(var)) { // TO DO: check that a %map is handled correctly. Oops. Had "!IS_A_POINTER" //dump_code(/*address_of*/ "(&(%N))", var); // test: adding full parenthesis to avoid ambiguity. Check that stuff still compilers after this... dump_code(/*address_of*/ "%N", var); // test: adding full parenthesis to avoid ambiguity. Check that stuff still compilers after this... } else { /*why no '&'in address_of? - let's just add one and see what happens... */ dump_code("&%N", var); } } break; case AST_INDIRECT_THROUGH: { int tag_op; ASTIDX var, tag; detuple(tuple, &AST_check_op, &var); detuple(var, &tag_op, &tag); // X is the raw tag. if (IS_A_POINTER(var) && FORM(var) != F_ARRAY_NAME) { // TO DO: arraynames got an extra indirection here. Maybe namearrayname is bad too. debug_types(var); dump_code(/*indirect_through=Y*/ "*%N", var); // Do *not* pass the buck to mktuple(AST_INDIRECT_THROUGH)! :-) } else { dump_code("/*indirect_through=N*/ %N", var); } } break; case AST_DYNAMICARRAYACCESS: { ASTIDX array, index_list; detuple(tuple, &AST_check_op, &array); ASTIDX dopevector = DOPEVECTOR(array); //int tag = USERFIELD(array, 0); index_list = INDEX_LIST(array); debug_types(index_list); int dims = USERFIELD(index_list, 0); if (IS_ARRAY_NAME(array)) { dump_code("(*N)", array); } else { dump_code("%N", array); } for (int dim = 1; dim <= dims; dim++) { ASTIDX boundspair = EXTRAFIELD(dopevector, dim-1); /* '-1' to be tidied up */ ASTIDX index = USERFIELD(index_list, dim); if (REQUIRES_AUTO_DEREF(index)) { index=mktuple(AST_INDIRECT_THROUGH, index); // I should not have to keep handling these all over the place. There should be a 'get_value(idx)' call that can be used everywhere... } ASTIDX LB, UB; int check_op; detuple(boundspair, &check_op, &LB, &UB); if (IS_ICONST(LB) && IS_ZERO(LB)) { dump_code("[%N]", index); } else { //dump_code("[(%N)-(%N)]", index, LB); dump_code("[%N]", mktuple(AST_BINOP, '-', index, LB)); } } } break; case AST_ARRAYACCESS: { // I think that now I've got AST_DYNAMICARRAYACCESS working, the 'dims' and dopevector code below will never be called and can now be removed. int dims=0; ASTIDX array, arrayindex; detuple(tuple, &AST_check_op, &array, &arrayindex); // unpack the AST_ARRAYACCESS tuple. if (REQUIRES_AUTO_DEREF(arrayindex)) { arrayindex=mktuple(AST_INDIRECT_THROUGH, arrayindex); // Should now remove the indirection in the type info that has been percolated up to the updated arrayinfo. // Also, TO DO, anywhere else that outputs [%N] ... // Note: The fact that the translator is more or less working at this point means that I am probably // handling the indirections already in other parts of the code and that this fix for a few holdouts // is going to make those other places break. So now that I understand how things should be done a // little better I probably need to go through the entire code generator and use REQUIRES_AUTO_DEREF() // everywhere more consistently. } //if (IS_A_POINTER()) dump_code("*"); // <--------------------------------------------------------------------------------------------- if (OP(array) != AST_VAR && OP(array) != AST_FIELDSELECT) { // TO DO: trying to fix array accesses by a record field... dump_code("/*ast.c:%d why isn't OP(array) an AST_VAR?*/", __LINE__); // *** TO DO *** // The indexed object doesn't have to be a bottom-level VAR describing an array variable, // it could equally be an array object that was constructed in some other way, such as // a record field that is an array or an array name... (eg AST_FIELDSELECT) // // So we need to be smarter about locating the dopevector or array bounds from that object! // The correct mechanism to use is that the tuple should have its DOPEECTOR() or BOUNDS1D() // field set up by now to supply the appropriate bounds information of the object. // // (bearing in mind the complexity of multi-dimensional arrays and accessing the correct // index for the given AST_ARRAYACCESS call which has still to be dealt with...) // (and I'm wondering whether it might be a good trick to copy the current DIM bounds // to the BOUNDSPAIR location so that we only ever need to look at the latter and that // the latter will be updated with the next DIM pair whenever an ARRAYACCESS is done!) if (BOUNDS1D(array) == 0 && DOPEVECTOR(array) == 0) { dump_code("/* This array object (%d) has not had bounds information attached. */\n", array); dump_code("/* Object was created at line %d */\n", SOURCE_LINE(array)); } } ASTIDX dopevector = DOPEVECTOR(array); ASTIDX boundspair = BOUNDS1D(array); ASTIDX LB, UB; int check_dv_op, check_bounds_op; if (dopevector != 0) { // ARRAYACCESS should only apply to 1-D non-auto arrays with static bounds. // - anything else goes through AST_DYNAMICARRAYACCESS ... so this section *ought* // to be completely removable. I'll flag any access to it and revisit after a few // more days... fprintf(stderr, "\n\n\n***************** THIS SECTION APPARENTLY CANNOT BE REMOVED AFTER ALL!!! ******************\n\n\n"); dump_code("/* BUG! I thought this section in %s:%d was not being executed. I was wrong. */ ??? ", __FILE__, __LINE__); detuple(dopevector, &check_dv_op, &dims); boundspair = EXTRAFIELD(dopevector, 0); detuple(boundspair, &check_bounds_op, &LB, &UB); //debug_types(boundspair); // for now just look at first dimension (others TO DO!!!) if (dims != 1) { dump_code("/* *** %d-D arrays not yet handled! *** */", dims); } if (OP(LB) == AST_ICONST && USERFIELD(LB, 0) == 0) { dump_code("%N[%N]", array, arrayindex); } else { if (USERFIELD(LB, 0) < 0) { dump_code("(%N+%d)[%N]", array, -USERFIELD(LB, 0), arrayindex); } else { dump_code("(%N-%d)[%N]", array, USERFIELD(LB, 0), arrayindex); } } } else if (boundspair != 0) { detuple(boundspair, &check_bounds_op, &LB, &UB); if (IS_ZERO(LB)) { dump_code("%N[%N]", array, arrayindex); } else if (IS_ICONST(LB)) { if (USERFIELD(LB, 0) < 0) { dump_code("(%N+%d)[%N]", array, -USERFIELD(LB, 0), arrayindex); } else { dump_code("(%N-%d)[%N]", array, USERFIELD(LB, 0), arrayindex); } } else { dump_code("(%N)[%N]", mktuple(AST_BINOP, '-', array, LB), arrayindex); } } else if (IS_ARRAY_NAME(array)) { // So lower bound is implicitly 0 dump_code("%N[%N]", array, arrayindex); } else { // *TO DO* these are probably arrays that have been passed as a parameter // to a procedure, and I have not yet constructed a dopevector or boundspair // to accompany them. For now at a miminum I need to ensure that it is the // address of the zeroth element that is passed, not the address of the // lowest indexed element in the original declaration, which is what the // code is likely to try to pass by default. // Question: is it better to wrap objects in a struct or to pass extra // parameters explicitly? If the latter should I use the '$' extension // in GCC, eg handle_array(fred, fred$LB, fred$UB); // ***TO DO*** Look for "D: BUG" in test2/skimp?s.{c,imp} for an outstanding bug. Not clear // to me at this point why only 'link' is affected and not other similar arrays. dump_code("/* D: BUG. BOUNDS INFO MISSING boundspair=%d dopevector=%d */", boundspair, dopevector); dump_code("%N[%N]", array, arrayindex); debug_types(array); } } break; case AST_FIELDSELECT: { // how can this not be called yet the field is output???? ASTIDX record, field; // record is a VAR and that VAR contains the AST_DECLARE as a field detuple(tuple, &AST_check_op, &record, &field); //ASTIDX parent = USERFIELD(record, 0); // raw tag number //debug_types(Descriptor[parent]); if (IS_A_POINTER(record)) { // TO DO: check that a %map is handled correctly. (I think it is...) dump_code("%N->%N", record, field); } else { dump_code("%N.%N", record, field); } } break; case AST_FORMAL_PARAMETER_LIST: { int count; detuple(tuple, &AST_check_op, &count); if (count == 0) { dump_code("void"); } else { for (int i = 0; i < count; i++) { ASTIDX param = EXTRAFIELD(tuple, i); dump_code("%N", param); if (i < count - 1) dump_code(", "); } } } break; case AST_ACTUAL_PARAMETER: { // These are a temporary item that is pushed on the compiler stack every time // 'p' (ASSPAR) is passed. By the time we get to CALL we are instead looking // at an AST_ACTUAL_PARAMETER_LIST containing an array of these. ASTIDX param; detuple(tuple, &AST_check_op, ¶m); dump_code("%N", param); } break; case AST_IMP_LINE: { int line; StrpoolIDX file; detuple(tuple, &AST_check_op, &line, &file); show_source_code(line, pooltostr(file)); if (PARM_IMP_SOURCE_LINENOS) { sprintf(hashline, "#line %d \"%s\"\n", line, pooltostr(file)); if (blocklevel > 0) { // (can't output imperative statements at the external level) // this could be made optional but the runtime overhead isn't particularly // high, and it's useful for minimal imp-style runtime diagnostics when // not running under valgrind or gdb: dump_code("_imp_current_line = %d; ", line); // just 2 loads & stores. No string copying happening. So verbose but relatively efficient. dump_code("_imp_current_file = \"%s\";\n", pooltostr(file)); } } } break; case AST_BOUNDSPAIR: { ASTIDX low, high; detuple(tuple, &AST_check_op, &low, &high); ASTIDX left = mktuple(AST_BINOP, '-', high, low); ASTIDX index = mktuple(AST_BINOP, '+', left, mktuple(AST_ICONST, 1)); dump_code("[%N]", index); } break; case AST_DOPEVECTOR: { int dims; detuple(tuple, &AST_check_op, &dims); //dump_code("/*DV:%d*/", dims); //for (int dim = 0; dim < dims; dim++) { // right to left order -- see comments at AST_DYNAMICARRAY: for (int dim = dims-1; dim >= 0; dim--) { // left to right order dump_code("%N", EXTRAFIELD(tuple, dim)); } } break; case AST_CONTROL: { int ctrl; /* %CONTROL: Bit significance of the fields in the %control word are given below. Bit set turns checking on. Bit clear disables the check. (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') */ detuple(tuple, &AST_check_op, &ctrl); dump_code("#ifdef _IMP_CONTROL\n"); dump_code("#undef _IMP_CONTROL\n"); dump_code("#endif // _IMP_CONTROL\n"); dump_code("#define _IMP_CONTROL %d\n", ctrl); _imp_control = ctrl; } break; case AST_DIAGNOSE: { int diag; detuple(tuple, &AST_check_op, &diag); dump_code("#ifdef _IMP_DIAGNOSE\n"); dump_code("#undef _IMP_DIAGNOSE %d\n", diag); dump_code("#endif // _IMP_DIAGNOSE\n"); dump_code("#define _IMP_DIAGNOSE %d\n", diag); _imp_diagnose = diag; } break; case AST_MONITOR: { int mon = 0; // NOTE: imp77 does not support "%monitor n" or "%monitorstop". // It just accepts "%monitor" or "%monitor %and %stop"... // (or %and %monitor) detuple(tuple, &AST_check_op, &mon); dump_code("_imp_monitor(%d, (_imp_current_line != 0 ? _imp_current_line : __LINE__), (_imp_current_file != 0 ? _imp_current_file : __FILE__), __PRETTY_FUNCTION__);\n", mon); } break; case AST_SIGNAL: { ASTIDX event, subevent, extra; detuple(tuple, &AST_check_op, &event, &subevent, &extra); // subevent and extra may be expressions, event must be a literal. dump_code("_imp_signal(%N, %N, %N, \"\");\n", event, subevent, extra); } break; default: fprintf(stderr, "\n// UNIMPLEMENTED codegen(%s) at \"%s\", Line %d\n", safe_astname(AST_op), file, line); dump_comment("\n// UNIMPLEMENTED codegen(%s) at \"%s\", Line %d\n", safe_astname(AST_op), file, line); int i = 0; i = 0/i; // throw us in to the debugger } // end of switch }