#ifndef __STACK_C__ #define __STACK_C__ 1 // IN PROGRESS: Propogating types in ACCESS, SELECT etc and // all mon/binops. // and probably should do something with DEFTAG 0x0000 when record // fields are declared. #include #include "stack.h" #include "showicode.h" #include "icode2ast_data.h" #include "stack.h" #include "errorf.h" #include "filter.h" // (reverse_index_order should always be 0 for genimp.c) // See comments in genc.c re the need to reverse array index order to // make the C translation map tp traditional Imp's COLUMN-MAJOR format. extern int reverse_index_order; int stackdebug = 0; #define MAX_STACK 0x10000 static int next_free_stack_index = 0; #define stackbottom 0 // (allowing for possibility of adding false bottom later.) static IMPAST *stack[MAX_STACK]; #define SMALL_STACK 1024 static int next_free_paramstack_index = 0; static IMPAST *paramstack[SMALL_STACK]; // Mark an ICode in Proglist for removal. Note that this just removes it from the chain // that is passed to remove_used_codes() - it doesn't actually delete the node, so it can // still be used elsewhere. It just won't be handled should that particular linked list // be traversed linearly. #define CHERISH(icode) CHERISH_inner(icode, __LINE__) void CHERISH_inner(IMPAST *icode, int line) { if (icode == NULL) { warnf("CHERISH(NULL) at stack.c:%d\n", line); } used[NOTNULL(icode)->generic.seqno] = 0; } void DISCARD(IMPAST *icode) { used[NOTNULL(icode)->generic.seqno] = 1; } // --------------------------------------------------------------------------------- static void Push(IMPAST *data) { stack[next_free_stack_index] = NOTNULL(data); CHERISH(stack[next_free_stack_index]); next_free_stack_index += 1; } static void PushParam(IMPAST *data) { if (OP(NOTNULL(data)) != OP_ASSPAR) { warnf("In the new scheme, the pushed params should all be wrapped in ASSPARs! This one was a %s\n", icode_name[OP(data)]); } paramstack[next_free_paramstack_index++] = data; } #define Pop() Pop_inner(__FILE__, __LINE__) static IMPAST *Pop_inner(char *file, int line) { if (next_free_stack_index == stackbottom) { fprintf(stderr, "\"%s\", %d: * FATAL ERROR: Attempt to pop from an empty stack", file, line); if (stackbottom != 0) fprintf(stderr, " (or more accurately, hitting a false bottom at stack[%d])", stackbottom); fprintf(stderr, "\n"); fprintf(stdout, "* FATAL ERROR: Attempt to pop from an empty stack"); if (stackbottom != 0) fprintf(stdout, " (or more accurately, hitting a false bottom at stack[%d])", stackbottom); fprintf(stdout, "\n"); exit(EXIT_FAILURE); } next_free_stack_index -= 1; DISCARD(stack[next_free_stack_index]); return stack[next_free_stack_index]; } static IMPAST *NullPop(void) { if (next_free_stack_index == stackbottom) { return NULL; } next_free_stack_index -= 1; DISCARD(stack[next_free_stack_index]); return NOTNULL(stack[next_free_stack_index]); } #define PopParam() PopParam_inner(__FILE__, __LINE__) static IMPAST *PopParam_inner(char *file, int line) { if (next_free_paramstack_index == 0) return NULL; // a procedure with no params if (next_free_paramstack_index <= 0) { fatalf("\"%s\", %d: Attempt to pop from an empty paramstack\n", file, line); } return NOTNULL(paramstack[--next_free_paramstack_index]); } //--------------------------------------------------------------------------------------- // Type propogation: void copy_type(IMPAST *dest, IMPAST *source) { // general-purpose type propogation routine that will handle most cases. // Some cases might need extra handling at the point of call, for example, // an integer '/' integer becomes a real. // OP_DEF has type, form, linkage and special, which might have been better // fields to include in the FIXED_FIELDs, but since I didn't declare them as // global fields, I'll continue using tf, format and ostate for now. At least // until it becomes obvious that some choice I made was a mistake. if (source == NULL) { errorf("copy_type: NULL\n"); return; } // of the fixed fields, do NOT copy: opcode next_icode seqno line //IMPAST *line = NOTNULL(source)->generic.line; //int blocklevel = source->generic.blocklevel; int tf = source->generic.tf; int format = source->generic.format; int ostate = source->generic.ostate; int linkage = source->generic.linkage; int type = source->generic.type; int form = source->generic.form; int special = source->generic.special; int is_spec = source->generic.is_spec; int is_indirect = source->generic.is_indirect; int no_unass_check = source->generic.no_unass_check; // Having moved these two into FIXED_FIELDs I need to check carefully that this didn't break anything: IMPAST *recordformatdef = source->generic.recordformatdef; // OP_SELECT is handled separately... //IMPAST *recordformat_field_list = source->generic.recordformat_field_list; // OP_SELECT is handled separately... int maxstring = source->generic.maxstring; //debugf("copy_type: tf=0x%04x format=0x%04x ostate=0x%04x\n", tf, format, ostate); //NOTNULL(dest)->generic.line = line; //dest->generic.line = NULL; // unsetting line info of generated or shuffled icodes // helps keep source listing from getting too corrupted //dest->generic.blocklevel = blocklevel; dest->generic.tf = tf; dest->generic.format = format; dest->generic.ostate = ostate; dest->generic.linkage = linkage; dest->generic.type = type; dest->generic.form = form; dest->generic.special = special; dest->generic.is_spec = is_spec; dest->generic.is_indirect = is_indirect; dest->generic.no_unass_check = no_unass_check; dest->generic.recordformatdef = recordformatdef; //dest->generic.recordformat_field_list = recordformat_field_list; dest->generic.maxstring = maxstring; } void set_type(IMPAST *this, int T_type) { NOTNULL(this)->generic.tf = (this->generic.tf & ~0xF0) | ((T_type&0xF)<<4); this->generic.type = T_type; } void set_form(IMPAST *this, int F_form) { NOTNULL(this)->generic.tf = (this->generic.tf & ~0xF) | (F_form&0xF); this->generic.form = F_form; } void set_recordformattag(IMPAST *this, int recfmtag) { NOTNULL(this)->generic.format = recfmtag; } void set_linkage(IMPAST *this, int L_linkage) { NOTNULL(this)->generic.ostate = (this->generic.ostate & ~0x7) | L_linkage; this->generic.linkage = L_linkage; } void set_special(IMPAST *this, int S_special) { NOTNULL(this)->generic.special = S_special; } void inherit_array_element_info(IMPAST *this) { // Oh shit! I've been testing TYPE() not FORM() !!! /* TO DO!!! Fix as soon as I've finished the other thing I'm working on - don't want to change too many major things at once, even though this is clearly very wrong! */ // switch (TYPE(NOTNULL(this))) { switch (FORM(NOTNULL(this))) { case F_ARRAY: NOTNULL(this)->generic.form = F_SIMPLE; break; case F_NAME_ARRAY: NOTNULL(this)->generic.form = F_NAME; break; default: // add debugf? break; } } void inherit_pointed_to_info(IMPAST *this) { // NOT YET USED BUT NEEDS TO BE ON POINTER DEREFENCING // Oh shit! I've been testing TYPE() not FORM() !!! /* TO DO!!! Fix as soon as I've finished the other thing I'm working on - don't want to change too many major things at once, even though this is clearly very wrong! */ //switch (TYPE(NOTNULL(this))) { switch (FORM(NOTNULL(this))) { case F_NAME: NOTNULL(this)->generic.form = F_SIMPLE; break; case F_ARRAY_NAME: NOTNULL(this)->generic.form = F_ARRAY; break; case F_NAME_ARRAY_NAME: NOTNULL(this)->generic.form = F_NAME_ARRAY; break; case F_MAP: NOTNULL(this)->generic.form = F_SIMPLE; break; default: // add debugf? break; } } void make_into_pointer(IMPAST *this) { // Oh shit! I've been testing TYPE() not FORM() !!! /* TO DO!!! Fix as soon as I've finished the other thing I'm working on - don't want to change too many major things at once, even though this is clearly very wrong! */ // switch (TYPE(NOTNULL(this))) { switch (FORM(NOTNULL(this))) { case F_SIMPLE: NOTNULL(this)->generic.form = F_NAME; break; case F_ARRAY: NOTNULL(this)->generic.form = F_ARRAY_NAME; break; case F_NAME_ARRAY: NOTNULL(this)->generic.form = F_NAME_ARRAY_NAME; break; default: // add debugf? break; } } //--------------------------------------------------------------------------------------- // Remove all marked ICodes. Be sure to link from parent to next non-removed icode. static IMPAST *remove_used_codes(IMPAST *Program) { // Like 'run_stack', we assume that the entire program is linear at this point. // At any rate, we'll only unlink elements that are on this chain, so if procedure // bodies have already been extracted from here and moved into a def->def.body // sublist, they won't be affected. IMPAST *this = NOTNULL(Program), *Parent = NULL; while (this != NULL) { if (used[NOTNULL(this)->generic.seqno] != 0) { // has it been marked for removal? //fprintf(stdout, "unmark: "); show_icode(this, stderr); fprintf(stderr, "\n"); if (Parent == NULL) { Program = this->generic.next_icode; //debugf("Unhooking %05d (%s) from Program. Next is %05d, Program is NULL again.\n", this->generic.seqno, icode_name[OP(this)], Program->generic.seqno); this->generic.next_icode = NULL; this = Program; Parent = NULL; } else { IMPAST *tmp = NOTNULL(this); //debugf("Unhooking %05d (%s) from Parent at %05d. Next is %05d.\n", this->generic.seqno, icode_name[OP(this)], Parent->generic.seqno, (this->generic.next_icode == NULL ? 0 : this->generic.next_icode->generic.seqno)); Parent->generic.next_icode = this->generic.next_icode; this = NOTNULL(this->generic.next_icode); tmp->generic.next_icode = NULL; } } else { Parent = this; this = this->generic.next_icode; } } return NOTNULL(Program); } void print_arrayindex_list(FILE *out, IMPAST *arrayindex) { while (arrayindex != NULL) { fprintf(out, "%05d ", arrayindex->array_index.seqno); arrayindex = arrayindex->array_index.next_index; } } IMPAST *reverse_arrayindex_list(FILE *out, IMPAST *list) { IMPAST *newlist = NULL; IMPAST *item = NULL; //fprintf(out, "Reversing array index list [ "); //print_arrayindex_list(out, list); while (list != NULL) { item = list; list = list->array_index.next_index; item->array_index.next_index = newlist; newlist = item; } //fprintf(out, "] to [ "); //print_arrayindex_list(out, newlist); //fprintf(out, "]\n"); return newlist; } IMPAST *run_stack(IMPAST *Program) { // This runs through all the compiler instructions and obeys the stacking information // which updates the other icodes. It marks used opcodes as it uses them, and the // short procedure above removes those opcodes on a pass through the entire program // once this procedure is done. Note that the entire program must be linear at this // point. (If it isn't, we would need to change both this code and 'remove_used_codes' // to match.) IMPAST *LASTDEF = NULL; // For INIT IMPAST *LASTBOUNDS = NULL; // For %switch sw1, sw2(0:1) declarations! if (Program == NULL) return Program; init_show_icode(); IMPAST *this = NOTNULL(Program); int opcode = OP(NOTNULL(this)); IMPAST *tos, *sos; // useful temporaries fflush(stdout); if (opcode < 0 || opcode > LAST_OP) { fatalf("Unhandled opcode in stack.c: %05d 0x%08x (Not in range, probably corruption)\n", opcode, opcode); } while (this != NULL) { IMPAST *debug_copy_of_this = NOTNULL(this); opcode = OP(this); //fprintf(stderr, "run stack: [%05d] %s\n", this->generic.seqno, icode_name[OP(this)]); switch (opcode) { // (In the code below 'break' exits the switch, not the loop...) case EOF: if (stackdebug) {show_icode(this, stderr); fprintf(stderr, "\n");} case 0: if (stackdebug) {show_icode(this, stderr); fprintf(stderr, "\n");} return remove_used_codes(Program); // Explicit stack operations: case OP_PUSHI: if (stackdebug) {show_icode(this, stderr); fprintf(stderr, "\n");} // integer constant Push(this); set_type(this, T_INTEGER); set_form(this, F_SIMPLE); this = NOTNULL(this->generic.next_icode); break; case OP_PUSHR: if (stackdebug) {show_icode(this, stderr); fprintf(stderr, "\n");} // real constant Push(this); set_type(this, T_REAL); set_form(this, F_SIMPLE); this = NOTNULL(this->generic.next_icode); break; case OP_PUSHS: if (stackdebug) {show_icode(this, stderr); fprintf(stderr, "\n");} // string constant Push(this); set_type(this, T_STRING); set_form(this, F_SIMPLE); this = NOTNULL(this->generic.next_icode); break; case OP_PUSH: if (stackdebug) {show_icode(this, stderr); fprintf(stderr, " (before)\n");} // tag Push(this); //copy_type(this, NOTNULL(DEFTAG[this->push.tag])); copy_type(this, NOTNULL(DEFUNIQUETAG[this->push.unique_tag])); if (stackdebug) {show_icode(this, stderr); fprintf(stderr, " (after)\n");} // tag this = NOTNULL(this->generic.next_icode); break; // Used by predicates: case OP_BF: if (stackdebug) {show_icode(this, stderr); fprintf(stderr, "\n");} tos = Pop(); this->bf.opd = NOTNULL(tos); this = NOTNULL(this->generic.next_icode); break; case OP_BT: if (stackdebug) {show_icode(this, stderr); fprintf(stderr, "\n");} tos = Pop(); this->bt.opd = NOTNULL(tos); this = NOTNULL(this->generic.next_icode); break; case OP_DEF: if (stackdebug) {show_icode(this, stderr); fprintf(stderr, "\n");} LASTDEF = this; // Pretty sure this is redundant (set in icode2ast.c) so commenting out: //DEFTAG[this->def.tag] = this; if (FORM(this) == F_SWITCH) { IMPAST *bounds = NullPop(); if (bounds == NULL) { bounds = NOTNULL(LASTBOUNDS); } else { if (OP(bounds) != OP_BOUNDSPAIR) fatalf("Internal error: Missing bounds for %%switch %s (not a boundspair)\n", this->def.c_id); LASTBOUNDS = bounds; } /* ARGH! %integerarray arr1, arr2(0:1) uses DIM after the declarations, not BOUNDS before it. %ownintegerarray arr(0:1) uses BOUNDS before, *but* %ownintegerarray arr1, arr2(0:1) is syntactically illegal, so %switch sw1, sw2(0:1) has no analogue in data declarations, and currently the BOUNDS on the stack is popped by the first sw1 so there are no bounds remaining for sw2 to pick up. It looks like a custom hack is going to be needed for multiple switch declarations in a single statement :-( Hence 'LASTBOUNDS' ... */ if (bounds->boundspair.next_bound != NULL) fatalf("Internal error: %%switch %s already has bounds.\n", this->def.c_id); this->def.bounds_list = bounds; // And the other thing we have to do is either abuse the INIT mechanism // or create an array of some sort to store the switch labels. Needs // some way of handling sw(*) versus missing labels if no sw(*)... So // I think the labels have to be IMPAST nodes rather than integers, so // we can distinguish between sw(0) and an uninitialised NULL entry. IMPAST **switcharray; int lb = NOTNULL(bounds->boundspair.lb)->pushi.value; int ub = NOTNULL(bounds->boundspair.ub)->pushi.value; switcharray = calloc(ub-lb+1, sizeof(IMPAST *)); // calloc initialises to 0 (NULL) this->def.switch_list = switcharray; this->def.lower_bound = lb; this->def.upper_bound = ub; } else if (FORM(this) == F_ARRAY || FORM(this) == F_NAME_ARRAY) { IMPAST *bounds = NullPop(); if (bounds == NULL) { // has to be a copy because bounds->boundspair.next_bound is updated if (LASTBOUNDS == NULL) { //warnf("LASTBOUNDS %s == NULL\n", this->def.c_id); } else { bounds = new_icode(BOUNDSPAIR); memmove(bounds, LASTBOUNDS, sizeof(ICODE_BOUNDSPAIR)); IMPAST *existingbounds = NOTNULL(this)->def.bounds_list; if (bounds->boundspair.next_bound != NULL) warnf("? Existing bounds causing a problem?\n"); bounds->boundspair.next_bound = existingbounds; this->def.bounds_list = bounds; } } else { //debugf("stack.c: DEF ARRAY or NAME_ARRAY: bounds were NOT NULL\n"); LASTBOUNDS = bounds; if (OP(bounds) != OP_BOUNDSPAIR) { fatalf("Array declaration %s but bounds were a %s\n", NOTNULL(this)->def.c_id, icode_name[OP(bounds)]); Push(bounds); } else { IMPAST *existingbounds = NOTNULL(this)->def.bounds_list; if (bounds->boundspair.next_bound != NULL) warnf("? Existing bounds causing a problem?\n"); bounds->boundspair.next_bound = existingbounds; this->def.bounds_list = bounds; } } this->def.dims += 1; } this = NOTNULL(this->generic.next_icode); break; case OP_INIT: if (stackdebug) {show_icode(this, stderr); fprintf(stderr, "\n");} { // stack.c removes INIT opcodes from the linear ProgList and attaches them to the DEF instead, so that the initialisation // is output when the DEF is handled. Opcode handling should never see an INIT code after this. //fprintf(stderr, "*** INIT\n"); IMPAST *data = NullPop(); if (data == NULL) { //fprintf(stderr, "? TODO: an init without data was an init to default for %%own I think.\n"); // and the def->def.init field should already be NULL //fprintf(stderr, "*** INIT with NULL data from compiler stack?\n"); this = NOTNULL(this->generic.next_icode); break; } // data should be a data type - a PUSH? or an expr. Another shared field 'is_data' might come in useful? (as long as it is properly initialised) this->init.data = data; DISCARD(data); // Matches NullPop() above. Take note of that, if removing DISCARDs //fprintf(stderr, "*** handling a scalar init in stack.c: [%05d].data = data = %s\n", this->init.seqno, icode_name[OP(data)]); if (LASTDEF != NULL) { // Should check type of LASTDEF IMPAST *init_list = LASTDEF->def.init; LASTDEF->def.init = this; this->init.next_init = init_list; //DISCARD(this); // one of the DISCARD calls without a matching Pop(). It's attached to the DEF above. //fprintf(stderr, "INIT: set [%05d] initial value to [%05d]\n", LASTDEF->generic.seqno, LASTDEF->def.init->generic.seqno); this = NOTNULL(this->generic.next_icode); } else { fatalf("No LASTDEF to attach INIT to!\n"); } } break; case OP_LOCATE: if (stackdebug) {show_icode(this, stderr); fprintf(stderr, "\n");} this = NOTNULL(this->generic.next_icode); break; case OP_REPEAT: if (stackdebug) {show_icode(this, stderr); fprintf(stderr, "\n");} /* Jump Backward(Tag); */ /* REPEAT label */ this = NOTNULL(this->generic.next_icode); break; case OP_JUMPIFA: if (stackdebug) {show_icode(this, stderr); fprintf(stderr, "\n");} tos = Pop(); sos = Pop(); this->jumpifa.opd1 = NOTNULL(sos); this->jumpifa.opd2 = NOTNULL(tos); this = NOTNULL(this->generic.next_icode); break; case OP_JUMPIFD: if (stackdebug) {show_icode(this, stderr); fprintf(stderr, "\n");} tos = Pop(); sos = Pop(); this->jumpifd.opd1 = NOTNULL(sos); this->jumpifd.opd2 = NOTNULL(tos); Push(tos); // (*One* of them is left on the stack. I hope I picked the right one!) this = NOTNULL(this->generic.next_icode); break; case OP_JUMPIF: if (stackdebug) {show_icode(this, stderr); fprintf(stderr, "\n");} tos = Pop(); sos = Pop(); this->jumpif.opd1 = NOTNULL(sos); this->jumpif.opd2 = NOTNULL(tos); this = NOTNULL(this->generic.next_icode); break; case OP_ASSPAR: if (stackdebug) {show_icode(this, stderr); fprintf(stderr, "\n");} // Unlike other icodes, we don't return ASSPAR as a tree node. Instead, we push // the parameter on a private parameter stack, then when the CALL instruction is // encountered, we transfer from that stack to its actual_params field. // I suppose I *could* attach the ASSPAR to the actual_param_list rather than // the param directly, though I don't see an advantage in doing so. I do see that // I added a "next_param" field to the ASSPAR struct so maybe that was my original // intention. What I'm currently doing is using the 'next_icode' field in the // parameter list objects, since they're no longer part of the main proglist. // I think I'll try changing they way I handle these and see if it fixes the // problems I've been having with truncated output at the point of a CALL. tos = NullPop(); // parameter on icode stack if (tos == NULL) { if (stackdebug) debugf("/* stack.c OP_ASSPAR TOS: stack was empty. (fatal but allowing recovery during development) */"); this = NOTNULL(this->generic.next_icode); break; } this->asspar.param = NOTNULL(tos); this->asspar.next_param = NULL; // ASSPARs will be linked when we pop them from the ParamStack (though I could do that now!?) to attach them to the CALL PushParam(this); DISCARD(this); // transfer to parameter stack // one of the DISCARD calls without a matching Pop() // The procedure to be called is below tos in sos... sos = NullPop(); if (sos == NULL) { if (stackdebug) debugf("/* stack.c OP_ASSPAR SOS: stack was empty. (fatal but allowing recovery during development) */"); this = NOTNULL(this->generic.next_icode); break; } if (OP(sos) != OP_PUSH) { fatalf("Procedure call - item below parameter was not a PUSHed DEF (it was a %s)\n", icode_name[OP(sos)]); //IMPAST *def = DEFTAG[sos->push.tag]; IMPAST *def = DEFUNIQUETAG[sos->push.unique_tag]; if (OP(def) != OP_DEF) { fatalf("Procedure call - item below parameter was not a DEF (it was a %s)\n", icode_name[OP(def)]); } } Push(sos); this = NOTNULL(this->generic.next_icode); break; case OP_CALL: if (stackdebug) {show_icode(this, stderr); fprintf(stderr, "\n");} { IMPAST *def = NULL; tos = NullPop(); // procedure descriptor, eg PUSH(def) (previously PROC(def)) if (tos == NULL) { if (stackdebug) debugf("/* stack.c OP_CALL TOS: stack was empty. (fatal but allowing recovery during development) */"); this = NOTNULL(this->generic.next_icode); break; } if (OP(tos) == OP_PUSH) { // This is how the procedure to be called was put on the stack. If not, we have an assumption error. //def = DEFTAG[tos->push.tag]; def = DEFUNIQUETAG[tos->push.unique_tag]; if (OP(def) != OP_DEF) { fatalf("CALL did not find a PUSHed DEF on the stack (got a %s)\n", icode_name[OP(def)]); } if (!IS_PROCEDURE(def)) { fatalf("CALL did not find a valid proc on the stack: tag=0x%04x ", tos->push.unique_tag); show_icode(def, stderr); fprintf(stderr, "\n"); } this->call.def = def; } else { fatalf("CALL did not find a PUSHed DEF on the stack (got a %s)\n", icode_name[OP(tos)]); } // ------------------------------------------ // If I need to reverse the formal parameter list, this is probably where I'll do it: (*TO DO*) // In hindsight it would have been better for the CALL ICode to set its parameter list to pairs // of rather than having them in separate lists that have // to be walked in parallel. I may in fact come back and revisit this decision *once everything // else is working correctly* but not right now while there is still some breakage. *TO DO* // Now pick up actual params from separate param stack: this->call.actual_params = NULL; IMPAST *formal_parameter_list = def->def.formal_params; IMPAST *fp = formal_parameter_list; this->call.formal_params = formal_parameter_list; for (;;) { if (fp == NULL) break; if (fp == NULL || OP(fp) == OP_FINISH) break; if (OP(fp) != OP_DEF) { fatalf("Bad formal parameter type %s\n", icode_name[OP(fp)]); } // copy over the same number of actual parameters as formal parameters... //debugf("Looking for parameter %s\n", fp->def.imp_id); IMPAST *ap = PopParam(); // Can be NULL if no actual params if (ap == NULL) { fatalf("Missing parameter!"); } else { ap->asspar.next_param = this->call.actual_params; // don't chain if no params } this->call.actual_params = ap; fp = fp->def.next_icode; } // ------------------------------------------ if (FORM(this->call.def) == F_ROUTINE) { // rt - just call. don't do anything with it. } else { // The type of the CALL ICode should be set to the result type of the function being called: copy_type(this, this->call.def); // The type of the result of a call of a recordmap is a recordname. Although this looks OK I'm relatively sure that CALL is getting // it wrong, maybe because it is looking for a F_NAME not F_MAP or F_FN // don't tell the world that this is actually a function... switch (FORM(this)) { case F_ROUTINE: set_form(this, F_VOID); // just in case. not currently enabled. break; case F_FN: // set type to whatever the return type of the function was: // (there are no array or name functions, so all F_FNs return scalars) set_form(this, F_SIMPLE); break; case F_MAP: // make sure the type of a F_MAP is set correctly so that when SELECT gets a field from a %map, it uses '->' rather than '.': set_form(this, F_NAME); break; case F_PREDICATE: set_form(this, F_SIMPLE); // (and the type should be set to T_INTEGER, but pass1 has ensured that we never need to use it.) break; default: break; } Push(this); // fn/map/pred - will be used in a parent expr } } this = NOTNULL(this->generic.next_icode); break; case OP_GOTO: if (stackdebug) {show_icode(this, stderr); fprintf(stderr, "\n");} this = NOTNULL(this->generic.next_icode); break; case OP_JUMP: if (stackdebug) {show_icode(this, stderr); fprintf(stderr, "\n");} this = NOTNULL(this->generic.next_icode); break; case OP_LABEL: if (stackdebug) {show_icode(this, stderr); fprintf(stderr, "\n");} this = NOTNULL(this->generic.next_icode); break; case OP_RETURN: if (stackdebug) {show_icode(this, stderr); fprintf(stderr, "\n");} this = NOTNULL(this->generic.next_icode); break; case OP_RESULT: if (stackdebug) {show_icode(this, stderr); fprintf(stderr, "\n");} // %fn %result = (not %result <- is not available) tos = Pop(); this->result.opd = NOTNULL(tos); copy_type(this, this->result.opd); this = NOTNULL(this->generic.next_icode); break; case OP_MAP: if (stackdebug) {show_icode(this, stderr); fprintf(stderr, "\n");} // %map %result == tos = Pop(); this->map.opd = NOTNULL(tos); copy_type(this, this->map.opd); this = NOTNULL(this->generic.next_icode); break; case OP_TRUE: if (stackdebug) {show_icode(this, stderr); fprintf(stderr, "\n");} // %predicate %true this = NOTNULL(this->generic.next_icode); break; case OP_FALSE: if (stackdebug) {show_icode(this, stderr); fprintf(stderr, "\n");} // %predicate %false this = NOTNULL(this->generic.next_icode); break; case OP_SJUMP: if (stackdebug) {show_icode(this, stderr); fprintf(stderr, "\n");} tos = Pop(); this->sjump.index = NOTNULL(tos); this = NOTNULL(this->generic.next_icode); break; case OP_DEFAULT: if (stackdebug) {show_icode(this, stderr); fprintf(stderr, "\n");} this = NOTNULL(this->generic.next_icode); break; case OP_SLABEL: if (stackdebug) {show_icode(this, stderr); fprintf(stderr, "\n");} { IMPAST *def; tos = Pop(); this->slabel.index = NOTNULL(tos); if (stackdebug) debugf("/* this->slabel.label = %d */\n", this->slabel.label); def = DEFTAG[this->slabel.label]; IMPAST **switcharray = def->def.switch_list;; if (switcharray == NULL) { if (stackdebug) debugf("/* OP_SLABEL error. switcharray is NULL. def is [%05d] */\n", def->def.seqno); } else { int lb = def->def.lower_bound; if (OP(tos) != OP_PUSHI) { // I think this relies on having folded - into ... // (and pass1 having converted any other const expression into a single const) fatalf("switch %s label is not a PUSHI (its a %s)\n", def->def.c_id, icode_name[OP(tos)]); } int this_index = NOTNULL(tos)->pushi.value; //fprintf(stderr, "switcharray[this_index (%d) - lb (%d)] = this (%p);\n", this_index, lb, this); switcharray[this_index-lb] = this; } } this = NOTNULL(this->generic.next_icode); break; case OP_DEFSW: if (stackdebug) {show_icode(this, stderr); fprintf(stderr, "\n");} { IMPAST *def = DEFTAG[this->slabel.label]; if (def == NULL || OP(def) != OP_DEF) fatalf("Bad DEFSW\n"); def->def.default_switch = this; } this = NOTNULL(this->generic.next_icode); break; case OP_ON: if (stackdebug) {show_icode(this, stderr); fprintf(stderr, "\n");} this = NOTNULL(this->generic.next_icode); break; case OP_EVENT: if (stackdebug) {show_icode(this, stderr); fprintf(stderr, "\n");} tos = NullPop(); if (tos) { this->event.extra = NOTNULL(tos); sos = NullPop(); if (sos) { this->event.subevent = NOTNULL(sos); } else { this->event.subevent = this->event.extra; this->event.extra = NULL; } } else { this->event.subevent = NULL; this->event.extra = NULL; } this = NOTNULL(this->generic.next_icode); break; case OP_FOR: if (stackdebug) {show_icode(this, stderr); fprintf(stderr, "\n");} { IMPAST *initial = Pop(); IMPAST *final = Pop(); IMPAST *increment = Pop(); IMPAST *control = Pop(); this->ifor.initial = initial; this->ifor.final = final; this->ifor.increment = increment; this->ifor.control = control; this = NOTNULL(this->generic.next_icode); } break; case OP_STOP: if (stackdebug) {show_icode(this, stderr); fprintf(stderr, "\n");} this = NOTNULL(this->generic.next_icode); break; case OP_LANG: if (stackdebug) {show_icode(this, stderr); fprintf(stderr, "\n");} this = NOTNULL(this->generic.next_icode); break; case OP_MONITOR: if (stackdebug) {show_icode(this, stderr); fprintf(stderr, "\n");} this = NOTNULL(this->generic.next_icode); break; case OP_DIAG: if (stackdebug) {show_icode(this, stderr); fprintf(stderr, "\n");} this = NOTNULL(this->generic.next_icode); DIAGNOSE = this->diag.data; break; case OP_CONTROL: if (stackdebug) {show_icode(this, stderr); fprintf(stderr, "\n");} /* (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') */ this = NOTNULL(this->generic.next_icode); CONTROL = this->control.data; break; // Ops still to be removed by pending block pass case OP_BEGIN: if (stackdebug) {show_icode(this, stderr); fprintf(stderr, "\n");} this = NOTNULL(this->generic.next_icode); break; case OP_END: if (stackdebug) {show_icode(this, stderr); fprintf(stderr, "\n");} this = this->generic.next_icode; // may come before NULL break; // Extended/derived AST operations: case ASTOP_PERMS: if (stackdebug) {show_icode(this, stderr); fprintf(stderr, "\n");} this = NOTNULL(this->generic.next_icode); break; case ASTOP_RECFMSPEC: if (stackdebug) {show_icode(this, stderr); fprintf(stderr, "\n");} DEFTAG[this->recfmspec.tag] = this; copy_type(this, this->recfmspec.def); // for listing support: this->recfmspec.line = NULL; this->recfmspec.def->def.line = NULL; this = NOTNULL(this->generic.next_icode); break; case ASTOP_DELETED: if (stackdebug) {show_icode(this, stderr); fprintf(stderr, "\n");} this = NOTNULL(this->generic.next_icode); break; case ASTOP_ADDRESS_OF: if (stackdebug) {show_icode(this, stderr); fprintf(stderr, "\n");} copy_type(this, this->address_of.opd); // TO DO: modify with _NAME this = NOTNULL(this->generic.next_icode); break; case ASTOP_INDIRECT_THROUGH: if (stackdebug) {show_icode(this, stderr); fprintf(stderr, "\n");} copy_type(this, this->indirect_through.opd); // TO DO: modify by removing _NAME this = NOTNULL(this->generic.next_icode); break; // and finally operations on stack data: case OP_SELECT: /*printf("BEFORE: ");*/ if (stackdebug) {show_icode(this, stderr); fprintf(stderr, "\n");} tos = Pop(); this->select.parent_record = NOTNULL(tos); // modified by record field index in tag field (but not a tag) if (this->select.recordformatdef == NULL) { //debugf("SELECT: this->select.recordformatdef was NULL. setting to this->select.format = 0x%04x also looking at this->select.parent_record->select.format = 0x%04x\n", this->select.format, this->select.parent_record->select.format); if (this->select.format != 0x0000 && DEFTAG[this->select.format] != NULL) { // belt this->select.recordformatdef = DEFTAG[this->select.format]; } else if (this->select.parent_record->select.format) { // and braces / and suspenders this->select.recordformatdef = DEFTAG[this->select.parent_record->select.format]; } else { //debugf("SELECT: could not find the recordformat!\n"); } } if (this->select.recordformatdef == NULL) { //debugf("SELECT: record is [%05d] field is <0x%04x> *** this->select.recordformatdef was NULL ***\n", this->select.parent_record->generic.seqno, this->select.fieldtag); } else if (this->select.recordformatdef->def.recordformat_field_list != NULL) { //debugf("SELECT: record is [%05d] recordformatdef is [%05d] recordformat field list is [%05d] field is <0x%04x>\n", this->select.parent_record->generic.seqno, this->select.recordformatdef->generic.seqno, this->select.recordformatdef->def.recordformat_field_list->generic.seqno, this->select.fieldtag); } else { //debugf("SELECT: record is [%05d] recordformatdef is [%05d] field is <0x%04x> *** this->select.recordformatdef->def.recordformat_field_list was NULL ***\n", this->select.parent_record->generic.seqno, this->select.recordformatdef->generic.seqno, this->select.fieldtag); } if (this->select.fielddef == NULL ) { if (this->select.recordformatdef != NULL) { IMPAST *fieldlist = this->select.recordformatdef->def.recordformat_field_list; int tag = this->select.fieldtag; int fieldnumber = 1; for (;;) { if (fieldlist == NULL) break; if (OP(fieldlist) == OP_DEF) { // /*if (stackdebug)*/ debugf("Examining field %d for tag=%d: ", fieldnumber, tag); if (fieldnumber == tag) { this->select.fielddef = fieldlist; // FOUND! return the DEF of the field. // Make sure that when a field is accessed from a %map, it uses '->' rather than '.': this->select.use_pointer = FORM(this->select.parent_record) == F_NAME || FORM(this->select.parent_record) == F_ARRAY_NAME || FORM(this->select.parent_record) == F_NAME_ARRAY_NAME || FORM(this->select.parent_record) == F_MAP; // /*if (stackdebug)*/ debugf("found: %s%s\n", this->select.fielddef->def.c_id, this->select.use_pointer ? "->" : "."); break; } fieldnumber += 1; } fieldlist = fieldlist->generic.next_icode; } } else /* debugf("this->select.recordformatdef was NULL\n")*/; // /*if (stackdebug)*/ if (this->select.fielddef == NULL) debugf("NOT found\n"); } else /*debugf("(already assigned) this->select.fielddef = [%05d]\n", this->select.fielddef->generic.seqno)*/; if (this->select.fielddef != NULL) { //debugf("Setting the type and form of the SELECT to that of the fielddef\n"); set_type(this, TYPE(this->select.fielddef)); set_form(this, FORM(this->select.fielddef)); if (TYPE(this->select.fielddef) == T_RECORD) { // the recordformat of the select object is the same as the recordformat of the field that was selected. this->select.format = this->select.fielddef->def.format; // this->select.fielddef->def.recordformatdef *should* contain the same thing... but apparently doesn't } } this->select.use_pointer = (FORM(this->select.parent_record) == F_NAME || FORM(this->select.parent_record) == F_ARRAY_NAME || FORM(this->select.parent_record) == F_NAME_ARRAY_NAME || FORM(this->select.parent_record) == F_MAP); // or use REQUIRES_AUTO_DEREFERENCE(this->select.parent_record) ? Push(this); /*printf("AFTER: ");*/ if (stackdebug) {show_icode(this, stderr); fprintf(stderr, "\n");} this = NOTNULL(this->generic.next_icode); break; case OP_ASSVAL: if (stackdebug) {show_icode(this, stderr); fprintf(stderr, "\n");} //tos = Pop(); sos = Pop(); tos = NullPop(); sos = NullPop(); if (tos == NULL || sos == NULL) { if (stackdebug) debugf("/* stack.c OP_ASSVAL TOS/SOS: stack was empty. (fatal but allowing recovery during development) */"); this = NOTNULL(this->generic.next_icode); break; } this->assval.dest = NOTNULL(sos); this->assval.source = NOTNULL(tos); copy_type(this, this->assval.dest); // type probably doesn't matter since ASSVAL tuple set_form(this, F_VOID); // is top-level, not a value that can be used elsewhere this = NOTNULL(this->generic.next_icode); break; case OP_ASSREF: if (stackdebug) {show_icode(this, stderr); fprintf(stderr, "\n");} tos = Pop(); sos = Pop(); this->assref.dest = NOTNULL(sos); this->assref.source = NOTNULL(tos); copy_type(this, this->assref.dest); // type probably doesn't matter since ASSREF tuple is top-level, not a value that can be used elsewhere this = NOTNULL(this->generic.next_icode); break; case OP_JAM: if (stackdebug) {show_icode(this, stderr); fprintf(stderr, "\n");} tos = Pop(); sos = Pop(); this->jam.source = NOTNULL(tos); this->jam.dest = NOTNULL(sos); copy_type(this, this->jam.dest); // type probably doesn't matter since JAM tuple is top-level, not a value that can be used elsewhere this = NOTNULL(this->generic.next_icode); break; case OP_NEGATE: if (stackdebug) {show_icode(this, stderr); fprintf(stderr, "\n");} tos = Pop(); // I could have sworn I was already doing this somewhere, but I can't find it, // and not doing it would explain the problem with %constreal r1 = -0.1234 // being output wrongly... Ah... it was only done in mknegate() in genc.c ... if (OP(tos) == OP_PUSHI) { // don't need to modify a string for integers IMPAST *num = new_icode(PUSHI); num->pushi.value = -tos->pushi.value; copy_type(num, tos); set_form(num, F_SIMPLE); Push(num); DISCARD(this); //fprintf(stderr, "Negated integer constant %ld -> %ld\n", tos->pushi.value, num->pushi.value); } else if (OP(tos) == OP_PUSHR) { // TO DO: string field too IMPAST *num = new_icode(PUSHR); if (tos->pushr.value < 0.0 || tos->pushr.str[0] == '-') { num->pushr.str = strdup(tos->pushr.str+1); } else { num->pushr.str = strdupf("-%s", tos->pushr.str); } num->pushr.exponent = tos->pushr.exponent; num->pushr.value = -tos->pushr.value; copy_type(num, tos); set_form(num, F_SIMPLE); Push(num); DISCARD(this); //fprintf(stderr, "Negated real constant %.16lf (\"%s\" %0d) -> %.16lf (\"%s\" %0d)\n", tos->pushr.value, tos->pushr.str, tos->pushr.exponent, num->pushr.value, num->pushr.str, num->pushr.exponent); } else { this->negate.opd = tos; copy_type(this, tos); set_form(this, F_SIMPLE); Push(this); //fprintf(stderr, "Negated expression [%05d] -> -[%05d]\n", tos->generic.seqno, this->negate.seqno); } // PS remember to check for overflow if param is largest neg number this = NOTNULL(this->generic.next_icode); break; case OP_LSH: if (stackdebug) {show_icode(this, stderr); fprintf(stderr, "\n");} tos = Pop(); sos = Pop(); this->lsh.opd2 = NOTNULL(tos); this->lsh.opd1 = NOTNULL(sos); Push(this); // bearing in mind what Acorn C called 'ANSI Surprise'! copy_type(this, this->lsh.opd1) /* (note: operands could be different) */; set_form(this, F_SIMPLE); this = NOTNULL(this->generic.next_icode); break; case OP_RSH: if (stackdebug) {show_icode(this, stderr); fprintf(stderr, "\n");} tos = Pop(); sos = Pop(); this->rsh.opd2 = NOTNULL(tos); this->rsh.opd1 = NOTNULL(sos); Push(this); copy_type(this, this->rsh.opd1) /* (note: operands could be different) */; set_form(this, F_SIMPLE); this = NOTNULL(this->generic.next_icode); break; case OP_AND: if (stackdebug) {show_icode(this, stderr); fprintf(stderr, "\n");} tos = Pop(); sos = Pop(); this->and.opd2 = NOTNULL(tos); this->and.opd1 = NOTNULL(sos); Push(this); copy_type(this, this->and.opd1) /* (note: operands could be different) */; set_form(this, F_SIMPLE); this = NOTNULL(this->generic.next_icode); break; case OP_OR: if (stackdebug) {show_icode(this, stderr); fprintf(stderr, "\n");} tos = NullPop(); sos = NullPop(); if (tos == NULL || sos == NULL) { if (stackdebug) debugf("/* stack.c OP_OR TOS/SOS: stack was empty. (fatal but allowing recovery during development) */"); this = NOTNULL(this->generic.next_icode); break; } this->or.opd2 = NOTNULL(tos); this->or.opd1 = NOTNULL(sos); Push(this); copy_type(this, this->or.opd1) /* (note: operands could be different) */; set_form(this, F_SIMPLE); this = NOTNULL(this->generic.next_icode); break; case OP_XOR: if (stackdebug) {show_icode(this, stderr); fprintf(stderr, "\n");} tos = Pop(); sos = Pop(); this->xor.opd2 = NOTNULL(tos); this->xor.opd1 = NOTNULL(sos); Push(this); copy_type(this, this->xor.opd1) /* (note: operands could be different) */; set_form(this, F_SIMPLE); this = NOTNULL(this->generic.next_icode); break; case OP_NOT: if (stackdebug) {show_icode(this, stderr); fprintf(stderr, "\n");} tos = Pop(); this->not.opd = NOTNULL(tos); Push(this); copy_type(this, this->mod.opd); set_form(this, F_SIMPLE); this = NOTNULL(this->generic.next_icode); break; case OP_ADD: if (stackdebug) {show_icode(this, stderr); fprintf(stderr, "\n");} tos = Pop(); sos = Pop(); this->add.opd2 = NOTNULL(tos); this->add.opd1 = NOTNULL(sos); Push(this); copy_type(this, this->add.opd1) /* (note: operands could be different) */; set_form(this, F_SIMPLE); this = NOTNULL(this->generic.next_icode); break; case OP_SUB: if (stackdebug) {show_icode(this, stderr); fprintf(stderr, "\n");} tos = Pop(); sos = Pop(); this->sub.opd2 = NOTNULL(tos); this->sub.opd1 = NOTNULL(sos); Push(this); copy_type(this, this->sub.opd1) /* (note: operands could be different) */; set_form(this, F_SIMPLE); this = NOTNULL(this->generic.next_icode); break; case OP_ADDA: if (stackdebug) {show_icode(this, stderr); fprintf(stderr, "\n");} tos = Pop(); sos = Pop(); this->adda.opd2 = NOTNULL(tos); this->adda.opd1 = NOTNULL(sos); Push(this); copy_type(this, this->adda.opd1); // remember opd1 is a pointer so it is the pointed-to type not the pointer type this = NOTNULL(this->generic.next_icode); break; case OP_SUBA: if (stackdebug) {show_icode(this, stderr); fprintf(stderr, "\n");} tos = Pop(); sos = Pop(); this->suba.opd2 = NOTNULL(tos); this->suba.opd1 = NOTNULL(sos); Push(this); copy_type(this, this->suba.opd1); this = NOTNULL(this->generic.next_icode); break; case OP_MUL: if (stackdebug) {show_icode(this, stderr); fprintf(stderr, "\n");} tos = Pop(); sos = Pop(); this->mul.opd2 = NOTNULL(tos); this->mul.opd1 = NOTNULL(sos); Push(this); copy_type(this, this->mul.opd1) /* (note: operands could be different) */; set_form(this, F_SIMPLE); this = NOTNULL(this->generic.next_icode); break; case OP_IEXP: if (stackdebug) {show_icode(this, stderr); fprintf(stderr, "\n");} tos = Pop(); sos = Pop(); this->iexp.opd2 = NOTNULL(tos); this->iexp.opd1 = NOTNULL(sos); Push(this); copy_type(this, this->iexp.opd1) /* (note: operands could be different) */; set_form(this, F_SIMPLE); this = NOTNULL(this->generic.next_icode); break; case OP_REXP: if (stackdebug) {show_icode(this, stderr); fprintf(stderr, "\n");} tos = Pop(); sos = Pop(); this->rexp.opd2 = NOTNULL(tos); this->rexp.opd1 = NOTNULL(sos); Push(this); copy_type(this, this->rexp.opd1) /* (note: operands could be different) */; set_form(this, F_SIMPLE); // exponent could be integer or real this = NOTNULL(this->generic.next_icode); break; case OP_QUOT: if (stackdebug) {show_icode(this, stderr); fprintf(stderr, "\n");} tos = Pop(); sos = Pop(); this->quot.opd2 = NOTNULL(tos); this->quot.opd1 = NOTNULL(sos); Push(this); copy_type(this, this->quot.opd1) /* (note: operands could be different) */; set_form(this, F_SIMPLE); this = NOTNULL(this->generic.next_icode); break; case OP_DIVIDE: if (stackdebug) {show_icode(this, stderr); fprintf(stderr, "\n");} tos = Pop(); sos = Pop(); this->divide.opd2 = NOTNULL(tos); this->divide.opd1 = NOTNULL(sos); Push(this); copy_type(this, this->divide.opd1) /* (note: operands could be different) */; set_form(this, F_SIMPLE); this = NOTNULL(this->generic.next_icode); break; case OP_MOD: if (stackdebug) {show_icode(this, stderr); fprintf(stderr, "\n");} // ABS (modulus), not REM (modulo) tos = Pop(); this->mod.opd = NOTNULL(tos); Push(this); copy_type(this, this->mod.opd); set_form(this, F_SIMPLE); this = NOTNULL(this->generic.next_icode); break; case OP_CONCAT: if (stackdebug) {show_icode(this, stderr); fprintf(stderr, "\n");} tos = Pop(); sos = Pop(); this->concat.opd2 = NOTNULL(tos); this->concat.opd1 = NOTNULL(sos); Push(this); // yeah, it's always going to be a string, though we do have to watch for capacity exceeded copy_type(this, this->concat.opd1); // unfortunately that just overwrote this->concat.maxstring, so now we have to repair it... this->concat.maxstring = 255; this = NOTNULL(this->generic.next_icode); break; case OP_DIM: if (stackdebug) {show_icode(this, stderr); fprintf(stderr, "\n");} { IMPAST *bounds_list = NULL; // (contrary to an earlier comment, *this* is the only source of array dimensionality - // it is *not* supplied by the OP_DEF code, in fact the code below has to update the // DEF node with the newly-discovered data:) // Prior to rewriting the block below, the lower bounds used in accessing array elements // were in the reverse order from the correspinding indices when an array access was printed. // The code below reverses the bounds list before storing it in the array's DEF data. // (Although at the time of writing this, I haven't yet coded the reversal of the bounds // in the output of the actual array declaration) IMPAST *last_bound; bounds_list = new_icode(BOUNDSPAIR); bounds_list->boundspair.opcode = OP_BOUNDSPAIR; tos = Pop(); sos = Pop(); //debugf("DIM1: sos = %p tos = %p ********* <----------------------------\n", sos, tos); bounds_list->boundspair.lb = NOTNULL(sos); bounds_list->boundspair.ub = NOTNULL(tos); bounds_list->boundspair.next_bound = NULL; last_bound = bounds_list; for (int dims = 0; dims < this->dim.dimens-1; dims++) { IMPAST *boundspair = new_icode(BOUNDSPAIR); boundspair->boundspair.opcode = OP_BOUNDSPAIR; // bounds of each dimension: tos = Pop(); sos = Pop(); //debugf("DIM2: sos = %p tos = %p ********* <----------------------------\n", sos, tos); boundspair->boundspair.lb = NOTNULL(sos); boundspair->boundspair.ub = NOTNULL(tos); boundspair->boundspair.next_bound = NULL; last_bound->boundspair.next_bound = boundspair; // append to end of list last_bound = boundspair; } IMPAST *def = LASTDEF; assert(def != NULL); assert(OP(def) == OP_DEF); // *** UPDATE THE DEF HERE *** (This is where the dimensions are set correctly // in an array declaration. The location in icode2ast.c where I thought it // should happen, on loading the icodes, did not work - dims were all set to '1'.) // debugf("stack.c: setting %s.dims = %d\n", def->def.c_id, this->dim.dimens); def->def.dims = this->dim.dimens; for (int num_arrays = 0; num_arrays < this->dim.arrays; num_arrays++) { def->def.bounds_list = bounds_list; def = def->def.previous_def; } this->dim.bounds_list = bounds_list; DISCARD(this); // one of the DISCARD calls without a matching Pop() } this = NOTNULL(this->generic.next_icode); break; // In filter.c we should probably conflate INDEX and ACCESS ops into // a single code, with the indices linked sequentially as we already // do for proc params. // *** NEW PLAN *** // stack has array, then pushed value, then INDEX. So when we pop the index, attach it to the array's index_list. Simple. case OP_INDEX: if (stackdebug) {show_icode(this, stderr); fprintf(stderr, "\n");} /* INDEX */ /* Array Index; */ { tos = Pop(); sos = Pop(); this->index.base = NOTNULL(sos); // ARRAY this->index.index = NOTNULL(tos); // index Push(sos); // base IMPAST *this_index = new_iast(ARRAYINDEX); this_index->array_index.index = tos; if (OP(sos) == OP_PUSH) { // <-- this is not working. The index is being added to the stack of indices, but the base array name is getting set to NULL :-/ // a simple array //debugf("Stack/PUSH: Set ARRAYINDEX to %p *****************************************************\n", DEFTAG[sos->push.tag]->def.index_list); this_index->array_index.array_base = sos; //this_index->array_index.next_index = DEFTAG[sos->push.tag]->def.index_list; this_index->array_index.next_index = DEFUNIQUETAG[sos->push.unique_tag]->def.index_list; DEFTAG[sos->push.tag]->def.index_list = this_index; } else if (OP(sos) == OP_SELECT) { // an array field in a record //debugf("Stack/SELECT: Set ARRAYINDEX to %p *****************************************************\n", sos->select.fielddef->def.index_list); this_index->array_index.next_index = sos->select.fielddef->def.index_list; sos->select.fielddef->def.index_list = this_index; } else { fatalf("OP_INDEX: SOS was not an OP_PUSH. (%s)\n", icode_name[OP(sos)]); } } copy_type(this, this->index.base); // we'll ignore INDEX and propogate the array type unchanged, handling it in ACCESS only. DISCARD(tos); // Leave the ARRAY on the stack but remove the INDEX this = NOTNULL(this)->index.next_icode; break; case OP_ACCESS: if (stackdebug) {show_icode(this, stderr); fprintf(stderr, "\n");} { tos = Pop(); // index sos = Pop(); // base if (OP(sos) == OP_PUSH) { // to handle nested indexes, what we need to do here is not set this to NULL, but // take the <#dims> items off this stack and assign them to the ARRAYINDEX object, // leaving behind any in excess of #dims. Problem example is "A[1] [A[2][3][4]] [5]" //warnf("ACCESS/PUSH: dims = %d\n", DEFTAG[sos->push.tag]->def.dims); IMPAST *chain = NULL; // this_index; for (int i = 0; i < DEFTAG[sos->push.tag]->def.dims-1; i++) { // move from def to arrayindex //IMPAST *next = DEFTAG[sos->push.tag]->def.index_list; IMPAST *next = DEFUNIQUETAG[sos->push.unique_tag]->def.index_list; // remove from DEF: DEFTAG[sos->push.tag]->def.index_list = (DEFTAG[sos->push.tag]->def.index_list)->array_index.next_index; // Add to local chain: next->array_index.next_index = chain; // add to end of chain chain = next; } IMPAST *this_index = new_iast(ARRAYINDEX); this_index->array_index.array_base = sos; this_index->array_index.index = tos; this_index->array_index.next_index = reverse_arrayindex_list(stderr, chain); //this_index->array_index.array_def = DEFTAG[sos->push.tag]; this_index->array_index.array_def = DEFUNIQUETAG[sos->push.unique_tag]; this_index->array_index.boundspair = this_index->array_index.array_def->def.bounds_list; copy_type(this_index, this_index->array_index.array_base); inherit_array_element_info(this_index); Push(this_index); DISCARD(sos); DISCARD(tos); } else if (OP(sos) == OP_SELECT) { //warnf("ACCESS/SELECT: dims = %d\n", sos->select.fielddef->def.dims); // sos->select.fielddef IMPAST *chain = NULL; // this_index; if (sos->select.fielddef == NULL) { debugf("/* stack.c: sos->select.fielddef is null. sos is [%05d] */\n", sos->select.seqno); } else { for (int i = 0; i < sos->select.fielddef->def.dims-1; i++) { // move from def to arrayindex IMPAST *next = sos->select.fielddef->def.index_list; // remove from DEF: sos->select.fielddef->def.index_list = (sos->select.fielddef->def.index_list)->array_index.next_index; // Add to local chain: next->array_index.next_index = chain; // add to end of chain chain = next; } IMPAST *this_index = new_iast(ARRAYINDEX); this_index->array_index.array_base = sos; this_index->array_index.index = tos; this_index->array_index.next_index = reverse_arrayindex_list(stderr, chain); this_index->array_index.array_base = sos; this_index->array_index.array_def = sos->select.fielddef; this_index->array_index.boundspair = this_index->array_index.array_def->def.bounds_list; copy_type(this_index, this_index->array_index.array_base); inherit_array_element_info(this_index); Push(this_index); DISCARD(sos); DISCARD(tos); } } else { fatalf("OP_ACCESS: SOS was not an OP_PUSH. (%s)\n", icode_name[OP(sos)]); } } // Replace the ARRAY and the INDEX with this more high-level-friendly array access which contains both the array base and a linked list of all the indices. this = NOTNULL(this->access.next_icode); break; case OP_BOUNDSPAIR: if (stackdebug) {show_icode(this, stderr); fprintf(stderr, "\n");} // fixed bounds of 1-D array // This comes before a DEF of an array. The def should attach these bounds and remove from list. tos = Pop(); sos = Pop(); //debugf("BOUNDSPAIR1: sos = %p tos = %p ********* <----------------------------\n", sos, tos); this->boundspair.lb = NOTNULL(sos); this->boundspair.ub = NOTNULL(tos); this->boundspair.next_bound = NULL; // 1-D so only one boundspair Push(this); this = NOTNULL(this)->boundspair.next_icode; break; case OP_RESOLVE: if (stackdebug) {show_icode(this, stderr); fprintf(stderr, "\n");} // r flag { /* String Resolution. Flag is a three bit number, the bits representing: 4 - conditional resolution. 2 - first destination present. 1 - second destination present. The resolution sets the condition code to true for successful resolution, and false for failure. The various operands are on the top of the stack. e.g. S -> A.(B).C @s@a@b@c r3 S -> A.(B) @s@a@b r1 stop if S -> (B).C @s@b@c r5k4s:4 */ if ((this->resolve.flags&1) != 0) { this->resolve.opd2 = Pop(); } else this->resolve.opd2 = NULL; this->resolve.match = Pop(); if ((this->resolve.flags&2) != 0) { this->resolve.opd1 = Pop(); } else this->resolve.opd1 = NULL; this->resolve.string = Pop(); // result is tested by BF or BT! if ((this->resolve.flags&4) != 0) { copy_type(this, this->resolve.match); // TO DO: more precise. Push(this); // otherwise a top-level statement like an assignment or // procedure call, so boolean result would be discarded. } this = NOTNULL(this)->resolve.next_icode; } break; case OP_START: if (stackdebug) {show_icode(this, stderr); fprintf(stderr, "\n");} this = NOTNULL(this)->start.next_icode; break; case OP_ALTALT: if (stackdebug) {show_icode(this, stderr); fprintf(stderr, "\n");} this = NOTNULL(this)->altalt.next_icode; break; case OP_FINISH: if (stackdebug) {show_icode(this, stderr); fprintf(stderr, "\n");} this = NOTNULL(this)->finish.next_icode; break; case OP_LINE: if (stackdebug) {show_icode(this, stderr); fprintf(stderr, "\n");} this = NOTNULL(this)->line.next_icode; break; // Ops still to be removed by pending block pass, if any: default: fatalf("Unhandled opcode in stack.c: %s (%05d 0x%08x)\n", icode_name[opcode], opcode, opcode); } // end of big switch statement if (stackbottom != next_free_stack_index) { // summarize what is on the stack. Don't alter anything. if (stackdebug) { fprintf(stderr, "{ STACK: %d items: ", next_free_stack_index-stackbottom); } for (int i = stackbottom; i < next_free_stack_index; i++) { opcode = OP(stack[i]); switch (opcode) { case OP_PUSHI: if (stackdebug) { fprintf(stderr, " %d", (int)stack[i]->pushi.value); } break; case OP_PUSHR: if (stackdebug) { fprintf(stderr, " %s", stack[i]->pushr.str); } break; case OP_PUSHS: if (stackdebug) { fprintf(stderr, " \"%s\"", stack[i]->pushs.string_value); } break; case OP_PUSH: { if (stack[i] == NULL) { fatalf("Yeah, this could definitely never happen.\n"); } else { int this_tag = stack[i]->push.tag; if (this_tag < 0 || this_tag > 0x100000) { if (stackdebug) { fprintf(stderr, " BAD TAG 0x%04x", stack[i]->push.tag); } } else if (DEFTAG[this_tag] == NULL) { if (stackdebug) { fprintf(stderr, "? PUSH tag=0x%04x\n", stack[i]->push.tag); } } else { if (stackdebug) { fprintf(stderr, " %s (tag=0x%04x)", DEFTAG[stack[i]->push.tag]->def.imp_id, stack[i]->push.tag); } } } } break; default: if (stackdebug) { fprintf(stderr, " %s??", icode_name[OP(stack[i])]); } } // end of switch statement for opcodes on the stack } // end of for-loop over stack items if (stackdebug) { if (used[debug_copy_of_this->generic.seqno]) fprintf(stderr, " USED"); fprintf(stderr, " }\n"); } } // end of 'if stack is not empty' (diagnostic-only code) } // end of while loop over program. return remove_used_codes(Program); } #endif // __STACK_C__ #ifdef NEVER // At this point we have the bounds of the array in a linked list, attached to // the DEF of the array. Depending on the order requesteded for output to C, // we can reverse this list here so it matches up with the list at the point // where the indexed array value is output. We reverse the bounds list once // only, here at the point of declaration, but we'll need to reverse the actual // index list every time an array element is accessed, in the OP_ACCESS node. // (one of them will be always be "if (reverse_index_order)" and the other will // be "if (!reverse_index_order)" because they end up in opposite order by // default due to the parsing and stack manipulation :-( ) // Unconditional reverse should put the output list into the same order as // original imp source declaration: //if (reverse_index_order) { this->def.bounds_list = reverse_list(this->def.bounds_list); //} #endif