/* argv[i] = ARGV[i] */ static void set_ARGV(int argc, char **argv, int i) { SYMTAB *st_p; CELL argi; register CELL *cp; st_p = insert("ARGV"); st_p->type = ST_ARRAY; Argv = st_p->stval.array = new_ARRAY(); no_leaks_array(Argv); argi.type = C_DOUBLE; argi.dval = 0.0; cp = array_find(st_p->stval.array, &argi, CREATE); cp->type = C_STRING; cp->ptr = (PTR) new_STRING(progname); /* ARGV[0] is set, do the rest The type of ARGV[1] ... should be C_MBSTRN because the user might enter numbers from the command line */ for (argi.dval = 1.0; i < argc; i++, argi.dval += 1.0) { cp = array_find(st_p->stval.array, &argi, CREATE); cp->type = C_MBSTRN; cp->ptr = (PTR) new_STRING(argv[i]); } ARGC->type = C_DOUBLE; ARGC->dval = argi.dval; }
void execute(INST * cdp, /* code ptr, start execution here */ CELL *sp, /* eval_stack pointer */ CELL *fp) /* frame ptr into eval_stack for user defined functions */ { /* some useful temporaries */ CELL *cp; int t; unsigned tu; /* save state for array loops via a stack */ ALOOP_STATE *aloop_state = (ALOOP_STATE *) 0; /* for moving the eval stack on deep recursion */ CELL *old_stack_base = 0; CELL *old_sp = 0; #ifdef DEBUG CELL *entry_sp = sp; #endif int force_exit = (end_start == 0); if (fp) { /* we are a function call, check for deep recursion */ if (sp > stack_danger) { /* change stacks */ old_stack_base = stack_base; old_sp = sp; stack_base = (CELL *) zmalloc(sizeof(CELL) * EVAL_STACK_SIZE); stack_danger = stack_base + DANGER; sp = stack_base; /* waste 1 slot for ANSI, actually large model msdos breaks in RET if we don't */ #ifdef DEBUG entry_sp = sp; #endif } else old_stack_base = (CELL *) 0; } while (1) { TRACE(("execute %s sp(%ld:%s)\n", da_op_name(cdp), (long) (sp - stack_base), da_type_name(sp))); switch ((cdp++)->op) { /* HALT only used by the disassemble now ; this remains so compilers don't offset the jump table */ case _HALT: case _STOP: /* only for range patterns */ #ifdef DEBUG if (sp != entry_sp + 1) bozo("stop0"); #endif return; case _PUSHC: inc_sp(); cellcpy(sp, (cdp++)->ptr); break; case _PUSHD: inc_sp(); sp->type = C_DOUBLE; sp->dval = *(double *) (cdp++)->ptr; break; case _PUSHS: inc_sp(); sp->type = C_STRING; sp->ptr = (cdp++)->ptr; string(sp)->ref_cnt++; break; case F_PUSHA: cp = (CELL *) cdp->ptr; if (cp != field) { if (nf < 0) split_field0(); if (!(cp >= NF && cp <= LAST_PFIELD)) { /* it is a real field $1, $2 ... If it is greater than $NF, we have to make sure it is set to "" so that (++|--) and g?sub() work right */ t = field_addr_to_index(cp); if (t > nf) { cp->type = C_STRING; cp->ptr = (PTR) & null_str; null_str.ref_cnt++; } } } /* fall thru */ case _PUSHA: case A_PUSHA: inc_sp(); sp->ptr = (cdp++)->ptr; break; case _PUSHI: /* put contents of next address on stack */ inc_sp(); cellcpy(sp, (cdp++)->ptr); break; case L_PUSHI: /* put the contents of a local var on stack, cdp->op holds the offset from the frame pointer */ inc_sp(); cellcpy(sp, fp + (cdp++)->op); break; case L_PUSHA: /* put a local address on eval stack */ inc_sp(); sp->ptr = (PTR) (fp + (cdp++)->op); break; case F_PUSHI: /* push contents of $i cdp[0] holds & $i , cdp[1] holds i */ inc_sp(); if (nf < 0) split_field0(); cp = (CELL *) cdp->ptr; t = (cdp + 1)->op; cdp += 2; if (t <= nf) cellcpy(sp, cp); else { /* an unset field */ sp->type = C_STRING; sp->ptr = (PTR) & null_str; null_str.ref_cnt++; } break; case NF_PUSHI: inc_sp(); if (nf < 0) split_field0(); cellcpy(sp, NF); break; case FE_PUSHA: if (sp->type != C_DOUBLE) cast1_to_d(sp); tu = d_to_index(sp->dval); if (tu && nf < 0) split_field0(); sp->ptr = (PTR) field_ptr((int) tu); if ((int) tu > nf) { /* make sure it is set to "" */ cp = (CELL *) sp->ptr; cell_destroy(cp); cp->type = C_STRING; cp->ptr = (PTR) & null_str; null_str.ref_cnt++; } break; case FE_PUSHI: if (sp->type != C_DOUBLE) cast1_to_d(sp); tu = d_to_index(sp->dval); if (nf < 0) split_field0(); if ((int) tu <= nf) { cellcpy(sp, field_ptr((int) tu)); } else { sp->type = C_STRING; sp->ptr = (PTR) & null_str; null_str.ref_cnt++; } break; case AE_PUSHA: /* top of stack has an expr, cdp->ptr points at an array, replace the expr with the cell address inside the array */ cp = array_find((ARRAY) (cdp++)->ptr, sp, CREATE); cell_destroy(sp); sp->ptr = (PTR) cp; break; case AE_PUSHI: /* top of stack has an expr, cdp->ptr points at an array, replace the expr with the contents of the cell inside the array */ cp = array_find((ARRAY) (cdp++)->ptr, sp, CREATE); cell_destroy(sp); cellcpy(sp, cp); break; case LAE_PUSHI: /* sp[0] is an expression cdp->op is offset from frame pointer of a CELL which has an ARRAY in the ptr field, replace expr with array[expr] */ if (fp != 0) { cp = array_find((ARRAY) fp[(cdp++)->op].ptr, sp, CREATE); cell_destroy(sp); cellcpy(sp, cp); } break; case LAE_PUSHA: /* sp[0] is an expression cdp->op is offset from frame pointer of a CELL which has an ARRAY in the ptr field, replace expr with & array[expr] */ if (fp != 0) { cp = array_find((ARRAY) fp[(cdp++)->op].ptr, sp, CREATE); cell_destroy(sp); sp->ptr = (PTR) cp; } break; case LA_PUSHA: /* cdp->op is offset from frame pointer of a CELL which has an ARRAY in the ptr field. Push this ARRAY on the eval stack */ if (fp != 0) { inc_sp(); sp->ptr = fp[(cdp++)->op].ptr; } break; case SET_ALOOP: { ALOOP_STATE *ap = ZMALLOC(ALOOP_STATE); size_t vector_size; ap->var = (CELL *) sp[-1].ptr; ap->base = ap->ptr = array_loop_vector((ARRAY) sp->ptr, &vector_size); ap->limit = ap->base + vector_size; sp -= 2; /* push onto aloop stack */ ap->link = aloop_state; aloop_state = ap; cdp += cdp->op; } break; case ALOOP: { ALOOP_STATE *ap = aloop_state; if (ap != 0 && (ap->ptr < ap->limit)) { cell_destroy(ap->var); ap->var->type = C_STRING; ap->var->ptr = (PTR) * ap->ptr++; cdp += cdp->op; } else { cdp++; } } break; case POP_AL: { /* finish up an array loop */ ALOOP_STATE *ap = aloop_state; if (ap != 0) { aloop_state = ap->link; while (ap->ptr < ap->limit) { free_STRING(*ap->ptr); ap->ptr++; } if (ap->base < ap->limit) { zfree(ap->base, ((unsigned) (ap->limit - ap->base) * sizeof(STRING *))); } ZFREE(ap); } } break; case _POP: cell_destroy(sp); sp--; break; case _ASSIGN: /* top of stack has an expr, next down is an address, put the expression in *address and replace the address with the expression */ /* don't propagate type C_MBSTRN */ if (sp->type == C_MBSTRN) check_strnum(sp); sp--; cell_destroy(((CELL *) sp->ptr)); cellcpy(sp, cellcpy(sp->ptr, sp + 1)); cell_destroy(sp + 1); break; case F_ASSIGN: /* assign to a field */ if (sp->type == C_MBSTRN) check_strnum(sp); sp--; field_assign((CELL *) sp->ptr, sp + 1); cell_destroy(sp + 1); cellcpy(sp, (CELL *) sp->ptr); break; case _ADD_ASG: if (sp->type != C_DOUBLE) cast1_to_d(sp); cp = (CELL *) (sp - 1)->ptr; if (cp->type != C_DOUBLE) cast1_to_d(cp); #ifdef SW_FP_CHECK /* specific to V7 and XNX23A */ clrerr(); #endif cp->dval += (sp--)->dval; #ifdef SW_FP_CHECK fpcheck(); #endif sp->type = C_DOUBLE; sp->dval = cp->dval; break; case _SUB_ASG: if (sp->type != C_DOUBLE) cast1_to_d(sp); cp = (CELL *) (sp - 1)->ptr; if (cp->type != C_DOUBLE) cast1_to_d(cp); #ifdef SW_FP_CHECK clrerr(); #endif cp->dval -= (sp--)->dval; #ifdef SW_FP_CHECK fpcheck(); #endif sp->type = C_DOUBLE; sp->dval = cp->dval; break; case _MUL_ASG: if (sp->type != C_DOUBLE) cast1_to_d(sp); cp = (CELL *) (sp - 1)->ptr; if (cp->type != C_DOUBLE) cast1_to_d(cp); #ifdef SW_FP_CHECK clrerr(); #endif cp->dval *= (sp--)->dval; #ifdef SW_FP_CHECK fpcheck(); #endif sp->type = C_DOUBLE; sp->dval = cp->dval; break; case _DIV_ASG: if (sp->type != C_DOUBLE) cast1_to_d(sp); cp = (CELL *) (sp - 1)->ptr; if (cp->type != C_DOUBLE) cast1_to_d(cp); #ifdef NOINFO_SIGFPE CHECK_DIVZERO(sp->dval); #endif #ifdef SW_FP_CHECK clrerr(); #endif cp->dval /= (sp--)->dval; #ifdef SW_FP_CHECK fpcheck(); #endif sp->type = C_DOUBLE; sp->dval = cp->dval; break; case _MOD_ASG: if (sp->type != C_DOUBLE) cast1_to_d(sp); cp = (CELL *) (sp - 1)->ptr; if (cp->type != C_DOUBLE) cast1_to_d(cp); #ifdef NOINFO_SIGFPE CHECK_DIVZERO(sp->dval); #endif cp->dval = fmod(cp->dval, (sp--)->dval); sp->type = C_DOUBLE; sp->dval = cp->dval; break; case _POW_ASG: if (sp->type != C_DOUBLE) cast1_to_d(sp); cp = (CELL *) (sp - 1)->ptr; if (cp->type != C_DOUBLE) cast1_to_d(cp); cp->dval = pow(cp->dval, (sp--)->dval); sp->type = C_DOUBLE; sp->dval = cp->dval; break; /* will anyone ever use these ? */ case F_ADD_ASG: if (sp->type != C_DOUBLE) cast1_to_d(sp); cp = (CELL *) (sp - 1)->ptr; cast1_to_d(cellcpy(&tc, cp)); #ifdef SW_FP_CHECK clrerr(); #endif tc.dval += (sp--)->dval; #ifdef SW_FP_CHECK fpcheck(); #endif sp->type = C_DOUBLE; sp->dval = tc.dval; field_assign(cp, &tc); break; case F_SUB_ASG: if (sp->type != C_DOUBLE) cast1_to_d(sp); cp = (CELL *) (sp - 1)->ptr; cast1_to_d(cellcpy(&tc, cp)); #ifdef SW_FP_CHECK clrerr(); #endif tc.dval -= (sp--)->dval; #ifdef SW_FP_CHECK fpcheck(); #endif sp->type = C_DOUBLE; sp->dval = tc.dval; field_assign(cp, &tc); break; case F_MUL_ASG: if (sp->type != C_DOUBLE) cast1_to_d(sp); cp = (CELL *) (sp - 1)->ptr; cast1_to_d(cellcpy(&tc, cp)); #ifdef SW_FP_CHECK clrerr(); #endif tc.dval *= (sp--)->dval; #ifdef SW_FP_CHECK fpcheck(); #endif sp->type = C_DOUBLE; sp->dval = tc.dval; field_assign(cp, &tc); break; case F_DIV_ASG: if (sp->type != C_DOUBLE) cast1_to_d(sp); cp = (CELL *) (sp - 1)->ptr; cast1_to_d(cellcpy(&tc, cp)); #ifdef NOINFO_SIGFPE CHECK_DIVZERO(sp->dval); #endif #ifdef SW_FP_CHECK clrerr(); #endif tc.dval /= (sp--)->dval; #ifdef SW_FP_CHECK fpcheck(); #endif sp->type = C_DOUBLE; sp->dval = tc.dval; field_assign(cp, &tc); break; case F_MOD_ASG: if (sp->type != C_DOUBLE) cast1_to_d(sp); cp = (CELL *) (sp - 1)->ptr; cast1_to_d(cellcpy(&tc, cp)); #ifdef NOINFO_SIGFPE CHECK_DIVZERO(sp->dval); #endif tc.dval = fmod(tc.dval, (sp--)->dval); sp->type = C_DOUBLE; sp->dval = tc.dval; field_assign(cp, &tc); break; case F_POW_ASG: if (sp->type != C_DOUBLE) cast1_to_d(sp); cp = (CELL *) (sp - 1)->ptr; cast1_to_d(cellcpy(&tc, cp)); tc.dval = pow(tc.dval, (sp--)->dval); sp->type = C_DOUBLE; sp->dval = tc.dval; field_assign(cp, &tc); break; case _ADD: sp--; if (TEST2(sp) != TWO_DOUBLES) cast2_to_d(sp); #ifdef SW_FP_CHECK clrerr(); #endif sp[0].dval += sp[1].dval; #ifdef SW_FP_CHECK fpcheck(); #endif break; case _SUB: sp--; if (TEST2(sp) != TWO_DOUBLES) cast2_to_d(sp); #ifdef SW_FP_CHECK clrerr(); #endif sp[0].dval -= sp[1].dval; #ifdef SW_FP_CHECK fpcheck(); #endif break; case _MUL: sp--; if (TEST2(sp) != TWO_DOUBLES) cast2_to_d(sp); #ifdef SW_FP_CHECK clrerr(); #endif sp[0].dval *= sp[1].dval; #ifdef SW_FP_CHECK fpcheck(); #endif break; case _DIV: sp--; if (TEST2(sp) != TWO_DOUBLES) cast2_to_d(sp); #ifdef NOINFO_SIGFPE CHECK_DIVZERO(sp[1].dval); #endif #ifdef SW_FP_CHECK clrerr(); #endif sp[0].dval /= sp[1].dval; #ifdef SW_FP_CHECK fpcheck(); #endif break; case _MOD: sp--; if (TEST2(sp) != TWO_DOUBLES) cast2_to_d(sp); #ifdef NOINFO_SIGFPE CHECK_DIVZERO(sp[1].dval); #endif sp[0].dval = fmod(sp[0].dval, sp[1].dval); break; case _POW: sp--; if (TEST2(sp) != TWO_DOUBLES) cast2_to_d(sp); sp[0].dval = pow(sp[0].dval, sp[1].dval); break; case _NOT: /* evaluates to 0.0 or 1.0 */ reswitch_1: switch (sp->type) { case C_NOINIT: sp->dval = 1.0; break; case C_DOUBLE: sp->dval = sp->dval != 0.0 ? 0.0 : 1.0; break; case C_FIELDWIDTHS: case C_STRING: sp->dval = string(sp)->len ? 0.0 : 1.0; free_STRING(string(sp)); break; case C_STRNUM: /* test as a number */ sp->dval = sp->dval != 0.0 ? 0.0 : 1.0; free_STRING(string(sp)); break; case C_MBSTRN: check_strnum(sp); goto reswitch_1; default: bozo("bad type on eval stack"); } sp->type = C_DOUBLE; break; case _TEST: /* evaluates to 0.0 or 1.0 */ reswitch_2: switch (sp->type) { case C_NOINIT: sp->dval = 0.0; break; case C_DOUBLE: sp->dval = sp->dval != 0.0 ? 1.0 : 0.0; break; case C_FIELDWIDTHS: case C_STRING: sp->dval = string(sp)->len ? 1.0 : 0.0; free_STRING(string(sp)); break; case C_STRNUM: /* test as a number */ sp->dval = sp->dval != 0.0 ? 1.0 : 0.0; free_STRING(string(sp)); break; case C_MBSTRN: check_strnum(sp); goto reswitch_2; default: bozo("bad type on eval stack"); } sp->type = C_DOUBLE; break; case _UMINUS: if (sp->type != C_DOUBLE) cast1_to_d(sp); sp->dval = -sp->dval; break; case _UPLUS: if (sp->type != C_DOUBLE) cast1_to_d(sp); break; case _CAT: { size_t len1, len2; char *str1, *str2; STRING *b; sp--; if (TEST2(sp) != TWO_STRINGS) cast2_to_s(sp); str1 = string(sp)->str; len1 = string(sp)->len; str2 = string(sp + 1)->str; len2 = string(sp + 1)->len; b = new_STRING0(len1 + len2); memcpy(b->str, str1, len1); memcpy(b->str + len1, str2, len2); free_STRING(string(sp)); free_STRING(string(sp + 1)); sp->ptr = (PTR) b; break; } case _PUSHINT: inc_sp(); sp->type = (short) (cdp++)->op; break; case _BUILTIN: case _PRINT: sp = (*(PF_CP) (cdp++)->ptr) (sp); break; case _POST_INC: cp = (CELL *) sp->ptr; if (cp->type != C_DOUBLE) cast1_to_d(cp); sp->type = C_DOUBLE; sp->dval = cp->dval; cp->dval += 1.0; break; case _POST_DEC: cp = (CELL *) sp->ptr; if (cp->type != C_DOUBLE) cast1_to_d(cp); sp->type = C_DOUBLE; sp->dval = cp->dval; cp->dval -= 1.0; break; case _PRE_INC: cp = (CELL *) sp->ptr; if (cp->type != C_DOUBLE) cast1_to_d(cp); sp->dval = cp->dval += 1.0; sp->type = C_DOUBLE; break; case _PRE_DEC: cp = (CELL *) sp->ptr; if (cp->type != C_DOUBLE) cast1_to_d(cp); sp->dval = cp->dval -= 1.0; sp->type = C_DOUBLE; break; case F_POST_INC: cp = (CELL *) sp->ptr; cellcpy(&tc, cp); cast1_to_d(&tc); sp->type = C_DOUBLE; sp->dval = tc.dval; tc.dval += 1.0; field_assign(cp, &tc); break; case F_POST_DEC: cp = (CELL *) sp->ptr; cellcpy(&tc, cp); cast1_to_d(&tc); sp->type = C_DOUBLE; sp->dval = tc.dval; tc.dval -= 1.0; field_assign(cp, &tc); break; case F_PRE_INC: cp = (CELL *) sp->ptr; cast1_to_d(cellcpy(sp, cp)); sp->dval += 1.0; field_assign(cp, sp); break; case F_PRE_DEC: cp = (CELL *) sp->ptr; cast1_to_d(cellcpy(sp, cp)); sp->dval -= 1.0; field_assign(cp, sp); break; case _JMP: cdp += cdp->op; break; case _JNZ: /* jmp if top of stack is non-zero and pop stack */ if (test(sp)) cdp += cdp->op; else cdp++; cell_destroy(sp); sp--; break; case _JZ: /* jmp if top of stack is zero and pop stack */ if (!test(sp)) cdp += cdp->op; else cdp++; cell_destroy(sp); sp--; break; case _LJZ: /* special jump for logical and */ /* this is always preceded by _TEST */ if (sp->dval == 0.0) { /* take jump, but don't pop stack */ cdp += cdp->op; } else { /* pop and don't jump */ sp--; cdp++; } break; case _LJNZ: /* special jump for logical or */ /* this is always preceded by _TEST */ if (sp->dval != 0.0) { /* take jump, but don't pop stack */ cdp += cdp->op; } else { /* pop and don't jump */ sp--; cdp++; } break; /* the relation operations */ /* compare() makes sure string ref counts are OK */ case _EQ: t = compare(--sp); sp->type = C_DOUBLE; sp->dval = t == 0 ? 1.0 : 0.0; break; case _NEQ: t = compare(--sp); sp->type = C_DOUBLE; sp->dval = t ? 1.0 : 0.0; break; case _LT: t = compare(--sp); sp->type = C_DOUBLE; sp->dval = t < 0 ? 1.0 : 0.0; break; case _LTE: t = compare(--sp); sp->type = C_DOUBLE; sp->dval = t <= 0 ? 1.0 : 0.0; break; case _GT: t = compare(--sp); sp->type = C_DOUBLE; sp->dval = t > 0 ? 1.0 : 0.0; break; case _GTE: t = compare(--sp); sp->type = C_DOUBLE; sp->dval = t >= 0 ? 1.0 : 0.0; break; case _MATCH0: /* does $0 match, the RE at cdp? */ inc_sp(); if (field->type >= C_STRING) { sp->type = C_DOUBLE; sp->dval = (REtest(string(field)->str, string(field)->len, cast_to_re((cdp++)->ptr)) ? 1.0 : 0.0); break /* the case */ ; } else { cellcpy(sp, field); /* and FALL THRU */ } case _MATCH1: /* does expr at sp[0] match RE at cdp */ if (sp->type < C_STRING) cast1_to_s(sp); t = REtest(string(sp)->str, string(sp)->len, cast_to_re((cdp++)->ptr)); free_STRING(string(sp)); sp->type = C_DOUBLE; sp->dval = t ? 1.0 : 0.0; break; case _MATCH2: /* does sp[-1] match sp[0] as re */ cast_to_RE(sp); if ((--sp)->type < C_STRING) cast1_to_s(sp); t = REtest(string(sp)->str, string(sp)->len, cast_to_re((sp + 1)->ptr)); free_STRING(string(sp)); no_leaks_re_ptr((sp + 1)->ptr); sp->type = C_DOUBLE; sp->dval = t ? 1.0 : 0.0; break; case A_LENGTH: sp--; sp->type = C_DOUBLE; sp->dval = (double) (((ARRAY) ((sp + 0)->ptr))->size); break; case A_TEST: /* entry : sp[0].ptr-> an array sp[-1] is an expression we compute (expression in array) */ sp--; cp = array_find((sp + 1)->ptr, sp, NO_CREATE); cell_destroy(sp); sp->type = C_DOUBLE; sp->dval = (cp != (CELL *) 0) ? 1.0 : 0.0; break; case A_DEL: /* sp[0].ptr -> array sp[-1] is an expr delete array[expr] */ array_delete(sp->ptr, sp - 1); cell_destroy(sp - 1); sp -= 2; break; case DEL_A: /* free all the array at once */ array_clear(sp->ptr); sp--; break; /* form a multiple array index */ case A_CAT: sp = array_cat(sp, (cdp++)->op); break; case _EXIT: if (sp->type != C_DOUBLE) cast1_to_d(sp); exit_code = d_to_i(sp->dval); sp--; /* fall thru */ case _EXIT0: if (force_exit) mawk_exit(exit_code); cdp = end_start; force_exit = 1; /* makes sure next exit exits */ if (begin_start) { free_codes("BEGIN", begin_start, begin_size); begin_start = 0; begin_size = 0; } if (main_start) { free_codes("MAIN", main_start, main_size); main_start = 0; main_size = 0; } sp = eval_stack - 1; /* might be in user function */ CLEAR_ALOOP_STACK(); /* ditto */ break; case _JMAIN: /* go from BEGIN code to MAIN code */ free_codes("BEGIN", begin_start, begin_size); begin_start = 0; begin_size = 0; cdp = main_start; break; case _OMAIN: if (!main_fin) open_main(); restart_label = cdp; cdp = next_label; break; case _NEXT: /* next might be inside an aloop -- clear stack */ CLEAR_ALOOP_STACK(); cdp = next_label; break; case _NEXTFILE: /* nextfile might be inside an aloop -- clear stack */ CLEAR_ALOOP_STACK(); FINsemi_close(main_fin); cdp = next_label; break; case OL_GL: { char *p; size_t len; if (!(p = FINgets(main_fin, &len))) { if (force_exit) mawk_exit(0); cdp = end_start; zfree(main_start, main_size); main_start = (INST *) 0; force_exit = 1; } else { set_field0(p, len); cdp = restart_label; rt_nr++; rt_fnr++; } } break; /* two kinds of OL_GL is a historical stupidity from working on a machine with very slow floating point emulation */ case OL_GL_NR: { char *p; size_t len; if (!(p = FINgets(main_fin, &len))) { if (force_exit) mawk_exit(0); cdp = end_start; zfree(main_start, main_size); main_start = (INST *) 0; force_exit = 1; } else { set_field0(p, len); cdp = restart_label; if (TEST2(NR) != TWO_DOUBLES) cast2_to_d(NR); NR->dval += 1.0; rt_nr++; FNR->dval += 1.0; rt_fnr++; } } break; case _RANGE: /* test a range pattern: pat1, pat2 { action } entry : cdp[0].op -- a flag, test pat1 if on else pat2 cdp[1].op -- offset of pat2 code from cdp cdp[2].op -- offset of action code from cdp cdp[3].op -- offset of code after the action from cdp cdp[4] -- start of pat1 code */ #define FLAG cdp[0].op #define PAT2 cdp[1].op #define ACTION cdp[2].op #define FOLLOW cdp[3].op #define PAT1 4 if (FLAG) /* test against pat1 */ { execute(cdp + PAT1, sp, fp); t = test(sp + 1); cell_destroy(sp + 1); if (t) FLAG = 0; else { cdp += FOLLOW; break; /* break the switch */ } } /* test against pat2 and then perform the action */ execute(cdp + PAT2, sp, fp); FLAG = test(sp + 1); cell_destroy(sp + 1); cdp += ACTION; break; /* function calls */ case _RET0: inc_sp(); sp->type = C_NOINIT; /* fall thru */ case _RET: #ifdef DEBUG if (sp != entry_sp + 1) bozo("ret"); #endif if (old_stack_base) /* reset stack */ { /* move the return value */ cellcpy(old_sp + 1, sp); cell_destroy(sp); zfree(stack_base, sizeof(CELL) * EVAL_STACK_SIZE); stack_base = old_stack_base; stack_danger = old_stack_base + DANGER; } /* return might be inside an aloop -- clear stack */ CLEAR_ALOOP_STACK(); return; case _CALL: /* cdp[0] holds ptr to "function block" cdp[1] holds number of input arguments */ { FBLOCK *fbp = (FBLOCK *) (cdp++)->ptr; int a_args = (cdp++)->op; /* actual number of args */ CELL *nfp = sp - a_args + 1; /* new fp for callee */ CELL *local_p = sp + 1; /* first local argument on stack */ char *type_p = 0; /* pts to type of an argument */ if (fbp->nargs) type_p = fbp->typev + a_args - 1; /* create space for locals */ t = fbp->nargs - a_args; /* t is number of locals */ while (t > 0) { t--; sp++; type_p++; sp->type = C_NOINIT; if ((type_p) != 0 && (*type_p == ST_LOCAL_ARRAY)) sp->ptr = (PTR) new_ARRAY(); } execute(fbp->code, sp, nfp); /* cleanup the callee's arguments */ /* putting return value at top of eval stack */ if ((type_p != 0) && (sp >= nfp)) { cp = sp + 1; /* cp -> the function return */ do { if (*type_p == ST_LOCAL_ARRAY) { if (sp >= local_p) { array_clear(sp->ptr); ZFREE((ARRAY) sp->ptr); } } else { cell_destroy(sp); } type_p--; sp--; } while (sp >= nfp); cellcpy(++sp, cp); cell_destroy(cp); } else sp++; /* no arguments passed */ } break; default: bozo("bad opcode"); } } }
int yylex(void) { register int c; token_lineno = lineno; #ifdef NO_LEAKS memset(&yylval, 0, sizeof(yylval)); #endif reswitch: switch (scan_code[NextUChar(c)]) { case 0: ct_ret(EOF); case SC_SPACE: goto reswitch; case SC_COMMENT: eat_comment(); goto reswitch; case SC_NL: lineno++; eat_nl(); ct_ret(NL); case SC_ESCAPE: while (scan_code[NextUChar(c)] == SC_SPACE) { ; /* empty */ }; if (c == '\n') { token_lineno = ++lineno; goto reswitch; } if (c == 0) ct_ret(EOF); un_next(); yylval.ival = '\\'; ct_ret(UNEXPECTED); case SC_SEMI_COLON: eat_nl(); ct_ret(SEMI_COLON); case SC_LBRACE: eat_nl(); brace_cnt++; ct_ret(LBRACE); case SC_PLUS: switch (next()) { case '+': yylval.ival = '+'; string_buff[0] = string_buff[1] = '+'; string_buff[2] = 0; ct_ret(INC_or_DEC); case '=': ct_ret(ADD_ASG); default: un_next(); ct_ret(PLUS); } case SC_MINUS: switch (next()) { case '-': yylval.ival = '-'; string_buff[0] = string_buff[1] = '-'; string_buff[2] = 0; ct_ret(INC_or_DEC); case '=': ct_ret(SUB_ASG); default: un_next(); ct_ret(MINUS); } case SC_COMMA: eat_nl(); ct_ret(COMMA); case SC_MUL: test1_ret('=', MUL_ASG, MUL); case SC_DIV: { static const int can_precede_div[] = {DOUBLE, STRING_, RPAREN, ID, D_ID, RE, RBOX, FIELD, GETLINE, INC_or_DEC, -1}; const int *p = can_precede_div; do { if (*p == current_token) { if (*p != INC_or_DEC) { test1_ret('=', DIV_ASG, DIV); } if (next() == '=') { un_next(); ct_ret(collect_RE()); } } } while (*++p != -1); ct_ret(collect_RE()); } case SC_MOD: test1_ret('=', MOD_ASG, MOD); case SC_POW: test1_ret('=', POW_ASG, POW); case SC_LPAREN: paren_cnt++; ct_ret(LPAREN); case SC_RPAREN: if (--paren_cnt < 0) { compile_error("extra ')'"); paren_cnt = 0; goto reswitch; } ct_ret(RPAREN); case SC_LBOX: ct_ret(LBOX); case SC_RBOX: ct_ret(RBOX); case SC_MATCH: string_buff[1] = '~'; string_buff[0] = 0; yylval.ival = 1; ct_ret(MATCH); case SC_EQUAL: test1_ret('=', EQ, ASSIGN); case SC_NOT: /* ! */ if ((c = next()) == '~') { string_buff[0] = '!'; string_buff[1] = '~'; string_buff[2] = 0; yylval.ival = 0; ct_ret(MATCH); } else if (c == '=') ct_ret(NEQ); un_next(); ct_ret(NOT); case SC_LT: /* '<' */ if (next() == '=') ct_ret(LTE); else un_next(); if (getline_flag) { getline_flag = 0; ct_ret(IO_IN); } else ct_ret(LT); case SC_GT: /* '>' */ if (print_flag && paren_cnt == 0) { print_flag = 0; /* there are 3 types of IO_OUT -- build the error string in string_buff */ string_buff[0] = '>'; if (next() == '>') { yylval.ival = F_APPEND; string_buff[1] = '>'; string_buff[2] = 0; } else { un_next(); yylval.ival = F_TRUNC; string_buff[1] = 0; } return current_token = IO_OUT; } test1_ret('=', GTE, GT); case SC_OR: if (next() == '|') { eat_nl(); ct_ret(OR); } else { un_next(); if (print_flag && paren_cnt == 0) { print_flag = 0; yylval.ival = PIPE_OUT; string_buff[0] = '|'; string_buff[1] = 0; ct_ret(IO_OUT); } else ct_ret(PIPE); } case SC_AND: if (next() == '&') { eat_nl(); ct_ret(AND); } else { un_next(); yylval.ival = '&'; ct_ret(UNEXPECTED); } case SC_QMARK: ct_ret(QMARK); case SC_COLON: ct_ret(COLON); case SC_RBRACE: if (--brace_cnt < 0) { compile_error("extra '}'"); eat_semi_colon(); brace_cnt = 0; goto reswitch; } if ((c = current_token) == NL || c == SEMI_COLON || c == SC_FAKE_SEMI_COLON || c == RBRACE) { /* if the brace_cnt is zero , we've completed a pattern action block. If the user insists on adding a semi-colon on the same line we will eat it. Note what we do below: physical law -- conservation of semi-colons */ if (brace_cnt == 0) eat_semi_colon(); eat_nl(); ct_ret(RBRACE); } /* supply missing semi-colon to statement that precedes a '}' */ brace_cnt++; un_next(); current_token = SC_FAKE_SEMI_COLON; return SEMI_COLON; case SC_DIGIT: case SC_DOT: { double d; int flag; if ((d = collect_decimal(c, &flag)) == 0.0) { if (flag) ct_ret(flag); else yylval.ptr = (PTR) & double_zero; } else if (d == 1.0) { yylval.ptr = (PTR) & double_one; } else { yylval.ptr = (PTR) ZMALLOC(double); *(double *) yylval.ptr = d; } ct_ret(DOUBLE); } case SC_DOLLAR: /* '$' */ { double d; int flag; while (scan_code[NextUChar(c)] == SC_SPACE) { ; /* empty */ }; if (scan_code[c] != SC_DIGIT && scan_code[c] != SC_DOT) { un_next(); ct_ret(DOLLAR); } /* compute field address at compile time */ if ((d = collect_decimal(c, &flag)) <= 0.0) { if (flag) ct_ret(flag); /* an error */ else yylval.cp = &field[0]; } else { int ival = d_to_I(d); double dval = (double) ival; if (dval != d) { compile_error("$%g is invalid field index", d); } yylval.cp = field_ptr(ival); } ct_ret(FIELD); } case SC_DQUOTE: return current_token = collect_string(); case SC_IDCHAR: /* collect an identifier */ { char *p = string_buff + 1; SYMTAB *stp; string_buff[0] = (char) c; while (1) { CheckStringSize(p); c = scan_code[NextUChar(*p++)]; if (c != SC_IDCHAR && c != SC_DIGIT) break; } un_next(); *--p = 0; switch ((stp = find(string_buff))->type) { case ST_NONE: /* check for function call before defined */ if (next() == '(') { stp->type = ST_FUNCT; stp->stval.fbp = (FBLOCK *) zmalloc(sizeof(FBLOCK)); stp->stval.fbp->name = stp->name; stp->stval.fbp->code = (INST *) 0; stp->stval.fbp->size = 0; yylval.fbp = stp->stval.fbp; current_token = FUNCT_ID; } else { yylval.stp = stp; current_token = current_token == DOLLAR ? D_ID : ID; } un_next(); break; case ST_NR: NR_flag = 1; stp->type = ST_VAR; /* FALLTHRU */ case ST_VAR: case ST_ARRAY: case ST_LOCAL_NONE: case ST_LOCAL_VAR: case ST_LOCAL_ARRAY: yylval.stp = stp; current_token = current_token == DOLLAR ? D_ID : ID; break; case ST_ENV: stp->type = ST_ARRAY; stp->stval.array = new_ARRAY(); load_environ(stp->stval.array); yylval.stp = stp; current_token = current_token == DOLLAR ? D_ID : ID; break; case ST_FUNCT: yylval.fbp = stp->stval.fbp; current_token = FUNCT_ID; break; case ST_KEYWORD: current_token = stp->stval.kw; break; case ST_BUILTIN: yylval.bip = stp->stval.bip; current_token = BUILTIN; break; case ST_LENGTH: yylval.bip = stp->stval.bip; /* check for length alone, this is an ugly hack */ while (scan_code[NextUChar(c)] == SC_SPACE) { ; /* empty */ }; un_next(); current_token = c == '(' ? BUILTIN : LENGTH; break; case ST_FIELD: yylval.cp = stp->stval.cp; current_token = FIELD; break; default: bozo("find returned bad st type"); } return current_token; } case SC_UNEXPECTED: yylval.ival = c & 0xff; ct_ret(UNEXPECTED); } return 0; /* never get here make lint happy */ }
void bi_vars_init() { register int i ; register SYMTAB *s ; for ( i = 0 ; i < NUM_BI_VAR ; i++ ) { if (!strcmp(bi_var_names[i], "PROCINFO")) continue; s = insert( bi_var_names[i] ) ; s->type = i <= 1 ? ST_NR : ST_VAR ; s->stval.cp = bi_vars + i ; /* bi_vars[i].type = 0 which is C_NOINIT */ } s = insert("ENVIRON") ; s->type = ST_ENV ; /* set defaults */ FILENAME->type = C_STRING ; FILENAME->ptr = (PTR) new_STRING( "" ) ; SORTTYPE->type = C_DOUBLE ; SORTTYPE->dval = 0.0 ; OFS->type = C_STRING ; OFS->ptr = (PTR) new_STRING( " " ) ; ORS->type = C_STRING ; ORS->ptr = (PTR) new_STRING( "\n" ) ; SUBSEP->type = C_STRING ; SUBSEP->ptr = (PTR) new_STRING( "\034" ) ; NF->type = C_DOUBLE ; NF->dval = 0.0 ; FIELDWIDTHS->type = C_DOUBLE ; FIELDWIDTHS->dval = 0.0 ; SAVEWIDTHS->type = C_DOUBLE ; SAVEWIDTHS->dval = 0.0 ; ARGIND->type = C_DOUBLE ; ARGIND->dval = 0.0 ; RS->type = C_STRING ; RS->ptr = (PTR) new_STRING("\n") ; /* rs_shadow already set */ RT->type = C_STRING ; RT->ptr = (PTR) new_STRING("\n") ; FS->type = C_STRING ; FS->ptr = (PTR) new_STRING(" ") ; /* fs_shadow is already set */ OFMT->type = C_STRING ; OFMT->ptr = (PTR) new_STRING("%.6g") ; CONVFMT->type = C_STRING ; CONVFMT->ptr = OFMT->ptr ; string(OFMT)->ref_cnt++ ; NR->type = FNR->type = C_DOUBLE ; s = insert("PROCINFO") ; s->type = ST_ARRAY; s->stval.array = new_ARRAY(); /* PROCINFO->stval.array = new_ARRAY(); */ /* dval is already 0.0 */ }
/* type checks a list of call arguments, returns a list of arguments whose type is still unknown */ static CA_REC * call_arg_check(FBLOCK * callee, CA_REC * entry_list, INST * start) { register CA_REC *q; CA_REC *exit_list = (CA_REC *) 0; check_progress = 0; /* loop : take q off entry_list test it if OK zfree(q) else put on exit_list */ while ((q = entry_list)) { entry_list = q->link; if (q->type == ST_NONE) { /* try to infer the type */ /* it might now be in symbol table */ if (q->sym_p->type == ST_VAR) { /* set type and patch */ q->type = CA_EXPR; start[q->call_offset + 1].ptr = (PTR) q->sym_p->stval.cp; } else if (q->sym_p->type == ST_ARRAY) { q->type = CA_ARRAY; start[q->call_offset].op = A_PUSHA; start[q->call_offset + 1].ptr = (PTR) q->sym_p->stval.array; } else { /* try to infer from callee */ switch (callee->typev[q->arg_num]) { case ST_LOCAL_VAR: q->type = CA_EXPR; q->sym_p->type = ST_VAR; q->sym_p->stval.cp = ZMALLOC(CELL); q->sym_p->stval.cp->type = C_NOINIT; start[q->call_offset + 1].ptr = (PTR) q->sym_p->stval.cp; break; case ST_LOCAL_ARRAY: q->type = CA_ARRAY; q->sym_p->type = ST_ARRAY; q->sym_p->stval.array = new_ARRAY(); start[q->call_offset].op = A_PUSHA; start[q->call_offset + 1].ptr = (PTR) q->sym_p->stval.array; break; } } } else if (q->type == ST_LOCAL_NONE) { /* try to infer the type */ if (*q->type_p == ST_LOCAL_VAR) { /* set type , don't need to patch */ q->type = CA_EXPR; } else if (*q->type_p == ST_LOCAL_ARRAY) { q->type = CA_ARRAY; start[q->call_offset].op = LA_PUSHA; /* offset+1 op is OK */ } else { /* try to infer from callee */ switch (callee->typev[q->arg_num]) { case ST_LOCAL_VAR: q->type = CA_EXPR; *q->type_p = ST_LOCAL_VAR; /* do not need to patch */ break; case ST_LOCAL_ARRAY: q->type = CA_ARRAY; *q->type_p = ST_LOCAL_ARRAY; start[q->call_offset].op = LA_PUSHA; break; } } } /* if we still do not know the type put on the new list else type check */ if (q->type == ST_NONE || q->type == ST_LOCAL_NONE) { q->link = exit_list; exit_list = q; } else { /* type known */ if (callee->typev[q->arg_num] == ST_LOCAL_NONE) callee->typev[q->arg_num] = (char) q->type; else if (q->type != callee->typev[q->arg_num]) compile_error("type error in arg(%d) in call to %s", q->arg_num + 1, callee->name); ZFREE(q); check_progress = 1; } } /* while */ return exit_list; }